From 50b706893fa7d10fbb5182cf27a60db872c938c2 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 4 Mar 2019 18:43:08 +0000 Subject: Fix execute splitting to work when constructors have constraints. Previously any constraints on constructors were just outright dropped when splitting the execute function in Lem generation. Now we get the constraints and type signature for each execute clause from the type given by Env.get_union_constructor, rather than by inferring the type of the pattern in each function clause. Currently this can still fail in the case where we have union U('x: Int), C1('x) = { ctor: {'y. C2('x, 'y), T('x, 'y)} } and val execute : forall 'z, C3('z). U('z) -> unit when C3 implies C1, and the body of an excute clause relies on the fact that C3 is stronger than C1, as each split function execute_ctor is only guaranteed to be constrained by some subset of C1. This seems unlikely to happen in practice though. Also fix a bug when binding P as int('T) against int('T) and similar cases, where the new type variable would cause the old type variable to become shadowed, but the constraint that the bound type variable and the old type variable are equal would not take this into account. --- src/rewrites.ml | 128 ++++++++++++++++++++++++++---------------------------- src/type_check.ml | 28 ++++++++---- 2 files changed, 82 insertions(+), 74 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index d8cb5a5d..bc9792ef 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2043,60 +2043,74 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) = let clauses, aux_funs = List.fold_left (fun (clauses, aux_funs) (FCL_aux (FCL_Funcl (id, pexp), fannot) as clause) -> - let pat, guard, exp, annot = destruct_pexp pexp in - match pat with - | P_aux (P_app (constr_id, args), pannot) -> - let argstup_typ = tuple_typ (List.map typ_of_pat args) in - let pannot' = swaptyp argstup_typ pannot in - let pat' = - match args with - | [arg] -> arg - | _ -> P_aux (P_tup args, pannot') - in - let pexp' = construct_pexp (pat', guard, exp, annot) in - let aux_fun_id = prepend_id (fun_name ^ "_") constr_id in - let aux_funcl = FCL_aux (FCL_Funcl (aux_fun_id, pexp'), pannot') in - begin - try - let aux_clauses = Bindings.find aux_fun_id aux_funs in - clauses, - Bindings.add aux_fun_id (aux_clauses @ [aux_funcl]) aux_funs - with Not_found -> - let argpats, argexps = List.split (List.mapi - (fun idx (P_aux (_,a) as pat) -> - let id = match pat_var pat with - | Some id -> id - | None -> mk_id ("arg" ^ string_of_int idx) - in - P_aux (P_id id, a), E_aux (E_id id, a)) - args) - in - let pexp = construct_pexp - (P_aux (P_app (constr_id, argpats), pannot), - None, - E_aux (E_app (aux_fun_id, argexps), annot), - annot) - in - clauses @ [FCL_aux (FCL_Funcl (id, pexp), fannot)], - Bindings.add aux_fun_id [aux_funcl] aux_funs - end - | _ -> clauses @ [clause], aux_funs) + let pat, guard, exp, annot = destruct_pexp pexp in + match pat with + | P_aux (P_app (constr_id, args), pannot) -> + let ctor_typq, ctor_typ = Env.get_union_id constr_id env in + let args = match args with [P_aux (P_tup args, _)] -> args | _ -> args in + let argstup_typ = tuple_typ (List.map typ_of_pat args) in + let pannot' = swaptyp argstup_typ pannot in + let pat' = + match args with + | [arg] -> arg + | _ -> P_aux (P_tup args, pannot') + in + let pexp' = construct_pexp (pat', guard, exp, annot) in + let aux_fun_id = prepend_id (fun_name ^ "_") constr_id in + let aux_funcl = FCL_aux (FCL_Funcl (aux_fun_id, pexp'), pannot') in + begin + try + let aux_clauses = Bindings.find aux_fun_id aux_funs in + clauses, + Bindings.add aux_fun_id (aux_clauses @ [(aux_funcl, ctor_typq, ctor_typ)]) aux_funs + with Not_found -> + let argpats, argexps = List.split (List.mapi + (fun idx (P_aux (_,a) as pat) -> + let id = match pat_var pat with + | Some id -> id + | None -> mk_id ("arg" ^ string_of_int idx) + in + P_aux (P_id id, a), E_aux (E_id id, a)) + args) + in + let pexp = construct_pexp + (P_aux (P_app (constr_id, argpats), pannot), + None, + E_aux (E_app (aux_fun_id, argexps), annot), + annot) + in + clauses @ [FCL_aux (FCL_Funcl (id, pexp), fannot)], + Bindings.add aux_fun_id [(aux_funcl, ctor_typq, ctor_typ)] aux_funs + end + | _ -> clauses @ [clause], aux_funs) ([], Bindings.empty) clauses in - let add_aux_def id funcls defs = - let env, args_typ, ret_typ = match funcls with - | FCL_aux (FCL_Funcl (_, pexp), _) :: _ -> + let add_aux_def id aux_funs defs = + let funcls = List.map (fun (fcl, _, _) -> fcl) aux_funs in + let env, quants, args_typ, ret_typ = match aux_funs with + | (FCL_aux (FCL_Funcl (_, pexp), _), ctor_typq, ctor_typ) :: _ -> let pat, _, exp, _ = destruct_pexp pexp in - env_of exp, typ_of_pat pat, typ_of exp + let ctor_quants args_typ = + List.filter (fun qi -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ args_typ)) + (quant_items ctor_typq) + in + begin match ctor_typ with + | Typ_aux (Typ_fn ([Typ_aux (Typ_exist (kopts, nc, args_typ), _)], _, _), _) -> + env_of exp, ctor_quants args_typ @ List.map mk_qi_kopt kopts @ [mk_qi_nc nc], args_typ, typ_of exp + | Typ_aux (Typ_fn ([args_typ], _, _), _) -> env_of exp, ctor_quants args_typ, args_typ, typ_of exp + | _ -> + raise (Reporting.err_unreachable l __POS__ + ("Union constructor has non-function type: " ^ string_of_typ ctor_typ)) + end | _ -> raise (Reporting.err_unreachable l __POS__ - "rewrite_split_fun_constr_pats: empty auxiliary function") + "rewrite_split_fun_constr_pats: empty auxiliary function") in let eff = List.fold_left - (fun eff (FCL_aux (FCL_Funcl (_, pexp), _)) -> - let _, _, exp, _ = destruct_pexp pexp in - union_effects eff (effect_of exp)) - no_effect funcls + (fun eff (FCL_aux (FCL_Funcl (_, pexp), _)) -> + let _, _, exp, _ = destruct_pexp pexp in + union_effects eff (effect_of exp)) + no_effect funcls in let fun_typ = (* Because we got the argument type from a pattern we need to @@ -2107,27 +2121,9 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) = | _ -> function_typ [args_typ] ret_typ eff in - let quant_new_kopts qis = - let quant_kopts = List.fold_left KOptSet.union KOptSet.empty (List.map kopts_of_quant_item qis) in - let typ_kopts = kopts_of_typ fun_typ in - let new_kopts = KOptSet.diff typ_kopts quant_kopts in - List.map mk_qi_kopt (KOptSet.elements new_kopts) - in - let typquant = match typquant with - | TypQ_aux (TypQ_tq qis, l) -> - let qis = - List.filter - (fun qi -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ fun_typ)) - qis - @ quant_new_kopts qis - in - TypQ_aux (TypQ_tq qis, l) - | _ -> - TypQ_aux (TypQ_tq (List.map mk_qi_kopt (KOptSet.elements (kopts_of_typ fun_typ))), l) - in let val_spec = VS_aux (VS_val_spec - (mk_typschm typquant fun_typ, id, (fun _ -> None), false), + (mk_typschm (mk_typquant quants) fun_typ, id, (fun _ -> None), false), (Parse_ast.Unknown, empty_tannot)) in let fundef = FD_aux (FD_function (r_o, t_o, e_o, funcls), fdannot) in diff --git a/src/type_check.ml b/src/type_check.ml index c1689a82..603052b5 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -432,6 +432,7 @@ module Env : sig val get_typ_var_loc : kid -> t -> Ast.l val get_typ_vars : t -> kind_aux KBindings.t val get_typ_var_locs : t -> Ast.l KBindings.t + val add_typ_var_shadow : l -> kinded_id -> t -> t * kid option val add_typ_var : l -> kinded_id -> t -> t val get_ret_typ : t -> typ option val add_ret_typ : typ -> t -> t @@ -656,10 +657,9 @@ end = struct ^ " with " ^ Util.string_of_list ", " string_of_n_constraint env.constraints) let get_typ_synonym id env = - begin match Bindings.find_opt id env.typ_synonyms with + match Bindings.find_opt id env.typ_synonyms with | Some (typq, arg) -> mk_synonym typq arg | None -> raise Not_found - end let rec expand_constraint_synonyms env (NC_aux (aux, l) as nc) = typ_debug ~level:2 (lazy ("Expanding " ^ string_of_n_constraint nc)); @@ -1208,7 +1208,7 @@ end = struct with | Not_found -> Unbound - let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env = + let add_typ_var_shadow l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env = if KBindings.mem v env.typ_vars then begin let n = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 in let s_l, s_k = KBindings.find v env.typ_vars in @@ -1218,13 +1218,15 @@ end = struct constraints = List.map (constraint_subst v (arg_kopt (mk_kopt s_k s_v))) env.constraints; typ_vars = KBindings.add v (l, k) (KBindings.add s_v (s_l, s_k) env.typ_vars); shadow_vars = KBindings.add v (n + 1) env.shadow_vars - } + }, Some s_v end else begin typ_print (lazy (adding ^ "type variable " ^ string_of_kid v ^ " : " ^ string_of_kind_aux k)); - { env with typ_vars = KBindings.add v (l, k) env.typ_vars } + { env with typ_vars = KBindings.add v (l, k) env.typ_vars }, None end + let add_typ_var l kopt env = fst (add_typ_var_shadow l kopt env) + let get_constraints env = env.constraints let add_constraint constr env = @@ -3133,6 +3135,8 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) end | P_app (f, pats) when Env.is_union_constructor f env -> begin + (* Treat Ctor((p, x)) the same as Ctor(p, x) *) + let pats = match pats with [P_aux (P_tup pats, _)] -> pats | _ -> pats in let (typq, ctor_typ) = Env.get_union_id f env in let quants = quant_items typq in let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with @@ -3152,6 +3156,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) typ_raise env l (Err_unresolved_quants (f, quants', Env.get_locals env, Env.get_constraints env)) else (); let ret_typ' = subst_unifiers unifiers ret_typ in + let arg_typ', env = bind_existential l None arg_typ' env in let tpats, env, guards = try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with | Invalid_argument _ -> typ_error env l "Union constructor pattern arguments have incorrect length" @@ -3325,15 +3330,20 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = | _ -> typ_error env l ("Couldn't infer type of pattern " ^ string_of_pat pat) and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) as typ) = + typ_print (lazy (Util.("Binding type pattern " |> yellow |> clear) ^ string_of_typ_pat typ_pat ^ " to " ^ string_of_typ typ)); match typ_pat_aux, typ_aux with | TP_wild, _ -> env | TP_var kid, _ -> begin match typ_nexps typ, typ_constraints typ with | [nexp], [] -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env) + let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_int kid) env in + let nexp = match shadow with Some s_v -> nexp_subst kid (arg_nexp (nvar s_v)) nexp | None -> nexp in + Env.add_constraint (nc_eq (nvar kid) nexp) env | [], [nc] -> - Env.add_constraint (nc_and (nc_or (nc_not nc) (nc_var kid)) (nc_or nc (nc_not (nc_var kid)))) (Env.add_typ_var l (mk_kopt K_bool kid) env) + let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_bool kid) env in + let nexp = match shadow with Some s_v -> constraint_subst kid (arg_bool (nc_var s_v)) nc | None -> nc in + Env.add_constraint (nc_and (nc_or (nc_not nc) (nc_var kid)) (nc_or nc (nc_not (nc_var kid)))) env | [], [] -> typ_error env l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to") | _, _ -> @@ -3346,7 +3356,9 @@ and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_au match typ_pat_aux, typ_arg_aux with | TP_wild, _ -> env | TP_var kid, A_nexp nexp -> - Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env) + let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_int kid) env in + let nexp = match shadow with Some s_v -> nexp_subst kid (arg_nexp (nvar s_v)) nexp | None -> nexp in + Env.add_constraint (nc_eq (nvar kid) nexp) env | _, A_typ typ -> bind_typ_pat env typ_pat typ | _, A_order _ -> typ_error env l "Cannot bind type pattern against order" | _, _ -> typ_error env l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat) -- cgit v1.2.3 From 15872b4c48d932a920ea6d22b69889ff32f6a446 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 4 Mar 2019 20:14:39 +0000 Subject: Fix aarch64_small test XML for jenkins Rename rewrite_split_fun_constr_pats to rewrite_split_fun_ctor_pats as constr is commonly used as an abbreviation for constraint rather than constructor, and add a more descriptive comment. --- src/rewrites.ml | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index bc9792ef..23e22769 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2025,7 +2025,6 @@ let is_funcl_rec (FCL_aux (FCL_Funcl (id, pexp), _)) = E_app_infix (e1, f, e2))) } exp) - let pat_var (P_aux (paux, a)) = let env = env_of_annot a in let is_var id = @@ -2035,9 +2034,28 @@ let pat_var (P_aux (paux, a)) = | (P_as (_, id) | P_id id) when is_var id -> Some id | _ -> None -(* Split out function clauses for individual union constructor patterns - (e.g. AST nodes) into auxiliary functions. Used for the execute function. *) -let rewrite_split_fun_constr_pats fun_name env (Defs defs) = +(** Split out function clauses for individual union constructor patterns + (e.g. AST nodes) into auxiliary functions. Used for the execute function. + + For example: + + function execute(Instr(x, y)) = ... + + would become + + function execute_Instr(x, y) = ... + + function execute(Instr(x, y)) = execute_C(x, y) + + This is actually a slightly complex rewrite than it first appears, because + we have to deal with cases where the AST type has constraints in various + places, e.g. + + union ast('x: Int), 0 <= 'x < 32 = { + Instr : {'r, 'r in {32, 64}. (int('x), bits('r))} + } + *) +let rewrite_split_fun_ctor_pats fun_name env (Defs defs) = let rewrite_fundef typquant (FD_aux (FD_function (r_o, t_o, e_o, clauses), ((l, _) as fdannot))) = let rec_clauses, clauses = List.partition is_funcl_rec clauses in let clauses, aux_funs = @@ -2045,8 +2063,8 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) = (fun (clauses, aux_funs) (FCL_aux (FCL_Funcl (id, pexp), fannot) as clause) -> let pat, guard, exp, annot = destruct_pexp pexp in match pat with - | P_aux (P_app (constr_id, args), pannot) -> - let ctor_typq, ctor_typ = Env.get_union_id constr_id env in + | P_aux (P_app (ctor_id, args), pannot) -> + let ctor_typq, ctor_typ = Env.get_union_id ctor_id env in let args = match args with [P_aux (P_tup args, _)] -> args | _ -> args in let argstup_typ = tuple_typ (List.map typ_of_pat args) in let pannot' = swaptyp argstup_typ pannot in @@ -2056,7 +2074,7 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) = | _ -> P_aux (P_tup args, pannot') in let pexp' = construct_pexp (pat', guard, exp, annot) in - let aux_fun_id = prepend_id (fun_name ^ "_") constr_id in + let aux_fun_id = prepend_id (fun_name ^ "_") ctor_id in let aux_funcl = FCL_aux (FCL_Funcl (aux_fun_id, pexp'), pannot') in begin try @@ -2074,7 +2092,7 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) = args) in let pexp = construct_pexp - (P_aux (P_app (constr_id, argpats), pannot), + (P_aux (P_app (ctor_id, argpats), pannot), None, E_aux (E_app (aux_fun_id, argexps), annot), annot) @@ -5071,7 +5089,7 @@ let rewrite_defs_lem = [ (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", rewrite_defs_nexp_ids); ("fix_val_specs", rewrite_fix_val_specs); - ("split_execute", rewrite_split_fun_constr_pats "execute"); + ("split_execute", rewrite_split_fun_ctor_pats "execute"); ("recheck_defs", recheck_defs); ("exp_lift_assign", rewrite_defs_exp_lift_assign); (* ("constraint", rewrite_constraint); *) @@ -5114,7 +5132,7 @@ let rewrite_defs_coq = [ (* ("register_ref_writes", rewrite_register_ref_writes); *) ("nexp_ids", rewrite_defs_nexp_ids); ("fix_val_specs", rewrite_fix_val_specs); - ("split_execute", rewrite_split_fun_constr_pats "execute"); + ("split_execute", rewrite_split_fun_ctor_pats "execute"); ("minimise_recursive_functions", minimise_recursive_functions); ("recheck_defs", recheck_defs); ("exp_lift_assign", rewrite_defs_exp_lift_assign); @@ -5197,7 +5215,7 @@ let rewrite_defs_c = [ ("simple_assignments", rewrite_simple_assignments); ("remove_vector_concat", rewrite_defs_remove_vector_concat); ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); - ("split_execute", if_separate (rewrite_split_fun_constr_pats "execute")); + ("split_execute", if_separate (rewrite_split_fun_ctor_pats "execute")); ("exp_lift_assign", rewrite_defs_exp_lift_assign); ("merge_function_clauses", merge_funcls); ("recheck_defs", fun _ -> Optimize.recheck) -- cgit v1.2.3 From 8718a39778d4c673ceea1c7f9bb219b29788ebae Mon Sep 17 00:00:00 2001 From: Alasdair Date: Tue, 5 Mar 2019 03:09:16 +0000 Subject: Additional optimizations for C compilation --- src/c_backend.ml | 47 +++++++++++++++++++++++++++++++++++++++++++++++ src/sail.ml | 11 ++++++++++- src/specialize.ml | 11 +++++++++++ 3 files changed, 68 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index ab388223..d14b5391 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -174,6 +174,7 @@ let rec ctyp_of_typ ctx typ = begin match destruct_range Env.empty typ with | None -> assert false (* Checked if range type in guard *) | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in match nexp_simp n, nexp_simp m with | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> @@ -483,6 +484,38 @@ let analyze_primop' ctx id args typ = | _ -> no_change end + | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) @@ -568,6 +601,14 @@ let analyze_primop' ctx id args typ = | _ -> no_change end + | "sail_signed", [AV_C_fragment (frag, vtyp, _)] -> + begin match destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> begin match destruct_range Env.empty typ with | None -> no_change @@ -592,6 +633,12 @@ let analyze_primop' ctx id args typ = | _ -> no_change end + | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true)); + AV_C_fragment (hi, _, CT_fint 64); + AV_C_fragment (lo, _, CT_fint 64); + AV_C_fragment (ys, _, CT_fbits (m, true))] -> + AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) + | "undefined_bool", _ -> AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) diff --git a/src/sail.ml b/src/sail.ml index 2a15f26e..eb81a0ee 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -67,6 +67,7 @@ let opt_print_cgen = ref false let opt_memo_z3 = ref false let opt_sanity = ref false let opt_includes_c = ref ([]:string list) +let opt_specialize_c = ref false let opt_libs_lem = ref ([]:string list) let opt_libs_coq = ref ([]:string list) let opt_file_arguments = ref ([]:string list) @@ -151,6 +152,9 @@ let options = Arg.align ([ ( "-c_extra_args", Arg.String (fun args -> C_backend.opt_extra_arguments := Some args), " supply extra argument to every generated C function call" ); + ( "-c_specialize", + Arg.Set opt_specialize_c, + " specialize integer arguments in C output"); ( "-elf", Arg.String (fun elf -> opt_process_elf := Some elf), " process an ELF file so that it can be executed by compiled C code"); @@ -422,7 +426,12 @@ let main() = then let ast_c = rewrite_ast_c type_envs ast in let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in - (* let ast_c, type_envs = Specialize.(specialize' 2 int_specialization_with_externs ast_c type_envs) in *) + let ast_c, type_envs = + if !opt_specialize_c then + Specialize.(specialize' 2 int_specialization ast_c type_envs) + else + ast_c, type_envs + in let output_chan = match !opt_file_out with Some f -> open_out (f ^ ".c") | None -> stdout in Util.opt_warnings := true; C_backend.compile_ast (C_backend.initial_ctx type_envs) output_chan (!opt_includes_c) ast_c; diff --git a/src/specialize.ml b/src/specialize.ml index 19c5df7a..a487fc2f 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -52,6 +52,8 @@ open Ast open Ast_util open Rewriter +let opt_ddump_spec_ast = ref None + let is_typ_ord_arg = function | A_aux (A_typ _, _) -> true | A_aux (A_order _, _) -> true @@ -565,6 +567,15 @@ let specialize_ids spec ids ast = (1, ast) (IdSet.elements ids) in let ast = reorder_typedefs ast in + begin match !opt_ddump_spec_ast with + | Some (f, i) -> + let filename = f ^ "_spec_" ^ string_of_int i ^ ".sail" in + let out_chan = open_out filename in + Pretty_print_sail.pp_defs out_chan ast; + close_out out_chan; + opt_ddump_spec_ast := Some (f, i + 1) + | None -> () + end; let ast, _ = Type_error.check Type_check.initial_env ast in let ast = List.fold_left (fun ast id -> rewrite_polymorphic_calls spec id ast) ast (IdSet.elements ids) -- cgit v1.2.3 From 080205194a861882918e10de7680201c64f99142 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 5 Mar 2019 12:13:53 +0000 Subject: Coq: output type-level Int definitions --- src/pretty_print_coq.ml | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 42780012..734e3c02 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -2089,6 +2089,7 @@ let rec doc_range ctxt (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ctxt ir1) ^^ comma ^^ (doc_range ctxt ir2) *) +(* TODO: check use of empty_ctxt below *) let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with | TD_abbrev(id,typq,A_aux (A_typ typ, _)) -> let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in @@ -2097,6 +2098,14 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with doc_typquant_items empty_ctxt parens typq; colon; string "Type"]) (doc_typschm empty_ctxt false typschm) ^^ dot + | TD_abbrev(id,typq,A_aux (A_nexp nexp,_)) -> + let idpp = doc_id_type id in + doc_op coloneq + (separate space [string "Definition"; idpp; + doc_typquant_items empty_ctxt parens typq; + colon; string "Z"]) + (doc_nexp empty_ctxt nexp) ^^ dot ^^ hardline ^^ + separate space [string "Hint Unfold"; idpp; colon; string "sail."] | TD_abbrev _ -> empty (* TODO? *) | TD_bitfield _ -> empty (* TODO? *) | TD_record(id,typq,fs,_) -> -- cgit v1.2.3 From 8e8684e97e063912e53fdcade132051f09304d55 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 5 Mar 2019 12:14:09 +0000 Subject: Coq: some debugging messages --- src/pretty_print_coq.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 734e3c02..5dab3b8e 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1484,6 +1484,7 @@ let doc_exp, doc_let = Util.list_mapi (fun i exp -> mk_id ("#coq#arg" ^ string_of_int i), general_typ_of exp) args in + let () = debug ctxt (lazy (" arg types: " ^ String.concat ", " (List.map (fun (_,ty) -> string_of_typ ty) dummy_args))) in let dummy_exp = mk_exp (E_app (f, List.map (fun (id,_) -> mk_exp (E_id id)) dummy_args)) in let dummy_env = List.fold_left (fun env (id,typ) -> Env.add_local id (Immutable,typ) env) env dummy_args in let inst_exp = @@ -1498,7 +1499,9 @@ let doc_exp, doc_let = type inferred when we know the target type. TODO: there are probably some edge cases where this won't pick up a need to cast. *) - | exception _ -> instantiation_of full_exp + | exception _ -> + (debug ctxt (lazy (" unable to infer function instantiation without return type " ^ string_of_typ (typ_of full_exp))); + instantiation_of full_exp) in let inst = KBindings.fold (fun k u m -> KBindings.add (KBindings.find (orig_kid k) tqs_map) u m) inst KBindings.empty in let () = debug ctxt (lazy (" instantiations: " ^ String.concat ", " (List.map (fun (kid,tyarg) -> string_of_kid kid ^ " => " ^ string_of_typ_arg tyarg) (KBindings.bindings inst)))) in -- cgit v1.2.3 From 542533ac7cbef0377de8413c3ac84c6fff2b9964 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 5 Mar 2019 12:16:17 +0000 Subject: Coq: use more local type information when constructing tuples --- src/pretty_print_coq.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 5dab3b8e..fe94dbb5 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -1200,11 +1200,12 @@ let doc_exp, doc_let = wrap_parens (string "build_ex" ^/^ epp) in let construct_dep_pairs ?(rawbools=false) env = - let rec aux want_parens (E_aux (e,_) as exp) (Typ_aux (t,_) as typ) = - match e,t with - | E_tuple exps, Typ_tup typs - | E_cast (_, E_aux (E_tuple exps,_)), Typ_tup typs + let rec aux want_parens (E_aux (e,_) as exp) typ = + match e with + | E_tuple exps + | E_cast (_, E_aux (E_tuple exps,_)) -> + let typs = List.map general_typ_of exps in parens (separate (string ", ") (List.map2 (aux false) exps typs)) | _ -> let typ' = expand_range_type (Env.expand_synonyms (env_of exp) typ) in -- cgit v1.2.3 From adf40a76fd9503628508ef1eea5396aabda88eab Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 5 Mar 2019 14:55:45 +0000 Subject: More optimizations and improvments for C generation Add some comments in constant_fold.ml --- src/c_backend.ml | 18 ++++++++++++++---- src/constant_fold.ml | 34 ++++++++++++++++++++++++++++++++++ src/sail.ml | 3 +++ 3 files changed, 51 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index d14b5391..925c7fd9 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -499,7 +499,7 @@ let analyze_primop' ctx id args typ = AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) | _ -> no_change end - + | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> begin match destruct_vector ctx.tc_env typ with | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) @@ -515,9 +515,19 @@ let analyze_primop' ctx id args typ = AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) | _ -> no_change end - + + | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)] + when n <= 63 -> + AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord))) + + | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool)) | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) + | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool)) + | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool)) | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) @@ -608,7 +618,7 @@ let analyze_primop' ctx id args typ = AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) | _ -> no_change end - + | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> begin match destruct_range Env.empty typ with | None -> no_change @@ -638,7 +648,7 @@ let analyze_primop' ctx id args typ = AV_C_fragment (lo, _, CT_fint 64); AV_C_fragment (ys, _, CT_fbits (m, true))] -> AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) - + | "undefined_bool", _ -> AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 6ad1f663..0ede2401 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -62,6 +62,9 @@ let optimize_constant_fold = ref false let rec fexp_of_ctor (field, value) = FE_aux (FE_Fexp (mk_id field, exp_of_value value), no_annot) +(* The interpreter will return a value for each folded expression, so + we must convert that back to expression to re-insert it in the AST + *) and exp_of_value = let open Value in function @@ -107,6 +110,32 @@ let safe_primops = "Elf_loader.elf_tohost" ] +(** We can specify a list of identifiers that we want to remove from + the final AST here. This is useful for removing tracing features in + optimized builds, e.g. for booting an OS as fast as possible. + + Basically we just do this by mapping + + f(x, y, z) -> () + + when f is in the list of identifiers to be mapped to unit. The + advantage of doing it like this is if x, y, and z are + computationally expensive then we remove them also. String + concatentation is very expensive at runtime so this is something we + really want when cutting out tracing features. Obviously it's + important that they don't have any meaningful side effects, and + that f does actually have type unit. +*) +let opt_fold_to_unit = ref [] + +let fold_to_unit id = + let remove = + !opt_fold_to_unit + |> List.map mk_id + |> List.fold_left (fun m id -> IdSet.add id m) IdSet.empty + in + IdSet.mem id remove + let rec is_constant (E_aux (e_aux, _)) = match e_aux with | E_lit _ -> true @@ -177,6 +206,11 @@ let rec rewrite_constant_function_calls' ast = let rw_funcall e_aux annot = match e_aux with + (* + | E_app (id, args) when fold_to_unit id -> + ok (); E_aux (E_lit (L_aux (L_unit, Parse_ast.Unknown)), annot) + *) + | E_app (id, args) when List.for_all is_constant args -> evaluate e_aux annot diff --git a/src/sail.ml b/src/sail.ml index eb81a0ee..aad7097f 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -155,6 +155,9 @@ let options = Arg.align ([ ( "-c_specialize", Arg.Set opt_specialize_c, " specialize integer arguments in C output"); + ( "-c_fold_unit", + Arg.String (fun str -> Constant_fold.opt_fold_to_unit := Util.split_on_char ',' str), + " remove comma separated list of functions from C output, replacing them with unit"); ( "-elf", Arg.String (fun elf -> opt_process_elf := Some elf), " process an ELF file so that it can be executed by compiled C code"); -- cgit v1.2.3 From 2cd88a225adf5f382df85a046cd59c43e1436965 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Tue, 5 Mar 2019 23:54:07 +0000 Subject: Fix missing case in specialization --- src/specialize.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/specialize.ml b/src/specialize.ml index a487fc2f..e2ab3c68 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -337,7 +337,8 @@ and remove_implicit_arg (A_aux (aux, l)) = let kopt_arg = function | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> arg_nexp (nvar kid) | KOpt_aux (KOpt_kind (K_aux (K_type,_), kid), _) -> arg_typ (mk_typ (Typ_var kid)) - | _ -> failwith "oh no" + | KOpt_aux (KOpt_kind (K_aux (K_bool, _), kid), _) -> arg_bool (nc_var kid) + | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid), _) -> arg_order (mk_ord (Ord_var kid)) (* For numeric type arguments we have to be careful not to run into a situation where we have an instantiation like -- cgit v1.2.3 From 2b4018a07e9eead8bfe147611b24a4d5856b4d56 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 6 Mar 2019 14:11:24 +0000 Subject: Add option to slice out printing and tracing functions when generating C Make instruction dependency graph use graph.ml Expose incremental graph building functions for performance in graph.mli --- src/bytecode_util.ml | 103 +++++++++++++++++++++++---------------------------- src/constant_fold.ml | 4 +- src/graph.ml | 25 +++++++++---- src/graph.mli | 9 +++++ src/slice.ml | 20 +++++----- 5 files changed, 84 insertions(+), 77 deletions(-) (limited to 'src') diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index 489bcc64..ee407289 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -540,6 +540,7 @@ module Node = struct | G_id id1, G_id id2 -> Id.compare id1 id2 | G_label str1, G_label str2 -> String.compare str1 str2 | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 + | G_start , G_start -> 0 | G_start , _ -> 1 | _ , G_start -> -1 | G_instr _, _ -> 1 @@ -548,10 +549,12 @@ module Node = struct | _ , G_id _ -> -1 end +module NodeGraph = Graph.Make(Node) + module NM = Map.Make(Node) module NS = Set.Make(Node) -type dep_graph = NS.t NM.t +type dep_graph = NodeGraph.graph let rec fragment_deps = function | F_id id | F_ref id -> NS.singleton (G_id id) @@ -593,78 +596,74 @@ let instr_deps = function | I_undefined _ -> NS.empty, NS.empty | I_match_failure -> NS.empty, NS.empty -let add_link from_node to_node graph = - try - NM.add from_node (NS.add to_node (NM.find from_node graph)) graph - with - | Not_found -> NM.add from_node (NS.singleton to_node) graph - -let leaves graph = - List.fold_left (fun acc (from_node, to_nodes) -> NS.filter (fun to_node -> Node.compare to_node from_node != 0) (NS.union acc to_nodes)) - NS.empty - (NM.bindings graph) - -(* Ensure that all leaves exist in the graph *) -let fix_leaves graph = - NS.fold (fun leaf graph -> if NM.mem leaf graph then graph else NM.add leaf NS.empty graph) (leaves graph) graph - let instrs_graph instrs = let icounter = ref 0 in - let graph = ref NM.empty in + let graph = ref NodeGraph.empty in - let rec add_instr last_instr (I_aux (instr, _) as iaux) = + let rec add_instr last_instrs (I_aux (instr, _) as iaux) = incr icounter; let node = G_instr (!icounter, iaux) in match instr with | I_block instrs | I_try_block instrs -> - List.fold_left add_instr last_instr instrs + List.fold_left add_instr last_instrs instrs | I_if (_, then_instrs, else_instrs, _) -> begin let inputs, _ = instr_deps instr in (* if has no outputs *) - graph := add_link last_instr node !graph; - NS.iter (fun input -> graph := add_link input node !graph) inputs; - let n1 = List.fold_left add_instr node then_instrs in - let n2 = List.fold_left add_instr node else_instrs in + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; + let n1 = List.fold_left add_instr [node] then_instrs in + let n2 = List.fold_left add_instr [node] else_instrs in incr icounter; let join = G_instr (!icounter, icomment "join") in - graph := add_link n1 join !graph; - graph := add_link n2 join !graph; - join + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; + [join] + end + | I_return _ -> + begin + let inputs, outputs = instr_deps instr in + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; + NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; + [] end + | I_label _ -> + node :: last_instrs | I_goto label -> begin let _, outputs = instr_deps instr in - graph := add_link last_instr node !graph; - NS.iter (fun output -> graph := add_link node output !graph) outputs; - incr icounter; - G_instr (!icounter, icomment "after goto") + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; + [] end | _ -> begin let inputs, outputs = instr_deps instr in - graph := add_link last_instr node !graph; - NS.iter (fun input -> graph := add_link input node !graph) inputs; - NS.iter (fun output -> graph := add_link node output !graph) outputs; - node + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; + NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; + [node] end in - ignore (List.fold_left add_instr G_start instrs); - fix_leaves !graph + ignore (List.fold_left add_instr [G_start] instrs); + let graph = NodeGraph.fix_leaves !graph in + graph let make_dot id graph = Util.opt_colors := false; let to_string node = String.escaped (string_of_node node) in let node_color = function - | G_start -> "lightpink" - | G_id _ -> "yellow" - | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" - | G_instr (_, I_aux (I_init _, _)) -> "springgreen" - | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" - | G_instr (_, I_aux (I_goto _, _)) -> "orange1" - | G_instr (_, I_aux (I_label _, _)) -> "white" - | G_instr (_, I_aux (I_raw _, _)) -> "khaki" - | G_instr _ -> "azure" - | G_label _ -> "lightpink" + | G_start -> "lightpink" + | G_id _ -> "yellow" + | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" + | G_instr (_, I_aux (I_init _, _)) -> "springgreen" + | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" + | G_instr (_, I_aux (I_goto _, _)) -> "orange1" + | G_instr (_, I_aux (I_label _, _)) -> "white" + | G_instr (_, I_aux (I_raw _, _)) -> "khaki" + | G_instr (_, I_aux (I_return _, _)) -> "deeppink" + | G_instr _ -> "azure" + | G_label _ -> "lightpink" in let edge_color from_node to_node = match from_node, to_node with @@ -677,17 +676,7 @@ let make_dot id graph = | _ , _ -> "coral3" in let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in - output_string out_chan "digraph DEPS {\n"; - let make_node from_node = - output_string out_chan (Printf.sprintf " \"%s\" [fillcolor=%s;style=filled];\n" (to_string from_node) (node_color from_node)) - in - let make_line from_node to_node = - output_string out_chan (Printf.sprintf " \"%s\" -> \"%s\" [color=%s];\n" (to_string from_node) (to_string to_node) (edge_color from_node to_node)) - in - NM.bindings graph |> List.iter (fun (from_node, _) -> make_node from_node); - NM.bindings graph |> List.iter (fun (from_node, to_nodes) -> NS.iter (make_line from_node) to_nodes); - output_string out_chan "}\n"; - Util.opt_colors := true; + NodeGraph.make_dot node_color edge_color to_string out_chan graph; close_out out_chan let rec map_clexp_ctyp f = function diff --git a/src/constant_fold.ml b/src/constant_fold.ml index 0ede2401..f85fb673 100644 --- a/src/constant_fold.ml +++ b/src/constant_fold.ml @@ -206,10 +206,8 @@ let rec rewrite_constant_function_calls' ast = let rw_funcall e_aux annot = match e_aux with - (* | E_app (id, args) when fold_to_unit id -> - ok (); E_aux (E_lit (L_aux (L_unit, Parse_ast.Unknown)), annot) - *) + ok (); E_aux (E_lit (L_aux (L_unit, fst annot)), annot) | E_app (id, args) when List.for_all is_constant args -> evaluate e_aux annot diff --git a/src/graph.ml b/src/graph.ml index e3af0b97..21863e47 100644 --- a/src/graph.ml +++ b/src/graph.ml @@ -69,6 +69,15 @@ module type S = val add_edge : node -> node -> graph -> graph val add_edges : node -> node list -> graph -> graph + (** Add edges to the graph, but may leave the internal structure + of the graph in a non-normalized state. Fix leaves repairs any + such issue in the graph. These additional functions are much + faster than those above, but it is important to call fix_leaves + before calling reachable, prune, or any other function. *) + val add_edge' : node -> node -> graph -> graph + val add_edges' : node -> node list -> graph -> graph + val fix_leaves : graph -> graph + val children : graph -> node -> node list (** Return the set of nodes that are reachable from the first set @@ -119,19 +128,21 @@ module Make(Ord: OrderedType) = struct let fix_leaves cg = NS.fold (fun leaf cg -> if NM.mem leaf cg then cg else NM.add leaf NS.empty cg) (leaves cg) cg - (* FIXME: don't use fix_leaves because this is inefficient *) - let add_edge caller callee cg = + let add_edge' caller callee cg = try - fix_leaves (NM.add caller (NS.add callee (NM.find caller cg)) cg) + NM.add caller (NS.add callee (NM.find caller cg)) cg with - | Not_found -> fix_leaves (NM.add caller (NS.singleton callee) cg) + | Not_found -> NM.add caller (NS.singleton callee) cg - let add_edges caller callees cg = + let add_edges' caller callees cg = let callees = List.fold_left (fun s c -> NS.add c s) NS.empty callees in try - fix_leaves (NM.add caller (NS.union callees (NM.find caller cg)) cg) + NM.add caller (NS.union callees (NM.find caller cg)) cg with - | Not_found -> fix_leaves (NM.add caller callees cg) + | Not_found -> NM.add caller callees cg + + let add_edge caller callee cg = fix_leaves (add_edge' caller callee cg) + let add_edges caller callees cg = fix_leaves (add_edges' caller callees cg) let reachable roots cuts cg = let visited = ref NS.empty in diff --git a/src/graph.mli b/src/graph.mli index 09b78304..02480a9d 100644 --- a/src/graph.mli +++ b/src/graph.mli @@ -71,6 +71,15 @@ module type S = val add_edge : node -> node -> graph -> graph val add_edges : node -> node list -> graph -> graph + (** Add edges to the graph, but may leave the internal structure + of the graph in a non-normalized state. Fix leaves repairs any + such issue in the graph. These additional functions are much + faster than those above, but it is important to call fix_leaves + before calling reachable, prune, or any other function. *) + val add_edge' : node -> node -> graph -> graph + val add_edges' : node -> node list -> graph -> graph + val fix_leaves : graph -> graph + val children : graph -> node -> node list (** Return the set of nodes that are reachable from the first set diff --git a/src/slice.ml b/src/slice.ml index cbf8ee5d..c1829f7d 100644 --- a/src/slice.ml +++ b/src/slice.ml @@ -133,18 +133,18 @@ let add_def_to_graph graph def = begin match e_aux with | E_id id -> begin match Env.lookup_id id env with - | Register _ -> graph := G.add_edge self (Register id) !graph + | Register _ -> graph := G.add_edge' self (Register id) !graph | _ -> if IdSet.mem id (Env.get_toplevel_lets env) then - graph := G.add_edge self (Letbind id) !graph + graph := G.add_edge' self (Letbind id) !graph else () end | E_app (id, _) -> - graph := G.add_edge self (Function id) !graph + graph := G.add_edge' self (Function id) !graph | E_ref id -> - graph := G.add_edge self (Register id) !graph + graph := G.add_edge' self (Register id) !graph | E_cast (typ, _) -> - IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ) + IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ) | _ -> () end; E_aux (e_aux, annot) @@ -160,19 +160,19 @@ let add_def_to_graph graph def = begin match def with | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), _), id, _, _), _)) -> - graph := G.add_edges (Function id) [] !graph; - IdSet.iter (fun typ_id -> graph := G.add_edge (Function id) (Type typ_id) !graph) (typ_ids typ) + graph := G.add_edges' (Function id) [] !graph; + IdSet.iter (fun typ_id -> graph := G.add_edge' (Function id) (Type typ_id) !graph) (typ_ids typ) | DEF_fundef fdef -> let id = id_of_fundef fdef in - graph := G.add_edges (Function id) [] !graph; + graph := G.add_edges' (Function id) [] !graph; ignore (rewrite_fun (rewriters (Function id)) fdef) | DEF_val (LB_aux (LB_val (pat, exp), _) as lb) -> let ids = pat_ids pat in - IdSet.iter (fun id -> graph := G.add_edges (Letbind id) [] !graph) ids; + IdSet.iter (fun id -> graph := G.add_edges' (Letbind id) [] !graph) ids; IdSet.iter (fun id -> ignore (rewrite_let (rewriters (Letbind id)) lb)) ids | _ -> () end; - !graph + G.fix_leaves !graph let rec graph_of_ast (Defs defs) = let module G = Graph.Make(Node) in -- cgit v1.2.3 From 08f65aad9bdb57dd1867b3206c9ffcd30666f2d3 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 6 Mar 2019 17:44:54 +0000 Subject: Improve AST slicing --- src/slice.ml | 158 ++++++++++++++++++++++++++++++++++++++++++++++------------ src/slice.mli | 68 +++++++++++++++++++++++++ 2 files changed, 195 insertions(+), 31 deletions(-) create mode 100644 src/slice.mli (limited to 'src') diff --git a/src/slice.ml b/src/slice.ml index c1829f7d..f50104c4 100644 --- a/src/slice.ml +++ b/src/slice.ml @@ -53,15 +53,12 @@ open Ast_util open Rewriter type node = - (* In the graph we have a node Register that represents the actual - register, but functions get only get transitive dependencies on - that through Register_read, Register_write, and Register_ref - nodes. *) | Register of id | Function of id | Letbind of id | Type of id | Overload of id + | Constructor of id let node_id = function | Register id -> id @@ -69,6 +66,7 @@ let node_id = function | Letbind id -> id | Type id -> id | Overload id -> id + | Constructor id -> id let node_kind = function | Register _ -> 0 @@ -76,6 +74,7 @@ let node_kind = function | Letbind _ -> 3 | Type _ -> 4 | Overload _ -> 5 + | Constructor _ -> 6 module Node = struct type t = node @@ -93,6 +92,7 @@ let node_color cuts = | Letbind _ -> "yellow" | Type _ -> "springgreen" | Overload _ -> "peachpuff" + | Constructor _ -> "lightslateblue" let node_string n = node_id n |> string_of_id |> String.escaped @@ -102,32 +102,82 @@ let builtins = let open Type_check in IdSet.of_list (List.map fst (Bindings.bindings Env.builtin_typs)) -let typ_ids typ = - let rec typ_ids (Typ_aux (aux, _)) = - match aux with - | Typ_var _ | Typ_internal_unknown -> IdSet.empty - | Typ_id id -> IdSet.singleton id - | Typ_app (id, typs) -> - IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids typs)) - | Typ_fn (typs, typ, _) -> - IdSet.union (typ_ids typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids typs)) - | Typ_bidir (typ1, typ2) -> - IdSet.union (typ_ids typ1) (typ_ids typ2) - | Typ_tup typs -> - List.fold_left IdSet.union IdSet.empty (List.map typ_ids typs) - | Typ_exist (_, _, typ) -> typ_ids typ - and typ_arg_ids (A_aux (aux, _)) = - match aux with - | A_typ typ -> typ_ids typ - | _ -> IdSet.empty - in - IdSet.diff (typ_ids typ) builtins +let rec constraint_ids' (NC_aux (aux, _)) = + match aux with + | NC_equal (n1, n2) | NC_bounded_le (n1, n2) | NC_bounded_ge (n1, n2) | NC_not_equal (n1, n2) -> + IdSet.union (nexp_ids' n1) (nexp_ids' n2) + | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> + IdSet.union (constraint_ids' nc1) (constraint_ids' nc2) + | NC_var _ | NC_true | NC_false | NC_set _ -> IdSet.empty + | NC_app (id, args) -> + IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args)) + +and nexp_ids' (Nexp_aux (aux, _)) = + match aux with + | Nexp_id id -> IdSet.singleton id + | Nexp_app (id, nexps) -> + IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map nexp_ids' nexps)) + | Nexp_var _ | Nexp_constant _ -> IdSet.empty + | Nexp_exp n | Nexp_neg n -> nexp_ids' n + | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) -> + IdSet.union (nexp_ids' n1) (nexp_ids' n2) + +and typ_ids' (Typ_aux (aux, _)) = + match aux with + | Typ_var _ | Typ_internal_unknown -> IdSet.empty + | Typ_id id -> IdSet.singleton id + | Typ_app (id, args) -> + IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args)) + | Typ_fn (typs, typ, _) -> + IdSet.union (typ_ids' typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs)) + | Typ_bidir (typ1, typ2) -> + IdSet.union (typ_ids' typ1) (typ_ids' typ2) + | Typ_tup typs -> + List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs) + | Typ_exist (_, _, typ) -> typ_ids' typ + +and typ_arg_ids' (A_aux (aux, _)) = + match aux with + | A_typ typ -> typ_ids' typ + | A_nexp nexp -> nexp_ids' nexp + | A_bool nc -> constraint_ids' nc + | A_order _ -> IdSet.empty + +let constraint_ids nc = IdSet.diff (constraint_ids' nc) builtins +let nexp_ids nc = IdSet.diff (constraint_ids' nc) builtins +and typ_ids typ = IdSet.diff (typ_ids' typ) builtins +let typ_arg_ids nc = IdSet.diff (typ_arg_ids' nc) builtins let add_def_to_graph graph def = let open Type_check in let module G = Graph.Make(Node) in let graph = ref graph in + let scan_pat self p_aux annot = + let env = env_of_annot annot in + begin match p_aux with + | P_app (id, _) -> + graph := G.add_edge' self (Constructor id) !graph + | P_typ (typ, _) -> + IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ) + | _ -> () + end; + P_aux (p_aux, annot) + in + let rw_pat self = { id_pat_alg with p_aux = (fun (p_aux, annot) -> scan_pat self p_aux annot) } in + + let scan_lexp self lexp_aux annot = + let env = env_of_annot annot in + begin match lexp_aux with + | LEXP_cast (typ, _) -> + IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ) + | LEXP_memory (id, _) -> + graph := G.add_edge' self (Function id) !graph + | _ -> () + end; + LEXP_aux (lexp_aux, annot) + in + let scan_exp self e_aux annot = let env = env_of_annot annot in begin match e_aux with @@ -140,7 +190,10 @@ let add_def_to_graph graph def = else () end | E_app (id, _) -> - graph := G.add_edge' self (Function id) !graph + if Env.is_union_constructor id env then + graph := G.add_edge' self (Constructor id) !graph + else + graph := G.add_edge' self (Function id) !graph | E_ref id -> graph := G.add_edge' self (Register id) !graph | E_cast (typ, _) -> @@ -149,15 +202,58 @@ let add_def_to_graph graph def = end; E_aux (e_aux, annot) in - let rw_exp self = { id_exp_alg with e_aux = (fun (e_aux, annot) -> scan_exp self e_aux annot) } in + let rw_exp self = { id_exp_alg with e_aux = (fun (e_aux, annot) -> scan_exp self e_aux annot); + pat_alg = rw_pat self } in let rewriters self = { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rw_exp self)); + rewrite_pat = (fun _ -> fold_pat (rw_pat self)); rewrite_let = (fun _ -> fold_letbind (rw_exp self)); } in + let scan_quant_item self (QI_aux (aux, _)) = + match aux with + | QI_id _ -> () + | QI_const nc -> + IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (constraint_ids nc) + in + + let scan_typquant self (TypQ_aux (aux, _)) = + match aux with + | TypQ_no_forall -> () + | TypQ_tq quants -> List.iter (scan_quant_item self) quants + in + + let add_type_def_to_graph (TD_aux (aux, (l, _))) = + match aux with + | TD_abbrev (id, typq, arg) -> + graph := G.add_edges' (Type id) (List.map (fun id -> Type id) (IdSet.elements (typ_arg_ids arg))) !graph; + scan_typquant (Type id) typq + | TD_record (id, typq, fields, _) -> + let field_nodes = + List.map (fun (typ, _) -> typ_ids typ) fields + |> List.fold_left IdSet.union IdSet.empty + |> IdSet.elements + |> List.map (fun id -> Type id) + in + graph := G.add_edges' (Type id) field_nodes !graph; + scan_typquant (Type id) typq + | TD_variant (id, typq, ctors, _) -> + let ctor_nodes = + List.map (fun (Tu_aux (Tu_ty_id (typ, id), _)) -> (typ_ids typ, id)) ctors + |> List.fold_left (fun (ids, ctors) (ids', ctor) -> (IdSet.union ids ids', IdSet.add ctor ctors)) (IdSet.empty, IdSet.empty) + in + IdSet.iter (fun ctor_id -> graph := G.add_edge' (Constructor ctor_id) (Type id) !graph) (snd ctor_nodes); + IdSet.iter (fun typ_id -> graph := G.add_edge' (Type id) (Type typ_id) !graph) (fst ctor_nodes); + scan_typquant (Type id) typq + | TD_enum (id, _, _) -> + graph := G.add_edges' (Type id) [] !graph + | TD_bitfield _ -> + Reporting.unreachable l __POS__ "Bitfield should be re-written" + in + begin match def with | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), _), id, _, _), _)) -> graph := G.add_edges' (Function id) [] !graph; @@ -170,6 +266,9 @@ let add_def_to_graph graph def = let ids = pat_ids pat in IdSet.iter (fun id -> graph := G.add_edges' (Letbind id) [] !graph) ids; IdSet.iter (fun id -> ignore (rewrite_let (rewriters (Letbind id)) lb)) ids + | DEF_type tdef -> + add_type_def_to_graph tdef + | DEF_pragma _ -> () | _ -> () end; G.fix_leaves !graph @@ -184,11 +283,8 @@ let rec graph_of_ast (Defs defs) = | [] -> G.empty -let dot_of_ast ast = +let dot_of_ast out_chan ast = let module G = Graph.Make(Node) in let module NodeSet = Set.Make(Node) in let g = graph_of_ast ast in - let roots = NodeSet.of_list (List.map (fun str -> Function (mk_id str)) ["execute_CGetPerm"; "execute_CSeal"]) in - let cuts = NodeSet.of_list (List.map (fun str -> Function (mk_id str)) ["readCapReg"; "writeCapReg"; "rGPR"; "wGPR"; "SignalException"]) in - let g = G.prune roots cuts g in - G.make_dot (node_color cuts) edge_color node_string stdout g + G.make_dot (node_color NodeSet.empty) edge_color node_string out_chan g diff --git a/src/slice.mli b/src/slice.mli new file mode 100644 index 00000000..09558ebf --- /dev/null +++ b/src/slice.mli @@ -0,0 +1,68 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast + +type node = + | Register of id + | Function of id + | Letbind of id + | Type of id + | Overload of id + | Constructor of id + +module Node : sig + type t = node + val compare : node -> node -> int +end + +val graph_of_ast : Type_check.tannot defs -> Graph.Make(Node).graph + +val dot_of_ast : out_channel -> Type_check.tannot defs -> unit -- cgit v1.2.3 From cfda45f01a251683d37c9d57bc228a46c28d9ae1 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 6 Mar 2019 18:11:19 +0000 Subject: Add an -ir option to print the intermediate representation of a file --- src/c_backend.ml | 4 ++++ src/c_backend.mli | 5 ++++- src/sail.ml | 20 ++++++++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/c_backend.ml b/src/c_backend.ml index 925c7fd9..14930d47 100644 --- a/src/c_backend.ml +++ b/src/c_backend.ml @@ -143,6 +143,9 @@ let initial_ctx env = iterate_size = false; } +let initial_ctx_iterate env = + { (initial_ctx env) with iterate_size = true } + let rec iterate_size ctx size n m = if size > 64 then CT_lint @@ -3476,6 +3479,7 @@ let bytecode_ast ctx rewrites (Defs defs) = List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs in let cdefs = List.concat (List.rev chunks) in + let cdefs, ctx = specialize_variants ctx [] cdefs in rewrites cdefs let rec get_recursive_functions (Defs defs) = diff --git a/src/c_backend.mli b/src/c_backend.mli index 3b26acdf..4017130a 100644 --- a/src/c_backend.mli +++ b/src/c_backend.mli @@ -122,10 +122,13 @@ type ctx should be the environment returned by typechecking the full AST. *) val initial_ctx : Env.t -> ctx +(** Same as initial ctx, but iterate to find more precise bounds on + integers. *) +val initial_ctx_iterate : Env.t -> ctx + (** Convert a typ to a IR ctyp *) val ctyp_of_typ : ctx -> Ast.typ -> ctyp - val compile_aexp : ctx -> Ast.typ Anf.aexp -> instr list * (clexp -> instr) * instr list val compile_ast : ctx -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/sail.ml b/src/sail.ml index aad7097f..77f0e32d 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -61,6 +61,7 @@ let opt_print_verbose = ref false let opt_print_lem = ref false let opt_print_ocaml = ref false let opt_print_c = ref false +let opt_print_ir = ref false let opt_print_latex = ref false let opt_print_coq = ref false let opt_print_cgen = ref false @@ -128,6 +129,9 @@ let options = Arg.align ([ ( "-latex_full_valspecs", Arg.Clear Latex.opt_simple_val, " print full valspecs in LaTeX output"); + ( "-ir", + Arg.Set opt_print_ir, + " print intermediate representation"); ( "-c", Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen], " output a C translated version of the input"); @@ -440,6 +444,22 @@ let main() = C_backend.compile_ast (C_backend.initial_ctx type_envs) output_chan (!opt_includes_c) ast_c; close_out output_chan else ()); + (if !(opt_print_ir) + then + let ast_c = rewrite_ast_c type_envs ast in + let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in + let ast_c, type_envs = Specialize.(specialize' 2 int_specialization_with_externs ast_c type_envs) in + let output_chan = + match !opt_file_out with + | Some f -> Util.opt_colors := false; open_out (f ^ ".ir.sail") + | None -> stdout + in + Util.opt_warnings := true; + let cdefs = C_backend.(bytecode_ast (initial_ctx_iterate type_envs) (List.map flatten_cdef) ast_c) in + let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Bytecode_util.pp_cdef cdefs) in + output_string output_chan (str ^ "\n"); + close_out output_chan + else ()); (if !(opt_print_cgen) then Cgen_backend.output type_envs ast else ()); -- cgit v1.2.3 From 2bb075e41d9b751bfb649f1385018529b112dee4 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 6 Mar 2019 16:07:29 +0000 Subject: Extract constant propagation and related functions from monomorphisation. This shouldn't change any functionality. --- src/ast_util.ml | 72 +++ src/ast_util.mli | 6 + src/constant_propagation.ml | 825 ++++++++++++++++++++++++++++++++ src/constant_propagation.mli | 67 +++ src/monomorphise.ml | 1059 +----------------------------------------- src/rewriter.ml | 1 - src/spec_analysis.ml | 209 +++++++++ src/spec_analysis.mli | 19 + 8 files changed, 1218 insertions(+), 1040 deletions(-) create mode 100644 src/constant_propagation.ml create mode 100644 src/constant_propagation.mli (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 158b40a8..79b5b0eb 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -1822,6 +1822,77 @@ let typquant_subst_kid_aux sv subst = function let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l) + +let subst_kids_nexp substs nexp = + let rec s_snexp substs (Nexp_aux (ne,l) as nexp) = + let re ne = Nexp_aux (ne,l) in + let s_snexp = s_snexp substs in + match ne with + | Nexp_var (Kid_aux (_,l) as kid) -> + (try KBindings.find kid substs + with Not_found -> nexp) + | Nexp_id _ + | Nexp_constant _ -> nexp + | Nexp_times (n1,n2) -> re (Nexp_times (s_snexp n1, s_snexp n2)) + | Nexp_sum (n1,n2) -> re (Nexp_sum (s_snexp n1, s_snexp n2)) + | Nexp_minus (n1,n2) -> re (Nexp_minus (s_snexp n1, s_snexp n2)) + | Nexp_exp ne -> re (Nexp_exp (s_snexp ne)) + | Nexp_neg ne -> re (Nexp_neg (s_snexp ne)) + | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args)) + in s_snexp substs nexp + +let subst_kids_nc, subst_kids_typ, subst_kids_typ_arg = + let rec subst_kids_nc substs (NC_aux (nc,l) as n_constraint) = + let snexp nexp = subst_kids_nexp substs nexp in + let snc nc = subst_kids_nc substs nc in + let re nc = NC_aux (nc,l) in + match nc with + | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2)) + | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2)) + | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2)) + | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2)) + | NC_set (kid,is) -> + begin + match KBindings.find kid substs with + | Nexp_aux (Nexp_constant i,_) -> + if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false + | nexp -> + raise (Reporting.err_general l + ("Unable to substitute " ^ string_of_nexp nexp ^ + " into set constraint " ^ string_of_n_constraint n_constraint)) + | exception Not_found -> n_constraint + end + | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2)) + | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2)) + | NC_true + | NC_false + -> n_constraint + | NC_var kid -> re (NC_var kid) + | NC_app (f, args) -> + re (NC_app (f, List.map (s_starg substs) args)) + and s_styp substs ((Typ_aux (t,l)) as ty) = + let re t = Typ_aux (t,l) in + match t with + | Typ_id _ + | Typ_var _ + -> ty + | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e)) + | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2)) + | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) + | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) + | Typ_exist (kopts,nc,t) -> + let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in + re (Typ_exist (kopts,subst_kids_nc substs nc,s_styp substs t)) + | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" + and s_starg substs (A_aux (ta,l) as targ) = + match ta with + | A_nexp ne -> A_aux (A_nexp (subst_kids_nexp substs ne),l) + | A_typ t -> A_aux (A_typ (s_styp substs t),l) + | A_order _ -> targ + | A_bool nc -> A_aux (A_bool (subst_kids_nc substs nc), l) + in subst_kids_nc, s_styp, s_starg + + let rec simp_loc = function | Parse_ast.Unknown -> None | Parse_ast.Unique (_, l) -> simp_loc l @@ -1953,3 +2024,4 @@ let rec find_annot_defs sl = function | [] -> None let rec find_annot_ast sl (Defs defs) = find_annot_defs sl defs + diff --git a/src/ast_util.mli b/src/ast_util.mli index 0c42d9d3..750d3730 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -439,6 +439,12 @@ val typ_arg_subst : kid -> typ_arg -> typ_arg -> typ_arg val subst_kid : (kid -> typ_arg -> 'a -> 'a) -> kid -> kid -> 'a -> 'a +(* Multiple type-level substitution *) +val subst_kids_nexp : nexp KBindings.t -> nexp -> nexp +val subst_kids_nc : nexp KBindings.t -> n_constraint -> n_constraint +val subst_kids_typ : nexp KBindings.t -> typ -> typ +val subst_kids_typ_arg : nexp KBindings.t -> typ_arg -> typ_arg + val quant_item_subst_kid : kid -> kid -> quant_item -> quant_item val typquant_subst_kid : kid -> kid -> typquant -> typquant diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml new file mode 100644 index 00000000..c44692b3 --- /dev/null +++ b/src/constant_propagation.ml @@ -0,0 +1,825 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Spec_analysis +open Type_check + +(* COULD DO: dead code is only eliminated at if expressions, but we could + also cut out impossible case branches and code after assertions. *) + +(* Constant propogation. + Takes maps of immutable/mutable variables to subsitute. + The substs argument also contains the current type-level kid refinements + so that we can check for dead code. + Extremely conservative about evaluation order of assignments in + subexpressions, dropping assignments rather than committing to + any particular order *) + + +let kbindings_from_list = List.fold_left (fun s (v,i) -> KBindings.add v i s) KBindings.empty +let bindings_from_list = List.fold_left (fun s (v,i) -> Bindings.add v i s) Bindings.empty +(* union was introduced in 4.03.0, a bit too recently *) +let bindings_union s1 s2 = + Bindings.merge (fun _ x y -> match x,y with + | _, (Some x) -> Some x + | (Some x), _ -> Some x + | _, _ -> None) s1 s2 +let kbindings_union s1 s2 = + KBindings.merge (fun _ x y -> match x,y with + | _, (Some x) -> Some x + | (Some x), _ -> Some x + | _, _ -> None) s1 s2 + +let rec list_extract f = function + | [] -> None + | h::t -> match f h with None -> list_extract f t | Some v -> Some v + + + +let is_pure e = + match e with + | Effect_aux (Effect_set [],_) -> true + | _ -> false + +let remove_bound (substs,ksubsts) pat = + let bound = bindings_from_pat pat in + List.fold_left (fun sub v -> Bindings.remove v sub) substs bound, ksubsts + +let rec is_value (E_aux (e,(l,annot))) = + let is_constructor id = + match destruct_tannot annot with + | None -> + (Reporting.print_err l "Monomorphisation" + ("Missing type information for identifier " ^ string_of_id id); + false) (* Be conservative if we have no info *) + | Some (env,_,_) -> + Env.is_union_constructor id env || + (match Env.lookup_id id env with + | Enum _ -> true + | Unbound | Local _ | Register _ -> false) + in + match e with + | E_id id -> is_constructor id + | E_lit _ -> true + | E_tuple es -> List.for_all is_value es + | E_app (id,es) -> is_constructor id && List.for_all is_value es + (* We add casts to undefined to keep the type information in the AST *) + | E_cast (typ,E_aux (E_lit (L_aux (L_undef,_)),_)) -> true +(* TODO: more? *) + | _ -> false + +let isubst_minus_set subst set = + IdSet.fold Bindings.remove set subst + +let threaded_map f state l = + let l',state' = + List.fold_left (fun (tl,state) element -> let (el',state') = f state element in (el'::tl,state')) + ([],state) l + in List.rev l',state' + + +(* Attempt simple pattern matches *) +let lit_match = function + | (L_zero | L_false), (L_zero | L_false) -> true + | (L_one | L_true ), (L_one | L_true ) -> true + | L_num i1, L_num i2 -> Big_int.equal i1 i2 + | l1,l2 -> l1 = l2 + +(* There's no undefined nexp, so replace undefined sizes with a plausible size. + 32 is used as a sensible default. *) + +let fabricate_nexp_exist env l typ kids nc typ' = + match kids,nc,Env.expand_synonyms env typ' with + | ([kid],NC_aux (NC_set (kid',i::_),_), + Typ_aux (Typ_app (Id_aux (Id "atom",_), + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) + when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 -> + Nexp_aux (Nexp_constant i,Unknown) + | ([kid],NC_aux (NC_true,_), + Typ_aux (Typ_app (Id_aux (Id "atom",_), + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) + when Kid.compare kid kid'' = 0 -> + nint 32 + | ([kid],NC_aux (NC_set (kid',i::_),_), + Typ_aux (Typ_app (Id_aux (Id "range",_), + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); + A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 && + Kid.compare kid kid''' = 0 -> + Nexp_aux (Nexp_constant i,Unknown) + | ([kid],NC_aux (NC_true,_), + Typ_aux (Typ_app (Id_aux (Id "range",_), + [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); + A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + when Kid.compare kid kid'' = 0 && + Kid.compare kid kid''' = 0 -> + nint 32 + | ([], _, typ) -> nint 32 + | (kids, nc, typ) -> + raise (Reporting.err_general l + ("Undefined value at unsupported type " ^ string_of_typ typ ^ " with " ^ Util.string_of_list ", " string_of_kid kids)) + +let fabricate_nexp l tannot = + match destruct_tannot tannot with + | None -> nint 32 + | Some (env,typ,_) -> + match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with + | None -> nint 32 + (* TODO: check this *) + | Some (kopts,nc,typ') -> fabricate_nexp_exist env l typ (List.map kopt_kid kopts) nc typ' + +let atom_typ_kid kid = function + | Typ_aux (Typ_app (Id_aux (Id "atom",_), + [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) -> + Kid.compare kid kid' = 0 + | _ -> false + +(* We reduce casts in a few cases, in particular to ensure that where the + type checker has added a ({'n, true. atom('n)}) ex_int(...) cast we can + fill in the 'n. For undefined we fabricate a suitable value for 'n. *) + +let reduce_cast typ exp l annot = + let env = env_of_annot (l,annot) in + let typ' = Env.base_typ_of env typ in + match exp, destruct_exist (Env.expand_synonyms env typ') with + | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nc_env = Env.add_typ_var l kopt env in + let nc_env = Env.add_constraint (nc_eq (nvar (kopt_kid kopt)) (nconstant n)) nc_env in + if prove __POS__ nc_env nc + then exp + else raise (Reporting.err_unreachable l __POS__ + ("Constant propagation error: literal " ^ Big_int.to_string n ^ + " does not satisfy constraint " ^ string_of_n_constraint nc)) + | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in + let newtyp = subst_kids_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in + E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) + | E_aux (E_cast (_, + (E_aux (E_lit (L_aux (L_undef,_)),_) as exp)),_), + Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> + let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in + let newtyp = subst_kids_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in + E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) + | _ -> E_aux (E_cast (typ,exp),(l,annot)) + +(* Used for constant propagation in pattern matches *) +type 'a matchresult = + | DoesMatch of 'a + | DoesNotMatch + | GiveUp + +(* Remove top-level casts from an expression. Useful when we need to look at + subexpressions to reduce something, but could break type-checking if we used + it everywhere. *) +let rec drop_casts = function + | E_aux (E_cast (_,e),_) -> drop_casts e + | exp -> exp + +let int_of_str_lit = function + | L_hex hex -> Big_int.of_string ("0x" ^ hex) + | L_bin bin -> Big_int.of_string ("0b" ^ bin) + | _ -> assert false + +let bits_of_lit = function + | L_bin bin -> bin + | L_hex hex -> hex_to_bin hex + | _ -> assert false + +let slice_lit (L_aux (lit,ll)) i len (Ord_aux (ord,_)) = + let i = Big_int.to_int i in + let len = Big_int.to_int len in + let bin = bits_of_lit lit in + match match ord with + | Ord_inc -> Some i + | Ord_dec -> Some (String.length bin - i - len) + | Ord_var _ -> None + with + | None -> None + | Some i -> + Some (L_aux (L_bin (String.sub bin i len),Generated ll)) + +let concat_vec lit1 lit2 = + let bits1 = bits_of_lit lit1 in + let bits2 = bits_of_lit lit2 in + L_bin (bits1 ^ bits2) + +let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = + match l1,l2 with + | (L_zero|L_false), (L_zero|L_false) + | (L_one |L_true ), (L_one |L_true) + -> Some true + | (L_hex _| L_bin _), (L_hex _|L_bin _) + -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2)) + | L_undef, _ | _, L_undef -> None + | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2) + | _ -> Some (l1 = l2) + +let try_app (l,ann) (id,args) = + let new_l = Parse_ast.Generated l in + let env = env_of_annot (l,ann) in + let get_overloads f = List.map string_of_id + (Env.get_overloads (Id_aux (Id f, Parse_ast.Unknown)) env @ + Env.get_overloads (Id_aux (DeIid f, Parse_ast.Unknown)) env) in + let is_id f = List.mem (string_of_id id) (f :: get_overloads f) in + if is_id "==" || is_id "!=" then + match args with + | [E_aux (E_lit l1,_); E_aux (E_lit l2,_)] -> + let lit b = if b then L_true else L_false in + let lit b = lit (if is_id "==" then b else not b) in + (match lit_eq l1 l2 with + | None -> None + | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)),(l,ann)))) + | _ -> None + else if is_id "cast_bit_bool" then + match args with + | [E_aux (E_lit L_aux (L_zero,_),_)] -> Some (E_aux (E_lit (L_aux (L_false,new_l)),(l,ann))) + | [E_aux (E_lit L_aux (L_one ,_),_)] -> Some (E_aux (E_lit (L_aux (L_true ,new_l)),(l,ann))) + | _ -> None + else if is_id "UInt" || is_id "unsigned" then + match args with + | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit,_), _)] -> + Some (E_aux (E_lit (L_aux (L_num (int_of_str_lit lit),new_l)),(l,ann))) + | _ -> None + else if is_id "slice" then + match args with + | [E_aux (E_lit (L_aux ((L_hex _| L_bin _),_) as lit), annot); + E_aux (E_lit L_aux (L_num i,_), _); + E_aux (E_lit L_aux (L_num len,_), _)] -> + (match Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) with + | Typ_aux (Typ_app (_,[_;A_aux (A_order ord,_);_]),_) -> + (match slice_lit lit i len ord with + | Some lit' -> Some (E_aux (E_lit lit',(l,ann))) + | None -> None) + | _ -> None) + | _ -> None + else if is_id "bitvector_concat" then + match args with + | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit1,_), _); + E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit2,_), _)] -> + Some (E_aux (E_lit (L_aux (concat_vec lit1 lit2,new_l)),(l,ann))) + | _ -> None + else if is_id "shl_int" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann))) + | _ -> None + else if is_id "mult_atom" || is_id "mult_int" || is_id "mult_range" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann))) + | _ -> None + else if is_id "quotient_nat" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (Big_int.div i j),new_l)),(l,ann))) + | _ -> None + else if is_id "add_atom" || is_id "add_int" || is_id "add_range" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (Big_int.add i j),new_l)),(l,ann))) + | _ -> None + else if is_id "negate_range" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (Big_int.negate i),new_l)),(l,ann))) + | _ -> None + else if is_id "ex_int" then + match args with + | [E_aux (E_lit lit,(l,_))] -> Some (E_aux (E_lit lit,(l,ann))) + | [E_aux (E_cast (_,(E_aux (E_lit (L_aux (L_undef,_)),_) as e)),(l,_))] -> + Some (reduce_cast (typ_of_annot (l,ann)) e l ann) + | _ -> None + else if is_id "vector_access" || is_id "bitvector_access" then + match args with + | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_); + E_aux (E_lit L_aux (L_num i,_),_)] -> + let v = int_of_str_lit lit in + let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in + let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in + Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann))) + | _ -> None + else None + + +let construct_lit_vector args = + let rec aux l = function + | [] -> Some (L_aux (L_bin (String.concat "" (List.rev l)),Unknown)) + | E_aux (E_lit (L_aux ((L_zero | L_one) as lit,_)),_)::t -> + aux ((if lit = L_zero then "0" else "1")::l) t + | _ -> None + in aux [] args + +(* Add a cast to undefined so that it retains its type, otherwise it can't be + substituted safely *) +let keep_undef_typ value = + match value with + | E_aux (E_lit (L_aux (L_undef,lann)),eann) -> + E_aux (E_cast (typ_of_annot eann,value),(Generated Unknown,snd eann)) + | _ -> value + +(* Check whether the current environment with the given kid assignments is + inconsistent (and hence whether the code is dead) *) +let is_env_inconsistent env ksubsts = + let env = KBindings.fold (fun k nexp env -> + Env.add_constraint (nc_eq (nvar k) nexp) env) ksubsts env in + prove __POS__ env nc_false + + +let const_prop defs = + let rec const_prop_exp ref_vars substs assigns ((E_aux (e,(l,annot))) as exp) = + (* Functions to treat lists and tuples of subexpressions as possibly + non-deterministic: that is, we stop making any assumptions about + variables that are assigned to in any of the subexpressions *) + let non_det_exp_list es = + let assigned_in = + List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) + IdSet.empty es in + let assigns = isubst_minus_set assigns assigned_in in + let es' = List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es in + es',assigns + in + let non_det_exp_2 e1 e2 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigns = isubst_minus_set assigns assigned_in_e12 in + let e1',_ = const_prop_exp ref_vars substs assigns e1 in + let e2',_ = const_prop_exp ref_vars substs assigns e2 in + e1',e2',assigns + in + let non_det_exp_3 e1 e2 e3 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in + let assigns = isubst_minus_set assigns assigned_in_e123 in + let e1',_ = const_prop_exp ref_vars substs assigns e1 in + let e2',_ = const_prop_exp ref_vars substs assigns e2 in + let e3',_ = const_prop_exp ref_vars substs assigns e3 in + e1',e2',e3',assigns + in + let non_det_exp_4 e1 e2 e3 e4 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in + let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in + let assigns = isubst_minus_set assigns assigned_in_e1234 in + let e1',_ = const_prop_exp ref_vars substs assigns e1 in + let e2',_ = const_prop_exp ref_vars substs assigns e2 in + let e3',_ = const_prop_exp ref_vars substs assigns e3 in + let e4',_ = const_prop_exp ref_vars substs assigns e4 in + e1',e2',e3',e4',assigns + in + let re e assigns = E_aux (e,(l,annot)),assigns in + match e with + (* TODO: are there more circumstances in which we should get rid of these? *) + | E_block [e] -> const_prop_exp ref_vars substs assigns e + | E_block es -> + let es',assigns = threaded_map (const_prop_exp ref_vars substs) assigns es in + re (E_block es') assigns + | E_nondet es -> + let es',assigns = non_det_exp_list es in + re (E_nondet es') assigns + | E_id id -> + let env = Type_check.env_of_annot (l, annot) in + (try + match Env.lookup_id id env with + | Local (Immutable,_) -> Bindings.find id (fst substs) + | Local (Mutable,_) -> Bindings.find id assigns + | _ -> exp + with Not_found -> exp),assigns + | E_lit _ + | E_sizeof _ + | E_constraint _ + -> exp,assigns + | E_cast (t,e') -> + let e'',assigns = const_prop_exp ref_vars substs assigns e' in + if is_value e'' + then reduce_cast t e'' l annot, assigns + else re (E_cast (t, e'')) assigns + | E_app (id,es) -> + let es',assigns = non_det_exp_list es in + let env = Type_check.env_of_annot (l, annot) in + (match try_app (l,annot) (id,es') with + | None -> + (match const_prop_try_fn ref_vars l env (id,es') with + | None -> re (E_app (id,es')) assigns + | Some r -> r,assigns) + | Some r -> r,assigns) + | E_tuple es -> + let es',assigns = non_det_exp_list es in + re (E_tuple es') assigns + | E_if (e1,e2,e3) -> + let e1',assigns = const_prop_exp ref_vars substs assigns e1 in + let e1_no_casts = drop_casts e1' in + (match e1_no_casts with + | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) -> + (match lit with + | L_true -> const_prop_exp ref_vars substs assigns e2 + | _ -> const_prop_exp ref_vars substs assigns e3) + | _ -> + (* If the guard is an equality check, propagate the value. *) + let env1 = env_of e1_no_casts in + let is_equal id = + List.exists (fun id' -> Id.compare id id' == 0) + (Env.get_overloads (Id_aux (DeIid "==", Parse_ast.Unknown)) + env1) + in + let substs_true = + match e1_no_casts with + | E_aux (E_app (id, [E_aux (E_id var,_); vl]),_) + | E_aux (E_app (id, [vl; E_aux (E_id var,_)]),_) + when is_equal id -> + if is_value vl then + (match Env.lookup_id var env1 with + | Local (Immutable,_) -> Bindings.add var vl (fst substs),snd substs + | _ -> substs) + else substs + | _ -> substs + in + (* Discard impossible branches *) + if is_env_inconsistent (env_of e2) (snd substs) then + const_prop_exp ref_vars substs assigns e3 + else if is_env_inconsistent (env_of e3) (snd substs) then + const_prop_exp ref_vars substs_true assigns e2 + else + let e2',assigns2 = const_prop_exp ref_vars substs_true assigns e2 in + let e3',assigns3 = const_prop_exp ref_vars substs assigns e3 in + let assigns = isubst_minus_set assigns (assigned_vars e2) in + let assigns = isubst_minus_set assigns (assigned_vars e3) in + re (E_if (e1',e2',e3')) assigns) + | E_for (id,e1,e2,e3,ord,e4) -> + (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *) + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + let assigns = isubst_minus_set assigns (assigned_vars e4) in + let e4',_ = const_prop_exp ref_vars (Bindings.remove id (fst substs),snd substs) assigns e4 in + re (E_for (id,e1',e2',e3',ord,e4')) assigns + | E_loop (loop,e1,e2) -> + let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in + let e1',_ = const_prop_exp ref_vars substs assigns e1 in + let e2',_ = const_prop_exp ref_vars substs assigns e2 in + re (E_loop (loop,e1',e2')) assigns + | E_vector es -> + let es',assigns = non_det_exp_list es in + begin + match construct_lit_vector es' with + | None -> re (E_vector es') assigns + | Some lit -> re (E_lit lit) assigns + end + | E_vector_access (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_vector_access (e1',e2')) assigns + | E_vector_subrange (e1,e2,e3) -> + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + re (E_vector_subrange (e1',e2',e3')) assigns + | E_vector_update (e1,e2,e3) -> + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + re (E_vector_update (e1',e2',e3')) assigns + | E_vector_update_subrange (e1,e2,e3,e4) -> + let e1',e2',e3',e4',assigns = non_det_exp_4 e1 e2 e3 e4 in + re (E_vector_update_subrange (e1',e2',e3',e4')) assigns + | E_vector_append (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_vector_append (e1',e2')) assigns + | E_list es -> + let es',assigns = non_det_exp_list es in + re (E_list es') assigns + | E_cons (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_cons (e1',e2')) assigns + | E_record fes -> + let assigned_in_fes = assigned_vars_in_fexps fes in + let assigns = isubst_minus_set assigns assigned_in_fes in + re (E_record (const_prop_fexps ref_vars substs assigns fes)) assigns + | E_record_update (e,fes) -> + let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in + let assigns = isubst_minus_set assigns assigned_in in + let e',_ = const_prop_exp ref_vars substs assigns e in + re (E_record_update (e', const_prop_fexps ref_vars substs assigns fes)) assigns + | E_field (e,id) -> + let e',assigns = const_prop_exp ref_vars substs assigns e in + re (E_field (e',id)) assigns + | E_case (e,cases) -> + let e',assigns = const_prop_exp ref_vars substs assigns e in + (match can_match ref_vars e' cases substs assigns with + | None -> + let assigned_in = + List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe)) + IdSet.empty cases + in + let assigns' = isubst_minus_set assigns assigned_in in + re (E_case (e', List.map (const_prop_pexp ref_vars substs assigns) cases)) assigns' + | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) -> + let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in + let newbindings_env = bindings_from_list newbindings in + let substs' = bindings_union (fst substs) newbindings_env, snd substs in + const_prop_exp ref_vars substs' assigns exp) + | E_let (lb,e2) -> + begin + match lb with + | LB_aux (LB_val (p,e), annot) -> + let e',assigns = const_prop_exp ref_vars substs assigns e in + let substs' = remove_bound substs p in + let plain () = + let e2',assigns = const_prop_exp ref_vars substs' assigns e2 in + re (E_let (LB_aux (LB_val (p,e'), annot), + e2')) assigns in + if is_value e' && not (is_value e) then + match can_match ref_vars e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with + | None -> plain () + | Some (e'',bindings,kbindings) -> + let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in + let bindings = bindings_from_list bindings in + let substs'' = bindings_union (fst substs') bindings, snd substs' in + const_prop_exp ref_vars substs'' assigns e'' + else plain () + end + (* TODO maybe - tuple assignments *) + | E_assign (le,e) -> + let env = Type_check.env_of_annot (l, annot) in + let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in + let assigns = isubst_minus_set assigns assigned_in in + let le',idopt = const_prop_lexp ref_vars substs assigns le in + let e',_ = const_prop_exp ref_vars substs assigns e in + let assigns = + match idopt with + | Some id -> + begin + match Env.lookup_id id env with + | Local (Mutable,_) | Unbound -> + if is_value e' && not (IdSet.mem id ref_vars) + then Bindings.add id (keep_undef_typ e') assigns + else Bindings.remove id assigns + | _ -> assigns + end + | None -> assigns + in + re (E_assign (le', e')) assigns + | E_exit e -> + let e',_ = const_prop_exp ref_vars substs assigns e in + re (E_exit e') Bindings.empty + | E_ref id -> re (E_ref id) Bindings.empty + | E_throw e -> + let e',_ = const_prop_exp ref_vars substs assigns e in + re (E_throw e') Bindings.empty + | E_try (e,cases) -> + (* TODO: try and preserve *any* assignment info *) + let e',_ = const_prop_exp ref_vars substs assigns e in + re (E_case (e', List.map (const_prop_pexp ref_vars substs Bindings.empty) cases)) Bindings.empty + | E_return e -> + let e',_ = const_prop_exp ref_vars substs assigns e in + re (E_return e') Bindings.empty + | E_assert (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_assert (e1',e2')) assigns + + | E_app_infix _ + | E_var _ + | E_internal_plet _ + | E_internal_return _ + | E_internal_value _ + -> raise (Reporting.err_unreachable l __POS__ + ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) + and const_prop_fexps ref_vars substs assigns fes = + List.map (const_prop_fexp ref_vars substs assigns) fes + and const_prop_fexp ref_vars substs assigns (FE_aux (FE_Fexp (id,e), annot)) = + FE_aux (FE_Fexp (id,fst (const_prop_exp ref_vars substs assigns e)),annot) + and const_prop_pexp ref_vars substs assigns = function + | (Pat_aux (Pat_exp (p,e),l)) -> + Pat_aux (Pat_exp (p,fst (const_prop_exp ref_vars (remove_bound substs p) assigns e)),l) + | (Pat_aux (Pat_when (p,e1,e2),l)) -> + let substs' = remove_bound substs p in + let e1',assigns = const_prop_exp ref_vars substs' assigns e1 in + Pat_aux (Pat_when (p, e1', fst (const_prop_exp ref_vars substs' assigns e2)),l) + and const_prop_lexp ref_vars substs assigns ((LEXP_aux (e,annot)) as le) = + let re e = LEXP_aux (e,annot), None in + match e with + | LEXP_id id (* shouldn't end up substituting here *) + | LEXP_cast (_,id) + -> le, Some id + | LEXP_memory (id,es) -> + re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es)) (* or here *) + | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) + | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp ref_vars substs assigns le), fst (const_prop_exp ref_vars substs assigns e))) + | LEXP_vector_range (le,e1,e2) -> + re (LEXP_vector_range (fst (const_prop_lexp ref_vars substs assigns le), + fst (const_prop_exp ref_vars substs assigns e1), + fst (const_prop_exp ref_vars substs assigns e2))) + | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) + | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp ref_vars substs assigns le), id)) + | LEXP_deref e -> + re (LEXP_deref (fst (const_prop_exp ref_vars substs assigns e))) + (* Reduce a function when + 1. all arguments are values, + 2. the function is pure, + 3. the result is a value + (and 4. the function is not scattered, but that's not terribly important) + to try and keep execution time and the results managable. + *) + and const_prop_try_fn ref_vars l env (id,args) = + if not (List.for_all is_value args) then + None + else + let (tq,typ) = Env.get_val_spec_orig id env in + let eff = match typ with + | Typ_aux (Typ_fn (_,_,eff),_) -> Some eff + | _ -> None + in + let Defs ds = defs in + match eff, list_extract (function + | (DEF_fundef (FD_aux (FD_function (_,_,eff,((FCL_aux (FCL_Funcl (id',_),_))::_ as fcls)),_))) + -> if Id.compare id id' = 0 then Some fcls else None + | _ -> None) ds with + | None,_ | _,None -> None + | Some eff,_ when not (is_pure eff) -> None + | Some _,Some fcls -> + let arg = match args with + | [] -> E_aux (E_lit (L_aux (L_unit,Generated l)),(Generated l,empty_tannot)) + | [e] -> e + | _ -> E_aux (E_tuple args,(Generated l,empty_tannot)) in + let cases = List.map (function + | FCL_aux (FCL_Funcl (_,pexp), ann) -> pexp) + fcls in + match can_match_with_env ref_vars env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with + | Some (exp,bindings,kbindings) -> + let substs = bindings_from_list bindings, kbindings_from_list kbindings in + let result,_ = const_prop_exp ref_vars substs Bindings.empty exp in + let result = match result with + | E_aux (E_return e,_) -> e + | _ -> result + in + if is_value result then Some result else None + | None -> None + + and can_match_with_env ref_vars env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = + let rec findpat_generic check_pat description assigns = function + | [] -> (Reporting.print_err l "Monomorphisation" + ("Failed to find a case for " ^ description); None) + | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) + | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> + findpat_generic check_pat description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) + | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx + when pat_id_is_variable env id' -> + Some (exp, [(id', exp0)], []) + | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl + when pat_id_is_variable env id' -> begin + let substs = Bindings.add id' exp0 substs, ksubsts in + let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in + match guard with + | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) + | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | _ -> None + end + | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin + match check_pat p with + | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesMatch (vsubst,ksubst) -> begin + let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in + let substs = bindings_union substs (bindings_from_list vsubst), + kbindings_union ksubsts (kbindings_from_list ksubst) in + let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in + match guard with + | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst) + | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | _ -> None + end + | GiveUp -> None + end + | (Pat_aux (Pat_exp (p,exp),_))::tl -> + match check_pat p with + | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst) + | GiveUp -> None + in + match e with + | E_id id -> + (match Env.lookup_id id env with + | Enum _ -> + let checkpat = function + | P_aux (P_id id',_) + | P_aux (P_app (id',[]),_) -> + if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch + | P_aux (_,(l',_)) -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for enumeration"; GiveUp) + in findpat_generic checkpat (string_of_id id) assigns cases + | _ -> None) + | E_lit (L_aux (lit_e, lit_l)) -> + let checkpat = function + | P_aux (P_lit (L_aux (lit_p, _)),_) -> + if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch + | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> + begin + match lit_e with + | L_num i -> + DoesMatch ([id, E_aux (e,(l,annot))], + [kid,Nexp_aux (Nexp_constant i,Unknown)]) + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + | L_undef -> + let nexp = fabricate_nexp l annot in + let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], + [kid,nexp]) + | _ -> + (Reporting.print_err lit_l "Monomorphisation" + "Unexpected kind of literal for var match"; GiveUp) + end + | P_aux (_,(l',_)) -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + in findpat_generic checkpat "literal" assigns cases + | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> + let checkpat = function + | P_aux (P_vector ps,_) -> + let matches = List.map2 (fun e p -> + match e, p with + | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> + if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch + | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> + DoesMatch ([var, e],[]) + | _ -> GiveUp) es ps in + let final = List.fold_left (fun acc m -> match acc, m with + | _, GiveUp -> GiveUp + | GiveUp, _ -> GiveUp + | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') + | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in + (match final with + | GiveUp -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + | _ -> final) + | _ -> + (Reporting.print_err l "Monomorphisation" + "Unexpected kind of pattern for vector literal"; GiveUp) + in findpat_generic checkpat "vector literal" assigns cases + + | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> + let checkpat = function + | P_aux (P_lit (L_aux (lit_p, _)),_) -> DoesNotMatch + | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + let nexp = fabricate_nexp l annot in + let kids = equal_kids (env_of_annot p_id_annot) kid in + let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in + let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], + KBindings.bindings ksubst) + | P_aux (_,(l',_)) -> + (Reporting.print_err l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + in findpat_generic checkpat "literal" assigns cases + | _ -> None + + and can_match ref_vars exp = + let env = Type_check.env_of exp in + can_match_with_env ref_vars env exp + +in const_prop_exp diff --git a/src/constant_propagation.mli b/src/constant_propagation.mli new file mode 100644 index 00000000..291ec056 --- /dev/null +++ b/src/constant_propagation.mli @@ -0,0 +1,67 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Type_check + +(** [const_prop defs ref_vars substs assigns exp] performs constant propagation + on [exp] where [substs] is a pair of substitutions on immutable variables + and type variables, [assigns] is a substitution on mutable variables, and + [ref_vars] is the set of variable which may have had a reference taken + (and hence we cannot reliably track). *) + +val const_prop : + tannot defs -> + IdSet.t -> + tannot exp Bindings.t * nexp KBindings.t -> + tannot exp Bindings.t -> + tannot exp -> + tannot exp * tannot exp Bindings.t diff --git a/src/monomorphise.ml b/src/monomorphise.ml index f0472385..56349989 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -81,75 +81,6 @@ let kbindings_union s1 s2 = | (Some x), _ -> Some x | _, _ -> None) s1 s2 -let subst_nexp substs nexp = - let rec s_snexp substs (Nexp_aux (ne,l) as nexp) = - let re ne = Nexp_aux (ne,l) in - let s_snexp = s_snexp substs in - match ne with - | Nexp_var (Kid_aux (_,l) as kid) -> - (try KBindings.find kid substs - with Not_found -> nexp) - | Nexp_id _ - | Nexp_constant _ -> nexp - | Nexp_times (n1,n2) -> re (Nexp_times (s_snexp n1, s_snexp n2)) - | Nexp_sum (n1,n2) -> re (Nexp_sum (s_snexp n1, s_snexp n2)) - | Nexp_minus (n1,n2) -> re (Nexp_minus (s_snexp n1, s_snexp n2)) - | Nexp_exp ne -> re (Nexp_exp (s_snexp ne)) - | Nexp_neg ne -> re (Nexp_neg (s_snexp ne)) - | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args)) - in s_snexp substs nexp - -let subst_nc, subst_src_typ, subst_src_typ_arg = - let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = - let snexp nexp = subst_nexp substs nexp in - let snc nc = subst_nc substs nc in - let re nc = NC_aux (nc,l) in - match nc with - | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2)) - | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2)) - | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2)) - | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2)) - | NC_set (kid,is) -> - begin - match KBindings.find kid substs with - | Nexp_aux (Nexp_constant i,_) -> - if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false - | nexp -> - raise (Reporting.err_general l - ("Unable to substitute " ^ string_of_nexp nexp ^ - " into set constraint " ^ string_of_n_constraint n_constraint)) - | exception Not_found -> n_constraint - end - | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2)) - | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2)) - | NC_true - | NC_false - -> n_constraint - | NC_var kid -> re (NC_var kid) - | NC_app (f, args) -> - re (NC_app (f, List.map (s_starg substs) args)) - and s_styp substs ((Typ_aux (t,l)) as ty) = - let re t = Typ_aux (t,l) in - match t with - | Typ_id _ - | Typ_var _ - -> ty - | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e)) - | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2)) - | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) - | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) - | Typ_exist (kopts,nc,t) -> - let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in - re (Typ_exist (kopts,subst_nc substs nc,s_styp substs t)) - | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown" - and s_starg substs (A_aux (ta,l) as targ) = - match ta with - | A_nexp ne -> A_aux (A_nexp (subst_nexp substs ne),l) - | A_typ t -> A_aux (A_typ (s_styp substs t),l) - | A_order _ -> targ - | A_bool nc -> A_aux (A_bool (subst_nc substs nc), l) - in subst_nc, s_styp, s_starg - let make_vector_lit sz i = let f j = if Big_int.equal (Big_int.modulus (Big_int.shift_right i (sz-j-1)) (Big_int.of_int 2)) Big_int.zero then '0' else '1' in let s = String.init sz f in @@ -164,50 +95,6 @@ let tabulate f n = let make_vectors sz = tabulate (make_vector_lit sz) (Big_int.shift_left (Big_int.of_int 1) sz) -let pat_id_is_variable env id = - match Env.lookup_id id env with - (* Unbound is returned for both variables and constructors which take - arguments, but the latter only don't appear in a P_id *) - | Unbound - (* Shadowing of immutable locals is allowed; mutable locals and registers - are rejected by the type checker, so don't matter *) - | Local _ - | Register _ - -> true - | Enum _ -> false - -let rec is_value (E_aux (e,(l,annot))) = - let is_constructor id = - match destruct_tannot annot with - | None -> - (Reporting.print_err l "Monomorphisation" - ("Missing type information for identifier " ^ string_of_id id); - false) (* Be conservative if we have no info *) - | Some (env,_,_) -> - Env.is_union_constructor id env || - (match Env.lookup_id id env with - | Enum _ -> true - | Unbound | Local _ | Register _ -> false) - in - match e with - | E_id id -> is_constructor id - | E_lit _ -> true - | E_tuple es -> List.for_all is_value es - | E_app (id,es) -> is_constructor id && List.for_all is_value es - (* We add casts to undefined to keep the type information in the AST *) - | E_cast (typ,E_aux (E_lit (L_aux (L_undef,_)),_)) -> true -(* TODO: more? *) - | _ -> false - -let is_pure e = - match e with - | Effect_aux (Effect_set [],_) -> true - | _ -> false - -let rec list_extract f = function - | [] -> None - | h::t -> match f h with None -> list_extract f t | Some v -> Some v - let rec cross = function | [] -> failwith "cross" | [(x,l)] -> List.map (fun y -> [(x,y)]) l @@ -232,33 +119,9 @@ let kidset_bigunion = function | [] -> KidSet.empty | h::t -> List.fold_left KidSet.union h t -let rec flatten_constraints = function - | [] -> [] - | (NC_aux (NC_and (nc1,nc2),_))::t -> flatten_constraints (nc1::nc2::t) - | h::t -> h::(flatten_constraints t) - -(* NB: this only looks for direct equalities with the given kid. It would be - better in principle to find the entire set of equal kids, but it isn't - necessary to deal with the fresh kids produced by the type checker while - checking P_var patterns, so we don't do it for now. *) -let equal_kids_ncs kid ncs = - let is_eq = function - | NC_aux (NC_equal (Nexp_aux (Nexp_var var1,_), Nexp_aux (Nexp_var var2,_)),_) -> - if Kid.compare kid var1 == 0 then Some var2 else - if Kid.compare kid var2 == 0 then Some var1 else - None - | _ -> None - in - let kids = Util.map_filter is_eq ncs in - List.fold_left (fun s k -> KidSet.add k s) (KidSet.singleton kid) kids - -let equal_kids env kid = - let ncs = flatten_constraints (Env.get_constraints env) in - equal_kids_ncs kid ncs - (* TODO: deal with non-set constraints, intersections, etc somehow *) let extract_set_nc l var nc = - let vars = equal_kids_ncs var [nc] in + let vars = Spec_analysis.equal_kids_ncs var [nc] in let rec aux_or (NC_aux (nc,l)) = match nc with | NC_equal (Nexp_aux (Nexp_var id,_), Nexp_aux (Nexp_constant n,_)) @@ -306,7 +169,7 @@ let apply_kid_insts kid_insts t = let kid_insts, kids' = split_insts kid_insts in let kid_insts = List.map (fun (v,i) -> (v,Nexp_aux (Nexp_constant i,Generated Unknown))) kid_insts in let subst = kbindings_from_list kid_insts in - kids', subst_src_typ subst t + kids', subst_kids_typ subst t let rec inst_src_type insts (Typ_aux (ty,l) as typ) = match ty with @@ -555,374 +418,6 @@ let refine_constructor refinements l env id args = | exception Not_found -> None -(* Substitute found nexps for variables in an expression, and rename constructors to reflect - specialisation *) - -(* TODO: kid shadowing *) -let nexp_subst_fns substs = - - let s_t t = subst_src_typ substs t in -(* let s_typschm (TypSchm_aux (TypSchm_ts (q,t),l)) = TypSchm_aux (TypSchm_ts (q,s_t t),l) in - hopefully don't need this anyway *)(* - let s_typschm tsh = tsh in*) - let s_tannot tannot = - match destruct_tannot tannot with - | None -> empty_tannot - | Some (env,t,eff) -> mk_tannot env (s_t t) eff (* TODO: what about env? *) - in - let rec s_pat (P_aux (p,(l,annot))) = - let re p = P_aux (p,(l,s_tannot annot)) in - match p with - | P_lit _ | P_wild | P_id _ -> re p - | P_or (p1, p2) -> re (P_or (s_pat p1, s_pat p2)) - | P_not (p) -> re (P_not (s_pat p)) - | P_var (p',tpat) -> re (P_var (s_pat p',tpat)) - | P_as (p',id) -> re (P_as (s_pat p', id)) - | P_typ (ty,p') -> re (P_typ (s_t ty,s_pat p')) - | P_app (id,ps) -> re (P_app (id, List.map s_pat ps)) - | P_record (fps,flag) -> re (P_record (List.map s_fpat fps, flag)) - | P_vector ps -> re (P_vector (List.map s_pat ps)) - | P_vector_concat ps -> re (P_vector_concat (List.map s_pat ps)) - | P_string_append ps -> re (P_string_append (List.map s_pat ps)) - | P_tup ps -> re (P_tup (List.map s_pat ps)) - | P_list ps -> re (P_list (List.map s_pat ps)) - | P_cons (p1,p2) -> re (P_cons (s_pat p1, s_pat p2)) - and s_fpat (FP_aux (FP_Fpat (id, p), (l,annot))) = - FP_aux (FP_Fpat (id, s_pat p), (l,s_tannot annot)) - in - let rec s_exp (E_aux (e,(l,annot))) = - let re e = E_aux (e,(l,s_tannot annot)) in - match e with - | E_block es -> re (E_block (List.map s_exp es)) - | E_nondet es -> re (E_nondet (List.map s_exp es)) - | E_id _ - | E_ref _ - | E_lit _ - | E_internal_value _ - -> re e - | E_sizeof ne -> begin - let ne' = subst_nexp substs ne in - match ne' with - | Nexp_aux (Nexp_constant i,l) -> re (E_lit (L_aux (L_num i,l))) - | _ -> re (E_sizeof ne') - end - | E_constraint nc -> re (E_constraint (subst_nc substs nc)) - | E_cast (t,e') -> re (E_cast (s_t t, s_exp e')) - | E_app (id,es) -> re (E_app (id, List.map s_exp es)) - | E_app_infix (e1,id,e2) -> re (E_app_infix (s_exp e1,id,s_exp e2)) - | E_tuple es -> re (E_tuple (List.map s_exp es)) - | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3)) - | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4)) - | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2)) - | E_vector es -> re (E_vector (List.map s_exp es)) - | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2)) - | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3)) - | E_vector_update (e1,e2,e3) -> re (E_vector_update (s_exp e1,s_exp e2,s_exp e3)) - | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (s_exp e1,s_exp e2,s_exp e3,s_exp e4)) - | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2)) - | E_list es -> re (E_list (List.map s_exp es)) - | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2)) - | E_record fes -> re (E_record (List.map s_fexp fes)) - | E_record_update (e,fes) -> re (E_record_update (s_exp e, List.map s_fexp fes)) - | E_field (e,id) -> re (E_field (s_exp e,id)) - | E_case (e,cases) -> re (E_case (s_exp e, List.map s_pexp cases)) - | E_let (lb,e) -> re (E_let (s_letbind lb, s_exp e)) - | E_assign (le,e) -> re (E_assign (s_lexp le, s_exp e)) - | E_exit e -> re (E_exit (s_exp e)) - | E_return e -> re (E_return (s_exp e)) - | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2)) - | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2)) - | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2)) - | E_internal_return e -> re (E_internal_return (s_exp e)) - | E_throw e -> re (E_throw (s_exp e)) - | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases)) - and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) = - FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot)) - and s_pexp = function - | (Pat_aux (Pat_exp (p,e),(l,annot))) -> - Pat_aux (Pat_exp (s_pat p, s_exp e),(l,s_tannot annot)) - | (Pat_aux (Pat_when (p,e1,e2),(l,annot))) -> - Pat_aux (Pat_when (s_pat p, s_exp e1, s_exp e2),(l,s_tannot annot)) - and s_letbind (LB_aux (lb,(l,annot))) = - match lb with - | LB_val (p,e) -> LB_aux (LB_val (s_pat p,s_exp e), (l,s_tannot annot)) - and s_lexp (LEXP_aux (e,(l,annot))) = - let re e = LEXP_aux (e,(l,s_tannot annot)) in - match e with - | LEXP_id _ -> re e - | LEXP_cast (typ,id) -> re (LEXP_cast (s_t typ, id)) - | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map s_exp es)) - | LEXP_tup les -> re (LEXP_tup (List.map s_lexp les)) - | LEXP_vector (le,e) -> re (LEXP_vector (s_lexp le, s_exp e)) - | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (s_lexp le, s_exp e1, s_exp e2)) - | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map s_lexp les)) - | LEXP_field (le,id) -> re (LEXP_field (s_lexp le, id)) - | LEXP_deref e -> re (LEXP_deref (s_exp e)) - in (s_pat,s_exp) -let nexp_subst_pat substs = fst (nexp_subst_fns substs) -let nexp_subst_exp substs = snd (nexp_subst_fns substs) - -let bindings_from_pat p = - let rec aux_pat (P_aux (p,(l,annot))) = - let env = Type_check.env_of_annot (l, annot) in - match p with - | P_lit _ - | P_wild - -> [] - | P_or (p1, p2) -> aux_pat p1 @ aux_pat p2 - | P_not (p) -> aux_pat p - | P_as (p,id) -> id::(aux_pat p) - | P_typ (_,p) -> aux_pat p - | P_id id -> - if pat_id_is_variable env id then [id] else [] - | P_var (p,kid) -> aux_pat p - | P_vector ps - | P_vector_concat ps - | P_string_append ps - | P_app (_,ps) - | P_tup ps - | P_list ps - -> List.concat (List.map aux_pat ps) - | P_record (fps,_) -> List.concat (List.map aux_fpat fps) - | P_cons (p1,p2) -> aux_pat p1 @ aux_pat p2 - and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p - in aux_pat p - -let remove_bound (substs,ksubsts) pat = - let bound = bindings_from_pat pat in - List.fold_left (fun sub v -> Bindings.remove v sub) substs bound, ksubsts - -(* Attempt simple pattern matches *) -let lit_match = function - | (L_zero | L_false), (L_zero | L_false) -> true - | (L_one | L_true ), (L_one | L_true ) -> true - | L_num i1, L_num i2 -> Big_int.equal i1 i2 - | l1,l2 -> l1 = l2 - -(* There's no undefined nexp, so replace undefined sizes with a plausible size. - 32 is used as a sensible default. *) - -let fabricate_nexp_exist env l typ kids nc typ' = - match kids,nc,Env.expand_synonyms env typ' with - | ([kid],NC_aux (NC_set (kid',i::_),_), - Typ_aux (Typ_app (Id_aux (Id "atom",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) - when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 -> - Nexp_aux (Nexp_constant i,Unknown) - | ([kid],NC_aux (NC_true,_), - Typ_aux (Typ_app (Id_aux (Id "atom",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_)) - when Kid.compare kid kid'' = 0 -> - nint 32 - | ([kid],NC_aux (NC_set (kid',i::_),_), - Typ_aux (Typ_app (Id_aux (Id "range",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); - A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) - when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 && - Kid.compare kid kid''' = 0 -> - Nexp_aux (Nexp_constant i,Unknown) - | ([kid],NC_aux (NC_true,_), - Typ_aux (Typ_app (Id_aux (Id "range",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_); - A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) - when Kid.compare kid kid'' = 0 && - Kid.compare kid kid''' = 0 -> - nint 32 - | ([], _, typ) -> nint 32 - | (kids, nc, typ) -> - raise (Reporting.err_general l - ("Undefined value at unsupported type " ^ string_of_typ typ ^ " with " ^ Util.string_of_list ", " string_of_kid kids)) - -let fabricate_nexp l tannot = - match destruct_tannot tannot with - | None -> nint 32 - | Some (env,typ,_) -> - match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with - | None -> nint 32 - (* TODO: check this *) - | Some (kopts,nc,typ') -> fabricate_nexp_exist env l typ (List.map kopt_kid kopts) nc typ' - -let atom_typ_kid kid = function - | Typ_aux (Typ_app (Id_aux (Id "atom",_), - [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) -> - Kid.compare kid kid' = 0 - | _ -> false - -(* We reduce casts in a few cases, in particular to ensure that where the - type checker has added a ({'n, true. atom('n)}) ex_int(...) cast we can - fill in the 'n. For undefined we fabricate a suitable value for 'n. *) - -let reduce_cast typ exp l annot = - let env = env_of_annot (l,annot) in - let typ' = Env.base_typ_of env typ in - match exp, destruct_exist (Env.expand_synonyms env typ') with - | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> - let nc_env = Env.add_typ_var l kopt env in - let nc_env = Env.add_constraint (nc_eq (nvar (kopt_kid kopt)) (nconstant n)) nc_env in - if prove __POS__ nc_env nc - then exp - else raise (Reporting.err_unreachable l __POS__ - ("Constant propagation error: literal " ^ Big_int.to_string n ^ - " does not satisfy constraint " ^ string_of_n_constraint nc)) - | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> - let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in - let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in - E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) - | E_aux (E_cast (_, - (E_aux (E_lit (L_aux (L_undef,_)),_) as exp)),_), - Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' -> - let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in - let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in - E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot)) - | _ -> E_aux (E_cast (typ,exp),(l,annot)) - -(* Used for constant propagation in pattern matches *) -type 'a matchresult = - | DoesMatch of 'a - | DoesNotMatch - | GiveUp - -(* Remove top-level casts from an expression. Useful when we need to look at - subexpressions to reduce something, but could break type-checking if we used - it everywhere. *) -let rec drop_casts = function - | E_aux (E_cast (_,e),_) -> drop_casts e - | exp -> exp - -let int_of_str_lit = function - | L_hex hex -> Big_int.of_string ("0x" ^ hex) - | L_bin bin -> Big_int.of_string ("0b" ^ bin) - | _ -> assert false - -let bits_of_lit = function - | L_bin bin -> bin - | L_hex hex -> hex_to_bin hex - | _ -> assert false - -let slice_lit (L_aux (lit,ll)) i len (Ord_aux (ord,_)) = - let i = Big_int.to_int i in - let len = Big_int.to_int len in - let bin = bits_of_lit lit in - match match ord with - | Ord_inc -> Some i - | Ord_dec -> Some (String.length bin - i - len) - | Ord_var _ -> None - with - | None -> None - | Some i -> - Some (L_aux (L_bin (String.sub bin i len),Generated ll)) - -let concat_vec lit1 lit2 = - let bits1 = bits_of_lit lit1 in - let bits2 = bits_of_lit lit2 in - L_bin (bits1 ^ bits2) - -let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = - match l1,l2 with - | (L_zero|L_false), (L_zero|L_false) - | (L_one |L_true ), (L_one |L_true) - -> Some true - | (L_hex _| L_bin _), (L_hex _|L_bin _) - -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2)) - | L_undef, _ | _, L_undef -> None - | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2) - | _ -> Some (l1 = l2) - -let try_app (l,ann) (id,args) = - let new_l = Generated l in - let env = env_of_annot (l,ann) in - let get_overloads f = List.map string_of_id - (Env.get_overloads (Id_aux (Id f, Parse_ast.Unknown)) env @ - Env.get_overloads (Id_aux (DeIid f, Parse_ast.Unknown)) env) in - let is_id f = List.mem (string_of_id id) (f :: get_overloads f) in - if is_id "==" || is_id "!=" then - match args with - | [E_aux (E_lit l1,_); E_aux (E_lit l2,_)] -> - let lit b = if b then L_true else L_false in - let lit b = lit (if is_id "==" then b else not b) in - (match lit_eq l1 l2 with - | None -> None - | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)),(l,ann)))) - | _ -> None - else if is_id "cast_bit_bool" then - match args with - | [E_aux (E_lit L_aux (L_zero,_),_)] -> Some (E_aux (E_lit (L_aux (L_false,new_l)),(l,ann))) - | [E_aux (E_lit L_aux (L_one ,_),_)] -> Some (E_aux (E_lit (L_aux (L_true ,new_l)),(l,ann))) - | _ -> None - else if is_id "UInt" || is_id "unsigned" then - match args with - | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit,_), _)] -> - Some (E_aux (E_lit (L_aux (L_num (int_of_str_lit lit),new_l)),(l,ann))) - | _ -> None - else if is_id "slice" then - match args with - | [E_aux (E_lit (L_aux ((L_hex _| L_bin _),_) as lit), annot); - E_aux (E_lit L_aux (L_num i,_), _); - E_aux (E_lit L_aux (L_num len,_), _)] -> - (match Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) with - | Typ_aux (Typ_app (_,[_;A_aux (A_order ord,_);_]),_) -> - (match slice_lit lit i len ord with - | Some lit' -> Some (E_aux (E_lit lit',(l,ann))) - | None -> None) - | _ -> None) - | _ -> None - else if is_id "bitvector_concat" then - match args with - | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit1,_), _); - E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit2,_), _)] -> - Some (E_aux (E_lit (L_aux (concat_vec lit1 lit2,new_l)),(l,ann))) - | _ -> None - else if is_id "shl_int" then - match args with - | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann))) - | _ -> None - else if is_id "mult_atom" || is_id "mult_int" || is_id "mult_range" then - match args with - | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann))) - | _ -> None - else if is_id "quotient_nat" then - match args with - | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (Big_int.div i j),new_l)),(l,ann))) - | _ -> None - else if is_id "add_atom" || is_id "add_int" || is_id "add_range" then - match args with - | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (Big_int.add i j),new_l)),(l,ann))) - | _ -> None - else if is_id "negate_range" then - match args with - | [E_aux (E_lit L_aux (L_num i,_),_)] -> - Some (E_aux (E_lit (L_aux (L_num (Big_int.negate i),new_l)),(l,ann))) - | _ -> None - else if is_id "ex_int" then - match args with - | [E_aux (E_lit lit,(l,_))] -> Some (E_aux (E_lit lit,(l,ann))) - | [E_aux (E_cast (_,(E_aux (E_lit (L_aux (L_undef,_)),_) as e)),(l,_))] -> - Some (reduce_cast (typ_of_annot (l,ann)) e l ann) - | _ -> None - else if is_id "vector_access" || is_id "bitvector_access" then - match args with - | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_); - E_aux (E_lit L_aux (L_num i,_),_)] -> - let v = int_of_str_lit lit in - let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in - let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in - Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann))) - | _ -> None - else None - - -let construct_lit_vector args = - let rec aux l = function - | [] -> Some (L_aux (L_bin (String.concat "" (List.rev l)),Unknown)) - | E_aux (E_lit (L_aux ((L_zero | L_one) as lit,_)),_)::t -> - aux ((if lit = L_zero then "0" else "1")::l) t - | _ -> None - in aux [] args - type pat_choice = Parse_ast.l * (int * int * (id * tannot exp) list) (* We may need to split up a pattern match if (1) we've been told to case split @@ -937,64 +432,15 @@ type split = list | ConstrSplit of (tannot pat * nexp KBindings.t) list -let threaded_map f state l = - let l',state' = - List.fold_left (fun (tl,state) element -> let (el',state') = f state element in (el'::tl,state')) - ([],state) l - in List.rev l',state' - let isubst_minus subst subst' = Bindings.merge (fun _ x y -> match x,y with (Some a), None -> Some a | _, _ -> None) subst subst' -let isubst_minus_set subst set = - IdSet.fold Bindings.remove set subst - -let assigned_vars exp = - fst (Rewriter.fold_exp - { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with - Rewriter.lEXP_id = (fun id -> IdSet.singleton id, LEXP_id id); - Rewriter.lEXP_cast = (fun (ty,id) -> IdSet.singleton id, LEXP_cast (ty,id)) } - exp) - let referenced_vars exp = let open Rewriter in fst (fold_exp { (compute_exp_alg IdSet.empty IdSet.union) with e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp) -let assigned_vars_in_fexps fes = - List.fold_left - (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e)) - IdSet.empty - fes - -let assigned_vars_in_pexp (Pat_aux (p,_)) = - match p with - | Pat_exp (_,e) -> assigned_vars e - | Pat_when (p,e1,e2) -> IdSet.union (assigned_vars e1) (assigned_vars e2) - -let rec assigned_vars_in_lexp (LEXP_aux (le,_)) = - match le with - | LEXP_id id - | LEXP_cast (_,id) -> IdSet.singleton id - | LEXP_tup lexps - | LEXP_vector_concat lexps -> - List.fold_left (fun vs le -> IdSet.union vs (assigned_vars_in_lexp le)) IdSet.empty lexps - | LEXP_memory (_,es) -> List.fold_left (fun vs e -> IdSet.union vs (assigned_vars e)) IdSet.empty es - | LEXP_vector (le,e) -> IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) - | LEXP_vector_range (le,e1,e2) -> - IdSet.union (assigned_vars_in_lexp le) (IdSet.union (assigned_vars e1) (assigned_vars e2)) - | LEXP_field (le,_) -> assigned_vars_in_lexp le - | LEXP_deref e -> assigned_vars e - -(* Add a cast to undefined so that it retains its type, otherwise it can't be - substituted safely *) -let keep_undef_typ value = - match value with - | E_aux (E_lit (L_aux (L_undef,lann)),eann) -> - E_aux (E_cast (typ_of_annot eann,value),(Generated Unknown,snd eann)) - | _ -> value - let freshen_id = let counter = ref 0 in fun id -> @@ -1174,13 +620,6 @@ let apply_pat_choices choices = e_assert = rewrite_assert; e_case = rewrite_case } -(* Check whether the current environment with the given kid assignments is - inconsistent (and hence whether the code is dead) *) -let is_env_inconsistent env ksubsts = - let env = KBindings.fold (fun k nexp env -> - Env.add_constraint (nc_eq (nvar k) nexp) env) ksubsts env in - prove __POS__ env nc_false - let split_defs all_errors splits defs = let no_errors_happened = ref true in let split_constructors (Defs defs) = @@ -1209,467 +648,9 @@ let split_defs all_errors splits defs = let (refinements, defs') = split_constructors defs in - (* COULD DO: dead code is only eliminated at if expressions, but we could - also cut out impossible case branches and code after assertions. *) - - (* Constant propogation. - Takes maps of immutable/mutable variables to subsitute. - The substs argument also contains the current type-level kid refinements - so that we can check for dead code. - Extremely conservative about evaluation order of assignments in - subexpressions, dropping assignments rather than committing to - any particular order *) - let rec const_prop_exp ref_vars substs assigns ((E_aux (e,(l,annot))) as exp) = - (* Functions to treat lists and tuples of subexpressions as possibly - non-deterministic: that is, we stop making any assumptions about - variables that are assigned to in any of the subexpressions *) - let non_det_exp_list es = - let assigned_in = - List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) - IdSet.empty es in - let assigns = isubst_minus_set assigns assigned_in in - let es' = List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es in - es',assigns - in - let non_det_exp_2 e1 e2 = - let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in - let assigns = isubst_minus_set assigns assigned_in_e12 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - e1',e2',assigns - in - let non_det_exp_3 e1 e2 e3 = - let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in - let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in - let assigns = isubst_minus_set assigns assigned_in_e123 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - let e3',_ = const_prop_exp ref_vars substs assigns e3 in - e1',e2',e3',assigns - in - let non_det_exp_4 e1 e2 e3 e4 = - let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in - let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in - let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in - let assigns = isubst_minus_set assigns assigned_in_e1234 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - let e3',_ = const_prop_exp ref_vars substs assigns e3 in - let e4',_ = const_prop_exp ref_vars substs assigns e4 in - e1',e2',e3',e4',assigns - in - let re e assigns = E_aux (e,(l,annot)),assigns in - match e with - (* TODO: are there more circumstances in which we should get rid of these? *) - | E_block [e] -> const_prop_exp ref_vars substs assigns e - | E_block es -> - let es',assigns = threaded_map (const_prop_exp ref_vars substs) assigns es in - re (E_block es') assigns - | E_nondet es -> - let es',assigns = non_det_exp_list es in - re (E_nondet es') assigns - | E_id id -> - let env = Type_check.env_of_annot (l, annot) in - (try - match Env.lookup_id id env with - | Local (Immutable,_) -> Bindings.find id (fst substs) - | Local (Mutable,_) -> Bindings.find id assigns - | _ -> exp - with Not_found -> exp),assigns - | E_lit _ - | E_sizeof _ - | E_constraint _ - -> exp,assigns - | E_cast (t,e') -> - let e'',assigns = const_prop_exp ref_vars substs assigns e' in - if is_value e'' - then reduce_cast t e'' l annot, assigns - else re (E_cast (t, e'')) assigns - | E_app (id,es) -> - let es',assigns = non_det_exp_list es in - let env = Type_check.env_of_annot (l, annot) in - (match try_app (l,annot) (id,es') with - | None -> - (match const_prop_try_fn ref_vars l env (id,es') with - | None -> re (E_app (id,es')) assigns - | Some r -> r,assigns) - | Some r -> r,assigns) - | E_tuple es -> - let es',assigns = non_det_exp_list es in - re (E_tuple es') assigns - | E_if (e1,e2,e3) -> - let e1',assigns = const_prop_exp ref_vars substs assigns e1 in - let e1_no_casts = drop_casts e1' in - (match e1_no_casts with - | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) -> - (match lit with - | L_true -> const_prop_exp ref_vars substs assigns e2 - | _ -> const_prop_exp ref_vars substs assigns e3) - | _ -> - (* If the guard is an equality check, propagate the value. *) - let env1 = env_of e1_no_casts in - let is_equal id = - List.exists (fun id' -> Id.compare id id' == 0) - (Env.get_overloads (Id_aux (DeIid "==", Parse_ast.Unknown)) - env1) - in - let substs_true = - match e1_no_casts with - | E_aux (E_app (id, [E_aux (E_id var,_); vl]),_) - | E_aux (E_app (id, [vl; E_aux (E_id var,_)]),_) - when is_equal id -> - if is_value vl then - (match Env.lookup_id var env1 with - | Local (Immutable,_) -> Bindings.add var vl (fst substs),snd substs - | _ -> substs) - else substs - | _ -> substs - in - (* Discard impossible branches *) - if is_env_inconsistent (env_of e2) (snd substs) then - const_prop_exp ref_vars substs assigns e3 - else if is_env_inconsistent (env_of e3) (snd substs) then - const_prop_exp ref_vars substs_true assigns e2 - else - let e2',assigns2 = const_prop_exp ref_vars substs_true assigns e2 in - let e3',assigns3 = const_prop_exp ref_vars substs assigns e3 in - let assigns = isubst_minus_set assigns (assigned_vars e2) in - let assigns = isubst_minus_set assigns (assigned_vars e3) in - re (E_if (e1',e2',e3')) assigns) - | E_for (id,e1,e2,e3,ord,e4) -> - (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *) - let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in - let assigns = isubst_minus_set assigns (assigned_vars e4) in - let e4',_ = const_prop_exp ref_vars (Bindings.remove id (fst substs),snd substs) assigns e4 in - re (E_for (id,e1',e2',e3',ord,e4')) assigns - | E_loop (loop,e1,e2) -> - let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - re (E_loop (loop,e1',e2')) assigns - | E_vector es -> - let es',assigns = non_det_exp_list es in - begin - match construct_lit_vector es' with - | None -> re (E_vector es') assigns - | Some lit -> re (E_lit lit) assigns - end - | E_vector_access (e1,e2) -> - let e1',e2',assigns = non_det_exp_2 e1 e2 in - re (E_vector_access (e1',e2')) assigns - | E_vector_subrange (e1,e2,e3) -> - let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in - re (E_vector_subrange (e1',e2',e3')) assigns - | E_vector_update (e1,e2,e3) -> - let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in - re (E_vector_update (e1',e2',e3')) assigns - | E_vector_update_subrange (e1,e2,e3,e4) -> - let e1',e2',e3',e4',assigns = non_det_exp_4 e1 e2 e3 e4 in - re (E_vector_update_subrange (e1',e2',e3',e4')) assigns - | E_vector_append (e1,e2) -> - let e1',e2',assigns = non_det_exp_2 e1 e2 in - re (E_vector_append (e1',e2')) assigns - | E_list es -> - let es',assigns = non_det_exp_list es in - re (E_list es') assigns - | E_cons (e1,e2) -> - let e1',e2',assigns = non_det_exp_2 e1 e2 in - re (E_cons (e1',e2')) assigns - | E_record fes -> - let assigned_in_fes = assigned_vars_in_fexps fes in - let assigns = isubst_minus_set assigns assigned_in_fes in - re (E_record (const_prop_fexps ref_vars substs assigns fes)) assigns - | E_record_update (e,fes) -> - let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in - let assigns = isubst_minus_set assigns assigned_in in - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_record_update (e', const_prop_fexps ref_vars substs assigns fes)) assigns - | E_field (e,id) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in - re (E_field (e',id)) assigns - | E_case (e,cases) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in - (match can_match ref_vars e' cases substs assigns with - | None -> - let assigned_in = - List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe)) - IdSet.empty cases - in - let assigns' = isubst_minus_set assigns assigned_in in - re (E_case (e', List.map (const_prop_pexp ref_vars substs assigns) cases)) assigns' - | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) -> - let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in - let newbindings_env = bindings_from_list newbindings in - let substs' = bindings_union (fst substs) newbindings_env, snd substs in - const_prop_exp ref_vars substs' assigns exp) - | E_let (lb,e2) -> - begin - match lb with - | LB_aux (LB_val (p,e), annot) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in - let substs' = remove_bound substs p in - let plain () = - let e2',assigns = const_prop_exp ref_vars substs' assigns e2 in - re (E_let (LB_aux (LB_val (p,e'), annot), - e2')) assigns in - if is_value e' && not (is_value e) then - match can_match ref_vars e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with - | None -> plain () - | Some (e'',bindings,kbindings) -> - let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in - let bindings = bindings_from_list bindings in - let substs'' = bindings_union (fst substs') bindings, snd substs' in - const_prop_exp ref_vars substs'' assigns e'' - else plain () - end - (* TODO maybe - tuple assignments *) - | E_assign (le,e) -> - let env = Type_check.env_of_annot (l, annot) in - let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in - let assigns = isubst_minus_set assigns assigned_in in - let le',idopt = const_prop_lexp ref_vars substs assigns le in - let e',_ = const_prop_exp ref_vars substs assigns e in - let assigns = - match idopt with - | Some id -> - begin - match Env.lookup_id id env with - | Local (Mutable,_) | Unbound -> - if is_value e' && not (IdSet.mem id ref_vars) - then Bindings.add id (keep_undef_typ e') assigns - else Bindings.remove id assigns - | _ -> assigns - end - | None -> assigns - in - re (E_assign (le', e')) assigns - | E_exit e -> - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_exit e') Bindings.empty - | E_ref id -> re (E_ref id) Bindings.empty - | E_throw e -> - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_throw e') Bindings.empty - | E_try (e,cases) -> - (* TODO: try and preserve *any* assignment info *) - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_case (e', List.map (const_prop_pexp ref_vars substs Bindings.empty) cases)) Bindings.empty - | E_return e -> - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_return e') Bindings.empty - | E_assert (e1,e2) -> - let e1',e2',assigns = non_det_exp_2 e1 e2 in - re (E_assert (e1',e2')) assigns - - | E_app_infix _ - | E_var _ - | E_internal_plet _ - | E_internal_return _ - | E_internal_value _ - -> raise (Reporting.err_unreachable l __POS__ - ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) - and const_prop_fexps ref_vars substs assigns fes = - List.map (const_prop_fexp ref_vars substs assigns) fes - and const_prop_fexp ref_vars substs assigns (FE_aux (FE_Fexp (id,e), annot)) = - FE_aux (FE_Fexp (id,fst (const_prop_exp ref_vars substs assigns e)),annot) - and const_prop_pexp ref_vars substs assigns = function - | (Pat_aux (Pat_exp (p,e),l)) -> - Pat_aux (Pat_exp (p,fst (const_prop_exp ref_vars (remove_bound substs p) assigns e)),l) - | (Pat_aux (Pat_when (p,e1,e2),l)) -> - let substs' = remove_bound substs p in - let e1',assigns = const_prop_exp ref_vars substs' assigns e1 in - Pat_aux (Pat_when (p, e1', fst (const_prop_exp ref_vars substs' assigns e2)),l) - and const_prop_lexp ref_vars substs assigns ((LEXP_aux (e,annot)) as le) = - let re e = LEXP_aux (e,annot), None in - match e with - | LEXP_id id (* shouldn't end up substituting here *) - | LEXP_cast (_,id) - -> le, Some id - | LEXP_memory (id,es) -> - re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es)) (* or here *) - | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) - | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp ref_vars substs assigns le), fst (const_prop_exp ref_vars substs assigns e))) - | LEXP_vector_range (le,e1,e2) -> - re (LEXP_vector_range (fst (const_prop_lexp ref_vars substs assigns le), - fst (const_prop_exp ref_vars substs assigns e1), - fst (const_prop_exp ref_vars substs assigns e2))) - | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) - | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp ref_vars substs assigns le), id)) - | LEXP_deref e -> - re (LEXP_deref (fst (const_prop_exp ref_vars substs assigns e))) - (* Reduce a function when - 1. all arguments are values, - 2. the function is pure, - 3. the result is a value - (and 4. the function is not scattered, but that's not terribly important) - to try and keep execution time and the results managable. - *) - and const_prop_try_fn ref_vars l env (id,args) = - if not (List.for_all is_value args) then - None - else - let (tq,typ) = Env.get_val_spec_orig id env in - let eff = match typ with - | Typ_aux (Typ_fn (_,_,eff),_) -> Some eff - | _ -> None - in - let Defs ds = defs in - match eff, list_extract (function - | (DEF_fundef (FD_aux (FD_function (_,_,eff,((FCL_aux (FCL_Funcl (id',_),_))::_ as fcls)),_))) - -> if Id.compare id id' = 0 then Some fcls else None - | _ -> None) ds with - | None,_ | _,None -> None - | Some eff,_ when not (is_pure eff) -> None - | Some _,Some fcls -> - let arg = match args with - | [] -> E_aux (E_lit (L_aux (L_unit,Generated l)),(Generated l,empty_tannot)) - | [e] -> e - | _ -> E_aux (E_tuple args,(Generated l,empty_tannot)) in - let cases = List.map (function - | FCL_aux (FCL_Funcl (_,pexp), ann) -> pexp) - fcls in - match can_match_with_env ref_vars env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with - | Some (exp,bindings,kbindings) -> - let substs = bindings_from_list bindings, kbindings_from_list kbindings in - let result,_ = const_prop_exp ref_vars substs Bindings.empty exp in - let result = match result with - | E_aux (E_return e,_) -> e - | _ -> result - in - if is_value result then Some result else None - | None -> None - - and can_match_with_env ref_vars env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = - let rec findpat_generic check_pat description assigns = function - | [] -> (Reporting.print_err l "Monomorphisation" - ("Failed to find a case for " ^ description); None) - | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[]) - | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl -> - findpat_generic check_pat description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) - | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx - when pat_id_is_variable env id' -> - Some (exp, [(id', exp0)], []) - | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl - when pat_id_is_variable env id' -> begin - let substs = Bindings.add id' exp0 substs, ksubsts in - let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in - match guard with - | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) - | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl - | _ -> None - end - | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin - match check_pat p with - | DoesNotMatch -> findpat_generic check_pat description assigns tl - | DoesMatch (vsubst,ksubst) -> begin - let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in - let substs = bindings_union substs (bindings_from_list vsubst), - kbindings_union ksubsts (kbindings_from_list ksubst) in - let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in - match guard with - | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst) - | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl - | _ -> None - end - | GiveUp -> None - end - | (Pat_aux (Pat_exp (p,exp),_))::tl -> - match check_pat p with - | DoesNotMatch -> findpat_generic check_pat description assigns tl - | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst) - | GiveUp -> None - in - match e with - | E_id id -> - (match Env.lookup_id id env with - | Enum _ -> - let checkpat = function - | P_aux (P_id id',_) - | P_aux (P_app (id',[]),_) -> - if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for enumeration"; GiveUp) - in findpat_generic checkpat (string_of_id id) assigns cases - | _ -> None) - | E_lit (L_aux (lit_e, lit_l)) -> - let checkpat = function - | P_aux (P_lit (L_aux (lit_p, _)),_) -> - if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch - | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> - begin - match lit_e with - | L_num i -> - DoesMatch ([id, E_aux (e,(l,annot))], - [kid,Nexp_aux (Nexp_constant i,Unknown)]) - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - | L_undef -> - let nexp = fabricate_nexp l annot in - let typ = subst_src_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))], - [kid,nexp]) - | _ -> - (Reporting.print_err lit_l "Monomorphisation" - "Unexpected kind of literal for var match"; GiveUp) - end - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - in findpat_generic checkpat "literal" assigns cases - | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es -> - let checkpat = function - | P_aux (P_vector ps,_) -> - let matches = List.map2 (fun e p -> - match e, p with - | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) -> - if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch - | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var -> - DoesMatch ([var, e],[]) - | _ -> GiveUp) es ps in - let final = List.fold_left (fun acc m -> match acc, m with - | _, GiveUp -> GiveUp - | GiveUp, _ -> GiveUp - | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub') - | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in - (match final with - | GiveUp -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - | _ -> final) - | _ -> - (Reporting.print_err l "Monomorphisation" - "Unexpected kind of pattern for vector literal"; GiveUp) - in findpat_generic checkpat "vector literal" assigns cases - - | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) -> - let checkpat = function - | P_aux (P_lit (L_aux (lit_p, _)),_) -> DoesNotMatch - | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) -> - (* For undefined we fix the type-level size (because there's no good - way to construct an undefined size), but leave the term as undefined - to make the meaning clear. *) - let nexp = fabricate_nexp l annot in - let kids = equal_kids (env_of_annot p_id_annot) kid in - let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in - let typ = subst_src_typ ksubst (typ_of_annot p_id_annot) in - DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))], - KBindings.bindings ksubst) - | P_aux (_,(l',_)) -> - (Reporting.print_err l' "Monomorphisation" - "Unexpected kind of pattern for literal"; GiveUp) - in findpat_generic checkpat "literal" assigns cases - | _ -> None - - and can_match ref_vars exp = - let env = Type_check.env_of exp in - can_match_with_env ref_vars env exp - in - let subst_exp ref_vars substs ksubsts exp = let substs = bindings_from_list substs, ksubsts in - fst (const_prop_exp ref_vars substs Bindings.empty exp) + fst (Constant_propagation.const_prop defs ref_vars substs Bindings.empty exp) in (* Split a variable pattern into every possible value *) @@ -1824,7 +805,7 @@ let split_defs all_errors splits defs = (match spl p' with | None -> None | Some ps -> - let kids = equal_kids (env_of_pat p') kid in + let kids = Spec_analysis.equal_kids (env_of_pat p') kid in Some (List.map (fun (p,sub,pchoices,ksub) -> P_aux (P_var (p,tp),(l,annot)), sub, pchoices, List.concat @@ -1949,7 +930,7 @@ let split_defs all_errors splits defs = match match_l l with | [] -> p | lvs -> - let pvs = bindings_from_pat p in + let pvs = Spec_analysis.bindings_from_pat p in let pvs = List.map string_of_id pvs in let overlap = List.exists (fun (v,_) -> List.mem v pvs) lvs in let () = @@ -2033,7 +1014,7 @@ let split_defs all_errors splits defs = if check_split_size patsubsts (pat_loc p) then List.map (fun (pat',substs,pchoices,ksubsts) -> let ksubsts = kbindings_from_list ksubsts in - let exp' = nexp_subst_exp ksubsts e in + let exp' = Spec_analysis.nexp_subst_exp ksubsts e in let exp' = subst_exp ref_vars substs ksubsts exp' in let exp' = apply_pat_choices pchoices exp' in let exp' = stop_at_false_assertions exp' in @@ -2042,8 +1023,8 @@ let split_defs all_errors splits defs = else nosplit | ConstrSplit patnsubsts -> List.map (fun (pat',nsubst) -> - let pat' = nexp_subst_pat nsubst pat' in - let exp' = nexp_subst_exp nsubst e in + let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in + let exp' = Spec_analysis.nexp_subst_exp nsubst e in Pat_aux (Pat_exp (pat', map_exp exp'),l) ) patnsubsts) | Pat_aux (Pat_when (p,e1,e2),l) -> @@ -2054,10 +1035,10 @@ let split_defs all_errors splits defs = if check_split_size patsubsts (pat_loc p) then List.map (fun (pat',substs,pchoices,ksubsts) -> let ksubsts = kbindings_from_list ksubsts in - let exp1' = nexp_subst_exp ksubsts e1 in + let exp1' = Spec_analysis.nexp_subst_exp ksubsts e1 in let exp1' = subst_exp ref_vars substs ksubsts exp1' in let exp1' = apply_pat_choices pchoices exp1' in - let exp2' = nexp_subst_exp ksubsts e2 in + let exp2' = Spec_analysis.nexp_subst_exp ksubsts e2 in let exp2' = subst_exp ref_vars substs ksubsts exp2' in let exp2' = apply_pat_choices pchoices exp2' in let exp2' = stop_at_false_assertions exp2' in @@ -2066,9 +1047,9 @@ let split_defs all_errors splits defs = else nosplit | ConstrSplit patnsubsts -> List.map (fun (pat',nsubst) -> - let pat' = nexp_subst_pat nsubst pat' in - let exp1' = nexp_subst_exp nsubst e1 in - let exp2' = nexp_subst_exp nsubst e2 in + let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in + let exp1' = Spec_analysis.nexp_subst_exp nsubst e1 in + let exp2' = Spec_analysis.nexp_subst_exp nsubst e2 in Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l) ) patnsubsts) and map_letbind (LB_aux (lb,annot)) = @@ -2798,12 +1779,12 @@ let update_env_new_kids env deps typ_env_pre typ_env_post = plus any new type variables. *) let update_env env deps pat typ_env_pre typ_env_post = - let bound = bindings_from_pat pat in + let bound = Spec_analysis.bindings_from_pat pat in let var_deps = List.fold_left (fun ds v -> Bindings.add v deps ds) env.var_deps bound in update_env_new_kids { env with var_deps = var_deps } deps typ_env_pre typ_env_post let assigned_vars_exps es = - List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) + List.fold_left (fun vs exp -> IdSet.union vs (Spec_analysis.assigned_vars exp)) IdSet.empty es (* For adding control dependencies to mutable variables *) @@ -3290,7 +2271,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = let Typ_aux (typ,_) = Env.base_typ_of env (typ_of_annot annot) in match typ with | Typ_app (Id_aux (Id "atom",_),[A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]) -> - equal_kids env kid + Spec_analysis.equal_kids env kid | _ -> KidSet.empty in let default_split annot kids = @@ -3365,7 +2346,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = let s,v,k = aux pat in let kids = kids_bound_by_typ_pat tpat in let kids = KidSet.fold (fun kid s -> - KidSet.union s (equal_kids (env_of_annot (l,annot)) kid)) + KidSet.union s (Spec_analysis.equal_kids (env_of_annot (l,annot)) kid)) kids kids in s,v,KidSet.fold (fun kid k -> KBindings.add kid (Have (s, ExtraSplits.empty)) k) kids k | P_app (_,pats) -> of_list pats @@ -4137,7 +3118,7 @@ let make_bitvector_cast_fns cast_name env quant_kids src_typ target_typ = (* TODO: bound vars *) let make_bitvector_env_casts env quant_kids (kid,i) exp = - let mk_cast var typ exp = (fst (make_bitvector_cast_fns "bitvector_cast_in" env quant_kids typ (subst_src_typ (KBindings.singleton kid (nconstant i)) typ))) var exp in + let mk_cast var typ exp = (fst (make_bitvector_cast_fns "bitvector_cast_in" env quant_kids typ (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ))) var exp in let locals = Env.get_locals env in Bindings.fold (fun var (mut,typ) exp -> if mut = Immutable then mk_cast var typ exp else exp) locals exp @@ -4209,7 +3190,7 @@ let fill_in_type env typ = (match solve_unique env (nvar kid) with | None -> subst | Some n -> KBindings.add kid (nconstant n) subst)) tyvars KBindings.empty in - subst_src_typ subst typ + subst_kids_typ subst typ (* TODO: top-level patterns *) (* TODO: proper environment tracking for variables. Currently we pretend that @@ -4280,7 +3261,7 @@ let add_bitvector_casts (Defs defs) = make_bitvector_env_casts env quant_kids inst body) e2 insts in let insts = List.fold_left (fun insts (kid,i) -> KBindings.add kid (nconstant i) insts) KBindings.empty insts in - let src_typ = subst_src_typ insts result_typ in + let src_typ = subst_kids_typ insts result_typ in let e2' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ e2' in E_aux (E_if (e1,e2',e3), ann) | E_return e' -> diff --git a/src/rewriter.ml b/src/rewriter.ml index 89f64401..edf0d4a5 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -52,7 +52,6 @@ module Big_int = Nat_big_num open Ast open Ast_util open Type_check -open Spec_analysis type 'a rewriters = { rewrite_exp : 'a rewriters -> 'a exp -> 'a exp; diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index e26ea8a2..80bff0dd 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -662,3 +662,212 @@ let top_sort_defs (Defs defs) = List.fold_left add_def_to_graph ([], [], Namemap.empty, Namemap.empty) defs in let components = scc ~original_order:original_order graph in Defs (prelude @ List.concat (List.map (def_of_component graph defset) components)) + + +(* Functions for finding the set of variables assigned to. Used in constant propagation + and monomorphisation. *) + + +let assigned_vars exp = + fst (Rewriter.fold_exp + { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with + Rewriter.lEXP_id = (fun id -> IdSet.singleton id, LEXP_id id); + Rewriter.lEXP_cast = (fun (ty,id) -> IdSet.singleton id, LEXP_cast (ty,id)) } + exp) + +let assigned_vars_in_fexps fes = + List.fold_left + (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e)) + IdSet.empty + fes + +let assigned_vars_in_pexp (Pat_aux (p,_)) = + match p with + | Pat_exp (_,e) -> assigned_vars e + | Pat_when (p,e1,e2) -> IdSet.union (assigned_vars e1) (assigned_vars e2) + +let rec assigned_vars_in_lexp (LEXP_aux (le,_)) = + match le with + | LEXP_id id + | LEXP_cast (_,id) -> IdSet.singleton id + | LEXP_tup lexps + | LEXP_vector_concat lexps -> + List.fold_left (fun vs le -> IdSet.union vs (assigned_vars_in_lexp le)) IdSet.empty lexps + | LEXP_memory (_,es) -> List.fold_left (fun vs e -> IdSet.union vs (assigned_vars e)) IdSet.empty es + | LEXP_vector (le,e) -> IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) + | LEXP_vector_range (le,e1,e2) -> + IdSet.union (assigned_vars_in_lexp le) (IdSet.union (assigned_vars e1) (assigned_vars e2)) + | LEXP_field (le,_) -> assigned_vars_in_lexp le + | LEXP_deref e -> assigned_vars e + + +let pat_id_is_variable env id = + match Type_check.Env.lookup_id id env with + (* Unbound is returned for both variables and constructors which take + arguments, but the latter only don't appear in a P_id *) + | Unbound + (* Shadowing of immutable locals is allowed; mutable locals and registers + are rejected by the type checker, so don't matter *) + | Local _ + | Register _ + -> true + | Enum _ -> false + +let bindings_from_pat p = + let rec aux_pat (P_aux (p,(l,annot))) = + let env = Type_check.env_of_annot (l, annot) in + match p with + | P_lit _ + | P_wild + -> [] + | P_or (p1, p2) -> aux_pat p1 @ aux_pat p2 + | P_not (p) -> aux_pat p + | P_as (p,id) -> id::(aux_pat p) + | P_typ (_,p) -> aux_pat p + | P_id id -> + if pat_id_is_variable env id then [id] else [] + | P_var (p,kid) -> aux_pat p + | P_vector ps + | P_vector_concat ps + | P_string_append ps + | P_app (_,ps) + | P_tup ps + | P_list ps + -> List.concat (List.map aux_pat ps) + | P_record (fps,_) -> List.concat (List.map aux_fpat fps) + | P_cons (p1,p2) -> aux_pat p1 @ aux_pat p2 + and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p + in aux_pat p + + +(* TODO: replace the below with solutions that don't depend so much on the + structure of the environment. *) + +let rec flatten_constraints = function + | [] -> [] + | (NC_aux (NC_and (nc1,nc2),_))::t -> flatten_constraints (nc1::nc2::t) + | h::t -> h::(flatten_constraints t) + +(* NB: this only looks for direct equalities with the given kid. It would be + better in principle to find the entire set of equal kids, but it isn't + necessary to deal with the fresh kids produced by the type checker while + checking P_var patterns, so we don't do it for now. *) +let equal_kids_ncs kid ncs = + let is_eq = function + | NC_aux (NC_equal (Nexp_aux (Nexp_var var1,_), Nexp_aux (Nexp_var var2,_)),_) -> + if Kid.compare kid var1 == 0 then Some var2 else + if Kid.compare kid var2 == 0 then Some var1 else + None + | _ -> None + in + let kids = Util.map_filter is_eq ncs in + List.fold_left (fun s k -> KidSet.add k s) (KidSet.singleton kid) kids + +let equal_kids env kid = + let ncs = flatten_constraints (Type_check.Env.get_constraints env) in + equal_kids_ncs kid ncs + + + +(* TODO: kid shadowing *) +let nexp_subst_fns substs = + let s_t t = subst_kids_typ substs t in +(* let s_typschm (TypSchm_aux (TypSchm_ts (q,t),l)) = TypSchm_aux (TypSchm_ts (q,s_t t),l) in + hopefully don't need this anyway *)(* + let s_typschm tsh = tsh in*) + let s_tannot tannot = + match Type_check.destruct_tannot tannot with + | None -> Type_check.empty_tannot + | Some (env,t,eff) -> Type_check.mk_tannot env (s_t t) eff (* TODO: what about env? *) + in + let rec s_pat (P_aux (p,(l,annot))) = + let re p = P_aux (p,(l,s_tannot annot)) in + match p with + | P_lit _ | P_wild | P_id _ -> re p + | P_or (p1, p2) -> re (P_or (s_pat p1, s_pat p2)) + | P_not (p) -> re (P_not (s_pat p)) + | P_var (p',tpat) -> re (P_var (s_pat p',tpat)) + | P_as (p',id) -> re (P_as (s_pat p', id)) + | P_typ (ty,p') -> re (P_typ (s_t ty,s_pat p')) + | P_app (id,ps) -> re (P_app (id, List.map s_pat ps)) + | P_record (fps,flag) -> re (P_record (List.map s_fpat fps, flag)) + | P_vector ps -> re (P_vector (List.map s_pat ps)) + | P_vector_concat ps -> re (P_vector_concat (List.map s_pat ps)) + | P_string_append ps -> re (P_string_append (List.map s_pat ps)) + | P_tup ps -> re (P_tup (List.map s_pat ps)) + | P_list ps -> re (P_list (List.map s_pat ps)) + | P_cons (p1,p2) -> re (P_cons (s_pat p1, s_pat p2)) + and s_fpat (FP_aux (FP_Fpat (id, p), (l,annot))) = + FP_aux (FP_Fpat (id, s_pat p), (l,s_tannot annot)) + in + let rec s_exp (E_aux (e,(l,annot))) = + let re e = E_aux (e,(l,s_tannot annot)) in + match e with + | E_block es -> re (E_block (List.map s_exp es)) + | E_nondet es -> re (E_nondet (List.map s_exp es)) + | E_id _ + | E_ref _ + | E_lit _ + | E_internal_value _ + -> re e + | E_sizeof ne -> begin + let ne' = subst_kids_nexp substs ne in + match ne' with + | Nexp_aux (Nexp_constant i,l) -> re (E_lit (L_aux (L_num i,l))) + | _ -> re (E_sizeof ne') + end + | E_constraint nc -> re (E_constraint (subst_kids_nc substs nc)) + | E_cast (t,e') -> re (E_cast (s_t t, s_exp e')) + | E_app (id,es) -> re (E_app (id, List.map s_exp es)) + | E_app_infix (e1,id,e2) -> re (E_app_infix (s_exp e1,id,s_exp e2)) + | E_tuple es -> re (E_tuple (List.map s_exp es)) + | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3)) + | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4)) + | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2)) + | E_vector es -> re (E_vector (List.map s_exp es)) + | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2)) + | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3)) + | E_vector_update (e1,e2,e3) -> re (E_vector_update (s_exp e1,s_exp e2,s_exp e3)) + | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (s_exp e1,s_exp e2,s_exp e3,s_exp e4)) + | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2)) + | E_list es -> re (E_list (List.map s_exp es)) + | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2)) + | E_record fes -> re (E_record (List.map s_fexp fes)) + | E_record_update (e,fes) -> re (E_record_update (s_exp e, List.map s_fexp fes)) + | E_field (e,id) -> re (E_field (s_exp e,id)) + | E_case (e,cases) -> re (E_case (s_exp e, List.map s_pexp cases)) + | E_let (lb,e) -> re (E_let (s_letbind lb, s_exp e)) + | E_assign (le,e) -> re (E_assign (s_lexp le, s_exp e)) + | E_exit e -> re (E_exit (s_exp e)) + | E_return e -> re (E_return (s_exp e)) + | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2)) + | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2)) + | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2)) + | E_internal_return e -> re (E_internal_return (s_exp e)) + | E_throw e -> re (E_throw (s_exp e)) + | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases)) + and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) = + FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot)) + and s_pexp = function + | (Pat_aux (Pat_exp (p,e),(l,annot))) -> + Pat_aux (Pat_exp (s_pat p, s_exp e),(l,s_tannot annot)) + | (Pat_aux (Pat_when (p,e1,e2),(l,annot))) -> + Pat_aux (Pat_when (s_pat p, s_exp e1, s_exp e2),(l,s_tannot annot)) + and s_letbind (LB_aux (lb,(l,annot))) = + match lb with + | LB_val (p,e) -> LB_aux (LB_val (s_pat p,s_exp e), (l,s_tannot annot)) + and s_lexp (LEXP_aux (e,(l,annot))) = + let re e = LEXP_aux (e,(l,s_tannot annot)) in + match e with + | LEXP_id _ -> re e + | LEXP_cast (typ,id) -> re (LEXP_cast (s_t typ, id)) + | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map s_exp es)) + | LEXP_tup les -> re (LEXP_tup (List.map s_lexp les)) + | LEXP_vector (le,e) -> re (LEXP_vector (s_lexp le, s_exp e)) + | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (s_lexp le, s_exp e1, s_exp e2)) + | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map s_lexp les)) + | LEXP_field (le,id) -> re (LEXP_field (s_lexp le, id)) + | LEXP_deref e -> re (LEXP_deref (s_exp e)) + in (s_pat,s_exp) +let nexp_subst_pat substs = fst (nexp_subst_fns substs) +let nexp_subst_exp substs = snd (nexp_subst_fns substs) diff --git a/src/spec_analysis.mli b/src/spec_analysis.mli index f13dd596..8586ac15 100644 --- a/src/spec_analysis.mli +++ b/src/spec_analysis.mli @@ -49,6 +49,7 @@ (**************************************************************************) open Ast +open Ast_util open Util open Type_check @@ -76,3 +77,21 @@ val is_within_machine64 : typ -> nexp_range list -> triple *) (* val restrict_defs : 'a defs -> string list -> 'a defs *) val top_sort_defs : tannot defs -> tannot defs + +(** Return the set of mutable variables assigned to in the given AST. *) +val assigned_vars : 'a exp -> IdSet.t +val assigned_vars_in_fexps : 'a fexp list -> IdSet.t +val assigned_vars_in_pexp : 'a pexp -> IdSet.t +val assigned_vars_in_lexp : 'a lexp -> IdSet.t + +(** Variable bindings in patterns *) +val pat_id_is_variable : env -> id -> bool +val bindings_from_pat : tannot pat -> id list + +val equal_kids_ncs : kid -> n_constraint list -> KidSet.t +val equal_kids : env -> kid -> KidSet.t + +(** Type-level substitutions into patterns and expressions. Also attempts to + update type annotations, but not the associated environments. *) +val nexp_subst_pat : nexp KBindings.t -> tannot pat -> tannot pat +val nexp_subst_exp : nexp KBindings.t -> tannot exp -> tannot exp -- cgit v1.2.3 From dc60b5018596669090b5d6761f24b2e8801546e9 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 6 Mar 2019 17:07:09 +0000 Subject: Simplify handling of referenced variables in constant propagation --- src/constant_propagation.ml | 149 ++++++++++++++++++++++--------------------- src/constant_propagation.mli | 2 + src/monomorphise.ml | 14 ++-- 3 files changed, 84 insertions(+), 81 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index c44692b3..015b615e 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -374,8 +374,8 @@ let is_env_inconsistent env ksubsts = prove __POS__ env nc_false -let const_prop defs = - let rec const_prop_exp ref_vars substs assigns ((E_aux (e,(l,annot))) as exp) = +let const_prop defs ref_vars = + let rec const_prop_exp substs assigns ((E_aux (e,(l,annot))) as exp) = (* Functions to treat lists and tuples of subexpressions as possibly non-deterministic: that is, we stop making any assumptions about variables that are assigned to in any of the subexpressions *) @@ -384,23 +384,23 @@ let const_prop defs = List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) IdSet.empty es in let assigns = isubst_minus_set assigns assigned_in in - let es' = List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es in + let es' = List.map (fun e -> fst (const_prop_exp substs assigns e)) es in es',assigns in let non_det_exp_2 e1 e2 = let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in let assigns = isubst_minus_set assigns assigned_in_e12 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in e1',e2',assigns in let non_det_exp_3 e1 e2 e3 = let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in let assigns = isubst_minus_set assigns assigned_in_e123 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - let e3',_ = const_prop_exp ref_vars substs assigns e3 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + let e3',_ = const_prop_exp substs assigns e3 in e1',e2',e3',assigns in let non_det_exp_4 e1 e2 e3 e4 = @@ -408,18 +408,18 @@ let const_prop defs = let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in let assigns = isubst_minus_set assigns assigned_in_e1234 in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in - let e3',_ = const_prop_exp ref_vars substs assigns e3 in - let e4',_ = const_prop_exp ref_vars substs assigns e4 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + let e3',_ = const_prop_exp substs assigns e3 in + let e4',_ = const_prop_exp substs assigns e4 in e1',e2',e3',e4',assigns in let re e assigns = E_aux (e,(l,annot)),assigns in match e with (* TODO: are there more circumstances in which we should get rid of these? *) - | E_block [e] -> const_prop_exp ref_vars substs assigns e + | E_block [e] -> const_prop_exp substs assigns e | E_block es -> - let es',assigns = threaded_map (const_prop_exp ref_vars substs) assigns es in + let es',assigns = threaded_map (const_prop_exp substs) assigns es in re (E_block es') assigns | E_nondet es -> let es',assigns = non_det_exp_list es in @@ -437,7 +437,7 @@ let const_prop defs = | E_constraint _ -> exp,assigns | E_cast (t,e') -> - let e'',assigns = const_prop_exp ref_vars substs assigns e' in + let e'',assigns = const_prop_exp substs assigns e' in if is_value e'' then reduce_cast t e'' l annot, assigns else re (E_cast (t, e'')) assigns @@ -446,7 +446,7 @@ let const_prop defs = let env = Type_check.env_of_annot (l, annot) in (match try_app (l,annot) (id,es') with | None -> - (match const_prop_try_fn ref_vars l env (id,es') with + (match const_prop_try_fn l env (id,es') with | None -> re (E_app (id,es')) assigns | Some r -> r,assigns) | Some r -> r,assigns) @@ -454,13 +454,13 @@ let const_prop defs = let es',assigns = non_det_exp_list es in re (E_tuple es') assigns | E_if (e1,e2,e3) -> - let e1',assigns = const_prop_exp ref_vars substs assigns e1 in + let e1',assigns = const_prop_exp substs assigns e1 in let e1_no_casts = drop_casts e1' in (match e1_no_casts with | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) -> (match lit with - | L_true -> const_prop_exp ref_vars substs assigns e2 - | _ -> const_prop_exp ref_vars substs assigns e3) + | L_true -> const_prop_exp substs assigns e2 + | _ -> const_prop_exp substs assigns e3) | _ -> (* If the guard is an equality check, propagate the value. *) let env1 = env_of e1_no_casts in @@ -483,12 +483,12 @@ let const_prop defs = in (* Discard impossible branches *) if is_env_inconsistent (env_of e2) (snd substs) then - const_prop_exp ref_vars substs assigns e3 + const_prop_exp substs assigns e3 else if is_env_inconsistent (env_of e3) (snd substs) then - const_prop_exp ref_vars substs_true assigns e2 + const_prop_exp substs_true assigns e2 else - let e2',assigns2 = const_prop_exp ref_vars substs_true assigns e2 in - let e3',assigns3 = const_prop_exp ref_vars substs assigns e3 in + let e2',assigns2 = const_prop_exp substs_true assigns e2 in + let e3',assigns3 = const_prop_exp substs assigns e3 in let assigns = isubst_minus_set assigns (assigned_vars e2) in let assigns = isubst_minus_set assigns (assigned_vars e3) in re (E_if (e1',e2',e3')) assigns) @@ -496,12 +496,12 @@ let const_prop defs = (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *) let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in let assigns = isubst_minus_set assigns (assigned_vars e4) in - let e4',_ = const_prop_exp ref_vars (Bindings.remove id (fst substs),snd substs) assigns e4 in + let e4',_ = const_prop_exp (Bindings.remove id (fst substs),snd substs) assigns e4 in re (E_for (id,e1',e2',e3',ord,e4')) assigns | E_loop (loop,e1,e2) -> let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in - let e1',_ = const_prop_exp ref_vars substs assigns e1 in - let e2',_ = const_prop_exp ref_vars substs assigns e2 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in re (E_loop (loop,e1',e2')) assigns | E_vector es -> let es',assigns = non_det_exp_list es in @@ -534,48 +534,48 @@ let const_prop defs = | E_record fes -> let assigned_in_fes = assigned_vars_in_fexps fes in let assigns = isubst_minus_set assigns assigned_in_fes in - re (E_record (const_prop_fexps ref_vars substs assigns fes)) assigns + re (E_record (const_prop_fexps substs assigns fes)) assigns | E_record_update (e,fes) -> let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in let assigns = isubst_minus_set assigns assigned_in in - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_record_update (e', const_prop_fexps ref_vars substs assigns fes)) assigns + let e',_ = const_prop_exp substs assigns e in + re (E_record_update (e', const_prop_fexps substs assigns fes)) assigns | E_field (e,id) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in + let e',assigns = const_prop_exp substs assigns e in re (E_field (e',id)) assigns | E_case (e,cases) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in - (match can_match ref_vars e' cases substs assigns with + let e',assigns = const_prop_exp substs assigns e in + (match can_match e' cases substs assigns with | None -> let assigned_in = List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe)) IdSet.empty cases in let assigns' = isubst_minus_set assigns assigned_in in - re (E_case (e', List.map (const_prop_pexp ref_vars substs assigns) cases)) assigns' + re (E_case (e', List.map (const_prop_pexp substs assigns) cases)) assigns' | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) -> let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in let newbindings_env = bindings_from_list newbindings in let substs' = bindings_union (fst substs) newbindings_env, snd substs in - const_prop_exp ref_vars substs' assigns exp) + const_prop_exp substs' assigns exp) | E_let (lb,e2) -> begin match lb with | LB_aux (LB_val (p,e), annot) -> - let e',assigns = const_prop_exp ref_vars substs assigns e in + let e',assigns = const_prop_exp substs assigns e in let substs' = remove_bound substs p in let plain () = - let e2',assigns = const_prop_exp ref_vars substs' assigns e2 in + let e2',assigns = const_prop_exp substs' assigns e2 in re (E_let (LB_aux (LB_val (p,e'), annot), e2')) assigns in if is_value e' && not (is_value e) then - match can_match ref_vars e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with + match can_match e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with | None -> plain () | Some (e'',bindings,kbindings) -> let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in let bindings = bindings_from_list bindings in let substs'' = bindings_union (fst substs') bindings, snd substs' in - const_prop_exp ref_vars substs'' assigns e'' + const_prop_exp substs'' assigns e'' else plain () end (* TODO maybe - tuple assignments *) @@ -583,8 +583,8 @@ let const_prop defs = let env = Type_check.env_of_annot (l, annot) in let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in let assigns = isubst_minus_set assigns assigned_in in - let le',idopt = const_prop_lexp ref_vars substs assigns le in - let e',_ = const_prop_exp ref_vars substs assigns e in + let le',idopt = const_prop_lexp substs assigns le in + let e',_ = const_prop_exp substs assigns e in let assigns = match idopt with | Some id -> @@ -600,18 +600,18 @@ let const_prop defs = in re (E_assign (le', e')) assigns | E_exit e -> - let e',_ = const_prop_exp ref_vars substs assigns e in + let e',_ = const_prop_exp substs assigns e in re (E_exit e') Bindings.empty | E_ref id -> re (E_ref id) Bindings.empty | E_throw e -> - let e',_ = const_prop_exp ref_vars substs assigns e in + let e',_ = const_prop_exp substs assigns e in re (E_throw e') Bindings.empty | E_try (e,cases) -> (* TODO: try and preserve *any* assignment info *) - let e',_ = const_prop_exp ref_vars substs assigns e in - re (E_case (e', List.map (const_prop_pexp ref_vars substs Bindings.empty) cases)) Bindings.empty + let e',_ = const_prop_exp substs assigns e in + re (E_case (e', List.map (const_prop_pexp substs Bindings.empty) cases)) Bindings.empty | E_return e -> - let e',_ = const_prop_exp ref_vars substs assigns e in + let e',_ = const_prop_exp substs assigns e in re (E_return e') Bindings.empty | E_assert (e1,e2) -> let e1',e2',assigns = non_det_exp_2 e1 e2 in @@ -624,35 +624,35 @@ let const_prop defs = | E_internal_value _ -> raise (Reporting.err_unreachable l __POS__ ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) - and const_prop_fexps ref_vars substs assigns fes = - List.map (const_prop_fexp ref_vars substs assigns) fes - and const_prop_fexp ref_vars substs assigns (FE_aux (FE_Fexp (id,e), annot)) = - FE_aux (FE_Fexp (id,fst (const_prop_exp ref_vars substs assigns e)),annot) - and const_prop_pexp ref_vars substs assigns = function + and const_prop_fexps substs assigns fes = + List.map (const_prop_fexp substs assigns) fes + and const_prop_fexp substs assigns (FE_aux (FE_Fexp (id,e), annot)) = + FE_aux (FE_Fexp (id,fst (const_prop_exp substs assigns e)),annot) + and const_prop_pexp substs assigns = function | (Pat_aux (Pat_exp (p,e),l)) -> - Pat_aux (Pat_exp (p,fst (const_prop_exp ref_vars (remove_bound substs p) assigns e)),l) + Pat_aux (Pat_exp (p,fst (const_prop_exp (remove_bound substs p) assigns e)),l) | (Pat_aux (Pat_when (p,e1,e2),l)) -> let substs' = remove_bound substs p in - let e1',assigns = const_prop_exp ref_vars substs' assigns e1 in - Pat_aux (Pat_when (p, e1', fst (const_prop_exp ref_vars substs' assigns e2)),l) - and const_prop_lexp ref_vars substs assigns ((LEXP_aux (e,annot)) as le) = + let e1',assigns = const_prop_exp substs' assigns e1 in + Pat_aux (Pat_when (p, e1', fst (const_prop_exp substs' assigns e2)),l) + and const_prop_lexp substs assigns ((LEXP_aux (e,annot)) as le) = let re e = LEXP_aux (e,annot), None in match e with | LEXP_id id (* shouldn't end up substituting here *) | LEXP_cast (_,id) -> le, Some id | LEXP_memory (id,es) -> - re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es)) (* or here *) - | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) - | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp ref_vars substs assigns le), fst (const_prop_exp ref_vars substs assigns e))) + re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp substs assigns e)) es)) (* or here *) + | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp substs assigns le)) les)) + | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp substs assigns le), fst (const_prop_exp substs assigns e))) | LEXP_vector_range (le,e1,e2) -> - re (LEXP_vector_range (fst (const_prop_lexp ref_vars substs assigns le), - fst (const_prop_exp ref_vars substs assigns e1), - fst (const_prop_exp ref_vars substs assigns e2))) - | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les)) - | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp ref_vars substs assigns le), id)) + re (LEXP_vector_range (fst (const_prop_lexp substs assigns le), + fst (const_prop_exp substs assigns e1), + fst (const_prop_exp substs assigns e2))) + | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp substs assigns le)) les)) + | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp substs assigns le), id)) | LEXP_deref e -> - re (LEXP_deref (fst (const_prop_exp ref_vars substs assigns e))) + re (LEXP_deref (fst (const_prop_exp substs assigns e))) (* Reduce a function when 1. all arguments are values, 2. the function is pure, @@ -660,7 +660,7 @@ let const_prop defs = (and 4. the function is not scattered, but that's not terribly important) to try and keep execution time and the results managable. *) - and const_prop_try_fn ref_vars l env (id,args) = + and const_prop_try_fn l env (id,args) = if not (List.for_all is_value args) then None else @@ -684,10 +684,10 @@ let const_prop defs = let cases = List.map (function | FCL_aux (FCL_Funcl (_,pexp), ann) -> pexp) fcls in - match can_match_with_env ref_vars env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with + match can_match_with_env env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with | Some (exp,bindings,kbindings) -> let substs = bindings_from_list bindings, kbindings_from_list kbindings in - let result,_ = const_prop_exp ref_vars substs Bindings.empty exp in + let result,_ = const_prop_exp substs Bindings.empty exp in let result = match result with | E_aux (E_return e,_) -> e | _ -> result @@ -695,7 +695,7 @@ let const_prop defs = if is_value result then Some result else None | None -> None - and can_match_with_env ref_vars env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = + and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns = let rec findpat_generic check_pat description assigns = function | [] -> (Reporting.print_err l "Monomorphisation" ("Failed to find a case for " ^ description); None) @@ -708,7 +708,7 @@ let const_prop defs = | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl when pat_id_is_variable env id' -> begin let substs = Bindings.add id' exp0 substs, ksubsts in - let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in + let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in match guard with | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl @@ -721,7 +721,7 @@ let const_prop defs = let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in let substs = bindings_union substs (bindings_from_list vsubst), kbindings_union ksubsts (kbindings_from_list ksubst) in - let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in + let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in match guard with | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst) | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl @@ -818,8 +818,15 @@ let const_prop defs = in findpat_generic checkpat "literal" assigns cases | _ -> None - and can_match ref_vars exp = + and can_match exp = let env = Type_check.env_of exp in - can_match_with_env ref_vars env exp + can_match_with_env env exp in const_prop_exp + + +let referenced_vars exp = + let open Rewriter in + fst (fold_exp + { (compute_exp_alg IdSet.empty IdSet.union) with + e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp) diff --git a/src/constant_propagation.mli b/src/constant_propagation.mli index 291ec056..1537b927 100644 --- a/src/constant_propagation.mli +++ b/src/constant_propagation.mli @@ -65,3 +65,5 @@ val const_prop : tannot exp Bindings.t -> tannot exp -> tannot exp * tannot exp Bindings.t + +val referenced_vars : tannot exp -> IdSet.t diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 56349989..07063ac4 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -435,12 +435,6 @@ type split = let isubst_minus subst subst' = Bindings.merge (fun _ x y -> match x,y with (Some a), None -> Some a | _, _ -> None) subst subst' -let referenced_vars exp = - let open Rewriter in - fst (fold_exp - { (compute_exp_alg IdSet.empty IdSet.union) with - e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp) - let freshen_id = let counter = ref 0 in fun id -> @@ -1074,7 +1068,7 @@ let split_defs all_errors splits defs = let map_pexp r = let (_,f,_) = map_fns r in f in let map_letbind r = let (_,_,f) = map_fns r in f in let map_exp exp = - let ref_vars = referenced_vars exp in + let ref_vars = Constant_propagation.referenced_vars exp in map_exp ref_vars exp in let map_pexp top_pexp = @@ -1082,11 +1076,11 @@ let split_defs all_errors splits defs = make false assumptions about them during constant propagation. Note that we assume there aren't any in the guard. *) let (_,_,body,_) = destruct_pexp top_pexp in - let ref_vars = referenced_vars body in + let ref_vars = Constant_propagation.referenced_vars body in map_pexp ref_vars top_pexp in let map_letbind (LB_aux (LB_val (_,e),_) as lb) = - let ref_vars = referenced_vars e in + let ref_vars = Constant_propagation.referenced_vars e in map_letbind ref_vars lb in @@ -2387,7 +2381,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions = | _, _ -> None in let kid_deps = KBindings.merge merge_kid_deps_eqns kid_deps eqn_kid_deps in - let referenced_vars = referenced_vars body in + let referenced_vars = Constant_propagation.referenced_vars body in { top_kids; var_deps; kid_deps; referenced_vars } (* When there's more than one pick the first *) -- cgit v1.2.3 From 21043d3e70279109d7c721735d83c084d25784e2 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Thu, 7 Mar 2019 11:58:43 +0000 Subject: Add a rewrite to remove impossible cases on integer literals (e.g., for the dual 32/64 bit RISC-V model) Apply this rewrite in Coq backend. --- src/constant_propagation.ml | 40 ++++++++++++++++++++++++++++++++++++++-- src/constant_propagation.mli | 2 ++ src/rewrites.ml | 1 + 3 files changed, 41 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index 015b615e..c3e00753 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -374,7 +374,7 @@ let is_env_inconsistent env ksubsts = prove __POS__ env nc_false -let const_prop defs ref_vars = +let const_props defs ref_vars = let rec const_prop_exp substs assigns ((E_aux (e,(l,annot))) as exp) = (* Functions to treat lists and tuples of subexpressions as possibly non-deterministic: that is, we stop making any assumptions about @@ -822,11 +822,47 @@ let const_prop defs ref_vars = let env = Type_check.env_of exp in can_match_with_env env exp -in const_prop_exp +in (const_prop_exp, const_prop_pexp) +let const_prop d r = fst (const_props d r) +let const_prop_pexp d r = snd (const_props d r) let referenced_vars exp = let open Rewriter in fst (fold_exp { (compute_exp_alg IdSet.empty IdSet.union) with e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp) + +(* This is intended to remove impossible cases when a type-level constant has + been used to fix a property of the architecture. In particular, the current + version of the RISC-V model uses constructs like + + match (width, sizeof(xlen)) { + (BYTE, _) => ... + ... + (DOUBLE, 64) => ... + }; + + and the type checker will replace the sizeof with the literal 32 or 64. This + pass will then remove the DOUBLE case. + + It would be nice to have the full constant propagation above do this kind of + thing too... +*) + +let remove_impossible_int_cases _ = + + let must_keep_case exp (Pat_aux ((Pat_exp (p,_) | Pat_when (p,_,_)),_)) = + let rec aux (E_aux (exp,_)) (P_aux (p,_)) = + match exp, p with + | E_tuple exps, P_tup ps -> List.for_all2 aux exps ps + | E_lit (L_aux (lit,_)), P_lit (L_aux (lit',_)) -> lit_match (lit, lit') + | _ -> true + in aux exp p + in + let rewrite_e_case (exp,cases) = + E_case (exp, List.filter (must_keep_case exp) cases) + in + let open Rewriter in + let rewrite_exp _ = fold_exp { id_exp_alg with e_case = rewrite_e_case } in + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } diff --git a/src/constant_propagation.mli b/src/constant_propagation.mli index 1537b927..437492c6 100644 --- a/src/constant_propagation.mli +++ b/src/constant_propagation.mli @@ -67,3 +67,5 @@ val const_prop : tannot exp * tannot exp Bindings.t val referenced_vars : tannot exp -> IdSet.t + +val remove_impossible_int_cases : 'a -> tannot defs -> tannot defs diff --git a/src/rewrites.ml b/src/rewrites.ml index 23e22769..d9bcec04 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -5120,6 +5120,7 @@ let rewrite_defs_coq = [ ("rewrite_undefined", rewrite_undefined_if_gen true); ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list); ("remove_not_pats", rewrite_defs_not_pats); + ("remove_impossible_int_cases", Constant_propagation.remove_impossible_int_cases); ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); -- cgit v1.2.3 From a98c6844fe7ab3dc0c39a27930e6635c5cde89a1 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 7 Mar 2019 14:50:08 +0000 Subject: C: Make instrs_graph return just control flow graph Previously instrs_graph would return the control-flow graph, as well as some data-flow by including reads and writes to variables represented as a node type in the graph (G_id). However, this was not particularly useful, and since the graph isn't in SSA form (so identifiers are non-unique) potentially inaccurate too. This simplifies the code so instrs_graph just returns control flow dependencies, which in turn simplifies the instr_reads and instr_writes functions. --- src/bytecode_util.ml | 168 ++++++++++++++++++++------------------------------- 1 file changed, 66 insertions(+), 102 deletions(-) (limited to 'src') diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml index ee407289..630d2a48 100644 --- a/src/bytecode_util.ml +++ b/src/bytecode_util.ml @@ -522,13 +522,11 @@ let pp_cdef = function (**************************************************************************) type graph_node = - | G_id of id | G_label of string | G_instr of int * instr | G_start let string_of_node = function - | G_id id -> string_of_id id | G_label label -> label | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) | G_start -> "START" @@ -537,7 +535,6 @@ module Node = struct type t = graph_node let compare gn1 gn2 = match gn1, gn2 with - | G_id id1, G_id id2 -> Id.compare id1 id2 | G_label str1, G_label str2 -> String.compare str1 str2 | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 | G_start , G_start -> 0 @@ -545,8 +542,6 @@ module Node = struct | _ , G_start -> -1 | G_instr _, _ -> 1 | _ , G_instr _ -> -1 - | G_id _ , _ -> 1 - | _ , G_id _ -> -1 end module NodeGraph = Graph.Make(Node) @@ -557,45 +552,46 @@ module NS = Set.Make(Node) type dep_graph = NodeGraph.graph let rec fragment_deps = function - | F_id id | F_ref id -> NS.singleton (G_id id) - | F_lit _ -> NS.empty + | F_id id | F_ref id -> IdSet.singleton id + | F_lit _ -> IdSet.empty | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag - | F_call (_, frags) -> List.fold_left NS.union NS.empty (List.map fragment_deps frags) - | F_op (frag1, _, frag2) -> NS.union (fragment_deps frag1) (fragment_deps frag2) - | F_current_exception -> NS.empty - | F_have_exception -> NS.empty - | F_raw _ -> NS.empty + | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags) + | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2) + | F_current_exception -> IdSet.empty + | F_have_exception -> IdSet.empty + | F_raw _ -> IdSet.empty let cval_deps = function (frag, _) -> fragment_deps frag let rec clexp_deps = function - | CL_id (id, _) -> NS.singleton (G_id id) + | CL_id (id, _) -> IdSet.singleton id | CL_field (clexp, _) -> clexp_deps clexp | CL_tuple (clexp, _) -> clexp_deps clexp | CL_addr clexp -> clexp_deps clexp - | CL_have_exception -> NS.empty - | CL_current_exception _ -> NS.empty + | CL_have_exception -> IdSet.empty + | CL_current_exception _ -> IdSet.empty -(** Return the direct, non program-order dependencies of a single - instruction **) +(* Return the direct, read/write dependencies of a single instruction *) let instr_deps = function - | I_decl (ctyp, id) -> NS.empty, NS.singleton (G_id id) - | I_reset (ctyp, id) -> NS.empty, NS.singleton (G_id id) - | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, NS.singleton (G_id id) - | I_if (cval, _, _, _) -> cval_deps cval, NS.empty - | I_jump (cval, label) -> cval_deps cval, NS.singleton (G_label label) - | I_funcall (clexp, _, _, cvals) -> List.fold_left NS.union NS.empty (List.map cval_deps cvals), clexp_deps clexp + | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id + | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty + | I_jump (cval, label) -> cval_deps cval, IdSet.empty + | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_clear (_, id) -> NS.singleton (G_id id), NS.singleton (G_id id) - | I_throw cval | I_return cval -> cval_deps cval, NS.empty - | I_block _ | I_try_block _ -> NS.empty, NS.empty - | I_comment _ | I_raw _ -> NS.empty, NS.empty - | I_label label -> NS.singleton (G_label label), NS.empty - | I_goto label -> NS.empty, NS.singleton (G_label label) - | I_undefined _ -> NS.empty, NS.empty - | I_match_failure -> NS.empty, NS.empty - + | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id + | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty + | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty + | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty + | I_label label -> IdSet.empty, IdSet.empty + | I_goto label -> IdSet.empty, IdSet.empty + | I_undefined _ -> IdSet.empty, IdSet.empty + | I_match_failure -> IdSet.empty, IdSet.empty + +(* instrs_graph returns the control-flow graph for a list of + instructions. *) let instrs_graph instrs = let icounter = ref 0 in let graph = ref NodeGraph.empty in @@ -607,43 +603,34 @@ let instrs_graph instrs = | I_block instrs | I_try_block instrs -> List.fold_left add_instr last_instrs instrs | I_if (_, then_instrs, else_instrs, _) -> - begin - let inputs, _ = instr_deps instr in (* if has no outputs *) - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; - let n1 = List.fold_left add_instr [node] then_instrs in - let n2 = List.fold_left add_instr [node] else_instrs in - incr icounter; - let join = G_instr (!icounter, icomment "join") in - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; - [join] - end + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + let n1 = List.fold_left add_instr [node] then_instrs in + let n2 = List.fold_left add_instr [node] else_instrs in + incr icounter; + let join = G_instr (!icounter, icomment "join") in + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; + [join] | I_return _ -> - begin - let inputs, outputs = instr_deps instr in - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; - NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; - [] - end - | I_label _ -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] + | I_label label -> + graph := NodeGraph.add_edge' (G_label label) node !graph; node :: last_instrs | I_goto label -> - begin - let _, outputs = instr_deps instr in - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; - [] - end + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edge' node (G_label label) !graph; + [] + | I_jump (cval, label) -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edges' (G_label label) [] !graph; + [node] + | I_match_failure -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] | _ -> - begin - let inputs, outputs = instr_deps instr in - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - NS.iter (fun input -> graph := NodeGraph.add_edge' input node !graph) inputs; - NS.iter (fun output -> graph := NodeGraph.add_edge' node output !graph) outputs; - [node] - end + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [node] in ignore (List.fold_left add_instr [G_start] instrs); let graph = NodeGraph.fix_leaves !graph in @@ -653,17 +640,17 @@ let make_dot id graph = Util.opt_colors := false; let to_string node = String.escaped (string_of_node node) in let node_color = function - | G_start -> "lightpink" - | G_id _ -> "yellow" - | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" - | G_instr (_, I_aux (I_init _, _)) -> "springgreen" - | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" - | G_instr (_, I_aux (I_goto _, _)) -> "orange1" - | G_instr (_, I_aux (I_label _, _)) -> "white" - | G_instr (_, I_aux (I_raw _, _)) -> "khaki" - | G_instr (_, I_aux (I_return _, _)) -> "deeppink" - | G_instr _ -> "azure" - | G_label _ -> "lightpink" + | G_start -> "lightpink" + | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" + | G_instr (_, I_aux (I_init _, _)) -> "springgreen" + | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" + | G_instr (_, I_aux (I_goto _, _)) -> "orange1" + | G_instr (_, I_aux (I_label _, _)) -> "white" + | G_instr (_, I_aux (I_raw _, _)) -> "khaki" + | G_instr (_, I_aux (I_return _, _)) -> "deeppink" + | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" + | G_instr _ -> "azure" + | G_label _ -> "lightpink" in let edge_color from_node to_node = match from_node, to_node with @@ -671,8 +658,6 @@ let make_dot id graph = | G_label _, _ -> "darkgreen" | _ , G_label _ -> "goldenrod4" | G_instr _, G_instr _ -> "black" - | G_id _ , G_instr _ -> "blue3" - | G_instr _, G_id _ -> "red3" | _ , _ -> "coral3" in let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in @@ -765,36 +750,15 @@ let rec map_instrs f (I_aux (instr, aux)) = let rec instr_ids (I_aux (instr, _)) = let reads, writes = instr_deps instr in - let get_id = function - | G_id id -> Some id - | _ -> None - in - NS.elements reads @ NS.elements writes - |> List.map get_id - |> Util.option_these - |> IdSet.of_list + IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) let rec instr_reads (I_aux (instr, _)) = let reads, _ = instr_deps instr in - let get_id = function - | G_id id -> Some id - | _ -> None - in - NS.elements reads - |> List.map get_id - |> Util.option_these - |> IdSet.of_list + IdSet.of_list (IdSet.elements reads) let rec instr_writes (I_aux (instr, _)) = let _, writes = instr_deps instr in - let get_id = function - | G_id id -> Some id - | _ -> None - in - NS.elements writes - |> List.map get_id - |> Util.option_these - |> IdSet.of_list + IdSet.of_list (IdSet.elements writes) let rec filter_instrs f instrs = let filter_instrs' = function -- cgit v1.2.3 From e9d0335845cf2caffd4b4626bdedb02732fd8141 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Thu, 7 Mar 2019 13:28:04 +0000 Subject: Fix bug in a mono rewrite helper function --- src/monomorphise.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 07063ac4..fdc20932 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -2961,9 +2961,9 @@ let rec rewrite_app env typ (id,args) = else if is_id env (Id "__SetSlice_bits") id then match args with - | [len; slice_len; vector; pos; E_aux (E_app (zeros, _), _)] + | [len; slice_len; vector; start; E_aux (E_app (zeros, _), _)] when is_zeros zeros -> - E_app (mk_id "set_slice_zeros", [len; slice_len; vector; pos]) + E_app (mk_id "set_slice_zeros", [len; vector; start; slice_len]) | _ -> E_app (id, args) else E_app (id,args) -- cgit v1.2.3 From dcceda3f662daebe00c3c4bfafa7f1083abea102 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Thu, 7 Mar 2019 14:57:15 +0000 Subject: Also remove impossible if-branches --- src/constant_propagation.ml | 12 ++++++++++-- src/rewrites.ml | 1 + 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index c3e00753..d0b524ed 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -860,9 +860,17 @@ let remove_impossible_int_cases _ = | _ -> true in aux exp p in - let rewrite_e_case (exp,cases) = + let e_case (exp,cases) = E_case (exp, List.filter (must_keep_case exp) cases) in + let e_if (cond, e_then, e_else) = + match destruct_atom_bool (env_of cond) (typ_of cond) with + | Some nc -> + if prove __POS__ (Env.add_constraint nc (env_of cond)) nc_false + then unaux_exp e_else + else E_if (cond, e_then, e_else) + | _ -> E_if (cond, e_then, e_else) + in let open Rewriter in - let rewrite_exp _ = fold_exp { id_exp_alg with e_case = rewrite_e_case } in + let rewrite_exp _ = fold_exp { id_exp_alg with e_case = e_case; e_if = e_if } in rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } diff --git a/src/rewrites.ml b/src/rewrites.ml index d9bcec04..f6a004b3 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -5077,6 +5077,7 @@ let rewrite_defs_lem = [ ("rewrite_undefined", rewrite_undefined_if_gen false); ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list); ("remove_not_pats", rewrite_defs_not_pats); + ("remove_impossible_int_cases", Constant_propagation.remove_impossible_int_cases); ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem); ("vector_concat_assignments", rewrite_vector_concat_assignments); ("tuple_assignments", rewrite_tuple_assignments); -- cgit v1.2.3 From dc433c92714e7ea4485a87cfec3b07a3c36910d8 Mon Sep 17 00:00:00 2001 From: Thomas Bauereiss Date: Thu, 7 Mar 2019 16:32:16 +0000 Subject: Remove more dead branches --- src/constant_propagation.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml index d0b524ed..33b67008 100644 --- a/src/constant_propagation.ml +++ b/src/constant_propagation.ml @@ -866,9 +866,9 @@ let remove_impossible_int_cases _ = let e_if (cond, e_then, e_else) = match destruct_atom_bool (env_of cond) (typ_of cond) with | Some nc -> - if prove __POS__ (Env.add_constraint nc (env_of cond)) nc_false - then unaux_exp e_else - else E_if (cond, e_then, e_else) + if prove __POS__ (env_of cond) nc then unaux_exp e_then else + if prove __POS__ (env_of cond) (nc_not nc) then unaux_exp e_else else + E_if (cond, e_then, e_else) | _ -> E_if (cond, e_then, e_else) in let open Rewriter in -- cgit v1.2.3 From f0b4a103325e150faa3c2bd0a06594b2e62fae43 Mon Sep 17 00:00:00 2001 From: Alasdair Date: Fri, 8 Mar 2019 00:16:47 +0000 Subject: Fix: Never consider single variable types to be ambiguous --- src/type_check.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/type_check.ml b/src/type_check.ml index 603052b5..48a64226 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1851,7 +1851,7 @@ let instantiate_quants quants unifier = they'll be unambigiously unified with the argument types so it's better to just not bother with the return type. *) -let rec ambiguous_vars (Typ_aux (aux, _)) = +let rec ambiguous_vars' (Typ_aux (aux, _)) = match aux with | Typ_app (_, args) -> List.fold_left KidSet.union KidSet.empty (List.map ambiguous_arg_vars args) | _ -> KidSet.empty @@ -1876,6 +1876,10 @@ and ambiguous_nexp_vars (Nexp_aux (aux, _)) = | Nexp_sum (nexp1, nexp2) -> KidSet.union (tyvars_of_nexp nexp1) (tyvars_of_nexp nexp2) | _ -> KidSet.empty +let ambiguous_vars typ = + let vars = ambiguous_vars' typ in + if KidSet.cardinal vars > 1 then vars else KidSet.empty + (**************************************************************************) (* 3.5. Subtyping with existentials *) (**************************************************************************) -- cgit v1.2.3 From 703e996e44d0c1773fb23cd554b896318fae081b Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 7 Mar 2019 20:22:03 +0000 Subject: C: Refactor C backend Main change is splitting apart the Sail->IR compilation stage and the C code generation and optimization phase. Rather than variously calling the intermediate language either bytecode (when it's not really) or simply IR, we give it a name: Jib (a type of Sail). Most of the types are still prefixed by c/C, and I don't think it's worth changing this. The various parts of the C backend are now in the src/jib/ subdirectory src/jib/anf.ml - Sail->ANF translation src/jib/jib_util.ml - various Jib AST processing and helper functions (formerly bytecode_util) src/jib/jib_compile.ml - Sail->Jib translation (using Sail->ANF) src/jib/c_backend.ml - Jib->C code generator and optimizations Further, bytecode.ott is now jib.ott and generates jib.ml (which still lives in src/ for now) The optimizations in c_backend.ml should eventually be moved in a separate jib_optimization file. The Sail->Jib compilation can be parameterised by two functions - one is a custom ANF->ANF optimization pass that can be specified on a per Jib backend basis, and the other is the rule for translating Sail types in Jib types. This can be more or less precise depending on how precise we want to be about bit-widths etc, i.e. we only care about <64 and >64 for C, but for SMT generation we would want to be as precise as possible. Additional improvements: The Jib IR is now agnostic about whether arguments are allocated on the heap vs the stack and this is handled by the C code generator. jib.ott now has some more comments explaining various parts of the Jib AST. A Set module and comparison function for ctyps is defined, and some functions now return ctyp sets rather than lists to avoid repeated work. --- src/Makefile | 24 +- src/_tags | 1 + src/anf.ml | 717 --------- src/anf.mli | 125 -- src/bytecode_interpreter.ml | 162 -- src/bytecode_util.ml | 771 --------- src/c_backend.ml | 3715 ------------------------------------------- src/c_backend.mli | 141 -- src/isail.ml | 49 +- src/jib/anf.ml | 717 +++++++++ src/jib/anf.mli | 125 ++ src/jib/c_backend.ml | 2420 ++++++++++++++++++++++++++++ src/jib/c_backend.mli | 118 ++ src/jib/jib_compile.ml | 1367 ++++++++++++++++ src/jib/jib_compile.mli | 87 + src/jib/jib_util.ml | 935 +++++++++++ src/sail.ml | 16 +- 17 files changed, 5792 insertions(+), 5698 deletions(-) delete mode 100644 src/anf.ml delete mode 100644 src/anf.mli delete mode 100644 src/bytecode_interpreter.ml delete mode 100644 src/bytecode_util.ml delete mode 100644 src/c_backend.ml delete mode 100644 src/c_backend.mli create mode 100644 src/jib/anf.ml create mode 100644 src/jib/anf.mli create mode 100644 src/jib/c_backend.ml create mode 100644 src/jib/c_backend.mli create mode 100644 src/jib/jib_compile.ml create mode 100644 src/jib/jib_compile.mli create mode 100644 src/jib/jib_util.ml (limited to 'src') diff --git a/src/Makefile b/src/Makefile index beba66df..d71c9fb8 100644 --- a/src/Makefile +++ b/src/Makefile @@ -74,16 +74,16 @@ full: sail lib doc ast.lem: ../language/sail.ott ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott -bytecode.lem: ../language/bytecode.ott ast.lem - ott -sort false -generate_aux_rules true -o bytecode.lem -picky_multiple_parses true ../language/bytecode.ott +jib.lem: ../language/jib.ott ast.lem + ott -sort false -generate_aux_rules true -o jib.lem -picky_multiple_parses true ../language/jib.ott ast.ml: ast.lem lem -ocaml ast.lem sed -i.bak -f ast.sed ast.ml -bytecode.ml: bytecode.lem - lem -ocaml bytecode.lem -lib . -lib gen_lib/ - sed -i.bak -f ast.sed bytecode.ml +jib.ml: jib.lem + lem -ocaml jib.lem -lib . -lib gen_lib/ + sed -i.bak -f ast.sed jib.ml manifest.ml: echo "(* Generated file -- do not edit. *)" > manifest.ml @@ -99,18 +99,18 @@ else echo let version=\"$(shell grep '^version:' ../opam | grep -o -E '"[^"]+"')\" >> manifest.ml endif -sail: ast.ml bytecode.ml manifest.ml +sail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa -isail: ast.ml bytecode.ml manifest.ml +isail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind isail.native -coverage: ast.ml bytecode.ml manifest.ml +coverage: ast.ml jib.ml manifest.ml BISECT_COVERAGE=YES ocamlbuild -use-ocamlfind -plugin-tag 'package(bisect_ppx-ocamlbuild)' isail.native sail.native: sail -sail.byte: ast.ml bytecode.ml manifest.ml +sail.byte: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind -cflag -g sail.byte interpreter: lem_interp/interp_ast.lem @@ -132,9 +132,9 @@ clean: -rm -f ast.ml -rm -f ast.lem -rm -f ast.ml.bak - -rm -f bytecode.ml - -rm -f bytecode.lem - -rm -f bytecode.ml.bak + -rm -f jib.ml + -rm -f jib.lem + -rm -f jib.ml.bak -rm -f manifest.ml doc: diff --git a/src/_tags b/src/_tags index aac18862..f792fefa 100644 --- a/src/_tags +++ b/src/_tags @@ -11,6 +11,7 @@ true: -traverse, debug, use_menhir <**/*.m{l,li}>: package(lem) : include +: include or : include # disable partial match and unused variable warnings diff --git a/src/anf.ml b/src/anf.ml deleted file mode 100644 index 5db836e9..00000000 --- a/src/anf.ml +++ /dev/null @@ -1,717 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util -open Type_check -open PPrint - -module Big_int = Nat_big_num - -(**************************************************************************) -(* 1. Conversion to A-normal form (ANF) *) -(**************************************************************************) - -(* The first step in compiling sail is converting the Sail expression - grammar into A-normal form. Essentially this converts expressions - such as f(g(x), h(y)) into something like: - - let v0 = g(x) in let v1 = h(x) in f(v0, v1) - - Essentially the arguments to every function must be trivial, and - complex expressions must be let bound to new variables, or used in - a block, assignment, or control flow statement (if, for, and - while/until loops). The aexp datatype represents these expressions, - while aval represents the trivial values. - - The convention is that the type of an aexp is given by last - argument to a constructor. It is omitted where it is obvious - for - example all for loops have unit as their type. If some constituent - part of the aexp has an annotation, the it refers to the previous - argument, so in - - AE_let (id, typ1, _, body, typ2) - - typ1 is the type of the bound identifer, whereas typ2 is the type - of the whole let expression (and therefore also the body). - - See Flanagan et al's 'The Essence of Compiling with Continuations' - *) -type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l - -and 'a aexp_aux = - | AE_val of 'a aval - | AE_app of id * ('a aval) list * 'a - | AE_cast of 'a aexp * 'a - | AE_assign of id * 'a * 'a aexp - | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a - | AE_block of ('a aexp) list * 'a aexp * 'a - | AE_return of 'a aval * 'a - | AE_throw of 'a aval * 'a - | AE_if of 'a aval * 'a aexp * 'a aexp * 'a - | AE_field of 'a aval * id * 'a - | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a - | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp - | AE_loop of loop * 'a aexp * 'a aexp - | AE_short_circuit of sc_op * 'a aval * 'a aexp - -and sc_op = SC_and | SC_or - -and 'a apat = AP_aux of 'a apat_aux * Env.t * l - -and 'a apat_aux = - | AP_tup of ('a apat) list - | AP_id of id * 'a - | AP_global of id * 'a - | AP_app of id * 'a apat * 'a - | AP_cons of 'a apat * 'a apat - | AP_nil of 'a - | AP_wild of 'a - -and 'a aval = - | AV_lit of lit * 'a - | AV_id of id * 'a lvar - | AV_ref of id * 'a lvar - | AV_tuple of ('a aval) list - | AV_list of ('a aval) list * 'a - | AV_vector of ('a aval) list * 'a - | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a * ctyp - -(* Renaming variables in ANF expressions *) - -let rec apat_bindings (AP_aux (apat_aux, _, _)) = - match apat_aux with - | AP_tup apats -> List.fold_left IdSet.union IdSet.empty (List.map apat_bindings apats) - | AP_id (id, _) -> IdSet.singleton id - | AP_global (id, _) -> IdSet.empty - | AP_app (id, apat, _) -> apat_bindings apat - | AP_cons (apat1, apat2) -> IdSet.union (apat_bindings apat1) (apat_bindings apat2) - | AP_nil _ -> IdSet.empty - | AP_wild _ -> IdSet.empty - -(** This function returns the types of all bound variables in a - pattern. It ignores AP_global, apat_globals is used for that. *) -let rec apat_types (AP_aux (apat_aux, _, _)) = - let merge id b1 b2 = - match b1, b2 with - | None, None -> None - | Some v, None -> Some v - | None, Some v -> Some v - | Some _, Some _ -> assert false - in - match apat_aux with - | AP_tup apats -> List.fold_left (Bindings.merge merge) Bindings.empty (List.map apat_types apats) - | AP_id (id, typ) -> Bindings.singleton id typ - | AP_global (id, _) -> Bindings.empty - | AP_app (id, apat, _) -> apat_types apat - | AP_cons (apat1, apat2) -> (Bindings.merge merge) (apat_types apat1) (apat_types apat2) - | AP_nil _ -> Bindings.empty - | AP_wild _ -> Bindings.empty - -let rec apat_rename from_id to_id (AP_aux (apat_aux, env, l)) = - let apat_aux = match apat_aux with - | AP_tup apats -> AP_tup (List.map (apat_rename from_id to_id) apats) - | AP_id (id, typ) when Id.compare id from_id = 0 -> AP_id (to_id, typ) - | AP_id (id, typ) -> AP_id (id, typ) - | AP_global (id, typ) -> AP_global (id, typ) - | AP_app (ctor, apat, typ) -> AP_app (ctor, apat_rename from_id to_id apat, typ) - | AP_cons (apat1, apat2) -> AP_cons (apat_rename from_id to_id apat1, apat_rename from_id to_id apat2) - | AP_nil typ -> AP_nil typ - | AP_wild typ -> AP_wild typ - in - AP_aux (apat_aux, env, l) - -let rec aval_rename from_id to_id = function - | AV_lit (lit, typ) -> AV_lit (lit, typ) - | AV_id (id, lvar) when Id.compare id from_id = 0 -> AV_id (to_id, lvar) - | AV_id (id, lvar) -> AV_id (id, lvar) - | AV_ref (id, lvar) when Id.compare id from_id = 0 -> AV_ref (to_id, lvar) - | AV_ref (id, lvar) -> AV_ref (id, lvar) - | AV_tuple avals -> AV_tuple (List.map (aval_rename from_id to_id) avals) - | AV_list (avals, typ) -> AV_list (List.map (aval_rename from_id to_id) avals, typ) - | AV_vector (avals, typ) -> AV_vector (List.map (aval_rename from_id to_id) avals, typ) - | AV_record (avals, typ) -> AV_record (Bindings.map (aval_rename from_id to_id) avals, typ) - | AV_C_fragment (fragment, typ, ctyp) -> AV_C_fragment (frag_rename from_id to_id fragment, typ, ctyp) - -let rec aexp_rename from_id to_id (AE_aux (aexp, env, l)) = - let recur = aexp_rename from_id to_id in - let aexp = match aexp with - | AE_val aval -> AE_val (aval_rename from_id to_id aval) - | AE_app (id, avals, typ) -> AE_app (id, List.map (aval_rename from_id to_id) avals, typ) - | AE_cast (aexp, typ) -> AE_cast (recur aexp, typ) - | AE_assign (id, typ, aexp) when Id.compare from_id id = 0 -> AE_assign (to_id, typ, aexp_rename from_id to_id aexp) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, aexp_rename from_id to_id aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when Id.compare from_id id = 0 -> AE_let (mut, id, typ1, recur aexp1, aexp2, typ2) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, recur aexp1, recur aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map recur aexps, recur aexp, typ) - | AE_return (aval, typ) -> AE_return (aval_rename from_id to_id aval, typ) - | AE_throw (aval, typ) -> AE_throw (aval_rename from_id to_id aval, typ) - | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval_rename from_id to_id aval, recur then_aexp, recur else_aexp, typ) - | AE_field (aval, id, typ) -> AE_field (aval_rename from_id to_id aval, id, typ) - | AE_case (aval, apexps, typ) -> AE_case (aval_rename from_id to_id aval, List.map (apexp_rename from_id to_id) apexps, typ) - | AE_try (aexp, apexps, typ) -> AE_try (aexp_rename from_id to_id aexp, List.map (apexp_rename from_id to_id) apexps, typ) - | AE_record_update (aval, avals, typ) -> AE_record_update (aval_rename from_id to_id aval, Bindings.map (aval_rename from_id to_id) avals, typ) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when Id.compare from_id to_id = 0 -> AE_for (id, aexp1, aexp2, aexp3, order, aexp4) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> AE_for (id, recur aexp1, recur aexp2, recur aexp3, order, recur aexp4) - | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, recur aexp1, recur aexp2) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval_rename from_id to_id aval, recur aexp) - in - AE_aux (aexp, env, l) - -and apexp_rename from_id to_id (apat, aexp1, aexp2) = - if IdSet.mem from_id (apat_bindings apat) then - (apat, aexp1, aexp2) - else - (apat, aexp_rename from_id to_id aexp1, aexp_rename from_id to_id aexp2) - -let shadow_counter = ref 0 - -let new_shadow id = - let shadow_id = append_id id ("shadow#" ^ string_of_int !shadow_counter) in - incr shadow_counter; - shadow_id - -let rec no_shadow ids (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_val aval -> AE_val aval - | AE_app (id, avals, typ) -> AE_app (id, avals, typ) - | AE_cast (aexp, typ) -> AE_cast (no_shadow ids aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, no_shadow ids aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when IdSet.mem id ids -> - let shadow_id = new_shadow id in - let aexp1 = no_shadow ids aexp1 in - let ids = IdSet.add shadow_id ids in - AE_let (mut, shadow_id, typ1, aexp1, no_shadow ids (aexp_rename id shadow_id aexp2), typ2) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> - AE_let (mut, id, typ1, no_shadow ids aexp1, no_shadow (IdSet.add id ids) aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (no_shadow ids) aexps, no_shadow ids aexp, typ) - | AE_return (aval, typ) -> AE_return (aval, typ) - | AE_throw (aval, typ) -> AE_throw (aval, typ) - | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval, no_shadow ids then_aexp, no_shadow ids else_aexp, typ) - | AE_field (aval, id, typ) -> AE_field (aval, id, typ) - | AE_case (aval, apexps, typ) -> AE_case (aval, List.map (no_shadow_apexp ids) apexps, typ) - | AE_try (aexp, apexps, typ) -> AE_try (no_shadow ids aexp, List.map (no_shadow_apexp ids) apexps, typ) - | AE_record_update (aval, avals, typ) -> AE_record_update (aval, avals, typ) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when IdSet.mem id ids -> - let shadow_id = new_shadow id in - let aexp1 = no_shadow ids aexp1 in - let aexp2 = no_shadow ids aexp2 in - let aexp3 = no_shadow ids aexp3 in - let ids = IdSet.add shadow_id ids in - AE_for (shadow_id, aexp1, aexp2, aexp3, order, no_shadow ids (aexp_rename id shadow_id aexp4)) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let ids = IdSet.add id ids in - AE_for (id, no_shadow ids aexp1, no_shadow ids aexp2, no_shadow ids aexp3, order, no_shadow ids aexp4) - | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, no_shadow ids aexp1, no_shadow ids aexp2) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, no_shadow ids aexp) - in - AE_aux (aexp, env, l) - -and no_shadow_apexp ids (apat, aexp1, aexp2) = - let shadows = IdSet.inter (apat_bindings apat) ids in - let shadows = List.map (fun id -> id, new_shadow id) (IdSet.elements shadows) in - let rename aexp = List.fold_left (fun aexp (from_id, to_id) -> aexp_rename from_id to_id aexp) aexp shadows in - let rename_apat apat = List.fold_left (fun apat (from_id, to_id) -> apat_rename from_id to_id apat) apat shadows in - let ids = IdSet.union (apat_bindings apat) (IdSet.union ids (IdSet.of_list (List.map snd shadows))) in - (rename_apat apat, no_shadow ids (rename aexp1), no_shadow ids (rename aexp2)) - -(* Map over all the avals in an aexp. *) -let rec map_aval f (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_val v -> AE_val (f env l v) - | AE_cast (aexp, typ) -> AE_cast (map_aval f aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_aval f aexp) - | AE_app (id, vs, typ) -> AE_app (id, List.map (f env l) vs, typ) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> - AE_let (mut, id, typ1, map_aval f aexp1, map_aval f aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_aval f) aexps, map_aval f aexp, typ) - | AE_return (aval, typ) -> AE_return (f env l aval, typ) - | AE_throw (aval, typ) -> AE_throw (f env l aval, typ) - | AE_if (aval, aexp1, aexp2, typ2) -> - AE_if (f env l aval, map_aval f aexp1, map_aval f aexp2, typ2) - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_aval f aexp1, map_aval f aexp2) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - AE_for (id, map_aval f aexp1, map_aval f aexp2, map_aval f aexp3, order, map_aval f aexp4) - | AE_record_update (aval, updates, typ) -> - AE_record_update (f env l aval, Bindings.map (f env l) updates, typ) - | AE_field (aval, field, typ) -> - AE_field (f env l aval, field, typ) - | AE_case (aval, cases, typ) -> - AE_case (f env l aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (map_aval f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, f env l aval, map_aval f aexp) - in - AE_aux (aexp, env, l) - -(* Map over all the functions in an aexp. *) -let rec map_functions f (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_app (id, vs, typ) -> f env l id vs typ - | AE_cast (aexp, typ) -> AE_cast (map_functions f aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_functions f aexp) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, map_functions f aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, map_functions f aexp1, map_functions f aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_functions f) aexps, map_functions f aexp, typ) - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, map_functions f aexp1, map_functions f aexp2, typ) - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_functions f aexp1, map_functions f aexp2) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - AE_for (id, map_functions f aexp1, map_functions f aexp2, map_functions f aexp3, order, map_functions f aexp4) - | AE_case (aval, cases, typ) -> - AE_case (aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (map_functions f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) - -(* For debugging we provide a pretty printer for ANF expressions. *) - -let pp_lvar lvar doc = - match lvar with - | Register (_, _, typ) -> - string "[R/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Local (Mutable, typ) -> - string "[M/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Local (Immutable, typ) -> - string "[I/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Enum typ -> - string "[E/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Unbound -> string "[?]" ^^ doc - -let pp_annot typ doc = - string "[" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - -let pp_order = function - | Ord_aux (Ord_inc, _) -> string "inc" - | Ord_aux (Ord_dec, _) -> string "dec" - | _ -> assert false (* Order types have been specialised, so no polymorphism in C backend. *) - -let rec pp_aexp (AE_aux (aexp, _, _)) = - match aexp with - | AE_val v -> pp_aval v - | AE_cast (aexp, typ) -> - pp_annot typ (string "$" ^^ pp_aexp aexp) - | AE_assign (id, typ, aexp) -> - pp_annot typ (pp_id id) ^^ string " := " ^^ pp_aexp aexp - | AE_app (id, args, typ) -> - pp_annot typ (pp_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) - | AE_short_circuit (SC_or, aval, aexp) -> - pp_aval aval ^^ string " || " ^^ pp_aexp aexp - | AE_short_circuit (SC_and, aval, aexp) -> - pp_aval aval ^^ string " && " ^^ pp_aexp aexp - | AE_let (mut, id, id_typ, binding, body, typ) -> group - begin - let let_doc = string (match mut with Immutable -> "let" | Mutable -> "let mut") in - match binding with - | AE_aux (AE_let _, _, _) -> - (pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="]) - ^^ hardline ^^ nest 2 (pp_aexp binding)) - ^^ hardline ^^ string "in" ^^ space ^^ pp_aexp body - | _ -> - pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="; pp_aexp binding; string "in"]) - ^^ hardline ^^ pp_aexp body - end - | AE_if (cond, then_aexp, else_aexp, typ) -> - pp_annot typ (separate space [ string "if"; pp_aval cond; - string "then"; pp_aexp then_aexp; - string "else"; pp_aexp else_aexp ]) - | AE_block (aexps, aexp, typ) -> - pp_annot typ (surround 2 0 lbrace (pp_block (aexps @ [aexp])) rbrace) - | AE_return (v, typ) -> pp_annot typ (string "return" ^^ parens (pp_aval v)) - | AE_throw (v, typ) -> pp_annot typ (string "throw" ^^ parens (pp_aval v)) - | AE_loop (While, aexp1, aexp2) -> - separate space [string "while"; pp_aexp aexp1; string "do"; pp_aexp aexp2] - | AE_loop (Until, aexp1, aexp2) -> - separate space [string "repeat"; pp_aexp aexp2; string "until"; pp_aexp aexp1] - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let header = - string "foreach" ^^ space ^^ - group (parens (separate (break 1) - [ pp_id id; - string "from " ^^ pp_aexp aexp1; - string "to " ^^ pp_aexp aexp2; - string "by " ^^ pp_aexp aexp3; - string "in " ^^ pp_order order ])) - in - header ^//^ pp_aexp aexp4 - | AE_field (aval, field, typ) -> pp_annot typ (parens (pp_aval aval ^^ string "." ^^ pp_id field)) - | AE_case (aval, cases, typ) -> - pp_annot typ (separate space [string "match"; pp_aval aval; pp_cases cases]) - | AE_try (aexp, cases, typ) -> - pp_annot typ (separate space [string "try"; pp_aexp aexp; pp_cases cases]) - | AE_record_update (aval, updates, typ) -> - braces (pp_aval aval ^^ string " with " - ^^ separate (string ", ") (List.map (fun (id, aval) -> pp_id id ^^ string " = " ^^ pp_aval aval) - (Bindings.bindings updates))) - -and pp_apat (AP_aux (apat_aux, _, _)) = - match apat_aux with - | AP_wild _ -> string "_" - | AP_id (id, typ) -> pp_annot typ (pp_id id) - | AP_global (id, _) -> pp_id id - | AP_tup apats -> parens (separate_map (comma ^^ space) pp_apat apats) - | AP_app (id, apat, typ) -> pp_annot typ (pp_id id ^^ parens (pp_apat apat)) - | AP_nil _ -> string "[||]" - | AP_cons (hd_apat, tl_apat) -> pp_apat hd_apat ^^ string " :: " ^^ pp_apat tl_apat - -and pp_cases cases = surround 2 0 lbrace (separate_map (comma ^^ hardline) pp_case cases) rbrace - -and pp_case (apat, guard, body) = - separate space [pp_apat apat; string "if"; pp_aexp guard; string "=>"; pp_aexp body] - -and pp_block = function - | [] -> string "()" - | [aexp] -> pp_aexp aexp - | aexp :: aexps -> pp_aexp aexp ^^ semi ^^ hardline ^^ pp_block aexps - -and pp_aval = function - | AV_lit (lit, typ) -> pp_annot typ (string (string_of_lit lit)) - | AV_id (id, lvar) -> pp_lvar lvar (pp_id id) - | AV_tuple avals -> parens (separate_map (comma ^^ space) pp_aval avals) - | AV_ref (id, lvar) -> string "ref" ^^ space ^^ pp_lvar lvar (pp_id id) - | AV_C_fragment (frag, typ, ctyp) -> - pp_annot typ (string ("(" ^ string_of_ctyp ctyp ^ ")" ^ string_of_fragment frag |> Util.cyan |> Util.clear)) - | AV_vector (avals, typ) -> - pp_annot typ (string "[" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "]") - | AV_list (avals, typ) -> - pp_annot typ (string "[|" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "|]") - | AV_record (fields, typ) -> - pp_annot typ (string "struct {" - ^^ separate_map (comma ^^ space) (fun (id, field) -> pp_id id ^^ string " = " ^^ pp_aval field) (Bindings.bindings fields) - ^^ string "}") - -let ae_lit lit typ = AE_val (AV_lit (lit, typ)) - -let is_dead_aexp (AE_aux (_, env, _)) = prove __POS__ env nc_false - -(** GLOBAL: gensym_counter is used to generate fresh identifiers where - needed. It should be safe to reset between top level - definitions. **) -let gensym_counter = ref 0 - -let gensym () = - let id = mk_id ("gs#" ^ string_of_int !gensym_counter) in - incr gensym_counter; - id - -let rec split_block l = function - | [exp] -> [], exp - | exp :: exps -> - let exps, last = split_block l exps in - exp :: exps, last - | [] -> - raise (Reporting.err_unreachable l __POS__ "empty block found when converting to ANF") - -let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = - let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in - match p_aux with - | P_id id when global -> mk_apat (AP_global (id, typ_of_pat pat)) - | P_id id -> mk_apat (AP_id (id, typ_of_pat pat)) - | P_wild -> mk_apat (AP_wild (typ_of_pat pat)) - | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)) - | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, typ_of_pat pat)) - | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), typ_of_pat pat)) - | P_typ (_, pat) -> anf_pat ~global:global pat - | P_var (pat, _) -> anf_pat ~global:global pat - | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) - | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) - | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) - | _ -> - raise (Reporting.err_unreachable (fst annot) __POS__ - ("Could not convert pattern to ANF: " ^ string_of_pat pat)) - -let rec apat_globals (AP_aux (aux, _, _)) = - match aux with - | AP_nil _ | AP_wild _ | AP_id _ -> [] - | AP_global (id, typ) -> [(id, typ)] - | AP_tup apats -> List.concat (List.map apat_globals apats) - | AP_app (_, apat, _) -> apat_globals apat - | AP_cons (hd_apat, tl_apat) -> apat_globals hd_apat @ apat_globals tl_apat - -let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = - let mk_aexp aexp = AE_aux (aexp, env_of_annot exp_annot, l) in - - let to_aval (AE_aux (aexp_aux, env, l) as aexp) = - let mk_aexp aexp = AE_aux (aexp, env, l) in - match aexp_aux with - | AE_val v -> (v, fun x -> x) - | AE_short_circuit (_, _, _) -> - let id = gensym () in - (AV_id (id, Local (Immutable, bool_typ)), fun x -> mk_aexp (AE_let (Immutable, id, bool_typ, aexp, x, typ_of exp))) - | AE_app (_, _, typ) - | AE_let (_, _, _, _, _, typ) - | AE_return (_, typ) - | AE_throw (_, typ) - | AE_cast (_, typ) - | AE_if (_, _, _, typ) - | AE_field (_, _, typ) - | AE_case (_, _, typ) - | AE_try (_, _, typ) - | AE_record_update (_, _, typ) - | AE_block (_, _, typ) -> - let id = gensym () in - (AV_id (id, Local (Immutable, typ)), fun x -> mk_aexp (AE_let (Immutable, id, typ, aexp, x, typ_of exp))) - | AE_assign _ | AE_for _ | AE_loop _ -> - let id = gensym () in - (AV_id (id, Local (Immutable, unit_typ)), fun x -> mk_aexp (AE_let (Immutable, id, unit_typ, aexp, x, typ_of exp))) - in - match e_aux with - | E_lit lit -> mk_aexp (ae_lit lit (typ_of exp)) - - | E_block [] -> - Util.warn (Reporting.loc_to_string l - ^ "\n\nTranslating empty block (possibly assigning to an uninitialized variable at the end of a block?)"); - mk_aexp (ae_lit (L_aux (L_unit, l)) (typ_of exp)) - | E_block exps -> - let exps, last = split_block l exps in - let aexps = List.map anf exps in - let alast = anf last in - mk_aexp (AE_block (aexps, alast, typ_of exp)) - - | E_assign (LEXP_aux (LEXP_deref dexp, _), exp) -> - let gs = gensym () in - mk_aexp (AE_let (Mutable, gs, typ_of dexp, anf dexp, mk_aexp (AE_assign (gs, typ_of dexp, anf exp)), unit_typ)) - - | E_assign (LEXP_aux (LEXP_id id, _), exp) - | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> - let aexp = anf exp in - mk_aexp (AE_assign (id, lvar_typ (Env.lookup_id id (env_of exp)), aexp)) - - | E_assign (lexp, _) -> - raise (Reporting.err_unreachable l __POS__ - ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) - - | E_loop (loop_typ, cond, exp) -> - let acond = anf cond in - let aexp = anf exp in - mk_aexp (AE_loop (loop_typ, acond, aexp)) - - | E_for (id, exp1, exp2, exp3, order, body) -> - let aexp1, aexp2, aexp3, abody = anf exp1, anf exp2, anf exp3, anf body in - mk_aexp (AE_for (id, aexp1, aexp2, aexp3, order, abody)) - - | E_if (cond, then_exp, else_exp) -> - let cond_val, wrap = to_aval (anf cond) in - let then_aexp = anf then_exp in - let else_aexp = anf else_exp in - wrap (mk_aexp (AE_if (cond_val, then_aexp, else_aexp, typ_of exp))) - - | E_app_infix (x, Id_aux (Id op, l), y) -> - anf (E_aux (E_app (Id_aux (DeIid op, l), [x; y]), exp_annot)) - | E_app_infix (x, Id_aux (DeIid op, l), y) -> - anf (E_aux (E_app (Id_aux (Id op, l), [x; y]), exp_annot)) - - | E_vector exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_vector (List.map fst avals, typ_of exp)))) - - | E_list exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_list (List.map fst avals, typ_of exp)))) - - | E_field (field_exp, id) -> - let aval, wrap = to_aval (anf field_exp) in - wrap (mk_aexp (AE_field (aval, id, typ_of exp))) - - | E_record_update (exp, fexps) -> - let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = - let aval, wrap = to_aval (anf exp) in - (id, aval), wrap - in - let aval, exp_wrap = to_aval (anf exp) in - let fexps = List.map anf_fexp fexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in - let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in - exp_wrap (wrap (mk_aexp (AE_record_update (aval, record, typ_of exp)))) - - | E_app (id, [exp1; exp2]) when string_of_id id = "and_bool" -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap = to_aval aexp1 in - wrap (mk_aexp (AE_short_circuit (SC_and, aval1, aexp2))) - - | E_app (id, [exp1; exp2]) when string_of_id id = "or_bool" -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap = to_aval aexp1 in - wrap (mk_aexp (AE_short_circuit (SC_or, aval1, aexp2))) - - | E_app (id, exps) -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_app (id, List.map fst avals, typ_of exp))) - - | E_throw exn_exp -> - let aexp = anf exn_exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_throw (aval, typ_of exp))) - - | E_exit exp -> - let aexp = anf exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_app (mk_id "sail_exit", [aval], unit_typ))) - - | E_return ret_exp -> - let aexp = anf ret_exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_return (aval, typ_of exp))) - - | E_assert (exp1, exp2) -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap1 = to_aval aexp1 in - let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_assert", [aval1; aval2], unit_typ)))) - - | E_cons (exp1, exp2) -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap1 = to_aval aexp1 in - let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "cons", [aval1; aval2], unit_typ)))) - - | E_id id -> - let lvar = Env.lookup_id id (env_of exp) in - begin match lvar with - | _ -> mk_aexp (AE_val (AV_id (id, lvar))) - end - - | E_ref id -> - let lvar = Env.lookup_id id (env_of exp) in - mk_aexp (AE_val (AV_ref (id, lvar))) - - | E_case (match_exp, pexps) -> - let match_aval, match_wrap = to_aval (anf match_exp) in - let anf_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_when (pat, guard, body) -> - (anf_pat pat, anf guard, anf body) - | Pat_exp (pat, body) -> - (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) - in - match_wrap (mk_aexp (AE_case (match_aval, List.map anf_pexp pexps, typ_of exp))) - - | E_try (match_exp, pexps) -> - let match_aexp = anf match_exp in - let anf_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_when (pat, guard, body) -> - (anf_pat pat, anf guard, anf body) - | Pat_exp (pat, body) -> - (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) - in - mk_aexp (AE_try (match_aexp, List.map anf_pexp pexps, typ_of exp)) - - | E_var (LEXP_aux (LEXP_id id, _), binding, body) - | E_var (LEXP_aux (LEXP_cast (_, id), _), binding, body) - | E_let (LB_aux (LB_val (P_aux (P_id id, _), binding), _), body) -> - let env = env_of body in - let lvar = Env.lookup_id id env in - mk_aexp (AE_let (Mutable, id, lvar_typ lvar, anf binding, anf body, typ_of exp)) - - | E_var (lexp, _, _) -> - raise (Reporting.err_unreachable l __POS__ - ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) - - | E_let (LB_aux (LB_val (pat, binding), _), body) -> - anf (E_aux (E_case (binding, [Pat_aux (Pat_exp (pat, body), (Parse_ast.Unknown, empty_tannot))]), exp_annot)) - - | E_tuple exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_tuple (List.map fst avals)))) - - | E_record fexps -> - let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = - let aval, wrap = to_aval (anf exp) in - (id, aval), wrap - in - let fexps = List.map anf_fexp fexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in - let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in - wrap (mk_aexp (AE_val (AV_record (record, typ_of exp)))) - - | E_cast (typ, exp) -> mk_aexp (AE_cast (anf exp, typ)) - - | E_vector_access _ | E_vector_subrange _ | E_vector_update _ | E_vector_update_subrange _ | E_vector_append _ -> - (* Should be re-written by type checker *) - raise (Reporting.err_unreachable l __POS__ "encountered raw vector operation when converting to ANF") - - | E_internal_value _ -> - (* Interpreter specific *) - raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") - - | E_sizeof nexp -> - (* Sizeof nodes removed by sizeof rewriting pass *) - raise (Reporting.err_unreachable l __POS__ ("encountered E_sizeof node " ^ string_of_nexp nexp ^ " when converting to ANF")) - - | E_constraint _ -> - (* Sizeof nodes removed by sizeof rewriting pass *) - raise (Reporting.err_unreachable l __POS__ "encountered E_constraint node when converting to ANF") - - | E_nondet _ -> - (* We don't compile E_nondet nodes *) - raise (Reporting.err_unreachable l __POS__ "encountered E_nondet node when converting to ANF") - - | E_internal_return _ | E_internal_plet _ -> - raise (Reporting.err_unreachable l __POS__ "encountered unexpected internal node when converting to ANF") diff --git a/src/anf.mli b/src/anf.mli deleted file mode 100644 index 6b9c9b51..00000000 --- a/src/anf.mli +++ /dev/null @@ -1,125 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Type_check - -(* The A-normal form (ANF) grammar *) - -type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l - -and 'a aexp_aux = - | AE_val of 'a aval - | AE_app of id * ('a aval) list * 'a - | AE_cast of 'a aexp * 'a - | AE_assign of id * 'a * 'a aexp - | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a - | AE_block of ('a aexp) list * 'a aexp * 'a - | AE_return of 'a aval * 'a - | AE_throw of 'a aval * 'a - | AE_if of 'a aval * 'a aexp * 'a aexp * 'a - | AE_field of 'a aval * id * 'a - | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a - | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp - | AE_loop of loop * 'a aexp * 'a aexp - | AE_short_circuit of sc_op * 'a aval * 'a aexp - -and sc_op = SC_and | SC_or - -and 'a apat = AP_aux of 'a apat_aux * Env.t * l - -and 'a apat_aux = - | AP_tup of ('a apat) list - | AP_id of id * 'a - | AP_global of id * 'a - | AP_app of id * 'a apat * 'a - | AP_cons of 'a apat * 'a apat - | AP_nil of 'a - | AP_wild of 'a - -and 'a aval = - | AV_lit of lit * 'a - | AV_id of id * 'a lvar - | AV_ref of id * 'a lvar - | AV_tuple of ('a aval) list - | AV_list of ('a aval) list * 'a - | AV_vector of ('a aval) list * 'a - | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a * ctyp - -val gensym : unit -> id - -(* Functions for transforming ANF expressions *) - -val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp - -val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp - -val no_shadow : IdSet.t -> 'a aexp -> 'a aexp - -val apat_globals : 'a apat -> (id * 'a) list - -val apat_types : 'a apat -> 'a Bindings.t - -val is_dead_aexp : 'a aexp -> bool - -(* Compiling to ANF expressions *) - -val anf_pat : ?global:bool -> tannot pat -> typ apat - -val anf : tannot exp -> typ aexp - -(* Pretty printing ANF expressions *) -val pp_aval : typ aval -> PPrint.document -val pp_aexp : typ aexp -> PPrint.document diff --git a/src/bytecode_interpreter.ml b/src/bytecode_interpreter.ml deleted file mode 100644 index 398e0c9d..00000000 --- a/src/bytecode_interpreter.ml +++ /dev/null @@ -1,162 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util - -module StringMap = Map.Make(String) - -type 'a frame = { - jump_table : int StringMap.t; - locals : 'a Bindings.t; - pc : int; - instrs : instr array - } - -type 'a gstate = { - globals : 'a Bindings.t; - cdefs : cdef list - } - -type 'a stack = { - top : 'a frame; - ret : ('a -> 'a frame) list - } - -let make_jump_table instrs = - let rec aux n = function - | I_aux (I_label label, _) :: instrs -> StringMap.add label n (aux (n + 1) instrs) - | _ :: instrs -> aux (n + 1) instrs - | [] -> StringMap.empty - in - aux 0 instrs - -let new_gstate cdefs = { - globals = Bindings.empty; - cdefs = cdefs - } - -let new_stack instrs = { - top = { - jump_table = make_jump_table instrs; - locals = Bindings.empty; - pc = 0; - instrs = Array.of_list instrs - }; - ret = [] - } - -let with_top stack f = - { stack with top = f (stack.top) } - -let eval_fragment gstate locals = function - | F_id id -> - begin match Bindings.find_opt id locals with - | Some vl -> vl - | None -> - begin match Bindings.find_opt id gstate.globals with - | Some vl -> vl - | None -> failwith "Identifier not found" - end - end - | F_lit vl -> vl - | _ -> failwith "Cannot eval fragment" - -let is_function id = function - | CDEF_fundef (id', _, _, _) when Id.compare id id' = 0 -> true - | _ -> false - -let step (gstate, stack) = - let I_aux (instr_aux, (_, l)) = stack.top.instrs.(stack.top.pc) in - match instr_aux with - | I_decl _ -> - gstate, with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) - - | I_init (_, id, (fragment, _)) -> - let vl = eval_fragment gstate stack.top.locals fragment in - gstate, - with_top stack (fun frame -> { frame with pc = frame.pc + 1; locals = Bindings.add id vl frame.locals }) - - | I_jump ((fragment, _), label) -> - let vl = eval_fragment gstate stack.top.locals fragment in - gstate, - begin match vl with - | V_bool true -> - with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) - | V_bool false -> - with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) - | _ -> - failwith "Type error" - end - - | I_funcall (clexp, _, id, cvals) -> - let args = List.map (fun (fragment, _) -> eval_fragment gstate stack.top.locals fragment) cvals in - let params, instrs = - match List.find_opt (is_function id) gstate.cdefs with - | Some (CDEF_fundef (_, _, params, instrs)) -> params, instrs - | _ -> failwith "Function not found" - in - gstate, - { - top = { - jump_table = make_jump_table instrs; - locals = List.fold_left2 (fun locals param arg -> Bindings.add param arg locals) Bindings.empty params args; - pc = 0; - instrs = Array.of_list instrs; - }; - ret = (fun vl -> { stack.top with pc = stack.top.pc + 1 }) :: stack.ret - } - - | I_goto label -> - gstate, with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) - - | _ -> raise (Reporting.err_unreachable l __POS__ "Unhandled instruction") diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml deleted file mode 100644 index 630d2a48..00000000 --- a/src/bytecode_util.ml +++ /dev/null @@ -1,771 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Value2 -open PPrint - -(* Define wrappers for creating bytecode instructions. Each function - uses a counter to assign each instruction a unique identifier. *) - -let instr_counter = ref 0 - -let instr_number () = - let n = !instr_counter in - incr instr_counter; - n - -let idecl ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_decl (ctyp, id), (instr_number (), l)) - -let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_reset (ctyp, id), (instr_number (), l)) - -let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = - I_aux (I_init (ctyp, id, cval), (instr_number (), l)) - -let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = - I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) - -let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = - I_aux (I_funcall (clexp, false, id, cvals), (instr_number (), l)) - -let iextern ?loc:(l=Parse_ast.Unknown) clexp id cvals = - I_aux (I_funcall (clexp, true, id, cvals), (instr_number (), l)) - -let icopy l clexp cval = - I_aux (I_copy (clexp, cval), (instr_number (), l)) - -let ialias l clexp cval = - I_aux (I_alias (clexp, cval), (instr_number (), l)) - -let iclear ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_clear (ctyp, id), (instr_number (), l)) - -let ireturn ?loc:(l=Parse_ast.Unknown) cval = - I_aux (I_return cval, (instr_number (), l)) - -let iblock ?loc:(l=Parse_ast.Unknown) instrs = - I_aux (I_block instrs, (instr_number (), l)) - -let itry_block ?loc:(l=Parse_ast.Unknown) instrs = - I_aux (I_try_block instrs, (instr_number (), l)) - -let ithrow ?loc:(l=Parse_ast.Unknown) cval = - I_aux (I_throw cval, (instr_number (), l)) -let icomment ?loc:(l=Parse_ast.Unknown) str = - I_aux (I_comment str, (instr_number (), l)) - -let ilabel ?loc:(l=Parse_ast.Unknown) label = - I_aux (I_label label, (instr_number (), l)) -let igoto ?loc:(l=Parse_ast.Unknown) label = - I_aux (I_goto label, (instr_number (), l)) - -let iundefined ?loc:(l=Parse_ast.Unknown) ctyp = - I_aux (I_undefined ctyp, (instr_number (), l)) - -let imatch_failure ?loc:(l=Parse_ast.Unknown) () = - I_aux (I_match_failure, (instr_number (), l)) - -let iraw ?loc:(l=Parse_ast.Unknown) str = - I_aux (I_raw str, (instr_number (), l)) - -let ijump ?loc:(l=Parse_ast.Unknown) cval label = - I_aux (I_jump (cval, label), (instr_number (), l)) - -let rec frag_rename from_id to_id = function - | F_id id when Id.compare id from_id = 0 -> F_id to_id - | F_id id -> F_id id - | F_ref id when Id.compare id from_id = 0 -> F_ref to_id - | F_ref id -> F_ref id - | F_lit v -> F_lit v - | F_have_exception -> F_have_exception - | F_current_exception -> F_current_exception - | F_call (call, frags) -> F_call (call, List.map (frag_rename from_id to_id) frags) - | F_op (f1, op, f2) -> F_op (frag_rename from_id to_id f1, op, frag_rename from_id to_id f2) - | F_unary (op, f) -> F_unary (op, frag_rename from_id to_id f) - | F_field (f, field) -> F_field (frag_rename from_id to_id f, field) - | F_raw raw -> F_raw raw - | F_poly f -> F_poly (frag_rename from_id to_id f) - -let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) - -let rec clexp_rename from_id to_id = function - | CL_id (id, ctyp) when Id.compare id from_id = 0 -> CL_id (to_id, ctyp) - | CL_id (id, ctyp) -> CL_id (id, ctyp) - | CL_field (clexp, field) -> - CL_field (clexp_rename from_id to_id clexp, field) - | CL_addr clexp -> - CL_addr (clexp_rename from_id to_id clexp) - | CL_tuple (clexp, n) -> - CL_tuple (clexp_rename from_id to_id clexp, n) - | CL_current_exception ctyp -> CL_current_exception ctyp - | CL_have_exception -> CL_have_exception - -let rec instr_rename from_id to_id (I_aux (instr, aux)) = - let instr = match instr with - | I_decl (ctyp, id) when Id.compare id from_id = 0 -> I_decl (ctyp, to_id) - | I_decl (ctyp, id) -> I_decl (ctyp, id) - - | I_init (ctyp, id, cval) when Id.compare id from_id = 0 -> - I_init (ctyp, to_id, cval_rename from_id to_id cval) - | I_init (ctyp, id, cval) -> - I_init (ctyp, id, cval_rename from_id to_id cval) - - | I_if (cval, then_instrs, else_instrs, ctyp2) -> - I_if (cval_rename from_id to_id cval, - List.map (instr_rename from_id to_id) then_instrs, - List.map (instr_rename from_id to_id) else_instrs, - ctyp2) - - | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) - - | I_funcall (clexp, extern, id, args) -> - I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) - - | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) - | I_alias (clexp, cval) -> I_alias (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) - - | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) - | I_clear (ctyp, id) -> I_clear (ctyp, id) - - | I_return cval -> I_return (cval_rename from_id to_id cval) - - | I_block instrs -> I_block (List.map (instr_rename from_id to_id) instrs) - - | I_try_block instrs -> I_try_block (List.map (instr_rename from_id to_id) instrs) - - | I_throw cval -> I_throw (cval_rename from_id to_id cval) - - | I_comment str -> I_comment str - - | I_raw str -> I_raw str - - | I_label label -> I_label label - - | I_goto label -> I_goto label - - | I_undefined ctyp -> I_undefined ctyp - - | I_match_failure -> I_match_failure - - | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id) - | I_reset (ctyp, id) -> I_reset (ctyp, id) - - | I_reinit (ctyp, id, cval) when Id.compare id from_id = 0 -> - I_reinit (ctyp, to_id, cval_rename from_id to_id cval) - | I_reinit (ctyp, id, cval) -> - I_reinit (ctyp, id, cval_rename from_id to_id cval) - in - I_aux (instr, aux) - -(**************************************************************************) -(* 1. Instruction pretty printer *) -(**************************************************************************) - -let string_of_value = function - | V_bits [] -> "UINT64_C(0)" - | V_bits bs -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" - | V_int i -> Big_int.to_string i ^ "l" - | V_bool true -> "true" - | V_bool false -> "false" - | V_null -> "NULL" - | V_unit -> "UNIT" - | V_bit Sail2_values.B0 -> "UINT64_C(0)" - | V_bit Sail2_values.B1 -> "UINT64_C(1)" - | V_string str -> "\"" ^ str ^ "\"" - | V_ctor_kind str -> "Kind_" ^ Util.zencode_string str - | _ -> failwith "Cannot convert value to string" - -let rec string_of_fragment ?zencode:(zencode=true) = function - | F_id id when zencode -> Util.zencode_string (string_of_id id) - | F_id id -> string_of_id id - | F_ref id when zencode -> "&" ^ Util.zencode_string (string_of_id id) - | F_ref id -> "&" ^ string_of_id id - | F_lit v -> string_of_value v - | F_call (str, frags) -> - Printf.sprintf "%s(%s)" str (Util.string_of_list ", " (string_of_fragment ~zencode:zencode) frags) - | F_field (f, field) -> - Printf.sprintf "%s.%s" (string_of_fragment' ~zencode:zencode f) field - | F_op (f1, op, f2) -> - Printf.sprintf "%s %s %s" (string_of_fragment' ~zencode:zencode f1) op (string_of_fragment' ~zencode:zencode f2) - | F_unary (op, f) -> - op ^ string_of_fragment' ~zencode:zencode f - | F_have_exception -> "have_exception" - | F_current_exception -> "(*current_exception)" - | F_raw raw -> raw - | F_poly f -> string_of_fragment ~zencode:zencode f -and string_of_fragment' ?zencode:(zencode=true) f = - match f with - | F_op _ | F_unary _ -> "(" ^ string_of_fragment ~zencode:zencode f ^ ")" - | _ -> string_of_fragment ~zencode:zencode f - -(* String representation of ctyps here is only for debugging and - intermediate language pretty-printer. *) -and string_of_ctyp = function - | CT_lint -> "int" - | CT_lbits true -> "lbits(dec)" - | CT_lbits false -> "lbits(inc)" - | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" - | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" - | CT_sbits true -> "sbits(dec)" - | CT_sbits false -> "sbits(inc)" - | CT_fint n -> "int(" ^ string_of_int n ^ ")" - | CT_bit -> "bit" - | CT_unit -> "unit" - | CT_bool -> "bool" - | CT_real -> "real" - | CT_tup ctyps -> "(" ^ Util.string_of_list ", " string_of_ctyp ctyps ^ ")" - | CT_struct (id, _) | CT_enum (id, _) | CT_variant (id, _) -> string_of_id id - | CT_string -> "string" - | CT_vector (true, ctyp) -> "vector(dec, " ^ string_of_ctyp ctyp ^ ")" - | CT_vector (false, ctyp) -> "vector(inc, " ^ string_of_ctyp ctyp ^ ")" - | CT_list ctyp -> "list(" ^ string_of_ctyp ctyp ^ ")" - | CT_ref ctyp -> "ref(" ^ string_of_ctyp ctyp ^ ")" - | CT_poly -> "*" - -(** This function is like string_of_ctyp, but recursively prints all - constructors in variants and structs. Used for debug output. *) -and full_string_of_ctyp = function - | CT_lint -> "int" - | CT_lbits true -> "lbits(dec)" - | CT_lbits false -> "lbits(inc)" - | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" - | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" - | CT_sbits true -> "sbits(dec)" - | CT_sbits false -> "sbits(inc)" - | CT_fint n -> "int(" ^ string_of_int n ^ ")" - | CT_bit -> "bit" - | CT_unit -> "unit" - | CT_bool -> "bool" - | CT_real -> "real" - | CT_tup ctyps -> "(" ^ Util.string_of_list ", " full_string_of_ctyp ctyps ^ ")" - | CT_enum (id, _) -> string_of_id id - | CT_struct (id, ctors) | CT_variant (id, ctors) -> - "struct " ^ string_of_id id - ^ "{ " - ^ Util.string_of_list ", " (fun (id, ctyp) -> string_of_id id ^ " : " ^ full_string_of_ctyp ctyp) ctors - ^ "}" - | CT_string -> "string" - | CT_vector (true, ctyp) -> "vector(dec, " ^ full_string_of_ctyp ctyp ^ ")" - | CT_vector (false, ctyp) -> "vector(inc, " ^ full_string_of_ctyp ctyp ^ ")" - | CT_list ctyp -> "list(" ^ full_string_of_ctyp ctyp ^ ")" - | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" - | CT_poly -> "*" - -let rec map_ctyp f = function - | (CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ - | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp - | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) - | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) - | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) - | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) - | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) - | CT_variant (id, ctors) -> f (CT_variant (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) - -let rec ctyp_equal ctyp1 ctyp2 = - match ctyp1, ctyp2 with - | CT_lint, CT_lint -> true - | CT_lbits d1, CT_lbits d2 -> d1 = d2 - | CT_sbits d1, CT_sbits d2 -> d1 = d2 - | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2 - | CT_bit, CT_bit -> true - | CT_fint n, CT_fint m -> n = m - | CT_unit, CT_unit -> true - | CT_bool, CT_bool -> true - | CT_struct (id1, _), CT_struct (id2, _) -> Id.compare id1 id2 = 0 - | CT_enum (id1, _), CT_enum (id2, _) -> Id.compare id1 id2 = 0 - | CT_variant (id1, _), CT_variant (id2, _) -> Id.compare id1 id2 = 0 - | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> - List.for_all2 ctyp_equal ctyps1 ctyps2 - | CT_string, CT_string -> true - | CT_real, CT_real -> true - | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 - | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 - | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 - | CT_poly, CT_poly -> true - | _, _ -> false - -let rec ctyp_unify ctyp1 ctyp2 = - match ctyp1, ctyp2 with - | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> - List.concat (List.map2 ctyp_unify ctyps1 ctyps2) - - | CT_vector (b1, ctyp1), CT_vector (b2, ctyp2) when b1 = b2 -> - ctyp_unify ctyp1 ctyp2 - - | CT_list ctyp1, CT_list ctyp2 -> ctyp_unify ctyp1 ctyp2 - - | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_unify ctyp1 ctyp2 - - | CT_poly, _ -> [ctyp2] - - | _, _ when ctyp_equal ctyp1 ctyp2 -> [] - | _, _ -> raise (Invalid_argument "ctyp_unify") - -let rec ctyp_suprema = function - | CT_lint -> CT_lint - | CT_lbits d -> CT_lbits d - | CT_fbits (_, d) -> CT_lbits d - | CT_sbits d -> CT_lbits d - | CT_fint _ -> CT_lint - | CT_unit -> CT_unit - | CT_bool -> CT_bool - | CT_real -> CT_real - | CT_bit -> CT_bit - | CT_tup ctyps -> CT_tup (List.map ctyp_suprema ctyps) - | CT_string -> CT_string - | CT_enum (id, ids) -> CT_enum (id, ids) - (* Do we really never want to never call ctyp_suprema on constructor - fields? Doing it causes issues for structs (see - test/c/stack_struct.sail) but it might be wrong to not call it - for nested variants... *) - | CT_struct (id, ctors) -> CT_struct (id, ctors) - | CT_variant (id, ctors) -> CT_variant (id, ctors) - | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) - | CT_list ctyp -> CT_list (ctyp_suprema ctyp) - | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) - | CT_poly -> CT_poly - -let rec ctyp_ids = function - | CT_enum (id, _) -> IdSet.singleton id - | CT_struct (id, ctors) | CT_variant (id, ctors) -> - IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) - | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit - | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty - -let rec unpoly = function - | F_poly f -> unpoly f - | F_call (call, fs) -> F_call (call, List.map unpoly fs) - | F_field (f, field) -> F_field (unpoly f, field) - | F_op (f1, op, f2) -> F_op (unpoly f1, op, unpoly f2) - | F_unary (op, f) -> F_unary (op, unpoly f) - | f -> f - -let rec is_polymorphic = function - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false - | CT_tup ctyps -> List.exists is_polymorphic ctyps - | CT_enum _ -> false - | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp - | CT_poly -> true - -let pp_id id = - string (string_of_id id) - -let pp_ctyp ctyp = - string (string_of_ctyp ctyp |> Util.yellow |> Util.clear) - -let pp_keyword str = - string ((str |> Util.red |> Util.clear) ^ " ") - -let pp_cval (frag, ctyp) = - string (string_of_fragment ~zencode:false frag) ^^ string " : " ^^ pp_ctyp ctyp - -let rec pp_clexp = function - | CL_id (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | CL_field (clexp, field) -> parens (pp_clexp clexp) ^^ string "." ^^ string field - | CL_tuple (clexp, n) -> parens (pp_clexp clexp) ^^ string "." ^^ string (string_of_int n) - | CL_addr clexp -> string "*" ^^ pp_clexp clexp - | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp - | CL_have_exception -> string "have_exception" - -let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = - match instr with - | I_decl (ctyp, id) -> - pp_keyword "var" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_if (cval, then_instrs, else_instrs, ctyp) -> - let pp_if_block = function - | [] -> string "{}" - | instrs -> surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - in - parens (pp_ctyp ctyp) ^^ space - ^^ pp_keyword "if" ^^ pp_cval cval - ^^ if short then - empty - else - pp_keyword " then" ^^ pp_if_block then_instrs - ^^ pp_keyword " else" ^^ pp_if_block else_instrs - | I_jump (cval, label) -> - pp_keyword "jump" ^^ pp_cval cval ^^ space ^^ string (label |> Util.blue |> Util.clear) - | I_block instrs -> - surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - | I_try_block instrs -> - pp_keyword "try" ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - | I_reset (ctyp, id) -> - pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_init (ctyp, id, cval) -> - pp_keyword "create" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval - | I_reinit (ctyp, id, cval) -> - pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval - | I_funcall (x, _, f, args) -> - separate space [ pp_clexp x; string "="; - string (string_of_id f |> Util.green |> Util.clear) ^^ parens (separate_map (string ", ") pp_cval args) ] - | I_copy (clexp, cval) -> - separate space [pp_clexp clexp; string "="; pp_cval cval] - | I_alias (clexp, cval) -> - pp_keyword "alias" ^^ separate space [pp_clexp clexp; string "="; pp_cval cval] - | I_clear (ctyp, id) -> - pp_keyword "kill" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_return cval -> - pp_keyword "return" ^^ pp_cval cval - | I_throw cval -> - pp_keyword "throw" ^^ pp_cval cval - | I_comment str -> - string ("// " ^ str |> Util.magenta |> Util.clear) - | I_label str -> - string (str |> Util.blue |> Util.clear) ^^ string ":" - | I_goto str -> - pp_keyword "goto" ^^ string (str |> Util.blue |> Util.clear) - | I_match_failure -> - pp_keyword "match_failure" - | I_undefined ctyp -> - pp_keyword "undefined" ^^ pp_ctyp ctyp - | I_raw str -> - pp_keyword "C" ^^ string (str |> Util.cyan |> Util.clear) - -let pp_ctype_def = function - | CTD_enum (id, ids) -> - pp_keyword "enum" ^^ pp_id id ^^ string " = " - ^^ separate_map (string " | ") pp_id ids - | CTD_struct (id, fields) -> - pp_keyword "struct" ^^ pp_id id ^^ string " = " - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) fields) rbrace - | CTD_variant (id, ctors) -> - pp_keyword "union" ^^ pp_id id ^^ string " = " - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) ctors) rbrace - -let pp_cdef = function - | CDEF_spec (id, ctyps, ctyp) -> - pp_keyword "val" ^^ pp_id id ^^ string " : " ^^ parens (separate_map (comma ^^ space) pp_ctyp ctyps) ^^ string " -> " ^^ pp_ctyp ctyp - ^^ hardline - | CDEF_fundef (id, ret, args, instrs) -> - let ret = match ret with - | None -> empty - | Some id -> space ^^ pp_id id - in - pp_keyword "function" ^^ pp_id id ^^ ret ^^ parens (separate_map (comma ^^ space) pp_id args) ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_reg_dec (id, ctyp, instrs) -> - pp_keyword "register" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_type tdef -> pp_ctype_def tdef ^^ hardline - | CDEF_let (n, bindings, instrs) -> - let pp_binding (id, ctyp) = pp_id id ^^ string " : " ^^ pp_ctyp ctyp in - pp_keyword "let" ^^ string (string_of_int n) ^^ parens (separate_map (comma ^^ space) pp_binding bindings) ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace ^^ space - ^^ hardline - | CDEF_startup (id, instrs)-> - pp_keyword "startup" ^^ pp_id id ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_finish (id, instrs)-> - pp_keyword "finish" ^^ pp_id id ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - -(**************************************************************************) -(* 2. Dependency Graphs *) -(**************************************************************************) - -type graph_node = - | G_label of string - | G_instr of int * instr - | G_start - -let string_of_node = function - | G_label label -> label - | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) - | G_start -> "START" - -module Node = struct - type t = graph_node - let compare gn1 gn2 = - match gn1, gn2 with - | G_label str1, G_label str2 -> String.compare str1 str2 - | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 - | G_start , G_start -> 0 - | G_start , _ -> 1 - | _ , G_start -> -1 - | G_instr _, _ -> 1 - | _ , G_instr _ -> -1 -end - -module NodeGraph = Graph.Make(Node) - -module NM = Map.Make(Node) -module NS = Set.Make(Node) - -type dep_graph = NodeGraph.graph - -let rec fragment_deps = function - | F_id id | F_ref id -> IdSet.singleton id - | F_lit _ -> IdSet.empty - | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag - | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags) - | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2) - | F_current_exception -> IdSet.empty - | F_have_exception -> IdSet.empty - | F_raw _ -> IdSet.empty - -let cval_deps = function (frag, _) -> fragment_deps frag - -let rec clexp_deps = function - | CL_id (id, _) -> IdSet.singleton id - | CL_field (clexp, _) -> clexp_deps clexp - | CL_tuple (clexp, _) -> clexp_deps clexp - | CL_addr clexp -> clexp_deps clexp - | CL_have_exception -> IdSet.empty - | CL_current_exception _ -> IdSet.empty - -(* Return the direct, read/write dependencies of a single instruction *) -let instr_deps = function - | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id - | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id - | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id - | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty - | I_jump (cval, label) -> cval_deps cval, IdSet.empty - | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp - | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id - | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty - | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty - | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty - | I_label label -> IdSet.empty, IdSet.empty - | I_goto label -> IdSet.empty, IdSet.empty - | I_undefined _ -> IdSet.empty, IdSet.empty - | I_match_failure -> IdSet.empty, IdSet.empty - -(* instrs_graph returns the control-flow graph for a list of - instructions. *) -let instrs_graph instrs = - let icounter = ref 0 in - let graph = ref NodeGraph.empty in - - let rec add_instr last_instrs (I_aux (instr, _) as iaux) = - incr icounter; - let node = G_instr (!icounter, iaux) in - match instr with - | I_block instrs | I_try_block instrs -> - List.fold_left add_instr last_instrs instrs - | I_if (_, then_instrs, else_instrs, _) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - let n1 = List.fold_left add_instr [node] then_instrs in - let n2 = List.fold_left add_instr [node] else_instrs in - incr icounter; - let join = G_instr (!icounter, icomment "join") in - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; - [join] - | I_return _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | I_label label -> - graph := NodeGraph.add_edge' (G_label label) node !graph; - node :: last_instrs - | I_goto label -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edge' node (G_label label) !graph; - [] - | I_jump (cval, label) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edges' (G_label label) [] !graph; - [node] - | I_match_failure -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [node] - in - ignore (List.fold_left add_instr [G_start] instrs); - let graph = NodeGraph.fix_leaves !graph in - graph - -let make_dot id graph = - Util.opt_colors := false; - let to_string node = String.escaped (string_of_node node) in - let node_color = function - | G_start -> "lightpink" - | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" - | G_instr (_, I_aux (I_init _, _)) -> "springgreen" - | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" - | G_instr (_, I_aux (I_goto _, _)) -> "orange1" - | G_instr (_, I_aux (I_label _, _)) -> "white" - | G_instr (_, I_aux (I_raw _, _)) -> "khaki" - | G_instr (_, I_aux (I_return _, _)) -> "deeppink" - | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" - | G_instr _ -> "azure" - | G_label _ -> "lightpink" - in - let edge_color from_node to_node = - match from_node, to_node with - | G_start , _ -> "goldenrod4" - | G_label _, _ -> "darkgreen" - | _ , G_label _ -> "goldenrod4" - | G_instr _, G_instr _ -> "black" - | _ , _ -> "coral3" - in - let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in - NodeGraph.make_dot node_color edge_color to_string out_chan graph; - close_out out_chan - -let rec map_clexp_ctyp f = function - | CL_id (id, ctyp) -> CL_id (id, f ctyp) - | CL_field (clexp, field) -> CL_field (map_clexp_ctyp f clexp, field) - | CL_tuple (clexp, n) -> CL_tuple (map_clexp_ctyp f clexp, n) - | CL_addr clexp -> CL_addr (map_clexp_ctyp f clexp) - | CL_current_exception ctyp -> CL_current_exception (f ctyp) - | CL_have_exception -> CL_have_exception - -let rec map_instr_ctyp f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl (ctyp, id) -> I_decl (f ctyp, id) - | I_init (ctyp1, id, (frag, ctyp2)) -> I_init (f ctyp1, id, (frag, f ctyp2)) - | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> - I_if ((frag, f ctyp1), List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs, f ctyp2) - | I_jump ((frag, ctyp), label) -> I_jump ((frag, f ctyp), label) - | I_funcall (clexp, extern, id, cvals) -> - I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals) - | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp)) - | I_alias (clexp, (frag, ctyp)) -> I_alias (map_clexp_ctyp f clexp, (frag, f ctyp)) - | I_clear (ctyp, id) -> I_clear (f ctyp, id) - | I_return (frag, ctyp) -> I_return (frag, f ctyp) - | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs) - | I_try_block instrs -> I_try_block (List.map (map_instr_ctyp f) instrs) - | I_throw (frag, ctyp) -> I_throw (frag, f ctyp) - | I_undefined ctyp -> I_undefined (f ctyp) - | I_reset (ctyp, id) -> I_reset (f ctyp, id) - | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2)) - | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr - in - I_aux (instr, aux) - -(** Map over each instruction within an instruction, bottom-up *) -let rec map_instr f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_init _ | I_reset _ | I_reinit _ - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp) - | I_block instrs -> - I_block (List.map (map_instr f) instrs) - | I_try_block instrs -> - I_try_block (List.map (map_instr f) instrs) - in - f (I_aux (instr, aux)) - -(** Map over each instruction in a cdef using map_instr *) -let cdef_map_instr f = function - | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs) - | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr f) instrs) - | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) - | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) - | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) - | CDEF_type tdef -> CDEF_type tdef - -let ctype_def_map_ctyp f = function - | CTD_enum (id, ids) -> CTD_enum (id, ids) - | CTD_struct (id, ctors) -> CTD_struct (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) - | CTD_variant (id, ctors) -> CTD_variant (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) - -(** Map over each ctyp in a cdef using map_instr_ctyp *) -let cdef_map_ctyp f = function - | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, f ctyp, List.map (map_instr_ctyp f) instrs) - | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr_ctyp f) instrs) - | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) - | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) - | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) - | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) - -(* Map over all sequences of instructions contained within an instruction *) -let rec map_instrs f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr - | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) - | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr - in - I_aux (instr, aux) - -let rec instr_ids (I_aux (instr, _)) = - let reads, writes = instr_deps instr in - IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) - -let rec instr_reads (I_aux (instr, _)) = - let reads, _ = instr_deps instr in - IdSet.of_list (IdSet.elements reads) - -let rec instr_writes (I_aux (instr, _)) = - let _, writes = instr_deps instr in - IdSet.of_list (IdSet.elements writes) - -let rec filter_instrs f instrs = - let filter_instrs' = function - | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) - | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) - | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> - I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) - | instr -> instr - in - List.filter f (List.map filter_instrs' instrs) diff --git a/src/c_backend.ml b/src/c_backend.ml deleted file mode 100644 index 14930d47..00000000 --- a/src/c_backend.ml +++ /dev/null @@ -1,3715 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util -open Type_check -open PPrint -open Value2 - -open Anf - -module Big_int = Nat_big_num - -let c_verbosity = ref 0 - -let opt_debug_flow_graphs = ref false -let opt_debug_function = ref "" -let opt_trace = ref false -let opt_smt_trace = ref false -let opt_static = ref false -let opt_no_main = ref false -let opt_memo_cache = ref false -let opt_no_rts = ref false -let opt_prefix = ref "z" -let opt_extra_params = ref None -let opt_extra_arguments = ref None - -let extra_params () = - match !opt_extra_params with - | Some str -> str ^ ", " - | _ -> "" - -let extra_arguments is_extern = - match !opt_extra_arguments with - | Some str when not is_extern -> str ^ ", " - | _ -> "" - -(* Optimization flags *) -let optimize_primops = ref false -let optimize_hoist_allocations = ref false -let optimize_struct_updates = ref false -let optimize_alias = ref false -let optimize_experimental = ref false - -let c_debug str = - if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () - -let c_error ?loc:(l=Parse_ast.Unknown) message = - raise (Reporting.err_general l ("\nC backend: " ^ message)) - -let zencode_id = function - | Id_aux (Id str, l) -> Id_aux (Id (Util.zencode_string str), l) - | Id_aux (DeIid str, l) -> Id_aux (Id (Util.zencode_string ("op " ^ str)), l) - -(**************************************************************************) -(* 2. Converting sail types to C types *) -(**************************************************************************) - -let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) -let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) - -(** The context type contains two type-checking - environments. ctx.local_env contains the closest typechecking - environment, usually from the expression we are compiling, whereas - ctx.tc_env is the global type checking environment from - type-checking the entire AST. We also keep track of local variables - in ctx.locals, so we know when their type changes due to flow - typing. *) -type ctx = - { records : (ctyp Bindings.t) Bindings.t; - enums : IdSet.t Bindings.t; - variants : (ctyp Bindings.t) Bindings.t; - tc_env : Env.t; - local_env : Env.t; - locals : (mut * ctyp) Bindings.t; - letbinds : int list; - recursive_functions : IdSet.t; - no_raw : bool; - optimize_smt : bool; - iterate_size : bool; - } - -let initial_ctx env = - { records = Bindings.empty; - enums = Bindings.empty; - variants = Bindings.empty; - tc_env = env; - local_env = env; - locals = Bindings.empty; - letbinds = []; - recursive_functions = IdSet.empty; - no_raw = false; - optimize_smt = true; - iterate_size = false; - } - -let initial_ctx_iterate env = - { (initial_ctx env) with iterate_size = true } - -let rec iterate_size ctx size n m = - if size > 64 then - CT_lint - else if prove __POS__ ctx.local_env (nc_and (nc_lteq (nconstant (min_int size)) n) (nc_lteq m (nconstant (max_int size)))) then - CT_fint size - else - iterate_size ctx (size + 1) n m - -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - if ctx.iterate_size then - iterate_size ctx 2 (nconstant n) (nconstant m) - else - CT_fint 64 - | n, m when ctx.optimize_smt -> - if ctx.iterate_size then - iterate_size ctx 2 n m - else if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then - CT_fint 64 - else - CT_lint - | _ -> CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* When converting a sail bitvector type into C, we have three options in order of efficiency: - - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. - - If the length is less than 64, then use a small bits type, sbits. - - If the length may be larger than 64, use a large bits type lbits. *) - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) - when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - begin match nexp_simp n with - | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) - | n when ctx.optimize_smt && prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> Bindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ when ctx.optimize_smt -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_exist (_, _, typ) -> ctyp_of_typ ctx typ - - | Typ_var kid -> CT_poly - - | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - -let rec is_stack_ctyp ctyp = match ctyp with - | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true - | CT_fint n -> n <= 64 - | CT_lbits _ | CT_lint | CT_real | CT_string | CT_list _ | CT_vector _ -> false - | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields - | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) - | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps - | CT_ref ctyp -> true - | CT_poly -> true - -let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) - -let is_fbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_fbits _ -> true - | _ -> false - -let is_sbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_sbits _ -> true - | _ -> false - -let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty - -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) - -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_fragment (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - Some (F_lit (V_int n), CT_fint 64) - | L_hex str when String.length str <= 16 -> - let padding = 16 - String.length str in - let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (F_lit (V_bits (padding @ content)), CT_fbits (String.length str * 4, true)) - | L_unit -> Some (F_lit V_unit, CT_unit) - | L_true -> Some (F_lit (V_bool true), CT_bool) - | L_false -> Some (F_lit (V_bool false), CT_bool) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> - begin - match literal_to_fragment lit with - | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) - | None -> v - end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal - -let mask m = - if Big_int.less_equal m (Big_int.of_int 64) then - let n = Big_int.to_int m in - if n = 0 then - "UINT64_C(0)" - else if n mod 4 = 0 then - "UINT64_C(0x" ^ String.make (16 - n / 4) '0' ^ String.make (n / 4) 'F' ^ ")" - else - "UINT64_C(" ^ String.make (64 - n) '0' ^ String.make n '1' ^ ")" - else - failwith "Tried to create a mask literal for a vector greater than 64 bits." - -let rec is_bitvector = function - | [] -> true - | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals - | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals - | _ :: _ -> false - -let rec value_of_aval_bit = function - | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 - | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 - | _ -> assert false - -let rec c_aval ctx = function - | AV_lit (lit, typ) as v -> - begin - match literal_to_fragment lit with - | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) - | None -> v - end - | AV_C_fragment (str, typ, ctyp) -> AV_C_fragment (str, typ, ctyp) - (* An id can be converted to a C fragment if it's type can be - stack-allocated. *) - | AV_id (id, lvar) as v -> - begin - match lvar with - | Local (_, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp then - begin - try - (* We need to check that id's type hasn't changed due to flow typing *) - let _, ctyp' = Bindings.find id ctx.locals in - if ctyp_equal ctyp ctyp' then - AV_C_fragment (F_id id, typ, ctyp) - else - (* id's type changed due to flow - typing, so it's really still heap allocated! *) - v - with - (* Hack: Assuming global letbindings don't change from flow typing... *) - Not_found -> AV_C_fragment (F_id id, typ, ctyp) - end - else - v - | Register (_, _, typ) when is_stack_typ ctx typ -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp then - AV_C_fragment (F_id id, typ, ctyp) - else - v - | _ -> v - end - | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> - let bitstring = F_lit (V_bits (List.map value_of_aval_bit v)) in - AV_C_fragment (bitstring, typ, CT_fbits (List.length v, true)) - | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) - | aval -> aval - -let is_c_fragment = function - | AV_C_fragment _ -> true - | _ -> false - -let c_fragment = function - | AV_C_fragment (frag, _, _) -> frag - | _ -> assert false - -let v_mask_lower i = F_lit (V_bits (Util.list_init i (fun _ -> Sail2_values.B1))) - -(* Map over all the functions in an aexp. *) -let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = - let ctx = { ctx with local_env = env } in - let aexp = match aexp with - | AE_app (id, vs, typ) -> f ctx id vs typ - - | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) - - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) - - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) - - | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> - let aexp1 = analyze_functions ctx f aexp1 in - (* Use aexp2's environment because it will contain constraints for id *) - let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in - let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in - AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) - - | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) - - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) - - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) - - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let aexp1 = analyze_functions ctx f aexp1 in - let aexp2 = analyze_functions ctx f aexp2 in - let aexp3 = analyze_functions ctx f aexp3 in - let aexp4 = analyze_functions ctx f aexp4 in - (* Currently we assume that loop indexes are always safe to put into an int64 *) - let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in - AE_for (id, aexp1, aexp2, aexp3, order, aexp4) - - | AE_case (aval, cases, typ) -> - let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = - let pat_bindings = Bindings.bindings (apat_types pat) in - let ctx = { ctx with local_env = env } in - let ctx = - List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings - in - pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 - in - AE_case (aval, List.map analyze_case cases, typ) - - | AE_try (aexp, cases, typ) -> - AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) - - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) - -let analyze_primop' ctx id args typ = - let no_change = AE_app (id, args, typ) in - let args = List.map (c_aval ctx) args in - let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in - - let v_one = F_lit (V_int (Big_int.of_int 1)) in - let v_int n = F_lit (V_int (Big_int.of_int n)) in - - c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); - - match extern, args with - | "eq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) - | "eq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_call ("eq_sbits", [v1; v2]), typ, CT_bool)) - - | "neq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ, CT_bool)) - | "neq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_call ("neq_sbits", [v1; v2]), typ, CT_bool)) - - | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) - - | "zeros", [_] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_raw "0x0", typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) - | _ -> no_change - end - - | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) - | _ -> no_change - end - - | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)] - when n <= 63 -> - AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord))) - - | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool)) - | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) - | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool)) - | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool)) - - | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) - | "xor_bits", [AV_C_fragment (v1, _, (CT_sbits _ as ctyp)); AV_C_fragment (v2, _, CT_sbits _)] -> - AE_val (AV_C_fragment (F_call ("xor_sbits", [v1; v2]), typ, ctyp)) - - | "or_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) - - | "and_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) - - | "not_bits", [AV_C_fragment (v, _, ctyp)] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ, ctyp)) - | _ -> no_change - end - - | "vector_subrange", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] - when is_fbits_typ ctx typ -> - let len = F_op (f, "-", F_op (t, "-", v_one)) in - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), - typ, - ctyp_of_typ ctx typ)) - - | "vector_access", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (n, _, _)] -> - AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) - - | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> - AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) - - | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] - when is_fbits_typ ctx typ -> - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), - typ, - ctyp_of_typ ctx typ)) - - | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] - when is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("sslice", [vec; start; len]), typ, ctyp_of_typ ctx typ)) - - | "undefined_bit", _ -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) - - (* Optimized routines for all combinations of fixed and small bits - appends, where the result is guaranteed to be smaller than 64. *) - | "append", [AV_C_fragment (vec1, _, CT_fbits (0, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2)) as v2] - when ord1 = ord2 -> - AE_val v2 - | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] - when ord1 = ord2 && n1 + n2 <= 64 -> - AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) - - | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ)) - - | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits ord2)] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ)) - - | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_sbits ord2)] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ)) - - | "undefined_vector", [AV_C_fragment (len, _, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "sail_unsigned", [AV_C_fragment (frag, vtyp, _)] -> - begin match destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _) - when Big_int.less_equal n (Big_int.of_int 63) && is_stack_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("fast_unsigned", [frag]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "sail_signed", [AV_C_fragment (frag, vtyp, _)] -> - begin match destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> - begin match destruct_range Env.empty typ with - | None -> no_change - | Some (kids, constr, n, m) -> - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) - | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> - AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) - | _ -> no_change - end - - | "neg_int", [AV_C_fragment (frag, _, _)] -> - AE_val (AV_C_fragment (F_op (v_int 0, "-", frag), typ, CT_fint 64)) - - | "replicate_bits", [AV_C_fragment (vec, vtyp, _); AV_C_fragment (times, _, _)] -> - begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true)); - AV_C_fragment (hi, _, CT_fint 64); - AV_C_fragment (lo, _, CT_fint 64); - AV_C_fragment (ys, _, CT_fbits (m, true))] -> - AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) - - | "undefined_bool", _ -> - AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) - - | _, _ -> - c_debug (lazy ("No optimization routine found")); - no_change - -let analyze_primop ctx id args typ = - let no_change = AE_app (id, args, typ) in - if !optimize_primops then - try analyze_primop' ctx id args typ with - | Failure str -> - (c_debug (lazy ("Analyze primop failed for id " ^ string_of_id id ^ " reason: " ^ str))); - no_change - else - no_change - -(**************************************************************************) -(* 4. Conversion to low-level AST *) -(**************************************************************************) - -(** We now use a low-level AST (see language/bytecode.ott) that is - only slightly abstracted away from C. To be succint in comments we - usually refer to this as Sail IR or IR rather than low-level AST - repeatedly. - - The general idea is ANF expressions are converted into lists of - instructions (type instr) where allocations and deallocations are - now made explicit. ANF values (aval) are mapped to the cval type, - which is even simpler still. Some things are still more abstract - than in C, so the type definitions follow the sail type definition - structure, just with typ (from ast.ml) replaced with - ctyp. Top-level declarations that have no meaning for the backend - are not included at this level. - - The convention used here is that functions of the form compile_X - compile the type X into types in this AST, so compile_aval maps - avals into cvals. Note that the return types for these functions - are often quite complex, and they usually return some tuple - containing setup instructions (to allocate memory for the - expression), cleanup instructions (to deallocate that memory) and - possibly typing information about what has been translated. **) - -let ctype_def_ctyps = function - | CTD_enum _ -> [] - | CTD_struct (_, fields) -> List.map snd fields - | CTD_variant (_, ctors) -> List.map snd ctors - -let cval_ctyp = function (_, ctyp) -> ctyp - -let rec clexp_ctyp = function - | CL_id (_, ctyp) -> ctyp - | CL_field (clexp, field) -> - begin match clexp_ctyp clexp with - | CT_struct (id, ctors) -> - begin - try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with - | Not_found -> c_error ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field) - end - | ctyp -> c_error ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp) - end - | CL_addr clexp -> - begin match clexp_ctyp clexp with - | CT_ref ctyp -> ctyp - | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) - end - | CL_tuple (clexp, n) -> - begin match clexp_ctyp clexp with - | CT_tup typs -> - begin - try List.nth typs n with - | _ -> c_error "Tuple assignment index out of bounds" - end - | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) - end - | CL_have_exception -> CT_bool - | CL_current_exception ctyp -> ctyp - -let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) - -let rec instr_ctyps (I_aux (instr, aux)) = - match instr with - | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> [ctyp] - | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> [ctyp; cval_ctyp cval] - | I_if (cval, instrs1, instrs2, ctyp) -> - ctyp :: cval_ctyp cval :: List.concat (List.map instr_ctyps instrs1 @ List.map instr_ctyps instrs2) - | I_funcall (clexp, _, _, cvals) -> - clexp_ctyp clexp :: List.map cval_ctyp cvals - | I_copy (clexp, cval) | I_alias (clexp, cval) -> [clexp_ctyp clexp; cval_ctyp cval] - | I_block instrs | I_try_block instrs -> List.concat (List.map instr_ctyps instrs) - | I_throw cval | I_jump (cval, _) | I_return cval -> [cval_ctyp cval] - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure -> [] - -let rec c_ast_registers = function - | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast - | _ :: ast -> c_ast_registers ast - | [] -> [] - -let cdef_ctyps ctx = function - | CDEF_reg_dec (_, ctyp, instrs) -> ctyp :: List.concat (List.map instr_ctyps instrs) - | CDEF_spec (_, ctyps, ctyp) -> ctyp :: ctyps - | CDEF_fundef (id, _, _, instrs) -> - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let arg_ctyps, ret_ctyp = - List.map (ctyp_of_typ ctx) arg_typs, - ctyp_of_typ { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } ret_typ - in - ret_ctyp :: arg_ctyps @ List.concat (List.map instr_ctyps instrs) - - | CDEF_startup (id, instrs) | CDEF_finish (id, instrs) -> List.concat (List.map instr_ctyps instrs) - | CDEF_type tdef -> ctype_def_ctyps tdef - | CDEF_let (_, bindings, instrs) -> - List.map snd bindings - @ List.concat (List.map instr_ctyps instrs) - -let is_ct_enum = function - | CT_enum _ -> true - | _ -> false - -let is_ct_variant = function - | CT_variant _ -> true - | _ -> false - -let is_ct_tup = function - | CT_tup _ -> true - | _ -> false - -let is_ct_list = function - | CT_list _ -> true - | _ -> false - -let is_ct_vector = function - | CT_vector _ -> true - | _ -> false - -let is_ct_struct = function - | CT_struct _ -> true - | _ -> false - -let is_ct_ref = function - | CT_ref _ -> true - | _ -> false - -let rec chunkify n xs = - match Util.take n xs, Util.drop n xs with - | xs, [] -> [xs] - | xs, ys -> xs :: chunkify n ys - -let rec compile_aval l ctx = function - | AV_C_fragment (frag, typ, ctyp) -> - let ctyp' = ctyp_of_typ ctx typ in - if not (ctyp_equal ctyp ctyp' || ctx.iterate_size) then - raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp')); - [], (frag, ctyp_of_typ ctx typ), [] - - | AV_id (id, typ) -> - begin - try - let _, ctyp = Bindings.find id ctx.locals in - [], (F_id id, ctyp), [] - with - | Not_found -> - [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), [] - end - - | AV_ref (id, typ) -> - [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] - - | AV_lit (L_aux (L_string str, _), typ) -> - [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), [] - - | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - let gs = gensym () in - [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)], - (F_id gs, CT_lint), - [iclear CT_lint gs] - - | AV_lit (L_aux (L_num n, _), typ) -> - let gs = gensym () in - [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)], - (F_id gs, CT_lint), - [iclear CT_lint gs] - - | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), [] - | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), [] - - | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), [] - | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), [] - - | AV_lit (L_aux (L_real str, _), _) -> - let gs = gensym () in - [iinit CT_real gs (F_lit (V_string str), CT_string)], - (F_id gs, CT_real), - [iclear CT_real gs] - - | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), [] - - | AV_lit (L_aux (_, l) as lit, _) -> - c_error ~loc:l ("Encountered unexpected literal " ^ string_of_lit lit) - - | AV_tuple avals -> - let elements = List.map (compile_aval l ctx) avals in - let cvals = List.map (fun (_, cval, _) -> cval) elements in - let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in - let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in - let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in - let gs = gensym () in - setup - @ [idecl tup_ctyp gs] - @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals, - (F_id gs, CT_tup (List.map cval_ctyp cvals)), - [iclear tup_ctyp gs] - @ cleanup - - | AV_record (fields, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let gs = gensym () in - let compile_fields (id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] - @ field_cleanup - in - [idecl ctyp gs] - @ List.concat (List.map compile_fields (Bindings.bindings fields)), - (F_id gs, ctyp), - [iclear ctyp gs] - - | AV_vector ([], _) -> - c_error "Encountered empty vector literal" - - (* Convert a small bitvector to a uint64_t literal. *) - | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 -> - begin - let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in - let len = List.length avals in - match destruct_vector ctx.tc_env typ with - | Some (_, Ord_aux (Ord_inc, _), _) -> - [], (bitstring, CT_fbits (len, false)), [] - | Some (_, Ord_aux (Ord_dec, _), _) -> - [], (bitstring, CT_fbits (len, true)), [] - | Some _ -> - c_error "Encountered order polymorphic bitvector literal" - | None -> - c_error "Encountered vector literal without vector type" - end - - (* Convert a bitvector literal that is larger than 64-bits to a - variable size bitvector, converting it in 64-bit chunks. *) - | AV_vector (avals, typ) when is_bitvector avals -> - let len = List.length avals in - let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in - let first_chunk = bitstring (Util.take (len mod 64) avals) in - let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in - let gs = gensym () in - [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))] - @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true)) - (mk_id "append_64") - [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks, - (F_id gs, CT_lbits true), - [iclear (CT_lbits true) gs] - - (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) - when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 -> - let len = List.length avals in - let direction = match ord with - | Ord_aux (Ord_inc, _) -> false - | Ord_aux (Ord_dec, _) -> true - | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found" - in - let gs = gensym () in - let ctyp = CT_fbits (len, direction) in - let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in - let aval_mask i aval = - let setup, cval, cleanup = compile_aval l ctx aval in - match cval with - | (F_lit (V_bit Sail2_values.B0), _) -> [] - | (F_lit (V_bit Sail2_values.B1), _) -> - [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] - | _ -> - setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup - in - [idecl ctyp gs; - icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)] - @ List.concat (List.mapi aval_mask (List.rev avals)), - (F_id gs, ctyp), - [] - - (* Compiling a vector literal that isn't a bitvector *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _)) - when string_of_id id = "vector" -> - let len = List.length avals in - let direction = match ord with - | Ord_aux (Ord_inc, _) -> false - | Ord_aux (Ord_dec, _) -> true - | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found" - in - let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in - let gs = gensym () in - let aval_set i aval = - let setup, cval, cleanup = compile_aval l ctx aval in - setup - @ [iextern (CL_id (gs, vector_ctyp)) - (mk_id "internal_vector_update") - [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]] - @ cleanup - in - [idecl vector_ctyp gs; - iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]] - @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)), - (F_id gs, vector_ctyp), - [iclear vector_ctyp gs] - - | AV_vector _ as aval -> - c_error ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type") - - | AV_list (avals, Typ_aux (typ, _)) -> - let ctyp = match typ with - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ - | _ -> c_error "Invalid list type" - in - let gs = gensym () in - let mk_cons aval = - let setup, cval, cleanup = compile_aval l ctx aval in - setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup - in - [idecl (CT_list ctyp) gs] - @ List.concat (List.map mk_cons (List.rev avals)), - (F_id gs, CT_list ctyp), - [iclear (CT_list ctyp) gs] - -let compile_funcall l ctx id args typ = - let setup = ref [] in - let cleanup = ref [] in - - let quant, Typ_aux (fn_typ, _) = - try Env.get_val_spec id ctx.local_env - with Type_error _ -> - c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env - in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - let final_ctyp = ctyp_of_typ ctx typ in - - let setup_arg ctyp aval = - let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in - setup := List.rev arg_setup @ !setup; - cleanup := arg_cleanup @ !cleanup; - let have_ctyp = cval_ctyp cval in - if is_polymorphic ctyp then - (F_poly (fst cval), have_ctyp) - else if ctyp_equal ctyp have_ctyp then - cval - else - let gs = gensym () in - setup := iinit ctyp gs cval :: !setup; - cleanup := iclear ctyp gs :: !cleanup; - (F_id gs, ctyp) - in - - assert (List.length arg_ctyps = List.length args); - - let setup_args = List.map2 setup_arg arg_ctyps args in - - List.rev !setup, - begin fun clexp -> - if ctyp_equal (clexp_ctyp clexp) ret_ctyp then - ifuncall clexp id setup_args - else - let gs = gensym () in - iblock [idecl ret_ctyp gs; - ifuncall (CL_id (gs, ret_ctyp)) id setup_args; - icopy l clexp (F_id gs, ret_ctyp); - iclear ret_ctyp gs] - end, - !cleanup - -let rec apat_ctyp ctx (AP_aux (apat, _, _)) = - match apat with - | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats) - | AP_global (_, typ) -> ctyp_of_typ ctx typ - | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat) - | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ - | AP_app (_, _, typ) -> ctyp_of_typ ctx typ - -let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = - let ctx = { ctx with local_env = env } in - match apat_aux, cval with - | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env -> - [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label], - [], - ctx - - | AP_global (pid, typ), (frag, ctyp) -> - let global_ctyp = ctyp_of_typ ctx typ in - [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx - - | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp -> - begin match Env.lookup_id pid ctx.tc_env with - | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx - | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx - end - - | AP_id (pid, typ), _ -> - let ctyp = cval_ctyp cval in - let id_ctyp = ctyp_of_typ ctx typ in - c_debug (lazy ("Adding local " ^ string_of_id pid ^ " : " ^ string_of_ctyp id_ctyp)); - let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in - [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx - - | AP_tup apats, (frag, ctyp) -> - begin - let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in - let fold (instrs, cleanup, n, ctx) apat ctyp = - let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in - instrs @ instrs', cleanup' @ cleanup, n + 1, ctx - in - match ctyp with - | CT_tup ctyps -> - let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in - instrs, cleanup, ctx - | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp) - end - - | AP_app (ctor, apat, variant_typ), (frag, ctyp) -> - begin match ctyp with - | CT_variant (_, ctors) -> - let ctor_c_id = string_of_id ctor in - let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in - (* These should really be the same, something has gone wrong if they are not. *) - if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then - c_error ~loc:l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ))) - else (); - let ctor_c_id, ctor_ctyp = - if is_polymorphic ctor_ctyp then - let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in - (if List.length unification > 0 then - ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification - else - ctor_c_id), - ctyp_suprema (apat_ctyp ctx apat) - else - ctor_c_id, ctor_ctyp - in - let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in - [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label] - @ instrs, - cleanup, - ctx - | ctyp -> - c_error ~loc:l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s" - (string_of_id ctor) - (string_of_typ variant_typ) - (string_of_fragment ~zencode:false frag) - (string_of_ctyp ctyp)) - end - - | AP_wild _, _ -> [], [], ctx - - | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) -> - let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in - let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in - [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx - - | AP_cons _, (_, _) -> c_error "Tried to pattern match cons on non list type" - - | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx - -let unit_fragment = (F_lit V_unit, CT_unit) - -(** GLOBAL: label_counter is used to make sure all labels have unique - names. Like gensym_counter it should be safe to reset between - top-level definitions. **) -let label_counter = ref 0 - -let label str = - let str = str ^ string_of_int !label_counter in - incr label_counter; - str - -let pointer_assign ctyp1 ctyp2 = - match ctyp1 with - | CT_ref ctyp1 -> true - | _ -> false - -let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = - let ctx = { ctx with local_env = env } in - match aexp_aux with - | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) -> - let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in - let setup, call, cleanup = compile_aexp ctx binding in - let letb_setup, letb_cleanup = - [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id] - in - let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in - let setup, call, cleanup = compile_aexp ctx body in - letb_setup @ setup, call, cleanup @ letb_cleanup - - | AE_app (id, vs, typ) -> - compile_funcall l ctx id vs typ - - | AE_val aval -> - let setup, cval, cleanup = compile_aval l ctx aval in - setup, (fun clexp -> icopy l clexp cval), cleanup - - (* Compile case statements *) - | AE_case (aval, cases, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in - let case_return_id = gensym () in - let finish_match_label = label "finish_match_" in - let compile_case (apat, guard, body) = - let trivial_guard = match guard with - | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true - | _ -> false - in - let case_label = label "case_" in - c_debug (lazy ("Compiling match")); - let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in - c_debug (lazy ("Compiled match")); - let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let case_instrs = - destructure @ [icomment "end destructuring"] - @ (if not trivial_guard then - guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit] - @ [icomment "end guard"] - else []) - @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup - @ [igoto finish_match_label] - in - if is_dead_aexp body then - [ilabel case_label] - else - [iblock case_instrs; ilabel case_label] - in - [icomment "begin match"] - @ aval_setup @ [idecl ctyp case_return_id] - @ List.concat (List.map compile_case cases) - @ [imatch_failure ()] - @ [ilabel finish_match_label], - (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)), - [iclear ctyp case_return_id] - @ aval_cleanup - @ [icomment "end match"] - - (* Compile try statement *) - | AE_try (aexp, cases, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in - let try_return_id = gensym () in - let handled_exception_label = label "handled_exception_" in - let fallthrough_label = label "fallthrough_exception_" in - let compile_case (apat, guard, body) = - let trivial_guard = match guard with - | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true - | _ -> false - in - let try_label = label "try_" in - let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in - let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in - let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let case_instrs = - destructure @ [icomment "end destructuring"] - @ (if not trivial_guard then - guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label] - @ [icomment "end guard"] - else []) - @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup - @ [igoto handled_exception_label] - in - [iblock case_instrs; ilabel try_label] - in - assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); - [idecl ctyp try_return_id; - itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); - ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label] - @ List.concat (List.map compile_case cases) - @ [igoto fallthrough_label; - ilabel handled_exception_label; - icopy l CL_have_exception (F_lit (V_bool false), CT_bool); - ilabel fallthrough_label], - (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)), - [] - - | AE_if (aval, then_aexp, else_aexp, if_typ) -> - if is_dead_aexp then_aexp then - compile_aexp ctx else_aexp - else if is_dead_aexp else_aexp then - compile_aexp ctx then_aexp - else - let if_ctyp = ctyp_of_typ ctx if_typ in - let compile_branch aexp = - let setup, call, cleanup = compile_aexp ctx aexp in - fun clexp -> setup @ [call clexp] @ cleanup - in - let setup, cval, cleanup = compile_aval l ctx aval in - setup, - (fun clexp -> iif cval - (compile_branch then_aexp clexp) - (compile_branch else_aexp clexp) - if_ctyp), - cleanup - - (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *) - | AE_record_update (aval, fields, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let ctors = match ctyp with - | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors - | _ -> c_error "Cannot perform record update for non-record type" - in - let gs = gensym () in - let compile_fields (id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] - @ field_cleanup - in - let setup, cval, cleanup = compile_aval l ctx aval in - [idecl ctyp gs] - @ setup - @ [icopy l (CL_id (gs, ctyp)) cval] - @ cleanup - @ List.concat (List.map compile_fields (Bindings.bindings fields)), - (fun clexp -> icopy l clexp (F_id gs, ctyp)), - [iclear ctyp gs] - - | AE_short_circuit (SC_and, aval, aexp) -> - let left_setup, cval, left_cleanup = compile_aval l ctx aval in - let right_setup, call, right_cleanup = compile_aexp ctx aexp in - let gs = gensym () in - left_setup - @ [ idecl CT_bool gs; - iif cval - (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)] - CT_bool ] - @ left_cleanup, - (fun clexp -> icopy l clexp (F_id gs, CT_bool)), - [] - | AE_short_circuit (SC_or, aval, aexp) -> - let left_setup, cval, left_cleanup = compile_aval l ctx aval in - let right_setup, call, right_cleanup = compile_aexp ctx aexp in - let gs = gensym () in - left_setup - @ [ idecl CT_bool gs; - iif cval - [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)] - (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - CT_bool ] - @ left_cleanup, - (fun clexp -> icopy l clexp (F_id gs, CT_bool)), - [] - - (* This is a faster assignment rule for updating fields of a - struct. Turned on by !optimize_struct_updates. *) - | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _)) - when Id.compare id rid = 0 && !optimize_struct_updates -> - c_debug (lazy ("Optimizing struct update")); - let compile_fields (field_id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval] - @ field_cleanup - in - List.concat (List.map compile_fields (Bindings.bindings fields)), - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_assign (id, assign_typ, aexp) -> - let assign_ctyp = - match Bindings.find_opt id ctx.locals with - | Some (_, ctyp) -> ctyp - | None -> ctyp_of_typ ctx assign_typ - in - let setup, call, cleanup = compile_aexp ctx aexp in - setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup - - | AE_block (aexps, aexp, _) -> - let block = compile_block ctx aexps in - let setup, call, cleanup = compile_aexp ctx aexp in - block @ setup, call, cleanup - - | AE_loop (While, cond, body) -> - let loop_start_label = label "while_" in - let loop_end_label = label "wend_" in - let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let unit_gs = gensym () in - let loop_test = (F_unary ("!", F_id gs), CT_bool) in - [idecl CT_bool gs; idecl CT_unit unit_gs] - @ [ilabel loop_start_label] - @ [iblock (cond_setup - @ [cond_call (CL_id (gs, CT_bool))] - @ cond_cleanup - @ [ijump loop_test loop_end_label] - @ body_setup - @ [body_call (CL_id (unit_gs, CT_unit))] - @ body_cleanup - @ [igoto loop_start_label])] - @ [ilabel loop_end_label], - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_loop (Until, cond, body) -> - let loop_start_label = label "repeat_" in - let loop_end_label = label "until_" in - let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let unit_gs = gensym () in - let loop_test = (F_id gs, CT_bool) in - [idecl CT_bool gs; idecl CT_unit unit_gs] - @ [ilabel loop_start_label] - @ [iblock (body_setup - @ [body_call (CL_id (unit_gs, CT_unit))] - @ body_cleanup - @ cond_setup - @ [cond_call (CL_id (gs, CT_bool))] - @ cond_cleanup - @ [ijump loop_test loop_end_label] - @ [igoto loop_start_label])] - @ [ilabel loop_end_label], - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_cast (aexp, typ) -> compile_aexp ctx aexp - - | AE_return (aval, typ) -> - let fn_return_ctyp = match Env.get_ret_typ env with - | Some typ -> ctyp_of_typ ctx typ - | None -> c_error ~loc:l "No function return type found when compiling return statement" - in - (* Cleanup info will be re-added by fix_early_return *) - let return_setup, cval, _ = compile_aval l ctx aval in - let creturn = - if ctyp_equal fn_return_ctyp (cval_ctyp cval) then - [ireturn cval] - else - let gs = gensym () in - [idecl fn_return_ctyp gs; - icopy l (CL_id (gs, fn_return_ctyp)) cval; - ireturn (F_id gs, fn_return_ctyp)] - in - return_setup @ creturn, - (fun clexp -> icomment "unreachable after return"), - [] - - | AE_throw (aval, typ) -> - (* Cleanup info will be handled by fix_exceptions *) - let throw_setup, cval, _ = compile_aval l ctx aval in - throw_setup @ [ithrow cval], - (fun clexp -> icomment "unreachable after throw"), - [] - - | AE_field (aval, id, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let setup, cval, cleanup = compile_aval l ctx aval in - setup, - (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)), - cleanup - - | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) -> - (* We assume that all loop indices are safe to put in a CT_fint. *) - let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in - - let is_inc = match ord with - | Ord_inc -> true - | Ord_dec -> false - | Ord_var _ -> c_error "Polymorphic loop direction in C backend" - in - - (* Loop variables *) - let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in - let from_gs = gensym () in - let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in - let to_gs = gensym () in - let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in - let step_gs = gensym () in - let variable_init gs setup call cleanup = - [idecl (CT_fint 64) gs; - iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)] - in - - let loop_start_label = label "for_start_" in - let loop_end_label = label "for_end_" in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let body_gs = gensym () in - - variable_init from_gs from_setup from_call from_cleanup - @ variable_init to_gs to_setup to_call to_cleanup - @ variable_init step_gs step_setup step_call step_cleanup - @ [iblock ([idecl (CT_fint 64) loop_var; - icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64)); - idecl CT_unit body_gs; - iblock ([ilabel loop_start_label] - @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label] - @ body_setup - @ [body_call (CL_id (body_gs, CT_unit))] - @ body_cleanup - @ [icopy l (CL_id (loop_var, (CT_fint 64))) - (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))] - @ [igoto loop_start_label]); - ilabel loop_end_label])], - (fun clexp -> icopy l clexp unit_fragment), - [] - -and compile_block ctx = function - | [] -> [] - | exp :: exps -> - let setup, call, cleanup = compile_aexp ctx exp in - let rest = compile_block ctx exps in - let gs = gensym () in - iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest - -(** Compile a sail type definition into a IR one. Most of the - actual work of translating the typedefs into C is done by the code - generator, as it's easy to keep track of structs, tuples and unions - in their sail form at this level, and leave the fiddly details of - how they get mapped to C in the next stage. This function also adds - details of the types it compiles to the context, ctx, which is why - it returns a ctypdef * ctx pair. **) -let compile_type_def ctx (TD_aux (type_def, _)) = - match type_def with - | TD_enum (id, ids, _) -> - CTD_enum (id, ids), - { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } - - | TD_record (id, _, ctors, _) -> - let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in - CTD_struct (id, Bindings.bindings ctors), - { ctx with records = Bindings.add id ctors ctx.records } - - | TD_variant (id, typq, tus, _) -> - let compile_tu = function - | Tu_aux (Tu_ty_id (typ, id), _) -> - let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in - ctyp_of_typ ctx typ, id - in - let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in - CTD_variant (id, Bindings.bindings ctus), - { ctx with variants = Bindings.add id ctus ctx.variants } - - (* Will be re-written before here, see bitfield.ml *) - | TD_bitfield _ -> failwith "Cannot compile TD_bitfield" - (* All type abbreviations are filtered out in compile_def *) - | TD_abbrev _ -> assert false - -let instr_split_at f = - let rec instr_split_at' f before = function - | [] -> (List.rev before, []) - | instr :: instrs when f instr -> (List.rev before, instr :: instrs) - | instr :: instrs -> instr_split_at' f (instr :: before) instrs - in - instr_split_at' f [] - -let generate_cleanup instrs = - let generate_cleanup' (I_aux (instr, _)) = - match instr with - | I_init (ctyp, id, cval) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)] - | I_decl (ctyp, id) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)] - | instr -> [] - in - let is_clear ids = function - | I_aux (I_clear (_, id), _) -> IdSet.add id ids - | _ -> ids - in - let cleaned = List.fold_left is_clear IdSet.empty instrs in - instrs - |> List.map generate_cleanup' - |> List.concat - |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) - |> List.map snd - -(** Functions that have heap-allocated return types are implemented by - passing a pointer a location where the return value should be - stored. The ANF -> Sail IR pass for expressions simply outputs an - I_return instruction for any return value, so this function walks - over the IR ast for expressions and modifies the return statements - into code that sets that pointer, as well as adds extra control - flow to cleanup heap-allocated variables correctly when a function - terminates early. See the generate_cleanup function for how this is - done. *) -let fix_early_return ret ctx instrs = - let end_function_label = label "end_function_" in - let is_return_recur (I_aux (instr, _)) = - match instr with - | I_return _ | I_if _ | I_block _ -> true - | _ -> false - in - let rec rewrite_return historic instrs = - match instr_split_at is_return_recur instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_return (historic @ before) instrs)] - @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] - @ rewrite_return historic after - | before, I_aux (I_return cval, (_, l)) :: after -> - let cleanup_label = label "cleanup_" in - let end_cleanup_label = label "end_cleanup_" in - before - @ [icopy l ret cval; - igoto cleanup_label] - (* This is probably dead code until cleanup_label, but how can we be sure there are no jumps into it? *) - @ rewrite_return (historic @ before) after - @ [igoto end_cleanup_label] - @ [ilabel cleanup_label] - @ generate_cleanup (historic @ before) - @ [igoto end_function_label] - @ [ilabel end_cleanup_label] - | _, _ -> assert false - in - rewrite_return [] instrs - @ [ilabel end_function_label] - -(* This is like fix_early_return, but for stack allocated returns. *) -let fix_early_stack_return ctx instrs = - let is_return_recur (I_aux (instr, _)) = - match instr with - | I_return _ | I_if _ | I_block _ -> true - | _ -> false - in - let rec rewrite_return historic instrs = - match instr_split_at is_return_recur instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_return (historic @ before) instrs)] - @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] - @ rewrite_return historic after - | before, (I_aux (I_return cval, _) as ret) :: after -> - before - @ [icomment "early return cleanup"] - @ generate_cleanup (historic @ before) - @ [ret] - (* There could be jumps into here *) - @ rewrite_return (historic @ before) after - | _, _ -> assert false - in - rewrite_return [] instrs - -let fix_exception_block ?return:(return=None) ctx instrs = - let end_block_label = label "end_block_exception_" in - let is_exception_stop (I_aux (instr, _)) = - match instr with - | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true - | _ -> false - in - (* In this function 'after' is instructions after the one we've - matched on, 'before is instructions before the instruction we've - matched with, but after the previous match, and 'historic' are - all the befores from previous matches. *) - let rec rewrite_exception historic instrs = - match instr_split_at is_exception_stop instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_exception (historic @ before) instrs)] - @ rewrite_exception (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] - @ rewrite_exception historic after - | before, I_aux (I_throw cval, (_, l)) :: after -> - before - @ [icopy l (CL_current_exception (cval_ctyp cval)) cval; - icopy l CL_have_exception (F_lit (V_bool true), CT_bool)] - @ generate_cleanup (historic @ before) - @ [igoto end_block_label] - @ rewrite_exception (historic @ before) after - | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> - let effects = match Env.get_val_spec f ctx.tc_env with - | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects - | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) - | _ -> assert false (* valspec must have function type *) - in - if has_effect effects BE_escape then - before - @ [funcall; - iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] - @ rewrite_exception (historic @ before) after - else - before @ funcall :: rewrite_exception (historic @ before) after - | _, _ -> assert false (* unreachable *) - in - match return with - | None -> - rewrite_exception [] instrs @ [ilabel end_block_label] - | Some ctyp -> - rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp] - -let rec map_try_block f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr - | I_block instrs -> I_block (List.map (map_try_block f) instrs) - | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ -> instr - in - I_aux (instr, aux) - -let fix_exception ?return:(return=None) ctx instrs = - let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in - fix_exception_block ~return:return ctx instrs - -let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp = - match p_aux with - | P_id id -> (id, ([], [])) - | P_wild -> let gs = gensym () in (gs, ([], [])) - | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], [])) - | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp - | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp - | _ -> - let apat = anf_pat pat in - let gs = gensym () in - let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in - (gs, (destructure, cleanup)) - -let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps = - match p_aux with - | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps - | P_tup pats when List.length pats = List.length ctyps -> - [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, [] - | _ when List.length ctyps = 1 -> - [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], [] - - | _ -> - let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in - let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in - destructure - @ [idecl (CT_tup ctyps) arg_id] - @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids, - List.map (fun (id, _) -> id, ([], [])) new_ids, - [iclear (CT_tup ctyps) arg_id] - @ cleanup - -let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs)) - -let fix_destructure fail_label = function - | ([], cleanup) -> ([], cleanup) - | destructure, cleanup -> - let body_label = label "fundef_body_" in - (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup) - -let letdef_count = ref 0 - -(** Compile a Sail toplevel definition into an IR definition **) -let rec compile_def n total ctx def = - match def with - | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _)) - when !opt_memo_cache -> - let digest = - def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string - in - let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in - let cached = - if Sys.file_exists cachefile then - let in_chan = open_in cachefile in - try - let compiled = Marshal.from_channel in_chan in - close_in in_chan; - Some (compiled, ctx) - with - | _ -> close_in in_chan; None - else - None - in - begin match cached with - | Some (compiled, ctx) -> - Util.progress "Compiling " (string_of_id id) n total; - compiled, ctx - | None -> - let compiled, ctx = compile_def' n total ctx def in - let out_chan = open_out cachefile in - Marshal.to_channel out_chan compiled [Marshal.Closures]; - close_out out_chan; - compiled, ctx - end - - | _ -> compile_def' n total ctx def - -and compile_def' n total ctx = function - | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> - [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx - | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> - let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in - let setup, call, cleanup = compile_aexp ctx aexp in - let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in - [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx - - | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> - c_debug (lazy "Compiling VS"); - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx - - | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> - c_debug (lazy ("Compiling function " ^ string_of_id id)); - Util.progress "Compiling " (string_of_id id) n total; - - (* Find the function's type. *) - let quant, Typ_aux (fn_typ, _) = - try Env.get_val_spec id ctx.local_env - with Type_error _ -> - c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env - in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - - (* Handle the argument pattern. *) - let fundef_label = label "fundef_fail_" in - let orig_ctx = ctx in - (* The context must be updated before we call ctyp_of_typ on the argument types. *) - let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in - - let arg_ctyps = List.map (ctyp_of_typ ctx) arg_typs in - let ret_ctyp = ctyp_of_typ ctx ret_typ in - - (* Optimize and compile the expression to ANF. *) - let aexp = no_shadow (pat_ids pat) (anf exp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in - - if Id.compare (mk_id !opt_debug_function) id = 0 then - let header = - Printf.sprintf "Sail ANF for %s %s %s. (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) - (string_of_typquant quant) - Util.(string_of_list ", " (fun typ -> string_of_typ typ |> yellow |> clear) arg_typs) - Util.(string_of_typ ret_typ |> yellow |> clear) - - in - prerr_endline (Util.header header (List.length arg_typs + 2)); - prerr_endline (Pretty_print_sail.to_string (pp_aexp aexp)) - else (); - - (* Compile the function arguments as patterns. *) - let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in - let ctx = - (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *) - List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps - in - - (* Optimize and compile the expression from ANF to C. *) - let aexp = no_shadow (pat_ids pat) (anf exp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let setup, call, cleanup = compile_aexp ctx aexp in - c_debug (lazy "Compiled aexp"); - let gs = gensym () in - let destructure, destructure_cleanup = - compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label - in - - if is_stack_ctyp ret_ctyp then - let instrs = arg_setup @ destructure @ [idecl ret_ctyp gs] @ setup @ [call (CL_id (gs, ret_ctyp))] @ cleanup @ destructure_cleanup @ arg_cleanup @ [ireturn (F_id gs, ret_ctyp)] in - let instrs = fix_early_stack_return ctx instrs in - let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in - [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx - else - let instrs = arg_setup @ destructure @ setup @ [call (CL_addr (CL_id (gs, CT_ref ret_ctyp)))] @ cleanup @ destructure_cleanup @ arg_cleanup in - let instrs = fix_early_return (CL_addr (CL_id (gs, CT_ref ret_ctyp))) ctx instrs in - let instrs = fix_exception ctx instrs in - [CDEF_fundef (id, Some gs, List.map fst compiled_args, instrs)], orig_ctx - - | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> - c_error ~loc:l "Encountered function with no clauses" - | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) -> - c_error ~loc:l "Encountered function with multiple clauses" - - (* All abbreviations should expanded by the typechecker, so we don't - need to translate type abbreviations into C typedefs. *) - | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx - - | DEF_type type_def -> - let tdef, ctx = compile_type_def ctx type_def in - [CDEF_type tdef], ctx - - | DEF_val (LB_aux (LB_val (pat, exp), _)) -> - c_debug (lazy ("Compiling letbind " ^ string_of_pat pat)); - let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in - let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in - let setup, call, cleanup = compile_aexp ctx aexp in - let apat = anf_pat ~global:true pat in - let gs = gensym () in - let end_label = label "let_end_" in - let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in - let gs_setup, gs_cleanup = - [idecl ctyp gs], [iclear ctyp gs] - in - let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in - let n = !letdef_count in - incr letdef_count; - let instrs = - gs_setup @ setup - @ [call (CL_id (gs, ctyp))] - @ cleanup - @ destructure - @ destructure_cleanup @ gs_cleanup - @ [ilabel end_label] - in - [CDEF_let (n, bindings, instrs)], - { ctx with letbinds = n :: ctx.letbinds } - - (* Only DEF_default that matters is default Order, but all order - polymorphism is specialised by this point. *) - | DEF_default _ -> [], ctx - - (* Overloading resolved by type checker *) - | DEF_overload _ -> [], ctx - - (* Only the parser and sail pretty printer care about this. *) - | DEF_fixity _ -> [], ctx - - (* We just ignore any pragmas we don't want to deal with. *) - | DEF_pragma _ -> [], ctx - - | DEF_internal_mutrec fundefs -> - let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in - List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs - - | def -> - c_error ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def)) - -(** To keep things neat we use GCC's local labels extension to limit - the scope of labels. We do this by iterating over all the blocks - and adding a __label__ declaration with all the labels local to - that block. The add_local_labels function is called by the code - generator just before it outputs C. - - See https://gcc.gnu.org/onlinedocs/gcc/Local-Labels.html **) -let add_local_labels' instrs = - let is_label (I_aux (instr, _)) = - match instr with - | I_label str -> [str] - | _ -> [] - in - let labels = List.concat (List.map is_label instrs) in - let local_label_decl = iraw ("__label__ " ^ String.concat ", " labels ^ ";\n") in - if labels = [] then - instrs - else - local_label_decl :: instrs - -let add_local_labels instrs = - match map_instrs add_local_labels' (iblock instrs) with - | I_aux (I_block instrs, _) -> instrs - | _ -> assert false - -(**************************************************************************) -(* 5. Optimizations *) -(**************************************************************************) - -let rec clexp_rename from_id to_id = - let rename id = if Id.compare id from_id = 0 then to_id else id in - function - | CL_id (id, ctyp) -> CL_id (rename id, ctyp) - | CL_field (clexp, field) -> CL_field (clexp_rename from_id to_id clexp, field) - | CL_tuple (clexp, n) -> CL_tuple (clexp_rename from_id to_id clexp, n) - | CL_addr clexp -> CL_addr (clexp_rename from_id to_id clexp) - | CL_current_exception ctyp -> CL_current_exception ctyp - | CL_have_exception -> CL_have_exception - -let rec instrs_rename from_id to_id = - let rename id = if Id.compare id from_id = 0 then to_id else id in - let crename = cval_rename from_id to_id in - let irename instrs = instrs_rename from_id to_id instrs in - let lrename = clexp_rename from_id to_id in - function - | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs - | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs - | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs - | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs - | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs - | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs - | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> - I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs - | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs - | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs - | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs - | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs - | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs - | (I_aux ((I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs - | [] -> [] - -let hoist_ctyp = function - | CT_lint | CT_lbits _ | CT_struct _ -> true - | _ -> false - -let hoist_counter = ref 0 -let hoist_id () = - let id = mk_id ("gh#" ^ string_of_int !hoist_counter) in - incr hoist_counter; - id - -let hoist_allocations ctx = function - | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id ctx.recursive_functions -> - c_debug (lazy (Printf.sprintf "skipping recursive function %s" (string_of_id function_id))); - [cdef] - - | CDEF_fundef (function_id, heap_return, args, body) -> - let decls = ref [] in - let cleanups = ref [] in - let rec hoist = function - | I_aux (I_decl (ctyp, decl_id), annot) :: instrs when hoist_ctyp ctyp -> - let hid = hoist_id () in - decls := idecl ctyp hid :: !decls; - cleanups := iclear ctyp hid :: !cleanups; - let instrs = instrs_rename decl_id hid instrs in - I_aux (I_reset (ctyp, hid), annot) :: hoist instrs - - | I_aux (I_init (ctyp, decl_id, cval), annot) :: instrs when hoist_ctyp ctyp -> - let hid = hoist_id () in - decls := idecl ctyp hid :: !decls; - cleanups := iclear ctyp hid :: !cleanups; - let instrs = instrs_rename decl_id hid instrs in - I_aux (I_reinit (ctyp, hid, cval), annot) :: hoist instrs - - | I_aux (I_clear (ctyp, _), _) :: instrs when hoist_ctyp ctyp -> - hoist instrs - - | I_aux (I_block block, annot) :: instrs -> - I_aux (I_block (hoist block), annot) :: hoist instrs - | I_aux (I_try_block block, annot) :: instrs -> - I_aux (I_try_block (hoist block), annot) :: hoist instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), annot) :: instrs -> - I_aux (I_if (cval, hoist then_instrs, hoist else_instrs, ctyp), annot) :: hoist instrs - - | instr :: instrs -> instr :: hoist instrs - | [] -> [] - in - let body = hoist body in - if !decls = [] then - [CDEF_fundef (function_id, heap_return, args, body)] - else - [CDEF_startup (function_id, List.rev !decls); - CDEF_fundef (function_id, heap_return, args, body); - CDEF_finish (function_id, !cleanups)] - - | cdef -> [cdef] - -let flat_counter = ref 0 -let flat_id () = - let id = mk_id ("local#" ^ string_of_int !flat_counter) in - incr flat_counter; - id - -let rec flatten_instrs = function - | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> - let fid = flat_id () in - I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) - - | I_aux ((I_block block | I_try_block block), _) :: instrs -> - flatten_instrs block @ flatten_instrs instrs - - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> - let then_label = label "then_" in - let endif_label = label "endif_" in - [ijump cval then_label] - @ flatten_instrs else_instrs - @ [igoto endif_label] - @ [ilabel then_label] - @ flatten_instrs then_instrs - @ [ilabel endif_label] - @ flatten_instrs instrs - - | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs - - | instr :: instrs -> instr :: flatten_instrs instrs - | [] -> [] - -let flatten_cdef = - function - | CDEF_fundef (function_id, heap_return, args, body) -> - flat_counter := 0; - CDEF_fundef (function_id, heap_return, args, flatten_instrs body) - - | CDEF_let (n, bindings, instrs) -> - flat_counter := 0; - CDEF_let (n, bindings, flatten_instrs instrs) - - | cdef -> cdef - - -let rec specialize_variants ctx prior = - let unifications = ref (Bindings.empty) in - - let fix_variant_ctyp var_id new_ctors = function - | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) - | ctyp -> ctyp - in - - let specialize_constructor ctx ctor_id ctyp = - function - | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> - (* Work out how each call to a constructor in instantiated and add that to unifications *) - let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in - let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in - unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; - - (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) - let casts = - let cast_to_suprema (frag, ctyp) = - let suprema = ctyp_suprema ctyp in - if ctyp_equal ctyp suprema then - [], (unpoly frag, ctyp), [] - else - let gs = gensym () in - [idecl suprema gs; - icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], - (F_id gs, suprema), - [iclear suprema gs] - in - List.map cast_to_suprema [cval] - in - let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in - let cvals = List.map (fun (_, cval, _) -> cval) casts in - let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in - - let mk_funcall instr = - if List.length setup = 0 then - instr - else - iblock (setup @ [instr] @ cleanup) - in - - mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) - - | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> - c_error ~loc:l "Multiple argument constructor found" - - | instr -> instr - in - - function - | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> - let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in - - let cdefs = - List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) - cdefs - polymorphic_ctors - in - - let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in - let specialized_ctors = Bindings.bindings !unifications in - let new_ctors = monomorphic_ctors @ specialized_ctors in - - let ctx = { - ctx with variants = Bindings.add var_id - (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) - ctx.variants - } in - - let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in - let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in - specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs - - | cdef :: cdefs -> - let remove_poly (I_aux (instr, aux)) = - match instr with - | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> - I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) - | instr -> I_aux (instr, aux) - in - let cdef = cdef_map_instr remove_poly cdef in - specialize_variants ctx (cdef :: prior) cdefs - - | [] -> List.rev prior, ctx - -(** Once we specialize variants, there may be additional type - dependencies which could be in the wrong order. As such we need to - sort the type definitions in the list of cdefs. *) -let sort_ctype_defs cdefs = - (* Split the cdefs into type definitions and non type definitions *) - let is_ctype_def = function CDEF_type _ -> true | _ -> false in - let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in - let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in - let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in - - let ctdef_id = function - | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id - in - - let ctdef_ids = function - | CTD_enum _ -> IdSet.empty - | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> - List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors - in - - (* Create a reverse (i.e. from types to the types that are dependent - upon them) id graph of dependencies between types *) - let module IdGraph = Graph.Make(Id) in - - let graph = - List.fold_left (fun g ctdef -> - List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) - (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) - (IdSet.elements (ctdef_ids ctdef))) - IdGraph.empty - ctype_defs - in - - (* Then select the ctypes in the correct order as given by the topsort *) - let ids = IdGraph.topsort graph in - let ctype_defs = - List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids - in - - ctype_defs @ cdefs - -let removed = icomment "REMOVED" - -let is_not_removed = function - | I_aux (I_comment "REMOVED", _) -> false - | _ -> true - -(** This optimization looks for patterns of the form: - - create x : t; - x = y; - // modifications to x, and no changes to y - y = x; - // no further changes to x - kill x; - - If found, we can remove the variable x, and directly modify y instead. *) -let remove_alias ctx = - let pattern ctyp id = - let alias = ref None in - let rec scan ctyp id n instrs = - match n, !alias, instrs with - | 0, None, I_aux (I_copy (CL_id (id', ctyp'), (F_id a, ctyp'')), _) :: instrs - when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - alias := Some a; - scan ctyp id 1 instrs - - | 1, Some a, I_aux (I_copy (CL_id (a', ctyp'), (F_id id', ctyp'')), _) :: instrs - when Id.compare a a' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - scan ctyp id 2 instrs - - | 1, Some a, instr :: instrs -> - if IdSet.mem a (instr_ids instr) then - None - else - scan ctyp id 1 instrs - - | 2, Some a, I_aux (I_clear (ctyp', id'), _) :: instrs - when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' -> - scan ctyp id 2 instrs - - | 2, Some a, instr :: instrs -> - if IdSet.mem id (instr_ids instr) then - None - else - scan ctyp id 2 instrs - - | 2, Some a, [] -> !alias - - | n, _, _ :: instrs when n = 0 || n > 2 -> scan ctyp id n instrs - | _, _, I_aux (_, (_, l)) :: instrs -> raise (Reporting.err_unreachable l __POS__ "optimize_alias") - | _, _, [] -> None - in - scan ctyp id 0 - in - let remove_alias id alias = function - | I_aux (I_copy (CL_id (id', _), (F_id alias', _)), _) - when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed - | I_aux (I_copy (CL_id (alias', _), (F_id id', _)), _) - when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed - | I_aux (I_clear (_, id'), _) -> removed - | instr -> instr - in - let rec opt = function - | I_aux (I_decl (ctyp, id), _) as instr :: instrs -> - begin match pattern ctyp id instrs with - | None -> instr :: opt instrs - | Some alias -> - let instrs = List.map (map_instr (remove_alias id alias)) instrs in - filter_instrs is_not_removed (List.map (instr_rename id alias) instrs) - end - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, opt body)] - | cdef -> [cdef] - - -(** This pass ensures that all variables created by I_decl have unique names *) -let unique_names = - let unique_counter = ref 0 in - let unique_id () = - let id = mk_id ("u#" ^ string_of_int !unique_counter) in - incr unique_counter; - id - in - - let rec opt seen = function - | I_aux (I_decl (ctyp, id), aux) :: instrs when IdSet.mem id seen -> - let id' = unique_id () in - let instrs', seen = opt seen instrs in - I_aux (I_decl (ctyp, id'), aux) :: instrs_rename id id' instrs', seen - - | I_aux (I_decl (ctyp, id), aux) :: instrs -> - let instrs', seen = opt (IdSet.add id seen) instrs in - I_aux (I_decl (ctyp, id), aux) :: instrs', seen - - | I_aux (I_block block, aux) :: instrs -> - let block', seen = opt seen block in - let instrs', seen = opt seen instrs in - I_aux (I_block block', aux) :: instrs', seen - - | I_aux (I_try_block block, aux) :: instrs -> - let block', seen = opt seen block in - let instrs', seen = opt seen instrs in - I_aux (I_try_block block', aux) :: instrs', seen - - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - let then_instrs', seen = opt seen then_instrs in - let else_instrs', seen = opt seen else_instrs in - let instrs', seen = opt seen instrs in - I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen - - | instr :: instrs -> - let instrs', seen = opt seen instrs in - instr :: instrs', seen - - | [] -> [], seen - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, fst (opt IdSet.empty body))] - | CDEF_reg_dec (id, ctyp, instrs) -> - [CDEF_reg_dec (id, ctyp, fst (opt IdSet.empty instrs))] - | CDEF_let (n, bindings, instrs) -> - [CDEF_let (n, bindings, fst (opt IdSet.empty instrs))] - | cdef -> [cdef] - -(** This optimization looks for patterns of the form - - create x : t; - create y : t; - // modifications to y, no changes to x - x = y; - kill y; - - If found we can replace y by x *) -let combine_variables ctx = - let pattern ctyp id = - let combine = ref None in - let rec scan id n instrs = - match n, !combine, instrs with - | 0, None, I_aux (I_block block, _) :: instrs -> - begin match scan id 0 block with - | Some combine -> Some combine - | None -> scan id 0 instrs - end - - | 0, None, I_aux (I_decl (ctyp', id'), _) :: instrs when ctyp_equal ctyp ctyp' -> - combine := Some id'; - scan id 1 instrs - - | 1, Some c, I_aux (I_copy (CL_id (id', ctyp'), (F_id c', ctyp'')), _) :: instrs - when Id.compare c c' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - scan id 2 instrs - - (* Ignore seemingly early clears of x, as this can happen along exception paths *) - | 1, Some c, I_aux (I_clear (_, id'), _) :: instrs - when Id.compare id id' = 0 -> - scan id 1 instrs - - | 1, Some c, instr :: instrs -> - if IdSet.mem id (instr_ids instr) then - None - else - scan id 1 instrs - - | 2, Some c, I_aux (I_clear (ctyp', c'), _) :: instrs - when Id.compare c c' = 0 && ctyp_equal ctyp ctyp' -> - !combine - - | 2, Some c, instr :: instrs -> - if IdSet.mem c (instr_ids instr) then - None - else - scan id 2 instrs - - | 2, Some c, [] -> !combine - - | n, _, _ :: instrs -> scan id n instrs - | _, _, [] -> None - in - scan id 0 - in - let remove_variable id = function - | I_aux (I_decl (_, id'), _) when Id.compare id id' = 0 -> removed - | I_aux (I_clear (_, id'), _) when Id.compare id id' = 0 -> removed - | instr -> instr - in - let is_not_self_assignment = function - | I_aux (I_copy (CL_id (id, _), (F_id id', _)), _) when Id.compare id id' = 0 -> false - | _ -> true - in - let rec opt = function - | (I_aux (I_decl (ctyp, id), _) as instr) :: instrs -> - begin match pattern ctyp id instrs with - | None -> instr :: opt instrs - | Some combine -> - let instrs = List.map (map_instr (remove_variable combine)) instrs in - let instrs = filter_instrs (fun i -> is_not_removed i && is_not_self_assignment i) - (List.map (instr_rename combine id) instrs) in - opt (instr :: instrs) - end - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, opt body)] - | cdef -> [cdef] - -(** hoist_alias looks for patterns like - - recreate x; y = x; // no furthner mentions of x - - Provided x has a certain type, then we can make y an alias to x - (denoted in the IR as 'alias y = x'). This only works if y also has - a lifespan that also spans the entire function body. It's possible - we may need to do a more thorough lifetime evaluation to get this - to be 100% correct - so it's behind the -Oexperimental flag - for now. Some benchmarking shows that this kind of optimization - is very valuable however! *) -let hoist_alias ctx = - (* Must return true for a subset of the types hoist_ctyp would return true for. *) - let is_struct = function - | CT_struct _ -> true - | _ -> false - in - let pattern heap_return id ctyp instrs = - let rec scan instrs = - match instrs with - (* The only thing that has a longer lifetime than id is the - function return, so we want to make sure we avoid that - case. *) - | (I_aux (I_copy (clexp, (F_id id', ctyp')), aux) as instr) :: instrs - when not (IdSet.mem heap_return (instr_writes instr)) && Id.compare id id' = 0 - && ctyp_equal (clexp_ctyp clexp) ctyp && ctyp_equal ctyp ctyp' -> - if List.exists (IdSet.mem id) (List.map instr_ids instrs) then - instr :: scan instrs - else - I_aux (I_alias (clexp, (F_id id', ctyp')), aux) :: instrs - - | instr :: instrs -> instr :: scan instrs - | [] -> [] - in - scan instrs - in - let optimize heap_return = - let rec opt = function - | (I_aux (I_reset (ctyp, id), _) as instr) :: instrs when not (is_stack_ctyp ctyp) && is_struct ctyp -> - instr :: opt (pattern heap_return id ctyp instrs) - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - opt - in - function - | CDEF_fundef (function_id, Some heap_return, args, body) -> - [CDEF_fundef (function_id, Some heap_return, args, optimize heap_return body)] - | cdef -> [cdef] - -let concatMap f xs = List.concat (List.map f xs) - -let optimize ctx cdefs = - let nothing cdefs = cdefs in - cdefs - |> (if !optimize_alias then concatMap unique_names else nothing) - |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing) - |> (if !optimize_alias then concatMap (combine_variables ctx) else nothing) - (* We need the runtime to initialize hoisted allocations *) - |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations ctx) else nothing) - |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap (hoist_alias ctx) else nothing) - -(**************************************************************************) -(* 6. Code generation *) -(**************************************************************************) - -let sgen_id id = Util.zencode_string (string_of_id id) -let codegen_id id = string (sgen_id id) - -let sgen_function_id id = - let str = Util.zencode_string (string_of_id id) in - !opt_prefix ^ String.sub str 1 (String.length str - 1) - -let codegen_function_id id = string (sgen_function_id id) - -let rec sgen_ctyp = function - | CT_unit -> "unit" - | CT_bit -> "fbits" - | CT_bool -> "bool" - | CT_fbits _ -> "fbits" - | CT_sbits _ -> "sbits" - | CT_fint _ -> "mach_int" - | CT_lint -> "sail_int" - | CT_lbits _ -> "lbits" - | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) - | CT_struct (id, _) -> "struct " ^ sgen_id id - | CT_enum (id, _) -> "enum " ^ sgen_id id - | CT_variant (id, _) -> "struct " ^ sgen_id id - | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) - | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) - | CT_string -> "sail_string" - | CT_real -> "real" - | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" - | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) - -let rec sgen_ctyp_name = function - | CT_unit -> "unit" - | CT_bit -> "fbits" - | CT_bool -> "bool" - | CT_fbits _ -> "fbits" - | CT_sbits _ -> "sbits" - | CT_fint _ -> "mach_int" - | CT_lint -> "sail_int" - | CT_lbits _ -> "lbits" - | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) - | CT_struct (id, _) -> sgen_id id - | CT_enum (id, _) -> sgen_id id - | CT_variant (id, _) -> sgen_id id - | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) - | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) - | CT_string -> "sail_string" - | CT_real -> "real" - | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp - | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) - -let sgen_cval_param (frag, ctyp) = - match ctyp with - | CT_lbits direction -> - string_of_fragment frag ^ ", " ^ string_of_bool direction - | CT_sbits direction -> - string_of_fragment frag ^ ", " ^ string_of_bool direction - | CT_fbits (len, direction) -> - string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction - | _ -> - string_of_fragment frag - -let sgen_cval = function (frag, _) -> string_of_fragment frag - -let rec sgen_clexp = function - | CL_id (id, _) -> "&" ^ sgen_id id - | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ Util.zencode_string field ^ ")" - | CL_tuple (clexp, n) -> "&((" ^ sgen_clexp clexp ^ ")->ztup" ^ string_of_int n ^ ")" - | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -let rec sgen_clexp_pure = function - | CL_id (id, _) -> sgen_id id - | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ Util.zencode_string field - | CL_tuple (clexp, n) -> sgen_clexp_pure clexp ^ ".ztup" ^ string_of_int n - | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -(** Generate instructions to copy from a cval to a clexp. This will - insert any needed type conversions from big integers to small - integers (or vice versa), or from arbitrary-length bitvectors to - and from uint64 bitvectors as needed. *) -let rec codegen_conversion l clexp cval = - let open Printf in - let ctyp_to = clexp_ctyp clexp in - let ctyp_from = cval_ctyp cval in - match ctyp_to, ctyp_from with - (* When both types are equal, we don't need any conversion. *) - | _, _ when ctyp_equal ctyp_to ctyp_from -> - if is_stack_ctyp ctyp_to then - ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) - else - ksprintf string " COPY(%s)(%s, %s);" (sgen_ctyp_name ctyp_to) (sgen_clexp clexp) (sgen_cval cval) - - | CT_ref ctyp_to, ctyp_from -> - codegen_conversion l (CL_addr clexp) cval - - (* If we have to convert between tuple types, convert the fields individually. *) - | CT_tup ctyps_to, CT_tup ctyps_from when List.length ctyps_to = List.length ctyps_from -> - let conversions = - List.mapi (fun i ctyp -> codegen_conversion l (CL_tuple (clexp, i)) (F_field (fst cval, "ztup" ^ string_of_int i), ctyp)) ctyps_from - in - string " /* conversions */" - ^^ hardline - ^^ separate hardline conversions - ^^ hardline - ^^ string " /* end conversions */" - - (* For anything not special cased, just try to call a appropriate CONVERT_OF function. *) - | _, _ when is_stack_ctyp (clexp_ctyp clexp) -> - ksprintf string " %s = CONVERT_OF(%s, %s)(%s);" - (sgen_clexp_pure clexp) (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_cval_param cval) - | _, _ -> - ksprintf string " CONVERT_OF(%s, %s)(%s, %s);" - (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_clexp clexp) (sgen_cval_param cval) - -let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = - let open Printf in - match instr with - | I_decl (ctyp, id) when is_stack_ctyp ctyp -> - ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) - | I_decl (ctyp, id) -> - ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline - ^^ ksprintf string " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) - - | I_copy (clexp, cval) -> codegen_conversion l clexp cval - - | I_alias (clexp, cval) -> - ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) - - | I_jump (cval, label) -> - ksprintf string " if (%s) goto %s;" (sgen_cval cval) label - - | I_if (cval, [then_instr], [], ctyp) -> - ksprintf string " if (%s)" (sgen_cval cval) ^^ hardline - ^^ twice space ^^ codegen_instr fid ctx then_instr - | I_if (cval, then_instrs, [], ctyp) -> - string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) - | I_if (cval, then_instrs, else_instrs, ctyp) -> - string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) - ^^ space ^^ string "else" ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) - - | I_block instrs -> - string " {" - ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline - ^^ string " }" - - | I_try_block instrs -> - string " { /* try */" - ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline - ^^ string " }" - - | I_funcall (x, extern, f, args) -> - let c_args = Util.string_of_list ", " sgen_cval args in - let ctyp = clexp_ctyp x in - let is_extern = Env.is_extern f ctx.tc_env "c" || extern in - let fname = - if Env.is_extern f ctx.tc_env "c" then - Env.get_extern f ctx.tc_env "c" - else if extern then - string_of_id f - else - sgen_function_id f - in - let fname = - match fname, ctyp with - | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) - | "eq_anything", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "eq_anything function with bad arity." - end - | "length", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "length_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "length function with bad arity." - end - | "vector_access", CT_bit -> "bitvector_access" - | "vector_access", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "vector_access_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "vector access function with bad arity." - end - | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_update", CT_fbits _ -> "update_fbits" - | "vector_update", CT_lbits _ -> "update_lbits" - | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) - | "string_of_bits", _ -> - begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "string_of_fbits" - | CT_lbits _ -> "string_of_lbits" - | _ -> assert false - end - | "decimal_string_of_bits", _ -> - begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "decimal_string_of_fbits" - | CT_lbits _ -> "decimal_string_of_lbits" - | _ -> assert false - end - | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) - | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) - | "undefined_vector", CT_fbits _ -> "UNDEFINED(fbits)" - | "undefined_vector", CT_lbits _ -> "UNDEFINED(lbits)" - | "undefined_bit", _ -> "UNDEFINED(fbits)" - | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) - | fname, _ -> fname - in - if fname = "sail_assert" && !optimize_experimental then - empty - else if fname = "reg_deref" then - if is_stack_ctyp ctyp then - string (Printf.sprintf " %s = *(%s);" (sgen_clexp_pure x) c_args) - else - string (Printf.sprintf " COPY(%s)(&%s, *(%s));" (sgen_ctyp_name ctyp) (sgen_clexp_pure x) c_args) - else - if is_stack_ctyp ctyp then - string (Printf.sprintf " %s = %s(%s%s);" (sgen_clexp_pure x) fname (extra_arguments is_extern) c_args) - else - string (Printf.sprintf " %s(%s%s, %s);" fname (extra_arguments is_extern) (sgen_clexp x) c_args) - - | I_clear (ctyp, id) when is_stack_ctyp ctyp -> - empty - | I_clear (ctyp, id) -> - string (Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - - | I_init (ctyp, id, cval) -> - codegen_instr fid ctx (idecl ctyp id) ^^ hardline - ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval - - | I_reinit (ctyp, id, cval) -> - codegen_instr fid ctx (ireset ctyp id) ^^ hardline - ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval - - | I_reset (ctyp, id) when is_stack_ctyp ctyp -> - string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | I_reset (ctyp, id) -> - string (Printf.sprintf " RECREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - - | I_return cval -> - string (Printf.sprintf " return %s;" (sgen_cval cval)) - - | I_throw cval -> - c_error ~loc:l "I_throw reached code generator" - - | I_undefined ctyp -> - let rec codegen_exn_return ctyp = - match ctyp with - | CT_unit -> "UNIT", [] - | CT_bit -> "UINT64_C(0)", [] - | CT_fint _ -> "INT64_C(0xdeadc0de)", [] - | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] - | CT_sbits _ -> "undefined_sbits()", [] - | CT_bool -> "false", [] - | CT_enum (_, ctor :: _) -> sgen_id ctor, [] - | CT_tup ctyps when is_stack_ctyp ctyp -> - let gs = gensym () in - let fold (inits, prev) (n, ctyp) = - let init, prev' = codegen_exn_return ctyp in - Printf.sprintf ".ztup%d = %s" n init :: inits, prev @ prev' - in - let inits, prev = List.fold_left fold ([], []) (List.mapi (fun i x -> (i, x)) ctyps) in - sgen_id gs, - [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) - ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev - | CT_struct (id, ctors) when is_stack_ctyp ctyp -> - let gs = gensym () in - let fold (inits, prev) (id, ctyp) = - let init, prev' = codegen_exn_return ctyp in - Printf.sprintf ".%s = %s" (sgen_id id) init :: inits, prev @ prev' - in - let inits, prev = List.fold_left fold ([], []) ctors in - sgen_id gs, - [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) - ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev - | ctyp -> c_error ("Cannot create undefined value for type: " ^ string_of_ctyp ctyp) - in - let ret, prev = codegen_exn_return ctyp in - separate_map hardline (fun str -> string (" " ^ str)) (List.rev prev) - ^^ hardline - ^^ string (Printf.sprintf " return %s;" ret) - - | I_comment str -> - string (" /* " ^ str ^ " */") - - | I_label str -> - string (str ^ ": ;") - - | I_goto str -> - string (Printf.sprintf " goto %s;" str) - - | I_raw _ when ctx.no_raw -> empty - | I_raw str -> - string (" " ^ str) - - | I_match_failure -> - string (" sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");") - -let codegen_type_def ctx = function - | CTD_enum (id, ((first_id :: _) as ids)) -> - let codegen_eq = - let name = sgen_id id in - string (Printf.sprintf "static bool eq_%s(enum %s op1, enum %s op2) { return op1 == op2; }" name name name) - in - let codegen_undefined = - let name = sgen_id id in - string (Printf.sprintf "enum %s UNDEFINED(%s)(unit u) { return %s; }" name name (sgen_id first_id)) - in - string (Printf.sprintf "// enum %s" (string_of_id id)) ^^ hardline - ^^ separate space [string "enum"; codegen_id id; lbrace; separate_map (comma ^^ space) codegen_id ids; rbrace ^^ semi] - ^^ twice hardline - ^^ codegen_eq - ^^ twice hardline - ^^ codegen_undefined - - | CTD_enum (id, []) -> c_error ("Cannot compile empty enum " ^ string_of_id id) - - | CTD_struct (id, ctors) -> - let struct_ctyp = CT_struct (id, ctors) in - c_debug (lazy (Printf.sprintf "Generating struct for %s" (full_string_of_ctyp struct_ctyp))); - - (* Generate a set_T function for every struct T *) - let codegen_set (id, ctyp) = - if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op.%s;" (sgen_id id) (sgen_id id)) - else - string (Printf.sprintf "COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) - in - let codegen_setter id ctors = - string (let n = sgen_id id in Printf.sprintf "static void COPY(%s)(struct %s *rop, const struct %s op)" n n n) ^^ space - ^^ surround 2 0 lbrace - (separate_map hardline codegen_set (Bindings.bindings ctors)) - rbrace - in - (* Generate an init/clear_T function for every struct T *) - let codegen_field_init f (id, ctyp) = - if not (is_stack_ctyp ctyp) then - [string (Printf.sprintf "%s(%s)(&op->%s);" f (sgen_ctyp_name ctyp) (sgen_id id))] - else [] - in - let codegen_init f id ctors = - string (let n = sgen_id id in Printf.sprintf "static void %s(%s)(struct %s *op)" f n n) ^^ space - ^^ surround 2 0 lbrace - (separate hardline (Bindings.bindings ctors |> List.map (codegen_field_init f) |> List.concat)) - rbrace - in - let codegen_eq = - let codegen_eq_test (id, ctyp) = - string (Printf.sprintf "EQUAL(%s)(op1.%s, op2.%s)" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) - in - string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2)" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ space - ^^ surround 2 0 lbrace - (string "return" ^^ space - ^^ separate_map (string " && ") codegen_eq_test ctors - ^^ string ";") - rbrace - in - (* Generate the struct and add the generated functions *) - let codegen_ctor (id, ctyp) = - string (sgen_ctyp ctyp) ^^ space ^^ codegen_id id - in - string (Printf.sprintf "// struct %s" (string_of_id id)) ^^ hardline - ^^ string "struct" ^^ space ^^ codegen_id id ^^ space - ^^ surround 2 0 lbrace - (separate_map (semi ^^ hardline) codegen_ctor ctors ^^ semi) - rbrace - ^^ semi ^^ twice hardline - ^^ codegen_setter id (ctor_bindings ctors) - ^^ (if not (is_stack_ctyp struct_ctyp) then - twice hardline - ^^ codegen_init "CREATE" id (ctor_bindings ctors) - ^^ twice hardline - ^^ codegen_init "RECREATE" id (ctor_bindings ctors) - ^^ twice hardline - ^^ codegen_init "KILL" id (ctor_bindings ctors) - else empty) - ^^ twice hardline - ^^ codegen_eq - - | CTD_variant (id, tus) -> - let codegen_tu (ctor_id, ctyp) = - separate space [string "struct"; lbrace; string (sgen_ctyp ctyp); codegen_id ctor_id ^^ semi; rbrace] - in - (* Create an if, else if, ... block that does something for each constructor *) - let rec each_ctor v f = function - | [] -> string "{}" - | [(ctor_id, ctyp)] -> - string (Printf.sprintf "if (%skind == Kind_%s)" v (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (f ctor_id ctyp) - ^^ hardline ^^ rbrace - | (ctor_id, ctyp) :: ctors -> - string (Printf.sprintf "if (%skind == Kind_%s) " v (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (f ctor_id ctyp) - ^^ hardline ^^ rbrace ^^ string " else " ^^ each_ctor v f ctors - in - let codegen_init = - let n = sgen_id id in - let ctor_id, ctyp = List.hd tus in - string (Printf.sprintf "static void CREATE(%s)(struct %s *op)" n n) - ^^ hardline - ^^ surround 2 0 lbrace - (string (Printf.sprintf "op->kind = Kind_%s;" (sgen_id ctor_id)) ^^ hardline - ^^ if not (is_stack_ctyp ctyp) then - string (Printf.sprintf "CREATE(%s)(&op->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) - else empty) - rbrace - in - let codegen_reinit = - let n = sgen_id id in - string (Printf.sprintf "static void RECREATE(%s)(struct %s *op) {}" n n) - in - let clear_field v ctor_id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "/* do nothing */") - else - string (Printf.sprintf "KILL(%s)(&%s->%s);" (sgen_ctyp_name ctyp) v (sgen_id ctor_id)) - in - let codegen_clear = - let n = sgen_id id in - string (Printf.sprintf "static void KILL(%s)(struct %s *op)" n n) ^^ hardline - ^^ surround 2 0 lbrace - (each_ctor "op->" (clear_field "op") tus ^^ semi) - rbrace - in - let codegen_ctor (ctor_id, ctyp) = - let ctor_args, tuple, tuple_cleanup = - let tuple_set i ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "op.ztup%d = op%d;" i i) - else - string (Printf.sprintf "COPY(%s)(&op.ztup%d, op%d);" (sgen_ctyp_name ctyp) i i) - in - Printf.sprintf "%s op" (sgen_ctyp ctyp), empty, empty - in - string (Printf.sprintf "static void %s(%sstruct %s *rop, %s)" (sgen_function_id ctor_id) (extra_params ()) (sgen_id id) ctor_args) ^^ hardline - ^^ surround 2 0 lbrace - (tuple - ^^ each_ctor "rop->" (clear_field "rop") tus ^^ hardline - ^^ string ("rop->kind = Kind_" ^ sgen_id ctor_id) ^^ semi ^^ hardline - ^^ if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op;" (sgen_id ctor_id)) - else - string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline - ^^ string (Printf.sprintf "COPY(%s)(&rop->%s, op);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline - ^^ tuple_cleanup) - rbrace - in - let codegen_setter = - let n = sgen_id id in - let set_field ctor_id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op.%s;" (sgen_id ctor_id) (sgen_id ctor_id)) - else - string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) - ^^ string (Printf.sprintf " COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) - in - string (Printf.sprintf "static void COPY(%s)(struct %s *rop, struct %s op)" n n n) ^^ hardline - ^^ surround 2 0 lbrace - (each_ctor "rop->" (clear_field "rop") tus - ^^ semi ^^ hardline - ^^ string "rop->kind = op.kind" - ^^ semi ^^ hardline - ^^ each_ctor "op." set_field tus) - rbrace - in - let codegen_eq = - let codegen_eq_test ctor_id ctyp = - string (Printf.sprintf "return EQUAL(%s)(op1.%s, op2.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) - in - let rec codegen_eq_tests = function - | [] -> string "return false;" - | (ctor_id, ctyp) :: ctors -> - string (Printf.sprintf "if (op1.kind == Kind_%s && op2.kind == Kind_%s) " (sgen_id ctor_id) (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (codegen_eq_test ctor_id ctyp) - ^^ hardline ^^ rbrace ^^ string " else " ^^ codegen_eq_tests ctors - in - let n = sgen_id id in - string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2) " n n n) - ^^ surround 2 0 lbrace (codegen_eq_tests tus) rbrace - in - string (Printf.sprintf "// union %s" (string_of_id id)) ^^ hardline - ^^ string "enum" ^^ space - ^^ string ("kind_" ^ sgen_id id) ^^ space - ^^ separate space [ lbrace; - separate_map (comma ^^ space) (fun id -> string ("Kind_" ^ sgen_id id)) (List.map fst tus); - rbrace ^^ semi ] - ^^ twice hardline - ^^ string "struct" ^^ space ^^ codegen_id id ^^ space - ^^ surround 2 0 lbrace - (separate space [string "enum"; string ("kind_" ^ sgen_id id); string "kind" ^^ semi] - ^^ hardline - ^^ string "union" ^^ space - ^^ surround 2 0 lbrace - (separate_map (semi ^^ hardline) codegen_tu tus ^^ semi) - rbrace - ^^ semi) - rbrace - ^^ semi - ^^ twice hardline - ^^ codegen_init - ^^ twice hardline - ^^ codegen_reinit - ^^ twice hardline - ^^ codegen_clear - ^^ twice hardline - ^^ codegen_setter - ^^ twice hardline - ^^ codegen_eq - ^^ twice hardline - ^^ separate_map (twice hardline) codegen_ctor tus - (* If this is the exception type, then we setup up some global variables to deal with exceptions. *) - ^^ if string_of_id id = "exception" then - twice hardline - ^^ string "struct zexception *current_exception = NULL;" - ^^ hardline - ^^ string "bool have_exception = false;" - else - empty - -(** GLOBAL: because C doesn't have real anonymous tuple types - (anonymous structs don't quite work the way we need) every tuple - type in the spec becomes some generated named struct in C. This is - done in such a way that every possible tuple type has a unique name - associated with it. This global variable keeps track of these - generated struct names, so we never generate two copies of the - struct that is used to represent them in C. - - The way this works is that codegen_def scans each definition's type - annotations for tuple types and generates the required structs - using codegen_type_def before the actual definition is generated by - codegen_def'. - - This variable should be reset to empty only when the entire AST has - been translated to C. **) -let generated = ref IdSet.empty - -let codegen_tup ctx ctyps = - let id = mk_id ("tuple_" ^ string_of_ctyp (CT_tup ctyps)) in - if IdSet.mem id !generated then - empty - else - begin - let _, fields = List.fold_left (fun (n, fields) ctyp -> n + 1, Bindings.add (mk_id ("tup" ^ string_of_int n)) ctyp fields) - (0, Bindings.empty) - ctyps - in - generated := IdSet.add id !generated; - codegen_type_def ctx (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline - end - -let codegen_node id ctyp = - string (Printf.sprintf "struct node_%s {\n %s hd;\n struct node_%s *tl;\n};\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string (Printf.sprintf "typedef struct node_%s *%s;" (sgen_id id) (sgen_id id)) - -let codegen_list_init id = - string (Printf.sprintf "static void CREATE(%s)(%s *rop) { *rop = NULL; }" (sgen_id id) (sgen_id id)) - -let codegen_list_clear id ctyp = - string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " if (*rop == NULL) return;") - ^^ (if is_stack_ctyp ctyp then empty - else string (Printf.sprintf " KILL(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp))) - ^^ string (Printf.sprintf " KILL(%s)(&(*rop)->tl);\n" (sgen_id id)) - ^^ string " free(*rop);" - ^^ string "}" - -let codegen_list_set id ctyp = - string (Printf.sprintf "static void internal_set_%s(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string " if (op == NULL) { *rop = NULL; return; };\n" - ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then - string " (*rop)->hd = op->hd;\n" - else - string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) - ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, op->hd);\n" (sgen_ctyp_name ctyp))) - ^^ string (Printf.sprintf " internal_set_%s(&(*rop)->tl, op->tl);\n" (sgen_id id)) - ^^ string "}" - ^^ twice hardline - ^^ string (Printf.sprintf "static void COPY(%s)(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) - ^^ string (Printf.sprintf " internal_set_%s(rop, op);\n" (sgen_id id)) - ^^ string "}" - -let codegen_cons id ctyp = - let cons_id = mk_id ("cons#" ^ string_of_ctyp ctyp) in - string (Printf.sprintf "static void %s(%s *rop, const %s x, const %s xs) {\n" (sgen_function_id cons_id) (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then - string " (*rop)->hd = x;\n" - else - string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) - ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, x);\n" (sgen_ctyp_name ctyp))) - ^^ string " (*rop)->tl = xs;\n" - ^^ string "}" - -let codegen_pick id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "static %s pick_%s(const %s xs) { return xs->hd; }" (sgen_ctyp ctyp) (sgen_ctyp_name ctyp) (sgen_id id)) - else - string (Printf.sprintf "static void pick_%s(%s *x, const %s xs) { COPY(%s)(x, xs->hd); }" (sgen_ctyp_name ctyp) (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp)) - -let codegen_list ctx ctyp = - let id = mk_id (string_of_ctyp (CT_list ctyp)) in - if IdSet.mem id !generated then - empty - else - begin - generated := IdSet.add id !generated; - codegen_node id ctyp ^^ twice hardline - ^^ codegen_list_init id ^^ twice hardline - ^^ codegen_list_clear id ctyp ^^ twice hardline - ^^ codegen_list_set id ctyp ^^ twice hardline - ^^ codegen_cons id ctyp ^^ twice hardline - ^^ codegen_pick id ctyp ^^ twice hardline - end - -(* Generate functions for working with non-bit vectors of some specific type. *) -let codegen_vector ctx (direction, ctyp) = - let id = mk_id (string_of_ctyp (CT_vector (direction, ctyp))) in - if IdSet.mem id !generated then - empty - else - let vector_typedef = - string (Printf.sprintf "struct %s {\n size_t len;\n %s *data;\n};\n" (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (Printf.sprintf "typedef struct %s %s;" (sgen_id id) (sgen_id id)) - in - let vector_init = - string (Printf.sprintf "static void CREATE(%s)(%s *rop) {\n rop->len = 0;\n rop->data = NULL;\n}" (sgen_id id) (sgen_id id)) - in - let vector_set = - string (Printf.sprintf "static void COPY(%s)(%s *rop, %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) - ^^ string " rop->len = op.len;\n" - ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ string " for (int i = 0; i < op.len; i++) {\n" - ^^ string (if is_stack_ctyp ctyp then - " (rop->data)[i] = op.data[i];\n" - else - Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, op.data[i]);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - let vector_clear = - string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then empty - else - string " for (int i = 0; i < (rop->len); i++) {\n" - ^^ string (Printf.sprintf " KILL(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n") - ^^ string " if (rop->data != NULL) free(rop->data);\n" - ^^ string "}" - in - let vector_update = - string (Printf.sprintf "static void vector_update_%s(%s *rop, %s op, mpz_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string " if (rop->data == op.data) {\n" - ^^ string (if is_stack_ctyp ctyp then - " rop->data[m] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string " } else {\n" - ^^ string (Printf.sprintf " COPY(%s)(rop, op);\n" (sgen_id id)) - ^^ string (if is_stack_ctyp ctyp then - " rop->data[m] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - let internal_vector_update = - string (Printf.sprintf "static void internal_vector_update_%s(%s *rop, %s op, const int64_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (if is_stack_ctyp ctyp then - " rop->data[n] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + n, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string "}" - in - let vector_access = - if is_stack_ctyp ctyp then - string (Printf.sprintf "static %s vector_access_%s(%s op, mpz_t n) {\n" (sgen_ctyp ctyp) (sgen_id id) (sgen_id id)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string " return op.data[m];\n" - ^^ string "}" - else - string (Printf.sprintf "static void vector_access_%s(%s *rop, %s op, mpz_t n) {\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string (Printf.sprintf " COPY(%s)(rop, op.data[m]);\n" (sgen_ctyp_name ctyp)) - ^^ string "}" - in - let internal_vector_init = - string (Printf.sprintf "static void internal_vector_init_%s(%s *rop, const int64_t len) {\n" (sgen_id id) (sgen_id id)) - ^^ string " rop->len = len;\n" - ^^ string (Printf.sprintf " rop->data = malloc(len * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ (if not (is_stack_ctyp ctyp) then - string " for (int i = 0; i < len; i++) {\n" - ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n" - else empty) - ^^ string "}" - in - let vector_undefined = - string (Printf.sprintf "static void undefined_vector_%s(%s *rop, mpz_t len, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (Printf.sprintf " rop->len = mpz_get_ui(len);\n") - ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ string " for (int i = 0; i < (rop->len); i++) {\n" - ^^ string (if is_stack_ctyp ctyp then - " (rop->data)[i] = elem;\n" - else - Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, elem);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - begin - generated := IdSet.add id !generated; - vector_typedef ^^ twice hardline - ^^ vector_init ^^ twice hardline - ^^ vector_clear ^^ twice hardline - ^^ vector_undefined ^^ twice hardline - ^^ vector_access ^^ twice hardline - ^^ vector_set ^^ twice hardline - ^^ vector_update ^^ twice hardline - ^^ internal_vector_update ^^ twice hardline - ^^ internal_vector_init ^^ twice hardline - end - -let is_decl = function - | I_aux (I_decl _, _) -> true - | _ -> false - -let codegen_decl = function - | I_aux (I_decl (ctyp, id), _) -> - string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | _ -> assert false - -let codegen_alloc = function - | I_aux (I_decl (ctyp, id), _) when is_stack_ctyp ctyp -> empty - | I_aux (I_decl (ctyp, id), _) -> - string (Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - | _ -> assert false - -let codegen_def' ctx = function - | CDEF_reg_dec (id, ctyp, _) -> - string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline - ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - - | CDEF_spec (id, arg_ctyps, ret_ctyp) -> - let static = if !opt_static then "static " else "" in - if Env.is_extern id ctx.tc_env "c" then - empty - else if is_stack_ctyp ret_ctyp then - string (Printf.sprintf "%s%s %s(%s%s);" static (sgen_ctyp ret_ctyp) (sgen_function_id id) (extra_params ()) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) - else - string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) - - | CDEF_fundef (id, ret_arg, args, instrs) as def -> - if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); - - (* Extract type information about the function from the environment. *) - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - - (* Check that the function has the correct arity at this point. *) - if List.length arg_ctyps <> List.length args then - c_error ~loc:(id_loc id) ("function arguments " - ^ Util.string_of_list ", " string_of_id args - ^ " matched against type " - ^ Util.string_of_list ", " string_of_ctyp arg_ctyps) - else (); - - (* If this function is set as opt_debug_function, then output its IR *) - if Id.compare (mk_id !opt_debug_function) id = 0 then - let header = - Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) - (Util.string_of_list ", " string_of_id args) - (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps) - Util.(string_of_ctyp ret_ctyp |> yellow |> clear) - in - prerr_endline (Util.header header (List.length arg_ctyps + 2)); - prerr_endline (Pretty_print_sail.to_string (separate_map hardline pp_instr instrs)) - else (); - - let instrs = add_local_labels instrs in - let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in - let function_header = - match ret_arg with - | None -> - assert (is_stack_ctyp ret_ctyp); - (if !opt_static then string "static " else empty) - ^^ string (sgen_ctyp ret_ctyp) ^^ space ^^ codegen_function_id id ^^ parens (string (extra_params ()) ^^ string args) ^^ hardline - | Some gs -> - assert (not (is_stack_ctyp ret_ctyp)); - (if !opt_static then string "static " else empty) - ^^ string "void" ^^ space ^^ codegen_function_id id - ^^ parens (string (extra_params ()) ^^ string (sgen_ctyp ret_ctyp ^ " *" ^ sgen_id gs ^ ", ") ^^ string args) - ^^ hardline - in - function_header - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline - ^^ string "}" - - | CDEF_type ctype_def -> - codegen_type_def ctx ctype_def - - | CDEF_startup (id, instrs) -> - let static = if !opt_static then "static " else "" in - let startup_header = string (Printf.sprintf "%svoid startup_%s(void)" static (sgen_function_id id)) in - separate_map hardline codegen_decl instrs - ^^ twice hardline - ^^ startup_header ^^ hardline - ^^ string "{" - ^^ jump 0 2 (separate_map hardline codegen_alloc instrs) ^^ hardline - ^^ string "}" - - | CDEF_finish (id, instrs) -> - let static = if !opt_static then "static " else "" in - let finish_header = string (Printf.sprintf "%svoid finish_%s(void)" static (sgen_function_id id)) in - separate_map hardline codegen_decl (List.filter is_decl instrs) - ^^ twice hardline - ^^ finish_header ^^ hardline - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline - ^^ string "}" - - | CDEF_let (number, bindings, instrs) -> - let instrs = add_local_labels instrs in - let setup = - List.concat (List.map (fun (id, ctyp) -> [idecl ctyp id]) bindings) - in - let cleanup = - List.concat (List.map (fun (id, ctyp) -> [iclear ctyp id]) bindings) - in - separate_map hardline (fun (id, ctyp) -> string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id))) bindings - ^^ hardline ^^ string (Printf.sprintf "static void create_letbind_%d(void) " number) - ^^ string "{" - ^^ jump 0 2 (separate_map hardline codegen_alloc setup) ^^ hardline - ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") { ctx with no_raw = true }) instrs) ^^ hardline - ^^ string "}" - ^^ hardline ^^ string (Printf.sprintf "static void kill_letbind_%d(void) " number) - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") ctx) cleanup) ^^ hardline - ^^ string "}" - -(** As we generate C we need to generate specialized version of tuple, - list, and vector type. These must be generated in the correct - order. The ctyp_dependencies function generates a list of - c_gen_typs in the order they must be generated. Types may be - repeated in ctyp_dependencies so it's up to the code-generator not - to repeat definitions pointlessly (using the !generated variable) - *) -type c_gen_typ = - | CTG_tup of ctyp list - | CTG_list of ctyp - | CTG_vector of bool * ctyp - -let rec ctyp_dependencies = function - | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] - | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] - | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] - | CT_ref ctyp -> ctyp_dependencies ctyp - | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) - | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] - -let codegen_ctg ctx = function - | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp) - | CTG_tup ctyps -> codegen_tup ctx ctyps - | CTG_list ctyp -> codegen_list ctx ctyp - -(** When we generate code for a definition, we need to first generate - any auxillary type definitions that are required. *) -let codegen_def ctx def = - let ctyps = cdef_ctyps ctx def in - (* We should have erased any polymorphism introduced by variants at this point! *) - if List.exists is_polymorphic ctyps then - let polymorphic_ctyps = List.filter is_polymorphic ctyps in - prerr_endline (Pretty_print_sail.to_string (pp_cdef def)); - c_error (Printf.sprintf "Found polymorphic types:\n%s\nwhile generating definition." - (Util.string_of_list "\n" string_of_ctyp polymorphic_ctyps)) - else - let deps = List.concat (List.map ctyp_dependencies ctyps) in - separate_map hardline (codegen_ctg ctx) deps - ^^ codegen_def' ctx def - -let is_cdef_startup = function - | CDEF_startup _ -> true - | _ -> false - -let sgen_startup = function - | CDEF_startup (id, _) -> - Printf.sprintf " startup_%s();" (sgen_id id) - | _ -> assert false - -let sgen_instr id ctx instr = - Pretty_print_sail.to_string (codegen_instr id ctx instr) - -let is_cdef_finish = function - | CDEF_startup _ -> true - | _ -> false - -let sgen_finish = function - | CDEF_startup (id, _) -> - Printf.sprintf " finish_%s();" (sgen_id id) - | _ -> assert false - -let instrument_tracing ctx = - let module StringSet = Set.Make(String) in - let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in - let rec instrument = function - | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> - let trace_start = - iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id))) - in - let trace_arg cval = - let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval)) - else - iraw "trace_unknown();" - in - let rec trace_args = function - | [] -> [] - | [cval] -> [trace_arg cval] - | cval :: cvals -> - trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals - in - let trace_end = iraw "trace_end();" in - let trace_ret = iraw "trace_unknown();" - (* - let ctyp_name = sgen_ctyp_name ctyp in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) - else - iraw "trace_unknown();" - *) - in - [trace_start] - @ trace_args args - @ [iraw "trace_argend();"; - instr; - trace_end; - trace_ret; - iraw "trace_retend();"] - @ instrument instrs - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs - - | instr :: instrs -> instr :: instrument instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - CDEF_fundef (function_id, heap_return, args, instrument body) - | cdef -> cdef - -let bytecode_ast ctx rewrites (Defs defs) = - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in - - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in - let total = List.length defs in - let _, chunks, ctx = - List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs - in - let cdefs = List.concat (List.rev chunks) in - let cdefs, ctx = specialize_variants ctx [] cdefs in - rewrites cdefs - -let rec get_recursive_functions (Defs defs) = - match defs with - | DEF_internal_mutrec fundefs :: defs -> - IdSet.union (List.map id_of_fundef fundefs |> IdSet.of_list) (get_recursive_functions (Defs defs)) - - | (DEF_fundef fdef as def) :: defs -> - let open Rewriter in - let ids = ref IdSet.empty in - let collect_funcalls e_aux annot = - match e_aux with - | E_app (id, args) -> (ids := IdSet.add id !ids; E_aux (e_aux, annot)) - | _ -> E_aux (e_aux, annot) - in - let map_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> collect_funcalls e_aux annot) - } in - let map_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp map_exp) } in - let _ = rewrite_def map_defs def in - if IdSet.mem (id_of_fundef fdef) !ids then - IdSet.add (id_of_fundef fdef) (get_recursive_functions (Defs defs)) - else - get_recursive_functions (Defs defs) - - | _ :: defs -> get_recursive_functions (Defs defs) - | [] -> IdSet.empty - -let trace_cval = function (frag, ctyp) -> string_of_fragment frag ^ " : " ^ string_of_ctyp ctyp - -let rec trace_clexp = function - | CL_id (id, ctyp) -> sgen_id id ^ " : " ^ string_of_ctyp ctyp - | CL_field (clexp, field) -> "(" ^ trace_clexp clexp ^ ")->" ^ field ^ ")" - | CL_tuple (clexp, n) -> "(" ^ trace_clexp clexp ^ ")." ^ string_of_int n - | CL_addr clexp -> "*(" ^ trace_clexp clexp ^ ")" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -let rec smt_trace_instrs ctx function_id = function - | I_aux (I_jump (cval, label), aux) :: instrs -> - iraw ("printf(\"!branch %s %s\\n\"," ^ sgen_cval cval ^ " ?\"true\":\"false\", \"" ^ trace_cval cval ^ "\");") - :: I_aux (I_jump (cval, label), aux) - :: smt_trace_instrs ctx function_id instrs - - | (I_aux ((I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval)), _) as instr) :: instrs -> - iraw ("printf(\"!create " ^ Util.zencode_string (string_of_id id) ^ " : " ^ string_of_ctyp ctyp ^ " = " ^ trace_cval cval ^ "\\n\");") - :: instr - :: smt_trace_instrs ctx function_id instrs - - | (I_aux ((I_decl (ctyp, id) | I_reset (ctyp, id)), _) as instr) :: instrs -> - iraw ("printf(\"!create " ^ Util.zencode_string (string_of_id id) ^ " : " ^ string_of_ctyp ctyp ^ "\\n\");") - :: instr - :: smt_trace_instrs ctx function_id instrs - - | I_aux (I_funcall (x, extern, f, args), aux) :: instrs -> - let extern_name = - if Env.is_extern f ctx.tc_env "c" then - Some (Env.get_extern f ctx.tc_env "c") - else if extern then - Some (string_of_id f) - else None - in - begin match extern_name with - | Some name -> - iraw ("printf(\"!" - ^ trace_clexp x - ^ " = " - ^ string_of_id f ^ "(" ^ Util.string_of_list ", " (fun cval -> String.escaped (trace_cval cval)) args ^ ")\\n\");") - :: I_aux (I_funcall (x, extern, f, args), aux) - :: smt_trace_instrs ctx function_id instrs - | None -> - iraw ("printf(\"!call " ^ string_of_id f ^ "(" ^ Util.string_of_list ", " (fun cval -> String.escaped (trace_cval cval)) args ^ ")\\n\");") - :: I_aux (I_funcall (x, extern, f, args), aux) - :: iraw ("printf(\"!" ^ trace_clexp x ^ " = endcall " ^ string_of_id f ^ "\\n\");") - :: smt_trace_instrs ctx function_id instrs - end - - | I_aux (I_return cval, aux) :: instrs -> - iraw ("printf(\"!return " ^ trace_cval cval ^ "\\n\");") - :: I_aux (I_return cval, aux) - :: smt_trace_instrs ctx function_id instrs - - | instr :: instrs -> instr :: smt_trace_instrs ctx function_id instrs - - | [] -> [] - -let smt_trace ctx = - function - | CDEF_fundef (function_id, heap_return, args, body) -> - let string_of_heap_return = function - | Some id -> Util.zencode_string (string_of_id id) - | None -> "return" - in - let body = - iraw ("printf(\"!link " ^ string_of_heap_return heap_return ^ "(" ^ Util.string_of_list ", " (fun id -> Util.zencode_string (string_of_id id)) args ^ ")\\n\");") - :: smt_trace_instrs ctx function_id body - in - CDEF_fundef (function_id, heap_return, args, body) - - | cdef -> cdef - -let compile_ast ctx output_chan c_includes (Defs defs) = - try - c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions")); - let recursive_functions = Spec_analysis.top_sort_defs (Defs defs) |> get_recursive_functions in - let ctx = { ctx with recursive_functions = recursive_functions } in - c_debug (lazy (Util.string_of_list ", " string_of_id (IdSet.elements recursive_functions))); - - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in - - if !opt_memo_cache then - (try - if Sys.is_directory "_sbuild" then - () - else - raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!") - with - | Sys_error _ -> Unix.mkdir "_sbuild" 0o775) - else (); - - let total = List.length defs in - let _, chunks, ctx = - List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs - in - let cdefs = List.concat (List.rev chunks) in - - let cdefs, ctx = specialize_variants ctx [] cdefs in - let cdefs = sort_ctype_defs cdefs in - let cdefs = optimize ctx cdefs in - let cdefs = if !opt_trace then List.map (instrument_tracing ctx) cdefs else cdefs in - - let cdefs = if !opt_smt_trace then List.map (fun cdef -> smt_trace ctx (flatten_cdef cdef)) cdefs else cdefs in - - let docs = List.map (codegen_def ctx) cdefs in - - let preamble = separate hardline - ([ string "#include \"sail.h\"" ] - @ (if !opt_no_rts then [] else - [ string "#include \"rts.h\""; - string "#include \"elf.h\"" ]) - @ (List.map (fun h -> string (Printf.sprintf "#include \"%s\"" h)) c_includes)) - in - - let exn_boilerplate = - if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else - ([ " current_exception = malloc(sizeof(struct zexception));"; - " CREATE(zexception)(current_exception);" ], - [ " KILL(zexception)(current_exception);"; - " free(current_exception);"; - " if (have_exception) fprintf(stderr, \"Exiting due to uncaught exception\\n\");" ]) - in - - let letbind_initializers = - List.map (fun n -> Printf.sprintf " create_letbind_%d();" n) (List.rev ctx.letbinds) - in - let letbind_finalizers = - List.map (fun n -> Printf.sprintf " kill_letbind_%d();" n) ctx.letbinds - in - let startup cdefs = - List.map sgen_startup (List.filter is_cdef_startup cdefs) - in - let finish cdefs = - List.map sgen_finish (List.filter is_cdef_finish cdefs) - in - - let regs = c_ast_registers cdefs in - - let register_init_clear (id, ctyp, instrs) = - if is_stack_ctyp ctyp then - List.map (sgen_instr (mk_id "reg") ctx) instrs, [] - else - [ Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] - @ List.map (sgen_instr (mk_id "reg") ctx) instrs, - [ Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] - in - - let model_init = separate hardline (List.map string - ( [ "void model_init(void)"; - "{"; - " setup_rts();" ] - @ fst exn_boilerplate - @ startup cdefs - @ List.concat (List.map (fun r -> fst (register_init_clear r)) regs) - @ (if regs = [] then [] else [ Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "initialize_registers")) ]) - @ letbind_initializers - @ [ "}" ] )) - in - - let model_fini = separate hardline (List.map string - ( [ "void model_fini(void)"; - "{" ] - @ letbind_finalizers - @ List.concat (List.map (fun r -> snd (register_init_clear r)) regs) - @ finish cdefs - @ snd exn_boilerplate - @ [ " cleanup_rts();"; - "}" ] )) - in - - let model_default_main = separate hardline (List.map string - [ "int model_main(int argc, char *argv[])"; - "{"; - " model_init();"; - " if (process_arguments(argc, argv)) exit(EXIT_FAILURE);"; - Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "main")); - " model_fini();"; - " return EXIT_SUCCESS;"; - "}" ] ) - in - - let model_main = separate hardline (if (!opt_no_main) then [] else List.map string - [ "int main(int argc, char *argv[])"; - "{"; - " return model_main(argc, argv);"; - "}" ] ) - in - - let hlhl = hardline ^^ hardline in - - Pretty_print_sail.to_string (preamble ^^ hlhl ^^ separate hlhl docs ^^ hlhl - ^^ (if not !opt_no_rts then - model_init ^^ hlhl - ^^ model_fini ^^ hlhl - ^^ model_default_main ^^ hlhl - else - empty) - ^^ model_main ^^ hardline) - |> output_string output_chan - with - Type_error (_, l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) diff --git a/src/c_backend.mli b/src/c_backend.mli deleted file mode 100644 index 4017130a..00000000 --- a/src/c_backend.mli +++ /dev/null @@ -1,141 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Bytecode -open Type_check - -(** Global compilation options *) - -(** Output a dataflow graph for each generated function in Graphviz - (dot) format. *) -val opt_debug_flow_graphs : bool ref - -(** Print the ANF and IR representations of a specific function. *) -val opt_debug_function : string ref - -(** Instrument generated code to output a trace. opt_smt_trace is WIP - but intended to enable generating traces suitable for concolic - execution with SMT. *) -val opt_trace : bool ref -val opt_smt_trace : bool ref - -(** Define generated functions as static *) -val opt_static : bool ref - -(** Do not generate a main function *) -val opt_no_main : bool ref - -(** (WIP) Do not include rts.h (the runtime), and do not generate code - that requires any setup or teardown routines to be run by a runtime - before executing any instruction semantics. *) -val opt_no_rts : bool ref - -(** Ordinarily we use plain z-encoding to name-mangle generated Sail - identifiers into a form suitable for C. If opt_prefix is set, then - the "z" which is added on the front of each generated C function - will be replaced by opt_prefix. E.g. opt_prefix := "sail_" would - give sail_my_function rather than zmy_function. *) -val opt_prefix : string ref - -(** opt_extra_params and opt_extra_arguments allow additional state to - be threaded through the generated C code by adding an additional - parameter to each function type, and then giving an extra argument - to each function call. For example we could have - - opt_extra_params := Some "CPUMIPSState *env" - opt_extra_arguments := Some "env" - - and every generated function will take a pointer to a QEMU MIPS - processor state, and each function will be passed the env argument - when it is called. *) -val opt_extra_params : string option ref -val opt_extra_arguments : string option ref - -(** (WIP) [opt_memo_cache] will store the compiled function - definitions in file _sbuild/ccacheDIGEST where DIGEST is the md5sum - of the original function to be compiled. Enabled using the -memo - flag. Uses Marshal so it's quite picky about the exact version of - the Sail version. This cache can obviously become stale if the C - backend changes - it'll load an old version compiled without said - changes. *) -val opt_memo_cache : bool ref - -(** Optimization flags *) - -val optimize_primops : bool ref -val optimize_hoist_allocations : bool ref -val optimize_struct_updates : bool ref -val optimize_alias : bool ref -val optimize_experimental : bool ref - -(** The compilation context. *) -type ctx - -(** Create a context from a typechecking environment. This environment - should be the environment returned by typechecking the full AST. *) -val initial_ctx : Env.t -> ctx - -(** Same as initial ctx, but iterate to find more precise bounds on - integers. *) -val initial_ctx_iterate : Env.t -> ctx - -(** Convert a typ to a IR ctyp *) -val ctyp_of_typ : ctx -> Ast.typ -> ctyp - -val compile_aexp : ctx -> Ast.typ Anf.aexp -> instr list * (clexp -> instr) * instr list - -val compile_ast : ctx -> out_channel -> string list -> tannot Ast.defs -> unit - -val bytecode_ast : ctx -> (cdef list -> cdef list) -> tannot Ast.defs -> cdef list - -(** Rewriting steps for compiled ASTs *) -val flatten_instrs : instr list -> instr list - -val flatten_cdef : cdef -> cdef diff --git a/src/isail.ml b/src/isail.ml index 4c7cf8d6..e47973b4 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -57,7 +57,6 @@ open Pretty_print_sail type mode = | Evaluation of frame - | Bytecode of Value2.vl Bytecode_interpreter.gstate * Value2.vl Bytecode_interpreter.stack | Normal | Emacs @@ -67,7 +66,6 @@ let prompt () = match !current_mode with | Normal -> "sail> " | Evaluation _ -> "eval> " - | Bytecode _ -> "ir> " | Emacs -> "" let eval_clear = ref true @@ -76,7 +74,6 @@ let mode_clear () = match !current_mode with | Normal -> () | Evaluation _ -> if !eval_clear then LNoise.clear_screen () else () - | Bytecode _ -> () (* if !eval_clear then LNoise.clear_screen () else () *) | Emacs -> () let rec user_input callback = @@ -126,22 +123,6 @@ let print_program () = | Evaluation (Done (_, v)) -> print_endline (Value.string_of_value v |> Util.green |> Util.clear) | Evaluation _ -> () - | Bytecode (_, stack) -> - let open Bytecode_interpreter in - let open Bytecode_util in - let pc = stack.top.pc in - let instrs = stack.top.instrs in - for i = 0 to stack.top.pc - 1 do - print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) - done; - print_endline (">> " ^ Pretty_print_sail.to_string (pp_instr instrs.(stack.top.pc))); - for i = stack.top.pc + 1 to Array.length instrs - 1 do - print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) - done; - print_endline sep; - print_endline (Util.string_of_list ", " - (fun (id, vl) -> Printf.sprintf "%s = %s" (string_of_id id) (string_of_value vl)) - (Bindings.bindings stack.top.locals)) let rec run () = match !current_mode with @@ -165,7 +146,6 @@ let rec run () = print_endline "Breakpoint"; current_mode := Evaluation frame end - | Bytecode _ -> () let rec run_steps n = print_endline ("step " ^ string_of_int n); @@ -191,7 +171,6 @@ let rec run_steps n = print_endline "Breakpoint"; current_mode := Evaluation frame end - | Bytecode _ -> () let help = function | ":t" | ":type" -> @@ -372,16 +351,19 @@ let handle_input' input = | ":pretty" -> print_endline (Pretty_print_sail.to_string (Latex.defs !Interactive.ast)) | ":compile" -> + (* let open PPrint in let open C_backend in let ast = Process_file.rewrite_ast_c !Interactive.env !Interactive.ast in let ast, env = Specialize.(specialize typ_ord_specialization ast !Interactive.env) in let ctx = initial_ctx env in interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast + *) + () | ":ir" -> print_endline arg; - let open Bytecode in - let open Bytecode_util in + let open Jib in + let open Jib_util in let open PPrint in let is_cdef = function | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true @@ -426,16 +408,6 @@ let handle_input' input = (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () - | ":exec" -> - let open Bytecode_interpreter in - let exp = Type_check.infer_exp !Interactive.env (Initial_check.exp_of_string arg) in - let anf = Anf.anf exp in - let ctx = C_backend.initial_ctx !Interactive.env in - let ctyp = C_backend.ctyp_of_typ ctx (Type_check.typ_of exp) in - let setup, call, cleanup = C_backend.compile_aexp ctx anf in - let instrs = C_backend.flatten_instrs (setup @ [call (CL_id (mk_id "interactive#", ctyp))] @ cleanup) in - current_mode := Bytecode (new_gstate !interactive_bytecode, new_stack instrs); - print_program () | _ -> unrecognised_command cmd end | Expression str -> @@ -538,17 +510,6 @@ let handle_input' input = current_mode := Evaluation frame end end - | Bytecode (gstate, stack) -> - begin match input with - | Command (cmd, arg) -> - () - | Expression str -> - print_endline "Evaluating IR, cannot evaluate expression" - | Empty -> - let gstate, stack = Bytecode_interpreter.step (gstate, stack) in - current_mode := Bytecode (gstate, stack); - print_program () - end let handle_input input = try handle_input' input with diff --git a/src/jib/anf.ml b/src/jib/anf.ml new file mode 100644 index 00000000..16fb6756 --- /dev/null +++ b/src/jib/anf.ml @@ -0,0 +1,717 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_util +open Type_check +open PPrint + +module Big_int = Nat_big_num + +(**************************************************************************) +(* 1. Conversion to A-normal form (ANF) *) +(**************************************************************************) + +(* The first step in compiling sail is converting the Sail expression + grammar into A-normal form. Essentially this converts expressions + such as f(g(x), h(y)) into something like: + + let v0 = g(x) in let v1 = h(x) in f(v0, v1) + + Essentially the arguments to every function must be trivial, and + complex expressions must be let bound to new variables, or used in + a block, assignment, or control flow statement (if, for, and + while/until loops). The aexp datatype represents these expressions, + while aval represents the trivial values. + + The convention is that the type of an aexp is given by last + argument to a constructor. It is omitted where it is obvious - for + example all for loops have unit as their type. If some constituent + part of the aexp has an annotation, the it refers to the previous + argument, so in + + AE_let (id, typ1, _, body, typ2) + + typ1 is the type of the bound identifer, whereas typ2 is the type + of the whole let expression (and therefore also the body). + + See Flanagan et al's 'The Essence of Compiling with Continuations' + *) +type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l + +and 'a aexp_aux = + | AE_val of 'a aval + | AE_app of id * ('a aval) list * 'a + | AE_cast of 'a aexp * 'a + | AE_assign of id * 'a * 'a aexp + | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a + | AE_block of ('a aexp) list * 'a aexp * 'a + | AE_return of 'a aval * 'a + | AE_throw of 'a aval * 'a + | AE_if of 'a aval * 'a aexp * 'a aexp * 'a + | AE_field of 'a aval * id * 'a + | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a + | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp + | AE_loop of loop * 'a aexp * 'a aexp + | AE_short_circuit of sc_op * 'a aval * 'a aexp + +and sc_op = SC_and | SC_or + +and 'a apat = AP_aux of 'a apat_aux * Env.t * l + +and 'a apat_aux = + | AP_tup of ('a apat) list + | AP_id of id * 'a + | AP_global of id * 'a + | AP_app of id * 'a apat * 'a + | AP_cons of 'a apat * 'a apat + | AP_nil of 'a + | AP_wild of 'a + +and 'a aval = + | AV_lit of lit * 'a + | AV_id of id * 'a lvar + | AV_ref of id * 'a lvar + | AV_tuple of ('a aval) list + | AV_list of ('a aval) list * 'a + | AV_vector of ('a aval) list * 'a + | AV_record of ('a aval) Bindings.t * 'a + | AV_C_fragment of fragment * 'a * ctyp + +(* Renaming variables in ANF expressions *) + +let rec apat_bindings (AP_aux (apat_aux, _, _)) = + match apat_aux with + | AP_tup apats -> List.fold_left IdSet.union IdSet.empty (List.map apat_bindings apats) + | AP_id (id, _) -> IdSet.singleton id + | AP_global (id, _) -> IdSet.empty + | AP_app (id, apat, _) -> apat_bindings apat + | AP_cons (apat1, apat2) -> IdSet.union (apat_bindings apat1) (apat_bindings apat2) + | AP_nil _ -> IdSet.empty + | AP_wild _ -> IdSet.empty + +(** This function returns the types of all bound variables in a + pattern. It ignores AP_global, apat_globals is used for that. *) +let rec apat_types (AP_aux (apat_aux, _, _)) = + let merge id b1 b2 = + match b1, b2 with + | None, None -> None + | Some v, None -> Some v + | None, Some v -> Some v + | Some _, Some _ -> assert false + in + match apat_aux with + | AP_tup apats -> List.fold_left (Bindings.merge merge) Bindings.empty (List.map apat_types apats) + | AP_id (id, typ) -> Bindings.singleton id typ + | AP_global (id, _) -> Bindings.empty + | AP_app (id, apat, _) -> apat_types apat + | AP_cons (apat1, apat2) -> (Bindings.merge merge) (apat_types apat1) (apat_types apat2) + | AP_nil _ -> Bindings.empty + | AP_wild _ -> Bindings.empty + +let rec apat_rename from_id to_id (AP_aux (apat_aux, env, l)) = + let apat_aux = match apat_aux with + | AP_tup apats -> AP_tup (List.map (apat_rename from_id to_id) apats) + | AP_id (id, typ) when Id.compare id from_id = 0 -> AP_id (to_id, typ) + | AP_id (id, typ) -> AP_id (id, typ) + | AP_global (id, typ) -> AP_global (id, typ) + | AP_app (ctor, apat, typ) -> AP_app (ctor, apat_rename from_id to_id apat, typ) + | AP_cons (apat1, apat2) -> AP_cons (apat_rename from_id to_id apat1, apat_rename from_id to_id apat2) + | AP_nil typ -> AP_nil typ + | AP_wild typ -> AP_wild typ + in + AP_aux (apat_aux, env, l) + +let rec aval_rename from_id to_id = function + | AV_lit (lit, typ) -> AV_lit (lit, typ) + | AV_id (id, lvar) when Id.compare id from_id = 0 -> AV_id (to_id, lvar) + | AV_id (id, lvar) -> AV_id (id, lvar) + | AV_ref (id, lvar) when Id.compare id from_id = 0 -> AV_ref (to_id, lvar) + | AV_ref (id, lvar) -> AV_ref (id, lvar) + | AV_tuple avals -> AV_tuple (List.map (aval_rename from_id to_id) avals) + | AV_list (avals, typ) -> AV_list (List.map (aval_rename from_id to_id) avals, typ) + | AV_vector (avals, typ) -> AV_vector (List.map (aval_rename from_id to_id) avals, typ) + | AV_record (avals, typ) -> AV_record (Bindings.map (aval_rename from_id to_id) avals, typ) + | AV_C_fragment (fragment, typ, ctyp) -> AV_C_fragment (frag_rename from_id to_id fragment, typ, ctyp) + +let rec aexp_rename from_id to_id (AE_aux (aexp, env, l)) = + let recur = aexp_rename from_id to_id in + let aexp = match aexp with + | AE_val aval -> AE_val (aval_rename from_id to_id aval) + | AE_app (id, avals, typ) -> AE_app (id, List.map (aval_rename from_id to_id) avals, typ) + | AE_cast (aexp, typ) -> AE_cast (recur aexp, typ) + | AE_assign (id, typ, aexp) when Id.compare from_id id = 0 -> AE_assign (to_id, typ, aexp_rename from_id to_id aexp) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, aexp_rename from_id to_id aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when Id.compare from_id id = 0 -> AE_let (mut, id, typ1, recur aexp1, aexp2, typ2) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, recur aexp1, recur aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map recur aexps, recur aexp, typ) + | AE_return (aval, typ) -> AE_return (aval_rename from_id to_id aval, typ) + | AE_throw (aval, typ) -> AE_throw (aval_rename from_id to_id aval, typ) + | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval_rename from_id to_id aval, recur then_aexp, recur else_aexp, typ) + | AE_field (aval, id, typ) -> AE_field (aval_rename from_id to_id aval, id, typ) + | AE_case (aval, apexps, typ) -> AE_case (aval_rename from_id to_id aval, List.map (apexp_rename from_id to_id) apexps, typ) + | AE_try (aexp, apexps, typ) -> AE_try (aexp_rename from_id to_id aexp, List.map (apexp_rename from_id to_id) apexps, typ) + | AE_record_update (aval, avals, typ) -> AE_record_update (aval_rename from_id to_id aval, Bindings.map (aval_rename from_id to_id) avals, typ) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when Id.compare from_id to_id = 0 -> AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> AE_for (id, recur aexp1, recur aexp2, recur aexp3, order, recur aexp4) + | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, recur aexp1, recur aexp2) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval_rename from_id to_id aval, recur aexp) + in + AE_aux (aexp, env, l) + +and apexp_rename from_id to_id (apat, aexp1, aexp2) = + if IdSet.mem from_id (apat_bindings apat) then + (apat, aexp1, aexp2) + else + (apat, aexp_rename from_id to_id aexp1, aexp_rename from_id to_id aexp2) + +let shadow_counter = ref 0 + +let new_shadow id = + let shadow_id = append_id id ("shadow#" ^ string_of_int !shadow_counter) in + incr shadow_counter; + shadow_id + +let rec no_shadow ids (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_val aval -> AE_val aval + | AE_app (id, avals, typ) -> AE_app (id, avals, typ) + | AE_cast (aexp, typ) -> AE_cast (no_shadow ids aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, no_shadow ids aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when IdSet.mem id ids -> + let shadow_id = new_shadow id in + let aexp1 = no_shadow ids aexp1 in + let ids = IdSet.add shadow_id ids in + AE_let (mut, shadow_id, typ1, aexp1, no_shadow ids (aexp_rename id shadow_id aexp2), typ2) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> + AE_let (mut, id, typ1, no_shadow ids aexp1, no_shadow (IdSet.add id ids) aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (no_shadow ids) aexps, no_shadow ids aexp, typ) + | AE_return (aval, typ) -> AE_return (aval, typ) + | AE_throw (aval, typ) -> AE_throw (aval, typ) + | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval, no_shadow ids then_aexp, no_shadow ids else_aexp, typ) + | AE_field (aval, id, typ) -> AE_field (aval, id, typ) + | AE_case (aval, apexps, typ) -> AE_case (aval, List.map (no_shadow_apexp ids) apexps, typ) + | AE_try (aexp, apexps, typ) -> AE_try (no_shadow ids aexp, List.map (no_shadow_apexp ids) apexps, typ) + | AE_record_update (aval, avals, typ) -> AE_record_update (aval, avals, typ) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when IdSet.mem id ids -> + let shadow_id = new_shadow id in + let aexp1 = no_shadow ids aexp1 in + let aexp2 = no_shadow ids aexp2 in + let aexp3 = no_shadow ids aexp3 in + let ids = IdSet.add shadow_id ids in + AE_for (shadow_id, aexp1, aexp2, aexp3, order, no_shadow ids (aexp_rename id shadow_id aexp4)) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let ids = IdSet.add id ids in + AE_for (id, no_shadow ids aexp1, no_shadow ids aexp2, no_shadow ids aexp3, order, no_shadow ids aexp4) + | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, no_shadow ids aexp1, no_shadow ids aexp2) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, no_shadow ids aexp) + in + AE_aux (aexp, env, l) + +and no_shadow_apexp ids (apat, aexp1, aexp2) = + let shadows = IdSet.inter (apat_bindings apat) ids in + let shadows = List.map (fun id -> id, new_shadow id) (IdSet.elements shadows) in + let rename aexp = List.fold_left (fun aexp (from_id, to_id) -> aexp_rename from_id to_id aexp) aexp shadows in + let rename_apat apat = List.fold_left (fun apat (from_id, to_id) -> apat_rename from_id to_id apat) apat shadows in + let ids = IdSet.union (apat_bindings apat) (IdSet.union ids (IdSet.of_list (List.map snd shadows))) in + (rename_apat apat, no_shadow ids (rename aexp1), no_shadow ids (rename aexp2)) + +(* Map over all the avals in an aexp. *) +let rec map_aval f (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_val v -> AE_val (f env l v) + | AE_cast (aexp, typ) -> AE_cast (map_aval f aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_aval f aexp) + | AE_app (id, vs, typ) -> AE_app (id, List.map (f env l) vs, typ) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> + AE_let (mut, id, typ1, map_aval f aexp1, map_aval f aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_aval f) aexps, map_aval f aexp, typ) + | AE_return (aval, typ) -> AE_return (f env l aval, typ) + | AE_throw (aval, typ) -> AE_throw (f env l aval, typ) + | AE_if (aval, aexp1, aexp2, typ2) -> + AE_if (f env l aval, map_aval f aexp1, map_aval f aexp2, typ2) + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_aval f aexp1, map_aval f aexp2) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + AE_for (id, map_aval f aexp1, map_aval f aexp2, map_aval f aexp3, order, map_aval f aexp4) + | AE_record_update (aval, updates, typ) -> + AE_record_update (f env l aval, Bindings.map (f env l) updates, typ) + | AE_field (aval, field, typ) -> + AE_field (f env l aval, field, typ) + | AE_case (aval, cases, typ) -> + AE_case (f env l aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (map_aval f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, f env l aval, map_aval f aexp) + in + AE_aux (aexp, env, l) + +(* Map over all the functions in an aexp. *) +let rec map_functions f (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_app (id, vs, typ) -> f env l id vs typ + | AE_cast (aexp, typ) -> AE_cast (map_functions f aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_functions f aexp) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, map_functions f aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, map_functions f aexp1, map_functions f aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_functions f) aexps, map_functions f aexp, typ) + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, map_functions f aexp1, map_functions f aexp2, typ) + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_functions f aexp1, map_functions f aexp2) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + AE_for (id, map_functions f aexp1, map_functions f aexp2, map_functions f aexp3, order, map_functions f aexp4) + | AE_case (aval, cases, typ) -> + AE_case (aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (map_functions f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) + +(* For debugging we provide a pretty printer for ANF expressions. *) + +let pp_lvar lvar doc = + match lvar with + | Register (_, _, typ) -> + string "[R/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Local (Mutable, typ) -> + string "[M/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Local (Immutable, typ) -> + string "[I/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Enum typ -> + string "[E/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Unbound -> string "[?]" ^^ doc + +let pp_annot typ doc = + string "[" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + +let pp_order = function + | Ord_aux (Ord_inc, _) -> string "inc" + | Ord_aux (Ord_dec, _) -> string "dec" + | _ -> assert false (* Order types have been specialised, so no polymorphism in C backend. *) + +let rec pp_aexp (AE_aux (aexp, _, _)) = + match aexp with + | AE_val v -> pp_aval v + | AE_cast (aexp, typ) -> + pp_annot typ (string "$" ^^ pp_aexp aexp) + | AE_assign (id, typ, aexp) -> + pp_annot typ (pp_id id) ^^ string " := " ^^ pp_aexp aexp + | AE_app (id, args, typ) -> + pp_annot typ (pp_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) + | AE_short_circuit (SC_or, aval, aexp) -> + pp_aval aval ^^ string " || " ^^ pp_aexp aexp + | AE_short_circuit (SC_and, aval, aexp) -> + pp_aval aval ^^ string " && " ^^ pp_aexp aexp + | AE_let (mut, id, id_typ, binding, body, typ) -> group + begin + let let_doc = string (match mut with Immutable -> "let" | Mutable -> "let mut") in + match binding with + | AE_aux (AE_let _, _, _) -> + (pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="]) + ^^ hardline ^^ nest 2 (pp_aexp binding)) + ^^ hardline ^^ string "in" ^^ space ^^ pp_aexp body + | _ -> + pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="; pp_aexp binding; string "in"]) + ^^ hardline ^^ pp_aexp body + end + | AE_if (cond, then_aexp, else_aexp, typ) -> + pp_annot typ (separate space [ string "if"; pp_aval cond; + string "then"; pp_aexp then_aexp; + string "else"; pp_aexp else_aexp ]) + | AE_block (aexps, aexp, typ) -> + pp_annot typ (surround 2 0 lbrace (pp_block (aexps @ [aexp])) rbrace) + | AE_return (v, typ) -> pp_annot typ (string "return" ^^ parens (pp_aval v)) + | AE_throw (v, typ) -> pp_annot typ (string "throw" ^^ parens (pp_aval v)) + | AE_loop (While, aexp1, aexp2) -> + separate space [string "while"; pp_aexp aexp1; string "do"; pp_aexp aexp2] + | AE_loop (Until, aexp1, aexp2) -> + separate space [string "repeat"; pp_aexp aexp2; string "until"; pp_aexp aexp1] + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ pp_id id; + string "from " ^^ pp_aexp aexp1; + string "to " ^^ pp_aexp aexp2; + string "by " ^^ pp_aexp aexp3; + string "in " ^^ pp_order order ])) + in + header ^//^ pp_aexp aexp4 + | AE_field (aval, field, typ) -> pp_annot typ (parens (pp_aval aval ^^ string "." ^^ pp_id field)) + | AE_case (aval, cases, typ) -> + pp_annot typ (separate space [string "match"; pp_aval aval; pp_cases cases]) + | AE_try (aexp, cases, typ) -> + pp_annot typ (separate space [string "try"; pp_aexp aexp; pp_cases cases]) + | AE_record_update (aval, updates, typ) -> + braces (pp_aval aval ^^ string " with " + ^^ separate (string ", ") (List.map (fun (id, aval) -> pp_id id ^^ string " = " ^^ pp_aval aval) + (Bindings.bindings updates))) + +and pp_apat (AP_aux (apat_aux, _, _)) = + match apat_aux with + | AP_wild _ -> string "_" + | AP_id (id, typ) -> pp_annot typ (pp_id id) + | AP_global (id, _) -> pp_id id + | AP_tup apats -> parens (separate_map (comma ^^ space) pp_apat apats) + | AP_app (id, apat, typ) -> pp_annot typ (pp_id id ^^ parens (pp_apat apat)) + | AP_nil _ -> string "[||]" + | AP_cons (hd_apat, tl_apat) -> pp_apat hd_apat ^^ string " :: " ^^ pp_apat tl_apat + +and pp_cases cases = surround 2 0 lbrace (separate_map (comma ^^ hardline) pp_case cases) rbrace + +and pp_case (apat, guard, body) = + separate space [pp_apat apat; string "if"; pp_aexp guard; string "=>"; pp_aexp body] + +and pp_block = function + | [] -> string "()" + | [aexp] -> pp_aexp aexp + | aexp :: aexps -> pp_aexp aexp ^^ semi ^^ hardline ^^ pp_block aexps + +and pp_aval = function + | AV_lit (lit, typ) -> pp_annot typ (string (string_of_lit lit)) + | AV_id (id, lvar) -> pp_lvar lvar (pp_id id) + | AV_tuple avals -> parens (separate_map (comma ^^ space) pp_aval avals) + | AV_ref (id, lvar) -> string "ref" ^^ space ^^ pp_lvar lvar (pp_id id) + | AV_C_fragment (frag, typ, ctyp) -> + pp_annot typ (string ("(" ^ string_of_ctyp ctyp ^ ")" ^ string_of_fragment frag |> Util.cyan |> Util.clear)) + | AV_vector (avals, typ) -> + pp_annot typ (string "[" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "]") + | AV_list (avals, typ) -> + pp_annot typ (string "[|" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "|]") + | AV_record (fields, typ) -> + pp_annot typ (string "struct {" + ^^ separate_map (comma ^^ space) (fun (id, field) -> pp_id id ^^ string " = " ^^ pp_aval field) (Bindings.bindings fields) + ^^ string "}") + +let ae_lit lit typ = AE_val (AV_lit (lit, typ)) + +let is_dead_aexp (AE_aux (_, env, _)) = prove __POS__ env nc_false + +(** GLOBAL: gensym_counter is used to generate fresh identifiers where + needed. It should be safe to reset between top level + definitions. **) +let gensym_counter = ref 0 + +let gensym () = + let id = mk_id ("gs#" ^ string_of_int !gensym_counter) in + incr gensym_counter; + id + +let rec split_block l = function + | [exp] -> [], exp + | exp :: exps -> + let exps, last = split_block l exps in + exp :: exps, last + | [] -> + raise (Reporting.err_unreachable l __POS__ "empty block found when converting to ANF") + +let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = + let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in + match p_aux with + | P_id id when global -> mk_apat (AP_global (id, typ_of_pat pat)) + | P_id id -> mk_apat (AP_id (id, typ_of_pat pat)) + | P_wild -> mk_apat (AP_wild (typ_of_pat pat)) + | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)) + | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, typ_of_pat pat)) + | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), typ_of_pat pat)) + | P_typ (_, pat) -> anf_pat ~global:global pat + | P_var (pat, _) -> anf_pat ~global:global pat + | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) + | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) + | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) + | _ -> + raise (Reporting.err_unreachable (fst annot) __POS__ + ("Could not convert pattern to ANF: " ^ string_of_pat pat)) + +let rec apat_globals (AP_aux (aux, _, _)) = + match aux with + | AP_nil _ | AP_wild _ | AP_id _ -> [] + | AP_global (id, typ) -> [(id, typ)] + | AP_tup apats -> List.concat (List.map apat_globals apats) + | AP_app (_, apat, _) -> apat_globals apat + | AP_cons (hd_apat, tl_apat) -> apat_globals hd_apat @ apat_globals tl_apat + +let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = + let mk_aexp aexp = AE_aux (aexp, env_of_annot exp_annot, l) in + + let to_aval (AE_aux (aexp_aux, env, l) as aexp) = + let mk_aexp aexp = AE_aux (aexp, env, l) in + match aexp_aux with + | AE_val v -> (v, fun x -> x) + | AE_short_circuit (_, _, _) -> + let id = gensym () in + (AV_id (id, Local (Immutable, bool_typ)), fun x -> mk_aexp (AE_let (Immutable, id, bool_typ, aexp, x, typ_of exp))) + | AE_app (_, _, typ) + | AE_let (_, _, _, _, _, typ) + | AE_return (_, typ) + | AE_throw (_, typ) + | AE_cast (_, typ) + | AE_if (_, _, _, typ) + | AE_field (_, _, typ) + | AE_case (_, _, typ) + | AE_try (_, _, typ) + | AE_record_update (_, _, typ) + | AE_block (_, _, typ) -> + let id = gensym () in + (AV_id (id, Local (Immutable, typ)), fun x -> mk_aexp (AE_let (Immutable, id, typ, aexp, x, typ_of exp))) + | AE_assign _ | AE_for _ | AE_loop _ -> + let id = gensym () in + (AV_id (id, Local (Immutable, unit_typ)), fun x -> mk_aexp (AE_let (Immutable, id, unit_typ, aexp, x, typ_of exp))) + in + match e_aux with + | E_lit lit -> mk_aexp (ae_lit lit (typ_of exp)) + + | E_block [] -> + Util.warn (Reporting.loc_to_string l + ^ "\n\nTranslating empty block (possibly assigning to an uninitialized variable at the end of a block?)"); + mk_aexp (ae_lit (L_aux (L_unit, l)) (typ_of exp)) + | E_block exps -> + let exps, last = split_block l exps in + let aexps = List.map anf exps in + let alast = anf last in + mk_aexp (AE_block (aexps, alast, typ_of exp)) + + | E_assign (LEXP_aux (LEXP_deref dexp, _), exp) -> + let gs = gensym () in + mk_aexp (AE_let (Mutable, gs, typ_of dexp, anf dexp, mk_aexp (AE_assign (gs, typ_of dexp, anf exp)), unit_typ)) + + | E_assign (LEXP_aux (LEXP_id id, _), exp) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> + let aexp = anf exp in + mk_aexp (AE_assign (id, lvar_typ (Env.lookup_id id (env_of exp)), aexp)) + + | E_assign (lexp, _) -> + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) + + | E_loop (loop_typ, cond, exp) -> + let acond = anf cond in + let aexp = anf exp in + mk_aexp (AE_loop (loop_typ, acond, aexp)) + + | E_for (id, exp1, exp2, exp3, order, body) -> + let aexp1, aexp2, aexp3, abody = anf exp1, anf exp2, anf exp3, anf body in + mk_aexp (AE_for (id, aexp1, aexp2, aexp3, order, abody)) + + | E_if (cond, then_exp, else_exp) -> + let cond_val, wrap = to_aval (anf cond) in + let then_aexp = anf then_exp in + let else_aexp = anf else_exp in + wrap (mk_aexp (AE_if (cond_val, then_aexp, else_aexp, typ_of exp))) + + | E_app_infix (x, Id_aux (Id op, l), y) -> + anf (E_aux (E_app (Id_aux (DeIid op, l), [x; y]), exp_annot)) + | E_app_infix (x, Id_aux (DeIid op, l), y) -> + anf (E_aux (E_app (Id_aux (Id op, l), [x; y]), exp_annot)) + + | E_vector exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_vector (List.map fst avals, typ_of exp)))) + + | E_list exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_list (List.map fst avals, typ_of exp)))) + + | E_field (field_exp, id) -> + let aval, wrap = to_aval (anf field_exp) in + wrap (mk_aexp (AE_field (aval, id, typ_of exp))) + + | E_record_update (exp, fexps) -> + let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = + let aval, wrap = to_aval (anf exp) in + (id, aval), wrap + in + let aval, exp_wrap = to_aval (anf exp) in + let fexps = List.map anf_fexp fexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in + let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in + exp_wrap (wrap (mk_aexp (AE_record_update (aval, record, typ_of exp)))) + + | E_app (id, [exp1; exp2]) when string_of_id id = "and_bool" -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap = to_aval aexp1 in + wrap (mk_aexp (AE_short_circuit (SC_and, aval1, aexp2))) + + | E_app (id, [exp1; exp2]) when string_of_id id = "or_bool" -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap = to_aval aexp1 in + wrap (mk_aexp (AE_short_circuit (SC_or, aval1, aexp2))) + + | E_app (id, exps) -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_app (id, List.map fst avals, typ_of exp))) + + | E_throw exn_exp -> + let aexp = anf exn_exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_throw (aval, typ_of exp))) + + | E_exit exp -> + let aexp = anf exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_app (mk_id "sail_exit", [aval], unit_typ))) + + | E_return ret_exp -> + let aexp = anf ret_exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_return (aval, typ_of exp))) + + | E_assert (exp1, exp2) -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap1 = to_aval aexp1 in + let aval2, wrap2 = to_aval aexp2 in + wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_assert", [aval1; aval2], unit_typ)))) + + | E_cons (exp1, exp2) -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap1 = to_aval aexp1 in + let aval2, wrap2 = to_aval aexp2 in + wrap1 (wrap2 (mk_aexp (AE_app (mk_id "cons", [aval1; aval2], unit_typ)))) + + | E_id id -> + let lvar = Env.lookup_id id (env_of exp) in + begin match lvar with + | _ -> mk_aexp (AE_val (AV_id (id, lvar))) + end + + | E_ref id -> + let lvar = Env.lookup_id id (env_of exp) in + mk_aexp (AE_val (AV_ref (id, lvar))) + + | E_case (match_exp, pexps) -> + let match_aval, match_wrap = to_aval (anf match_exp) in + let anf_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_when (pat, guard, body) -> + (anf_pat pat, anf guard, anf body) + | Pat_exp (pat, body) -> + (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) + in + match_wrap (mk_aexp (AE_case (match_aval, List.map anf_pexp pexps, typ_of exp))) + + | E_try (match_exp, pexps) -> + let match_aexp = anf match_exp in + let anf_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_when (pat, guard, body) -> + (anf_pat pat, anf guard, anf body) + | Pat_exp (pat, body) -> + (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) + in + mk_aexp (AE_try (match_aexp, List.map anf_pexp pexps, typ_of exp)) + + | E_var (LEXP_aux (LEXP_id id, _), binding, body) + | E_var (LEXP_aux (LEXP_cast (_, id), _), binding, body) + | E_let (LB_aux (LB_val (P_aux (P_id id, _), binding), _), body) -> + let env = env_of body in + let lvar = Env.lookup_id id env in + mk_aexp (AE_let (Mutable, id, lvar_typ lvar, anf binding, anf body, typ_of exp)) + + | E_var (lexp, _, _) -> + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) + + | E_let (LB_aux (LB_val (pat, binding), _), body) -> + anf (E_aux (E_case (binding, [Pat_aux (Pat_exp (pat, body), (Parse_ast.Unknown, empty_tannot))]), exp_annot)) + + | E_tuple exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_tuple (List.map fst avals)))) + + | E_record fexps -> + let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = + let aval, wrap = to_aval (anf exp) in + (id, aval), wrap + in + let fexps = List.map anf_fexp fexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in + let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in + wrap (mk_aexp (AE_val (AV_record (record, typ_of exp)))) + + | E_cast (typ, exp) -> mk_aexp (AE_cast (anf exp, typ)) + + | E_vector_access _ | E_vector_subrange _ | E_vector_update _ | E_vector_update_subrange _ | E_vector_append _ -> + (* Should be re-written by type checker *) + raise (Reporting.err_unreachable l __POS__ "encountered raw vector operation when converting to ANF") + + | E_internal_value _ -> + (* Interpreter specific *) + raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") + + | E_sizeof nexp -> + (* Sizeof nodes removed by sizeof rewriting pass *) + raise (Reporting.err_unreachable l __POS__ ("encountered E_sizeof node " ^ string_of_nexp nexp ^ " when converting to ANF")) + + | E_constraint _ -> + (* Sizeof nodes removed by sizeof rewriting pass *) + raise (Reporting.err_unreachable l __POS__ "encountered E_constraint node when converting to ANF") + + | E_nondet _ -> + (* We don't compile E_nondet nodes *) + raise (Reporting.err_unreachable l __POS__ "encountered E_nondet node when converting to ANF") + + | E_internal_return _ | E_internal_plet _ -> + raise (Reporting.err_unreachable l __POS__ "encountered unexpected internal node when converting to ANF") diff --git a/src/jib/anf.mli b/src/jib/anf.mli new file mode 100644 index 00000000..e8d58fe4 --- /dev/null +++ b/src/jib/anf.mli @@ -0,0 +1,125 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Type_check + +(* The A-normal form (ANF) grammar *) + +type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l + +and 'a aexp_aux = + | AE_val of 'a aval + | AE_app of id * ('a aval) list * 'a + | AE_cast of 'a aexp * 'a + | AE_assign of id * 'a * 'a aexp + | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a + | AE_block of ('a aexp) list * 'a aexp * 'a + | AE_return of 'a aval * 'a + | AE_throw of 'a aval * 'a + | AE_if of 'a aval * 'a aexp * 'a aexp * 'a + | AE_field of 'a aval * id * 'a + | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a + | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp + | AE_loop of loop * 'a aexp * 'a aexp + | AE_short_circuit of sc_op * 'a aval * 'a aexp + +and sc_op = SC_and | SC_or + +and 'a apat = AP_aux of 'a apat_aux * Env.t * l + +and 'a apat_aux = + | AP_tup of ('a apat) list + | AP_id of id * 'a + | AP_global of id * 'a + | AP_app of id * 'a apat * 'a + | AP_cons of 'a apat * 'a apat + | AP_nil of 'a + | AP_wild of 'a + +and 'a aval = + | AV_lit of lit * 'a + | AV_id of id * 'a lvar + | AV_ref of id * 'a lvar + | AV_tuple of ('a aval) list + | AV_list of ('a aval) list * 'a + | AV_vector of ('a aval) list * 'a + | AV_record of ('a aval) Bindings.t * 'a + | AV_C_fragment of fragment * 'a * ctyp + +val gensym : unit -> id + +(* Functions for transforming ANF expressions *) + +val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp + +val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp + +val no_shadow : IdSet.t -> 'a aexp -> 'a aexp + +val apat_globals : 'a apat -> (id * 'a) list + +val apat_types : 'a apat -> 'a Bindings.t + +val is_dead_aexp : 'a aexp -> bool + +(* Compiling to ANF expressions *) + +val anf_pat : ?global:bool -> tannot pat -> typ apat + +val anf : tannot exp -> typ aexp + +(* Pretty printing ANF expressions *) +val pp_aval : typ aval -> PPrint.document +val pp_aexp : typ aexp -> PPrint.document diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml new file mode 100644 index 00000000..a08261fc --- /dev/null +++ b/src/jib/c_backend.ml @@ -0,0 +1,2420 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_compile +open Jib_util +open Type_check +open PPrint +open Value2 + +open Anf + +module Big_int = Nat_big_num + +let c_verbosity = ref 0 + +let opt_debug_flow_graphs = ref false +let opt_static = ref false +let opt_no_main = ref false +let opt_memo_cache = ref false +let opt_no_rts = ref false +let opt_prefix = ref "z" +let opt_extra_params = ref None +let opt_extra_arguments = ref None + +let extra_params () = + match !opt_extra_params with + | Some str -> str ^ ", " + | _ -> "" + +let extra_arguments is_extern = + match !opt_extra_arguments with + | Some str when not is_extern -> str ^ ", " + | _ -> "" + +(* Optimization flags *) +let optimize_primops = ref false +let optimize_hoist_allocations = ref false +let optimize_struct_updates = ref false +let optimize_alias = ref false +let optimize_experimental = ref false + +let c_debug str = + if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () + +let c_error ?loc:(l=Parse_ast.Unknown) message = + raise (Reporting.err_general l ("\nC backend: " ^ message)) + +let zencode_id = function + | Id_aux (Id str, l) -> Id_aux (Id (Util.zencode_string str), l) + | Id_aux (DeIid str, l) -> Id_aux (Id (Util.zencode_string ("op " ^ str)), l) + +(**************************************************************************) +(* 2. Converting sail types to C types *) +(**************************************************************************) + +let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) +let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) + +(** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) +let rec ctyp_of_typ ctx typ = + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + CT_fint 64 + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (ctyp_of_typ ctx typ) + + (* When converting a sail bitvector type into C, we have three options in order of efficiency: + - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. + - If the length is less than 64, then use a small bits type, sbits. + - If the length may be larger than 64, use a large bits type lbits. *) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) + when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + begin match nexp_simp n with + | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) + | n when prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) + | _ -> CT_lbits direction + end + + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, ctyp_of_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (ctyp_of_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> Bindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based upon + it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + ctyp_of_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") + end + + | Typ_var kid -> CT_poly + + | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) + +let rec is_stack_ctyp ctyp = match ctyp with + | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true + | CT_fint n -> n <= 64 + | CT_lbits _ | CT_lint | CT_real | CT_string | CT_list _ | CT_vector _ -> false + | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields + | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) + | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps + | CT_ref ctyp -> true + | CT_poly -> true + +let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) + +let is_fbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_fbits _ -> true + | _ -> false + +let is_sbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_sbits _ -> true + | _ -> false + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty + +(**************************************************************************) +(* 3. Optimization of primitives and literals *) +(**************************************************************************) + +let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + +let literal_to_fragment (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + Some (F_lit (V_int n), CT_fint 64) + | L_hex str when String.length str <= 16 -> + let padding = 16 - String.length str in + let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (F_lit (V_bits (padding @ content)), CT_fbits (String.length str * 4, true)) + | L_unit -> Some (F_lit V_unit, CT_unit) + | L_true -> Some (F_lit (V_bool true), CT_bool) + | L_false -> Some (F_lit (V_bool false), CT_bool) + | _ -> None + +let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> + begin + match literal_to_fragment lit with + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + +let mask m = + if Big_int.less_equal m (Big_int.of_int 64) then + let n = Big_int.to_int m in + if n = 0 then + "UINT64_C(0)" + else if n mod 4 = 0 then + "UINT64_C(0x" ^ String.make (16 - n / 4) '0' ^ String.make (n / 4) 'F' ^ ")" + else + "UINT64_C(" ^ String.make (64 - n) '0' ^ String.make n '1' ^ ")" + else + failwith "Tried to create a mask literal for a vector greater than 64 bits." + +let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + +let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + +let rec c_aval ctx = function + | AV_lit (lit, typ) as v -> + begin + match literal_to_fragment lit with + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) + | None -> v + end + | AV_C_fragment (str, typ, ctyp) -> AV_C_fragment (str, typ, ctyp) + (* An id can be converted to a C fragment if it's type can be + stack-allocated. *) + | AV_id (id, lvar) as v -> + begin + match lvar with + | Local (_, typ) -> + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + begin + try + (* We need to check that id's type hasn't changed due to flow typing *) + let _, ctyp' = Bindings.find id ctx.locals in + if ctyp_equal ctyp ctyp' then + AV_C_fragment (F_id id, typ, ctyp) + else + (* id's type changed due to flow + typing, so it's really still heap allocated! *) + v + with + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_C_fragment (F_id id, typ, ctyp) + end + else + v + | Register (_, _, typ) when is_stack_typ ctx typ -> + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + AV_C_fragment (F_id id, typ, ctyp) + else + v + | _ -> v + end + | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> + let bitstring = F_lit (V_bits (List.map value_of_aval_bit v)) in + AV_C_fragment (bitstring, typ, CT_fbits (List.length v, true)) + | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) + | aval -> aval + +let is_c_fragment = function + | AV_C_fragment _ -> true + | _ -> false + +let c_fragment = function + | AV_C_fragment (frag, _, _) -> frag + | _ -> assert false + +let v_mask_lower i = F_lit (V_bits (Util.list_init i (fun _ -> Sail2_values.B1))) + +(* Map over all the functions in an aexp. *) +let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = + let ctx = { ctx with local_env = env } in + let aexp = match aexp with + | AE_app (id, vs, typ) -> f ctx id vs typ + + | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) + + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + + | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> + let aexp1 = analyze_functions ctx f aexp1 in + (* Use aexp2's environment because it will contain constraints for id *) + let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in + let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in + AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + + | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let aexp1 = analyze_functions ctx f aexp1 in + let aexp2 = analyze_functions ctx f aexp2 in + let aexp3 = analyze_functions ctx f aexp3 in + let aexp4 = analyze_functions ctx f aexp4 in + (* Currently we assume that loop indexes are always safe to put into an int64 *) + let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in + AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + + | AE_case (aval, cases, typ) -> + let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = + let pat_bindings = Bindings.bindings (apat_types pat) in + let ctx = { ctx with local_env = env } in + let ctx = + List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings + in + pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 + in + AE_case (aval, List.map analyze_case cases, typ) + + | AE_try (aexp, cases, typ) -> + AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) + + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) + +let analyze_primop' ctx id args typ = + let no_change = AE_app (id, args, typ) in + let args = List.map (c_aval ctx) args in + let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in + + let v_one = F_lit (V_int (Big_int.of_int 1)) in + let v_int n = F_lit (V_int (Big_int.of_int n)) in + + c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); + + match extern, args with + | "eq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) + | "eq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("eq_sbits", [v1; v2]), typ, CT_bool)) + + | "neq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ, CT_bool)) + | "neq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("neq_sbits", [v1; v2]), typ, CT_bool)) + + | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) + + | "zeros", [_] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_raw "0x0", typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + + | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)] + when n <= 63 -> + AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord))) + + | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool)) + | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) + | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool)) + | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool)) + + | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) + | "xor_bits", [AV_C_fragment (v1, _, (CT_sbits _ as ctyp)); AV_C_fragment (v2, _, CT_sbits _)] -> + AE_val (AV_C_fragment (F_call ("xor_sbits", [v1; v2]), typ, ctyp)) + + | "or_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) + + | "and_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) + + | "not_bits", [AV_C_fragment (v, _, ctyp)] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ, ctyp)) + | _ -> no_change + end + + | "vector_subrange", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] + when is_fbits_typ ctx typ -> + let len = F_op (f, "-", F_op (t, "-", v_one)) in + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), + typ, + ctyp_of_typ ctx typ)) + + | "vector_access", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (n, _, _)] -> + AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) + + | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> + AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) + + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_fbits_typ ctx typ -> + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), + typ, + ctyp_of_typ ctx typ)) + + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("sslice", [vec; start; len]), typ, ctyp_of_typ ctx typ)) + + | "undefined_bit", _ -> + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) + + (* Optimized routines for all combinations of fixed and small bits + appends, where the result is guaranteed to be smaller than 64. *) + | "append", [AV_C_fragment (vec1, _, CT_fbits (0, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2)) as v2] + when ord1 = ord2 -> + AE_val v2 + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && n1 + n2 <= 64 -> + AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) + + | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ)) + + | "undefined_vector", [AV_C_fragment (len, _, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "sail_unsigned", [AV_C_fragment (frag, vtyp, _)] -> + begin match destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _) + when Big_int.less_equal n (Big_int.of_int 63) && is_stack_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("fast_unsigned", [frag]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "sail_signed", [AV_C_fragment (frag, vtyp, _)] -> + begin match destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> + begin match destruct_range Env.empty typ with + | None -> no_change + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) + | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) + | _ -> no_change + end + + | "neg_int", [AV_C_fragment (frag, _, _)] -> + AE_val (AV_C_fragment (F_op (v_int 0, "-", frag), typ, CT_fint 64)) + + | "replicate_bits", [AV_C_fragment (vec, vtyp, _); AV_C_fragment (times, _, _)] -> + begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true)); + AV_C_fragment (hi, _, CT_fint 64); + AV_C_fragment (lo, _, CT_fint 64); + AV_C_fragment (ys, _, CT_fbits (m, true))] -> + AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) + + | "undefined_bool", _ -> + AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) + + | _, _ -> + c_debug (lazy ("No optimization routine found")); + no_change + +let analyze_primop ctx id args typ = + let no_change = AE_app (id, args, typ) in + if !optimize_primops then + try analyze_primop' ctx id args typ with + | Failure str -> + (c_debug (lazy ("Analyze primop failed for id " ^ string_of_id id ^ " reason: " ^ str))); + no_change + else + no_change + +let generate_cleanup instrs = + let generate_cleanup' (I_aux (instr, _)) = + match instr with + | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)] + | I_decl (ctyp, id) -> [(id, iclear ctyp id)] + | instr -> [] + in + let is_clear ids = function + | I_aux (I_clear (_, id), _) -> IdSet.add id ids + | _ -> ids + in + let cleaned = List.fold_left is_clear IdSet.empty instrs in + instrs + |> List.map generate_cleanup' + |> List.concat + |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) + |> List.map snd + +(** Functions that have heap-allocated return types are implemented by + passing a pointer a location where the return value should be + stored. The ANF -> Sail IR pass for expressions simply outputs an + I_return instruction for any return value, so this function walks + over the IR ast for expressions and modifies the return statements + into code that sets that pointer, as well as adds extra control + flow to cleanup heap-allocated variables correctly when a function + terminates early. See the generate_cleanup function for how this is + done. *) +let fix_early_heap_return ret ret_ctyp instrs = + let end_function_label = label "end_function_" in + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ | I_undefined _ -> true + | _ -> false + in + let rec rewrite_return instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return instrs)] + @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + before + @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ rewrite_return after + | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after -> + before + @ [I_aux (I_funcall (CL_addr (CL_id (ret, CT_ref ctyp)), extern, fid, args), aux)] + @ rewrite_return after + | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after -> + before + @ [I_aux (I_copy (CL_addr (CL_id (ret, CT_ref ctyp)), cval), aux)] + @ rewrite_return after + | before, I_aux ((I_end | I_undefined _), _) :: after -> + before + @ [igoto end_function_label] + @ rewrite_return after + | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after -> + before @ instr :: rewrite_return after + | _, _ -> assert false + in + rewrite_return instrs + @ [ilabel end_function_label] + +(* This is like fix_early_return, but for stack allocated returns. *) +let fix_early_stack_return ret ret_ctyp instrs = + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ -> true + | _ -> false + in + let rec rewrite_return instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return instrs)] + @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + before + @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ rewrite_return after + | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after -> + before + @ [I_aux (I_funcall (CL_id (ret, ctyp), extern, fid, args), aux)] + @ rewrite_return after + | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after -> + before + @ [I_aux (I_copy (CL_id (ret, ctyp), cval), aux)] + @ rewrite_return after + | before, I_aux (I_end, _) :: after -> + before + @ [ireturn (F_id ret, ret_ctyp)] + @ rewrite_return after + | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after -> + before @ instr :: rewrite_return after + | _, _ -> assert false + in + rewrite_return instrs + +let rec insert_heap_returns ret_ctyps = function + | (CDEF_spec (id, _, ret_ctyp) as cdef) :: cdefs -> + cdef :: insert_heap_returns (Bindings.add id ret_ctyp ret_ctyps) cdefs + + | CDEF_fundef (id, None, args, body) :: cdefs -> + let gs = gensym () in + begin match Bindings.find_opt id ret_ctyps with + | None -> + raise (Reporting.err_general (id_loc id) ("Cannot find return type for function " ^ string_of_id id)) + | Some ret_ctyp when not (is_stack_ctyp ret_ctyp) -> + CDEF_fundef (id, Some gs, args, fix_early_heap_return gs ret_ctyp body) + :: insert_heap_returns ret_ctyps cdefs + | Some ret_ctyp -> + CDEF_fundef (id, None, args, fix_early_stack_return gs ret_ctyp (idecl ret_ctyp gs :: body)) + :: insert_heap_returns ret_ctyps cdefs + end + + | CDEF_fundef (id, gs, _, _) :: _ -> + raise (Reporting.err_unreachable (id_loc id) __POS__ "Found function with return already re-written in insert_heap_returns") + + | cdef :: cdefs -> + cdef :: insert_heap_returns ret_ctyps cdefs + + | [] -> [] + +(** To keep things neat we use GCC's local labels extension to limit + the scope of labels. We do this by iterating over all the blocks + and adding a __label__ declaration with all the labels local to + that block. The add_local_labels function is called by the code + generator just before it outputs C. + + See https://gcc.gnu.org/onlinedocs/gcc/Local-Labels.html **) +let add_local_labels' instrs = + let is_label (I_aux (instr, _)) = + match instr with + | I_label str -> [str] + | _ -> [] + in + let labels = List.concat (List.map is_label instrs) in + let local_label_decl = iraw ("__label__ " ^ String.concat ", " labels ^ ";\n") in + if labels = [] then + instrs + else + local_label_decl :: instrs + +let add_local_labels instrs = + match map_instrs add_local_labels' (iblock instrs) with + | I_aux (I_block instrs, _) -> instrs + | _ -> assert false + +(**************************************************************************) +(* 5. Optimizations *) +(**************************************************************************) + +let rec instrs_rename from_id to_id = + let rename id = if Id.compare id from_id = 0 then to_id else id in + let crename = cval_rename from_id to_id in + let irename instrs = instrs_rename from_id to_id instrs in + let lrename = clexp_rename from_id to_id in + function + | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs + | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs + | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs + | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs + | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs + | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> + I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs + | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs + | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs + | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs + | (I_aux ((I_comment _ | I_raw _ | I_end | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs + | [] -> [] + +let hoist_ctyp = function + | CT_lint | CT_lbits _ | CT_struct _ -> true + | _ -> false + +let hoist_counter = ref 0 +let hoist_id () = + let id = mk_id ("gh#" ^ string_of_int !hoist_counter) in + incr hoist_counter; + id + +let hoist_allocations recursive_functions = function + | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id recursive_functions -> + c_debug (lazy (Printf.sprintf "skipping recursive function %s" (string_of_id function_id))); + [cdef] + + | CDEF_fundef (function_id, heap_return, args, body) -> + let decls = ref [] in + let cleanups = ref [] in + let rec hoist = function + | I_aux (I_decl (ctyp, decl_id), annot) :: instrs when hoist_ctyp ctyp -> + let hid = hoist_id () in + decls := idecl ctyp hid :: !decls; + cleanups := iclear ctyp hid :: !cleanups; + let instrs = instrs_rename decl_id hid instrs in + I_aux (I_reset (ctyp, hid), annot) :: hoist instrs + + | I_aux (I_init (ctyp, decl_id, cval), annot) :: instrs when hoist_ctyp ctyp -> + let hid = hoist_id () in + decls := idecl ctyp hid :: !decls; + cleanups := iclear ctyp hid :: !cleanups; + let instrs = instrs_rename decl_id hid instrs in + I_aux (I_reinit (ctyp, hid, cval), annot) :: hoist instrs + + | I_aux (I_clear (ctyp, _), _) :: instrs when hoist_ctyp ctyp -> + hoist instrs + + | I_aux (I_block block, annot) :: instrs -> + I_aux (I_block (hoist block), annot) :: hoist instrs + | I_aux (I_try_block block, annot) :: instrs -> + I_aux (I_try_block (hoist block), annot) :: hoist instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), annot) :: instrs -> + I_aux (I_if (cval, hoist then_instrs, hoist else_instrs, ctyp), annot) :: hoist instrs + + | instr :: instrs -> instr :: hoist instrs + | [] -> [] + in + let body = hoist body in + if !decls = [] then + [CDEF_fundef (function_id, heap_return, args, body)] + else + [CDEF_startup (function_id, List.rev !decls); + CDEF_fundef (function_id, heap_return, args, body); + CDEF_finish (function_id, !cleanups)] + + | cdef -> [cdef] + +let flat_counter = ref 0 +let flat_id () = + let id = mk_id ("local#" ^ string_of_int !flat_counter) in + incr flat_counter; + id + +let rec flatten_instrs = function + | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> + let fid = flat_id () in + I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) + + | I_aux ((I_block block | I_try_block block), _) :: instrs -> + flatten_instrs block @ flatten_instrs instrs + + | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + let then_label = label "then_" in + let endif_label = label "endif_" in + [ijump cval then_label] + @ flatten_instrs else_instrs + @ [igoto endif_label] + @ [ilabel then_label] + @ flatten_instrs then_instrs + @ [ilabel endif_label] + @ flatten_instrs instrs + + | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs + + | instr :: instrs -> instr :: flatten_instrs instrs + | [] -> [] + +let flatten_cdef = + function + | CDEF_fundef (function_id, heap_return, args, body) -> + flat_counter := 0; + CDEF_fundef (function_id, heap_return, args, flatten_instrs body) + + | CDEF_let (n, bindings, instrs) -> + flat_counter := 0; + CDEF_let (n, bindings, flatten_instrs instrs) + + | cdef -> cdef + +let rec specialize_variants ctx prior = + let unifications = ref (Bindings.empty) in + + let fix_variant_ctyp var_id new_ctors = function + | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) + | ctyp -> ctyp + in + + let specialize_constructor ctx ctor_id ctyp = + function + | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + (* Work out how each call to a constructor in instantiated and add that to unifications *) + let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in + let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in + unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; + + (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) + let casts = + let cast_to_suprema (frag, ctyp) = + let suprema = ctyp_suprema ctyp in + if ctyp_equal ctyp suprema then + [], (unpoly frag, ctyp), [] + else + let gs = gensym () in + [idecl suprema gs; + icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], + (F_id gs, suprema), + [iclear suprema gs] + in + List.map cast_to_suprema [cval] + in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in + let cvals = List.map (fun (_, cval, _) -> cval) casts in + let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in + + let mk_funcall instr = + if List.length setup = 0 then + instr + else + iblock (setup @ [instr] @ cleanup) + in + + mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) + + | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + c_error ~loc:l "Multiple argument constructor found" + + | instr -> instr + in + + function + | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> + let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in + + let cdefs = + List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) + cdefs + polymorphic_ctors + in + + let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in + let specialized_ctors = Bindings.bindings !unifications in + let new_ctors = monomorphic_ctors @ specialized_ctors in + + let ctx = { + ctx with variants = Bindings.add var_id + (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) + ctx.variants + } in + + let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in + let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in + specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs + + | cdef :: cdefs -> + let remove_poly (I_aux (instr, aux)) = + match instr with + | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> + I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) + | instr -> I_aux (instr, aux) + in + let cdef = cdef_map_instr remove_poly cdef in + specialize_variants ctx (cdef :: prior) cdefs + + | [] -> List.rev prior, ctx + +(** Once we specialize variants, there may be additional type + dependencies which could be in the wrong order. As such we need to + sort the type definitions in the list of cdefs. *) +let sort_ctype_defs cdefs = + (* Split the cdefs into type definitions and non type definitions *) + let is_ctype_def = function CDEF_type _ -> true | _ -> false in + let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in + let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in + let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in + + let ctdef_id = function + | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id + in + + let ctdef_ids = function + | CTD_enum _ -> IdSet.empty + | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> + List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors + in + + (* Create a reverse (i.e. from types to the types that are dependent + upon them) id graph of dependencies between types *) + let module IdGraph = Graph.Make(Id) in + + let graph = + List.fold_left (fun g ctdef -> + List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) + (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) + (IdSet.elements (ctdef_ids ctdef))) + IdGraph.empty + ctype_defs + in + + (* Then select the ctypes in the correct order as given by the topsort *) + let ids = IdGraph.topsort graph in + let ctype_defs = + List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids + in + + ctype_defs @ cdefs + +let removed = icomment "REMOVED" + +let is_not_removed = function + | I_aux (I_comment "REMOVED", _) -> false + | _ -> true + +(** This optimization looks for patterns of the form: + + create x : t; + x = y; + // modifications to x, and no changes to y + y = x; + // no further changes to x + kill x; + + If found, we can remove the variable x, and directly modify y instead. *) +let remove_alias = + let pattern ctyp id = + let alias = ref None in + let rec scan ctyp id n instrs = + match n, !alias, instrs with + | 0, None, I_aux (I_copy (CL_id (id', ctyp'), (F_id a, ctyp'')), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + alias := Some a; + scan ctyp id 1 instrs + + | 1, Some a, I_aux (I_copy (CL_id (a', ctyp'), (F_id id', ctyp'')), _) :: instrs + when Id.compare a a' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan ctyp id 2 instrs + + | 1, Some a, instr :: instrs -> + if IdSet.mem a (instr_ids instr) then + None + else + scan ctyp id 1 instrs + + | 2, Some a, I_aux (I_clear (ctyp', id'), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' -> + scan ctyp id 2 instrs + + | 2, Some a, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan ctyp id 2 instrs + + | 2, Some a, [] -> !alias + + | n, _, _ :: instrs when n = 0 || n > 2 -> scan ctyp id n instrs + | _, _, I_aux (_, (_, l)) :: instrs -> raise (Reporting.err_unreachable l __POS__ "optimize_alias") + | _, _, [] -> None + in + scan ctyp id 0 + in + let remove_alias id alias = function + | I_aux (I_copy (CL_id (id', _), (F_id alias', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_copy (CL_id (alias', _), (F_id id', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_clear (_, id'), _) -> removed + | instr -> instr + in + let rec opt = function + | I_aux (I_decl (ctyp, id), _) as instr :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some alias -> + let instrs = List.map (map_instr (remove_alias id alias)) instrs in + filter_instrs is_not_removed (List.map (instr_rename id alias) instrs) + end + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, opt body)] + | cdef -> [cdef] + +(** This pass ensures that all variables created by I_decl have unique names *) +let unique_names = + let unique_counter = ref 0 in + let unique_id () = + let id = mk_id ("u#" ^ string_of_int !unique_counter) in + incr unique_counter; + id + in + + let rec opt seen = function + | I_aux (I_decl (ctyp, id), aux) :: instrs when IdSet.mem id seen -> + let id' = unique_id () in + let instrs', seen = opt seen instrs in + I_aux (I_decl (ctyp, id'), aux) :: instrs_rename id id' instrs', seen + + | I_aux (I_decl (ctyp, id), aux) :: instrs -> + let instrs', seen = opt (IdSet.add id seen) instrs in + I_aux (I_decl (ctyp, id), aux) :: instrs', seen + + | I_aux (I_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_block block', aux) :: instrs', seen + + | I_aux (I_try_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_try_block block', aux) :: instrs', seen + + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + let then_instrs', seen = opt seen then_instrs in + let else_instrs', seen = opt seen else_instrs in + let instrs', seen = opt seen instrs in + I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen + + | instr :: instrs -> + let instrs', seen = opt seen instrs in + instr :: instrs', seen + + | [] -> [], seen + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, fst (opt IdSet.empty body))] + | CDEF_reg_dec (id, ctyp, instrs) -> + [CDEF_reg_dec (id, ctyp, fst (opt IdSet.empty instrs))] + | CDEF_let (n, bindings, instrs) -> + [CDEF_let (n, bindings, fst (opt IdSet.empty instrs))] + | cdef -> [cdef] + +(** This optimization looks for patterns of the form + + create x : t; + create y : t; + // modifications to y, no changes to x + x = y; + kill y; + + If found we can replace y by x *) +let combine_variables = + let pattern ctyp id = + let combine = ref None in + let rec scan id n instrs = + match n, !combine, instrs with + | 0, None, I_aux (I_block block, _) :: instrs -> + begin match scan id 0 block with + | Some combine -> Some combine + | None -> scan id 0 instrs + end + + | 0, None, I_aux (I_decl (ctyp', id'), _) :: instrs when ctyp_equal ctyp ctyp' -> + combine := Some id'; + scan id 1 instrs + + | 1, Some c, I_aux (I_copy (CL_id (id', ctyp'), (F_id c', ctyp'')), _) :: instrs + when Id.compare c c' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan id 2 instrs + + (* Ignore seemingly early clears of x, as this can happen along exception paths *) + | 1, Some c, I_aux (I_clear (_, id'), _) :: instrs + when Id.compare id id' = 0 -> + scan id 1 instrs + + | 1, Some c, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan id 1 instrs + + | 2, Some c, I_aux (I_clear (ctyp', c'), _) :: instrs + when Id.compare c c' = 0 && ctyp_equal ctyp ctyp' -> + !combine + + | 2, Some c, instr :: instrs -> + if IdSet.mem c (instr_ids instr) then + None + else + scan id 2 instrs + + | 2, Some c, [] -> !combine + + | n, _, _ :: instrs -> scan id n instrs + | _, _, [] -> None + in + scan id 0 + in + let remove_variable id = function + | I_aux (I_decl (_, id'), _) when Id.compare id id' = 0 -> removed + | I_aux (I_clear (_, id'), _) when Id.compare id id' = 0 -> removed + | instr -> instr + in + let is_not_self_assignment = function + | I_aux (I_copy (CL_id (id, _), (F_id id', _)), _) when Id.compare id id' = 0 -> false + | _ -> true + in + let rec opt = function + | (I_aux (I_decl (ctyp, id), _) as instr) :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some combine -> + let instrs = List.map (map_instr (remove_variable combine)) instrs in + let instrs = filter_instrs (fun i -> is_not_removed i && is_not_self_assignment i) + (List.map (instr_rename combine id) instrs) in + opt (instr :: instrs) + end + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, opt body)] + | cdef -> [cdef] + +(** hoist_alias looks for patterns like + + recreate x; y = x; // no furthner mentions of x + + Provided x has a certain type, then we can make y an alias to x + (denoted in the IR as 'alias y = x'). This only works if y also has + a lifespan that also spans the entire function body. It's possible + we may need to do a more thorough lifetime evaluation to get this + to be 100% correct - so it's behind the -Oexperimental flag + for now. Some benchmarking shows that this kind of optimization + is very valuable however! *) +let hoist_alias = + (* Must return true for a subset of the types hoist_ctyp would return true for. *) + let is_struct = function + | CT_struct _ -> true + | _ -> false + in + let pattern heap_return id ctyp instrs = + let rec scan instrs = + match instrs with + (* The only thing that has a longer lifetime than id is the + function return, so we want to make sure we avoid that + case. *) + | (I_aux (I_copy (clexp, (F_id id', ctyp')), aux) as instr) :: instrs + when not (IdSet.mem heap_return (instr_writes instr)) && Id.compare id id' = 0 + && ctyp_equal (clexp_ctyp clexp) ctyp && ctyp_equal ctyp ctyp' -> + if List.exists (IdSet.mem id) (List.map instr_ids instrs) then + instr :: scan instrs + else + I_aux (I_alias (clexp, (F_id id', ctyp')), aux) :: instrs + + | instr :: instrs -> instr :: scan instrs + | [] -> [] + in + scan instrs + in + let optimize heap_return = + let rec opt = function + | (I_aux (I_reset (ctyp, id), _) as instr) :: instrs when not (is_stack_ctyp ctyp) && is_struct ctyp -> + instr :: opt (pattern heap_return id ctyp instrs) + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + opt + in + function + | CDEF_fundef (function_id, Some heap_return, args, body) -> + [CDEF_fundef (function_id, Some heap_return, args, optimize heap_return body)] + | cdef -> [cdef] + +let concatMap f xs = List.concat (List.map f xs) + +let optimize recursive_functions cdefs = + let nothing cdefs = cdefs in + cdefs + |> (if !optimize_alias then concatMap unique_names else nothing) + |> (if !optimize_alias then concatMap remove_alias else nothing) + |> (if !optimize_alias then concatMap combine_variables else nothing) + (* We need the runtime to initialize hoisted allocations *) + |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations recursive_functions) else nothing) + |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap hoist_alias else nothing) + +(**************************************************************************) +(* 6. Code generation *) +(**************************************************************************) + +let sgen_id id = Util.zencode_string (string_of_id id) +let codegen_id id = string (sgen_id id) + +let sgen_function_id id = + let str = Util.zencode_string (string_of_id id) in + !opt_prefix ^ String.sub str 1 (String.length str - 1) + +let codegen_function_id id = string (sgen_function_id id) + +let rec sgen_ctyp = function + | CT_unit -> "unit" + | CT_bit -> "fbits" + | CT_bool -> "bool" + | CT_fbits _ -> "fbits" + | CT_sbits _ -> "sbits" + | CT_fint _ -> "mach_int" + | CT_lint -> "sail_int" + | CT_lbits _ -> "lbits" + | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) + | CT_struct (id, _) -> "struct " ^ sgen_id id + | CT_enum (id, _) -> "enum " ^ sgen_id id + | CT_variant (id, _) -> "struct " ^ sgen_id id + | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) + | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_string -> "sail_string" + | CT_real -> "real" + | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" + | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) + +let rec sgen_ctyp_name = function + | CT_unit -> "unit" + | CT_bit -> "fbits" + | CT_bool -> "bool" + | CT_fbits _ -> "fbits" + | CT_sbits _ -> "sbits" + | CT_fint _ -> "mach_int" + | CT_lint -> "sail_int" + | CT_lbits _ -> "lbits" + | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) + | CT_struct (id, _) -> sgen_id id + | CT_enum (id, _) -> sgen_id id + | CT_variant (id, _) -> sgen_id id + | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) + | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_string -> "sail_string" + | CT_real -> "real" + | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp + | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) + +let sgen_cval_param (frag, ctyp) = + match ctyp with + | CT_lbits direction -> + string_of_fragment frag ^ ", " ^ string_of_bool direction + | CT_sbits (_, direction) -> + string_of_fragment frag ^ ", " ^ string_of_bool direction + | CT_fbits (len, direction) -> + string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction + | _ -> + string_of_fragment frag + +let sgen_cval = function (frag, _) -> string_of_fragment frag + +let rec sgen_clexp = function + | CL_id (id, _) -> "&" ^ sgen_id id + | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ Util.zencode_string field ^ ")" + | CL_tuple (clexp, n) -> "&((" ^ sgen_clexp clexp ^ ")->ztup" ^ string_of_int n ^ ")" + | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))" + | CL_have_exception -> "have_exception" + | CL_current_exception _ -> "current_exception" + | CL_return _ -> assert false + +let rec sgen_clexp_pure = function + | CL_id (id, _) -> sgen_id id + | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ Util.zencode_string field + | CL_tuple (clexp, n) -> sgen_clexp_pure clexp ^ ".ztup" ^ string_of_int n + | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))" + | CL_have_exception -> "have_exception" + | CL_current_exception _ -> "current_exception" + | CL_return _ -> assert false + +(** Generate instructions to copy from a cval to a clexp. This will + insert any needed type conversions from big integers to small + integers (or vice versa), or from arbitrary-length bitvectors to + and from uint64 bitvectors as needed. *) +let rec codegen_conversion l clexp cval = + let open Printf in + let ctyp_to = clexp_ctyp clexp in + let ctyp_from = cval_ctyp cval in + match ctyp_to, ctyp_from with + (* When both types are equal, we don't need any conversion. *) + | _, _ when ctyp_equal ctyp_to ctyp_from -> + if is_stack_ctyp ctyp_to then + ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) + else + ksprintf string " COPY(%s)(%s, %s);" (sgen_ctyp_name ctyp_to) (sgen_clexp clexp) (sgen_cval cval) + + | CT_ref ctyp_to, ctyp_from -> + codegen_conversion l (CL_addr clexp) cval + + (* If we have to convert between tuple types, convert the fields individually. *) + | CT_tup ctyps_to, CT_tup ctyps_from when List.length ctyps_to = List.length ctyps_from -> + let conversions = + List.mapi (fun i ctyp -> codegen_conversion l (CL_tuple (clexp, i)) (F_field (fst cval, "ztup" ^ string_of_int i), ctyp)) ctyps_from + in + string " /* conversions */" + ^^ hardline + ^^ separate hardline conversions + ^^ hardline + ^^ string " /* end conversions */" + + (* For anything not special cased, just try to call a appropriate CONVERT_OF function. *) + | _, _ when is_stack_ctyp (clexp_ctyp clexp) -> + ksprintf string " %s = CONVERT_OF(%s, %s)(%s);" + (sgen_clexp_pure clexp) (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_cval_param cval) + | _, _ -> + ksprintf string " CONVERT_OF(%s, %s)(%s, %s);" + (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_clexp clexp) (sgen_cval_param cval) + +let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = + let open Printf in + match instr with + | I_decl (ctyp, id) when is_stack_ctyp ctyp -> + ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) + | I_decl (ctyp, id) -> + ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline + ^^ ksprintf string " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) + + | I_copy (clexp, cval) -> codegen_conversion l clexp cval + + | I_alias (clexp, cval) -> + ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) + + | I_jump (cval, label) -> + ksprintf string " if (%s) goto %s;" (sgen_cval cval) label + + | I_if (cval, [then_instr], [], ctyp) -> + ksprintf string " if (%s)" (sgen_cval cval) ^^ hardline + ^^ twice space ^^ codegen_instr fid ctx then_instr + | I_if (cval, then_instrs, [], ctyp) -> + string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + | I_if (cval, then_instrs, else_instrs, ctyp) -> + string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + ^^ space ^^ string "else" ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) + + | I_block instrs -> + string " {" + ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline + ^^ string " }" + + | I_try_block instrs -> + string " { /* try */" + ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline + ^^ string " }" + + | I_funcall (x, extern, f, args) -> + let c_args = Util.string_of_list ", " sgen_cval args in + let ctyp = clexp_ctyp x in + let is_extern = Env.is_extern f ctx.tc_env "c" || extern in + let fname = + if Env.is_extern f ctx.tc_env "c" then + Env.get_extern f ctx.tc_env "c" + else if extern then + string_of_id f + else + sgen_function_id f + in + let fname = + match fname, ctyp with + | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) + | "eq_anything", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "eq_anything function with bad arity." + end + | "length", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "length_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "length function with bad arity." + end + | "vector_access", CT_bit -> "bitvector_access" + | "vector_access", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "vector_access_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "vector access function with bad arity." + end + | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) + | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) + | "vector_update", CT_fbits _ -> "update_fbits" + | "vector_update", CT_lbits _ -> "update_lbits" + | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) + | "string_of_bits", _ -> + begin match cval_ctyp (List.nth args 0) with + | CT_fbits _ -> "string_of_fbits" + | CT_lbits _ -> "string_of_lbits" + | _ -> assert false + end + | "decimal_string_of_bits", _ -> + begin match cval_ctyp (List.nth args 0) with + | CT_fbits _ -> "decimal_string_of_fbits" + | CT_lbits _ -> "decimal_string_of_lbits" + | _ -> assert false + end + | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) + | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) + | "undefined_vector", CT_fbits _ -> "UNDEFINED(fbits)" + | "undefined_vector", CT_lbits _ -> "UNDEFINED(lbits)" + | "undefined_bit", _ -> "UNDEFINED(fbits)" + | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) + | fname, _ -> fname + in + if fname = "sail_assert" && !optimize_experimental then + empty + else if fname = "reg_deref" then + if is_stack_ctyp ctyp then + string (Printf.sprintf " %s = *(%s);" (sgen_clexp_pure x) c_args) + else + string (Printf.sprintf " COPY(%s)(&%s, *(%s));" (sgen_ctyp_name ctyp) (sgen_clexp_pure x) c_args) + else + if is_stack_ctyp ctyp then + string (Printf.sprintf " %s = %s(%s%s);" (sgen_clexp_pure x) fname (extra_arguments is_extern) c_args) + else + string (Printf.sprintf " %s(%s%s, %s);" fname (extra_arguments is_extern) (sgen_clexp x) c_args) + + | I_clear (ctyp, id) when is_stack_ctyp ctyp -> + empty + | I_clear (ctyp, id) -> + string (Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + + | I_init (ctyp, id, cval) -> + codegen_instr fid ctx (idecl ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval + + | I_reinit (ctyp, id, cval) -> + codegen_instr fid ctx (ireset ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval + + | I_reset (ctyp, id) when is_stack_ctyp ctyp -> + string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_id id)) + | I_reset (ctyp, id) -> + string (Printf.sprintf " RECREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + + | I_return cval -> + string (Printf.sprintf " return %s;" (sgen_cval cval)) + + | I_throw cval -> + c_error ~loc:l "I_throw reached code generator" + + | I_undefined ctyp -> + let rec codegen_exn_return ctyp = + match ctyp with + | CT_unit -> "UNIT", [] + | CT_bit -> "UINT64_C(0)", [] + | CT_fint _ -> "INT64_C(0xdeadc0de)", [] + | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] + | CT_sbits _ -> "undefined_sbits()", [] + | CT_bool -> "false", [] + | CT_enum (_, ctor :: _) -> sgen_id ctor, [] + | CT_tup ctyps when is_stack_ctyp ctyp -> + let gs = gensym () in + let fold (inits, prev) (n, ctyp) = + let init, prev' = codegen_exn_return ctyp in + Printf.sprintf ".ztup%d = %s" n init :: inits, prev @ prev' + in + let inits, prev = List.fold_left fold ([], []) (List.mapi (fun i x -> (i, x)) ctyps) in + sgen_id gs, + [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) + ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev + | CT_struct (id, ctors) when is_stack_ctyp ctyp -> + let gs = gensym () in + let fold (inits, prev) (id, ctyp) = + let init, prev' = codegen_exn_return ctyp in + Printf.sprintf ".%s = %s" (sgen_id id) init :: inits, prev @ prev' + in + let inits, prev = List.fold_left fold ([], []) ctors in + sgen_id gs, + [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) + ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev + | ctyp -> c_error ("Cannot create undefined value for type: " ^ string_of_ctyp ctyp) + in + let ret, prev = codegen_exn_return ctyp in + separate_map hardline (fun str -> string (" " ^ str)) (List.rev prev) + ^^ hardline + ^^ string (Printf.sprintf " return %s;" ret) + + | I_comment str -> + string (" /* " ^ str ^ " */") + + | I_label str -> + string (str ^ ": ;") + + | I_goto str -> + string (Printf.sprintf " goto %s;" str) + + | I_raw _ when ctx.no_raw -> empty + | I_raw str -> + string (" " ^ str) + + | I_end -> assert false + + | I_match_failure -> + string (" sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");") + +let codegen_type_def ctx = function + | CTD_enum (id, ((first_id :: _) as ids)) -> + let codegen_eq = + let name = sgen_id id in + string (Printf.sprintf "static bool eq_%s(enum %s op1, enum %s op2) { return op1 == op2; }" name name name) + in + let codegen_undefined = + let name = sgen_id id in + string (Printf.sprintf "enum %s UNDEFINED(%s)(unit u) { return %s; }" name name (sgen_id first_id)) + in + string (Printf.sprintf "// enum %s" (string_of_id id)) ^^ hardline + ^^ separate space [string "enum"; codegen_id id; lbrace; separate_map (comma ^^ space) codegen_id ids; rbrace ^^ semi] + ^^ twice hardline + ^^ codegen_eq + ^^ twice hardline + ^^ codegen_undefined + + | CTD_enum (id, []) -> c_error ("Cannot compile empty enum " ^ string_of_id id) + + | CTD_struct (id, ctors) -> + let struct_ctyp = CT_struct (id, ctors) in + c_debug (lazy (Printf.sprintf "Generating struct for %s" (full_string_of_ctyp struct_ctyp))); + + (* Generate a set_T function for every struct T *) + let codegen_set (id, ctyp) = + if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op.%s;" (sgen_id id) (sgen_id id)) + else + string (Printf.sprintf "COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) + in + let codegen_setter id ctors = + string (let n = sgen_id id in Printf.sprintf "static void COPY(%s)(struct %s *rop, const struct %s op)" n n n) ^^ space + ^^ surround 2 0 lbrace + (separate_map hardline codegen_set (Bindings.bindings ctors)) + rbrace + in + (* Generate an init/clear_T function for every struct T *) + let codegen_field_init f (id, ctyp) = + if not (is_stack_ctyp ctyp) then + [string (Printf.sprintf "%s(%s)(&op->%s);" f (sgen_ctyp_name ctyp) (sgen_id id))] + else [] + in + let codegen_init f id ctors = + string (let n = sgen_id id in Printf.sprintf "static void %s(%s)(struct %s *op)" f n n) ^^ space + ^^ surround 2 0 lbrace + (separate hardline (Bindings.bindings ctors |> List.map (codegen_field_init f) |> List.concat)) + rbrace + in + let codegen_eq = + let codegen_eq_test (id, ctyp) = + string (Printf.sprintf "EQUAL(%s)(op1.%s, op2.%s)" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) + in + string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2)" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ space + ^^ surround 2 0 lbrace + (string "return" ^^ space + ^^ separate_map (string " && ") codegen_eq_test ctors + ^^ string ";") + rbrace + in + (* Generate the struct and add the generated functions *) + let codegen_ctor (id, ctyp) = + string (sgen_ctyp ctyp) ^^ space ^^ codegen_id id + in + string (Printf.sprintf "// struct %s" (string_of_id id)) ^^ hardline + ^^ string "struct" ^^ space ^^ codegen_id id ^^ space + ^^ surround 2 0 lbrace + (separate_map (semi ^^ hardline) codegen_ctor ctors ^^ semi) + rbrace + ^^ semi ^^ twice hardline + ^^ codegen_setter id (ctor_bindings ctors) + ^^ (if not (is_stack_ctyp struct_ctyp) then + twice hardline + ^^ codegen_init "CREATE" id (ctor_bindings ctors) + ^^ twice hardline + ^^ codegen_init "RECREATE" id (ctor_bindings ctors) + ^^ twice hardline + ^^ codegen_init "KILL" id (ctor_bindings ctors) + else empty) + ^^ twice hardline + ^^ codegen_eq + + | CTD_variant (id, tus) -> + let codegen_tu (ctor_id, ctyp) = + separate space [string "struct"; lbrace; string (sgen_ctyp ctyp); codegen_id ctor_id ^^ semi; rbrace] + in + (* Create an if, else if, ... block that does something for each constructor *) + let rec each_ctor v f = function + | [] -> string "{}" + | [(ctor_id, ctyp)] -> + string (Printf.sprintf "if (%skind == Kind_%s)" v (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (f ctor_id ctyp) + ^^ hardline ^^ rbrace + | (ctor_id, ctyp) :: ctors -> + string (Printf.sprintf "if (%skind == Kind_%s) " v (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (f ctor_id ctyp) + ^^ hardline ^^ rbrace ^^ string " else " ^^ each_ctor v f ctors + in + let codegen_init = + let n = sgen_id id in + let ctor_id, ctyp = List.hd tus in + string (Printf.sprintf "static void CREATE(%s)(struct %s *op)" n n) + ^^ hardline + ^^ surround 2 0 lbrace + (string (Printf.sprintf "op->kind = Kind_%s;" (sgen_id ctor_id)) ^^ hardline + ^^ if not (is_stack_ctyp ctyp) then + string (Printf.sprintf "CREATE(%s)(&op->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) + else empty) + rbrace + in + let codegen_reinit = + let n = sgen_id id in + string (Printf.sprintf "static void RECREATE(%s)(struct %s *op) {}" n n) + in + let clear_field v ctor_id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "/* do nothing */") + else + string (Printf.sprintf "KILL(%s)(&%s->%s);" (sgen_ctyp_name ctyp) v (sgen_id ctor_id)) + in + let codegen_clear = + let n = sgen_id id in + string (Printf.sprintf "static void KILL(%s)(struct %s *op)" n n) ^^ hardline + ^^ surround 2 0 lbrace + (each_ctor "op->" (clear_field "op") tus ^^ semi) + rbrace + in + let codegen_ctor (ctor_id, ctyp) = + let ctor_args, tuple, tuple_cleanup = + let tuple_set i ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "op.ztup%d = op%d;" i i) + else + string (Printf.sprintf "COPY(%s)(&op.ztup%d, op%d);" (sgen_ctyp_name ctyp) i i) + in + Printf.sprintf "%s op" (sgen_ctyp ctyp), empty, empty + in + string (Printf.sprintf "static void %s(%sstruct %s *rop, %s)" (sgen_function_id ctor_id) (extra_params ()) (sgen_id id) ctor_args) ^^ hardline + ^^ surround 2 0 lbrace + (tuple + ^^ each_ctor "rop->" (clear_field "rop") tus ^^ hardline + ^^ string ("rop->kind = Kind_" ^ sgen_id ctor_id) ^^ semi ^^ hardline + ^^ if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op;" (sgen_id ctor_id)) + else + string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline + ^^ string (Printf.sprintf "COPY(%s)(&rop->%s, op);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline + ^^ tuple_cleanup) + rbrace + in + let codegen_setter = + let n = sgen_id id in + let set_field ctor_id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op.%s;" (sgen_id ctor_id) (sgen_id ctor_id)) + else + string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) + ^^ string (Printf.sprintf " COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) + in + string (Printf.sprintf "static void COPY(%s)(struct %s *rop, struct %s op)" n n n) ^^ hardline + ^^ surround 2 0 lbrace + (each_ctor "rop->" (clear_field "rop") tus + ^^ semi ^^ hardline + ^^ string "rop->kind = op.kind" + ^^ semi ^^ hardline + ^^ each_ctor "op." set_field tus) + rbrace + in + let codegen_eq = + let codegen_eq_test ctor_id ctyp = + string (Printf.sprintf "return EQUAL(%s)(op1.%s, op2.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) + in + let rec codegen_eq_tests = function + | [] -> string "return false;" + | (ctor_id, ctyp) :: ctors -> + string (Printf.sprintf "if (op1.kind == Kind_%s && op2.kind == Kind_%s) " (sgen_id ctor_id) (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (codegen_eq_test ctor_id ctyp) + ^^ hardline ^^ rbrace ^^ string " else " ^^ codegen_eq_tests ctors + in + let n = sgen_id id in + string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2) " n n n) + ^^ surround 2 0 lbrace (codegen_eq_tests tus) rbrace + in + string (Printf.sprintf "// union %s" (string_of_id id)) ^^ hardline + ^^ string "enum" ^^ space + ^^ string ("kind_" ^ sgen_id id) ^^ space + ^^ separate space [ lbrace; + separate_map (comma ^^ space) (fun id -> string ("Kind_" ^ sgen_id id)) (List.map fst tus); + rbrace ^^ semi ] + ^^ twice hardline + ^^ string "struct" ^^ space ^^ codegen_id id ^^ space + ^^ surround 2 0 lbrace + (separate space [string "enum"; string ("kind_" ^ sgen_id id); string "kind" ^^ semi] + ^^ hardline + ^^ string "union" ^^ space + ^^ surround 2 0 lbrace + (separate_map (semi ^^ hardline) codegen_tu tus ^^ semi) + rbrace + ^^ semi) + rbrace + ^^ semi + ^^ twice hardline + ^^ codegen_init + ^^ twice hardline + ^^ codegen_reinit + ^^ twice hardline + ^^ codegen_clear + ^^ twice hardline + ^^ codegen_setter + ^^ twice hardline + ^^ codegen_eq + ^^ twice hardline + ^^ separate_map (twice hardline) codegen_ctor tus + (* If this is the exception type, then we setup up some global variables to deal with exceptions. *) + ^^ if string_of_id id = "exception" then + twice hardline + ^^ string "struct zexception *current_exception = NULL;" + ^^ hardline + ^^ string "bool have_exception = false;" + else + empty + +(** GLOBAL: because C doesn't have real anonymous tuple types + (anonymous structs don't quite work the way we need) every tuple + type in the spec becomes some generated named struct in C. This is + done in such a way that every possible tuple type has a unique name + associated with it. This global variable keeps track of these + generated struct names, so we never generate two copies of the + struct that is used to represent them in C. + + The way this works is that codegen_def scans each definition's type + annotations for tuple types and generates the required structs + using codegen_type_def before the actual definition is generated by + codegen_def'. + + This variable should be reset to empty only when the entire AST has + been translated to C. **) +let generated = ref IdSet.empty + +let codegen_tup ctx ctyps = + let id = mk_id ("tuple_" ^ string_of_ctyp (CT_tup ctyps)) in + if IdSet.mem id !generated then + empty + else + begin + let _, fields = List.fold_left (fun (n, fields) ctyp -> n + 1, Bindings.add (mk_id ("tup" ^ string_of_int n)) ctyp fields) + (0, Bindings.empty) + ctyps + in + generated := IdSet.add id !generated; + codegen_type_def ctx (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline + end + +let codegen_node id ctyp = + string (Printf.sprintf "struct node_%s {\n %s hd;\n struct node_%s *tl;\n};\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string (Printf.sprintf "typedef struct node_%s *%s;" (sgen_id id) (sgen_id id)) + +let codegen_list_init id = + string (Printf.sprintf "static void CREATE(%s)(%s *rop) { *rop = NULL; }" (sgen_id id) (sgen_id id)) + +let codegen_list_clear id ctyp = + string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " if (*rop == NULL) return;") + ^^ (if is_stack_ctyp ctyp then empty + else string (Printf.sprintf " KILL(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp))) + ^^ string (Printf.sprintf " KILL(%s)(&(*rop)->tl);\n" (sgen_id id)) + ^^ string " free(*rop);" + ^^ string "}" + +let codegen_list_set id ctyp = + string (Printf.sprintf "static void internal_set_%s(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string " if (op == NULL) { *rop = NULL; return; };\n" + ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then + string " (*rop)->hd = op->hd;\n" + else + string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) + ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, op->hd);\n" (sgen_ctyp_name ctyp))) + ^^ string (Printf.sprintf " internal_set_%s(&(*rop)->tl, op->tl);\n" (sgen_id id)) + ^^ string "}" + ^^ twice hardline + ^^ string (Printf.sprintf "static void COPY(%s)(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) + ^^ string (Printf.sprintf " internal_set_%s(rop, op);\n" (sgen_id id)) + ^^ string "}" + +let codegen_cons id ctyp = + let cons_id = mk_id ("cons#" ^ string_of_ctyp ctyp) in + string (Printf.sprintf "static void %s(%s *rop, const %s x, const %s xs) {\n" (sgen_function_id cons_id) (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then + string " (*rop)->hd = x;\n" + else + string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) + ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, x);\n" (sgen_ctyp_name ctyp))) + ^^ string " (*rop)->tl = xs;\n" + ^^ string "}" + +let codegen_pick id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "static %s pick_%s(const %s xs) { return xs->hd; }" (sgen_ctyp ctyp) (sgen_ctyp_name ctyp) (sgen_id id)) + else + string (Printf.sprintf "static void pick_%s(%s *x, const %s xs) { COPY(%s)(x, xs->hd); }" (sgen_ctyp_name ctyp) (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp)) + +let codegen_list ctx ctyp = + let id = mk_id (string_of_ctyp (CT_list ctyp)) in + if IdSet.mem id !generated then + empty + else + begin + generated := IdSet.add id !generated; + codegen_node id ctyp ^^ twice hardline + ^^ codegen_list_init id ^^ twice hardline + ^^ codegen_list_clear id ctyp ^^ twice hardline + ^^ codegen_list_set id ctyp ^^ twice hardline + ^^ codegen_cons id ctyp ^^ twice hardline + ^^ codegen_pick id ctyp ^^ twice hardline + end + +(* Generate functions for working with non-bit vectors of some specific type. *) +let codegen_vector ctx (direction, ctyp) = + let id = mk_id (string_of_ctyp (CT_vector (direction, ctyp))) in + if IdSet.mem id !generated then + empty + else + let vector_typedef = + string (Printf.sprintf "struct %s {\n size_t len;\n %s *data;\n};\n" (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (Printf.sprintf "typedef struct %s %s;" (sgen_id id) (sgen_id id)) + in + let vector_init = + string (Printf.sprintf "static void CREATE(%s)(%s *rop) {\n rop->len = 0;\n rop->data = NULL;\n}" (sgen_id id) (sgen_id id)) + in + let vector_set = + string (Printf.sprintf "static void COPY(%s)(%s *rop, %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) + ^^ string " rop->len = op.len;\n" + ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ string " for (int i = 0; i < op.len; i++) {\n" + ^^ string (if is_stack_ctyp ctyp then + " (rop->data)[i] = op.data[i];\n" + else + Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, op.data[i]);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + let vector_clear = + string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then empty + else + string " for (int i = 0; i < (rop->len); i++) {\n" + ^^ string (Printf.sprintf " KILL(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n") + ^^ string " if (rop->data != NULL) free(rop->data);\n" + ^^ string "}" + in + let vector_update = + string (Printf.sprintf "static void vector_update_%s(%s *rop, %s op, mpz_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string " if (rop->data == op.data) {\n" + ^^ string (if is_stack_ctyp ctyp then + " rop->data[m] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string " } else {\n" + ^^ string (Printf.sprintf " COPY(%s)(rop, op);\n" (sgen_id id)) + ^^ string (if is_stack_ctyp ctyp then + " rop->data[m] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + let internal_vector_update = + string (Printf.sprintf "static void internal_vector_update_%s(%s *rop, %s op, const int64_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (if is_stack_ctyp ctyp then + " rop->data[n] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + n, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string "}" + in + let vector_access = + if is_stack_ctyp ctyp then + string (Printf.sprintf "static %s vector_access_%s(%s op, mpz_t n) {\n" (sgen_ctyp ctyp) (sgen_id id) (sgen_id id)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string " return op.data[m];\n" + ^^ string "}" + else + string (Printf.sprintf "static void vector_access_%s(%s *rop, %s op, mpz_t n) {\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string (Printf.sprintf " COPY(%s)(rop, op.data[m]);\n" (sgen_ctyp_name ctyp)) + ^^ string "}" + in + let internal_vector_init = + string (Printf.sprintf "static void internal_vector_init_%s(%s *rop, const int64_t len) {\n" (sgen_id id) (sgen_id id)) + ^^ string " rop->len = len;\n" + ^^ string (Printf.sprintf " rop->data = malloc(len * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ (if not (is_stack_ctyp ctyp) then + string " for (int i = 0; i < len; i++) {\n" + ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n" + else empty) + ^^ string "}" + in + let vector_undefined = + string (Printf.sprintf "static void undefined_vector_%s(%s *rop, mpz_t len, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (Printf.sprintf " rop->len = mpz_get_ui(len);\n") + ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ string " for (int i = 0; i < (rop->len); i++) {\n" + ^^ string (if is_stack_ctyp ctyp then + " (rop->data)[i] = elem;\n" + else + Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, elem);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + begin + generated := IdSet.add id !generated; + vector_typedef ^^ twice hardline + ^^ vector_init ^^ twice hardline + ^^ vector_clear ^^ twice hardline + ^^ vector_undefined ^^ twice hardline + ^^ vector_access ^^ twice hardline + ^^ vector_set ^^ twice hardline + ^^ vector_update ^^ twice hardline + ^^ internal_vector_update ^^ twice hardline + ^^ internal_vector_init ^^ twice hardline + end + +let is_decl = function + | I_aux (I_decl _, _) -> true + | _ -> false + +let codegen_decl = function + | I_aux (I_decl (ctyp, id), _) -> + string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) + | _ -> assert false + +let codegen_alloc = function + | I_aux (I_decl (ctyp, id), _) when is_stack_ctyp ctyp -> empty + | I_aux (I_decl (ctyp, id), _) -> + string (Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + | _ -> assert false + +let codegen_def' ctx = function + | CDEF_reg_dec (id, ctyp, _) -> + string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline + ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) + + | CDEF_spec (id, arg_ctyps, ret_ctyp) -> + let static = if !opt_static then "static " else "" in + if Env.is_extern id ctx.tc_env "c" then + empty + else if is_stack_ctyp ret_ctyp then + string (Printf.sprintf "%s%s %s(%s%s);" static (sgen_ctyp ret_ctyp) (sgen_function_id id) (extra_params ()) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) + else + string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) + + | CDEF_fundef (id, ret_arg, args, instrs) as def -> + if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); + + (* Extract type information about the function from the environment. *) + let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + + (* Check that the function has the correct arity at this point. *) + if List.length arg_ctyps <> List.length args then + c_error ~loc:(id_loc id) ("function arguments " + ^ Util.string_of_list ", " string_of_id args + ^ " matched against type " + ^ Util.string_of_list ", " string_of_ctyp arg_ctyps) + else (); + + let instrs = add_local_labels instrs in + let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in + let function_header = + match ret_arg with + | None -> + assert (is_stack_ctyp ret_ctyp); + (if !opt_static then string "static " else empty) + ^^ string (sgen_ctyp ret_ctyp) ^^ space ^^ codegen_function_id id ^^ parens (string (extra_params ()) ^^ string args) ^^ hardline + | Some gs -> + assert (not (is_stack_ctyp ret_ctyp)); + (if !opt_static then string "static " else empty) + ^^ string "void" ^^ space ^^ codegen_function_id id + ^^ parens (string (extra_params ()) ^^ string (sgen_ctyp ret_ctyp ^ " *" ^ sgen_id gs ^ ", ") ^^ string args) + ^^ hardline + in + function_header + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline + ^^ string "}" + + | CDEF_type ctype_def -> + codegen_type_def ctx ctype_def + + | CDEF_startup (id, instrs) -> + let static = if !opt_static then "static " else "" in + let startup_header = string (Printf.sprintf "%svoid startup_%s(void)" static (sgen_function_id id)) in + separate_map hardline codegen_decl instrs + ^^ twice hardline + ^^ startup_header ^^ hardline + ^^ string "{" + ^^ jump 0 2 (separate_map hardline codegen_alloc instrs) ^^ hardline + ^^ string "}" + + | CDEF_finish (id, instrs) -> + let static = if !opt_static then "static " else "" in + let finish_header = string (Printf.sprintf "%svoid finish_%s(void)" static (sgen_function_id id)) in + separate_map hardline codegen_decl (List.filter is_decl instrs) + ^^ twice hardline + ^^ finish_header ^^ hardline + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline + ^^ string "}" + + | CDEF_let (number, bindings, instrs) -> + let instrs = add_local_labels instrs in + let setup = + List.concat (List.map (fun (id, ctyp) -> [idecl ctyp id]) bindings) + in + let cleanup = + List.concat (List.map (fun (id, ctyp) -> [iclear ctyp id]) bindings) + in + separate_map hardline (fun (id, ctyp) -> string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id))) bindings + ^^ hardline ^^ string (Printf.sprintf "static void create_letbind_%d(void) " number) + ^^ string "{" + ^^ jump 0 2 (separate_map hardline codegen_alloc setup) ^^ hardline + ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") { ctx with no_raw = true }) instrs) ^^ hardline + ^^ string "}" + ^^ hardline ^^ string (Printf.sprintf "static void kill_letbind_%d(void) " number) + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") ctx) cleanup) ^^ hardline + ^^ string "}" + +(** As we generate C we need to generate specialized version of tuple, + list, and vector type. These must be generated in the correct + order. The ctyp_dependencies function generates a list of + c_gen_typs in the order they must be generated. Types may be + repeated in ctyp_dependencies so it's up to the code-generator not + to repeat definitions pointlessly (using the !generated variable) + *) +type c_gen_typ = + | CTG_tup of ctyp list + | CTG_list of ctyp + | CTG_vector of bool * ctyp + +let rec ctyp_dependencies = function + | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] + | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] + | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] + | CT_ref ctyp -> ctyp_dependencies ctyp + | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) + | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] + +let codegen_ctg ctx = function + | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp) + | CTG_tup ctyps -> codegen_tup ctx ctyps + | CTG_list ctyp -> codegen_list ctx ctyp + +(** When we generate code for a definition, we need to first generate + any auxillary type definitions that are required. *) +let codegen_def ctx def = + let ctyps = cdef_ctyps def |> CTSet.elements in + (* We should have erased any polymorphism introduced by variants at this point! *) + if List.exists is_polymorphic ctyps then + let polymorphic_ctyps = List.filter is_polymorphic ctyps in + prerr_endline (Pretty_print_sail.to_string (pp_cdef def)); + c_error (Printf.sprintf "Found polymorphic types:\n%s\nwhile generating definition." + (Util.string_of_list "\n" string_of_ctyp polymorphic_ctyps)) + else + let deps = List.concat (List.map ctyp_dependencies ctyps) in + separate_map hardline (codegen_ctg ctx) deps + ^^ codegen_def' ctx def + +let is_cdef_startup = function + | CDEF_startup _ -> true + | _ -> false + +let sgen_startup = function + | CDEF_startup (id, _) -> + Printf.sprintf " startup_%s();" (sgen_id id) + | _ -> assert false + +let sgen_instr id ctx instr = + Pretty_print_sail.to_string (codegen_instr id ctx instr) + +let is_cdef_finish = function + | CDEF_startup _ -> true + | _ -> false + +let sgen_finish = function + | CDEF_startup (id, _) -> + Printf.sprintf " finish_%s();" (sgen_id id) + | _ -> assert false + +let instrument_tracing ctx = + let module StringSet = Set.Make(String) in + let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in + let rec instrument = function + | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> + let trace_start = + iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id))) + in + let trace_arg cval = + let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in + if StringSet.mem ctyp_name traceable then + iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval)) + else + iraw "trace_unknown();" + in + let rec trace_args = function + | [] -> [] + | [cval] -> [trace_arg cval] + | cval :: cvals -> + trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals + in + let trace_end = iraw "trace_end();" in + let trace_ret = iraw "trace_unknown();" + (* + let ctyp_name = sgen_ctyp_name ctyp in + if StringSet.mem ctyp_name traceable then + iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) + else + iraw "trace_unknown();" + *) + in + [trace_start] + @ trace_args args + @ [iraw "trace_argend();"; + instr; + trace_end; + trace_ret; + iraw "trace_retend();"] + @ instrument instrs + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs + + | instr :: instrs -> instr :: instrument instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + CDEF_fundef (function_id, heap_return, args, instrument body) + | cdef -> cdef + +let rec get_recursive_functions (Defs defs) = + match defs with + | DEF_internal_mutrec fundefs :: defs -> + IdSet.union (List.map id_of_fundef fundefs |> IdSet.of_list) (get_recursive_functions (Defs defs)) + + | (DEF_fundef fdef as def) :: defs -> + let open Rewriter in + let ids = ref IdSet.empty in + let collect_funcalls e_aux annot = + match e_aux with + | E_app (id, args) -> (ids := IdSet.add id !ids; E_aux (e_aux, annot)) + | _ -> E_aux (e_aux, annot) + in + let map_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> collect_funcalls e_aux annot) + } in + let map_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp map_exp) } in + let _ = rewrite_def map_defs def in + if IdSet.mem (id_of_fundef fdef) !ids then + IdSet.add (id_of_fundef fdef) (get_recursive_functions (Defs defs)) + else + get_recursive_functions (Defs defs) + + | _ :: defs -> get_recursive_functions (Defs defs) + | [] -> IdSet.empty + +let jib_of_ast env ast = + let ctx = + initial_ctx + ~convert_typ:ctyp_of_typ + ~optimize_anf:(fun ctx aexp -> analyze_functions ctx analyze_primop (c_literals ctx aexp)) + env + in + Jib_compile.compile_ast ctx ast + +let compile_ast env output_chan c_includes ast = + try + c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions")); + let recursive_functions = Spec_analysis.top_sort_defs ast |> get_recursive_functions in + + let cdefs, ctx = jib_of_ast env ast in + let cdefs = insert_heap_returns Bindings.empty cdefs in + let cdefs = optimize recursive_functions cdefs in + + let docs = separate_map (hardline ^^ hardline) (codegen_def ctx) cdefs in + + let preamble = separate hardline + ([ string "#include \"sail.h\"" ] + @ (if !opt_no_rts then [] else + [ string "#include \"rts.h\""; + string "#include \"elf.h\"" ]) + @ (List.map (fun h -> string (Printf.sprintf "#include \"%s\"" h)) c_includes)) + in + + let exn_boilerplate = + if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else + ([ " current_exception = malloc(sizeof(struct zexception));"; + " CREATE(zexception)(current_exception);" ], + [ " KILL(zexception)(current_exception);"; + " free(current_exception);"; + " if (have_exception) fprintf(stderr, \"Exiting due to uncaught exception\\n\");" ]) + in + + let letbind_initializers = + List.map (fun n -> Printf.sprintf " create_letbind_%d();" n) (List.rev ctx.letbinds) + in + let letbind_finalizers = + List.map (fun n -> Printf.sprintf " kill_letbind_%d();" n) ctx.letbinds + in + let startup cdefs = + List.map sgen_startup (List.filter is_cdef_startup cdefs) + in + let finish cdefs = + List.map sgen_finish (List.filter is_cdef_finish cdefs) + in + + let regs = c_ast_registers cdefs in + + let register_init_clear (id, ctyp, instrs) = + if is_stack_ctyp ctyp then + List.map (sgen_instr (mk_id "reg") ctx) instrs, [] + else + [ Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] + @ List.map (sgen_instr (mk_id "reg") ctx) instrs, + [ Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] + in + + let model_init = separate hardline (List.map string + ( [ "void model_init(void)"; + "{"; + " setup_rts();" ] + @ fst exn_boilerplate + @ startup cdefs + @ List.concat (List.map (fun r -> fst (register_init_clear r)) regs) + @ (if regs = [] then [] else [ Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "initialize_registers")) ]) + @ letbind_initializers + @ [ "}" ] )) + in + + let model_fini = separate hardline (List.map string + ( [ "void model_fini(void)"; + "{" ] + @ letbind_finalizers + @ List.concat (List.map (fun r -> snd (register_init_clear r)) regs) + @ finish cdefs + @ snd exn_boilerplate + @ [ " cleanup_rts();"; + "}" ] )) + in + + let model_default_main = separate hardline (List.map string + [ "int model_main(int argc, char *argv[])"; + "{"; + " model_init();"; + " if (process_arguments(argc, argv)) exit(EXIT_FAILURE);"; + Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "main")); + " model_fini();"; + " return EXIT_SUCCESS;"; + "}" ] ) + in + + let model_main = separate hardline (if (!opt_no_main) then [] else List.map string + [ "int main(int argc, char *argv[])"; + "{"; + " return model_main(argc, argv);"; + "}" ] ) + in + + let hlhl = hardline ^^ hardline in + + Pretty_print_sail.to_string (preamble ^^ hlhl ^^ docs ^^ hlhl + ^^ (if not !opt_no_rts then + model_init ^^ hlhl + ^^ model_fini ^^ hlhl + ^^ model_default_main ^^ hlhl + else + empty) + ^^ model_main ^^ hardline) + |> output_string output_chan + with + | Type_error (_, l, err) -> + c_error ~loc:l ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) diff --git a/src/jib/c_backend.mli b/src/jib/c_backend.mli new file mode 100644 index 00000000..2fc5be94 --- /dev/null +++ b/src/jib/c_backend.mli @@ -0,0 +1,118 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Jib +open Type_check + +(** Global compilation options *) + +(** Output a dataflow graph for each generated function in Graphviz + (dot) format. *) +val opt_debug_flow_graphs : bool ref + +(** Define generated functions as static *) +val opt_static : bool ref + +(** Do not generate a main function *) +val opt_no_main : bool ref + +(** (WIP) Do not include rts.h (the runtime), and do not generate code + that requires any setup or teardown routines to be run by a runtime + before executing any instruction semantics. *) +val opt_no_rts : bool ref + +(** Ordinarily we use plain z-encoding to name-mangle generated Sail + identifiers into a form suitable for C. If opt_prefix is set, then + the "z" which is added on the front of each generated C function + will be replaced by opt_prefix. E.g. opt_prefix := "sail_" would + give sail_my_function rather than zmy_function. *) +val opt_prefix : string ref + +(** opt_extra_params and opt_extra_arguments allow additional state to + be threaded through the generated C code by adding an additional + parameter to each function type, and then giving an extra argument + to each function call. For example we could have + + opt_extra_params := Some "CPUMIPSState *env" + opt_extra_arguments := Some "env" + + and every generated function will take a pointer to a QEMU MIPS + processor state, and each function will be passed the env argument + when it is called. *) +val opt_extra_params : string option ref +val opt_extra_arguments : string option ref + +(** (WIP) [opt_memo_cache] will store the compiled function + definitions in file _sbuild/ccacheDIGEST where DIGEST is the md5sum + of the original function to be compiled. Enabled using the -memo + flag. Uses Marshal so it's quite picky about the exact version of +b the Sail version. This cache can obviously become stale if the C + backend changes - it'll load an old version compiled without said + changes. *) +val opt_memo_cache : bool ref + +(** Optimization flags *) + +val optimize_primops : bool ref +val optimize_hoist_allocations : bool ref +val optimize_struct_updates : bool ref +val optimize_alias : bool ref +val optimize_experimental : bool ref + +(** Convert a typ to a IR ctyp *) +val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp + +(** Rewriting steps for compiled ASTs *) +val flatten_instrs : instr list -> instr list + +val flatten_cdef : cdef -> cdef + +val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx +val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml new file mode 100644 index 00000000..8411f464 --- /dev/null +++ b/src/jib/jib_compile.ml @@ -0,0 +1,1367 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_util +open Type_check +open Value2 + +open Anf + +let opt_memo_cache = ref false + +(**************************************************************************) +(* 4. Conversion to low-level AST *) +(**************************************************************************) + +(** We now use a low-level AST called Jib (see language/bytecode.ott) + that is only slightly abstracted away from C. To be succint in + comments we usually refer to this as Sail IR or IR rather than + low-level AST repeatedly. + + The general idea is ANF expressions are converted into lists of + instructions (type instr) where allocations and deallocations are + now made explicit. ANF values (aval) are mapped to the cval type, + which is even simpler still. Some things are still more abstract + than in C, so the type definitions follow the sail type definition + structure, just with typ (from ast.ml) replaced with + ctyp. Top-level declarations that have no meaning for the backend + are not included at this level. + + The convention used here is that functions of the form compile_X + compile the type X into types in this AST, so compile_aval maps + avals into cvals. Note that the return types for these functions + are often quite complex, and they usually return some tuple + containing setup instructions (to allocate memory for the + expression), cleanup instructions (to deallocate that memory) and + possibly typing information about what has been translated. **) + +(* FIXME: This stage shouldn't care about this *) +let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) +let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) + +let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + +let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + +let is_ct_enum = function + | CT_enum _ -> true + | _ -> false + +let is_ct_variant = function + | CT_variant _ -> true + | _ -> false + +let is_ct_tup = function + | CT_tup _ -> true + | _ -> false + +let is_ct_list = function + | CT_list _ -> true + | _ -> false + +let is_ct_vector = function + | CT_vector _ -> true + | _ -> false + +let is_ct_struct = function + | CT_struct _ -> true + | _ -> false + +let is_ct_ref = function + | CT_ref _ -> true + | _ -> false + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty + +(** The context type contains two type-checking + environments. ctx.local_env contains the closest typechecking + environment, usually from the expression we are compiling, whereas + ctx.tc_env is the global type checking environment from + type-checking the entire AST. We also keep track of local variables + in ctx.locals, so we know when their type changes due to flow + typing. *) +type ctx = + { records : (ctyp Bindings.t) Bindings.t; + enums : IdSet.t Bindings.t; + variants : (ctyp Bindings.t) Bindings.t; + tc_env : Env.t; + local_env : Env.t; + locals : (mut * ctyp) Bindings.t; + letbinds : int list; + no_raw : bool; + convert_typ : ctx -> typ -> ctyp; + optimize_anf : ctx -> typ aexp -> typ aexp + } + +let initial_ctx ~convert_typ:convert_typ ~optimize_anf:optimize_anf env = + { records = Bindings.empty; + enums = Bindings.empty; + variants = Bindings.empty; + tc_env = env; + local_env = env; + locals = Bindings.empty; + letbinds = []; + no_raw = false; + convert_typ = convert_typ; + optimize_anf = optimize_anf + } + +let ctyp_of_typ ctx typ = ctx.convert_typ ctx typ + +let rec chunkify n xs = + match Util.take n xs, Util.drop n xs with + | xs, [] -> [xs] + | xs, ys -> xs :: chunkify n ys + +let rec compile_aval l ctx = function + | AV_C_fragment (frag, typ, ctyp) -> + let ctyp' = ctyp_of_typ ctx typ in + if not (ctyp_equal ctyp ctyp') then + raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp')); + [], (frag, ctyp_of_typ ctx typ), [] + + | AV_id (id, typ) -> + begin + try + let _, ctyp = Bindings.find id ctx.locals in + [], (F_id id, ctyp), [] + with + | Not_found -> + [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), [] + end + + | AV_ref (id, typ) -> + [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] + + | AV_lit (L_aux (L_string str, _), typ) -> + [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), [] + + | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + let gs = gensym () in + [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)], + (F_id gs, CT_lint), + [iclear CT_lint gs] + + | AV_lit (L_aux (L_num n, _), typ) -> + let gs = gensym () in + [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)], + (F_id gs, CT_lint), + [iclear CT_lint gs] + + | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), [] + | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), [] + + | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), [] + | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), [] + + | AV_lit (L_aux (L_real str, _), _) -> + let gs = gensym () in + [iinit CT_real gs (F_lit (V_string str), CT_string)], + (F_id gs, CT_real), + [iclear CT_real gs] + + | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), [] + + | AV_lit (L_aux (_, l) as lit, _) -> + raise (Reporting.err_general l ("Encountered unexpected literal " ^ string_of_lit lit ^ " when converting ANF represention into IR")) + + | AV_tuple avals -> + let elements = List.map (compile_aval l ctx) avals in + let cvals = List.map (fun (_, cval, _) -> cval) elements in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in + let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in + let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in + let gs = gensym () in + setup + @ [idecl tup_ctyp gs] + @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals, + (F_id gs, CT_tup (List.map cval_ctyp cvals)), + [iclear tup_ctyp gs] + @ cleanup + + | AV_record (fields, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let gs = gensym () in + let compile_fields (id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] + @ field_cleanup + in + [idecl ctyp gs] + @ List.concat (List.map compile_fields (Bindings.bindings fields)), + (F_id gs, ctyp), + [iclear ctyp gs] + + | AV_vector ([], _) -> + raise (Reporting.err_general l "Encountered empty vector literal") + + (* Convert a small bitvector to a uint64_t literal. *) + | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 -> + begin + let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in + let len = List.length avals in + match destruct_vector ctx.tc_env typ with + | Some (_, Ord_aux (Ord_inc, _), _) -> + [], (bitstring, CT_fbits (len, false)), [] + | Some (_, Ord_aux (Ord_dec, _), _) -> + [], (bitstring, CT_fbits (len, true)), [] + | Some _ -> + raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") + | None -> + raise (Reporting.err_general l "Encountered vector literal without vector type") + end + + (* Convert a bitvector literal that is larger than 64-bits to a + variable size bitvector, converting it in 64-bit chunks. *) + | AV_vector (avals, typ) when is_bitvector avals -> + let len = List.length avals in + let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in + let first_chunk = bitstring (Util.take (len mod 64) avals) in + let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in + let gs = gensym () in + [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))] + @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true)) + (mk_id "append_64") + [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks, + (F_id gs, CT_lbits true), + [iclear (CT_lbits true) gs] + + (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) + when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 -> + let len = List.length avals in + let direction = match ord with + | Ord_aux (Ord_inc, _) -> false + | Ord_aux (Ord_dec, _) -> true + | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found") + in + let gs = gensym () in + let ctyp = CT_fbits (len, direction) in + let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in + let aval_mask i aval = + let setup, cval, cleanup = compile_aval l ctx aval in + match cval with + | (F_lit (V_bit Sail2_values.B0), _) -> [] + | (F_lit (V_bit Sail2_values.B1), _) -> + [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] + | _ -> + setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup + in + [idecl ctyp gs; + icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)] + @ List.concat (List.mapi aval_mask (List.rev avals)), + (F_id gs, ctyp), + [] + + (* Compiling a vector literal that isn't a bitvector *) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _)) + when string_of_id id = "vector" -> + let len = List.length avals in + let direction = match ord with + | Ord_aux (Ord_inc, _) -> false + | Ord_aux (Ord_dec, _) -> true + | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found") + in + let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in + let gs = gensym () in + let aval_set i aval = + let setup, cval, cleanup = compile_aval l ctx aval in + setup + @ [iextern (CL_id (gs, vector_ctyp)) + (mk_id "internal_vector_update") + [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]] + @ cleanup + in + [idecl vector_ctyp gs; + iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]] + @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)), + (F_id gs, vector_ctyp), + [iclear vector_ctyp gs] + + | AV_vector _ as aval -> + raise (Reporting.err_general l ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type")) + + | AV_list (avals, Typ_aux (typ, _)) -> + let ctyp = match typ with + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ + | _ -> raise (Reporting.err_general l "Invalid list type") + in + let gs = gensym () in + let mk_cons aval = + let setup, cval, cleanup = compile_aval l ctx aval in + setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup + in + [idecl (CT_list ctyp) gs] + @ List.concat (List.map mk_cons (List.rev avals)), + (F_id gs, CT_list ctyp), + [iclear (CT_list ctyp) gs] + +let compile_funcall l ctx id args typ = + let setup = ref [] in + let cleanup = ref [] in + + let quant, Typ_aux (fn_typ, _) = + (* If we can't find a function in local_env, fall back to the + global env - this happens when representing assertions, exit, + etc as functions in the IR. *) + try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env + in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + let final_ctyp = ctyp_of_typ ctx typ in + + let setup_arg ctyp aval = + let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in + setup := List.rev arg_setup @ !setup; + cleanup := arg_cleanup @ !cleanup; + let have_ctyp = cval_ctyp cval in + if is_polymorphic ctyp then + (F_poly (fst cval), have_ctyp) + else if ctyp_equal ctyp have_ctyp then + cval + else + let gs = gensym () in + setup := iinit ctyp gs cval :: !setup; + cleanup := iclear ctyp gs :: !cleanup; + (F_id gs, ctyp) + in + + assert (List.length arg_ctyps = List.length args); + + let setup_args = List.map2 setup_arg arg_ctyps args in + + List.rev !setup, + begin fun clexp -> + if ctyp_equal (clexp_ctyp clexp) ret_ctyp then + ifuncall clexp id setup_args + else + let gs = gensym () in + iblock [idecl ret_ctyp gs; + ifuncall (CL_id (gs, ret_ctyp)) id setup_args; + icopy l clexp (F_id gs, ret_ctyp); + iclear ret_ctyp gs] + end, + !cleanup + +let rec apat_ctyp ctx (AP_aux (apat, _, _)) = + match apat with + | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats) + | AP_global (_, typ) -> ctyp_of_typ ctx typ + | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat) + | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ + | AP_app (_, _, typ) -> ctyp_of_typ ctx typ + +let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = + let ctx = { ctx with local_env = env } in + match apat_aux, cval with + | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env -> + [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label], + [], + ctx + + | AP_global (pid, typ), (frag, ctyp) -> + let global_ctyp = ctyp_of_typ ctx typ in + [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx + + | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp -> + begin match Env.lookup_id pid ctx.tc_env with + | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx + | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx + end + + | AP_id (pid, typ), _ -> + let ctyp = cval_ctyp cval in + let id_ctyp = ctyp_of_typ ctx typ in + let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in + [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx + + | AP_tup apats, (frag, ctyp) -> + begin + let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in + let fold (instrs, cleanup, n, ctx) apat ctyp = + let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in + instrs @ instrs', cleanup' @ cleanup, n + 1, ctx + in + match ctyp with + | CT_tup ctyps -> + let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in + instrs, cleanup, ctx + | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp) + end + + | AP_app (ctor, apat, variant_typ), (frag, ctyp) -> + begin match ctyp with + | CT_variant (_, ctors) -> + let ctor_c_id = string_of_id ctor in + let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in + (* These should really be the same, something has gone wrong if they are not. *) + if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then + raise (Reporting.err_general l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ)))) + else (); + let ctor_c_id, ctor_ctyp = + if is_polymorphic ctor_ctyp then + let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in + (if List.length unification > 0 then + ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification + else + ctor_c_id), + ctyp_suprema (apat_ctyp ctx apat) + else + ctor_c_id, ctor_ctyp + in + let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in + [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label] + @ instrs, + cleanup, + ctx + | ctyp -> + raise (Reporting.err_general l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s" + (string_of_id ctor) + (string_of_typ variant_typ) + (string_of_fragment ~zencode:false frag) + (string_of_ctyp ctyp))) + end + + | AP_wild _, _ -> [], [], ctx + + | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) -> + let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in + let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in + [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx + + | AP_cons _, (_, _) -> + raise (Reporting.err_general l "Tried to pattern match cons on non list type") + + | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx + +let unit_fragment = (F_lit V_unit, CT_unit) + +let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = + let ctx = { ctx with local_env = env } in + match aexp_aux with + | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) -> + let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in + let setup, call, cleanup = compile_aexp ctx binding in + let letb_setup, letb_cleanup = + [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id] + in + let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in + let setup, call, cleanup = compile_aexp ctx body in + letb_setup @ setup, call, cleanup @ letb_cleanup + + | AE_app (id, vs, typ) -> + compile_funcall l ctx id vs typ + + | AE_val aval -> + let setup, cval, cleanup = compile_aval l ctx aval in + setup, (fun clexp -> icopy l clexp cval), cleanup + + (* Compile case statements *) + | AE_case (aval, cases, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in + let case_return_id = gensym () in + let finish_match_label = label "finish_match_" in + let compile_case (apat, guard, body) = + let trivial_guard = match guard with + | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true + | _ -> false + in + let case_label = label "case_" in + let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in + let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let case_instrs = + destructure @ [icomment "end destructuring"] + @ (if not trivial_guard then + guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup + @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit] + @ [icomment "end guard"] + else []) + @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup + @ [igoto finish_match_label] + in + if is_dead_aexp body then + [ilabel case_label] + else + [iblock case_instrs; ilabel case_label] + in + [icomment "begin match"] + @ aval_setup @ [idecl ctyp case_return_id] + @ List.concat (List.map compile_case cases) + @ [imatch_failure ()] + @ [ilabel finish_match_label], + (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)), + [iclear ctyp case_return_id] + @ aval_cleanup + @ [icomment "end match"] + + (* Compile try statement *) + | AE_try (aexp, cases, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in + let try_return_id = gensym () in + let handled_exception_label = label "handled_exception_" in + let fallthrough_label = label "fallthrough_exception_" in + let compile_case (apat, guard, body) = + let trivial_guard = match guard with + | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true + | _ -> false + in + let try_label = label "try_" in + let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in + let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in + let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let case_instrs = + destructure @ [icomment "end destructuring"] + @ (if not trivial_guard then + guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup + @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label] + @ [icomment "end guard"] + else []) + @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup + @ [igoto handled_exception_label] + in + [iblock case_instrs; ilabel try_label] + in + assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); + [idecl ctyp try_return_id; + itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); + ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label] + @ List.concat (List.map compile_case cases) + @ [igoto fallthrough_label; + ilabel handled_exception_label; + icopy l CL_have_exception (F_lit (V_bool false), CT_bool); + ilabel fallthrough_label], + (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)), + [] + + | AE_if (aval, then_aexp, else_aexp, if_typ) -> + if is_dead_aexp then_aexp then + compile_aexp ctx else_aexp + else if is_dead_aexp else_aexp then + compile_aexp ctx then_aexp + else + let if_ctyp = ctyp_of_typ ctx if_typ in + let compile_branch aexp = + let setup, call, cleanup = compile_aexp ctx aexp in + fun clexp -> setup @ [call clexp] @ cleanup + in + let setup, cval, cleanup = compile_aval l ctx aval in + setup, + (fun clexp -> iif cval + (compile_branch then_aexp clexp) + (compile_branch else_aexp clexp) + if_ctyp), + cleanup + + (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *) + | AE_record_update (aval, fields, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let ctors = match ctyp with + | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors + | _ -> raise (Reporting.err_general l "Cannot perform record update for non-record type") + in + let gs = gensym () in + let compile_fields (id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] + @ field_cleanup + in + let setup, cval, cleanup = compile_aval l ctx aval in + [idecl ctyp gs] + @ setup + @ [icopy l (CL_id (gs, ctyp)) cval] + @ cleanup + @ List.concat (List.map compile_fields (Bindings.bindings fields)), + (fun clexp -> icopy l clexp (F_id gs, ctyp)), + [iclear ctyp gs] + + | AE_short_circuit (SC_and, aval, aexp) -> + let left_setup, cval, left_cleanup = compile_aval l ctx aval in + let right_setup, call, right_cleanup = compile_aexp ctx aexp in + let gs = gensym () in + left_setup + @ [ idecl CT_bool gs; + iif cval + (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) + [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)] + CT_bool ] + @ left_cleanup, + (fun clexp -> icopy l clexp (F_id gs, CT_bool)), + [] + | AE_short_circuit (SC_or, aval, aexp) -> + let left_setup, cval, left_cleanup = compile_aval l ctx aval in + let right_setup, call, right_cleanup = compile_aexp ctx aexp in + let gs = gensym () in + left_setup + @ [ idecl CT_bool gs; + iif cval + [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)] + (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) + CT_bool ] + @ left_cleanup, + (fun clexp -> icopy l clexp (F_id gs, CT_bool)), + [] + + (* This is a faster assignment rule for updating fields of a + struct. *) + | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _)) + when Id.compare id rid = 0 -> + let compile_fields (field_id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval] + @ field_cleanup + in + List.concat (List.map compile_fields (Bindings.bindings fields)), + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_assign (id, assign_typ, aexp) -> + let assign_ctyp = + match Bindings.find_opt id ctx.locals with + | Some (_, ctyp) -> ctyp + | None -> ctyp_of_typ ctx assign_typ + in + let setup, call, cleanup = compile_aexp ctx aexp in + setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup + + | AE_block (aexps, aexp, _) -> + let block = compile_block ctx aexps in + let setup, call, cleanup = compile_aexp ctx aexp in + block @ setup, call, cleanup + + | AE_loop (While, cond, body) -> + let loop_start_label = label "while_" in + let loop_end_label = label "wend_" in + let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let unit_gs = gensym () in + let loop_test = (F_unary ("!", F_id gs), CT_bool) in + [idecl CT_bool gs; idecl CT_unit unit_gs] + @ [ilabel loop_start_label] + @ [iblock (cond_setup + @ [cond_call (CL_id (gs, CT_bool))] + @ cond_cleanup + @ [ijump loop_test loop_end_label] + @ body_setup + @ [body_call (CL_id (unit_gs, CT_unit))] + @ body_cleanup + @ [igoto loop_start_label])] + @ [ilabel loop_end_label], + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_loop (Until, cond, body) -> + let loop_start_label = label "repeat_" in + let loop_end_label = label "until_" in + let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let unit_gs = gensym () in + let loop_test = (F_id gs, CT_bool) in + [idecl CT_bool gs; idecl CT_unit unit_gs] + @ [ilabel loop_start_label] + @ [iblock (body_setup + @ [body_call (CL_id (unit_gs, CT_unit))] + @ body_cleanup + @ cond_setup + @ [cond_call (CL_id (gs, CT_bool))] + @ cond_cleanup + @ [ijump loop_test loop_end_label] + @ [igoto loop_start_label])] + @ [ilabel loop_end_label], + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_cast (aexp, typ) -> compile_aexp ctx aexp + + | AE_return (aval, typ) -> + let fn_return_ctyp = match Env.get_ret_typ env with + | Some typ -> ctyp_of_typ ctx typ + | None -> raise (Reporting.err_general l "No function return type found when compiling return statement") + in + (* Cleanup info will be re-added by fix_early_(heap/stack)_return *) + let return_setup, cval, _ = compile_aval l ctx aval in + let creturn = + if ctyp_equal fn_return_ctyp (cval_ctyp cval) then + [ireturn cval] + else + let gs = gensym () in + [idecl fn_return_ctyp gs; + icopy l (CL_id (gs, fn_return_ctyp)) cval; + ireturn (F_id gs, fn_return_ctyp)] + in + return_setup @ creturn, + (fun clexp -> icomment "unreachable after return"), + [] + + | AE_throw (aval, typ) -> + (* Cleanup info will be handled by fix_exceptions *) + let throw_setup, cval, _ = compile_aval l ctx aval in + throw_setup @ [ithrow cval], + (fun clexp -> icomment "unreachable after throw"), + [] + + | AE_field (aval, id, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let setup, cval, cleanup = compile_aval l ctx aval in + setup, + (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)), + cleanup + + | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) -> + (* We assume that all loop indices are safe to put in a CT_fint. *) + let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in + + let is_inc = match ord with + | Ord_inc -> true + | Ord_dec -> false + | Ord_var _ -> raise (Reporting.err_general l "Polymorphic loop direction in C backend") + in + + (* Loop variables *) + let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in + let from_gs = gensym () in + let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in + let to_gs = gensym () in + let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in + let step_gs = gensym () in + let variable_init gs setup call cleanup = + [idecl (CT_fint 64) gs; + iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)] + in + + let loop_start_label = label "for_start_" in + let loop_end_label = label "for_end_" in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let body_gs = gensym () in + + variable_init from_gs from_setup from_call from_cleanup + @ variable_init to_gs to_setup to_call to_cleanup + @ variable_init step_gs step_setup step_call step_cleanup + @ [iblock ([idecl (CT_fint 64) loop_var; + icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64)); + idecl CT_unit body_gs; + iblock ([ilabel loop_start_label] + @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label] + @ body_setup + @ [body_call (CL_id (body_gs, CT_unit))] + @ body_cleanup + @ [icopy l (CL_id (loop_var, (CT_fint 64))) + (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))] + @ [igoto loop_start_label]); + ilabel loop_end_label])], + (fun clexp -> icopy l clexp unit_fragment), + [] + +and compile_block ctx = function + | [] -> [] + | exp :: exps -> + let setup, call, cleanup = compile_aexp ctx exp in + let rest = compile_block ctx exps in + let gs = gensym () in + iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest + +(** Compile a sail type definition into a IR one. Most of the + actual work of translating the typedefs into C is done by the code + generator, as it's easy to keep track of structs, tuples and unions + in their sail form at this level, and leave the fiddly details of + how they get mapped to C in the next stage. This function also adds + details of the types it compiles to the context, ctx, which is why + it returns a ctypdef * ctx pair. **) +let compile_type_def ctx (TD_aux (type_def, (l, _))) = + match type_def with + | TD_enum (id, ids, _) -> + CTD_enum (id, ids), + { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } + + | TD_record (id, _, ctors, _) -> + let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in + CTD_struct (id, Bindings.bindings ctors), + { ctx with records = Bindings.add id ctors ctx.records } + + | TD_variant (id, typq, tus, _) -> + let compile_tu = function + | Tu_aux (Tu_ty_id (typ, id), _) -> + let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in + ctyp_of_typ ctx typ, id + in + let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in + CTD_variant (id, Bindings.bindings ctus), + { ctx with variants = Bindings.add id ctus ctx.variants } + + (* Will be re-written before here, see bitfield.ml *) + | TD_bitfield _ -> + Reporting.unreachable l __POS__ "Cannot compile TD_bitfield" + + (* All type abbreviations are filtered out in compile_def *) + | TD_abbrev _ -> + Reporting.unreachable l __POS__ "Found TD_abbrev in compile_type_def" + +let generate_cleanup instrs = + let generate_cleanup' (I_aux (instr, _)) = + match instr with + | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)] + | I_decl (ctyp, id) -> [(id, iclear ctyp id)] + | instr -> [] + in + let is_clear ids = function + | I_aux (I_clear (_, id), _) -> IdSet.add id ids + | _ -> ids + in + let cleaned = List.fold_left is_clear IdSet.empty instrs in + instrs + |> List.map generate_cleanup' + |> List.concat + |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) + |> List.map snd + +let fix_exception_block ?return:(return=None) ctx instrs = + let end_block_label = label "end_block_exception_" in + let is_exception_stop (I_aux (instr, _)) = + match instr with + | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true + | _ -> false + in + (* In this function 'after' is instructions after the one we've + matched on, 'before is instructions before the instruction we've + matched with, but after the previous match, and 'historic' are + all the befores from previous matches. *) + let rec rewrite_exception historic instrs = + match instr_split_at is_exception_stop instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_exception (historic @ before) instrs)] + @ rewrite_exception (historic @ before) after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + let historic = historic @ before in + before + @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] + @ rewrite_exception historic after + | before, I_aux (I_throw cval, (_, l)) :: after -> + before + @ [icopy l (CL_current_exception (cval_ctyp cval)) cval; + icopy l CL_have_exception (F_lit (V_bool true), CT_bool)] + @ generate_cleanup (historic @ before) + @ [igoto end_block_label] + @ rewrite_exception (historic @ before) after + | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> + let effects = match Env.get_val_spec f ctx.tc_env with + | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects + | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) + | _ -> assert false (* valspec must have function type *) + in + if has_effect effects BE_escape then + before + @ [funcall; + iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] + @ rewrite_exception (historic @ before) after + else + before @ funcall :: rewrite_exception (historic @ before) after + | _, _ -> assert false (* unreachable *) + in + match return with + | None -> + rewrite_exception [] instrs @ [ilabel end_block_label] + | Some ctyp -> + rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp] + +let rec map_try_block f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr + | I_block instrs -> I_block (List.map (map_try_block f) instrs) + | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ | I_end -> instr + in + I_aux (instr, aux) + +let fix_exception ?return:(return=None) ctx instrs = + let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in + fix_exception_block ~return:return ctx instrs + +let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp = + match p_aux with + | P_id id -> (id, ([], [])) + | P_wild -> let gs = gensym () in (gs, ([], [])) + | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], [])) + | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp + | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp + | _ -> + let apat = anf_pat pat in + let gs = gensym () in + let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in + (gs, (destructure, cleanup)) + +let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps = + match p_aux with + | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps + | P_tup pats when List.length pats = List.length ctyps -> + [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, [] + | _ when List.length ctyps = 1 -> + [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], [] + + | _ -> + let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in + let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in + destructure + @ [idecl (CT_tup ctyps) arg_id] + @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids, + List.map (fun (id, _) -> id, ([], [])) new_ids, + [iclear (CT_tup ctyps) arg_id] + @ cleanup + +let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs)) + +let fix_destructure fail_label = function + | ([], cleanup) -> ([], cleanup) + | destructure, cleanup -> + let body_label = label "fundef_body_" in + (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup) + +(** Functions that have heap-allocated return types are implemented by + passing a pointer a location where the return value should be + stored. The ANF -> Sail IR pass for expressions simply outputs an + I_return instruction for any return value, so this function walks + over the IR ast for expressions and modifies the return statements + into code that sets that pointer, as well as adds extra control + flow to cleanup heap-allocated variables correctly when a function + terminates early. See the generate_cleanup function for how this is + done. *) +let fix_early_return ret instrs = + let end_function_label = label "end_function_" in + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_return _ | I_undefined _ | I_if _ | I_block _ -> true + | _ -> false + in + let rec rewrite_return historic instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return (historic @ before) instrs)] + @ rewrite_return (historic @ before) after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + let historic = historic @ before in + before + @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] + @ rewrite_return historic after + | before, I_aux (I_return cval, (_, l)) :: after -> + let cleanup_label = label "cleanup_" in + let end_cleanup_label = label "end_cleanup_" in + before + @ [icopy l ret cval; + igoto cleanup_label] + (* This is probably dead code until cleanup_label, but we cannot be sure there are no jumps into it. *) + @ rewrite_return (historic @ before) after + @ [igoto end_cleanup_label; + ilabel cleanup_label] + @ generate_cleanup (historic @ before) + @ [igoto end_function_label; + ilabel end_cleanup_label] + | before, I_aux (I_undefined _, (_, l)) :: after -> + let cleanup_label = label "cleanup_" in + let end_cleanup_label = label "end_cleanup_" in + before + @ [igoto cleanup_label] + @ rewrite_return (historic @ before) after + @ [igoto end_cleanup_label; + ilabel cleanup_label] + @ generate_cleanup (historic @ before) + @ [igoto end_function_label; + ilabel end_cleanup_label] + | _, _ -> assert false + in + rewrite_return [] instrs + @ [ilabel end_function_label; iend ()] + +let letdef_count = ref 0 + +(** Compile a Sail toplevel definition into an IR definition **) +let rec compile_def n total ctx def = + match def with + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _)) + when !opt_memo_cache -> + let digest = + def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string + in + let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in + let cached = + if Sys.file_exists cachefile then + let in_chan = open_in cachefile in + try + let compiled = Marshal.from_channel in_chan in + close_in in_chan; + Some (compiled, ctx) + with + | _ -> close_in in_chan; None + else + None + in + begin match cached with + | Some (compiled, ctx) -> + Util.progress "Compiling " (string_of_id id) n total; + compiled, ctx + | None -> + let compiled, ctx = compile_def' n total ctx def in + let out_chan = open_out cachefile in + Marshal.to_channel out_chan compiled [Marshal.Closures]; + close_out out_chan; + compiled, ctx + end + + | _ -> compile_def' n total ctx def + +and compile_def' n total ctx = function + | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> + [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx + | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> + let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let setup, call, cleanup = compile_aexp ctx aexp in + let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in + [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx + + | DEF_reg_dec (DEC_aux (_, (l, _))) -> + raise (Reporting.err_general l "Cannot compile alias register declaration") + + | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> + let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx + + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> + Util.progress "Compiling " (string_of_id id) n total; + + (* Find the function's type. *) + let quant, Typ_aux (fn_typ, _) = + try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env + in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + + (* Handle the argument pattern. *) + let fundef_label = label "fundef_fail_" in + let orig_ctx = ctx in + (* The context must be updated before we call ctyp_of_typ on the argument types. *) + let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in + + let arg_ctyps = List.map (ctyp_of_typ ctx) arg_typs in + let ret_ctyp = ctyp_of_typ ctx ret_typ in + + (* Compile the function arguments as patterns. *) + let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in + let ctx = + (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *) + List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps + in + + (* Optimize and compile the expression to ANF. *) + let aexp = no_shadow (pat_ids pat) (anf exp) in + let aexp = ctx.optimize_anf ctx aexp in + + let setup, call, cleanup = compile_aexp ctx aexp in + let destructure, destructure_cleanup = + compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label + in + + let instrs = arg_setup @ destructure @ setup @ [call (CL_return ret_ctyp)] @ cleanup @ destructure_cleanup @ arg_cleanup in + let instrs = fix_early_return (CL_return ret_ctyp) instrs in + let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in + [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx + + | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> + raise (Reporting.err_general l "Encountered function with no clauses") + + | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) -> + raise (Reporting.err_general l "Encountered function with multiple clauses") + + (* All abbreviations should expanded by the typechecker, so we don't + need to translate type abbreviations into C typedefs. *) + | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx + + | DEF_type type_def -> + let tdef, ctx = compile_type_def ctx type_def in + [CDEF_type tdef], ctx + + | DEF_val (LB_aux (LB_val (pat, exp), _)) -> + let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in + let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let setup, call, cleanup = compile_aexp ctx aexp in + let apat = anf_pat ~global:true pat in + let gs = gensym () in + let end_label = label "let_end_" in + let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in + let gs_setup, gs_cleanup = + [idecl ctyp gs], [iclear ctyp gs] + in + let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in + let n = !letdef_count in + incr letdef_count; + let instrs = + gs_setup @ setup + @ [call (CL_id (gs, ctyp))] + @ cleanup + @ destructure + @ destructure_cleanup @ gs_cleanup + @ [ilabel end_label] + in + [CDEF_let (n, bindings, instrs)], + { ctx with letbinds = n :: ctx.letbinds } + + (* Only DEF_default that matters is default Order, but all order + polymorphism is specialised by this point. *) + | DEF_default _ -> [], ctx + + (* Overloading resolved by type checker *) + | DEF_overload _ -> [], ctx + + (* Only the parser and sail pretty printer care about this. *) + | DEF_fixity _ -> [], ctx + + (* We just ignore any pragmas we don't want to deal with. *) + | DEF_pragma _ -> [], ctx + + (* Termination measures only needed for Coq, and other theorem prover output *) + | DEF_measure _ -> [], ctx + + | DEF_internal_mutrec fundefs -> + let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in + List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs + + (* Scattereds and mapdefs should be removed by this point *) + | (DEF_scattered _ | DEF_mapdef _) as def -> + raise (Reporting.err_general Parse_ast.Unknown ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def))) + +let rec specialize_variants ctx prior = + let unifications = ref (Bindings.empty) in + + let fix_variant_ctyp var_id new_ctors = function + | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) + | ctyp -> ctyp + in + + let specialize_constructor ctx ctor_id ctyp = + function + | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + (* Work out how each call to a constructor in instantiated and add that to unifications *) + let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in + let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in + unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; + + (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) + let casts = + let cast_to_suprema (frag, ctyp) = + let suprema = ctyp_suprema ctyp in + if ctyp_equal ctyp suprema then + [], (unpoly frag, ctyp), [] + else + let gs = gensym () in + [idecl suprema gs; + icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], + (F_id gs, suprema), + [iclear suprema gs] + in + List.map cast_to_suprema [cval] + in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in + let cvals = List.map (fun (_, cval, _) -> cval) casts in + let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in + + let mk_funcall instr = + if List.length setup = 0 then + instr + else + iblock (setup @ [instr] @ cleanup) + in + + mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) + + | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + Reporting.unreachable l __POS__ "Multiple argument constructor found" + + | instr -> instr + in + + function + | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> + let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in + + let cdefs = + List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) + cdefs + polymorphic_ctors + in + + let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in + let specialized_ctors = Bindings.bindings !unifications in + let new_ctors = monomorphic_ctors @ specialized_ctors in + + let ctx = { + ctx with variants = Bindings.add var_id + (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) + ctx.variants + } in + + let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in + let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in + specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs + + | cdef :: cdefs -> + let remove_poly (I_aux (instr, aux)) = + match instr with + | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> + I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) + | instr -> I_aux (instr, aux) + in + let cdef = cdef_map_instr remove_poly cdef in + specialize_variants ctx (cdef :: prior) cdefs + + | [] -> List.rev prior, ctx + +(** Once we specialize variants, there may be additional type + dependencies which could be in the wrong order. As such we need to + sort the type definitions in the list of cdefs. *) +let sort_ctype_defs cdefs = + (* Split the cdefs into type definitions and non type definitions *) + let is_ctype_def = function CDEF_type _ -> true | _ -> false in + let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in + let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in + let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in + + let ctdef_id = function + | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id + in + + let ctdef_ids = function + | CTD_enum _ -> IdSet.empty + | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> + List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors + in + + (* Create a reverse (i.e. from types to the types that are dependent + upon them) id graph of dependencies between types *) + let module IdGraph = Graph.Make(Id) in + + let graph = + List.fold_left (fun g ctdef -> + List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) + (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) + (IdSet.elements (ctdef_ids ctdef))) + IdGraph.empty + ctype_defs + in + + (* Then select the ctypes in the correct order as given by the topsort *) + let ids = IdGraph.topsort graph in + let ctype_defs = + List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids + in + + ctype_defs @ cdefs + +let compile_ast ctx (Defs defs) = + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in + + let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in + + if !opt_memo_cache then + (try + if Sys.is_directory "_sbuild" then + () + else + raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!") + with + | Sys_error _ -> Unix.mkdir "_sbuild" 0o775) + else (); + + let total = List.length defs in + let _, chunks, ctx = + List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs + in + let cdefs = List.concat (List.rev chunks) in + let cdefs, ctx = specialize_variants ctx [] cdefs in + let cdefs = sort_ctype_defs cdefs in + cdefs, ctx diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli new file mode 100644 index 00000000..50054149 --- /dev/null +++ b/src/jib/jib_compile.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Anf +open Ast +open Ast_util +open Jib +open Type_check + +(** Context for compiling Sail to Jib. We need to pass a (global) + typechecking environment given by checking the full AST. We have to + provide a conversion function from Sail types into Jib types, as + well as a function that optimizes ANF expressions (which can just + be the identity function) *) +type ctx = + { records : (ctyp Bindings.t) Bindings.t; + enums : IdSet.t Bindings.t; + variants : (ctyp Bindings.t) Bindings.t; + tc_env : Env.t; + local_env : Env.t; + locals : (mut * ctyp) Bindings.t; + letbinds : int list; + no_raw : bool; + convert_typ : ctx -> typ -> ctyp; + optimize_anf : ctx -> typ aexp -> typ aexp + } + +val initial_ctx : + convert_typ:(ctx -> typ -> ctyp) -> + optimize_anf:(ctx -> typ aexp -> typ aexp) -> + Env.t -> + ctx + +(** Compile a Sail definition into a Jib definition. The first two + arguments are is the current definition number and the total number + of definitions, and can be used to drive a progress bar (see + Util.progress). *) +val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx + +val compile_ast : ctx -> tannot defs -> cdef list * ctx diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml new file mode 100644 index 00000000..d9c6a541 --- /dev/null +++ b/src/jib/jib_util.ml @@ -0,0 +1,935 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Value2 +open PPrint + +(* Define wrappers for creating bytecode instructions. Each function + uses a counter to assign each instruction a unique identifier. *) + +let instr_counter = ref 0 + +let instr_number () = + let n = !instr_counter in + incr instr_counter; + n + +let idecl ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_decl (ctyp, id), (instr_number (), l)) + +let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_reset (ctyp, id), (instr_number (), l)) + +let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = + I_aux (I_init (ctyp, id, cval), (instr_number (), l)) + +let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = + I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) + +let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = + I_aux (I_funcall (clexp, false, id, cvals), (instr_number (), l)) + +let iextern ?loc:(l=Parse_ast.Unknown) clexp id cvals = + I_aux (I_funcall (clexp, true, id, cvals), (instr_number (), l)) + +let icopy l clexp cval = + I_aux (I_copy (clexp, cval), (instr_number (), l)) + +let ialias l clexp cval = + I_aux (I_alias (clexp, cval), (instr_number (), l)) + +let iclear ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_clear (ctyp, id), (instr_number (), l)) + +let ireturn ?loc:(l=Parse_ast.Unknown) cval = + I_aux (I_return cval, (instr_number (), l)) + +let iend ?loc:(l=Parse_ast.Unknown) () = + I_aux (I_end, (instr_number (), l)) + +let iblock ?loc:(l=Parse_ast.Unknown) instrs = + I_aux (I_block instrs, (instr_number (), l)) + +let itry_block ?loc:(l=Parse_ast.Unknown) instrs = + I_aux (I_try_block instrs, (instr_number (), l)) + +let ithrow ?loc:(l=Parse_ast.Unknown) cval = + I_aux (I_throw cval, (instr_number (), l)) +let icomment ?loc:(l=Parse_ast.Unknown) str = + I_aux (I_comment str, (instr_number (), l)) + +let ilabel ?loc:(l=Parse_ast.Unknown) label = + I_aux (I_label label, (instr_number (), l)) +let igoto ?loc:(l=Parse_ast.Unknown) label = + I_aux (I_goto label, (instr_number (), l)) + +let iundefined ?loc:(l=Parse_ast.Unknown) ctyp = + I_aux (I_undefined ctyp, (instr_number (), l)) + +let imatch_failure ?loc:(l=Parse_ast.Unknown) () = + I_aux (I_match_failure, (instr_number (), l)) + +let iraw ?loc:(l=Parse_ast.Unknown) str = + I_aux (I_raw str, (instr_number (), l)) + +let ijump ?loc:(l=Parse_ast.Unknown) cval label = + I_aux (I_jump (cval, label), (instr_number (), l)) + +let rec frag_rename from_id to_id = function + | F_id id when Id.compare id from_id = 0 -> F_id to_id + | F_id id -> F_id id + | F_ref id when Id.compare id from_id = 0 -> F_ref to_id + | F_ref id -> F_ref id + | F_lit v -> F_lit v + | F_have_exception -> F_have_exception + | F_current_exception -> F_current_exception + | F_call (call, frags) -> F_call (call, List.map (frag_rename from_id to_id) frags) + | F_op (f1, op, f2) -> F_op (frag_rename from_id to_id f1, op, frag_rename from_id to_id f2) + | F_unary (op, f) -> F_unary (op, frag_rename from_id to_id f) + | F_field (f, field) -> F_field (frag_rename from_id to_id f, field) + | F_raw raw -> F_raw raw + | F_poly f -> F_poly (frag_rename from_id to_id f) + +let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) + +let rec clexp_rename from_id to_id = function + | CL_id (id, ctyp) when Id.compare id from_id = 0 -> CL_id (to_id, ctyp) + | CL_id (id, ctyp) -> CL_id (id, ctyp) + | CL_field (clexp, field) -> + CL_field (clexp_rename from_id to_id clexp, field) + | CL_addr clexp -> + CL_addr (clexp_rename from_id to_id clexp) + | CL_tuple (clexp, n) -> + CL_tuple (clexp_rename from_id to_id clexp, n) + | CL_current_exception ctyp -> CL_current_exception ctyp + | CL_have_exception -> CL_have_exception + | CL_return ctyp -> CL_return ctyp + +let rec instr_rename from_id to_id (I_aux (instr, aux)) = + let instr = match instr with + | I_decl (ctyp, id) when Id.compare id from_id = 0 -> I_decl (ctyp, to_id) + | I_decl (ctyp, id) -> I_decl (ctyp, id) + + | I_init (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_init (ctyp, to_id, cval_rename from_id to_id cval) + | I_init (ctyp, id, cval) -> + I_init (ctyp, id, cval_rename from_id to_id cval) + + | I_if (cval, then_instrs, else_instrs, ctyp2) -> + I_if (cval_rename from_id to_id cval, + List.map (instr_rename from_id to_id) then_instrs, + List.map (instr_rename from_id to_id) else_instrs, + ctyp2) + + | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) + + | I_funcall (clexp, extern, id, args) -> + I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) + + | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + | I_alias (clexp, cval) -> I_alias (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + + | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) + | I_clear (ctyp, id) -> I_clear (ctyp, id) + + | I_return cval -> I_return (cval_rename from_id to_id cval) + + | I_block instrs -> I_block (List.map (instr_rename from_id to_id) instrs) + + | I_try_block instrs -> I_try_block (List.map (instr_rename from_id to_id) instrs) + + | I_throw cval -> I_throw (cval_rename from_id to_id cval) + + | I_comment str -> I_comment str + + | I_raw str -> I_raw str + + | I_label label -> I_label label + + | I_goto label -> I_goto label + + | I_undefined ctyp -> I_undefined ctyp + + | I_match_failure -> I_match_failure + + | I_end -> I_end + + | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id) + | I_reset (ctyp, id) -> I_reset (ctyp, id) + + | I_reinit (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_reinit (ctyp, to_id, cval_rename from_id to_id cval) + | I_reinit (ctyp, id, cval) -> + I_reinit (ctyp, id, cval_rename from_id to_id cval) + in + I_aux (instr, aux) + +(**************************************************************************) +(* 1. Instruction pretty printer *) +(**************************************************************************) + +let string_of_value = function + | V_bits [] -> "UINT64_C(0)" + | V_bits bs -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" + | V_int i -> Big_int.to_string i ^ "l" + | V_bool true -> "true" + | V_bool false -> "false" + | V_null -> "NULL" + | V_unit -> "UNIT" + | V_bit Sail2_values.B0 -> "UINT64_C(0)" + | V_bit Sail2_values.B1 -> "UINT64_C(1)" + | V_string str -> "\"" ^ str ^ "\"" + | V_ctor_kind str -> "Kind_" ^ Util.zencode_string str + | _ -> failwith "Cannot convert value to string" + +let rec string_of_fragment ?zencode:(zencode=true) = function + | F_id id when zencode -> Util.zencode_string (string_of_id id) + | F_id id -> string_of_id id + | F_ref id when zencode -> "&" ^ Util.zencode_string (string_of_id id) + | F_ref id -> "&" ^ string_of_id id + | F_lit v -> string_of_value v + | F_call (str, frags) -> + Printf.sprintf "%s(%s)" str (Util.string_of_list ", " (string_of_fragment ~zencode:zencode) frags) + | F_field (f, field) -> + Printf.sprintf "%s.%s" (string_of_fragment' ~zencode:zencode f) field + | F_op (f1, op, f2) -> + Printf.sprintf "%s %s %s" (string_of_fragment' ~zencode:zencode f1) op (string_of_fragment' ~zencode:zencode f2) + | F_unary (op, f) -> + op ^ string_of_fragment' ~zencode:zencode f + | F_have_exception -> "have_exception" + | F_current_exception -> "(*current_exception)" + | F_raw raw -> raw + | F_poly f -> string_of_fragment ~zencode:zencode f +and string_of_fragment' ?zencode:(zencode=true) f = + match f with + | F_op _ | F_unary _ -> "(" ^ string_of_fragment ~zencode:zencode f ^ ")" + | _ -> string_of_fragment ~zencode:zencode f + +(* String representation of ctyps here is only for debugging and + intermediate language pretty-printer. *) +and string_of_ctyp = function + | CT_lint -> "int" + | CT_lbits true -> "lbits(dec)" + | CT_lbits false -> "lbits(inc)" + | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" + | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" + | CT_sbits (n, true) -> "sbits(" ^ string_of_int n ^ ", dec)" + | CT_sbits (n, false) -> "sbits(" ^ string_of_int n ^ ", inc)" + | CT_fint n -> "int(" ^ string_of_int n ^ ")" + | CT_bit -> "bit" + | CT_unit -> "unit" + | CT_bool -> "bool" + | CT_real -> "real" + | CT_tup ctyps -> "(" ^ Util.string_of_list ", " string_of_ctyp ctyps ^ ")" + | CT_struct (id, _) | CT_enum (id, _) | CT_variant (id, _) -> string_of_id id + | CT_string -> "string" + | CT_vector (true, ctyp) -> "vector(dec, " ^ string_of_ctyp ctyp ^ ")" + | CT_vector (false, ctyp) -> "vector(inc, " ^ string_of_ctyp ctyp ^ ")" + | CT_list ctyp -> "list(" ^ string_of_ctyp ctyp ^ ")" + | CT_ref ctyp -> "ref(" ^ string_of_ctyp ctyp ^ ")" + | CT_poly -> "*" + +(** This function is like string_of_ctyp, but recursively prints all + constructors in variants and structs. Used for debug output. *) +and full_string_of_ctyp = function + | CT_tup ctyps -> "(" ^ Util.string_of_list ", " full_string_of_ctyp ctyps ^ ")" + | CT_struct (id, ctors) | CT_variant (id, ctors) -> + "struct " ^ string_of_id id + ^ "{ " + ^ Util.string_of_list ", " (fun (id, ctyp) -> string_of_id id ^ " : " ^ full_string_of_ctyp ctyp) ctors + ^ "}" + | CT_vector (true, ctyp) -> "vector(dec, " ^ full_string_of_ctyp ctyp ^ ")" + | CT_vector (false, ctyp) -> "vector(inc, " ^ full_string_of_ctyp ctyp ^ ")" + | CT_list ctyp -> "list(" ^ full_string_of_ctyp ctyp ^ ")" + | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" + | ctyp -> string_of_ctyp ctyp + +let rec map_ctyp f = function + | (CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ + | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp + | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) + | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) + | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) + | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) + | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) + | CT_variant (id, ctors) -> f (CT_variant (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) + +let rec ctyp_equal ctyp1 ctyp2 = + match ctyp1, ctyp2 with + | CT_lint, CT_lint -> true + | CT_lbits d1, CT_lbits d2 -> d1 = d2 + | CT_sbits (m1, d1), CT_sbits (m2, d2) -> m1 = m2 && d1 = d2 + | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2 + | CT_bit, CT_bit -> true + | CT_fint n, CT_fint m -> n = m + | CT_unit, CT_unit -> true + | CT_bool, CT_bool -> true + | CT_struct (id1, _), CT_struct (id2, _) -> Id.compare id1 id2 = 0 + | CT_enum (id1, _), CT_enum (id2, _) -> Id.compare id1 id2 = 0 + | CT_variant (id1, _), CT_variant (id2, _) -> Id.compare id1 id2 = 0 + | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> + List.for_all2 ctyp_equal ctyps1 ctyps2 + | CT_string, CT_string -> true + | CT_real, CT_real -> true + | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 + | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 + | CT_poly, CT_poly -> true + | _, _ -> false + +let rec ctyp_compare ctyp1 ctyp2 = + let lex_ord c1 c2 = if c1 = 0 then c2 else c1 in + match ctyp1, ctyp2 with + | CT_lint, CT_lint -> 0 + | CT_lint, _ -> 1 + | _, CT_lint -> -1 + + | CT_fint n, CT_fint m -> compare n m + | CT_fint _, _ -> 1 + | _, CT_fint _ -> -1 + + | CT_fbits (n, ord1), CT_fbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2) + | CT_fbits _, _ -> 1 + | _, CT_fbits _ -> -1 + + | CT_sbits (n, ord1), CT_sbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2) + | CT_sbits _, _ -> 1 + | _, CT_sbits _ -> -1 + + | CT_lbits ord1 , CT_lbits ord2 -> compare ord1 ord2 + | CT_lbits _, _ -> 1 + | _, CT_lbits _ -> -1 + + | CT_bit, CT_bit -> 0 + | CT_bit, _ -> 1 + | _, CT_bit -> -1 + + | CT_unit, CT_unit -> 0 + | CT_unit, _ -> 1 + | _, CT_unit -> -1 + + | CT_real, CT_real -> 0 + | CT_real, _ -> 1 + | _, CT_real -> -1 + + | CT_poly, CT_poly -> 0 + | CT_poly, _ -> 1 + | _, CT_poly -> -1 + + | CT_bool, CT_bool -> 0 + | CT_bool, _ -> 1 + | _, CT_bool -> -1 + + | CT_string, CT_string -> 0 + | CT_string, _ -> 1 + | _, CT_string -> -1 + + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_compare ctyp1 ctyp2 + | CT_ref _, _ -> 1 + | _, CT_ref _ -> -1 + + | CT_list ctyp1, CT_list ctyp2 -> ctyp_compare ctyp1 ctyp2 + | CT_list _, _ -> 1 + | _, CT_list _ -> -1 + + | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> + lex_ord (ctyp_compare ctyp1 ctyp2) (compare d1 d2) + | CT_vector _, _ -> 1 + | _, CT_vector _ -> -1 + + | ctyp1, ctyp2 -> String.compare (full_string_of_ctyp ctyp1) (full_string_of_ctyp ctyp2) + +module CT = struct + type t = ctyp + let compare ctyp1 ctyp2 = ctyp_compare ctyp1 ctyp2 +end + +module CTSet = Set.Make(CT) + +let rec ctyp_unify ctyp1 ctyp2 = + match ctyp1, ctyp2 with + | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> + List.concat (List.map2 ctyp_unify ctyps1 ctyps2) + + | CT_vector (b1, ctyp1), CT_vector (b2, ctyp2) when b1 = b2 -> + ctyp_unify ctyp1 ctyp2 + + | CT_list ctyp1, CT_list ctyp2 -> ctyp_unify ctyp1 ctyp2 + + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_unify ctyp1 ctyp2 + + | CT_poly, _ -> [ctyp2] + + | _, _ when ctyp_equal ctyp1 ctyp2 -> [] + | _, _ -> raise (Invalid_argument "ctyp_unify") + +let rec ctyp_suprema = function + | CT_lint -> CT_lint + | CT_lbits d -> CT_lbits d + | CT_fbits (_, d) -> CT_lbits d + | CT_sbits (_, d) -> CT_lbits d + | CT_fint _ -> CT_lint + | CT_unit -> CT_unit + | CT_bool -> CT_bool + | CT_real -> CT_real + | CT_bit -> CT_bit + | CT_tup ctyps -> CT_tup (List.map ctyp_suprema ctyps) + | CT_string -> CT_string + | CT_enum (id, ids) -> CT_enum (id, ids) + (* Do we really never want to never call ctyp_suprema on constructor + fields? Doing it causes issues for structs (see + test/c/stack_struct.sail) but it might be wrong to not call it + for nested variants... *) + | CT_struct (id, ctors) -> CT_struct (id, ctors) + | CT_variant (id, ctors) -> CT_variant (id, ctors) + | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) + | CT_list ctyp -> CT_list (ctyp_suprema ctyp) + | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) + | CT_poly -> CT_poly + +let rec ctyp_ids = function + | CT_enum (id, _) -> IdSet.singleton id + | CT_struct (id, ctors) | CT_variant (id, ctors) -> + IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) + | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps + | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit + | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty + +let rec unpoly = function + | F_poly f -> unpoly f + | F_call (call, fs) -> F_call (call, List.map unpoly fs) + | F_field (f, field) -> F_field (unpoly f, field) + | F_op (f1, op, f2) -> F_op (unpoly f1, op, unpoly f2) + | F_unary (op, f) -> F_unary (op, unpoly f) + | f -> f + +let rec is_polymorphic = function + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false + | CT_tup ctyps -> List.exists is_polymorphic ctyps + | CT_enum _ -> false + | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors + | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp + | CT_poly -> true + +let pp_id id = + string (string_of_id id) + +let pp_ctyp ctyp = + string (string_of_ctyp ctyp |> Util.yellow |> Util.clear) + +let pp_keyword str = + string ((str |> Util.red |> Util.clear) ^ " ") + +let pp_cval (frag, ctyp) = + string (string_of_fragment ~zencode:false frag) ^^ string " : " ^^ pp_ctyp ctyp + +let rec pp_clexp = function + | CL_id (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | CL_field (clexp, field) -> parens (pp_clexp clexp) ^^ string "." ^^ string field + | CL_tuple (clexp, n) -> parens (pp_clexp clexp) ^^ string "." ^^ string (string_of_int n) + | CL_addr clexp -> string "*" ^^ pp_clexp clexp + | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp + | CL_have_exception -> string "have_exception" + | CL_return ctyp -> string "return : " ^^ pp_ctyp ctyp + +let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = + match instr with + | I_decl (ctyp, id) -> + pp_keyword "var" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_if (cval, then_instrs, else_instrs, ctyp) -> + let pp_if_block = function + | [] -> string "{}" + | instrs -> surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + in + parens (pp_ctyp ctyp) ^^ space + ^^ pp_keyword "if" ^^ pp_cval cval + ^^ if short then + empty + else + pp_keyword " then" ^^ pp_if_block then_instrs + ^^ pp_keyword " else" ^^ pp_if_block else_instrs + | I_jump (cval, label) -> + pp_keyword "jump" ^^ pp_cval cval ^^ space ^^ string (label |> Util.blue |> Util.clear) + | I_block instrs -> + surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + | I_try_block instrs -> + pp_keyword "try" ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + | I_reset (ctyp, id) -> + pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_init (ctyp, id, cval) -> + pp_keyword "create" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval + | I_reinit (ctyp, id, cval) -> + pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval + | I_funcall (x, _, f, args) -> + separate space [ pp_clexp x; string "="; + string (string_of_id f |> Util.green |> Util.clear) ^^ parens (separate_map (string ", ") pp_cval args) ] + | I_copy (clexp, cval) -> + separate space [pp_clexp clexp; string "="; pp_cval cval] + | I_alias (clexp, cval) -> + pp_keyword "alias" ^^ separate space [pp_clexp clexp; string "="; pp_cval cval] + | I_clear (ctyp, id) -> + pp_keyword "kill" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_return cval -> + pp_keyword "return" ^^ pp_cval cval + | I_throw cval -> + pp_keyword "throw" ^^ pp_cval cval + | I_comment str -> + string ("// " ^ str |> Util.magenta |> Util.clear) + | I_label str -> + string (str |> Util.blue |> Util.clear) ^^ string ":" + | I_goto str -> + pp_keyword "goto" ^^ string (str |> Util.blue |> Util.clear) + | I_match_failure -> + pp_keyword "match_failure" + | I_end -> + pp_keyword "end" + | I_undefined ctyp -> + pp_keyword "undefined" ^^ pp_ctyp ctyp + | I_raw str -> + pp_keyword "C" ^^ string (str |> Util.cyan |> Util.clear) + +let pp_ctype_def = function + | CTD_enum (id, ids) -> + pp_keyword "enum" ^^ pp_id id ^^ string " = " + ^^ separate_map (string " | ") pp_id ids + | CTD_struct (id, fields) -> + pp_keyword "struct" ^^ pp_id id ^^ string " = " + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) fields) rbrace + | CTD_variant (id, ctors) -> + pp_keyword "union" ^^ pp_id id ^^ string " = " + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) ctors) rbrace + +let pp_cdef = function + | CDEF_spec (id, ctyps, ctyp) -> + pp_keyword "val" ^^ pp_id id ^^ string " : " ^^ parens (separate_map (comma ^^ space) pp_ctyp ctyps) ^^ string " -> " ^^ pp_ctyp ctyp + ^^ hardline + | CDEF_fundef (id, ret, args, instrs) -> + let ret = match ret with + | None -> empty + | Some id -> space ^^ pp_id id + in + pp_keyword "function" ^^ pp_id id ^^ ret ^^ parens (separate_map (comma ^^ space) pp_id args) ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_reg_dec (id, ctyp, instrs) -> + pp_keyword "register" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_type tdef -> pp_ctype_def tdef ^^ hardline + | CDEF_let (n, bindings, instrs) -> + let pp_binding (id, ctyp) = pp_id id ^^ string " : " ^^ pp_ctyp ctyp in + pp_keyword "let" ^^ string (string_of_int n) ^^ parens (separate_map (comma ^^ space) pp_binding bindings) ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace ^^ space + ^^ hardline + | CDEF_startup (id, instrs)-> + pp_keyword "startup" ^^ pp_id id ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_finish (id, instrs)-> + pp_keyword "finish" ^^ pp_id id ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + +(**************************************************************************) +(* 2. Dependency Graphs *) +(**************************************************************************) + +type graph_node = + | G_label of string + | G_instr of int * instr + | G_start + +let string_of_node = function + | G_label label -> label + | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) + | G_start -> "START" + +module Node = struct + type t = graph_node + let compare gn1 gn2 = + match gn1, gn2 with + | G_label str1, G_label str2 -> String.compare str1 str2 + | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 + | G_start , G_start -> 0 + | G_start , _ -> 1 + | _ , G_start -> -1 + | G_instr _, _ -> 1 + | _ , G_instr _ -> -1 +end + +module NodeGraph = Graph.Make(Node) + +module NM = Map.Make(Node) +module NS = Set.Make(Node) + +type dep_graph = NodeGraph.graph + +let rec fragment_deps = function + | F_id id | F_ref id -> IdSet.singleton id + | F_lit _ -> IdSet.empty + | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag + | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags) + | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2) + | F_current_exception -> IdSet.empty + | F_have_exception -> IdSet.empty + | F_raw _ -> IdSet.empty + +let cval_deps = function (frag, _) -> fragment_deps frag + +let rec clexp_deps = function + | CL_id (id, _) -> IdSet.singleton id + | CL_field (clexp, _) -> clexp_deps clexp + | CL_tuple (clexp, _) -> clexp_deps clexp + | CL_addr clexp -> clexp_deps clexp + | CL_have_exception -> IdSet.empty + | CL_current_exception _ -> IdSet.empty + | CL_return _ -> IdSet.empty + +(* Return the direct, read/write dependencies of a single instruction *) +let instr_deps = function + | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id + | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty + | I_jump (cval, label) -> cval_deps cval, IdSet.empty + | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp + | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp + | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp + | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id + | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty + | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty + | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty + | I_label label -> IdSet.empty, IdSet.empty + | I_goto label -> IdSet.empty, IdSet.empty + | I_undefined _ -> IdSet.empty, IdSet.empty + | I_match_failure -> IdSet.empty, IdSet.empty + | I_end -> IdSet.empty, IdSet.empty + +(* instrs_graph returns the control-flow graph for a list of + instructions. *) +let instrs_graph instrs = + let icounter = ref 0 in + let graph = ref NodeGraph.empty in + + let rec add_instr last_instrs (I_aux (instr, _) as iaux) = + incr icounter; + let node = G_instr (!icounter, iaux) in + match instr with + | I_block instrs | I_try_block instrs -> + List.fold_left add_instr last_instrs instrs + | I_if (_, then_instrs, else_instrs, _) -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + let n1 = List.fold_left add_instr [node] then_instrs in + let n2 = List.fold_left add_instr [node] else_instrs in + incr icounter; + let join = G_instr (!icounter, icomment "join") in + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; + [join] + | I_return _ -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] + | I_label label -> + graph := NodeGraph.add_edge' (G_label label) node !graph; + node :: last_instrs + | I_goto label -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edge' node (G_label label) !graph; + [] + | I_jump (cval, label) -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edges' (G_label label) [] !graph; + [node] + | I_match_failure -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] + | _ -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [node] + in + ignore (List.fold_left add_instr [G_start] instrs); + let graph = NodeGraph.fix_leaves !graph in + graph + +let make_dot id graph = + Util.opt_colors := false; + let to_string node = String.escaped (string_of_node node) in + let node_color = function + | G_start -> "lightpink" + | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" + | G_instr (_, I_aux (I_init _, _)) -> "springgreen" + | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" + | G_instr (_, I_aux (I_goto _, _)) -> "orange1" + | G_instr (_, I_aux (I_label _, _)) -> "white" + | G_instr (_, I_aux (I_raw _, _)) -> "khaki" + | G_instr (_, I_aux (I_return _, _)) -> "deeppink" + | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" + | G_instr _ -> "azure" + | G_label _ -> "lightpink" + in + let edge_color from_node to_node = + match from_node, to_node with + | G_start , _ -> "goldenrod4" + | G_label _, _ -> "darkgreen" + | _ , G_label _ -> "goldenrod4" + | G_instr _, G_instr _ -> "black" + | _ , _ -> "coral3" + in + let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in + NodeGraph.make_dot node_color edge_color to_string out_chan graph; + close_out out_chan + +let rec map_clexp_ctyp f = function + | CL_id (id, ctyp) -> CL_id (id, f ctyp) + | CL_field (clexp, field) -> CL_field (map_clexp_ctyp f clexp, field) + | CL_tuple (clexp, n) -> CL_tuple (map_clexp_ctyp f clexp, n) + | CL_addr clexp -> CL_addr (map_clexp_ctyp f clexp) + | CL_current_exception ctyp -> CL_current_exception (f ctyp) + | CL_have_exception -> CL_have_exception + | CL_return ctyp -> CL_return (f ctyp) + +let rec map_instr_ctyp f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl (ctyp, id) -> I_decl (f ctyp, id) + | I_init (ctyp1, id, (frag, ctyp2)) -> I_init (f ctyp1, id, (frag, f ctyp2)) + | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> + I_if ((frag, f ctyp1), List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs, f ctyp2) + | I_jump ((frag, ctyp), label) -> I_jump ((frag, f ctyp), label) + | I_funcall (clexp, extern, id, cvals) -> + I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals) + | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp)) + | I_alias (clexp, (frag, ctyp)) -> I_alias (map_clexp_ctyp f clexp, (frag, f ctyp)) + | I_clear (ctyp, id) -> I_clear (f ctyp, id) + | I_return (frag, ctyp) -> I_return (frag, f ctyp) + | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs) + | I_try_block instrs -> I_try_block (List.map (map_instr_ctyp f) instrs) + | I_throw (frag, ctyp) -> I_throw (frag, f ctyp) + | I_undefined ctyp -> I_undefined (f ctyp) + | I_reset (ctyp, id) -> I_reset (f ctyp, id) + | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2)) + | I_end -> I_end + | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr + in + I_aux (instr, aux) + +(** Map over each instruction within an instruction, bottom-up *) +let rec map_instr f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_init _ | I_reset _ | I_reinit _ + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp) + | I_block instrs -> + I_block (List.map (map_instr f) instrs) + | I_try_block instrs -> + I_try_block (List.map (map_instr f) instrs) + in + f (I_aux (instr, aux)) + +(** Map over each instruction in a cdef using map_instr *) +let cdef_map_instr f = function + | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs) + | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr f) instrs) + | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) + | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) + | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) + | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_type tdef -> CDEF_type tdef + +let ctype_def_map_ctyp f = function + | CTD_enum (id, ids) -> CTD_enum (id, ids) + | CTD_struct (id, ctors) -> CTD_struct (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) + | CTD_variant (id, ctors) -> CTD_variant (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) + +(** Map over each ctyp in a cdef using map_instr_ctyp *) +let cdef_map_ctyp f = function + | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, f ctyp, List.map (map_instr_ctyp f) instrs) + | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr_ctyp f) instrs) + | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) + | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) + | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) + | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) + | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) + +(* Map over all sequences of instructions contained within an instruction *) +let rec map_instrs f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr + | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) + | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> instr + in + I_aux (instr, aux) + +let rec instr_ids (I_aux (instr, _)) = + let reads, writes = instr_deps instr in + IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) + +let rec instr_reads (I_aux (instr, _)) = + let reads, _ = instr_deps instr in + IdSet.of_list (IdSet.elements reads) + +let rec instr_writes (I_aux (instr, _)) = + let _, writes = instr_deps instr in + IdSet.of_list (IdSet.elements writes) + +let rec filter_instrs f instrs = + let filter_instrs' = function + | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) + | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) + | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> + I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) + | instr -> instr + in + List.filter f (List.map filter_instrs' instrs) + +(** GLOBAL: label_counter is used to make sure all labels have unique + names. Like gensym_counter it should be safe to reset between + top-level definitions. **) +let label_counter = ref 0 + +let label str = + let str = str ^ string_of_int !label_counter in + incr label_counter; + str + +let cval_ctyp = function (_, ctyp) -> ctyp + +let rec clexp_ctyp = function + | CL_id (_, ctyp) -> ctyp + | CL_return ctyp -> ctyp + | CL_field (clexp, field) -> + begin match clexp_ctyp clexp with + | CT_struct (id, ctors) -> + begin + try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with + | Not_found -> failwith ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field) + end + | ctyp -> failwith ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp) + end + | CL_addr clexp -> + begin match clexp_ctyp clexp with + | CT_ref ctyp -> ctyp + | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) + end + | CL_tuple (clexp, n) -> + begin match clexp_ctyp clexp with + | CT_tup typs -> + begin + try List.nth typs n with + | _ -> failwith "Tuple assignment index out of bounds" + end + | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) + end + | CL_have_exception -> CT_bool + | CL_current_exception ctyp -> ctyp + +let rec instr_ctyps (I_aux (instr, aux)) = + match instr with + | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> + CTSet.singleton ctyp + | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> + CTSet.add ctyp (CTSet.singleton (cval_ctyp cval)) + | I_if (cval, instrs1, instrs2, ctyp) -> + CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) + |> CTSet.add (cval_ctyp cval) + |> CTSet.add ctyp + | I_funcall (clexp, _, _, cvals) -> + List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map cval_ctyp cvals) + |> CTSet.add (clexp_ctyp clexp) + | I_copy (clexp, cval) | I_alias (clexp, cval) -> + CTSet.add (clexp_ctyp clexp) (CTSet.singleton (cval_ctyp cval)) + | I_block instrs | I_try_block instrs -> + instrs_ctyps instrs + | I_throw cval | I_jump (cval, _) | I_return cval -> + CTSet.singleton (cval_ctyp cval) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_end -> + CTSet.empty + +and instrs_ctyps instrs = List.fold_left CTSet.union CTSet.empty (List.map instr_ctyps instrs) + +let ctype_def_ctyps = function + | CTD_enum _ -> [] + | CTD_struct (_, fields) -> List.map snd fields + | CTD_variant (_, ctors) -> List.map snd ctors + +let cdef_ctyps = function + | CDEF_reg_dec (_, ctyp, instrs) -> + CTSet.add ctyp (instrs_ctyps instrs) + | CDEF_spec (_, ctyps, ctyp) -> + CTSet.add ctyp (List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty ctyps) + | CDEF_fundef (_, _, _, instrs) | CDEF_startup (_, instrs) | CDEF_finish (_, instrs) -> + instrs_ctyps instrs + | CDEF_type tdef -> + List.fold_right CTSet.add (ctype_def_ctyps tdef) CTSet.empty + | CDEF_let (_, bindings, instrs) -> + List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map snd bindings) + |> CTSet.union (instrs_ctyps instrs) + +let rec c_ast_registers = function + | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast + | _ :: ast -> c_ast_registers ast + | [] -> [] + +let instr_split_at f = + let rec instr_split_at' f before = function + | [] -> (List.rev before, []) + | instr :: instrs when f instr -> (List.rev before, instr :: instrs) + | instr :: instrs -> instr_split_at' f (instr :: before) instrs + in + instr_split_at' f [] diff --git a/src/sail.ml b/src/sail.ml index 77f0e32d..813d8ec1 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -183,11 +183,8 @@ let options = Arg.align ([ Arg.Set C_backend.opt_static, " make generated C functions static"); ( "-trace", - Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml], + Arg.Tuple [Arg.Set Ocaml_backend.opt_trace_ocaml], " instrument output with tracing"); - ( "-smt_trace", - Arg.Tuple [Arg.Set C_backend.opt_smt_trace], - " instrument output with tracing for SMT"); ( "-cgen", Arg.Set opt_print_cgen, " generate CGEN source"); @@ -310,9 +307,6 @@ let options = Arg.align ([ ( "-dmagic_hash", Arg.Set Initial_check.opt_magic_hash, " (debug) allow special character # in identifiers"); - ( "-dfunction", - Arg.String (fun f -> C_backend.opt_debug_function := f), - " (debug) print debugging output for a single function"); ( "-dprofile", Arg.Set Profile.opt_profile, " (debug) provide basic profiling information for rewriting passes within Sail"); @@ -441,22 +435,22 @@ let main() = in let output_chan = match !opt_file_out with Some f -> open_out (f ^ ".c") | None -> stdout in Util.opt_warnings := true; - C_backend.compile_ast (C_backend.initial_ctx type_envs) output_chan (!opt_includes_c) ast_c; + C_backend.compile_ast type_envs output_chan (!opt_includes_c) ast_c; close_out output_chan else ()); (if !(opt_print_ir) then let ast_c = rewrite_ast_c type_envs ast in let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in - let ast_c, type_envs = Specialize.(specialize' 2 int_specialization_with_externs ast_c type_envs) in + let ast_c, type_envs = Specialize.(specialize' 2 int_specialization ast_c type_envs) in let output_chan = match !opt_file_out with | Some f -> Util.opt_colors := false; open_out (f ^ ".ir.sail") | None -> stdout in Util.opt_warnings := true; - let cdefs = C_backend.(bytecode_ast (initial_ctx_iterate type_envs) (List.map flatten_cdef) ast_c) in - let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Bytecode_util.pp_cdef cdefs) in + let cdefs, _ = C_backend.jib_of_ast type_envs ast_c in + let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Jib_util.pp_cdef cdefs) in output_string output_chan (str ^ "\n"); close_out output_chan else ()); -- cgit v1.2.3 From 1caa56ca356432112cb4457a07b35754c1f85887 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Fri, 8 Mar 2019 17:59:44 +0000 Subject: Rewriter: Cleanup old sizeof rewrites Shouldn't affect anything as this is done by the typechecker now. Also remove some unfinished tracing code from c_backend.ml --- src/jib/c_backend.ml | 53 ------- src/rewrites.ml | 409 --------------------------------------------------- 2 files changed, 462 deletions(-) (limited to 'src') diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml index a08261fc..aab2894e 100644 --- a/src/jib/c_backend.ml +++ b/src/jib/c_backend.ml @@ -2222,59 +2222,6 @@ let sgen_finish = function Printf.sprintf " finish_%s();" (sgen_id id) | _ -> assert false -let instrument_tracing ctx = - let module StringSet = Set.Make(String) in - let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in - let rec instrument = function - | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> - let trace_start = - iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id))) - in - let trace_arg cval = - let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval)) - else - iraw "trace_unknown();" - in - let rec trace_args = function - | [] -> [] - | [cval] -> [trace_arg cval] - | cval :: cvals -> - trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals - in - let trace_end = iraw "trace_end();" in - let trace_ret = iraw "trace_unknown();" - (* - let ctyp_name = sgen_ctyp_name ctyp in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) - else - iraw "trace_unknown();" - *) - in - [trace_start] - @ trace_args args - @ [iraw "trace_argend();"; - instr; - trace_end; - trace_ret; - iraw "trace_retend();"] - @ instrument instrs - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs - - | instr :: instrs -> instr :: instrument instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - CDEF_fundef (function_id, heap_return, args, instrument body) - | cdef -> cdef - let rec get_recursive_functions (Defs defs) = match defs with | DEF_internal_mutrec fundefs :: defs -> diff --git a/src/rewrites.ml b/src/rewrites.ml index f6a004b3..ec074607 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -324,375 +324,6 @@ let rewrite_bitvector_exps env defs = else defs -(* Re-write trivial sizeof expressions - trivial meaning that the - value of the sizeof can be directly inferred from the type - variables in scope. *) -let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = - let extract_typ_var l env nexp (id, (_, typ)) = - let var = E_aux (E_id id, (l, mk_tannot env typ no_effect)) in - match destruct_atom_nexp env typ with - | Some size when prove __POS__ env (nc_eq size nexp) -> Some var - (* AA: This next case is a bit of a hack... is there a more - general way to deal with trivial nexps that are offset by - constants? This will resolve a 'n - 1 sizeof when 'n is in - scope. *) - | Some size when prove __POS__ env (nc_eq (nsum size (nint 1)) nexp) -> - let one_exp = infer_exp env (mk_lit_exp (L_num (Big_int.of_int 1))) in - Some (E_aux (E_app (mk_id "add_atom", [var; one_exp]), (gen_loc l, mk_tannot env (atom_typ (nsum size (nint 1))) no_effect))) - | _ -> - begin - match destruct_vector env typ with - | Some (len, _, _) when prove __POS__ env (nc_eq len nexp) -> - Some (E_aux (E_app (mk_id "length", [var]), (l, mk_tannot env (atom_typ len) no_effect))) - | _ -> None - end - in - let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = - match nexp_aux with - | Nexp_sum (n1, n2) -> - mk_exp ~loc:l (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2])) - | Nexp_minus (n1, n2) -> - mk_exp ~loc:l (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2])) - | Nexp_times (n1, n2) -> - mk_exp ~loc:l (E_app (mk_id "mult_atom", [split_nexp n1; split_nexp n2])) - | Nexp_neg nexp -> - mk_exp ~loc:l (E_app (mk_id "negate_atom", [split_nexp nexp])) - | Nexp_app (f, [n1; n2]) when string_of_id f = "div" -> - (* We should be more careful about the right division here *) - mk_exp ~loc:l (E_app (mk_id "div", [split_nexp n1; split_nexp n2])) - | _ -> - mk_exp ~loc:l (E_sizeof nexp) - in - let is_int_typ env v _ = function - | (_, Typ_aux (Typ_app (f, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _)) - when Kid.compare v v' = 0 && string_of_id f = "atom" -> - true - | _ -> false - in - let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = - let env = env_of orig_exp in - match e_aux with - | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect)) - | E_sizeof nexp -> - begin - let locals = Env.get_locals env in - match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with - | Nexp_aux (Nexp_constant c, _) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect)) - | Nexp_aux (Nexp_var v, _) when Bindings.exists (is_int_typ env v) locals -> - let id = fst (Bindings.choose (Bindings.filter (is_int_typ env v) locals)) in - E_aux (E_id id, (l, mk_tannot env (atom_typ nexp) no_effect)) - | _ -> - let locals = Env.get_locals env in - let exps = Bindings.bindings locals - |> List.map (extract_typ_var l env nexp) - |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) - |> List.concat - in - match exps with - | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) - | [] when split_sizeof -> - fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) - | [] -> orig_exp - end - | _ -> orig_exp - and rewrite_e_sizeof split_sizeof = - { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } - in - (fun env -> rewrite_defs_base_parallel 4 { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }), rewrite_e_aux true - -(* Rewrite sizeof expressions with type-level variables to - term-level expressions - - For each type-level variable used in a sizeof expressions whose value cannot - be directly extracted from existing parameters of the surrounding function, - a further parameter is added; calls to the function are rewritten - accordingly (possibly causing further rewriting in the calling function) *) -let rewrite_sizeof env (Defs defs) = - let sizeof_frees exp = - fst (fold_exp - { (compute_exp_alg KidSet.empty KidSet.union) with - e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) } - exp) in - - (* Collect nexps whose values can be obtained directly from a pattern bind *) - let nexps_from_params pat = - fst (fold_pat - { (compute_pat_alg [] (@)) with - p_aux = (fun ((v,pat),((l,_) as annot)) -> - let v' = match pat with - | P_id id | P_as (_, id) -> - let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in - (match typ with - | Typ_app (atom, [A_aux (A_nexp nexp, _)]) - when string_of_id atom = "atom" -> - [nexp, E_id id] - | Typ_app (vector, _) when string_of_id vector = "vector" -> - let id_length = Id_aux (Id "length", gen_loc l) in - (try - (match Env.get_val_spec id_length (env_of_annot annot) with - | _ -> - let (len,_,_) = vector_typ_args_of typ_aux in - let exp = E_app (id_length, [E_aux (E_id id, annot)]) in - [len, exp]) - with - | _ -> []) - | _ -> []) - | _ -> [] in - (v @ v', P_aux (pat,annot)))} pat) in - - (* Substitute collected values in sizeof expressions *) - let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = - try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) - with - | Not_found -> - let binop nexp1 op nexp2 = E_app_infix ( - E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), - Id_aux (Id op, Parse_ast.Unknown), - E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) - ) in - let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in - (match nexp with - | Nexp_constant i -> E_lit (L_aux (L_num i, l)) - | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 - | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 - | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 - | _ -> E_sizeof nexp_aux) in - - let ex_regex = Str.regexp "'ex[0-9]+" in - - (* Rewrite calls to functions which have had parameters added to pass values - of type-level variables; these are added as sizeof expressions first, and - then further rewritten as above. *) - let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = - let env = env_of_annot annot in - let full_exp = E_aux (exp, annot) in - let orig_exp = E_aux (exp_orig, annot) in - match exp with - | E_app (f, args) -> - if Bindings.mem f param_map then - (* Retrieve instantiation of the type variables of the called function - for the given parameters in the original environment *) - let inst = - try instantiation_of orig_exp with - | Type_error (_, l, err) -> - raise (Reporting.err_typ l (Type_error.string_of_type_error err)) in - (* Rewrite the inst using orig_kid so that each type variable has it's - original name rather than a mangled typechecker name *) - let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in - let kid_exp kid = begin - (* We really don't want to see an existential here! *) - assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); - let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in - match uvar with - | Some (A_aux (A_nexp nexp, _)) -> - let sizeof = E_aux (E_sizeof nexp, (l, mk_tannot env (atom_typ nexp) no_effect)) in - (try rewrite_trivial_sizeof_exp sizeof with - | Type_error (_, l, err) -> - raise (Reporting.err_typ l (Type_error.string_of_type_error err))) - (* If the type variable is Not_found then it was probably - introduced by a P_var pattern, so it likely exists as - a variable in scope. It can't be an existential because the assert rules that out. *) - | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) - | _ -> - raise (Reporting.err_unreachable l __POS__ - ("failed to infer nexp for type variable " ^ string_of_kid kid ^ - " of function " ^ string_of_id f)) - end in - let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in - (E_aux (E_app (f, kid_exps @ args), annot), orig_exp) - else (full_exp, orig_exp) - | _ -> (full_exp, orig_exp) in - - (* Plug this into a folding algorithm that also keeps around a copy of the - original expressions, which we use to infer instantiations of type variables - in the original environments *) - let copy_exp_alg = - { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) - ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) - ; e_id = (fun id -> (E_id id, E_id id)) - ; e_ref = (fun id -> (E_ref id, E_ref id)) - ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) - ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) - ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) - ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) - ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) - ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) - ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) - ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) - ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) - ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) - ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) - ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) - ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) - ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) - ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) - ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) - ; e_record = (fun fexps -> let (fexps, fexps') = List.split fexps in (E_record fexps, E_record fexps')) - ; e_record_update = (fun ((e1,e1'),fexps) -> let (fexps, fexps') = List.split fexps in (E_record_update (e1,fexps), E_record_update (e1',fexps'))) - ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) - ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) - ; e_try = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_try (e1,pexps), E_try (e1',pexps'))) - ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) - ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) - ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) - ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) - ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) - ; e_throw = (fun (e1,e1') -> (E_throw (e1), E_throw (e1'))) - ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) - ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) - ; e_var = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_var (lexp,e2,e3), E_var (lexp',e2',e3'))) - ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) - ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) - ; e_internal_value = (fun v -> (E_internal_value v, E_internal_value v)) - ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) - ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) - ; lEXP_deref = (fun (e, e') -> (LEXP_deref e, LEXP_deref e')) - ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) - ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) - ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) - ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) - ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) - ; lEXP_vector_concat = (fun lexps -> let (lexps,lexps') = List.split lexps in (LEXP_vector_concat lexps, LEXP_vector_concat lexps')) - ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) - ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) - ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) - ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) - ; def_val_empty = (Def_val_empty, Def_val_empty) - ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) - ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) - ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) - ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) - ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) - ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) - ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) - ; pat_alg = id_pat_alg - } in - - let rewrite_sizeof_fun params_map - (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = - let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pexp), annot)) (funcls,nvars) = - let pat,guard,exp,pannot = destruct_pexp pexp in - let nmap = nexps_from_params pat in - (* first rewrite calls to other functions... *) - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - (* ... then rewrite sizeof expressions in current function body *) - let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in - let guard' = match guard with - | Some guard -> - (* As above *) - let guard' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } guard) in - Some (fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } guard') - | None -> None in - let pexp' = construct_pexp (pat,guard',exp'',pannot) in - (FCL_aux (FCL_Funcl (id,pexp'), annot) :: funcls, - KidSet.union nvars (sizeof_frees exp'')) in - let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in - (* Add a parameter for each remaining free type-level variable in a - sizeof expression *) - let kid_typ kid = atom_typ (nvar kid) in - let kid_annot kid = simple_annot l (kid_typ kid) in - let kid_pat kid = - P_aux (P_typ (kid_typ kid, - P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)), - kid_annot kid)), kid_annot kid) in - let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in - let kid_typs = List.map kid_typ (KidSet.elements nvars) in - let kid_pats = List.map kid_pat (KidSet.elements nvars) in - let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in - let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pexp), annot) as funcl) = - let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = - let penv = env_of_annot pannot in - let peff = effect_of_annot (snd pannot) in - if KidSet.is_empty nvars then paux else - match typ_of_pat paux with - | Typ_aux (Typ_tup typs, _) -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in - (match pat with - | P_tup pats -> - P_aux (P_tup (kid_pats @ pats), (l, mk_tannot penv ptyp' peff)) - | P_wild -> P_aux (pat, (l, mk_tannot penv ptyp' peff)) - | P_typ (Typ_aux (Typ_tup typs, l), pat) -> - P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), - rewrite_pat pat), (l, mk_tannot penv ptyp' peff)) - | P_as (_, id) | P_id id -> - (* adding parameters here would change the type of id; - we should remove the P_as/P_id here and add a let-binding to the body *) - raise (Reporting.err_todo l - "rewriting as- or id-patterns for sizeof expressions not yet implemented") - | _ -> - raise (Reporting.err_unreachable l __POS__ - "unexpected pattern while rewriting function parameters for sizeof expressions")) - | ptyp -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in - P_aux (P_tup (kid_pats @ [paux]), (l, mk_tannot penv ptyp' peff)) in - let pat,guard,exp,pannot = destruct_pexp pexp in - let pat' = rewrite_pat pat in - let guard' = match guard with - | Some guard -> Some (fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } guard) - | None -> None in - let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in - let pexp' = construct_pexp (pat',guard',exp',pannot) in - FCL_aux (FCL_Funcl (id, pexp'), annot) in - let funcls = List.map rewrite_funcl_params funcls in - let fd = FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot) in - let params_map = - if KidSet.is_empty nvars then params_map else - Bindings.add (id_of_fundef fd) nvars params_map in - (params_map, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in - - let rewrite_sizeof_def (params_map, defs) = function - | DEF_fundef fd -> - let (params_map', fd') = rewrite_sizeof_fun params_map fd in - (params_map', defs @ [DEF_fundef fd']) - | DEF_internal_mutrec fds -> - let rewrite_fd (params_map, fds) fd = - let (params_map', fd') = rewrite_sizeof_fun params_map fd in - (params_map', fds @ [fd']) in - (* TODO Split rewrite_sizeof_fun into an analysis and a rewrite pass, - so that we can call the analysis until a fixpoint is reached and then - rewrite the mutually recursive functions *) - let (params_map', fds') = List.fold_left rewrite_fd (params_map, []) fds in - (params_map', defs @ [DEF_internal_mutrec fds']) - | DEF_val (LB_aux (lb, annot)) -> - begin - let lb' = match lb with - | LB_val (pat, exp) -> - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - LB_val (pat, exp') in - (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) - end - | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) -> - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - (params_map, defs @ [DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp'), annot))]) - | def -> - (params_map, defs @ [def]) in - - let rewrite_sizeof_valspec params_map def = - let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id = - if Bindings.mem id params_map then - let kid_typs = List.map (fun kid -> atom_typ (nvar kid)) - (KidSet.elements (Bindings.find id params_map)) in - let typ' = match typ with - | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) -> - Typ_aux (Typ_fn (kid_typs @ vtyp_args, vtyp_ret, declared_eff), vl) - | _ -> - raise (Reporting.err_typ l "val spec with non-function type") in - TypSchm_aux (TypSchm_ts (tq, typ'), l) - else ts in - match def with - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) -> - DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) - | def -> def - in - - let (params_map, defs) = List.fold_left rewrite_sizeof_def - (Bindings.empty, []) defs in - let defs = List.map (rewrite_sizeof_valspec params_map) defs in - (* Defs defs *) - fst (Type_error.check initial_env (Defs defs)) - let rewrite_defs_remove_assert defs = let e_assert ((E_aux (eaux, (l, _)) as exp), str) = match eaux with | E_constraint _ -> @@ -2302,41 +1933,6 @@ let rewrite_fix_val_specs env (Defs defs) = Defs defs (* else Defs defs *) -(* Turn constraints into numeric expressions with sizeof *) -let rewrite_constraint = - let rec rewrite_nc env (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux l env nc_aux) - and rewrite_nc_aux l env = function - | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) - | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) - | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) - | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) - | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "&", rewrite_nc env nc2) - | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "|", rewrite_nc env nc2) - | NC_false -> E_lit (mk_lit L_false) - | NC_true -> E_lit (mk_lit L_true) - | NC_set (kid, []) -> E_lit (mk_lit (L_false)) - | NC_set (kid, int :: ints) -> - let kid_eq kid int = nc_eq (nvar kid) (nconstant int) in - unaux_exp (rewrite_nc env (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints)) - | NC_app (f, [A_aux (A_bool nc, _)]) when string_of_id f = "not" -> - E_app (mk_id "not_bool", [rewrite_nc env nc]) - | NC_app (f, args) -> - unaux_exp (rewrite_nc env (Env.expand_constraint_synonyms env (mk_nc (NC_app (f, args))))) - | NC_var v -> - (* Would be better to translate change E_sizeof to take a kid, then rewrite to E_sizeof *) - E_id (id_of_kid v) - in - let rewrite_e_aux (E_aux (e_aux, (l, _)) as exp) = - match e_aux with - | E_constraint nc -> - locate (fun _ -> gen_loc l) (check_exp (env_of exp) (rewrite_nc (env_of exp) nc) (atom_bool_typ nc)) - | _ -> exp - in - - let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in - - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } - let rewrite_type_union_typs rw_typ (Tu_aux (Tu_ty_id (typ, id), annot)) = Tu_aux (Tu_ty_id (rw_typ typ, id), annot) @@ -5093,10 +4689,8 @@ let rewrite_defs_lem = [ ("split_execute", rewrite_split_fun_ctor_pats "execute"); ("recheck_defs", recheck_defs); ("exp_lift_assign", rewrite_defs_exp_lift_assign); - (* ("constraint", rewrite_constraint); *) (* ("remove_assert", rewrite_defs_remove_assert); *) ("top_sort_defs", fun _ -> top_sort_defs); - ("trivial_sizeof", rewrite_trivial_sizeof); (* ("sizeof", rewrite_sizeof); *) ("early_return", rewrite_defs_early_return); ("fix_val_specs", rewrite_fix_val_specs); @@ -5138,12 +4732,9 @@ let rewrite_defs_coq = [ ("minimise_recursive_functions", minimise_recursive_functions); ("recheck_defs", recheck_defs); ("exp_lift_assign", rewrite_defs_exp_lift_assign); - (* ("constraint", rewrite_constraint); *) (* ("remove_assert", rewrite_defs_remove_assert); *) ("move_termination_measures", move_termination_measures); ("top_sort_defs", fun _ -> top_sort_defs); - ("trivial_sizeof", rewrite_trivial_sizeof); - ("sizeof", rewrite_sizeof); ("early_return", rewrite_defs_early_return); (* merge funcls before adding the measure argument so that it doesn't disappear into an internal pattern match *) -- cgit v1.2.3 From 1d854bb23ffd4bdfad05621ddb8842e7d465baa7 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 9 Mar 2019 17:25:35 +0000 Subject: Adds missing bits for DC/IC --- src/lem_interp/sail2_instr_kinds.lem | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'src') diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/lem_interp/sail2_instr_kinds.lem index eadc85bf..bd3a3eb7 100644 --- a/src/lem_interp/sail2_instr_kinds.lem +++ b/src/lem_interp/sail2_instr_kinds.lem @@ -203,6 +203,30 @@ instance (Show trans_kind) end end +(* cache maintenance instructions *) +type cache_op_kind = + (* AArch64 DC *) + | Cache_op_D_IVAC | Cache_op_D_ISW | Cache_op_D_CSW | Cache_op_D_CISW + | Cache_op_D_ZVA | Cache_op_D_CVAC | Cache_op_D_CVAU | Cache_op_D_CIVAC + (* AArch64 IC *) + | Cache_op_I_IALLUIS | Cache_op_I_IALLU | Cache_op_I_IVAU + +instance (Show cache_op_kind) + let show = function + | Cache_op_D_IVAC -> "Cache_op_D_IVAC" + | Cache_op_D_ISW -> "Cache_op_D_ISW" + | Cache_op_D_CSW -> "Cache_op_D_CSW" + | Cache_op_D_CISW -> "Cache_op_D_CISW" + | Cache_op_D_ZVA -> "Cache_op_D_ZVA" + | Cache_op_D_CVAC -> "Cache_op_D_CVAC" + | Cache_op_D_CVAU -> "Cache_op_D_CVAU" + | Cache_op_D_CIVAC -> "Cache_op_D_CIVAC" + | Cache_op_I_IALLUIS -> "Cache_op_I_IALLUIS" + | Cache_op_I_IALLU -> "Cache_op_I_IALLU" + | Cache_op_I_IVAU -> "Cache_op_I_IVAU" + end +end + type instruction_kind = | IK_barrier of barrier_kind | IK_mem_read of read_kind @@ -213,6 +237,7 @@ type instruction_kind = and branch/jump (single nia of kind NIA_concrete_address) *) | IK_trans of trans_kind | IK_simple of unit + | IK_cache_op of cache_op_kind instance (Show instruction_kind) @@ -224,6 +249,7 @@ instance (Show instruction_kind) | IK_branch () -> "IK_branch" | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) | IK_simple () -> "IK_simple" + | IK_cache_op cache_kind -> "IK_cache_op " ^ (show cache_kind) end end -- cgit v1.2.3 From 9c4c0e8770a43bb097df243050163afd1b31cc8f Mon Sep 17 00:00:00 2001 From: Alasdair Date: Sat, 9 Mar 2019 17:41:14 +0000 Subject: C: Fix miscompilation of constrained struct field access For a Int-parameterised struct F('x: Int) = ... the optimizer would attempt to optimize field access in cases where 'x was known to constrain the types of the struct fields only locally. Which would create a type error in the generated C. Now we always use the type from the global struct type. However, we previously weren't using struct type quantifiers to optimize the field representation, which we now do. Also rename some utility functions to better match the List functions in the OCaml stdlib. --- src/jib/jib_compile.ml | 34 ++++++++++++++++++++++++++++++---- src/jib/jib_compile.mli | 5 ++++- src/jib/jib_util.ml | 2 +- src/sail.ml | 3 +++ src/util.ml | 9 +++++++-- src/util.mli | 7 ++++++- 6 files changed, 51 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index 8411f464..36a28d9f 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -57,6 +57,7 @@ open Value2 open Anf +let opt_debug_function = ref "" let opt_memo_cache = ref false (**************************************************************************) @@ -773,9 +774,19 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = (fun clexp -> icomment "unreachable after throw"), [] - | AE_field (aval, id, typ) -> - let ctyp = ctyp_of_typ ctx typ in + | AE_field (aval, id, _) -> let setup, cval, cleanup = compile_aval l ctx aval in + let ctyp = match cval_ctyp cval with + | CT_struct (struct_id, fields) -> + begin match Util.assoc_compare_opt Id.compare id fields with + | Some ctyp -> ctyp + | None -> + raise (Reporting.err_unreachable l __POS__ + ("Struct " ^ string_of_id struct_id ^ " does not have expected field " ^ string_of_id id ^ "?")) + end + | _ -> + raise (Reporting.err_unreachable l __POS__ "Field access on non-struct type in ANF representation!") + in setup, (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)), cleanup @@ -846,8 +857,11 @@ let compile_type_def ctx (TD_aux (type_def, (l, _))) = CTD_enum (id, ids), { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } - | TD_record (id, _, ctors, _) -> - let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in + | TD_record (id, typq, ctors, _) -> + let record_ctx = { ctx with local_env = add_typquant l typq ctx.local_env } in + let ctors = + List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ record_ctx typ) ctors) Bindings.empty ctors + in CTD_struct (id, Bindings.bindings ctors), { ctx with records = Bindings.add id ctors ctx.records } @@ -1149,6 +1163,18 @@ and compile_def' n total ctx = function let instrs = arg_setup @ destructure @ setup @ [call (CL_return ret_ctyp)] @ cleanup @ destructure_cleanup @ arg_cleanup in let instrs = fix_early_return (CL_return ret_ctyp) instrs in let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in + + if Id.compare (mk_id !opt_debug_function) id = 0 then + let header = + Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) + (Util.string_of_list ", " string_of_id (List.map fst compiled_args)) + (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps) + Util.(string_of_ctyp ret_ctyp |> yellow |> clear) + in + prerr_endline (Util.header header (List.length arg_ctyps + 2)); + prerr_endline (Pretty_print_sail.to_string PPrint.(separate_map hardline pp_instr instrs)) + else (); + [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli index 50054149..92a0d06a 100644 --- a/src/jib/jib_compile.mli +++ b/src/jib/jib_compile.mli @@ -53,7 +53,10 @@ open Ast open Ast_util open Jib open Type_check - + +(** Print the IR representation of a specific function. *) +val opt_debug_function : string ref + (** Context for compiling Sail to Jib. We need to pass a (global) typechecking environment given by checking the full AST. We have to provide a conversion function from Sail types into Jib types, as diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml index d9c6a541..17227875 100644 --- a/src/jib/jib_util.ml +++ b/src/jib/jib_util.ml @@ -466,7 +466,7 @@ let pp_id id = string (string_of_id id) let pp_ctyp ctyp = - string (string_of_ctyp ctyp |> Util.yellow |> Util.clear) + string (full_string_of_ctyp ctyp |> Util.yellow |> Util.clear) let pp_keyword str = string ((str |> Util.red |> Util.clear) ^ " ") diff --git a/src/sail.ml b/src/sail.ml index 813d8ec1..50719776 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -307,6 +307,9 @@ let options = Arg.align ([ ( "-dmagic_hash", Arg.Set Initial_check.opt_magic_hash, " (debug) allow special character # in identifiers"); + ( "-dfunction", + Arg.String (fun f -> Jib_compile.opt_debug_function := f), + " (debug) print debugging output for a single function"); ( "-dprofile", Arg.Set Profile.opt_profile, " (debug) provide basic profiling information for rewriting passes within Sail"); diff --git a/src/util.ml b/src/util.ml index 0ff00df1..251fb3eb 100644 --- a/src/util.ml +++ b/src/util.ml @@ -149,11 +149,16 @@ let rec power i tothe = then 1 else i * power i (tothe - 1) -let rec assoc_maybe eq l k = +let rec assoc_equal_opt eq k l = match l with | [] -> None - | (k',v)::l -> if (eq k k') then Some v else assoc_maybe eq l k + | (k',v)::l -> if (eq k k') then Some v else assoc_equal_opt eq k l +let rec assoc_compare_opt cmp k l = + match l with + | [] -> None + | (k',v)::l -> if cmp k k' = 0 then Some v else assoc_compare_opt cmp k l + let rec compare_list f l1 l2 = match (l1,l2) with | ([],[]) -> 0 diff --git a/src/util.mli b/src/util.mli index 51504941..013bdcda 100644 --- a/src/util.mli +++ b/src/util.mli @@ -72,8 +72,13 @@ val remove_duplicates : 'a list -> 'a list (** [remove_dups compare eq l] as remove_duplicates but with parameterised comparison and equality *) val remove_dups : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'a list -> 'a list -val assoc_maybe : ('a -> 'a -> bool) -> ('a * 'b) list -> 'a -> 'b option +(** [assoc_equal_opt] and [assoc_compare_opt] are like List.assoc_opt + but take equality/comparison functions as arguments, rather than + relying on OCaml's built in equality *) +val assoc_equal_opt : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option +val assoc_compare_opt : ('a -> 'a -> int) -> 'a -> ('a * 'b) list -> 'b option + val power : int -> int -> int (** {2 Option Functions} *) -- cgit v1.2.3 From 711de1e76e82026e361f232010304175f0542c3d Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 11 Mar 2019 13:03:07 +0000 Subject: Improve ocamldoc comments Check in a slightly nicer stylesheet for OCamldoc generated documentation in etc. Most just add a maximum width and increase the font size because the default looks absolutely terrible on high-DPI monitors. Move val_spec_ids out of initial_check and into ast_util where it probably belongs. Rename some functions in util.ml to better match the OCaml stdlib. --- src/ast_util.ml | 12 ++ src/ast_util.mli | 310 +++++++++++++++++++++++++++++------------------- src/initial_check.ml | 14 +-- src/initial_check.mli | 23 ++-- src/isail.ml | 10 +- src/jib/anf.ml | 25 ---- src/jib/anf.mli | 46 ++++++- src/jib/jib_compile.mli | 7 ++ src/ocaml_backend.ml | 2 +- src/pp.mli | 58 --------- src/pretty_print_coq.ml | 2 +- src/pretty_print_lem.ml | 2 +- src/rewriter.mli | 8 +- src/rewrites.ml | 2 +- src/sail.odocl | 20 ++-- src/specialize.ml | 4 +- src/type_check.mli | 47 +++++--- src/util.ml | 20 +--- src/util.mli | 63 +++++----- 19 files changed, 350 insertions(+), 325 deletions(-) delete mode 100644 src/pp.mli (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 79b5b0eb..96849f88 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -986,6 +986,18 @@ let ids_of_def = function let ids_of_defs (Defs defs) = List.fold_left IdSet.union IdSet.empty (List.map ids_of_def defs) +let val_spec_ids (Defs defs) = + let val_spec_id (VS_aux (vs_aux, _)) = + match vs_aux with + | VS_val_spec (_, id, _, _) -> id + in + let rec vs_ids = function + | DEF_spec vs :: defs -> val_spec_id vs :: vs_ids defs + | def :: defs -> vs_ids defs + | [] -> [] + in + IdSet.of_list (vs_ids defs) + module BE = struct type t = base_effect let compare be1 be2 = String.compare (string_of_base_effect be1) (string_of_base_effect be2) diff --git a/src/ast_util.mli b/src/ast_util.mli index 750d3730..815ef421 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -48,7 +48,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -(** Utilities for operating on Sail ASTs *) +(** Utilities and helper functions for operating on Sail ASTs *) open Ast module Big_int = Nat_big_num @@ -56,16 +56,26 @@ module Big_int = Nat_big_num type mut = Immutable | Mutable (** [lvar] is the type of variables - they can either be registers, - local mutable or immutable variables, nullary union constructors - (i.e. None in option), or unbound identifiers *) + local mutable or immutable variables constructors or unbound + identifiers. *) type 'a lvar = Register of effect * effect * 'a | Enum of 'a | Local of mut * 'a | Unbound (** Note: Partial function -- fails for Unknown lvars *) val lvar_typ : 'a lvar -> 'a +(** The empty annotation. Should be used carefully because it can + result in unhelpful error messgaes. However a common pattern is + generating code with [no_annot], then adding location information + with the various [locate_] functions in this module. *) val no_annot : unit annot + +(** [gen_loc l] takes a location l and generates a location which + means 'generated from location l'. This is useful for debugging + errors that occur in generated code. *) val gen_loc : Parse_ast.l -> Parse_ast.l +(** {2 Functions for building (untyped) AST elements} *) + val mk_id : string -> id val mk_kid : string -> kid val mk_ord : order_aux -> order @@ -92,6 +102,11 @@ val mk_fexp : id -> unit exp -> unit fexp val mk_letbind : unit pat -> unit exp -> unit letbind val mk_kopt : kind_aux -> kid -> kinded_id +val inc_ord : order +val dec_ord : order + +(** {2 Unwrap aux constructors} *) + val unaux_exp : 'a exp -> 'a exp_aux val unaux_pat : 'a pat -> 'a pat_aux val unaux_nexp : nexp -> nexp_aux @@ -100,26 +115,33 @@ val unaux_typ : typ -> typ_aux val unaux_kind : kind -> kind_aux val unaux_constraint : n_constraint -> n_constraint_aux +(** {2 Destruct type annotated patterns and expressions} *) + +(** [untyp_pat (P_aux (P_typ (typ, pat)), _)] returns [Some (pat, + typ)] or [None] if the pattern does not match. *) val untyp_pat : 'a pat -> 'a pat * typ option + +(** Same as [untyp_pat], but for [E_cast] nodes *) val uncast_exp : 'a exp -> 'a exp * typ option -val inc_ord : order -val dec_ord : order +(** {2 Utilites for working with kinded_ids} *) -(* Utilites for working with kinded_ids *) val kopt_kid : kinded_id -> kid val kopt_kind : kinded_id -> kind + val is_int_kopt : kinded_id -> bool val is_order_kopt : kinded_id -> bool val is_typ_kopt : kinded_id -> bool val is_bool_kopt : kinded_id -> bool -(* Some handy utility functions for constructing types. *) +(** {2 Utility functions for constructing types} *) + val mk_typ : typ_aux -> typ val mk_typ_arg : typ_arg_aux -> typ_arg val mk_id_typ : id -> typ -(* Sail builtin types. *) +(** {2 Sail builtin types} *) + val unknown_typ : typ val int_typ : typ val nat_typ : typ @@ -140,18 +162,128 @@ val exc_typ : typ val tuple_typ : typ list -> typ val function_typ : typ list -> typ -> effect -> typ -val no_effect : effect -val mk_effect : base_effect_aux list -> effect +val is_unit_typ : typ -> bool +val is_number : typ -> bool +val is_ref_typ : typ -> bool +val is_vector_typ : typ -> bool +val is_bit_typ : typ -> bool +val is_bitvector_typ : typ -> bool + +(** {2 Simplifcation of numeric expressions and constraints} + + These functions simplify nexps and n_constraints using various + basic rules. In general they will guarantee to reduce constant + numeric expressions like 2 + 5 into 7, although they will not + simplify 2^constant, as that often leads to unreadable error + messages containing huge numbers. *) val nexp_simp : nexp -> nexp val constraint_simp : n_constraint -> n_constraint -(* If a constraint is a conjunction, return a list of all the top-level conjuncts *) +(** If a constraint is a conjunction, return a list of all the top-level conjuncts *) val constraint_conj : n_constraint -> n_constraint list -(* Same as constraint_conj but for disjunctions *) + +(** Same as constraint_conj but for disjunctions *) val constraint_disj : n_constraint -> n_constraint list -(* Utilities for building n-expressions *) +(** {2 Set and Map modules for various AST elements} *) + +module Id : sig + type t = id + val compare : id -> id -> int +end + +module Kid : sig + type t = kid + val compare : kid -> kid -> int +end + +module Kind : sig + type t = kind + val compare : kind -> kind -> int +end + +module KOpt : sig + type t = kinded_id + val compare : kinded_id -> kinded_id -> int +end + +module Nexp : sig + type t = nexp + val compare : nexp -> nexp -> int +end + +module BE : sig + type t = base_effect + val compare : base_effect -> base_effect -> int +end + +module NC : sig + type t = n_constraint + val compare : n_constraint -> n_constraint -> int +end + +(* NB: the comparison function does not expand synonyms *) +module Typ : sig + type t = typ + val compare : typ -> typ -> int +end + +module IdSet : sig + include Set.S with type elt = id +end + +module NexpSet : sig + include Set.S with type elt = nexp +end + +module NexpMap : sig + include Map.S with type key = nexp +end + +module KOptSet : sig + include Set.S with type elt = kinded_id +end + +module KOptMap : sig + include Map.S with type key = kinded_id +end + +module BESet : sig + include Set.S with type elt = base_effect +end + +module KidSet : sig + include Set.S with type elt = kid +end + +module KBindings : sig + include Map.S with type key = kid +end + +module Bindings : sig + include Map.S with type key = id +end + +module TypMap : sig + include Map.S with type key = typ +end + + +(** {2 Functions for building and manipulating effects} *) + +val no_effect : effect +val mk_effect : base_effect_aux list -> effect + +val has_effect : effect -> base_effect_aux -> bool +val effect_set : effect -> BESet.t + +val equal_effects : effect -> effect -> bool +val subseteq_effects : effect -> effect -> bool +val union_effects : effect -> effect -> effect + +(** {2 Functions for building numeric expressions} *) + val nconstant : Big_int.num -> nexp val nint : int -> nexp val nminus : nexp -> nexp -> nexp @@ -162,7 +294,8 @@ val nvar : kid -> nexp val napp : id -> nexp list -> nexp val nid : id -> nexp -(* Numeric constraint builders *) +(** {2 Functions for building numeric constraints} *) + val nc_eq : nexp -> nexp -> n_constraint val nc_neq : nexp -> nexp -> n_constraint val nc_lteq : nexp -> nexp -> n_constraint @@ -178,13 +311,16 @@ val nc_set : kid -> Big_int.num list -> n_constraint val nc_int_set : kid -> int list -> n_constraint val nc_var : kid -> n_constraint +(** {2 Functions for building type arguments}*) + val arg_nexp : ?loc:l -> nexp -> typ_arg val arg_order : ?loc:l -> order -> typ_arg val arg_typ : ?loc:l -> typ -> typ_arg val arg_bool : ?loc:l -> n_constraint -> typ_arg val arg_kopt : kinded_id -> typ_arg -(* Functions for working with type quantifiers *) +(** {2 Functions for working with type quantifiers} *) + val quant_add : quant_item -> typquant -> typquant val quant_items : typquant -> quant_item list val quant_kopts : typquant -> kinded_id list @@ -194,7 +330,8 @@ val quant_map_items : (quant_item -> quant_item) -> typquant -> typquant val is_quant_kopt : quant_item -> bool val is_quant_constraint : quant_item -> bool -(* Functions to map over the annotations in sub-expressions *) +(** {2 Functions to map over annotations in sub-expressions} *) + val map_exp_annot : ('a annot -> 'b annot) -> 'a exp -> 'b exp val map_pat_annot : ('a annot -> 'b annot) -> 'a pat -> 'b pat val map_pexp_annot : ('a annot -> 'b annot) -> 'a pexp -> 'b pexp @@ -205,7 +342,8 @@ val map_mfpat_annot : ('a annot -> 'b annot) -> 'a mfpat -> 'b mfpat val map_mpexp_annot : ('a annot -> 'b annot) -> 'a mpexp -> 'b mpexp val map_mapcl_annot : ('a annot -> 'b annot) -> 'a mapcl -> 'b mapcl -(* Extract locations from identifiers *) +(** {2 Extract locations from terms} *) + val id_loc : id -> Parse_ast.l val kid_loc : kid -> Parse_ast.l val typ_loc : typ -> Parse_ast.l @@ -213,8 +351,11 @@ val pat_loc : 'a pat -> Parse_ast.l val exp_loc : 'a exp -> Parse_ast.l val def_loc : 'a def -> Parse_ast.l -(* For debugging and error messages only: Not guaranteed to produce - parseable SAIL, or even print all language constructs! *) +(** {2 Printing utilities} + + Note: For debugging and error messages only - not guaranteed to + produce parseable Sail, or even print all language constructs! *) + val string_of_id : id -> string val string_of_kid : kid -> string val string_of_base_effect_aux : base_effect_aux -> string @@ -241,11 +382,15 @@ val string_of_mpat : 'a mpat -> string val string_of_letbind : 'a letbind -> string val string_of_index_range : index_range -> string +(** {2 Functions for getting identifiers from toplevel definitions} *) + val id_of_fundef : 'a fundef -> id val id_of_type_def : 'a type_def -> id val id_of_val_spec : 'a val_spec -> id val id_of_dec_spec : 'a dec_spec -> id +(** {2 Functions for manipulating identifiers} *) + val id_of_kid : kid -> id val kid_of_id : id -> kid @@ -253,86 +398,7 @@ val prepend_id : string -> id -> id val append_id : id -> string -> id val prepend_kid : string -> kid -> kid -module Id : sig - type t = id - val compare : id -> id -> int -end - -module Kid : sig - type t = kid - val compare : kid -> kid -> int -end - -module Kind : sig - type t = kind - val compare : kind -> kind -> int -end - -module KOpt : sig - type t = kinded_id - val compare : kinded_id -> kinded_id -> int -end - -module Nexp : sig - type t = nexp - val compare : nexp -> nexp -> int -end - -module BE : sig - type t = base_effect - val compare : base_effect -> base_effect -> int -end - -module NC : sig - type t = n_constraint - val compare : n_constraint -> n_constraint -> int -end - -(* NB: the comparison function does not expand synonyms *) -module Typ : sig - type t = typ - val compare : typ -> typ -> int -end - -module IdSet : sig - include Set.S with type elt = id -end - -module NexpSet : sig - include Set.S with type elt = nexp -end - -module NexpMap : sig - include Map.S with type key = nexp -end - -module KOptSet : sig - include Set.S with type elt = kinded_id -end - -module KOptMap : sig - include Map.S with type key = kinded_id -end - -module BESet : sig - include Set.S with type elt = base_effect -end - -module KidSet : sig - include Set.S with type elt = kid -end - -module KBindings : sig - include Map.S with type key = kid -end - -module Bindings : sig - include Map.S with type key = id -end - -module TypMap : sig - include Map.S with type key = typ -end +(** {2 Misc functions} *) val nexp_frees : nexp -> KidSet.t val nexp_identical : nexp -> nexp -> bool @@ -341,27 +407,12 @@ val int_of_nexp_opt : nexp -> Big_int.num option val lexp_to_exp : 'a lexp -> 'a exp -val is_unit_typ : typ -> bool -val is_number : typ -> bool -val is_ref_typ : typ -> bool -val is_vector_typ : typ -> bool -val is_bit_typ : typ -> bool -val is_bitvector_typ : typ -> bool - val typ_app_args_of : typ -> string * typ_arg_aux list * Ast.l val vector_typ_args_of : typ -> nexp * order * typ val vector_start_index : typ -> nexp val is_order_inc : order -> bool -val has_effect : effect -> base_effect_aux -> bool - -val effect_set : effect -> BESet.t - -val equal_effects : effect -> effect -> bool -val subseteq_effects : effect -> effect -> bool -val union_effects : effect -> effect -> effect - val kopts_of_order : order -> KOptSet.t val kopts_of_nexp : nexp -> KOptSet.t val kopts_of_typ : typ -> KOptSet.t @@ -383,9 +434,7 @@ val construct_pexp : 'a pat * ('a exp) option * 'a exp * (Ast.l * 'a) -> 'a pex val destruct_mpexp : 'a mpexp -> 'a mpat * ('a exp) option * (Ast.l * 'a) val construct_mpexp : 'a mpat * ('a exp) option * (Ast.l * 'a) -> 'a mpexp - val is_valspec : id -> 'a def -> bool - val is_fundef : id -> 'a def -> bool val rename_valspec : id -> 'a val_spec -> 'a val_spec @@ -402,12 +451,16 @@ val type_union_id : type_union -> id val ids_of_def : 'a def -> IdSet.t val ids_of_defs : 'a defs -> IdSet.t +val val_spec_ids : 'a defs -> IdSet.t + val pat_ids : 'a pat -> IdSet.t val subst : id -> 'a exp -> 'a exp -> 'a exp val hex_to_bin : string -> string +(** {2 Manipulating locations} *) + (** locate takes an expression and recursively sets the location in every subexpression using a function that takes the orginal location as an argument. Expressions build using mk_exp and similar @@ -422,15 +475,26 @@ val locate_lexp : (l -> l) -> 'a lexp -> 'a lexp val locate_typ : (l -> l) -> typ -> typ -(* Make a unique location by giving it a Parse_ast.Unique wrapper with +(** Make a unique location by giving it a Parse_ast.Unique wrapper with a generated number. *) val unique : l -> l -(** Substitutions *) +(** Reduce a location to a pair of positions if possible *) +val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option + +(** Try to find the annotation closest to the provided (simplified) + location. Note that this function makes no guarantees about finding + the closest annotation or even finding an annotation at all. This + is used by the Emacs mode to provide type-at-cursor functionality + and we don't mind if it's a bit fuzzy in that context. *) +val find_annot_ast : (Lexing.position * Lexing.position) option -> 'a defs -> (Ast.l * 'a) option + +(** {2 Substitutions} -(* The function X_subst substitutes a type argument into something of + The function X_subst substitutes a type argument into something of type X. The type of the type argument determines which kind of type - variables willb e replaced *) + variables will be replaced *) + val nexp_subst : kid -> typ_arg -> nexp -> nexp val constraint_subst : kid -> typ_arg -> n_constraint -> n_constraint val order_subst : kid -> typ_arg -> order -> order @@ -439,7 +503,7 @@ val typ_arg_subst : kid -> typ_arg -> typ_arg -> typ_arg val subst_kid : (kid -> typ_arg -> 'a -> 'a) -> kid -> kid -> 'a -> 'a -(* Multiple type-level substitution *) +(* Multiple type-level substitutions *) val subst_kids_nexp : nexp KBindings.t -> nexp -> nexp val subst_kids_nc : nexp KBindings.t -> n_constraint -> n_constraint val subst_kids_typ : nexp KBindings.t -> typ -> typ @@ -447,7 +511,3 @@ val subst_kids_typ_arg : nexp KBindings.t -> typ_arg -> typ_arg val quant_item_subst_kid : kid -> kid -> quant_item -> quant_item val typquant_subst_kid : kid -> kid -> typquant -> typquant - -val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option - -val find_annot_ast : (Lexing.position * Lexing.position) option -> 'a defs -> (Ast.l * 'a) option diff --git a/src/initial_check.ml b/src/initial_check.ml index 5893563b..b3d24820 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -811,18 +811,6 @@ let constraint_of_string str = let extern_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> Some (string_of_id id)), false)) let val_spec_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> None), false)) -let val_spec_ids (Defs defs) = - let val_spec_id (VS_aux (vs_aux, _)) = - match vs_aux with - | VS_val_spec (_, id, _, _) -> id - in - let rec vs_ids = function - | DEF_spec vs :: defs -> val_spec_id vs :: vs_ids defs - | def :: defs -> vs_ids defs - | [] -> [] - in - IdSet.of_list (vs_ids defs) - let quant_item_param = function | QI_aux (QI_id kopt, _) when is_int_kopt kopt -> [prepend_id "atom_" (id_of_kid (kopt_kid kopt))] | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [prepend_id "typ_" (id_of_kid (kopt_kid kopt))] @@ -1047,7 +1035,7 @@ let process_ast ?generate:(generate=true) defs = |> generate_initialize_registers vs_ids else ast - + let ast_of_def_string str = let def = Parser.def_eof Lexer.token (Lexing.from_string str) in process_ast (P.Defs [def]) diff --git a/src/initial_check.mli b/src/initial_check.mli index a0bde482..b96a9efb 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -48,14 +48,18 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(** Initial desugaring pass over AST after parsing *) + open Ast open Ast_util -(* Generate undefined_T functions for every type T. False by +(** {2 Options} *) + +(** Generate undefined_T functions for every type T. False by default. *) val opt_undefined_gen : bool ref -(* Generate faster undefined_T functions. Rather than generating +(** Generate faster undefined_T functions. Rather than generating functions that allow for the undefined values of enums and variants to be picked at runtime using a RNG or similar, this creates undefined_T functions for those types that simply return a specific @@ -65,16 +69,17 @@ val opt_undefined_gen : bool ref default. *) val opt_fast_undefined : bool ref -(* Allow # in identifiers when set, like the GHC option of the same name *) +(** Allow # in identifiers when set, much like the GHC option of the same + name *) val opt_magic_hash : bool ref -(* When true enums can be automatically casted to range types and +(** When true enums can be automatically casted to range types and back. Otherwise generated T_of_num and num_of_T functions must be manually used for each enum T *) val opt_enum_casts : bool ref -(* This is a bit of a hack right now - it ensures that the undefiend - builtins (undefined_vector etc), only get added to the ast +(** This is a bit of a hack right now - it ensures that the undefiend + builtins (undefined_vector etc), only get added to the AST once. The original assumption in sail is that the whole AST gets processed at once (therefore they could only get added once), and this isn't true any more with the interpreter. This needs to be @@ -82,17 +87,17 @@ val opt_enum_casts : bool ref all the loaded files. *) val have_undefined_builtins : bool ref -val ast_of_def_string : string -> unit defs +(** {2 Desugar and process AST } *) (** If the generate flag is false, then we won't generate any auxilliary definitions, like the initialize_registers function *) val process_ast : ?generate:bool -> Parse_ast.defs -> unit defs -val val_spec_ids : 'a defs -> IdSet.t +(** {2 Parsing expressions and definitions from strings} *) val extern_of_string : id -> string -> unit def val val_spec_of_string : id -> string -> unit def - +val ast_of_def_string : string -> unit defs val exp_of_string : string -> unit exp val typ_of_string : string -> typ val constraint_of_string : string -> n_constraint diff --git a/src/isail.ml b/src/isail.ml index e47973b4..8f71a809 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -106,7 +106,7 @@ let sail_logo = in List.map banner logo @ [""] @ help @ [""] -let vs_ids = ref (Initial_check.val_spec_ids !Interactive.ast) +let vs_ids = ref (val_spec_ids !Interactive.ast) let interactive_state = ref (initial_state !Interactive.ast Value.primops) @@ -399,12 +399,12 @@ let handle_input' input = Interactive.ast := append_ast !Interactive.ast ast; interactive_state := initial_state !Interactive.ast Value.primops; Interactive.env := env; - vs_ids := Initial_check.val_spec_ids !Interactive.ast + vs_ids := val_spec_ids !Interactive.ast | ":u" | ":unload" -> Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; interactive_state := initial_state !Interactive.ast Value.primops; - vs_ids := Initial_check.val_spec_ids !Interactive.ast; + vs_ids := val_spec_ids !Interactive.ast; (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () @@ -431,7 +431,7 @@ let handle_input' input = Interactive.ast := append_ast !Interactive.ast ast; interactive_state := initial_state !Interactive.ast Value.primops; Interactive.env := env; - vs_ids := Initial_check.val_spec_ids !Interactive.ast; + vs_ids := val_spec_ids !Interactive.ast; print_endline ("(message \"Checked " ^ arg ^ " done\")\n"); with | Reporting.Fatal_error (Err_type (l, msg)) -> @@ -441,7 +441,7 @@ let handle_input' input = Interactive.ast := Ast.Defs []; Interactive.env := Type_check.initial_env; interactive_state := initial_state !Interactive.ast Value.primops; - vs_ids := Initial_check.val_spec_ids !Interactive.ast; + vs_ids := val_spec_ids !Interactive.ast; Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () | ":typeat" -> diff --git a/src/jib/anf.ml b/src/jib/anf.ml index 16fb6756..025138d0 100644 --- a/src/jib/anf.ml +++ b/src/jib/anf.ml @@ -61,31 +61,6 @@ module Big_int = Nat_big_num (* 1. Conversion to A-normal form (ANF) *) (**************************************************************************) -(* The first step in compiling sail is converting the Sail expression - grammar into A-normal form. Essentially this converts expressions - such as f(g(x), h(y)) into something like: - - let v0 = g(x) in let v1 = h(x) in f(v0, v1) - - Essentially the arguments to every function must be trivial, and - complex expressions must be let bound to new variables, or used in - a block, assignment, or control flow statement (if, for, and - while/until loops). The aexp datatype represents these expressions, - while aval represents the trivial values. - - The convention is that the type of an aexp is given by last - argument to a constructor. It is omitted where it is obvious - for - example all for loops have unit as their type. If some constituent - part of the aexp has an annotation, the it refers to the previous - argument, so in - - AE_let (id, typ1, _, body, typ2) - - typ1 is the type of the bound identifer, whereas typ2 is the type - of the whole let expression (and therefore also the body). - - See Flanagan et al's 'The Essence of Compiling with Continuations' - *) type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l and 'a aexp_aux = diff --git a/src/jib/anf.mli b/src/jib/anf.mli index e8d58fe4..79fb35ca 100644 --- a/src/jib/anf.mli +++ b/src/jib/anf.mli @@ -48,12 +48,38 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(** The A-normal form (ANF) grammar *) + open Ast open Ast_util open Jib open Type_check -(* The A-normal form (ANF) grammar *) +(** The first step in compiling Sail is converting the Sail expression + grammar into A-normal form (ANF). Essentially this converts + expressions such as [f(g(x), h(y))] into something like: + + [let v0 = g(x) in let v1 = h(x) in f(v0, v1)] + + Essentially the arguments to every function must be trivial, and + complex expressions must be let bound to new variables, or used in + a block, assignment, or control flow statement (if, for, and + while/until loops). The aexp datatype represents these expressions, + while aval represents the trivial values. + + The convention is that the type of an aexp is given by last + argument to a constructor. It is omitted where it is obvious - for + example all for loops have unit as their type. If some constituent + part of the aexp has an annotation, the it refers to the previous + argument, so in + + [AE_let (id, typ1, _, body, typ2)] + + [typ1] is the type of the bound identifer, whereas [typ2] is the type + of the whole let expression (and therefore also the body). + + See Flanagan et al's {e The Essence of Compiling with Continuations}. + *) type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l @@ -88,6 +114,9 @@ and 'a apat_aux = | AP_nil of 'a | AP_wild of 'a +(** We allow ANF->ANF optimization to insert fragments of C code + directly in the ANF grammar via [AV_C_fragment]. Such fragments + must be side-effect free expressions. *) and 'a aval = | AV_lit of lit * 'a | AV_id of id * 'a lvar @@ -98,28 +127,35 @@ and 'a aval = | AV_record of ('a aval) Bindings.t * 'a | AV_C_fragment of fragment * 'a * ctyp +(** Function for generating unique identifiers during ANF + translation. *) val gensym : unit -> id -(* Functions for transforming ANF expressions *) +(** {2 Functions for transforming ANF expressions} *) +(** Map over all values in an ANF expression *) val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp +(** Map over all function calls in an ANF expression *) val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp +(** Remove all variable shadowing in an ANF expression *) val no_shadow : IdSet.t -> 'a aexp -> 'a aexp val apat_globals : 'a apat -> (id * 'a) list - val apat_types : 'a apat -> 'a Bindings.t +(** Returns true if an ANF expression is dead due to flow typing + implying it is unreachable. Note: This function calls SMT. *) val is_dead_aexp : 'a aexp -> bool -(* Compiling to ANF expressions *) +(** {2 Compiling to ANF expressions} *) val anf_pat : ?global:bool -> tannot pat -> typ apat val anf : tannot exp -> typ aexp -(* Pretty printing ANF expressions *) +(** {2 Pretty printing ANF expressions} *) + val pp_aval : typ aval -> PPrint.document val pp_aexp : typ aexp -> PPrint.document diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli index 92a0d06a..173e5c5f 100644 --- a/src/jib/jib_compile.mli +++ b/src/jib/jib_compile.mli @@ -48,6 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(** Compile Sail ASTs to Jib intermediate representation *) + open Anf open Ast open Ast_util @@ -57,6 +59,9 @@ open Type_check (** Print the IR representation of a specific function. *) val opt_debug_function : string ref + +(** {2 Jib context} *) + (** Context for compiling Sail to Jib. We need to pass a (global) typechecking environment given by checking the full AST. We have to provide a conversion function from Sail types into Jib types, as @@ -81,6 +86,8 @@ val initial_ctx : Env.t -> ctx +(** {2 Compilation functions} *) + (** Compile a Sail definition into a Jib definition. The first two arguments are is the current definition number and the total number of definitions, and can be used to drive a progress bar (see diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index a5f0653b..ff4a9818 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -997,7 +997,7 @@ let ocaml_compile spec defs generator_types = ignore(Unix.system ("cp -r " ^ sail_dir ^ "/lib/myocamlbuild_coverage.ml myocamlbuild.ml")); ocaml_pp_defs out_chan defs generator_types; close_out out_chan; - if IdSet.mem (mk_id "main") (Initial_check.val_spec_ids defs) + if IdSet.mem (mk_id "main") (val_spec_ids defs) then begin print_endline "Generating main"; diff --git a/src/pp.mli b/src/pp.mli deleted file mode 100644 index 5cfb3d88..00000000 --- a/src/pp.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Format -val pp_str : formatter -> string -> unit - -val lst : ('a, formatter, unit) format -> (formatter -> 'b -> unit) -> formatter -> 'b list -> unit - -val opt : (formatter -> 'a -> unit) -> formatter -> 'a option -> unit - -val pp_to_string : (formatter -> 'a) -> string diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index fe94dbb5..4afa5153 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -2792,7 +2792,7 @@ try (* let regtypes = find_regtypes d in *) let state_ids = State.generate_regstate_defs true defs - |> Initial_check.val_spec_ids + |> val_spec_ids in let is_state_def = function | DEF_spec vs -> IdSet.mem (id_of_val_spec vs) state_ids diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 1c30e06e..50ce1e5a 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1466,7 +1466,7 @@ let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) type_env (De (* let regtypes = find_regtypes d in *) let state_ids = State.generate_regstate_defs !opt_mwords defs - |> Initial_check.val_spec_ids + |> val_spec_ids in let is_state_def = function | DEF_spec vs -> IdSet.mem (id_of_val_spec vs) state_ids diff --git a/src/rewriter.mli b/src/rewriter.mli index ec4e381c..ab29d1d9 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -48,6 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(** General rewriting framework for Sail->Sail rewrites *) + module Big_int = Nat_big_num open Ast open Type_check @@ -65,14 +67,14 @@ val rewrite_exp : tannot rewriters -> tannot exp -> tannot exp val rewriters_base : tannot rewriters -(* The identity re-writer *) +(** The identity re-writer *) val rewrite_defs : tannot defs -> tannot defs val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs val rewrite_defs_base_parallel : int -> tannot rewriters -> tannot defs -> tannot defs - -(* Same as rewrite_defs base but display a progress bar when verbosity >= 1 *) + +(** Same as rewrite_defs_base but display a progress bar when verbosity >= 1 *) val rewrite_defs_base_progress : string -> tannot rewriters -> tannot defs -> tannot defs val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp diff --git a/src/rewrites.ml b/src/rewrites.ml index ec074607..34b9388d 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -319,7 +319,7 @@ let rewrite_bitvector_exps env defs = | (e_aux, a) -> E_aux (e_aux, a) in let rewrite_exp _ = fold_exp { id_exp_alg with e_aux = e_aux } in - if IdSet.mem (mk_id "bitvector_of_bitlist") (Initial_check.val_spec_ids defs) then + if IdSet.mem (mk_id "bitvector_of_bitlist") (val_spec_ids defs) then rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } defs else defs diff --git a/src/sail.odocl b/src/sail.odocl index 87209053..4e91e22e 100644 --- a/src/sail.odocl +++ b/src/sail.odocl @@ -1,16 +1,16 @@ ast -ast_util -finite_map -initial_check -lexer -sail parse_ast +lexer parser -pp -pretty_print -process_file -reporting_basic +ast_util +initial_check +type_check rewriter +rewrites specialize -type_check +anf +jib +jib_compile +jib_util util +graph \ No newline at end of file diff --git a/src/specialize.ml b/src/specialize.ml index e2ab3c68..afce4b0f 100644 --- a/src/specialize.ml +++ b/src/specialize.ml @@ -256,7 +256,7 @@ let rec instantiations_of spec id ast = !instantiations let rec rewrite_polymorphic_calls spec id ast = - let vs_ids = Initial_check.val_spec_ids ast in + let vs_ids = val_spec_ids ast in let rewrite_e_aux = function | E_aux (E_app (id', args), annot) as exp when Id.compare id id' = 0 -> @@ -495,7 +495,7 @@ let initial_calls = IdSet.of_list let remove_unused_valspecs ?(initial_calls=initial_calls) env ast = let calls = ref initial_calls in - let vs_ids = Initial_check.val_spec_ids ast in + let vs_ids = val_spec_ids ast in let inspect_exp = function | E_aux (E_app (call, _), _) as exp -> diff --git a/src/type_check.mli b/src/type_check.mli index 15110b37..5333d02d 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -56,19 +56,21 @@ module Big_int = Nat_big_num (** [opt_tc_debug] controls the verbosity of the type checker. 0 is silent, 1 prints a tree of the type derivation and 2 is like 1 but - with much more debugging information. *) + with much more debugging information. 3 is the highest level, and + is even more verbose still. *) val opt_tc_debug : int ref -(** [opt_no_effects] turns of the effect checking. This can break - re-writer passes, so it should only be used for debugging. *) +(** [opt_no_effects] turns of the effect checking. Effects will still + be propagated as normal however. *) val opt_no_effects : bool ref (** [opt_no_lexp_bounds_check] turns of the bounds checking in vector assignments in l-expressions. *) val opt_no_lexp_bounds_check : bool ref -(** opt_expand_valspec expands typedefs in valspecs during type check. - We prefer not to do it for latex output but it is otherwise a good idea. *) +(** [opt_expand_valspec] expands typedefs in valspecs during type + checking. We prefer not to do it for latex output but it is + otherwise a good idea. *) val opt_expand_valspec : bool ref (** Linearize cases involving power where we would otherwise require @@ -204,9 +206,11 @@ module Env : sig node. *) val no_casts : t -> t - (* Is casting allowed by the environment? *) + (** Is casting allowed by the environment? *) val allow_casts : t -> bool + (** Note: Likely want use Type_check.initial_env instead. The empty + environment is lacking even basic builtins. *) val empty : t val pattern_completeness_ctx : t -> Pattern_completeness.ctx @@ -216,17 +220,12 @@ module Env : sig val get_union_id : id -> t -> typquant * typ end +(** {4 Environment helper functions} *) + (** Push all the type variables and constraints from a typquant into an environment *) val add_typquant : Ast.l -> typquant -> Env.t -> Env.t -(** Safely destructure an existential type. Returns None if the type - is not existential. This function will pick a fresh name for the - existential to ensure that no name-clashes occur. The "plain" - version does not treat numeric types as existentials. *) -val destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option -val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option - val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t (** When the typechecker creates new type variables it gives them @@ -238,10 +237,10 @@ val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t not of this form. *) val orig_kid : kid -> kid -(* Vector with default order. *) +(** Vector with default order as set in environment by [default Order ord] *) val dvector_typ : Env.t -> nexp -> typ -> typ -val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ +(** {2 Type annotations} *) (** The type of type annotations *) type tannot @@ -280,7 +279,7 @@ val strip_lexp : 'a lexp -> unit lexp val strip_mpexp : 'a mpexp -> unit mpexp val strip_mapcl : 'a mapcl -> unit mapcl -(* Strip location information from types for comparison purposes *) +(** Strip location information from types for comparison purposes *) val strip_typ : typ -> typ val strip_typq : typquant -> typquant val strip_id : id -> id @@ -372,6 +371,15 @@ val expected_typ_of : Ast.l * tannot -> typ option (** {2 Utilities } *) +(** Safely destructure an existential type. Returns None if the type + is not existential. This function will pick a fresh name for the + existential to ensure that no name-collisions occur, although we + can optionally suggest a name for the case where it would not cause + a collision. The "plain" version does not treat numeric types + (i.e. range, int, nat) as existentials. *) +val destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option +val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option + val destruct_atom_nexp : Env.t -> typ -> nexp option val destruct_atom_bool : Env.t -> typ -> n_constraint option @@ -382,6 +390,10 @@ val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * val destruct_vector : Env.t -> typ -> (nexp * order * typ) option +(** Construct an existential type with a guaranteed fresh + identifier. *) +val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ + val subst_unifiers : typ_arg KBindings.t -> typ -> typ (** [unify l env goals typ1 typ2] returns set of typ_arg bindings such @@ -392,6 +404,7 @@ val subst_unifiers : typ_arg KBindings.t -> typ -> typ typ2 (occurs check). *) val unify : l -> Env.t -> KidSet.t -> typ -> typ -> typ_arg KBindings.t +(** Check if two types are alpha equivalent *) val alpha_equivalent : Env.t -> typ -> typ -> bool (** Throws Invalid_argument if the argument is not a E_app expression *) @@ -408,7 +421,7 @@ val propagate_exp_effect : tannot exp -> tannot exp val propagate_pexp_effect : tannot pexp -> tannot pexp * effect -(** {2 Checking full AST} *) +(** {2 Checking full ASTs} *) (** Fully type-check an AST diff --git a/src/util.ml b/src/util.ml index 251fb3eb..703bbc1f 100644 --- a/src/util.ml +++ b/src/util.ml @@ -329,18 +329,7 @@ module IntIntSet = Set.Make( type t = int * int end ) - -module ExtraSet = functor (S : Set.S) -> - struct - let add_list s l = List.fold_left (fun s x -> S.add x s) s l - let from_list l = add_list S.empty l - let list_union l = List.fold_left S.union S.empty l - let list_inter = function s :: l -> List.fold_left S.inter s l - | [] -> raise (Failure "ExtraSet.list_inter") - end;; - - -let copy_file src dst = +let copy_file src dst = let len = 5096 in let b = Bytes.make len ' ' in let read_len = ref 0 in @@ -357,7 +346,7 @@ let move_file src dst = try (* try efficient version *) Sys.rename src dst - with Sys_error _ -> + with Sys_error _ -> begin (* OK, do it the the hard way *) copy_file src dst; @@ -370,7 +359,7 @@ let same_content_files file1 file2 : bool = let s1 = Stream.of_channel (open_in_bin file1) in let s2 = Stream.of_channel (open_in_bin file2) in let stream_is_empty s = (try Stream.empty s; true with Stream.Failure -> false) in - try + try while ((Stream.next s1) = (Stream.next s2)) do () done; false with Stream.Failure -> stream_is_empty s1 && stream_is_empty s2 @@ -454,9 +443,6 @@ let zencode_string str = "z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.ma let zencode_upper_string str = "Z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.map zchar (string_to_list str)) -(** Encode string for use as a filename. We can't use zencode directly - because some operating systems make the mistake of being - case-insensitive. *) let file_encode_string str = let zstr = zencode_string str in let md5 = Digest.to_hex (Digest.string zstr) in diff --git a/src/util.mli b/src/util.mli index 013bdcda..06fd5eff 100644 --- a/src/util.mli +++ b/src/util.mli @@ -48,6 +48,8 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(** Various non Sail specific utility functions *) + (* Last element of a list *) val last : 'a list -> 'a @@ -78,7 +80,7 @@ val remove_dups : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'a list -> 'a list val assoc_equal_opt : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option val assoc_compare_opt : ('a -> 'a -> int) -> 'a -> ('a * 'b) list -> 'b option - + val power : int -> int -> int (** {2 Option Functions} *) @@ -123,6 +125,9 @@ val option_all : 'a option list -> 'a list option similarly [y] in case [h y] returns [None]. *) val changed2 : ('a -> 'b -> 'c) -> ('a -> 'a option) -> 'a -> ('b -> 'b option) -> 'b -> 'c option +val is_some : 'a option -> bool +val is_none : 'a option -> bool + (** {2 List Functions} *) (** [list_index p l] returns the first index [i] such that @@ -139,14 +144,14 @@ val option_first: ('a -> 'b option) -> 'a list -> 'b option If for all elements of [l] the function [f] returns [None], then [map_changed f l] returns [None]. Otherwise, it uses [x] for all elements, where [f x] returns [None], - and returns the resulting list. *) + and returns the resulting list. *) val map_changed : ('a -> 'a option) -> 'a list -> 'a list option (** [map_changed_default d f l] maps [f] over [l]. If for all elements of [l] the function [f] returns [None], then [map_changed f l] returns [None]. Otherwise, it uses [d x] for all elements [x], where [f x] returns [None], - and returns the resulting list. *) + and returns the resulting list. *) val map_changed_default : ('a -> 'b) -> ('a -> 'b option) -> 'a list -> 'b list option (** [list_mapi f l] maps [f] over [l]. In contrast to the standard @@ -156,7 +161,7 @@ val list_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** [list_iter sf f [a1; ...; an]] applies function [f] in turn to [a1; ...; an] and calls [sf ()] in between. It is equivalent to [begin f a1; sf(); f a2; sf(); ...; f an; () end]. *) -val list_iter_sep : (unit -> unit) -> ('a -> unit) -> 'a list -> unit +val list_iter_sep : (unit -> unit) -> ('a -> unit) -> 'a list -> unit (** [map_filter f l] maps [f] over [l] and removes all entries [x] of [l] with [f x = None]. *) @@ -184,6 +189,12 @@ val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int +val take : int -> 'a list -> 'a list +val drop : int -> 'a list -> 'a list + +val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list) + +val list_init : int -> (int -> 'a) -> 'a list (** {2 Files} *) @@ -213,41 +224,16 @@ val string_to_list : string -> char list module IntSet : Set.S with type elt = int module IntIntSet : Set.S with type elt = int * int -(** Some useful extra functions for sets *) -module ExtraSet : functor (S : Set.S) -> - sig - (** Add a list of values to an existing set. *) - val add_list : S.t -> S.elt list -> S.t - - (** Construct a set from a list. *) - val from_list : S.elt list -> S.t +(** {2 Formatting functions} *) - (** Builds the union of a list of sets *) - val list_union : S.t list -> S.t - - (** Builds the intersection of a list of sets. - If the list is empty, a match exception is thrown. *) - val list_inter : S.t list -> S.t - end - -val list_init : int -> (int -> 'a) -> 'a list - -(*Formatting functions*) val string_of_list : string -> ('a -> string) -> 'a list -> string val string_of_option : ('a -> string) -> 'a option -> string val split_on_char : char -> string -> string list -val is_some : 'a option -> bool -val is_none : 'a option -> bool - -val take : int -> 'a list -> 'a list -val drop : int -> 'a list -> 'a list - -val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list) +(** {2 Terminal color codes} *) -(* Terminal color codes *) val termcode : int -> string val bold : string -> string val darkgray : string -> string @@ -260,14 +246,27 @@ val blue : string -> string val magenta : string -> string val clear : string -> string -val warn : string -> unit +(** {2 Encoding schemes for strings} *) + +(** z-encoding will take any string with ASCII characters in the range + 32-126 inclusive, and map it to a string that just contains ASCII + upper and lower case letters and numbers, prefixed with the letter + z. This mapping is one-to-one. *) val zencode_string : string -> string val zencode_upper_string : string -> string +(** Encode string for use as a filename. We can't use zencode directly + because some operating systems make the mistake of being + case-insensitive. *) val file_encode_string : string -> string +(** {2 Misc output functions} *) + val log_line : string -> int -> string -> string + val header : string -> int -> string val progress : string -> string -> int -> int -> unit + +val warn : string -> unit -- cgit v1.2.3 From c3d10cdb1787077425e174fa638f1d43de7c797f Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 12 Mar 2019 11:09:33 +0000 Subject: Coq: fix some boolean issues seen in arm Fixes bad precedence issues, removes an out-of-date special case that's not necessary, and solves more goals. --- src/pretty_print_coq.ml | 29 +++-------------------------- 1 file changed, 3 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index 4afa5153..f22ff758 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -652,7 +652,7 @@ and doc_arithfact ctxt ?(exists = []) ?extra nc = let prop = doc_nc_prop ctxt nc in let prop = match extra with | None -> prop - | Some pp -> separate space [pp; string "/\\"; prop] + | Some pp -> separate space [pp; string "/\\"; parens prop] in let prop = match exists with @@ -665,11 +665,11 @@ and doc_arithfact ctxt ?(exists = []) ?extra nc = and doc_nc_prop ?(top = true) ctx nc = let rec l85 (NC_aux (nc,_) as nc_full) = match nc with - | NC_or (nc1, nc2) -> doc_op (string "\\/") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2) + | NC_or (nc1, nc2) -> doc_op (string "\\/") (l80 nc1) (l85 nc2) | _ -> l80 nc_full and l80 (NC_aux (nc,_) as nc_full) = match nc with - | NC_and (nc1, nc2) -> doc_op (string "/\\") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2) + | NC_and (nc1, nc2) -> doc_op (string "/\\") (l70 nc1) (l80 nc2) | _ -> l70 nc_full and l70 (NC_aux (nc,_) as nc_full) = match nc with @@ -1846,29 +1846,6 @@ let doc_exp, doc_let = let epp = liftR (separate space [string "assert_exp'"; expY assert_e1; expY assert_e2]) in let epp = infix 0 1 (string ">>= fun _ =>") epp (top_exp new_ctxt false e2) in if aexp_needed then parens (align epp) else align epp - (* Special case because we don't handle variables with nested existentials well yet. - TODO: check that id1 is not used in e2' *) - | ((P_aux (P_id id1,_)) | P_aux (P_typ (_, P_aux (P_id id1,_)),_)), - _, - (E_aux (E_let (LB_aux (LB_val (pat', E_aux (E_cast (typ', E_aux (E_id id2,_)),_)),_), e2'),_)) - when Id.compare id1 id2 == 0 -> - let m_str, tail_pp = if ctxt.early_ret then "MR",[string "_"] else "M",[] in - let e1_pp = parens (separate space ([expY e1; colon; - string m_str; - parens (doc_typ ctxt typ')]@tail_pp)) in - let middle = - match pat' with - | P_aux (P_id id,_) - when Util.is_none (is_auto_decomposed_exist ctxt (env_of e1) (typ_of e1)) && - not (is_enum (env_of e1) id) -> - separate space [string ">>= fun"; doc_id id; bigarrow] - | P_aux (P_typ (typ, P_aux (P_id id,_)),_) - when Util.is_none (is_auto_decomposed_exist ctxt (env_of e1) typ) && - not (is_enum (env_of e1) id) -> - separate space [string ">>= fun"; doc_id id; colon; doc_typ ctxt typ; bigarrow] | _ -> - separate space [string ">>= fun"; squote ^^ doc_pat ctxt true true (pat', typ'); bigarrow] - in - infix 0 1 middle e1_pp (top_exp new_ctxt false e2') | _ -> let epp = let middle = -- cgit v1.2.3 From b0e0902a82f61d53ad3778b2683215ad03d056b7 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Tue, 12 Mar 2019 12:43:50 +0000 Subject: Coq: fix parametrized record types --- src/pretty_print_coq.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml index f22ff758..d720312f 100644 --- a/src/pretty_print_coq.ml +++ b/src/pretty_print_coq.ml @@ -2138,10 +2138,11 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with string "Defined." ^^ hardline else empty in + let resetimplicit = separate space [string "Arguments"; id_pp; colon; string "clear implicits."] in doc_op coloneq - (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq]) + (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt braces typq]) ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^ - dot ^^ hardline ^^ eq_pp ^^ updates_pp + dot ^^ hardline ^^ resetimplicit ^^ hardline ^^ eq_pp ^^ updates_pp | TD_variant(id,typq,ar,_) -> (match id with | Id_aux ((Id "read_kind"),_) -> empty -- cgit v1.2.3 From 874bb01f0e2c201474e0a07602a38037bb2495f9 Mon Sep 17 00:00:00 2001 From: Brian Campbell Date: Wed, 13 Mar 2019 09:28:10 +0000 Subject: Tell Lem that records parametrised over Ints need the len typeclass annotations --- src/pretty_print_lem.ml | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 50ce1e5a..759c7637 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1024,6 +1024,22 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) *) +let doc_typquant_sorts idpp (TypQ_aux (typq,_)) = + match typq with + | TypQ_tq qs -> + let q (QI_aux (qi,_)) = + match qi with + | QI_id (KOpt_aux (KOpt_kind (K_aux (K_int,_),kid),_)) -> Some (string "`len`") + | QI_id (KOpt_aux (KOpt_kind (K_aux (K_type,_),kid),_)) -> Some underscore + | QI_id (KOpt_aux (KOpt_kind (K_aux ((K_order|K_bool),_),kid),_)) -> None + | QI_const _ -> None + in + if List.exists (function (QI_aux (QI_id (KOpt_aux (KOpt_kind (K_aux (K_int,_),_),_)),_)) -> true | _ -> false) qs then + let qs_pp = Util.map_filter q qs in + string "declare isabelle target_sorts " ^^ idpp ^^ space ^^ separate space (equals::qs_pp) ^^ hardline + else empty + | TypQ_no_forall -> empty + let doc_typdef_lem env (TD_aux(td, (l, annot))) = match td with | TD_abbrev(id,typq,A_aux (A_typ typ, _)) -> let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in @@ -1078,9 +1094,10 @@ let doc_typdef_lem env (TD_aux(td, (l, annot))) = match td with doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp; doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp; doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in *) + let sorts_pp = doc_typquant_sorts (doc_id_lem_type id) typq in doc_op equals (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) - ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline + ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline ^^ sorts_pp (* if !opt_sequential && string_of_id id = "regstate" then empty else separate_map hardline doc_field fs *) | TD_variant(id,typq,ar,_) -> -- cgit v1.2.3 From ec8cad1daa76fb265014d3d313173905925c9922 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 13 Mar 2019 14:26:59 +0000 Subject: C: Improve Jib IR, add SSA representation Add a CL_void l-expression so we don't have redundant unit-typed variables everywhere, and add an optimization in Jib_optimize called optimize_unit which introduces these. Remove the basic control-flow graph in Jib_util and add a new mutable control-flow graph type in Jib_ssa which allows the IR to be converted into SSA form. The mutable graph allows for more efficient updates, and includes both back and forwards references making it much more convenient to traverse. Having an SSA representation should make some optimizations much simpler, and is also probably more natural for SMT generation where variables have to be defined once using declare-const anyway. Debug option -ddump_flow_graphs now outputs SSA'd graphs of the functions in a specification. --- src/graph.ml | 2 +- src/jib/c_backend.ml | 47 +--- src/jib/c_backend.mli | 9 - src/jib/jib_compile.ml | 12 +- src/jib/jib_compile.mli | 7 +- src/jib/jib_optimize.ml | 129 ++++++++++ src/jib/jib_optimize.mli | 63 +++++ src/jib/jib_ssa.ml | 602 +++++++++++++++++++++++++++++++++++++++++++++++ src/jib/jib_ssa.mli | 85 +++++++ src/jib/jib_util.ml | 167 +++++-------- src/sail.ml | 2 +- src/sail.odocl | 1 + 12 files changed, 953 insertions(+), 173 deletions(-) create mode 100644 src/jib/jib_optimize.ml create mode 100644 src/jib/jib_optimize.mli create mode 100644 src/jib/jib_ssa.ml create mode 100644 src/jib/jib_ssa.mli (limited to 'src') diff --git a/src/graph.ml b/src/graph.ml index 21863e47..703deba9 100644 --- a/src/graph.ml +++ b/src/graph.ml @@ -234,6 +234,6 @@ module Make(Ord: OrderedType) = struct NM.bindings graph |> List.iter (fun (from_node, _) -> make_node from_node); NM.bindings graph |> List.iter (fun (from_node, to_nodes) -> NS.iter (make_line from_node) to_nodes); output_string out_chan "}\n"; - Util.opt_colors := true; + Util.opt_colors := true end diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml index aab2894e..846b619f 100644 --- a/src/jib/c_backend.ml +++ b/src/jib/c_backend.ml @@ -63,7 +63,6 @@ module Big_int = Nat_big_num let c_verbosity = ref 0 -let opt_debug_flow_graphs = ref false let opt_static = ref false let opt_no_main = ref false let opt_memo_cache = ref false @@ -849,48 +848,6 @@ let hoist_allocations recursive_functions = function | cdef -> [cdef] -let flat_counter = ref 0 -let flat_id () = - let id = mk_id ("local#" ^ string_of_int !flat_counter) in - incr flat_counter; - id - -let rec flatten_instrs = function - | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> - let fid = flat_id () in - I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) - - | I_aux ((I_block block | I_try_block block), _) :: instrs -> - flatten_instrs block @ flatten_instrs instrs - - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> - let then_label = label "then_" in - let endif_label = label "endif_" in - [ijump cval then_label] - @ flatten_instrs else_instrs - @ [igoto endif_label] - @ [ilabel then_label] - @ flatten_instrs then_instrs - @ [ilabel endif_label] - @ flatten_instrs instrs - - | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs - - | instr :: instrs -> instr :: flatten_instrs instrs - | [] -> [] - -let flatten_cdef = - function - | CDEF_fundef (function_id, heap_return, args, body) -> - flat_counter := 0; - CDEF_fundef (function_id, heap_return, args, flatten_instrs body) - - | CDEF_let (n, bindings, instrs) -> - flat_counter := 0; - CDEF_let (n, bindings, flatten_instrs instrs) - - | cdef -> cdef - let rec specialize_variants ctx prior = let unifications = ref (Bindings.empty) in @@ -1386,6 +1343,7 @@ let rec sgen_clexp = function | CL_have_exception -> "have_exception" | CL_current_exception _ -> "current_exception" | CL_return _ -> assert false + | CL_void -> assert false let rec sgen_clexp_pure = function | CL_id (id, _) -> sgen_id id @@ -1395,6 +1353,7 @@ let rec sgen_clexp_pure = function | CL_have_exception -> "have_exception" | CL_current_exception _ -> "current_exception" | CL_return _ -> assert false + | CL_void -> assert false (** Generate instructions to copy from a cval to a clexp. This will insert any needed type conversions from big integers to small @@ -2079,8 +2038,6 @@ let codegen_def' ctx = function string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) | CDEF_fundef (id, ret_arg, args, instrs) as def -> - if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); - (* Extract type information about the function from the environment. *) let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in let arg_typs, ret_typ = match fn_typ with diff --git a/src/jib/c_backend.mli b/src/jib/c_backend.mli index 2fc5be94..7314eb5a 100644 --- a/src/jib/c_backend.mli +++ b/src/jib/c_backend.mli @@ -53,10 +53,6 @@ open Type_check (** Global compilation options *) -(** Output a dataflow graph for each generated function in Graphviz - (dot) format. *) -val opt_debug_flow_graphs : bool ref - (** Define generated functions as static *) val opt_static : bool ref @@ -109,10 +105,5 @@ val optimize_experimental : bool ref (** Convert a typ to a IR ctyp *) val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp -(** Rewriting steps for compiled ASTs *) -val flatten_instrs : instr list -> instr list - -val flatten_cdef : cdef -> cdef - val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml index 36a28d9f..27f833d8 100644 --- a/src/jib/jib_compile.ml +++ b/src/jib/jib_compile.ml @@ -58,6 +58,7 @@ open Value2 open Anf let opt_debug_function = ref "" +let opt_debug_flow_graphs = ref false let opt_memo_cache = ref false (**************************************************************************) @@ -1174,7 +1175,16 @@ and compile_def' n total ctx = function prerr_endline (Util.header header (List.length arg_ctyps + 2)); prerr_endline (Pretty_print_sail.to_string PPrint.(separate_map hardline pp_instr instrs)) else (); - + + if !opt_debug_flow_graphs then + begin + let instrs = Jib_optimize.(instrs |> optimize_unit |> flatten_instrs) in + let cfg = Jib_ssa.ssa instrs in + let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in + Jib_ssa.make_dot out_chan cfg; + close_out out_chan; + end; + [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli index 173e5c5f..f3bd8c76 100644 --- a/src/jib/jib_compile.mli +++ b/src/jib/jib_compile.mli @@ -55,10 +55,13 @@ open Ast open Ast_util open Jib open Type_check - + +(** Output a dataflow graph for each generated function in Graphviz + (dot) format. *) +val opt_debug_flow_graphs : bool ref + (** Print the IR representation of a specific function. *) val opt_debug_function : string ref - (** {2 Jib context} *) diff --git a/src/jib/jib_optimize.ml b/src/jib/jib_optimize.ml new file mode 100644 index 00000000..889e650e --- /dev/null +++ b/src/jib/jib_optimize.ml @@ -0,0 +1,129 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast_util +open Jib +open Jib_util + +let optimize_unit instrs = + let unit_cval cval = + match cval_ctyp cval with + | CT_unit -> (F_lit V_unit, CT_unit) + | _ -> cval + in + let unit_instr = function + | I_aux (I_funcall (clexp, extern, id, args), annot) as instr -> + begin match clexp_ctyp clexp with + | CT_unit -> + I_aux (I_funcall (CL_void, extern, id, List.map unit_cval args), annot) + | _ -> instr + end + | I_aux (I_copy (clexp, cval), annot) as instr -> + begin match clexp_ctyp clexp with + | CT_unit -> + I_aux (I_copy (CL_void, unit_cval cval), annot) + | _ -> instr + end + | I_aux (I_alias (clexp, cval), annot) as instr -> + begin match clexp_ctyp clexp with + | CT_unit -> + I_aux (I_alias (CL_void, unit_cval cval), annot) + | _ -> instr + end + | instr -> instr + in + let non_pointless_copy (I_aux (aux, annot)) = + match aux with + | I_copy (CL_void, _) -> false + | _ -> true + in + filter_instrs non_pointless_copy (map_instr_list unit_instr instrs) + +let flat_counter = ref 0 +let flat_id () = + let id = mk_id ("local#" ^ string_of_int !flat_counter) in + incr flat_counter; + id + +let rec flatten_instrs = function + | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> + let fid = flat_id () in + I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) + + | I_aux ((I_block block | I_try_block block), _) :: instrs -> + flatten_instrs block @ flatten_instrs instrs + + | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + let then_label = label "then_" in + let endif_label = label "endif_" in + [ijump cval then_label] + @ flatten_instrs else_instrs + @ [igoto endif_label] + @ [ilabel then_label] + @ flatten_instrs then_instrs + @ [ilabel endif_label] + @ flatten_instrs instrs + + | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs + + | instr :: instrs -> instr :: flatten_instrs instrs + | [] -> [] + +let flatten_cdef = + function + | CDEF_fundef (function_id, heap_return, args, body) -> + flat_counter := 0; + CDEF_fundef (function_id, heap_return, args, flatten_instrs body) + + | CDEF_let (n, bindings, instrs) -> + flat_counter := 0; + CDEF_let (n, bindings, flatten_instrs instrs) + + | cdef -> cdef diff --git a/src/jib/jib_optimize.mli b/src/jib/jib_optimize.mli new file mode 100644 index 00000000..beffa81e --- /dev/null +++ b/src/jib/jib_optimize.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Jib + +(** Remove redundant assignments and variables of type + unit. unit-typed identifiers that are assigned to are replaced with + CL_void, and cvals (which should be pure!) are replaced with unit + types are replaced by unit-literals. *) +val optimize_unit : instr list -> instr list + +(** Remove all instructions that can contain other nested + instructions, prodcing a flat list of instructions. *) +val flatten_instrs : instr list -> instr list +val flatten_cdef : cdef -> cdef + diff --git a/src/jib/jib_ssa.ml b/src/jib/jib_ssa.ml new file mode 100644 index 00000000..1f477696 --- /dev/null +++ b/src/jib/jib_ssa.ml @@ -0,0 +1,602 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast_util +open Jib +open Jib_util + +module IntSet = Set.Make(struct type t = int let compare = compare end) + +(**************************************************************************) +(* 1. Mutable graph type *) +(**************************************************************************) + +type 'a array_graph = { + mutable next : int; + mutable nodes : ('a * IntSet.t * IntSet.t) option array + } + +let make ~initial_size () = { + next = 0; + nodes = Array.make initial_size None + } + +(** Add a vertex to a graph, returning the node index *) +let add_vertex data graph = + let n = graph.next in + if n >= Array.length graph.nodes then + begin + let new_nodes = Array.make (Array.length graph.nodes * 2) None in + Array.blit graph.nodes 0 new_nodes 0 (Array.length graph.nodes); + graph.nodes <- new_nodes + end; + let n = graph.next in + graph.nodes.(n) <- Some (data, IntSet.empty, IntSet.empty); + graph.next <- n + 1; + n + +(** Add an edge between two existing vertices. Raises Invalid_argument + if either of the vertices do not exist. *) +let add_edge n m graph = + begin match graph.nodes.(n) with + | Some (data, parents, children) -> + graph.nodes.(n) <- Some (data, parents, IntSet.add m children) + | None -> + raise (Invalid_argument "Parent node does not exist in graph") + end; + match graph.nodes.(m) with + | Some (data, parents, children) -> + graph.nodes.(m) <- Some (data, IntSet.add n parents, children) + | None -> + raise (Invalid_argument "Child node does not exist in graph") + +let cardinal graph = graph.next + +let reachable roots graph = + let visited = ref IntSet.empty in + + let rec reachable' n = + if IntSet.mem n !visited then () + else + begin + visited := IntSet.add n !visited; + match graph.nodes.(n) with + | Some (_, _, successors) -> + IntSet.iter reachable' successors + | None -> () + end + in + IntSet.iter reachable' roots; !visited + +let prune visited graph = + for i = 0 to graph.next - 1 do + match graph.nodes.(i) with + | Some (n, preds, succs) -> + if IntSet.mem i visited then + graph.nodes.(i) <- Some (n, IntSet.inter visited preds, IntSet.inter visited succs) + else + graph.nodes.(i) <- None + | None -> () + done + +(**************************************************************************) +(* 2. Mutable control flow graph *) +(**************************************************************************) + +type cf_node = + | CF_label of string + | CF_block of instr list + | CF_start + +let control_flow_graph instrs = + let module StringMap = Map.Make(String) in + let labels = ref StringMap.empty in + + let graph = make ~initial_size:512 () in + + iter_instr (fun (I_aux (instr, annot)) -> + match instr with + | I_label label -> + labels := StringMap.add label (add_vertex ([], CF_label label) graph) !labels + | _ -> () + ) (iblock instrs); + + let cf_split (I_aux (aux, _)) = + match aux with + | I_block _ | I_label _ | I_goto _ | I_jump _ | I_if _ | I_end | I_match_failure | I_undefined _ -> true + | _ -> false + in + + let rec cfg preds instrs = + let before, after = instr_split_at cf_split instrs in + let last = match after with + | I_aux (I_label _, _) :: _ -> [] + | instr :: _ -> [instr] + | _ -> [] + in + let preds = match before @ last with + | [] -> preds + | instrs -> + let n = add_vertex ([], CF_block instrs) graph in + List.iter (fun p -> add_edge p n graph) preds; + [n] + in + match after with + | I_aux (I_if (cond, then_instrs, else_instrs, _), _) :: after -> + let t = cfg preds then_instrs in + let e = cfg preds else_instrs in + cfg (t @ e) after + + | I_aux ((I_end | I_match_failure | I_undefined _), _) :: after -> + cfg [] after + + | I_aux (I_goto label, _) :: after -> + List.iter (fun p -> add_edge p (StringMap.find label !labels) graph) preds; + cfg [] after + + | I_aux (I_jump (cval, label), _) :: after -> + List.iter (fun p -> add_edge p (StringMap.find label !labels) graph) preds; + cfg preds after + + | I_aux (I_label label, _) :: after -> + cfg (StringMap.find label !labels :: preds) after + + | I_aux (I_block instrs, _) :: after -> + let m = cfg preds instrs in + cfg m after + + | _ :: after -> assert false + + | [] -> preds + in + + let start = add_vertex ([], CF_start) graph in + let finish = cfg [start] instrs in + + let visited = reachable (IntSet.singleton start) graph in + prune visited graph; + + start, finish, graph + +(**************************************************************************) +(* 3. Computing dominators *) +(**************************************************************************) + +(** Calculate the (immediate) dominators of a graph using the + Lengauer-Tarjan algorithm. This is the slightly less sophisticated + version from Appel's book 'Modern compiler implementation in ML' + which runs in O(n log(n)) time. *) +let immediate_dominators graph root = + let none = -1 in + let vertex = Array.make (cardinal graph) 0 in + let parent = Array.make (cardinal graph) none in + let ancestor = Array.make (cardinal graph) none in + let semi = Array.make (cardinal graph) none in + let idom = Array.make (cardinal graph) none in + let samedom = Array.make (cardinal graph) none in + let best = Array.make (cardinal graph) none in + let dfnum = Array.make (cardinal graph) 0 in + let bucket = Array.make (cardinal graph) IntSet.empty in + + let rec ancestor_with_lowest_semi v = + let a = ancestor.(v) in + if ancestor.(a) <> none then + let b = ancestor_with_lowest_semi a in + ancestor.(v) <- ancestor.(a); + if dfnum.(semi.(b)) < dfnum.(semi.(best.(v))) then + best.(v) <- b + else (); + else (); + if best.(v) <> none then best.(v) else v + in + + let link p n = + ancestor.(n) <- p; + best.(n) <- n + in + + let count = ref 0 in + + let rec dfs p n = + if dfnum.(n) = 0 then + begin + dfnum.(n) <- !count; + vertex.(!count) <- n; + parent.(n) <- p; + incr count; + match graph.nodes.(n) with + | Some (_, _, successors) -> + IntSet.iter (fun w -> dfs n w) successors + | None -> assert false + end + in + dfs none root; + + for i = !count - 1 downto 1 do + let n = vertex.(i) in + let p = parent.(n) in + let s = ref p in + + begin match graph.nodes.(n) with + | Some (_, predecessors, _) -> + IntSet.iter (fun v -> + let s' = + if dfnum.(v) <= dfnum.(n) then + v + else + semi.(ancestor_with_lowest_semi v) + in + if dfnum.(s') < dfnum.(!s) then s := s' + ) predecessors + | None -> assert false + end; + semi.(n) <- !s; + bucket.(!s) <- IntSet.add n bucket.(!s); + link p n; + IntSet.iter (fun v -> + let y = ancestor_with_lowest_semi v in + if semi.(y) = semi.(v) then + idom.(v) <- p + else + samedom.(n) <- y + ) bucket.(p); + done; + for i = 1 to !count - 1 do + let n = vertex.(i) in + if samedom.(n) <> none then + idom.(n) <- idom.(samedom.(n)) + done; + idom + +(** [(dominator_children idoms).(n)] are the nodes whose immediate dominator + (idom) is n. *) +let dominator_children idom = + let none = -1 in + let children = Array.make (Array.length idom) IntSet.empty in + + for n = 0 to Array.length idom - 1 do + let p = idom.(n) in + if p <> none then + children.(p) <- IntSet.add n (children.(p)) + done; + children + +(** [dominate idom n w] is true if n dominates w in the tree of + immediate dominators idom. *) +let rec dominate idom n w = + let none = -1 in + let p = idom.(n) in + if p = none then + false + else if p = w then + true + else + dominate idom p w + +let dominance_frontiers graph root idom children = + let df = Array.make (cardinal graph) IntSet.empty in + + let rec compute_df n = + let set = ref IntSet.empty in + + begin match graph.nodes.(n) with + | Some (content, _, succs) -> + IntSet.iter (fun y -> + if idom.(y) <> n then + set := IntSet.add y !set + ) succs + | None -> () + end; + IntSet.iter (fun c -> + compute_df c; + IntSet.iter (fun w -> + if not (dominate idom n w) then + set := IntSet.add w !set + ) (df.(c)) + ) (children.(n)); + df.(n) <- !set + in + compute_df root; + df + +(**************************************************************************) +(* 4. Conversion to SSA form *) +(**************************************************************************) + +type ssa_elem = + | Phi of Ast.id * Ast.id list + +let place_phi_functions graph df = + let defsites = ref Bindings.empty in + + let all_vars = ref IdSet.empty in + + let rec all_decls = function + | I_aux (I_decl (_, id), _) :: instrs -> + IdSet.add id (all_decls instrs) + | _ :: instrs -> all_decls instrs + | [] -> IdSet.empty + in + + let orig_A n = + match graph.nodes.(n) with + | Some ((_, CF_block instrs), _, _) -> + let vars = List.fold_left IdSet.union IdSet.empty (List.map instr_writes instrs) in + let vars = IdSet.diff vars (all_decls instrs) in + all_vars := IdSet.union vars !all_vars; + vars + | Some _ -> IdSet.empty + | None -> IdSet.empty + in + let phi_A = ref Bindings.empty in + + for n = 0 to graph.next - 1 do + IdSet.iter (fun a -> + let ds = match Bindings.find_opt a !defsites with Some ds -> ds | None -> IntSet.empty in + defsites := Bindings.add a (IntSet.add n ds) !defsites + ) (orig_A n) + done; + + IdSet.iter (fun a -> + let workset = ref (Bindings.find a !defsites) in + while not (IntSet.is_empty !workset) do + let n = IntSet.choose !workset in + workset := IntSet.remove n !workset; + IntSet.iter (fun y -> + let phi_A_a = match Bindings.find_opt a !phi_A with Some set -> set | None -> IntSet.empty in + if not (IntSet.mem y phi_A_a) then + begin + begin match graph.nodes.(y) with + | Some ((phis, cfnode), preds, succs) -> + graph.nodes.(y) <- Some ((Phi (a, Util.list_init (IntSet.cardinal preds) (fun _ -> a)) :: phis, cfnode), preds, succs) + | None -> assert false + end; + phi_A := Bindings.add a (IntSet.add y phi_A_a) !phi_A; + if not (IdSet.mem a (orig_A y)) then + workset := IntSet.add y !workset + end + ) df.(n) + done + ) !all_vars + +let rename_variables graph root children = + let counts = ref Bindings.empty in + let stacks = ref Bindings.empty in + + let get_count id = + match Bindings.find_opt id !counts with Some n -> n | None -> 0 + in + let top_stack id = + match Bindings.find_opt id !stacks with Some (x :: _) -> x | (Some [] | None) -> 0 + in + let push_stack id n = + stacks := Bindings.add id (n :: match Bindings.find_opt id !stacks with Some s -> s | None -> []) !stacks + in + + let rec fold_frag = function + | F_id id -> + let i = top_stack id in + F_id (append_id id ("_" ^ string_of_int i)) + | F_ref id -> + let i = top_stack id in + F_ref (append_id id ("_" ^ string_of_int i)) + | F_lit vl -> F_lit vl + | F_have_exception -> F_have_exception + | F_current_exception -> F_current_exception + | F_op (f1, op, f2) -> F_op (fold_frag f1, op, fold_frag f2) + | F_unary (op, f) -> F_unary (op, fold_frag f) + | F_call (id, fs) -> F_call (id, List.map fold_frag fs) + | F_field (f, field) -> F_field (fold_frag f, field) + | F_raw str -> F_raw str + | F_poly f -> F_poly (fold_frag f) + in + + let rec fold_clexp = function + | CL_id (id, ctyp) -> + let i = get_count id + 1 in + counts := Bindings.add id i !counts; + push_stack id i; + CL_id (append_id id ("_" ^ string_of_int i), ctyp) + | CL_field (clexp, field) -> CL_field (fold_clexp clexp, field) + | CL_addr clexp -> CL_addr (fold_clexp clexp) + | CL_tuple (clexp, n) -> CL_tuple (fold_clexp clexp, n) + | CL_current_exception ctyp -> CL_current_exception ctyp + | CL_have_exception -> CL_have_exception + | CL_return ctyp -> CL_return ctyp + | CL_void -> CL_void + in + + let fold_cval (f, ctyp) = (fold_frag f, ctyp) in + + let ssa_instr (I_aux (aux, annot)) = + let aux = match aux with + | I_funcall (clexp, extern, id, args) -> + let args = List.map fold_cval args in + I_funcall (fold_clexp clexp, extern, id, args) + | I_copy (clexp, cval) -> + let cval = fold_cval cval in + I_copy (fold_clexp clexp, cval) + | I_decl (ctyp, id) -> + let i = get_count id + 1 in + counts := Bindings.add id i !counts; + push_stack id i; + I_decl (ctyp, append_id id ("_" ^ string_of_int i)) + | I_init (ctyp, id, cval) -> + let cval = fold_cval cval in + let i = get_count id + 1 in + counts := Bindings.add id i !counts; + push_stack id i; + I_init (ctyp, append_id id ("_" ^ string_of_int i), cval) + | instr -> instr + in + I_aux (aux, annot) + in + + let ssa_cfnode = function + | CF_start -> CF_start + | CF_block instrs -> CF_block (List.map ssa_instr instrs) + | CF_label label -> CF_label label + in + + let ssa_ssanode = function + | Phi (id, args) -> + let i = get_count id + 1 in + counts := Bindings.add id i !counts; + push_stack id i; + Phi (append_id id ("_" ^ string_of_int i), args) + in + + let fix_phi j = function + | Phi (id, ids) -> + Phi (id, List.mapi (fun k a -> + if k = j then + let i = top_stack a in + append_id a ("_" ^ string_of_int i) + else a) + ids) + in + + let rec rename n = + let old_stacks = !stacks in + begin match graph.nodes.(n) with + | Some ((ssa, cfnode), preds, succs) -> + let ssa = List.map ssa_ssanode ssa in + graph.nodes.(n) <- Some ((ssa, ssa_cfnode cfnode), preds, succs); + List.iter (fun succ -> + match graph.nodes.(succ) with + | Some ((ssa, cfnode), preds, succs) -> + (* Suppose n is the j-th predecessor of succ *) + let rec find_j n succ = function + | pred :: preds -> + if pred = succ then n else find_j (n + 1) succ preds + | [] -> assert false + in + let j = find_j 0 n (IntSet.elements preds) in + graph.nodes.(succ) <- Some ((List.map (fix_phi j) ssa, cfnode), preds, succs) + | None -> assert false + ) (IntSet.elements succs) + | None -> assert false + end; + IntSet.iter (fun child -> rename child) (children.(n)); + stacks := old_stacks + in + rename root + +let ssa instrs = + let start, finish, cfg = control_flow_graph instrs in + let idom = immediate_dominators cfg start in + let children = dominator_children idom in + let df = dominance_frontiers cfg start idom children in + place_phi_functions cfg df; + rename_variables cfg start children; + cfg + +(* Debugging utilities for outputing Graphviz files. *) + +let string_of_phis = function + | [] -> "" + | phis -> Util.string_of_list "\\l" (fun (Phi (id, args)) -> string_of_id id ^ " = phi(" ^ Util.string_of_list ", " string_of_id args ^ ")") phis ^ "\\l" + +let string_of_node = function + | (phis, CF_label label) -> string_of_phis phis ^ label + | (phis, CF_block instrs) -> string_of_phis phis ^ Util.string_of_list "\\l" (fun instr -> String.escaped (Pretty_print_sail.to_string (pp_instr ~short:true instr))) instrs + | (phis, CF_start) -> string_of_phis phis ^ "START" + +let vertex_color = function + | (_, CF_start) -> "peachpuff" + | (_, CF_block _) -> "white" + | (_, CF_label _) -> "springgreen" + +let edge_color node_from node_to = + match node_from, node_to with + | CF_block _, CF_block _ -> "black" + | CF_label _, CF_block _ -> "red" + | CF_block _, CF_label _ -> "blue" + | _, _ -> "deeppink" + +let make_dot out_chan graph = + Util.opt_colors := false; + output_string out_chan "digraph DEPS {\n"; + let make_node i n = + output_string out_chan (Printf.sprintf " n%i [label=\"%s\";shape=box;style=filled;fillcolor=%s];\n" i (string_of_node n) (vertex_color n)) + in + let make_line i s = + output_string out_chan (Printf.sprintf " n%i -> n%i [color=black];\n" i s) + in + for i = 0 to graph.next - 1 do + match graph.nodes.(i) with + | Some (n, _, successors) -> + make_node i n; + IntSet.iter (fun s -> make_line i s) successors + | None -> () + done; + output_string out_chan "}\n"; + Util.opt_colors := true + +let make_dominators_dot out_chan idom graph = + Util.opt_colors := false; + output_string out_chan "digraph DOMS {\n"; + let make_node i n = + output_string out_chan (Printf.sprintf " n%i [label=\"%s\";shape=box;style=filled;fillcolor=%s];\n" i (string_of_node n) (vertex_color n)) + in + let make_line i s = + output_string out_chan (Printf.sprintf " n%i -> n%i [color=black];\n" i s) + in + for i = 0 to Array.length idom - 1 do + match graph.nodes.(i) with + | Some (n, _, _) -> + if idom.(i) = -1 then + make_node i n + else + (make_node i n; make_line i idom.(i)) + | None -> () + done; + output_string out_chan "}\n"; + Util.opt_colors := true diff --git a/src/jib/jib_ssa.mli b/src/jib/jib_ssa.mli new file mode 100644 index 00000000..3796a114 --- /dev/null +++ b/src/jib/jib_ssa.mli @@ -0,0 +1,85 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Array + +(** A mutable array based graph type, with nodes indexed by integers. *) +type 'a array_graph + +(** Create an empty array_graph, specifying the initial size of the + underlying array. *) +val make : initial_size:int -> unit -> 'a array_graph + +(** Add a vertex to a graph, returning the index of the inserted + vertex. If the number of vertices exceeds the size of the + underlying array, then it is dynamically resized. *) +val add_vertex : 'a -> 'a array_graph -> int + +(** Add an edge between two existing vertices. Raises Invalid_argument + if either of the vertices do not exist. *) +val add_edge : int -> int -> 'a array_graph -> unit + +type cf_node = + | CF_label of string + | CF_block of Jib.instr list + | CF_start + +val control_flow_graph : Jib.instr list -> int * int list * ('a list * cf_node) array_graph + +type ssa_elem = + | Phi of Ast.id * Ast.id list + +(** Convert a list of instructions into SSA form *) +val ssa : Jib.instr list -> (ssa_elem list * cf_node) array_graph + +(** Output the control-flow graph in graphviz format for + debugging. Can use 'dot -Tpng X.gv -o X.png' to generate a png + image of the graph. *) +val make_dot : out_channel -> (ssa_elem list * cf_node) array_graph -> unit diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml index 17227875..81cd07ef 100644 --- a/src/jib/jib_util.ml +++ b/src/jib/jib_util.ml @@ -154,6 +154,7 @@ let rec clexp_rename from_id to_id = function | CL_current_exception ctyp -> CL_current_exception ctyp | CL_have_exception -> CL_have_exception | CL_return ctyp -> CL_return ctyp + | CL_void -> CL_void let rec instr_rename from_id to_id (I_aux (instr, aux)) = let instr = match instr with @@ -482,6 +483,7 @@ let rec pp_clexp = function | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp | CL_have_exception -> string "have_exception" | CL_return ctyp -> string "return : " ^^ pp_ctyp ctyp + | CL_void -> string "void" let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = match instr with @@ -581,40 +583,6 @@ let pp_cdef = function ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace ^^ hardline -(**************************************************************************) -(* 2. Dependency Graphs *) -(**************************************************************************) - -type graph_node = - | G_label of string - | G_instr of int * instr - | G_start - -let string_of_node = function - | G_label label -> label - | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) - | G_start -> "START" - -module Node = struct - type t = graph_node - let compare gn1 gn2 = - match gn1, gn2 with - | G_label str1, G_label str2 -> String.compare str1 str2 - | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 - | G_start , G_start -> 0 - | G_start , _ -> 1 - | _ , G_start -> -1 - | G_instr _, _ -> 1 - | _ , G_instr _ -> -1 -end - -module NodeGraph = Graph.Make(Node) - -module NM = Map.Make(Node) -module NS = Set.Make(Node) - -type dep_graph = NodeGraph.graph - let rec fragment_deps = function | F_id id | F_ref id -> IdSet.singleton id | F_lit _ -> IdSet.empty @@ -635,6 +603,7 @@ let rec clexp_deps = function | CL_have_exception -> IdSet.empty | CL_current_exception _ -> IdSet.empty | CL_return _ -> IdSet.empty + | CL_void -> IdSet.empty (* Return the direct, read/write dependencies of a single instruction *) let instr_deps = function @@ -646,7 +615,7 @@ let instr_deps = function | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id + | I_clear (_, id) -> IdSet.singleton id, IdSet.empty | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty @@ -656,80 +625,6 @@ let instr_deps = function | I_match_failure -> IdSet.empty, IdSet.empty | I_end -> IdSet.empty, IdSet.empty -(* instrs_graph returns the control-flow graph for a list of - instructions. *) -let instrs_graph instrs = - let icounter = ref 0 in - let graph = ref NodeGraph.empty in - - let rec add_instr last_instrs (I_aux (instr, _) as iaux) = - incr icounter; - let node = G_instr (!icounter, iaux) in - match instr with - | I_block instrs | I_try_block instrs -> - List.fold_left add_instr last_instrs instrs - | I_if (_, then_instrs, else_instrs, _) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - let n1 = List.fold_left add_instr [node] then_instrs in - let n2 = List.fold_left add_instr [node] else_instrs in - incr icounter; - let join = G_instr (!icounter, icomment "join") in - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; - [join] - | I_return _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | I_label label -> - graph := NodeGraph.add_edge' (G_label label) node !graph; - node :: last_instrs - | I_goto label -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edge' node (G_label label) !graph; - [] - | I_jump (cval, label) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edges' (G_label label) [] !graph; - [node] - | I_match_failure -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [node] - in - ignore (List.fold_left add_instr [G_start] instrs); - let graph = NodeGraph.fix_leaves !graph in - graph - -let make_dot id graph = - Util.opt_colors := false; - let to_string node = String.escaped (string_of_node node) in - let node_color = function - | G_start -> "lightpink" - | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" - | G_instr (_, I_aux (I_init _, _)) -> "springgreen" - | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" - | G_instr (_, I_aux (I_goto _, _)) -> "orange1" - | G_instr (_, I_aux (I_label _, _)) -> "white" - | G_instr (_, I_aux (I_raw _, _)) -> "khaki" - | G_instr (_, I_aux (I_return _, _)) -> "deeppink" - | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" - | G_instr _ -> "azure" - | G_label _ -> "lightpink" - in - let edge_color from_node to_node = - match from_node, to_node with - | G_start , _ -> "goldenrod4" - | G_label _, _ -> "darkgreen" - | _ , G_label _ -> "goldenrod4" - | G_instr _, G_instr _ -> "black" - | _ , _ -> "coral3" - in - let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in - NodeGraph.make_dot node_color edge_color to_string out_chan graph; - close_out out_chan - let rec map_clexp_ctyp f = function | CL_id (id, ctyp) -> CL_id (id, f ctyp) | CL_field (clexp, field) -> CL_field (map_clexp_ctyp f clexp, field) @@ -738,6 +633,7 @@ let rec map_clexp_ctyp f = function | CL_current_exception ctyp -> CL_current_exception (f ctyp) | CL_have_exception -> CL_have_exception | CL_return ctyp -> CL_return (f ctyp) + | CL_void -> CL_void let rec map_instr_ctyp f (I_aux (instr, aux)) = let instr = match instr with @@ -778,6 +674,18 @@ let rec map_instr f (I_aux (instr, aux)) = in f (I_aux (instr, aux)) +(** Iterate over each instruction within an instruction, bottom-up *) +let rec iter_instr f (I_aux (instr, aux)) = + match instr with + | I_decl _ | I_init _ | I_reset _ | I_reinit _ + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> f (I_aux (instr, aux)) + | I_if (cval, instrs1, instrs2, ctyp) -> + List.iter (iter_instr f) instrs1; + List.iter (iter_instr f) instrs2 + | I_block instrs | I_try_block instrs -> + List.iter (iter_instr f) instrs + (** Map over each instruction in a cdef using map_instr *) let cdef_map_instr f = function | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs) @@ -816,17 +724,21 @@ let rec map_instrs f (I_aux (instr, aux)) = in I_aux (instr, aux) +let map_instr_list f instrs = + List.map (map_instr f) instrs + +let map_instrs_list f instrs = + f (List.map (map_instrs f) instrs) + let rec instr_ids (I_aux (instr, _)) = let reads, writes = instr_deps instr in - IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) + IdSet.union reads writes let rec instr_reads (I_aux (instr, _)) = - let reads, _ = instr_deps instr in - IdSet.of_list (IdSet.elements reads) + fst (instr_deps instr) let rec instr_writes (I_aux (instr, _)) = - let _, writes = instr_deps instr in - IdSet.of_list (IdSet.elements writes) + snd (instr_deps instr) let rec filter_instrs f instrs = let filter_instrs' = function @@ -878,6 +790,7 @@ let rec clexp_ctyp = function end | CL_have_exception -> CT_bool | CL_current_exception ctyp -> ctyp + | CL_void -> CT_unit let rec instr_ctyps (I_aux (instr, aux)) = match instr with @@ -933,3 +846,29 @@ let instr_split_at f = | instr :: instrs -> instr_split_at' f (instr :: before) instrs in instr_split_at' f [] + +let rec instrs_rename from_id to_id = + let rename id = if Id.compare id from_id = 0 then to_id else id in + let crename = cval_rename from_id to_id in + let irename instrs = instrs_rename from_id to_id instrs in + let lrename = clexp_rename from_id to_id in + function + | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs + | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs + | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs + | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs + | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs + | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> + I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs + | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs + | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs + | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs + | (I_aux ((I_comment _ | I_raw _ | I_end | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs + | [] -> [] diff --git a/src/sail.ml b/src/sail.ml index 50719776..b654831b 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -290,7 +290,7 @@ let options = Arg.align ([ Arg.String (fun l -> opt_ddump_rewrite_ast := Some (l, 0)), " (debug) dump the ast after each rewriting step to _.lem"); ( "-ddump_flow_graphs", - Arg.Set C_backend.opt_debug_flow_graphs, + Arg.Set Jib_compile.opt_debug_flow_graphs, " (debug) dump flow analysis for Sail functions when compiling to C"); ( "-dtc_verbose", Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity), diff --git a/src/sail.odocl b/src/sail.odocl index 4e91e22e..0a45eba3 100644 --- a/src/sail.odocl +++ b/src/sail.odocl @@ -11,6 +11,7 @@ specialize anf jib jib_compile +jib_ssa jib_util util graph \ No newline at end of file -- cgit v1.2.3