diff options
Diffstat (limited to 'src')
40 files changed, 7416 insertions, 9972 deletions
diff --git a/src/Makefile b/src/Makefile index be1eb9e5..8ef800a6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -40,7 +40,7 @@ # SUCH DAMAGE. # ########################################################################## -.PHONY: all sail test clean doc lib power test_power test_idempotence +.PHONY: all sail sail.native sail.byte test clean doc lib power test_power test_idempotence # set to -p on command line to enable gprof profiling OCAML_OPTS?= @@ -50,7 +50,7 @@ all: sail lib doc full: sail lib power doc test sail: - ocamlbuild sail.native sail_lib.cma sail_lib.cmxa + ocamlbuild sail.native sail.native: sail @@ -1,7 +1,7 @@ true: -traverse, debug <**/*.ml>: bin_annot, annot <lem_interp> or <test>: include -<sail.{byte,native}>: use_pprint, use_nums +<sail.{byte,native}>: use_pprint, use_nums, use_unix <pprint> or <pprint/src>: include # see http://caml.inria.fr/mantis/view.php?id=4943 @@ -42,7 +42,6 @@ (* generated by Ott 0.25 from: l2.ott *) - type text = string type l = Parse_ast.l @@ -53,7 +52,7 @@ type 'a annot = l * 'a type x = text (* identifier *) type ix = text (* infix identifier *) -type +type base_kind_aux = (* base kind *) BK_type (* kind of types *) | BK_nat (* kind of natural number size expressions *) @@ -61,43 +60,43 @@ base_kind_aux = (* base kind *) | BK_effect (* kind of effect sets *) -type -base_kind = +type +base_kind = BK_aux of base_kind_aux * l -type +type id_aux = (* Identifier *) Id of x | DeIid of x (* remove infix status *) -type +type kid_aux = (* variables with kind, ticked to differntiate from program variables *) Var of x -type +type kind_aux = (* kinds *) K_kind of (base_kind) list -type -id = +type +id = Id_aux of id_aux * l -type -kid = +type +kid = Kid_aux of kid_aux * l -type -kind = +type +kind = K_aux of kind_aux * l -type +type nexp_aux = (* expression of kind Nat, for vector sizes and origins *) Nexp_id of id (* identifier, bound by def Nat x = nexp *) | Nexp_var of kid (* variable *) @@ -108,11 +107,11 @@ nexp_aux = (* expression of kind Nat, for vector sizes and origins *) | Nexp_exp of nexp (* exponential *) | Nexp_neg of nexp (* For internal use *) -and nexp = +and nexp = Nexp_aux of nexp_aux * l -type +type base_effect_aux = (* effect *) BE_rreg (* read register *) | BE_wreg (* write register *) @@ -133,76 +132,76 @@ base_effect_aux = (* effect *) | BE_lret (* Local return happened; not user-writable *) -type -base_effect = +type +base_effect = BE_aux of base_effect_aux * l -type +type order_aux = (* vector order specifications, of kind Order *) Ord_var of kid (* variable *) | Ord_inc (* increasing (little-endian) *) | Ord_dec (* decreasing (big-endian) *) -type +type effect_aux = (* effect set, of kind Effects *) Effect_var of kid | Effect_set of (base_effect) list (* effect set *) -type -order = +type +order = Ord_aux of order_aux * l -type -effect = +type +effect = Effect_aux of effect_aux * l -type +type kinded_id_aux = (* optionally kind-annotated identifier *) KOpt_none of kid (* identifier *) | KOpt_kind of kind * kid (* kind-annotated variable *) -type +type n_constraint_aux = (* constraint over kind $_$ *) NC_fixed of nexp * nexp | NC_bounded_ge of nexp * nexp | NC_bounded_le of nexp * nexp + | NC_not_equal of nexp * nexp | NC_nat_set_bounded of kid * (int) list + | NC_or of n_constraint * n_constraint + | NC_and of n_constraint * n_constraint - -type -kinded_id = - KOpt_aux of kinded_id_aux * l - - -type -n_constraint = +and +n_constraint = NC_aux of n_constraint_aux * l +type +kinded_id = + KOpt_aux of kinded_id_aux * l -type +type quant_item_aux = (* Either a kinded identifier or a nexp constraint for a typquant *) QI_id of kinded_id (* An optionally kinded identifier *) | QI_const of n_constraint (* A constraint for this type *) -type -quant_item = +type +quant_item = QI_aux of quant_item_aux * l -type +type typquant_aux = (* type quantifiers and constraints *) TypQ_tq of (quant_item) list | TypQ_no_forall (* sugar, omitting quantifier and constraints *) -type +type lit_aux = (* Literal constant *) L_unit (* $() : _$ *) | L_zero (* $_ : _$ *) @@ -214,14 +213,13 @@ lit_aux = (* Literal constant *) | L_bin of string (* bit vector constant, C-style *) | L_undef (* constant representing undefined values *) | L_string of string (* string constant *) + | L_real of string - -type -typquant = +type +typquant = TypQ_aux of typquant_aux * l - -type +type typ_aux = (* Type expressions, of kind $_$ *) Typ_wild (* Unspecified type *) | Typ_id of id (* Defined type *) @@ -230,7 +228,7 @@ typ_aux = (* Type expressions, of kind $_$ *) | Typ_tup of (typ) list (* Tuple type *) | Typ_app of id * (typ_arg) list (* type constructor application *) -and typ = +and typ = Typ_aux of typ_aux * l and typ_arg_aux = (* Type constructor arguments of all kinds *) @@ -239,21 +237,21 @@ and typ_arg_aux = (* Type constructor arguments of all kinds *) | Typ_arg_order of order | Typ_arg_effect of effect -and typ_arg = +and typ_arg = Typ_arg_aux of typ_arg_aux * l -type -lit = +type +lit = L_aux of lit_aux * l -type +type typschm_aux = (* type scheme *) TypSchm_ts of typquant * typ -type +type 'a pat_aux = (* Pattern *) P_lit of lit (* literal constant pattern *) | P_wild (* wildcard *) @@ -267,28 +265,29 @@ type | P_vector_concat of ('a pat) list (* concatenated vector pattern *) | P_tup of ('a pat) list (* tuple pattern *) | P_list of ('a pat) list (* list pattern *) + | P_cons of 'a pat * 'a pat -and 'a pat = +and 'a pat = P_aux of 'a pat_aux * 'a annot and 'a fpat_aux = (* Field pattern *) FP_Fpat of id * 'a pat -and 'a fpat = +and 'a fpat = FP_aux of 'a fpat_aux * 'a annot -type -typschm = +type +typschm = TypSchm_aux of typschm_aux * l -type -'a reg_id_aux = +type +'a reg_id_aux = RI_id of id -type +type 'a exp_aux = (* Expression *) E_block of ('a exp) list (* block *) | E_nondet of ('a exp) list (* nondeterminisitic block, expressions evaluate in an unspecified order, or concurrently *) @@ -316,6 +315,7 @@ type | E_let of 'a letbind * 'a exp (* let expression *) | E_assign of 'a lexp * 'a exp (* imperative assignment *) | E_sizeof of nexp (* Expression to return the value of the nexp variable or expression at run time *) + | E_constraint of n_constraint (* Expression to evaluate the n_constraint at run time *) | E_exit of 'a exp (* expression to halt all current execution, potentially calling a system, trap, or interrupt handler with exp *) | E_return of 'a exp (* expression to end current function execution and return the value of exp from the function; this can be used to break out of for loops *) | E_assert of 'a exp * 'a exp (* expression to halt with error, when the first expression is false, reporting the optional string as an error *) @@ -329,7 +329,7 @@ type | E_internal_plet of 'a pat * 'a exp * 'a exp (* This is an internal node, used to distinguised some introduced lets during processing from original ones *) | E_internal_return of 'a exp (* For internal use to embed into monad definition *) -and 'a exp = +and 'a exp = E_aux of 'a exp_aux * 'a annot and 'a lexp_aux = (* lvalue expression *) @@ -341,82 +341,83 @@ and 'a lexp_aux = (* lvalue expression *) | LEXP_vector_range of 'a lexp * 'a exp * 'a exp (* subvector *) | LEXP_field of 'a lexp * id (* struct field *) -and 'a lexp = +and 'a lexp = LEXP_aux of 'a lexp_aux * 'a annot and 'a fexp_aux = (* Field-expression *) FE_Fexp of id * 'a exp -and 'a fexp = +and 'a fexp = FE_aux of 'a fexp_aux * 'a annot and 'a fexps_aux = (* Field-expression list *) FES_Fexps of ('a fexp) list * bool -and 'a fexps = +and 'a fexps = FES_aux of 'a fexps_aux * 'a annot and 'a opt_default_aux = (* Optional default value for indexed vectors, to define a defualt value for any unspecified positions in a sparse map *) Def_val_empty | Def_val_dec of 'a exp -and 'a opt_default = +and 'a opt_default = Def_val_aux of 'a opt_default_aux * 'a annot and 'a pexp_aux = (* Pattern match *) - Pat_exp of 'a pat * 'a exp + Pat_exp of 'a pat * 'a exp +| Pat_when of 'a pat * 'a exp * 'a exp -and 'a pexp = +and 'a pexp = Pat_aux of 'a pexp_aux * 'a annot and 'a letbind_aux = (* Let binding *) LB_val_explicit of typschm * 'a pat * 'a exp (* value binding, explicit type ('a pat must be total) *) | LB_val_implicit of 'a pat * 'a exp (* value binding, implicit type ('a pat must be total) *) -and 'a letbind = +and 'a letbind = LB_aux of 'a letbind_aux * 'a annot -type -'a reg_id = +type +'a reg_id = RI_aux of 'a reg_id_aux * 'a annot -type +type type_union_aux = (* Type union constructors *) Tu_id of id | Tu_ty_id of typ * id -type +type name_scm_opt_aux = (* Optional variable-naming-scheme specification for variables of defined type *) Name_sect_none | Name_sect_some of string -type +type effect_opt_aux = (* Optional effect annotation for functions *) Effect_opt_pure (* sugar for empty effect set *) | Effect_opt_effect of effect -type +type 'a funcl_aux = (* Function clause *) FCL_Funcl of id * 'a pat * 'a exp -type +type rec_opt_aux = (* Optional recursive annotation for functions *) Rec_nonrec (* non-recursive *) | Rec_rec (* recursive *) -type +type tannot_opt_aux = (* Optional type annotation for functions *) Typ_annot_opt_some of typquant * typ + | Typ_annot_opt_none - -type +type 'a alias_spec_aux = (* Register alias expression forms. Other than where noted, each id must refer to an unaliased register of type vector *) AL_subreg of 'a reg_id * id | AL_bit of 'a reg_id * 'a exp @@ -424,60 +425,60 @@ type | AL_concat of 'a reg_id * 'a reg_id -type -type_union = +type +type_union = Tu_aux of type_union_aux * l -type +type index_range_aux = (* index specification, for bitfields in register types *) BF_single of int (* single index *) | BF_range of int * int (* index range *) | BF_concat of index_range * index_range (* concatenation of index ranges *) -and index_range = +and index_range = BF_aux of index_range_aux * l -type -name_scm_opt = +type +name_scm_opt = Name_sect_aux of name_scm_opt_aux * l -type -effect_opt = +type +effect_opt = Effect_opt_aux of effect_opt_aux * l -type -'a funcl = +type +'a funcl = FCL_aux of 'a funcl_aux * 'a annot -type -rec_opt = +type +rec_opt = Rec_aux of rec_opt_aux * l -type -tannot_opt = +type +tannot_opt = Typ_annot_opt_aux of tannot_opt_aux * l -type -'a alias_spec = +type +'a alias_spec = AL_aux of 'a alias_spec_aux * 'a annot -type -'a default_spec_aux = (* Default kinding or typing assumption *) +type +default_spec_aux = (* Default kinding or typing assumption *) DT_kind of base_kind * kid | DT_order of order | DT_typ of typschm * id -type -'a type_def_aux = (* Type definition body *) +type +type_def_aux = (* Type definition body *) TD_abbrev of id * name_scm_opt * typschm (* type abbreviation *) | TD_record of id * name_scm_opt * typquant * ((typ * id)) list * bool (* struct type definition *) | TD_variant of id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) @@ -485,14 +486,15 @@ type | TD_register of id * nexp * nexp * ((index_range * id)) list (* register mutable bitfield type definition *) -type -'a val_spec_aux = (* Value type specification *) +type +val_spec_aux = (* Value type specification *) VS_val_spec of typschm * id | VS_extern_no_rename of typschm * id | VS_extern_spec of typschm * id * string (* Specify the type and id of a function from Lem, where the string must provide an explicit path to the required function but will not be checked *) + | VS_cast_spec of typschm * id -type +type 'a kind_def_aux = (* Definition body for elements of kind; many are shorthands for type\_defs *) KD_nabbrev of kind * id * name_scm_opt * nexp (* nexp abbreviation *) | KD_abbrev of kind * id * name_scm_opt * typschm (* type abbreviation *) @@ -502,7 +504,7 @@ type | KD_register of kind * id * nexp * nexp * ((index_range * id)) list (* register mutable bitfield type definition *) -type +type 'a scattered_def_aux = (* Function and type union definitions that can be spread across a file. Each one must end in $_$ *) SD_scattered_function of rec_opt * tannot_opt * effect_opt * id (* scattered function definition header *) @@ -512,54 +514,54 @@ type | SD_scattered_end of id (* scattered definition end *) -type +type 'a fundef_aux = (* Function definition *) FD_function of rec_opt * tannot_opt * effect_opt * ('a funcl) list -type +type 'a dec_spec_aux = (* Register declarations *) DEC_reg of typ * id | DEC_alias of id * 'a alias_spec | DEC_typ_alias of typ * id * 'a alias_spec -type -'a default_spec = - DT_aux of 'a default_spec_aux * l +type +'a default_spec = + DT_aux of default_spec_aux * l -type -'a type_def = - TD_aux of 'a type_def_aux * 'a annot +type +'a type_def = + TD_aux of type_def_aux * 'a annot -type -'a val_spec = - VS_aux of 'a val_spec_aux * 'a annot +type +'a val_spec = + VS_aux of val_spec_aux * 'a annot -type -'a kind_def = +type +'a kind_def = KD_aux of 'a kind_def_aux * 'a annot -type -'a scattered_def = +type +'a scattered_def = SD_aux of 'a scattered_def_aux * 'a annot -type -'a fundef = +type +'a fundef = FD_aux of 'a fundef_aux * 'a annot -type -'a dec_spec = +type +'a dec_spec = DEC_aux of 'a dec_spec_aux * 'a annot -type +type 'a dec_comm = (* Top-level generated comments *) DC_comm of string (* generated unstructured comment *) | DC_comm_struct of 'a def (* generated structured comment *) @@ -570,13 +572,13 @@ and 'a def = (* Top-level definition *) | DEF_fundef of 'a fundef (* function definition *) | DEF_val of 'a letbind (* value definition *) | DEF_spec of 'a val_spec (* top-level type constraint *) + | DEF_overload of id * id list (* operator overload specification *) | DEF_default of 'a default_spec (* default kind and type assumptions *) | DEF_scattered of 'a scattered_def (* scattered function and type definition *) | DEF_reg_dec of 'a dec_spec (* register declaration *) | DEF_comm of 'a dec_comm (* generated comments *) - -type +type 'a defs = (* Definition sequence *) Defs of ('a def) list diff --git a/src/ast_util.ml b/src/ast_util.ml new file mode 100644 index 00000000..5bb4e0a6 --- /dev/null +++ b/src/ast_util.ml @@ -0,0 +1,439 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Thomas Bauereiss *) +(* *) +(* 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 Util +open Big_int + +let mk_nc nc_aux = NC_aux (nc_aux, Parse_ast.Unknown) + +let mk_nexp nexp_aux = Nexp_aux (nexp_aux, Parse_ast.Unknown) + +let rec map_exp_annot f (E_aux (exp, annot)) = E_aux (map_exp_annot_aux f exp, f annot) +and map_exp_annot_aux f = function + | E_block xs -> E_block (List.map (map_exp_annot f) xs) + | E_nondet xs -> E_nondet (List.map (map_exp_annot f) xs) + | E_id id -> E_id id + | E_lit lit -> E_lit lit + | E_cast (typ, exp) -> E_cast (typ, map_exp_annot f exp) + | E_app (id, xs) -> E_app (id, List.map (map_exp_annot f) xs) + | E_app_infix (x, op, y) -> E_app_infix (map_exp_annot f x, op, map_exp_annot f y) + | E_tuple xs -> E_tuple (List.map (map_exp_annot f) xs) + | E_if (cond, t, e) -> E_if (map_exp_annot f cond, map_exp_annot f t, map_exp_annot f e) + | E_for (v, e1, e2, e3, o, e4) -> E_for (v, map_exp_annot f e1, map_exp_annot f e2, map_exp_annot f e3, o, map_exp_annot f e4) + | E_vector exps -> E_vector (List.map (map_exp_annot f) exps) + | E_vector_indexed (iexps, opt_default) -> + E_vector_indexed (List.map (fun (i, exp) -> (i, map_exp_annot f exp)) iexps, map_opt_default_annot f opt_default) + | E_vector_access (exp1, exp2) -> E_vector_access (map_exp_annot f exp1, map_exp_annot f exp2) + | E_vector_subrange (exp1, exp2, exp3) -> E_vector_subrange (map_exp_annot f exp1, map_exp_annot f exp2, map_exp_annot f exp3) + | E_vector_update (exp1, exp2, exp3) -> E_vector_update (map_exp_annot f exp1, map_exp_annot f exp2, map_exp_annot f exp3) + | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> + E_vector_update_subrange (map_exp_annot f exp1, map_exp_annot f exp2, map_exp_annot f exp3, map_exp_annot f exp4) + | E_vector_append (exp1, exp2) -> E_vector_append (map_exp_annot f exp1, map_exp_annot f exp2) + | E_list xs -> E_list (List.map (map_exp_annot f) xs) + | E_cons (exp1, exp2) -> E_cons (map_exp_annot f exp1, map_exp_annot f exp2) + | E_record fexps -> E_record (map_fexps_annot f fexps) + | E_record_update (exp, fexps) -> E_record_update (map_exp_annot f exp, map_fexps_annot f fexps) + | E_field (exp, id) -> E_field (map_exp_annot f exp, id) + | E_case (exp, cases) -> E_case (map_exp_annot f exp, List.map (map_pexp_annot f) cases) + | E_let (letbind, exp) -> E_let (map_letbind_annot f letbind, map_exp_annot f exp) + | E_assign (lexp, exp) -> E_assign (map_lexp_annot f lexp, map_exp_annot f exp) + | E_sizeof nexp -> E_sizeof nexp + | E_constraint nc -> E_constraint nc + | E_exit exp -> E_exit (map_exp_annot f exp) + | E_return exp -> E_return (map_exp_annot f exp) + | E_assert (test, msg) -> E_assert (map_exp_annot f test, map_exp_annot f msg) + | E_internal_cast (annot, exp) -> E_internal_cast (f annot, map_exp_annot f exp) + | E_internal_exp annot -> E_internal_exp (f annot) + | E_sizeof_internal annot -> E_sizeof_internal (f annot) + | E_internal_exp_user (annot1, annot2) -> E_internal_exp_user (f annot1, f annot2) + | E_comment str -> E_comment str + | E_comment_struc exp -> E_comment_struc (map_exp_annot f exp) + | E_internal_let (lexp, exp1, exp2) -> E_internal_let (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) + | E_internal_plet (pat, exp1, exp2) -> E_internal_plet (map_pat_annot f pat, map_exp_annot f exp1, map_exp_annot f exp2) + | E_internal_return exp -> E_internal_return (map_exp_annot f exp) +and map_opt_default_annot f (Def_val_aux (df, annot)) = Def_val_aux (map_opt_default_annot_aux f df, f annot) +and map_opt_default_annot_aux f = function + | Def_val_empty -> Def_val_empty + | Def_val_dec exp -> Def_val_dec (map_exp_annot f exp) +and map_fexps_annot f (FES_aux (FES_Fexps (fexps, b), annot)) = FES_aux (FES_Fexps (List.map (map_fexp_annot f) fexps, b), f annot) +and map_fexp_annot f (FE_aux (FE_Fexp (id, exp), annot)) = FE_aux (FE_Fexp (id, map_exp_annot f exp), f annot) +and map_pexp_annot f (Pat_aux (pexp, annot)) = Pat_aux (map_pexp_annot_aux f pexp, f annot) +and map_pexp_annot_aux f = function + | Pat_exp (pat, exp) -> Pat_exp (map_pat_annot f pat, map_exp_annot f exp) + | Pat_when (pat, guard, exp) -> Pat_when (map_pat_annot f pat, map_exp_annot f guard, map_exp_annot f exp) +and map_pat_annot f (P_aux (pat, annot)) = P_aux (map_pat_annot_aux f pat, f annot) +and map_pat_annot_aux f = function + | P_lit lit -> P_lit lit + | P_wild -> P_wild + | P_as (pat, id) -> P_as (map_pat_annot f pat, id) + | P_typ (typ, pat) -> P_typ (typ, map_pat_annot f pat) + | P_id id -> P_id id + | P_app (id, pats) -> P_app (id, List.map (map_pat_annot f) pats) + | P_record (fpats, b) -> P_record (List.map (map_fpat_annot f) fpats, b) + | P_tup pats -> P_tup (List.map (map_pat_annot f) pats) + | P_list pats -> P_list (List.map (map_pat_annot f) pats) + | P_vector_concat pats -> P_vector_concat (List.map (map_pat_annot f) pats) + | P_vector_indexed ipats -> P_vector_indexed (List.map (fun (i, pat) -> (i, map_pat_annot f pat)) ipats) + | P_vector pats -> P_vector (List.map (map_pat_annot f) pats) + | P_cons (pat1, pat2) -> P_cons (map_pat_annot f pat1, map_pat_annot f pat2) +and map_fpat_annot f (FP_aux (FP_Fpat (id, pat), annot)) = FP_aux (FP_Fpat (id, map_pat_annot f pat), f annot) +and map_letbind_annot f (LB_aux (lb, annot)) = LB_aux (map_letbind_annot_aux f lb, f annot) +and map_letbind_annot_aux f = function + | LB_val_explicit (typschm, pat, exp) -> LB_val_explicit (typschm, map_pat_annot f pat, map_exp_annot f exp) + | LB_val_implicit (pat, exp) -> LB_val_implicit (map_pat_annot f pat, map_exp_annot f exp) +and map_lexp_annot f (LEXP_aux (lexp, annot)) = LEXP_aux (map_lexp_annot_aux f lexp, f annot) +and map_lexp_annot_aux f = function + | LEXP_id id -> LEXP_id id + | LEXP_memory (id, exps) -> LEXP_memory (id, List.map (map_exp_annot f) exps) + | LEXP_cast (typ, id) -> LEXP_cast (typ, id) + | LEXP_tup lexps -> LEXP_tup (List.map (map_lexp_annot f) lexps) + | LEXP_vector (lexp, exp) -> LEXP_vector (map_lexp_annot f lexp, map_exp_annot f exp) + | LEXP_vector_range (lexp, exp1, exp2) -> LEXP_vector_range (map_lexp_annot f lexp, map_exp_annot f exp1, map_exp_annot f exp2) + | LEXP_field (lexp, id) -> LEXP_field (map_lexp_annot f lexp, id) + +let id_loc = function + | Id_aux (_, l) -> l + +let kid_loc = function + | Kid_aux (_, l) -> l + +let string_of_id = function + | Id_aux (Id v, _) -> v + | Id_aux (DeIid v, _) -> "(deinfix " ^ v ^ ")" + +let string_of_kid = function + | Kid_aux (Var v, _) -> v + +let string_of_base_effect_aux = function + | BE_rreg -> "rreg" + | BE_wreg -> "wreg" + | BE_rmem -> "rmem" + | BE_rmemt -> "rmemt" + | BE_wmem -> "wmem" + | BE_eamem -> "eamem" + | BE_exmem -> "exmem" + | BE_wmv -> "wmv" + | BE_wmvt -> "wmvt" + | BE_barr -> "barr" + | BE_depend -> "depend" + | BE_undef -> "undef" + | BE_unspec -> "unspec" + | BE_nondet -> "nondet" + | BE_escape -> "escape" + | BE_lset -> "lset" + | BE_lret -> "lret" + +let string_of_base_kind_aux = function + | BK_type -> "Type" + | BK_nat -> "Nat" + | BK_order -> "Order" + | BK_effect -> "Effect" + +let string_of_base_kind (BK_aux (bk, _)) = string_of_base_kind_aux bk + +let string_of_kind (K_aux (K_kind bks, _)) = string_of_list " -> " string_of_base_kind bks + +let string_of_base_effect = function + | BE_aux (beff, _) -> string_of_base_effect_aux beff + +let string_of_effect = function + | Effect_aux (Effect_var kid, _) -> + string_of_kid kid + | Effect_aux (Effect_set [], _) -> "pure" + | Effect_aux (Effect_set beffs, _) -> + "{" ^ string_of_list ", " string_of_base_effect beffs ^ "}" + +let string_of_order = function + | Ord_aux (Ord_var kid, _) -> string_of_kid kid + | Ord_aux (Ord_inc, _) -> "inc" + | Ord_aux (Ord_dec, _) -> "dec" + +let rec string_of_nexp = function + | Nexp_aux (nexp, _) -> string_of_nexp_aux nexp +and string_of_nexp_aux = function + | Nexp_id id -> string_of_id id + | Nexp_var kid -> string_of_kid kid + | Nexp_constant c -> string_of_int c + | Nexp_times (n1, n2) -> "(" ^ string_of_nexp n1 ^ " * " ^ string_of_nexp n2 ^ ")" + | Nexp_sum (n1, n2) -> "(" ^ string_of_nexp n1 ^ " + " ^ string_of_nexp n2 ^ ")" + | Nexp_minus (n1, n2) -> "(" ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2 ^ ")" + | Nexp_exp n -> "2 ^ " ^ string_of_nexp n + | Nexp_neg n -> "- " ^ string_of_nexp n + +let rec string_of_typ = function + | Typ_aux (typ, l) -> string_of_typ_aux typ +and string_of_typ_aux = function + | Typ_wild -> "_" + | Typ_id id -> string_of_id id + | Typ_var kid -> string_of_kid kid + | Typ_tup typs -> "(" ^ string_of_list ", " string_of_typ typs ^ ")" + | Typ_app (id, args) -> string_of_id id ^ "<" ^ string_of_list ", " string_of_typ_arg args ^ ">" + | Typ_fn (typ_arg, typ_ret, eff) -> + string_of_typ typ_arg ^ " -> " ^ string_of_typ typ_ret ^ " effect " ^ string_of_effect eff +and string_of_typ_arg = function + | Typ_arg_aux (typ_arg, l) -> string_of_typ_arg_aux typ_arg +and string_of_typ_arg_aux = function + | Typ_arg_nexp n -> string_of_nexp n + | Typ_arg_typ typ -> string_of_typ typ + | Typ_arg_order o -> string_of_order o + | Typ_arg_effect eff -> string_of_effect eff + +let rec string_of_n_constraint = function + | NC_aux (NC_fixed (n1, n2), _) -> string_of_nexp n1 ^ " = " ^ string_of_nexp n2 + | NC_aux (NC_not_equal (n1, n2), _) -> string_of_nexp n1 ^ " != " ^ string_of_nexp n2 + | NC_aux (NC_bounded_ge (n1, n2), _) -> string_of_nexp n1 ^ " >= " ^ string_of_nexp n2 + | NC_aux (NC_bounded_le (n1, n2), _) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2 + | NC_aux (NC_or (nc1, nc2), _) -> + "(" ^ string_of_n_constraint nc1 ^ " | " ^ string_of_n_constraint nc2 ^ ")" + | NC_aux (NC_and (nc1, nc2), _) -> + "(" ^ string_of_n_constraint nc1 ^ " & " ^ string_of_n_constraint nc2 ^ ")" + | NC_aux (NC_nat_set_bounded (kid, ns), _) -> + string_of_kid kid ^ " IN {" ^ string_of_list ", " string_of_int ns ^ "}" + +let string_of_quant_item_aux = function + | QI_id (KOpt_aux (KOpt_none kid, _)) -> string_of_kid kid + | QI_id (KOpt_aux (KOpt_kind (k, kid), _)) -> string_of_kind k ^ " " ^ string_of_kid kid + | QI_const constr -> string_of_n_constraint constr + +let string_of_quant_item = function + | QI_aux (qi, _) -> string_of_quant_item_aux qi + +let string_of_typquant_aux = function + | TypQ_tq quants -> "forall " ^ string_of_list ", " string_of_quant_item quants + | TypQ_no_forall -> "" + +let string_of_typquant = function + | TypQ_aux (quant, _) -> string_of_typquant_aux quant + +let string_of_typschm (TypSchm_aux (TypSchm_ts (quant, typ), _)) = + string_of_typquant quant ^ ". " ^ string_of_typ typ +let string_of_lit (L_aux (lit, _)) = + match lit with + | L_unit -> "()" + | L_zero -> "bitzero" + | L_one -> "bitone" + | L_true -> "true" + | L_false -> "false" + | L_num n -> string_of_int n + | L_hex n -> "0x" ^ n + | L_bin n -> "0b" ^ n + | L_undef -> "undefined" + | L_real r -> r + | L_string str -> "\"" ^ str ^ "\"" + +let rec string_of_exp (E_aux (exp, _)) = + match exp with + | E_block exps -> "{ " ^ string_of_list "; " string_of_exp exps ^ " }" + | E_id v -> string_of_id v + | E_sizeof nexp -> "sizeof " ^ string_of_nexp nexp + | E_constraint nc -> "constraint(" ^ string_of_n_constraint nc ^ ")" + | E_lit lit -> string_of_lit lit + | E_return exp -> "return " ^ string_of_exp exp + | E_app (f, args) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_exp args ^ ")" + | E_app_infix (x, op, y) -> "(" ^ string_of_exp x ^ " " ^ string_of_id op ^ " " ^ string_of_exp y ^ ")" + | E_tuple exps -> "(" ^ string_of_list ", " string_of_exp exps ^ ")" + | E_case (exp, cases) -> + "switch " ^ string_of_exp exp ^ " { case " ^ string_of_list " case " string_of_pexp cases ^ "}" + | E_let (letbind, exp) -> "let " ^ string_of_letbind letbind ^ " in " ^ string_of_exp exp + | E_assign (lexp, bind) -> string_of_lexp lexp ^ " := " ^ string_of_exp bind + | E_cast (typ, exp) -> "(" ^ string_of_typ typ ^ ") " ^ string_of_exp exp + | E_vector vec -> "[" ^ string_of_list ", " string_of_exp vec ^ "]" + | E_vector_access (v, n) -> string_of_exp v ^ "[" ^ string_of_exp n ^ "]" + | E_vector_subrange (v, n1, n2) -> string_of_exp v ^ "[" ^ string_of_exp n1 ^ " .. " ^ string_of_exp n2 ^ "]" + | E_vector_append (v1, v2) -> string_of_exp v1 ^ " : " ^ string_of_exp v2 + | E_if (cond, then_branch, else_branch) -> + "if " ^ string_of_exp cond ^ " then " ^ string_of_exp then_branch ^ " else " ^ string_of_exp else_branch + | E_field (exp, id) -> string_of_exp exp ^ "." ^ string_of_id id + | E_for (id, f, t, u, ord, body) -> + "foreach (" + ^ string_of_id id ^ " from " ^ string_of_exp f ^ " to " ^ string_of_exp t + ^ " by " ^ string_of_exp u ^ " order " ^ string_of_order ord + ^ ") { " + ^ string_of_exp body + | E_assert (test, msg) -> "assert(" ^ string_of_exp test ^ ", " ^ string_of_exp msg ^ ")" + | _ -> "INTERNAL" +and string_of_pexp (Pat_aux (pexp, _)) = + match pexp with + | Pat_exp (pat, exp) -> string_of_pat pat ^ " -> " ^ string_of_exp exp + | Pat_when (pat, guard, exp) -> string_of_pat pat ^ " when " ^ string_of_exp guard ^ " -> " ^ string_of_exp exp +and string_of_pat (P_aux (pat, l)) = + match pat with + | P_lit lit -> string_of_lit lit + | P_wild -> "_" + | P_id v -> string_of_id v + | P_typ (typ, pat) -> "(" ^ string_of_typ typ ^ ") " ^ string_of_pat pat + | P_tup pats -> "(" ^ string_of_list ", " string_of_pat pats ^ ")" + | P_app (f, pats) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_pat pats ^ ")" + | P_cons (pat1, pat2) -> string_of_pat pat1 ^ " :: " ^ string_of_pat pat2 + | P_list pats -> "[||" ^ string_of_list "," string_of_pat pats ^ "||]" + | _ -> "PAT" +and string_of_lexp (LEXP_aux (lexp, _)) = + match lexp with + | LEXP_id v -> string_of_id v + | LEXP_cast (typ, v) -> "(" ^ string_of_typ typ ^ ") " ^ string_of_id v + | LEXP_tup lexps -> "(" ^ string_of_list ", " string_of_lexp lexps ^ ")" + | LEXP_vector (lexp, exp) -> string_of_lexp lexp ^ "[" ^ string_of_exp exp ^ "]" + | LEXP_field (lexp, id) -> string_of_lexp lexp ^ "." ^ string_of_id id + | LEXP_memory (f, xs) -> string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")" + | _ -> "LEXP" +and string_of_letbind (LB_aux (lb, l)) = + match lb with + | LB_val_implicit (pat, exp) -> string_of_pat pat ^ " = " ^ string_of_exp exp + | LB_val_explicit (typschm, pat, exp) -> + string_of_typschm typschm ^ " " ^ string_of_pat pat ^ " = " ^ string_of_exp exp + +let rec string_of_index_range (BF_aux (ir, _)) = + match ir with + | BF_single n -> string_of_int n + | BF_range (n, m) -> string_of_int n ^ " .. " ^ string_of_int m + | BF_concat (ir1, ir2) -> "(" ^ string_of_index_range ir1 ^ ") : (" ^ string_of_index_range ir2 ^ ")" + +let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) = + match (List.fold_right + (fun (FCL_aux (FCL_Funcl (id, _, _), _)) id' -> + match id' with + | Some id' -> if string_of_id id' = string_of_id id then Some id' + else raise (Reporting_basic.err_typ l + ("Function declaration expects all definitions to have the same name, " + ^ string_of_id id ^ " differs from other definitions of " ^ string_of_id id')) + | None -> Some id) funcls None) + with + | Some id -> id + | None -> raise (Reporting_basic.err_typ l "funcl list is empty") + +module Kid = struct + type t = kid + let compare kid1 kid2 = String.compare (string_of_kid kid1) (string_of_kid kid2) +end + +module BE = struct + type t = base_effect + let compare be1 be2 = String.compare (string_of_base_effect be1) (string_of_base_effect be2) +end + +module Id = struct + type t = id + let compare id1 id2 = + match (id1, id2) with + | Id_aux (Id x, _), Id_aux (Id y, _) -> String.compare x y + | Id_aux (DeIid x, _), Id_aux (DeIid y, _) -> String.compare x y + | Id_aux (Id _, _), Id_aux (DeIid _, _) -> -1 + | Id_aux (DeIid _, _), Id_aux (Id _, _) -> 1 +end + +module Bindings = Map.Make(Id) +module IdSet = Set.Make(Id) +module KBindings = Map.Make(Kid) +module KidSet = Set.Make(Kid) + +let rec nexp_frees (Nexp_aux (nexp, l)) = + match nexp with + | Nexp_id _ -> raise (Reporting_basic.err_typ l "Unimplemented Nexp_id in nexp_frees") + | Nexp_var kid -> KidSet.singleton kid + | Nexp_constant _ -> KidSet.empty + | Nexp_times (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) + | Nexp_sum (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) + | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees n1) (nexp_frees n2) + | Nexp_exp n -> nexp_frees n + | Nexp_neg n -> nexp_frees n + +let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = + match nexp1, nexp2 with + | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0 + | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 = 0 + | Nexp_constant c1, Nexp_constant c2 -> c1 = c2 + | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | Nexp_exp n1, Nexp_exp n2 -> nexp_identical n1 n2 + | Nexp_neg n1, Nexp_neg n2 -> nexp_identical n1 n2 + | _, _ -> false + +let rec is_number (Typ_aux (t,_)) = + match t with + | Typ_app (Id_aux (Id "range", _),_) + | Typ_app (Id_aux (Id "implicit", _),_) + | Typ_app (Id_aux (Id "atom", _),_) -> true + | _ -> false + +let rec is_vector_typ = function + | Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;_;_;_]), _) -> true + | Typ_aux (Typ_app (Id_aux (Id "register",_), [Typ_arg_aux (Typ_arg_typ rtyp,_)]), _) -> + is_vector_typ rtyp + | _ -> false + +let typ_app_args_of = function + | Typ_aux (Typ_app (Id_aux (Id c,_), targs), l) -> + (c, List.map (fun (Typ_arg_aux (a,_)) -> a) targs, l) + | Typ_aux (_, l) -> raise (Reporting_basic.err_typ l "typ_app_args_of called on non-app type") + +let rec vector_typ_args_of typ = match typ_app_args_of typ with + | ("vector", [Typ_arg_nexp start; Typ_arg_nexp len; Typ_arg_order ord; Typ_arg_typ etyp], _) -> + (start, len, ord, etyp) + | ("register", [Typ_arg_typ rtyp], _) -> vector_typ_args_of rtyp + | (_, _, l) -> raise (Reporting_basic.err_typ l "vector_typ_args_of called on non-vector type") + +let is_order_inc = function + | Ord_aux (Ord_inc, _) -> true + | Ord_aux (Ord_dec, _) -> false + | Ord_aux (Ord_var _, l) -> + raise (Reporting_basic.err_unreachable l "is_order_inc called on vector with variable ordering") + +let is_bit_typ = function + | Typ_aux (Typ_id (Id_aux (Id "bit", _)), _) -> true + | _ -> false + +let is_bitvector_typ typ = + if is_vector_typ typ then + let (_,_,_,etyp) = vector_typ_args_of typ in + is_bit_typ etyp + else false + +let has_effect (Effect_aux (eff,_)) searched_for = match eff with + | Effect_set effs -> + List.exists (fun (BE_aux (be,_)) -> be = searched_for) effs + | Effect_var _ -> + raise (Reporting_basic.err_unreachable Parse_ast.Unknown + "has_effect called on effect variable") diff --git a/src/initial_check_full_ast.mli b/src/ast_util.mli index be612532..6e22d173 100644 --- a/src/initial_check_full_ast.mli +++ b/src/ast_util.mli @@ -9,6 +9,8 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Alasdair Armstrong *) +(* Thomas Bauereiss *) (* *) (* All rights reserved. *) (* *) @@ -41,11 +43,91 @@ (**************************************************************************) open Ast -open Type_internal -(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *) -type envs = Nameset.t * kind Envmap.t * Ast.order -type 'a envs_out = 'a * envs +val mk_nc : n_constraint_aux -> n_constraint +val mk_nexp : nexp_aux -> nexp -val to_checked_ast : Nameset.t -> kind Envmap.t -> Ast.order -> tannot defs -> tannot defs * kind Envmap.t * Ast.order -val to_exp : kind Envmap.t -> Ast.order -> exp -> exp +(* Functions to map over the 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_lexp_annot : ('a annot -> 'b annot) -> 'a lexp -> 'b lexp +val map_letbind_annot : ('a annot -> 'b annot) -> 'a letbind -> 'b letbind + +(* Extract locations from identifiers *) +val id_loc : id -> Parse_ast.l +val kid_loc : kid -> Parse_ast.l + +(* For debugging and error messages only: Not guaranteed to produce + parseable SAIL, or even print all language constructs! *) +(* TODO: replace with existing pretty-printer *) +val string_of_id : id -> string +val string_of_kid : kid -> string +val string_of_base_effect_aux : base_effect_aux -> string +val string_of_base_kind_aux : base_kind_aux -> string +val string_of_base_kind : base_kind -> string +val string_of_kind : kind -> string +val string_of_base_effect : base_effect -> string +val string_of_effect : effect -> string +val string_of_order : order -> string +val string_of_nexp : nexp -> string +val string_of_typ : typ -> string +val string_of_typ_arg : typ_arg -> string +val string_of_n_constraint : n_constraint -> string +val string_of_quant_item : quant_item -> string +val string_of_typquant : typquant -> string +val string_of_typschm : typschm -> string +val string_of_lit : lit -> string +val string_of_exp : 'a exp -> string +val string_of_pexp : 'a pexp -> string +val string_of_lexp : 'a lexp -> string +val string_of_pat : 'a pat -> string +val string_of_letbind : 'a letbind -> string +val string_of_index_range : index_range -> string + +val id_of_fundef : 'a fundef -> id + +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 BE : sig + type t = base_effect + val compare : base_effect -> base_effect -> int +end + +module IdSet : sig + include Set.S with type elt = id +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 + +val nexp_frees : nexp -> KidSet.t +val nexp_identical : nexp -> nexp -> bool + +val is_number : 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 * nexp * order * typ + +val is_order_inc : order -> bool + +val has_effect : effect -> base_effect_aux -> bool diff --git a/src/constraint.ml b/src/constraint.ml new file mode 100644 index 00000000..f71193b2 --- /dev/null +++ b/src/constraint.ml @@ -0,0 +1,306 @@ +open Big_int +open Util + +(* ===== Integer Constraints ===== *) + +type nexp_op = Plus | Minus | Mult + +type nexp = + | NFun of (nexp_op * nexp * nexp) + | N2n of nexp + | NConstant of big_int + | NVar of int + +let big_int_op : nexp_op -> big_int -> big_int -> big_int = function + | Plus -> add_big_int + | Minus -> sub_big_int + | Mult -> mult_big_int + +let rec arith constr = + let constr' = match constr with + | NFun (op, x, y) -> NFun (op, arith x, arith y) + | N2n c -> arith c + | c -> c + in + match constr' with + | NFun (op, NConstant x, NConstant y) -> NConstant (big_int_op op x y) + | N2n (NConstant x) -> NConstant (power_int_positive_big_int 2 x) + | c -> c + +(* ===== Boolean Constraints ===== *) + +type constraint_bool_op = And | Or + +type constraint_compare_op = Gt | Lt | GtEq | LtEq | Eq | NEq + +let negate_comparison = function + | Gt -> LtEq + | Lt -> GtEq + | GtEq -> Lt + | LtEq -> Gt + | Eq -> NEq + | NEq -> Eq + +type 'a constraint_bool = + | BFun of (constraint_bool_op * 'a constraint_bool * 'a constraint_bool) + | Not of 'a constraint_bool + | CFun of (constraint_compare_op * 'a * 'a) + | Branch of ('a constraint_bool list) + | Boolean of bool + +let rec pairs (xs : 'a list) (ys : 'a list) : ('a * 'b) list = + match xs with + | [] -> [] + | (x :: xs) -> List.map (fun y -> (x, y)) ys @ pairs xs ys + +let rec unbranch : 'a constraint_bool -> 'a constraint_bool list = function + | Branch xs -> List.map unbranch xs |> List.concat + | Not x -> unbranch x |> List.map (fun y -> Not y) + | BFun (op, x, y) -> + let xs, ys = unbranch x, unbranch y in + List.map (fun (z, w) -> BFun (op, z, w)) (pairs xs ys) + | c -> [c] + +(* Apply De Morgan's laws to push all negations to just before integer + constraints *) +let rec de_morgan : 'a constraint_bool -> 'a constraint_bool = function + | Not (Not x) -> de_morgan x + | Not (BFun (And, x, y)) -> BFun (Or, de_morgan (Not x), de_morgan (Not y)) + | Not (BFun (Or, x, y)) -> BFun (And, de_morgan (Not x), de_morgan (Not y)) + | Not (Boolean b) -> Boolean (not b) + | BFun (op, x, y) -> BFun (op, de_morgan x, de_morgan y) + | c -> c + +(* Once De Morgan's laws are applied we can push all the Nots into + comparison constraints *) +let rec remove_nots : 'a constraint_bool -> 'a constraint_bool = function + | BFun (op, x, y) -> BFun (op, remove_nots x, remove_nots y) + | Not (CFun (c, x, y)) -> CFun (negate_comparison c, x, y) + | c -> c + +(* Apply distributivity so all Or clauses are within And clauses *) +let rec distrib_step : 'a constraint_bool -> ('a constraint_bool * int) = function + | BFun (Or, x, BFun (And, y, z)) -> + let (xy, n) = distrib_step (BFun (Or, x, y)) in + let (xz, m) = distrib_step (BFun (Or, x, z)) in + BFun (And, xy, xz), n + m + 1 + | BFun (Or, BFun (And, x, y), z) -> + let (xz, n) = distrib_step (BFun (Or, x, z)) in + let (yz, m) = distrib_step (BFun (Or, y, z)) in + BFun (And, xz, yz), n + m + 1 + | BFun (op, x, y) -> + let (x', n) = distrib_step x in + let (y', m) = distrib_step y in + BFun (op, x', y'), n + m + | c -> (c, 0) + +let rec distrib (c : 'a constraint_bool) : 'a constraint_bool = + let (c', n) = distrib_step c in + if n = 0 then c else distrib c' + +(* Once these steps have been applied, the constraint language is a + list of And clauses, each a list of Or clauses, with either + explicit booleans (LBool) or integer comparisons LFun. The flatten + function coverts from a constraint_bool to this representation. *) +type 'a constraint_leaf = + | LFun of (constraint_compare_op * 'a * 'a) + | LBoolean of bool + +let rec flatten_or : 'a constraint_bool -> 'a constraint_leaf list = function + | BFun (Or, x, y) -> flatten_or x @ flatten_or y + | CFun comparison -> [LFun comparison] + | Boolean b -> [LBoolean b] + | _ -> assert false + +let rec flatten : 'a constraint_bool -> 'a constraint_leaf list list = function + | BFun (And, x, y) -> flatten x @ flatten y + | Boolean b -> [[LBoolean b]] + | c -> [flatten_or c] + +let normalize (constr : 'a constraint_bool) : 'a constraint_leaf list list = + constr + |> de_morgan + |> remove_nots + |> distrib + |> flatten + +(* Get a set of variables from a constraint *) +module IntSet = Set.Make( + struct + let compare = Pervasives.compare + type t = int + end) + +let rec int_expr_vars : nexp -> IntSet.t = function + | NConstant _ -> IntSet.empty + | NVar v -> IntSet.singleton v + | NFun (_, x, y) -> IntSet.union (int_expr_vars x) (int_expr_vars y) + | N2n x -> int_expr_vars x + +let leaf_expr_vars : nexp constraint_leaf -> IntSet .t = function + | LBoolean _ -> IntSet.empty + | LFun (_, x, y) -> IntSet.union (int_expr_vars x) (int_expr_vars y) + +let constraint_vars constr : IntSet.t = + constr + |> List.map (List.map leaf_expr_vars) + |> List.map (List.fold_left IntSet.union IntSet.empty) + |> List.fold_left IntSet.union IntSet.empty + +(* SMTLIB v2.0 format is based on S-expressions so we have a + lightweight representation of those here. *) +type sexpr = List of (sexpr list) | Atom of string + +let sfun (fn : string) (xs : sexpr list) : sexpr = List (Atom fn :: xs) + +let rec pp_sexpr : sexpr -> string = function + | List xs -> "(" ^ string_of_list " " pp_sexpr xs ^ ")" + | Atom x -> x + +let var_decs constr = + constraint_vars constr + |> IntSet.elements + |> List.map (fun var -> sfun "declare-const" [Atom ("v" ^ string_of_int var); Atom "Int"]) + |> string_of_list "\n" pp_sexpr + +let cop_sexpr op x y = + match op with + | Gt -> sfun ">" [x; y] + | Lt -> sfun "<" [x; y] + | GtEq -> sfun ">=" [x; y] + | LtEq -> sfun "<=" [x; y] + | Eq -> sfun "=" [x; y] + | NEq -> sfun "not" [sfun "=" [x; y]] + +let iop_sexpr op x y = + match op with + | Plus -> sfun "+" [x; y] + | Minus -> sfun "-" [x; y] + | Mult -> sfun "*" [x; y] + +let rec sexpr_of_nexp = function + | NFun (op, x, y) -> iop_sexpr op (sexpr_of_nexp x) (sexpr_of_nexp y) + | N2n x -> sfun "^" [Atom "2"; sexpr_of_nexp x] + | NConstant c -> Atom (string_of_big_int c) (* CHECK: do we do negative constants right? *) + | NVar var -> Atom ("v" ^ string_of_int var) + +let rec sexpr_of_cbool = function + | BFun (And, x, y) -> sfun "and" [sexpr_of_cbool x; sexpr_of_cbool y] + | BFun (Or, x, y) -> sfun "or" [sexpr_of_cbool x; sexpr_of_cbool y] + | Not x -> sfun "not" [sexpr_of_cbool x] + | CFun (op, x, y) -> cop_sexpr op (sexpr_of_nexp x) (sexpr_of_nexp y) + | Branch xs -> sfun "BRANCH" (List.map sexpr_of_cbool xs) + | Boolean true -> Atom "true" + | Boolean false -> Atom "false" + +let sexpr_of_constraint_leaf = function + | LFun (op, x, y) -> cop_sexpr op (sexpr_of_nexp x) (sexpr_of_nexp y) + | LBoolean true -> Atom "true" + | LBoolean false -> Atom "false" + +let sexpr_of_constraint constr : sexpr = + constr + |> List.map (List.map sexpr_of_constraint_leaf) + |> List.map (fun xs -> match xs with [x] -> x | _ -> (sfun "or" xs)) + |> sfun "and" + +let smtlib_of_constraint constr : string = + "(push)\n" + ^ var_decs constr ^ "\n" + ^ pp_sexpr (sfun "define-fun" [Atom "constraint"; List []; Atom "Bool"; sexpr_of_constraint constr]) + ^ "\n(assert constraint)\n(check-sat)\n(pop)" + +type t = nexp constraint_bool + +type smt_result = Unknown of t list | Unsat of t + +let rec call_z3 constraints : smt_result = + let problems = unbranch constraints in + let z3_file = + problems + |> List.map normalize + |> List.map smtlib_of_constraint + |> string_of_list "\n" (fun x -> x) + in + + (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *) + + let rec input_lines chan = function + | 0 -> [] + | n -> + begin + let l = input_line chan in + let ls = input_lines chan (n - 1) in + l :: ls + end + in + + begin + let (input_file, tmp_chan) = Filename.open_temp_file "constraint_" ".sat" in + output_string tmp_chan z3_file; + close_out tmp_chan; + let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in + let z3_output = List.combine problems (input_lines z3_chan (List.length problems)) in + let _ = Unix.close_process_in z3_chan in + Sys.remove input_file; + try + let (problem, _) = List.find (fun (_, result) -> result = "unsat") z3_output in + Unsat problem + with + | Not_found -> + z3_output + |> List.filter (fun (_, result) -> result = "unknown") + |> List.map fst + |> (fun unsolved -> Unknown unsolved) + end + +let string_of constr = + constr + |> unbranch + |> List.map normalize + |> List.map (fun c -> smtlib_of_constraint c) + |> string_of_list "\n" (fun x -> x) + +(* ===== Abstract API for building constraints ===== *) + +(* These functions are exported from constraint.mli, and ensure that + the internal representation of constraints remains opaque. *) + +let implies (x : t) (y : t) : t = + BFun (Or, Not x, y) + +let conj (x : t) (y : t) : t = + BFun (And, x, y) + +let disj (x : t) (y : t) : t = + BFun (Or, x, y) + +let negate (x : t) : t = Not x + +let branch (xs : t list) : t = Branch xs + +let literal (b : bool) : t = Boolean b + +let lt x y : t = CFun (Lt, x, y) + +let lteq x y : t = CFun (LtEq, x, y) + +let gt x y : t = CFun (Gt, x, y) + +let gteq x y : t = CFun (GtEq, x, y) + +let eq x y : t = CFun (Eq, x, y) + +let neq x y : t = CFun (NEq, x, y) + +let pow2 x : nexp = N2n x + +let add x y : nexp = NFun (Plus, x, y) + +let sub x y : nexp = NFun (Minus, x, y) + +let mult x y : nexp = NFun (Mult, x, y) + +let constant (x : big_int) : nexp = NConstant x + +let variable (v : int) : nexp = NVar v diff --git a/src/constraint.mli b/src/constraint.mli new file mode 100644 index 00000000..3fb3d2f6 --- /dev/null +++ b/src/constraint.mli @@ -0,0 +1,30 @@ +type nexp +type t + +type smt_result = Unknown of t list | Unsat of t + +val call_z3 : t -> smt_result + +val string_of : t -> string + +val implies : t -> t -> t +val conj : t -> t -> t +val disj : t -> t -> t +val negate : t -> t +val branch : t list -> t +val literal : bool -> t + +val lt : nexp -> nexp -> t +val lteq : nexp -> nexp -> t +val gt : nexp -> nexp -> t +val gteq : nexp -> nexp -> t +val eq : nexp -> nexp -> t +val neq : nexp -> nexp -> t + +val pow2 : nexp -> nexp +val add : nexp -> nexp -> nexp +val sub : nexp -> nexp -> nexp +val mult : nexp -> nexp -> nexp + +val constant : Big_int.big_int -> nexp +val variable : int -> nexp diff --git a/src/gen_lib/prompt.lem b/src/gen_lib/prompt.lem index 426b0811..70850dc1 100644 --- a/src/gen_lib/prompt.lem +++ b/src/gen_lib/prompt.lem @@ -71,12 +71,12 @@ let read_reg_range reg i j = read_reg_aux (external_reg_slice reg (natFromInteger i,natFromInteger j)) let read_reg_bit reg i = read_reg_aux (external_reg_slice reg (natFromInteger i,natFromInteger i)) >>= fun v -> - return (extract_only_bit v) + return (extract_only_element v) let read_reg_field reg regfield = read_reg_aux (external_reg_field_whole reg regfield) let read_reg_bitfield reg regfield = read_reg_aux (external_reg_field_whole reg regfield) >>= fun v -> - return (extract_only_bit v) + return (extract_only_element v) val write_reg_aux : reg_name -> vector bitU -> M unit let write_reg_aux reg_name v = diff --git a/src/gen_lib/sail_values.lem b/src/gen_lib/sail_values.lem index 38f7d512..5dbdb157 100644 --- a/src/gen_lib/sail_values.lem +++ b/src/gen_lib/sail_values.lem @@ -1,4 +1,7 @@ +(* Version of sail_values.lem that uses Lem's machine words library *) + open import Pervasives_extra +open import Machine_word open import Sail_impl_base @@ -197,58 +200,141 @@ val update_pos : forall 'a. vector 'a -> integer -> 'a -> vector 'a let update_pos v n b = update_aux v n n [b] +(*** Bitvectors *) + +(* element list * start * has increasing direction *) +type bitvector 'a = Bitvector of mword 'a * integer * bool +declare isabelle target_sorts bitvector = `len` + +let showBitvector (Bitvector elems start inc) = + "Bitvector " ^ show elems ^ " " ^ show start ^ " " ^ show inc + +let bvget_dir (Bitvector _ _ ord) = ord +let bvget_start (Bitvector _ s _) = s +let bvget_elems (Bitvector elems _ _) = elems +let bvlength (Bitvector bs _ _) = integerFromNat (word_length bs) + +instance forall 'a. (Show (bitvector 'a)) + let show = showBitvector +end + +let bvec_to_vec (Bitvector bs start is_inc) = + let bits = List.map bool_to_bitU (bitlistFromWord bs) in + Vector bits start is_inc + +let vec_to_bvec (Vector elems start is_inc) = + let word = wordFromBitlist (List.map bitU_to_bool elems) in + Bitvector word start is_inc + +(*** Vector operations *) + +val set_bitvector_start : forall 'a. integer -> bitvector 'a -> bitvector 'a +let set_bitvector_start new_start (Bitvector bs _ is_inc) = + Bitvector bs new_start is_inc + +let reset_bitvector_start v = + set_bitvector_start (if (bvget_dir v) then 0 else (bvlength v - 1)) v + +let set_bitvector_start_to_length v = + set_bitvector_start (bvlength v - 1) v + +let bitvector_concat (Bitvector bs start is_inc) (Bitvector bs' _ _) = + Bitvector (word_concat bs bs') start is_inc + +let inline (^^^) = bitvector_concat + +val bvslice : forall 'a 'b. bitvector 'a -> integer -> integer -> bitvector 'b +let bvslice (Bitvector bs start is_inc) i j = + let iN = natFromInteger i in + let jN = natFromInteger j in + let startN = natFromInteger start in + let (lo,hi) = if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN) in + let subvector_bits = word_extract lo hi bs in + Bitvector subvector_bits i is_inc + +(* this is for the vector slicing introduced in vector-concat patterns: i and j +index into the "raw data", the list of bits. Therefore getting the bit list is +easy, but the start index has to be transformed to match the old vector start +and the direction. *) +val bvslice_raw : forall 'a 'b. Size 'b => bitvector 'a -> integer -> integer -> bitvector 'b +let bvslice_raw (Bitvector bs start is_inc) i j = + let iN = natFromInteger i in + let jN = natFromInteger j in + let bits = word_extract iN jN bs in + let len = integerFromNat (word_length bits) in + Bitvector bits (if is_inc then 0 else len - 1) is_inc + +val bvupdate_aux : forall 'a 'b. bitvector 'a -> integer -> integer -> mword 'b -> bitvector 'a +let bvupdate_aux (Bitvector bs start is_inc) i j bs' = + let iN = natFromInteger i in + let jN = natFromInteger j in + let startN = natFromInteger start in + let (lo,hi) = if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN) in + let bits = word_update bs lo hi bs' in + Bitvector bits start is_inc + +val bvupdate : forall 'a 'b. bitvector 'a -> integer -> integer -> bitvector 'b -> bitvector 'a +let bvupdate v i j (Bitvector bs' _ _) = + bvupdate_aux v i j bs' + +(* TODO: decide between nat/natural, change either here or in machine_word *) +val getBit' : forall 'a. mword 'a -> nat -> bool +let getBit' w n = getBit w (naturalFromNat n) + +val bvaccess : forall 'a. bitvector 'a -> integer -> bitU +let bvaccess (Bitvector bs start is_inc) n = bool_to_bitU ( + if is_inc then getBit' bs (natFromInteger (n - start)) + else getBit' bs (natFromInteger (start - n))) + +val bvupdate_pos : forall 'a. Size 'a => bitvector 'a -> integer -> bitU -> bitvector 'a +let bvupdate_pos v n b = + bvupdate_aux v n n ((wordFromNatural (if bitU_to_bool b then 1 else 0)) : mword ty1) (*** Bit vector operations *) -let extract_only_bit (Vector elems _ _) = match elems with - | [] -> failwith "extract_single_bit called for empty vector" +let extract_only_element (Vector elems _ _) = match elems with + | [] -> failwith "extract_only_element called for empty vector" | [e] -> e - | _ -> failwith "extract_single_bit called for vector with more bits" + | _ -> failwith "extract_only_element called for vector with more elements" end +val extract_only_bit : bitvector ty1 -> bitU +let extract_only_bit (Bitvector elems _ _) = + (*let l = word_length elems in + if l = 1 then*) + bool_to_bitU (msb elems) + (*else if l = 0 then + failwith "extract_single_bit called for empty vector" + else + failwith "extract_single_bit called for vector with more bits"*) + let pp_bitu_vector (Vector elems start inc) = let elems_pp = List.foldl (fun acc elem -> acc ^ showBitU elem) "" elems in "Vector [" ^ elems_pp ^ "] " ^ show start ^ " " ^ show inc -let most_significant = function - | (Vector (b :: _) _ _) -> b - | _ -> failwith "most_significant applied to empty vector" - end +let most_significant (Bitvector v _ _) = + if word_length v = 0 then + failwith "most_significant applied to empty vector" + else + bool_to_bitU (msb v) let bitwise_not_bitlist = List.map bitwise_not_bit -let bitwise_not (Vector bs start is_inc) = - Vector (bitwise_not_bitlist bs) start is_inc - -let bitwise_binop op (Vector bsl start is_inc, Vector bsr _ _) = - let revbs = foldl (fun acc pair -> bitwise_binop_bit op pair :: acc) [] (zip bsl bsr) in - Vector (reverse revbs) start is_inc - -let bitwise_and = bitwise_binop (&&) -let bitwise_or = bitwise_binop (||) -let bitwise_xor = bitwise_binop xor - -let unsigned (Vector bs _ _) : integer = - let (sum,_) = - List.foldr - (fun b (acc,exp) -> - match b with - | B1 -> (acc + integerPow 2 exp,exp + 1) - | B0 -> (acc, exp + 1) - | BU -> failwith "unsigned: vector has undefined bits" - end) - (0,0) bs in - sum +let bitwise_not (Bitvector bs start is_inc) = + Bitvector (lNot bs) start is_inc + +let bitwise_binop op (Bitvector bsl start is_inc, Bitvector bsr _ _) = + Bitvector (op bsl bsr) start is_inc + +let bitwise_and = bitwise_binop lAnd +let bitwise_or = bitwise_binop lOr +let bitwise_xor = bitwise_binop lXor +let unsigned (Bitvector bs _ _) : integer = unsignedIntegerFromWord bs let unsigned_big = unsigned -let signed v : integer = - match most_significant v with - | B1 -> 0 - (1 + (unsigned (bitwise_not v))) - | B0 -> unsigned v - | BU -> failwith "signed applied to vector with undefined bits" - end +let signed (Bitvector v _ _) : integer = signedIntegerFromWord v let hardware_mod (a: integer) (b:integer) : integer = if a < 0 && b < 0 @@ -323,36 +409,31 @@ end let add_one_bit_ignore_overflow bits = List.reverse (add_one_bit_ignore_overflow_aux (List.reverse bits)) - let to_vec is_inc ((len : integer),(n : integer)) = let start = if is_inc then 0 else len - 1 in - let bits = to_bin (naturalFromInteger (abs n)) in - let len_bits = integerFromNat (List.length bits) in - let longer = len - len_bits in - let bits' = - if longer < 0 then drop (natFromInteger (abs (longer))) bits - else pad_zero bits longer in - if n > (0 : integer) - then Vector bits' start is_inc - else Vector (add_one_bit_ignore_overflow (bitwise_not_bitlist bits')) - start is_inc + let bits = wordFromInteger n in + if integerFromNat (word_length bits) = len then + Bitvector bits start is_inc + else + failwith "Vector length mismatch in to_vec" let to_vec_big = to_vec let to_vec_inc = to_vec true let to_vec_dec = to_vec false +(* TODO: Think about undefined bit(vector)s *) let to_vec_undef is_inc (len : integer) = - Vector (replicate (natFromInteger len) BU) (if is_inc then 0 else len-1) is_inc + Bitvector (failwith "undefined bitvector") (if is_inc then 0 else len-1) is_inc let to_vec_inc_undef = to_vec_undef true let to_vec_dec_undef = to_vec_undef false -let exts (len, vec) = to_vec (get_dir vec) (len,signed vec) -let extz (len, vec) = to_vec (get_dir vec) (len,unsigned vec) +let exts (len, vec) = to_vec (bvget_dir vec) (len,signed vec) +let extz (len, vec) = to_vec (bvget_dir vec) (len,unsigned vec) -let exts_big (len, vec) = to_vec_big (get_dir vec) (len, signed_big vec) -let extz_big (len, vec) = to_vec_big (get_dir vec) (len, unsigned_big vec) +let exts_big (len, vec) = to_vec_big (bvget_dir vec) (len, signed_big vec) +let extz_big (len, vec) = to_vec_big (bvget_dir vec) (len, unsigned_big vec) let add = integerAdd let add_signed = integerAdd @@ -362,10 +443,13 @@ let modulo = hardware_mod let quot = hardware_quot let power = integerPow -let arith_op_vec op sign (size : integer) (Vector _ _ is_inc as l) r = +(* TODO: this, and the definitions that use it, currently require Size for + to_vec, which I'd rather avoid in favour of library versions; the + double-size results for multiplication may be a problem *) +let arith_op_vec op sign (size : integer) (Bitvector _ _ is_inc as l) r = let (l',r') = (to_num sign l, to_num sign r) in let n = op l' r' in - to_vec is_inc (size * (length l),n) + to_vec is_inc (size * (bvlength l),n) (* add_vec @@ -380,8 +464,9 @@ let minus_VVV = arith_op_vec integerMinus false 1 let mult_VVV = arith_op_vec integerMult false 2 let multS_VVV = arith_op_vec integerMult true 2 -let arith_op_vec_range op sign size (Vector _ _ is_inc as l) r = - arith_op_vec op sign size l (to_vec is_inc (length l,r)) +val arith_op_vec_range : forall 'a 'b. Size 'a, Size 'b => (integer -> integer -> integer) -> bool -> integer -> bitvector 'a -> integer -> bitvector 'b +let arith_op_vec_range op sign size (Bitvector _ _ is_inc as l) r = + arith_op_vec op sign size l ((to_vec is_inc (bvlength l,r)) : bitvector 'a) (* add_vec_range * add_vec_range_signed @@ -395,8 +480,9 @@ let minus_VIV = arith_op_vec_range integerMinus false 1 let mult_VIV = arith_op_vec_range integerMult false 2 let multS_VIV = arith_op_vec_range integerMult true 2 -let arith_op_range_vec op sign size l (Vector _ _ is_inc as r) = - arith_op_vec op sign size (to_vec is_inc (length r, l)) r +val arith_op_range_vec : forall 'a 'b. Size 'a, Size 'b => (integer -> integer -> integer) -> bool -> integer -> integer -> bitvector 'a -> bitvector 'b +let arith_op_range_vec op sign size l (Bitvector _ _ is_inc as r) = + arith_op_vec op sign size ((to_vec is_inc (bvlength r, l)) : bitvector 'a) r (* add_range_vec * add_range_vec_signed @@ -442,10 +528,10 @@ let arith_op_vec_vec_range op sign l r = let add_VVI = arith_op_vec_vec_range integerAdd false let addS_VVI = arith_op_vec_vec_range integerAdd true -let arith_op_vec_bit op sign (size : integer) (Vector _ _ is_inc as l)r = +let arith_op_vec_bit op sign (size : integer) (Bitvector _ _ is_inc as l)r = let l' = to_num sign l in let n = op l' (match r with | B1 -> (1 : integer) | _ -> 0 end) in - to_vec is_inc (length l * size,n) + to_vec is_inc (bvlength l * size,n) (* add_vec_bit * add_vec_bit_signed @@ -455,8 +541,10 @@ let add_VBV = arith_op_vec_bit integerAdd false 1 let addS_VBV = arith_op_vec_bit integerAdd true 1 let minus_VBV = arith_op_vec_bit integerMinus true 1 -let rec arith_op_overflow_vec (op : integer -> integer -> integer) sign size (Vector _ _ is_inc as l) r = - let len = length l in +(* TODO: these can't be done directly in Lem because of the one_more size calculation +val arith_op_overflow_vec : forall 'a 'b. Size 'a, Size 'b => (integer -> integer -> integer) -> bool -> integer -> bitvector 'a -> bitvector 'a -> bitvector 'b * bitU * bool +let rec arith_op_overflow_vec op sign size (Bitvector _ _ is_inc as l) r = + let len = bvlength l in let act_size = len * size in let (l_sign,r_sign) = (to_num sign l,to_num sign r) in let (l_unsign,r_unsign) = (to_num false l,to_num false r) in @@ -485,9 +573,11 @@ let minusSO_VVV = arith_op_overflow_vec integerMinus true 1 let multO_VVV = arith_op_overflow_vec integerMult false 2 let multSO_VVV = arith_op_overflow_vec integerMult true 2 +val arith_op_overflow_vec_bit : forall 'a 'b. Size 'a, Size 'b => (integer -> integer -> integer) -> bool -> integer -> + bitvector 'a -> bitU -> bitvector 'b * bitU * bool let rec arith_op_overflow_vec_bit (op : integer -> integer -> integer) sign (size : integer) - (Vector _ _ is_inc as l) r_bit = - let act_size = length l * size in + (Bitvector _ _ is_inc as l) r_bit = + let act_size = bvlength l * size in let l' = to_num sign l in let l_u = to_num false l in let (n,nu,changed) = match r_bit with @@ -513,18 +603,18 @@ let rec arith_op_overflow_vec_bit (op : integer -> integer -> integer) sign (siz let addSO_VBV = arith_op_overflow_vec_bit integerAdd true 1 let minusO_VBV = arith_op_overflow_vec_bit integerMinus false 1 let minusSO_VBV = arith_op_overflow_vec_bit integerMinus true 1 - +*) type shift = LL_shift | RR_shift | LLL_shift -let shift_op_vec op (Vector bs start is_inc,(n : integer)) = +let shift_op_vec op (Bitvector bs start is_inc,(n : integer)) = let n = natFromInteger n in match op with | LL_shift (*"<<"*) -> - Vector (sublist bs (n,List.length bs -1) ++ List.replicate n B0) start is_inc + Bitvector (shiftLeft bs (naturalFromNat n)) start is_inc | RR_shift (*">>"*) -> - Vector (List.replicate n B0 ++ sublist bs (0,n-1)) start is_inc + Bitvector (shiftRight bs (naturalFromNat n)) start is_inc | LLL_shift (*"<<<"*) -> - Vector (sublist bs (n,List.length bs - 1) ++ sublist bs (0,n-1)) start is_inc + Bitvector (rotateLeft (naturalFromNat n) bs) start is_inc end let bitwise_leftshift = shift_op_vec LL_shift (*"<<"*) @@ -535,9 +625,9 @@ let rec arith_op_no0 (op : integer -> integer -> integer) l r = if r = 0 then Nothing else Just (op l r) - -let rec arith_op_vec_no0 (op : integer -> integer -> integer) sign size ((Vector _ start is_inc) as l) r = - let act_size = length l * size in +(* TODO +let rec arith_op_vec_no0 (op : integer -> integer -> integer) sign size ((Bitvector _ start is_inc) as l) r = + let act_size = bvlength l * size in let (l',r') = (to_num sign l,to_num sign r) in let n = arith_op_no0 op l' r' in let (representable,n') = @@ -585,7 +675,7 @@ let arith_op_vec_range_no0 op sign size (Vector _ _ is_inc as l) r = arith_op_vec_no0 op sign size l (to_vec is_inc (length l,r)) let mod_VIV = arith_op_vec_range_no0 hardware_mod false 1 - +*) val repeat : forall 'a. list 'a -> integer -> list 'a let rec repeat xs n = if n = 0 then [] @@ -667,9 +757,9 @@ let make_bitvector_undef length = (* let bitwise_not_range_bit n = bitwise_not (to_vec defaultDir n) *) -let mask (n,Vector bits start dir) = - let current_size = List.length bits in - Vector (drop (current_size - (natFromInteger n)) bits) (if dir then 0 else (n-1)) dir +let mask (n,bv) = + let len = bvlength bv in + bvslice_raw bv (len - n) (len - 1) val byte_chunks : forall 'a. nat -> list 'a -> list (list 'a) @@ -956,4 +1046,3 @@ let diafp_to_dia reginfo = function | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v) | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r) end - diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 430ee562..709052fe 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -47,12 +47,12 @@ let set_reg state reg bitv = <| state with regstate = Map.insert reg bitv state.regstate |> -val read_mem : bool -> read_kind -> vector bitU -> integer -> M (vector bitU) +val read_mem : forall 'a 'b. Size 'b => bool -> read_kind -> bitvector 'a -> integer -> M (bitvector 'b) let read_mem dir read_kind addr sz state = - let addr = integer_of_address (address_of_bitv addr) in + let addr = unsigned addr in let addrs = range addr (addr+sz-1) in let memory_value = List.map (fun addr -> Map_extra.find addr state.memstate) addrs in - let value = Sail_values.internal_mem_value dir memory_value in + let value = vec_to_bvec (Sail_values.internal_mem_value dir memory_value) in let is_exclusive = match read_kind with | Sail_impl_base.Read_plain -> false | Sail_impl_base.Read_reserve -> true @@ -69,9 +69,9 @@ let read_mem dir read_kind addr sz state = (* caps are aligned at 32 bytes *) let cap_alignment = (32 : integer) -val read_tag : bool -> read_kind -> vector bitU -> M bitU +val read_tag : forall 'a. bool -> read_kind -> bitvector 'a -> M bitU let read_tag dir read_kind addr state = - let addr = (integer_of_address (address_of_bitv addr)) / cap_alignment in + let addr = (unsigned addr) / cap_alignment in let tag = match (Map.lookup addr state.tagstate) with | Just t -> t | Nothing -> B0 @@ -96,18 +96,18 @@ let excl_result () state = (Left true, <| state with last_exclusive_operation_was_load = false |>) in (Left false, state) :: if state.last_exclusive_operation_was_load then [success] else [] -val write_mem_ea : write_kind -> vector bitU -> integer -> M unit +val write_mem_ea : forall 'a. write_kind -> bitvector 'a -> integer -> M unit let write_mem_ea write_kind addr sz state = - let addr = integer_of_address (address_of_bitv addr) in + let addr = unsigned addr in [(Left (), <| state with write_ea = Just (write_kind,addr,sz) |>)] -val write_mem_val : vector bitU -> M bool +val write_mem_val : forall 'b. bitvector 'b -> M bool let write_mem_val v state = let (write_kind,addr,sz) = match state.write_ea with | Nothing -> failwith "write ea has not been announced yet" | Just write_ea -> write_ea end in let addrs = range addr (addr+sz-1) in - let v = external_mem_value v in + let v = external_mem_value (bvec_to_vec v) in let addresses_with_value = List.zip addrs v in let memstate = List.foldl (fun mem (addr,v) -> Map.insert addr v mem) state.memstate addresses_with_value in @@ -122,16 +122,16 @@ let write_tag t state = let tagstate = Map.insert taddr t state.tagstate in [(Left true, <| state with tagstate = tagstate |>)] -val read_reg : register -> M (vector bitU) +val read_reg : forall 'a. Size 'a => register -> M (bitvector 'a) let read_reg reg state = - let v = Map_extra.find (name_of_reg reg) state.regstate in + let v = get_reg state (name_of_reg reg) in + [(Left (vec_to_bvec v),state)] +let read_reg_range reg i j state = + let v = slice (get_reg state (name_of_reg reg)) i j in + [(Left (vec_to_bvec v),state)] +let read_reg_bit reg i state = + let v = access (get_reg state (name_of_reg reg)) i in [(Left v,state)] -let read_reg_range reg i j = - read_reg reg >>= fun rv -> - return (slice rv i j) -let read_reg_bit reg i = - read_reg_range reg i i >>= fun v -> - return (extract_only_bit v) let read_reg_field reg regfield = let (i,j) = register_field_indices reg regfield in read_reg_range reg i j @@ -139,25 +139,30 @@ let read_reg_bitfield reg regfield = let (i,_) = register_field_indices reg regfield in read_reg_bit reg i -val write_reg : register -> vector bitU -> M unit +val write_reg : forall 'a. Size 'a => register -> bitvector 'a -> M unit let write_reg reg v state = - [(Left (),<| state with regstate = Map.insert (name_of_reg reg) v state.regstate |>)] -let write_reg_range reg i j v = - read_reg reg >>= fun current_value -> - let new_value = update current_value i j v in - write_reg reg new_value -let write_reg_bit reg i bit = - write_reg_range reg i i (Vector [bit] i (is_inc_of_reg reg)) + [(Left (), set_reg state (name_of_reg reg) (bvec_to_vec v))] +let write_reg_range reg i j v state = + let current_value = get_reg state (name_of_reg reg) in + let new_value = update current_value i j (bvec_to_vec v) in + [(Left (), set_reg state (name_of_reg reg) new_value)] +let write_reg_bit reg i bit state = + let current_value = get_reg state (name_of_reg reg) in + let new_value = update_pos current_value i bit in + [(Left (), set_reg state (name_of_reg reg) new_value)] let write_reg_field reg regfield = - let (i,j) = register_field_indices reg regfield in + let (i,j) = register_field_indices reg regfield in write_reg_range reg i j let write_reg_bitfield reg regfield = let (i,_) = register_field_indices reg regfield in write_reg_bit reg i -let write_reg_field_range reg regfield i j v = - read_reg_field reg regfield >>= fun current_field_value -> - let new_field_value = update current_field_value i j v in - write_reg_field reg regfield new_field_value +let write_reg_field_range reg regfield i j v state = + let (i0,j0) = register_field_indices reg regfield in + let current_value = get_reg state (name_of_reg reg) in + let current_field_value = slice current_value i0 j0 in + let new_field_value = update current_field_value i j (bvec_to_vec v) in + let new_value = update current_value i j new_field_value in + [(Left (), set_reg state (name_of_reg reg) new_value)] val barrier : barrier_kind -> M unit @@ -186,7 +191,8 @@ let rec foreachM_dec (i,stop,by) vars body = foreachM_dec (i - by,stop,by) vars body else return vars -let write_two_regs r1 r2 vec = +let write_two_regs r1 r2 bvec state = + let vec = bvec_to_vec bvec in let is_inc = let is_inc_r1 = is_inc_of_reg r1 in let is_inc_r2 = is_inc_of_reg r2 in @@ -205,4 +211,6 @@ let write_two_regs r1 r2 vec = if is_inc then slice vec (size_r1 - start_vec) (size_vec - start_vec) else slice vec (start_vec - size_r1) (start_vec - size_vec) in - write_reg r1 r1_v >> write_reg r2 r2_v + let state1 = set_reg state (name_of_reg r1) r1_v in + let state2 = set_reg state1 (name_of_reg r2) r2_v in + [(Left (), state2)] diff --git a/src/initial_check.ml b/src/initial_check.ml index 0e37b418..cfdf9807 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -40,11 +40,37 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal open Ast +open Util -type kind = Type_internal.kind -type typ = Type_internal.t +module Envmap = Finite_map.Fmap_map(String) +module Nameset' = Set.Make(String) +module Nameset = struct + include Nameset' + let pp ppf nameset = + Format.fprintf ppf "{@[%a@]}" + (Pp.lst ",@ " Pp.pp_str) + (Nameset'.elements nameset) +end + +type kind = { mutable k : k_aux } +and k_aux = + | K_Typ + | K_Nat + | K_Ord + | K_Efct + | K_Val + | K_Lam of kind list * kind + | K_infer + +let rec kind_to_string kind = match kind.k with + | K_Nat -> "Nat" + | K_Typ -> "Type" + | K_Ord -> "Order" + | K_Efct -> "Effect" + | K_infer -> "Infer" + | K_Val -> "Val" + | K_Lam (kinds,kind) -> "Lam [" ^ string_of_list ", " kind_to_string kinds ^ "] -> " ^ (kind_to_string kind) (*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *) type envs = Nameset.t * kind Envmap.t * order @@ -303,14 +329,18 @@ and to_ast_typ_arg (k_env : kind Envmap.t) (def_ord : order) (kind : kind) (arg | _ -> raise (Reporting_basic.err_unreachable l "To_ast_typ_arg received Lam kind or infer kind")), l) -let to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) : n_constraint = - match c with +let rec to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) : n_constraint = + match c with | Parse_ast.NC_aux(nc,l) -> NC_aux( (match nc with | Parse_ast.NC_fixed(t1,t2) -> let n1 = to_ast_nexp k_env t1 in let n2 = to_ast_nexp k_env t2 in NC_fixed(n1,n2) + | Parse_ast.NC_not_equal(t1,t2) -> + let n1 = to_ast_nexp k_env t1 in + let n2 = to_ast_nexp k_env t2 in + NC_not_equal(n1,n2) | Parse_ast.NC_bounded_ge(t1,t2) -> let n1 = to_ast_nexp k_env t1 in let n2 = to_ast_nexp k_env t2 in @@ -320,8 +350,12 @@ let to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) let n2 = to_ast_nexp k_env t2 in NC_bounded_le(n1,n2) | Parse_ast.NC_nat_set_bounded(id,bounds) -> - NC_nat_set_bounded(to_ast_var id, bounds) - ), l) + NC_nat_set_bounded(to_ast_var id, bounds) + | Parse_ast.NC_or (nc1, nc2) -> + NC_or (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) + | Parse_ast.NC_and (nc1, nc2) -> + NC_and (to_ast_nexp_constraint k_env nc1, to_ast_nexp_constraint k_env nc2) + ), l) (* Transforms a typquant while building first the kind environment of declared variables, and also the kind environment in context *) let to_ast_typquant (k_env: kind Envmap.t) (tq : Parse_ast.typquant) : typquant * kind Envmap.t * kind Envmap.t = @@ -392,10 +426,11 @@ let to_ast_lit (Parse_ast.L_aux(lit,l)) : lit = | Parse_ast.L_num(i) -> L_num(i) | Parse_ast.L_hex(h) -> L_hex(h) | Parse_ast.L_bin(b) -> L_bin(b) + | Parse_ast.L_real r -> L_real r | Parse_ast.L_string(s) -> L_string(s)) ,l) -let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pat,l) : Parse_ast.pat) : tannot pat = +let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pat,l) : Parse_ast.pat) : unit pat = P_aux( (match pat with | Parse_ast.P_lit(lit) -> P_lit(to_ast_lit lit) @@ -410,17 +445,18 @@ let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pa | Parse_ast.P_record(fpats,_) -> P_record(List.map (fun (Parse_ast.FP_aux(Parse_ast.FP_Fpat(id,fp),l)) -> - FP_aux(FP_Fpat(to_ast_id id, to_ast_pat k_env def_ord fp),(l,NoTyp))) + FP_aux(FP_Fpat(to_ast_id id, to_ast_pat k_env def_ord fp),(l,()))) fpats, false) | Parse_ast.P_vector(pats) -> P_vector(List.map (to_ast_pat k_env def_ord) pats) | Parse_ast.P_vector_indexed(ipats) -> P_vector_indexed(List.map (fun (i,pat) -> i,to_ast_pat k_env def_ord pat) ipats) | Parse_ast.P_vector_concat(pats) -> P_vector_concat(List.map (to_ast_pat k_env def_ord) pats) | Parse_ast.P_tup(pats) -> P_tup(List.map (to_ast_pat k_env def_ord) pats) | Parse_ast.P_list(pats) -> P_list(List.map (to_ast_pat k_env def_ord) pats) - ), (l,NoTyp)) + | Parse_ast.P_cons(pat1, pat2) -> P_cons (to_ast_pat k_env def_ord pat1, to_ast_pat k_env def_ord pat2) + ), (l,())) -let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_aux(lb,l) : Parse_ast.letbind) : tannot letbind = +let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_aux(lb,l) : Parse_ast.letbind) : unit letbind = LB_aux( (match lb with | Parse_ast.LB_val_explicit(typschm,pat,exp) -> @@ -428,9 +464,9 @@ let rec to_ast_letbind (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.LB_a LB_val_explicit(typsch,to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp) | Parse_ast.LB_val_implicit(pat,exp) -> LB_val_implicit(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp) - ), (l,NoTyp)) + ), (l,())) -and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : tannot exp = +and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit exp = E_aux( (match exp with | Parse_ast.E_block(exps) -> @@ -457,14 +493,14 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) (match to_ast_iexps false k_env def_ord exps with | Some([]) -> E_vector([]) | Some(iexps) -> E_vector_indexed(iexps, - Def_val_aux(Def_val_empty,(l,NoTyp))) + Def_val_aux(Def_val_empty,(l,()))) | None -> E_vector(List.map (to_ast_exp k_env def_ord) exps)) | Parse_ast.E_vector_indexed(iexps,Parse_ast.Def_val_aux(default,dl)) -> (match to_ast_iexps true k_env def_ord iexps with | Some(iexps) -> E_vector_indexed (iexps, Def_val_aux((match default with | Parse_ast.Def_val_empty -> Def_val_empty - | Parse_ast.Def_val_dec e -> Def_val_dec (to_ast_exp k_env def_ord e)),(dl,NoTyp))) + | Parse_ast.Def_val_dec e -> Def_val_dec (to_ast_exp k_env def_ord e)),(dl,()))) | _ -> raise (Reporting_basic.err_unreachable l "to_ast_iexps didn't throw error")) | Parse_ast.E_vector_access(vexp,exp) -> E_vector_access(to_ast_exp k_env def_ord vexp, to_ast_exp k_env def_ord exp) | Parse_ast.E_vector_subrange(vex,exp1,exp2) -> @@ -487,12 +523,13 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_let(leb,exp) -> E_let(to_ast_letbind k_env def_ord leb, to_ast_exp k_env def_ord exp) | Parse_ast.E_assign(lexp,exp) -> E_assign(to_ast_lexp k_env def_ord lexp, to_ast_exp k_env def_ord exp) | Parse_ast.E_sizeof(nexp) -> E_sizeof(to_ast_nexp k_env nexp) + | Parse_ast.E_constraint nc -> E_constraint (to_ast_nexp_constraint k_env nc) | Parse_ast.E_exit exp -> E_exit(to_ast_exp k_env def_ord exp) | Parse_ast.E_return exp -> E_return(to_ast_exp k_env def_ord exp) | Parse_ast.E_assert(cond,msg) -> E_assert(to_ast_exp k_env def_ord cond, to_ast_exp k_env def_ord msg) - ), (l,NoTyp)) + ), (l,())) -and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : tannot lexp = +and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : unit lexp = LEXP_aux( (match exp with | Parse_ast.E_id(id) -> LEXP_id(to_ast_id id) @@ -520,15 +557,17 @@ and to_ast_lexp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l LEXP_vector_range(to_ast_lexp k_env def_ord vexp, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) | Parse_ast.E_field(fexp,id) -> LEXP_field(to_ast_lexp k_env def_ord fexp, to_ast_id id) | _ -> typ_error l "Only identifiers, cast identifiers, vector accesses, vector slices, and fields can be on the lefthand side of an assignment" None None None) - , (l,NoTyp)) + , (l,())) -and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex,l) : Parse_ast.pexp) : tannot pexp = +and to_ast_case (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.Pat_aux(pex,l) : Parse_ast.pexp) : unit pexp = match pex with - | Parse_ast.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,NoTyp)) + | Parse_ast.Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,())) + | Parse_ast.Pat_when(pat,guard,exp) -> + Pat_aux (Pat_when (to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord guard, to_ast_exp k_env def_ord exp), (l, ())) -and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : tannot fexps option = +and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps : Parse_ast.exp list) : unit fexps option = match exps with - | [] -> Some(FES_aux(FES_Fexps([],false), (Parse_ast.Unknown,NoTyp))) + | [] -> Some(FES_aux(FES_Fexps([],false), (Parse_ast.Unknown,()))) | fexp::exps -> let maybe_fexp,maybe_error = to_ast_record_try k_env def_ord fexp in (match maybe_fexp,maybe_error with | Some(fexp),None -> @@ -541,12 +580,12 @@ and to_ast_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exp else None | _ -> None) -and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l):Parse_ast.exp): tannot fexp option * (l * string) option = +and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l):Parse_ast.exp): unit fexp option * (l * string) option = match exp with | Parse_ast.E_app_infix(left,op,r) -> (match left, op with | Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(Parse_ast.Id("="),leq) -> - Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp k_env def_ord r), (l,NoTyp))),None + Some(FE_aux(FE_Fexp(to_ast_id id, to_ast_exp k_env def_ord r), (l,()))),None | Parse_ast.E_aux(_,li) , Parse_ast.Id_aux(Parse_ast.Id("="),leq) -> None,Some(li,"Expected an identifier to begin this field assignment") | Parse_ast.E_aux(Parse_ast.E_id(id),li), Parse_ast.Id_aux(_,leq) -> @@ -556,7 +595,7 @@ and to_ast_record_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp | _ -> None,Some(l, "Expected a field assignment to be identifier = expression") -and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps:Parse_ast.exp list):(int * tannot exp) list option = +and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exps:Parse_ast.exp list):(int * unit exp) list option = match exps with | [] -> Some([]) | iexp::exps -> (match to_iexp_try k_env def_ord iexp with @@ -569,7 +608,7 @@ and to_ast_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:order) (exp then typ_error l msg None None None else None | _ -> None) -and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): Parse_ast.exp): ((int * tannot exp) option * (l*string) option) = +and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): Parse_ast.exp): ((int * unit exp) option * (l*string) option) = match exp with | Parse_ast.E_app_infix(left,op,r) -> (match left,op with @@ -581,7 +620,7 @@ and to_iexp_try (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.E_aux(exp,l): P None,(Some(leq,"Expected an indexed vector assignment constant = expression"))) | _ -> None,(Some(l,"Expected an indexed vector assignment: constant = expression")) -let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : (tannot default_spec) envs_out = +let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_typing_spec) : (unit default_spec) envs_out = match default with | Parse_ast.DT_aux(df,l) -> (match df with @@ -604,20 +643,23 @@ let to_ast_default (names, k_env, default_order) (default : Parse_ast.default_ty DT_aux(DT_order default_order,l),(names,k_env,default_order) | _ -> typ_error l "Inc and Dec must have kind Order" None None None)) -let to_ast_spec (names,k_env,default_order) (val_:Parse_ast.val_spec) : (tannot val_spec) envs_out = +let to_ast_spec (names,k_env,default_order) (val_:Parse_ast.val_spec) : (unit val_spec) envs_out = match val_ with | Parse_ast.VS_aux(vs,l) -> (match vs with | Parse_ast.VS_val_spec(ts,id) -> (*let _ = Printf.eprintf "to_ast_spec called for internal spec: for %s\n" (id_to_string (to_ast_id id)) in*) let typsch,_,_ = to_ast_typschm k_env default_order ts in - VS_aux(VS_val_spec(typsch,to_ast_id id),(l,NoTyp)),(names,k_env,default_order) + VS_aux(VS_val_spec(typsch,to_ast_id id),(l,())),(names,k_env,default_order) | Parse_ast.VS_extern_spec(ts,id,s) -> let typsch,_,_ = to_ast_typschm k_env default_order ts in - VS_aux(VS_extern_spec(typsch,to_ast_id id,s),(l,NoTyp)),(names,k_env,default_order) + VS_aux(VS_extern_spec(typsch,to_ast_id id,s),(l,())),(names,k_env,default_order) + | Parse_ast.VS_cast_spec(ts,id) -> + let typsch,_,_ = to_ast_typschm k_env default_order ts in + VS_aux(VS_cast_spec(typsch,to_ast_id id),(l,())),(names,k_env,default_order) | Parse_ast.VS_extern_no_rename(ts,id) -> let typsch,_,_ = to_ast_typschm k_env default_order ts in - VS_aux(VS_extern_no_rename(typsch,to_ast_id id),(l,NoTyp)),(names,k_env,default_order)) + VS_aux(VS_extern_no_rename(typsch,to_ast_id id),(l,())),(names,k_env,default_order)) let to_ast_namescm (Parse_ast.Name_sect_aux(ns,l)) = @@ -645,7 +687,7 @@ let to_ast_type_union k_env default_order (Parse_ast.Tu_aux(tu,l)) = | _ -> Tu_aux(Tu_ty_id(typ, to_ast_id id), l)) | Parse_ast.Tu_id id -> (Tu_aux(Tu_id(to_ast_id id),l)) -let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_def) envs_out = +let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (unit type_def) envs_out = match td with | Parse_ast.TD_aux(td,l) -> (match td with @@ -653,7 +695,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_ let id = to_ast_id id in let key = id_to_string id in let typschm,k_env,_ = to_ast_typschm k_env def_ord typschm in - let td_abrv = TD_aux(TD_abbrev(id,to_ast_namescm name_scm_opt,typschm),(l,NoTyp)) in + let td_abrv = TD_aux(TD_abbrev(id,to_ast_namescm name_scm_opt,typschm),(l,())) in let typ = (match typschm with | TypSchm_aux(TypSchm_ts(tq,typ), _) -> begin match (typquant_to_quantkinds k_env tq) with @@ -666,7 +708,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_ let key = id_to_string id in let typq,k_env,_ = to_ast_typquant k_env typq in let fields = List.map (fun (atyp,id) -> (to_ast_typ k_env def_ord atyp),(to_ast_id id)) fields in (* Add check that all arms have unique names locally *) - let td_rec = TD_aux(TD_record(id,to_ast_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in + let td_rec = TD_aux(TD_record(id,to_ast_namescm name_scm_opt,typq,fields,false),(l,())) in let typ = (match (typquant_to_quantkinds k_env typq) with | [ ] -> {k = K_Typ} | typs -> {k = K_Lam(typs,{k=K_Typ})}) in @@ -676,7 +718,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_ let key = id_to_string id in let typq,k_env,_ = to_ast_typquant k_env typq in let arms = List.map (to_ast_type_union k_env def_ord) arms in (* Add check that all arms have unique names *) - let td_var = TD_aux(TD_variant(id,to_ast_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in + let td_var = TD_aux(TD_variant(id,to_ast_namescm name_scm_opt,typq,arms,false),(l,())) in let typ = (match (typquant_to_quantkinds k_env typq) with | [ ] -> {k = K_Typ} | typs -> {k = K_Lam(typs,{k=K_Typ})}) in @@ -686,7 +728,7 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_ let key = id_to_string id in let enums = List.map to_ast_id enums in let keys = List.map id_to_string enums in - let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *) + let td_enum = TD_aux(TD_enum(id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *) let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in td_enum, (names,k_env,def_ord) | Parse_ast.TD_register(id,t1,t2,ranges) -> @@ -695,9 +737,9 @@ let to_ast_typedef (names,k_env,def_ord) (td:Parse_ast.type_def) : (tannot type_ let n1 = to_ast_nexp k_env t1 in let n2 = to_ast_nexp k_env t2 in let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in - TD_aux(TD_register(id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) + TD_aux(TD_register(id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) -let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def) envs_out = +let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (unit kind_def) envs_out = match td with | Parse_ast.KD_aux(td,l) -> (match td with @@ -708,7 +750,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def (match k.k with | K_Typ | K_Lam _ -> let typschm,k_env,_ = to_ast_typschm k_env def_ord typschm in - let kd_abrv = KD_aux(KD_abbrev(kind,id,to_ast_namescm name_scm_opt,typschm),(l,NoTyp)) in + let kd_abrv = KD_aux(KD_abbrev(kind,id,to_ast_namescm name_scm_opt,typschm),(l,())) in let typ = (match typschm with | TypSchm_aux(TypSchm_ts(tq,typ), _) -> begin match (typquant_to_quantkinds k_env tq) with @@ -722,7 +764,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def | Parse_ast.TypSchm_aux(Parse_ast.TypSchm_ts(Parse_ast.TypQ_aux(tq,_),atyp),_) -> (match tq with | Parse_ast.TypQ_no_forall -> - KD_aux(KD_nabbrev(kind,id,to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l,NoTyp)) + KD_aux(KD_nabbrev(kind,id,to_ast_namescm name_scm_opt, to_ast_nexp k_env atyp), (l,())) | _ -> typ_error l "Def with kind Nat cannot have universal quantification" None None None)) in kd_nabrv,(names,Envmap.insert k_env (key, k),def_ord) | _ -> assert false @@ -733,7 +775,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def let (kind,k) = to_ast_kind k_env kind in let typq,k_env,_ = to_ast_typquant k_env typq in let fields = List.map (fun (atyp,id) -> (to_ast_typ k_env def_ord atyp),(to_ast_id id)) fields in (* Add check that all arms have unique names locally *) - let kd_rec = KD_aux(KD_record(kind,id,to_ast_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in + let kd_rec = KD_aux(KD_record(kind,id,to_ast_namescm name_scm_opt,typq,fields,false),(l,())) in let typ = (match (typquant_to_quantkinds k_env typq) with | [ ] -> {k = K_Typ} | typs -> {k = K_Lam(typs,{k=K_Typ})}) in @@ -744,7 +786,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def let kind,k = to_ast_kind k_env kind in let typq,k_env,_ = to_ast_typquant k_env typq in let arms = List.map (to_ast_type_union k_env def_ord) arms in (* Add check that all arms have unique names *) - let kd_var = KD_aux(KD_variant(kind,id,to_ast_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in + let kd_var = KD_aux(KD_variant(kind,id,to_ast_namescm name_scm_opt,typq,arms,false),(l,())) in let typ = (match (typquant_to_quantkinds k_env typq) with | [ ] -> {k = K_Typ} | typs -> {k = K_Lam(typs,{k=K_Typ})}) in @@ -755,7 +797,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def let kind,k = to_ast_kind k_env kind in let enums = List.map to_ast_id enums in let keys = List.map id_to_string enums in - let kd_enum = KD_aux(KD_enum(kind,id,to_ast_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *) + let kd_enum = KD_aux(KD_enum(kind,id,to_ast_namescm name_scm_opt,enums,false),(l,())) in (* Add check that all enums have unique names *) let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in kd_enum, (names,k_env,def_ord) | Parse_ast.KD_register(kind,id,t1,t2,ranges) -> @@ -765,7 +807,7 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def let n1 = to_ast_nexp k_env t1 in let n2 = to_ast_nexp k_env t2 in let ranges = List.map (fun (range,id) -> (to_ast_range range),to_ast_id id) ranges in - KD_aux(KD_register(kind,id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) + KD_aux(KD_register(kind,id,n1,n2,ranges),(l,())), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = @@ -776,7 +818,8 @@ let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = let to_ast_tannot_opt (k_env:kind Envmap.t) (def_ord:order) (Parse_ast.Typ_annot_opt_aux(tp,l)):tannot_opt * kind Envmap.t * kind Envmap.t= match tp with - | Parse_ast.Typ_annot_opt_none -> raise (Reporting_basic.err_unreachable l "Parser generated typ annot opt none") + | Parse_ast.Typ_annot_opt_none -> + Typ_annot_opt_aux (Typ_annot_opt_none, l), k_env, Envmap.empty | Parse_ast.Typ_annot_opt_some(tq,typ) -> let typq,k_env,k_local = to_ast_typquant k_env tq in Typ_annot_opt_aux(Typ_annot_opt_some(typq,to_ast_typ k_env def_ord typ),l),k_env,k_local @@ -786,25 +829,25 @@ let to_ast_effects_opt (k_env : kind Envmap.t) (Parse_ast.Effect_opt_aux(e,l)) : | Parse_ast.Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l) | Parse_ast.Effect_opt_effect(typ) -> Effect_opt_aux(Effect_opt_effect(to_ast_effects k_env typ),l) -let to_ast_funcl (names,k_env,def_ord) (Parse_ast.FCL_aux(fcl,l) : Parse_ast.funcl) : (tannot funcl) = +let to_ast_funcl (names,k_env,def_ord) (Parse_ast.FCL_aux(fcl,l) : Parse_ast.funcl) : (unit funcl) = (*let _ = Printf.eprintf "to_ast_funcl\n" in*) match fcl with | Parse_ast.FCL_Funcl(id,pat,exp) -> - FCL_aux(FCL_Funcl(to_ast_id id, to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,NoTyp)) + FCL_aux(FCL_Funcl(to_ast_id id, to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp),(l,())) -let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.fundef) : (tannot fundef) envs_out = +let to_ast_fundef (names,k_env,def_ord) (Parse_ast.FD_aux(fd,l):Parse_ast.fundef) : (unit fundef) envs_out = match fd with | Parse_ast.FD_function(rec_opt,tannot_opt,effects_opt,funcls) -> (*let _ = Printf.eprintf "to_ast_fundef\n" in*) let tannot_opt, k_env,_ = to_ast_tannot_opt k_env def_ord tannot_opt in - FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,NoTyp)), (names,k_env,def_ord) + FD_aux(FD_function(to_ast_rec rec_opt, tannot_opt, to_ast_effects_opt k_env effects_opt, List.map (to_ast_funcl (names, k_env, def_ord)) funcls), (l,())), (names,k_env,def_ord) type def_progress = No_def | Def_place_holder of id * Parse_ast.l - | Finished of tannot def + | Finished of unit def -type partial_def = ((tannot def) * bool) ref * kind Envmap.t +type partial_def = ((unit def) * bool) ref * kind Envmap.t let rec def_in_progress (id : id) (partial_defs : (id * partial_def) list) : partial_def option = match partial_defs with @@ -818,17 +861,17 @@ let to_ast_alias_spec k_env def_ord (Parse_ast.E_aux(e,le)) = AL_aux( (match e with | Parse_ast.E_field(Parse_ast.E_aux(Parse_ast.E_id id,li), field) -> - AL_subreg(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_id field) + AL_subreg(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_id field) | Parse_ast.E_vector_access(Parse_ast.E_aux(Parse_ast.E_id id,li),range) -> - AL_bit(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_exp k_env def_ord range) + AL_bit(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord range) | Parse_ast.E_vector_subrange(Parse_ast.E_aux(Parse_ast.E_id id,li),base,stop) -> - AL_slice(RI_aux(RI_id (to_ast_id id),(li,NoTyp)),to_ast_exp k_env def_ord base,to_ast_exp k_env def_ord stop) + AL_slice(RI_aux(RI_id (to_ast_id id),(li,())),to_ast_exp k_env def_ord base,to_ast_exp k_env def_ord stop) | Parse_ast.E_vector_append(Parse_ast.E_aux(Parse_ast.E_id first,lf), Parse_ast.E_aux(Parse_ast.E_id second,ls)) -> - AL_concat(RI_aux(RI_id (to_ast_id first),(lf,NoTyp)), - RI_aux(RI_id (to_ast_id second),(ls,NoTyp))) + AL_concat(RI_aux(RI_id (to_ast_id first),(lf,())), + RI_aux(RI_id (to_ast_id second),(ls,()))) | _ -> raise (Reporting_basic.err_unreachable le "Found an expression not supported by parser in to_ast_alias_spec") - ), (le,NoTyp)) + ), (le,())) let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) = DEC_aux( @@ -839,11 +882,13 @@ let to_ast_dec (names,k_env,def_ord) (Parse_ast.DEC_aux(regdec,l)) = DEC_alias(to_ast_id id,to_ast_alias_spec k_env def_ord e) | Parse_ast.DEC_typ_alias(typ,id,e) -> DEC_typ_alias(to_ast_typ k_env def_ord typ,to_ast_id id,to_ast_alias_spec k_env def_ord e) - ),(l,NoTyp)) + ),(l,())) let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out * (id * partial_def) list = let envs = (names,k_env,def_ord) in match def with + | Parse_ast.DEF_overload(id,ids) -> + ((Finished(DEF_overload(to_ast_id id, List.map to_ast_id ids))),envs),partial_defs | Parse_ast.DEF_kind(k_def) -> let kd,envs = to_ast_kdef envs k_def in ((Finished(DEF_kind(kd))),envs),partial_defs @@ -869,11 +914,11 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out (match sd with | Parse_ast.SD_scattered_function(rec_opt, tannot_opt, effects_opt, id) -> let rec_opt = to_ast_rec rec_opt in - let tannot,k_env',k_local = to_ast_tannot_opt k_env def_ord tannot_opt in + let unit,k_env',k_local = to_ast_tannot_opt k_env def_ord tannot_opt in let effects_opt = to_ast_effects_opt k_env' effects_opt in let id = to_ast_id id in (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,tannot,effects_opt,[]),(l,NoTyp)))),false) in + | None -> let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,unit,effects_opt,[]),(l,())))),false) in (No_def,envs),((id,(partial_def,k_local))::partial_defs) | Some(d,k) -> typ_error l "Scattered function definition header name already in use by scattered definition" (Some id) None None) | Parse_ast.SD_scattered_funcl(funcl) -> @@ -901,7 +946,7 @@ let to_ast_def (names, k_env, def_ord) partial_defs def : def_progress envs_out | [ ] -> {k = K_Typ} | typs -> {k = K_Lam(typs,{k=K_Typ})}) in (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,NoTyp)))),false) in + | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,())))),false) in (Def_place_holder(id,l),(names,Envmap.insert k_env ((id_to_string id),kind),def_ord)),(id,(partial_def,k_env'))::partial_defs | Some(d,k) -> typ_error l "Scattered type definition header name already in use by scattered definition" (Some id) None None) | Parse_ast.SD_scattered_unioncl(id,tu) -> @@ -957,3 +1002,30 @@ let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : ord | (_, true) -> ())) partial_defs; (Defs defs),k_env,def_ord + +let initial_kind_env = + Envmap.from_list [ + ("bool", {k = K_Typ}); + ("nat", {k = K_Typ}); + ("int", {k = K_Typ}); + ("uint8", {k = K_Typ}); + ("uint16", {k= K_Typ}); + ("uint32", {k=K_Typ}); + ("uint64", {k=K_Typ}); + ("unit", {k = K_Typ}); + ("bit", {k = K_Typ}); + ("string", {k = K_Typ}); + ("real", {k = K_Typ}); + ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})}); + ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); + ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); + ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) }); + ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); + ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); + ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) }); + ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} ); + ] + +let process_ast defs = + let (ast, _, _) = to_ast Nameset.empty initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown)) defs in + ast diff --git a/src/initial_check.mli b/src/initial_check.mli index 5e4b7e77..063a0131 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -41,13 +41,8 @@ (**************************************************************************) open Ast -open Type_internal -type kind = Type_internal.kind -type typ = Type_internal.t -(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *) -type envs = Nameset.t * kind Envmap.t * Ast.order -type 'a envs_out = 'a * envs +val process_ast : Parse_ast.defs -> unit defs -val to_ast : Nameset.t -> kind Envmap.t -> Ast.order -> Parse_ast.defs -> tannot defs * kind Envmap.t * Ast.order -val to_ast_exp : kind Envmap.t -> Ast.order -> Parse_ast.exp -> Type_internal.tannot Ast.exp + + diff --git a/src/initial_check_full_ast.ml b/src/initial_check_full_ast.ml deleted file mode 100644 index b2781350..00000000 --- a/src/initial_check_full_ast.ml +++ /dev/null @@ -1,820 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* *) -(* 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 Type_internal -open Ast -open Type_internal - -(*Envs is a tuple of used names (currently unused), map from id to kind, default order for vector types and literal vectors *) -type envs = Nameset.t * kind Envmap.t * Ast.order -type 'a envs_out = 'a * envs - -let id_to_string (Id_aux(id,l)) = - match id with | Id(x) | DeIid(x) -> x - -let var_to_string (Kid_aux(Var v,l)) = v - -let typquant_to_quantkinds k_env typquant = - match typquant with - | TypQ_aux(tq,_) -> - (match tq with - | TypQ_no_forall -> [] - | TypQ_tq(qlist) -> - List.fold_right - (fun (QI_aux(qi,_)) rst -> - match qi with - | QI_const _ -> rst - | QI_id(ki) -> begin - match ki with - | KOpt_aux(KOpt_none(v),l) | KOpt_aux(KOpt_kind(_,v),l) -> - (match Envmap.apply k_env (var_to_string v) with - | Some(typ) -> typ::rst - | None -> raise (Reporting_basic.err_unreachable l "Envmap didn't get an entry during typschm processing")) - end) - qlist - []) - -let typ_error l msg opt_id opt_var opt_kind = - let full_msg = (msg ^ - (match opt_id, opt_var, opt_kind with - | Some(id),None,Some(kind) -> (id_to_string id) ^ " of " ^ (kind_to_string kind) - | Some(id),None,None -> ": " ^ (id_to_string id) - | None,Some(v),Some(kind) -> (var_to_string v) ^ " of " ^ (kind_to_string kind) - | None,Some(v),None -> ": " ^ (var_to_string v) - | None,None,Some(kind) -> " " ^ (kind_to_string kind) - | _ -> "")) in - Reporting_basic.report_error (Reporting_basic.Err_type(l, full_msg)) - -let to_base_kind (BK_aux(k,l')) = - match k with - | BK_type -> BK_aux(BK_type,l'), { k = K_Typ} - | BK_nat -> BK_aux(BK_nat,l'), { k = K_Nat } - | BK_order -> BK_aux(BK_order,l'), { k = K_Ord } - | BK_effect -> BK_aux(BK_effect,l'), { k = K_Efct } - -let to_kind (k_env : kind Envmap.t) (K_aux(K_kind(klst),l)) : (Ast.kind * kind) = - match klst with - | [] -> raise (Reporting_basic.err_unreachable l "Kind with empty kindlist encountered") - | [k] -> let k_ast,k_typ = to_base_kind k in - K_aux(K_kind([k_ast]),l), k_typ - | ks -> let k_pairs = List.map to_base_kind ks in - let reverse_typs = List.rev (List.map snd k_pairs) in - let ret,args = List.hd reverse_typs, List.rev (List.tl reverse_typs) in - match ret.k with - | K_Typ -> K_aux(K_kind(List.map fst k_pairs), l), { k = K_Lam(args,ret) } - | _ -> typ_error l "Type constructor must have an -> kind ending in Type" None None None - -let rec typ_to_string (Typ_aux(t,_)) = match t with - | Typ_id i -> id_to_string i - | Typ_var (Kid_aux (Var i,_)) -> i - | _ -> "bigger than var" - -and nexp_to_string (Nexp_aux(n,_)) = match n with - | Nexp_id i -> id_to_string i - | Nexp_var (Kid_aux (Var i,_)) -> i - | _ -> "nexp bigger than var" - -let rec to_typ (k_env : kind Envmap.t) (def_ord : Ast.order) (t: Ast.typ) : Ast.typ = - match t with - | Typ_aux(t,l) -> - Typ_aux( (match t with - | Typ_id(id) -> - let mk = Envmap.apply k_env (id_to_string id) in - (match mk with - | Some(k) -> - (match k.k with - | K_Typ -> Typ_id id - | K_infer -> k.k <- K_Typ; Typ_id id - | _ -> typ_error l "Required an identifier with kind Type, encountered " (Some id) None (Some k)) - | None -> typ_error l "Encountered an unbound type identifier" (Some id) None None) - | Typ_var(v) -> - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Typ -> Typ_var v - | K_infer -> k.k <- K_Typ; Typ_var v - | _ -> typ_error l "Required a variable with kind Type, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Typ_fn(arg,ret,efct) -> Typ_fn( (to_typ k_env def_ord arg), - (to_typ k_env def_ord ret), - (to_effects k_env efct)) - | Typ_tup(typs) -> Typ_tup( List.map (to_typ k_env def_ord) typs) - | Typ_app(id,typs) -> - let k = Envmap.apply k_env (id_to_string id) in - (match k with - | Some({k = K_Lam(args,t)}) -> - if ((List.length args) = (List.length typs)) - then - Typ_app(id,(List.map2 (fun k a -> (to_typ_arg k_env def_ord k a)) args typs)) - else typ_error l "Type constructor given incorrect number of arguments" (Some id) None None - | None -> - typ_error l "Required a type constructor, encountered an unbound identifier" (Some id) None None - | _ -> typ_error l "Required a type constructor, encountered a base kind variable" (Some id) None None) - | _ -> - typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None - ), l) - -and to_nexp (k_env : kind Envmap.t) (n: Ast.nexp) : Ast.nexp = - match n with - | Nexp_aux(t,l) -> - (match t with - | Nexp_id i -> - let mk = Envmap.apply k_env (id_to_string i) in - (match mk with - | Some(k) -> Nexp_aux((match k.k with - | K_Nat -> Nexp_id i - | K_infer -> k.k <- K_Nat; Nexp_id i - | _ -> typ_error l "Required a variable with kind Nat, encountered " (Some i) None (Some k)),l) - | None -> typ_error l "Encountered an unbound variable" (Some i) None None) - | Nexp_var(v) -> - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> Nexp_aux((match k.k with - | K_Nat -> Nexp_var v - | K_infer -> k.k <- K_Nat; Nexp_var v - | _ -> typ_error l "Required a variable with kind Nat, encountered " None (Some v) (Some k)),l) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Nexp_constant(i) -> Nexp_aux(Nexp_constant(i),l) - | Nexp_sum(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - Nexp_aux(Nexp_sum(n1,n2),l) - | Nexp_exp(t1) -> Nexp_aux(Nexp_exp(to_nexp k_env t1),l) - | Nexp_neg(t1) -> Nexp_aux(Nexp_neg(to_nexp k_env t1),l) - | Nexp_times(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - Nexp_aux(Nexp_times(n1,n2),l) - | Nexp_minus(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - Nexp_aux(Nexp_minus(n1,n2),l)) - -and to_order (k_env : kind Envmap.t) (def_ord : Ast.order) (o: Ast.order) : Ast.order = - match o with - | Ord_aux(t,l) -> - (match t with - | Ord_var(v) -> - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Ord -> Ord_aux(Ord_var v, l) - | K_infer -> k.k <- K_Ord; Ord_aux(Ord_var v,l) - | _ -> typ_error l "Required a variable with kind Order, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Ord_inc -> Ord_aux(Ord_inc,l) - | Ord_dec -> Ord_aux(Ord_dec,l) - ) - -and to_effects (k_env : kind Envmap.t) (e : Ast.effect) : Ast.effect = - match e with - | Effect_aux(t,l) -> - Effect_aux( (match t with - | Effect_var(v) -> - let mk = Envmap.apply k_env (var_to_string v) in - (match mk with - | Some(k) -> (match k.k with - | K_Efct -> Effect_var v - | K_infer -> k.k <- K_Efct; Effect_var v - | _ -> typ_error l "Required a variable with kind Effect, encountered " None (Some v) (Some k)) - | None -> typ_error l "Encountered an unbound variable" None (Some v) None) - | Effect_set(effects) -> Effect_set(effects) - ), l) - -and to_typ_arg (k_env : kind Envmap.t) (def_ord : Ast.order) (kind : kind) (arg : Ast.typ_arg) : Ast.typ_arg = - let l,ta = (match arg with Typ_arg_aux(ta,l) -> l,ta) in - Typ_arg_aux ( - (match kind.k,ta with - | K_Typ,Typ_arg_typ t -> Typ_arg_typ (to_typ k_env def_ord t) - | K_Nat,Typ_arg_nexp n -> Typ_arg_nexp (to_nexp k_env n) - | K_Ord,Typ_arg_order o -> Typ_arg_order (to_order k_env def_ord o) - | K_Efct,Typ_arg_effect e -> Typ_arg_effect (to_effects k_env e) - | (K_Lam _ | K_infer | K_Val),_ -> - raise (Reporting_basic.err_unreachable l "To_ast_typ_arg received Lam kind or infer kind") - | _ -> - let tn_str = - (match ta with - | Typ_arg_typ t -> typ_to_string t - | Typ_arg_nexp n -> nexp_to_string n - | _ -> "order or effect") in - typ_error l ("Kind declaration and kind of type argument, " ^ tn_str ^ " don't match here") - None None (Some kind)), - l) - -let to_nexp_constraint (k_env : kind Envmap.t) (c : n_constraint) : n_constraint = - match c with - | NC_aux(nc,l) -> - NC_aux( (match nc with - | NC_fixed(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - NC_fixed(n1,n2) - | NC_bounded_ge(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - NC_bounded_ge(n1,n2) - | NC_bounded_le(t1,t2) -> - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - NC_bounded_le(n1,n2) - | NC_nat_set_bounded(id,bounds) -> - NC_nat_set_bounded(id, bounds) - ), l) - -(* Transforms a typquant while building first the kind environment of declared variables, and also the kind environment in context *) -let to_typquant (k_env: kind Envmap.t) (tq : typquant) : typquant * kind Envmap.t * kind Envmap.t = - let opt_kind_to_ast k_env local_names local_env (KOpt_aux(ki,l)) = - let v, key, kind, ktyp = - match ki with - | KOpt_none(v) -> - let key = var_to_string v in - let kind,ktyp = - if (Envmap.in_dom key k_env) then None,(Envmap.apply k_env key) - else None,(Some{ k = K_infer }) in - v,key,kind, ktyp - | KOpt_kind(k,v) -> - let key = var_to_string v in - let kind,ktyp = to_kind k_env k in - v,key,Some(kind),Some(ktyp) - in - if (Nameset.mem key local_names) - then typ_error l "Encountered duplicate name in type scheme" None (Some v) None - else - let local_names = Nameset.add key local_names in - let kopt,k_env,k_env_local = (match kind,ktyp with - | Some(k),Some(kt) -> KOpt_kind(k,v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) - | None, Some(kt) -> KOpt_none(v), (Envmap.insert k_env (key,kt)), (Envmap.insert local_env (key,kt)) - | _ -> raise (Reporting_basic.err_unreachable l "Envmap in dom is true but apply gives None")) in - KOpt_aux(kopt,l),k_env,local_names,k_env_local - in - match tq with - | TypQ_aux(tqa,l) -> - (match tqa with - | TypQ_no_forall -> TypQ_aux(TypQ_no_forall,l), k_env, Envmap.empty - | TypQ_tq(qlist) -> - let rec to_q_items k_env local_names local_env = function - | [] -> [],k_env,local_env - | q::qs -> - (match q with - | QI_aux(qi,l) -> - (match qi with - | QI_const(n_const) -> - let c = QI_aux(QI_const(to_nexp_constraint k_env n_const),l) in - let qis,k_env,local_env = to_q_items k_env local_names local_env qs in - (c::qis),k_env,local_env - | QI_id(kid) -> - let kid,k_env,local_names,local_env = opt_kind_to_ast k_env local_names local_env kid in - let c = QI_aux(QI_id(kid),l) in - let qis,k_env,local_env = to_q_items k_env local_names local_env qs in - (c::qis),k_env,local_env)) - in - let lst,k_env,local_env = to_q_items k_env Nameset.empty Envmap.empty qlist in - TypQ_aux(TypQ_tq(lst),l), k_env, local_env) - -let to_typschm (k_env:kind Envmap.t) (def_ord:Ast.order) (tschm:Ast.typschm) - :Ast.typschm * kind Envmap.t * kind Envmap.t = - match tschm with - | TypSchm_aux(ts,l) -> - (match ts with | TypSchm_ts(tquant,t) -> - let tq,k_env,local_env = to_typquant k_env tquant in - let typ = to_typ k_env def_ord t in - TypSchm_aux(TypSchm_ts(tq,typ),l),k_env,local_env) - -let rec to_pat (k_env : kind Envmap.t) (def_ord : Ast.order) (P_aux(pat,(l,_)) : tannot pat) : tannot pat = - P_aux( - (match pat with - | P_lit(lit) -> P_lit(lit) - | P_wild -> P_wild - | P_as(pat,id) -> P_as(to_pat k_env def_ord pat, id) - | P_typ(typ,pat) -> P_typ(to_typ k_env def_ord typ,to_pat k_env def_ord pat) - | P_id(id) -> P_id(id) - | P_app(id,pats) -> - if pats = [] - then P_id (id) - else P_app(id, List.map (to_pat k_env def_ord) pats) - | P_record(fpats,_) -> - P_record(List.map - (fun (FP_aux(FP_Fpat(id,fp),(l,_))) -> - FP_aux(FP_Fpat(id, to_pat k_env def_ord fp),(l,NoTyp))) - fpats, false) - | P_vector(pats) -> P_vector(List.map (to_pat k_env def_ord) pats) - | P_vector_indexed(ipats) -> P_vector_indexed(List.map (fun (i,pat) -> i,to_pat k_env def_ord pat) ipats) - | P_vector_concat(pats) -> P_vector_concat(List.map (to_pat k_env def_ord) pats) - | P_tup(pats) -> P_tup(List.map (to_pat k_env def_ord) pats) - | P_list(pats) -> P_list(List.map (to_pat k_env def_ord) pats) - ), (l,NoTyp)) - - -let rec to_letbind (k_env : kind Envmap.t) (def_ord : Ast.order) (LB_aux(lb,(l,_)) : tannot letbind) : tannot letbind = - LB_aux( - (match lb with - | LB_val_explicit(typschm,pat,exp) -> - let typsch, k_env, _ = to_typschm k_env def_ord typschm in - LB_val_explicit(typsch,to_pat k_env def_ord pat, to_exp k_env def_ord exp) - | LB_val_implicit(pat,exp) -> - LB_val_implicit(to_pat k_env def_ord pat, to_exp k_env def_ord exp) - ), (l,NoTyp)) - -and to_exp (k_env : kind Envmap.t) (def_ord : Ast.order) (E_aux(exp,(l,_)) : exp) : exp = - E_aux( - (match exp with - | E_block(exps) -> E_block(List.map (to_exp k_env def_ord) exps) - | E_nondet(exps) -> E_nondet(List.map (to_exp k_env def_ord) exps) - | E_id(id) -> E_id(id) - | E_lit(lit) -> E_lit(lit) - | E_cast(typ,exp) -> E_cast(to_typ k_env def_ord typ, to_exp k_env def_ord exp) - | E_app(f,args) -> - (match List.map (to_exp k_env def_ord) args with - | [] -> E_app(f, []) - | [E_aux(E_tuple(exps),_)] -> E_app(f, exps) - | exps -> E_app(f, exps)) - | E_app_infix(left,op,right) -> - E_app_infix(to_exp k_env def_ord left, op, to_exp k_env def_ord right) - | E_tuple(exps) -> E_tuple(List.map (to_exp k_env def_ord) exps) - | E_if(e1,e2,e3) -> E_if(to_exp k_env def_ord e1, to_exp k_env def_ord e2, to_exp k_env def_ord e3) - | E_for(id,e1,e2,e3,atyp,e4) -> - E_for(id,to_exp k_env def_ord e1, to_exp k_env def_ord e2, - to_exp k_env def_ord e3,to_order k_env def_ord atyp, to_exp k_env def_ord e4) - | E_vector(exps) -> E_vector(List.map (to_exp k_env def_ord) exps) - | E_vector_indexed(iexps,Def_val_aux(default,(dl,_))) -> - E_vector_indexed (to_iexps true k_env def_ord iexps, - Def_val_aux((match default with - | Def_val_empty -> Def_val_empty - | Def_val_dec e -> Def_val_dec (to_exp k_env def_ord e)),(dl,NoTyp))) - | E_vector_access(vexp,exp) -> E_vector_access(to_exp k_env def_ord vexp, to_exp k_env def_ord exp) - | E_vector_subrange(vex,exp1,exp2) -> - E_vector_subrange(to_exp k_env def_ord vex, to_exp k_env def_ord exp1, to_exp k_env def_ord exp2) - | E_vector_update(vex,exp1,exp2) -> - E_vector_update(to_exp k_env def_ord vex, to_exp k_env def_ord exp1, to_exp k_env def_ord exp2) - | E_vector_update_subrange(vex,e1,e2,e3) -> - E_vector_update_subrange(to_exp k_env def_ord vex, to_exp k_env def_ord e1, - to_exp k_env def_ord e2, to_exp k_env def_ord e3) - | E_vector_append(e1,e2) -> E_vector_append(to_exp k_env def_ord e1,to_exp k_env def_ord e2) - | E_list(exps) -> E_list(List.map (to_exp k_env def_ord) exps) - | E_cons(e1,e2) -> E_cons(to_exp k_env def_ord e1, to_exp k_env def_ord e2) - | E_record(fexps) -> - (match to_fexps true k_env def_ord fexps with - | Some(fexps) -> E_record(fexps) - | None -> raise (Reporting_basic.err_unreachable l "to_fexps with true returned none")) - | E_record_update(exp,fexps) -> - (match to_fexps true k_env def_ord fexps with - | Some(fexps) -> E_record_update(to_exp k_env def_ord exp, fexps) - | _ -> raise (Reporting_basic.err_unreachable l "to_fexps with true returned none")) - | E_field(exp,id) -> E_field(to_exp k_env def_ord exp, id) - | E_case(exp,pexps) -> E_case(to_exp k_env def_ord exp, List.map (to_case k_env def_ord) pexps) - | E_let(leb,exp) -> E_let(to_letbind k_env def_ord leb, to_exp k_env def_ord exp) - | E_assign(lexp,exp) -> E_assign(to_lexp k_env def_ord lexp, to_exp k_env def_ord exp) - | E_sizeof(nexp) -> E_sizeof(to_nexp k_env nexp) - | E_exit exp -> E_exit(to_exp k_env def_ord exp) - | E_return exp -> E_return(to_exp k_env def_ord exp) - | E_assert(cond,msg) -> E_assert(to_exp k_env def_ord cond, to_exp k_env def_ord msg) - | E_comment s -> E_comment s - | E_comment_struc e -> E_comment_struc e - | _ -> raise (Reporting_basic.err_unreachable l "to_exp given internal node") - ), (l,NoTyp)) - -and to_lexp (k_env : kind Envmap.t) (def_ord : Ast.order) (LEXP_aux(exp,(l,_)) : tannot lexp) : tannot lexp = - LEXP_aux( - (match exp with - | LEXP_id(id) -> LEXP_id(id) - | LEXP_memory(f,args) -> - (match List.map (to_exp k_env def_ord) args with - | [] -> LEXP_memory(f,[]) - | [E_aux(E_tuple exps,_)] -> LEXP_memory(f,exps) - | args -> LEXP_memory(f, args)) - | LEXP_cast(typ,id) -> - LEXP_cast(to_typ k_env def_ord typ, id) - | LEXP_tup tups -> - let ltups = List.map (to_lexp k_env def_ord) tups in - let is_ok_in_tup (LEXP_aux (le,(l,_))) = - match le with - | LEXP_id _ | LEXP_cast _ | LEXP_vector _ | LEXP_field _ | LEXP_vector_range _ | LEXP_tup _ -> () - | LEXP_memory _ -> - typ_error l "only identifiers, fields, and vectors may be set in a tuple" None None None in - List.iter is_ok_in_tup ltups; - LEXP_tup(ltups) - | LEXP_vector(vexp,exp) -> LEXP_vector(to_lexp k_env def_ord vexp, to_exp k_env def_ord exp) - | LEXP_vector_range(vexp,exp1,exp2) -> - LEXP_vector_range(to_lexp k_env def_ord vexp, to_exp k_env def_ord exp1, to_exp k_env def_ord exp2) - | LEXP_field(fexp,id) -> LEXP_field(to_lexp k_env def_ord fexp, id)) - , (l,NoTyp)) - -and to_case (k_env : kind Envmap.t) (def_ord : Ast.order) (Pat_aux(pex,(l,_)) : tannot pexp) : tannot pexp = - match pex with - | Pat_exp(pat,exp) -> Pat_aux(Pat_exp(to_pat k_env def_ord pat, to_exp k_env def_ord exp),(l,NoTyp)) - -and to_fexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:Ast.order) (FES_aux (FES_Fexps(fexps,_),(l,_))) - : tannot fexps option = - let wrap fs = FES_aux (FES_Fexps(fs,false),(l,NoTyp)) in - match fexps with - | [] -> if fail_on_error then typ_error l "Record or record update must include fields" None None None - else None - | fexp::exps -> - match fexp with - | FE_aux(FE_Fexp(id,exp),(fl,_)) -> - (match (to_fexps false k_env def_ord (wrap exps)) with - | Some(FES_aux(FES_Fexps(fexps,_),(l,_))) -> - Some(wrap(fexp::fexps)) - | None -> - Some(wrap([fexp]))) - -and to_iexps (fail_on_error:bool) (k_env:kind Envmap.t) (def_ord:Ast.order) (iexps: (int * exp) list) - :(int * exp) list = - match iexps with - | [] -> [] - | (i,exp)::exps -> - (i, to_exp k_env def_ord exp)::to_iexps fail_on_error k_env def_ord exps - -let to_default (names, k_env, default_order) (default : tannot default_spec) : (tannot default_spec) envs_out = - match default with - | DT_aux(df,l) -> - (match df with - | DT_kind(bk,v) -> - let k,k_typ = to_base_kind bk in - let key = var_to_string v in - DT_aux(DT_kind(k,v),l),(names,(Envmap.insert k_env (key,k_typ)),default_order) - | DT_typ(typschm,id) -> - let tps,_,_ = to_typschm k_env default_order typschm in - DT_aux(DT_typ(tps,id),l),(names,k_env,default_order) - | DT_order(o) -> - (match o with - | Ord_aux(Ord_inc,lo) -> - let default_order = Ord_aux(Ord_inc,lo) in - DT_aux(DT_order default_order,l),(names,k_env,default_order) - | Ord_aux(Ord_dec,lo) -> - let default_order = Ord_aux(Ord_dec,lo) in - DT_aux(DT_order default_order,l),(names,k_env,default_order) - | _ -> typ_error l "Default order must be Inc or Dec" None None None)) - -let to_spec (names,k_env,default_order) (val_: tannot val_spec) : (tannot val_spec) envs_out = - match val_ with - | VS_aux(vs,(l,_)) -> - (match vs with - | VS_val_spec(ts,id) -> - let typsch,_,_ = to_typschm k_env default_order ts in - VS_aux(VS_val_spec(typsch, id),(l,NoTyp)),(names,k_env,default_order) - | VS_extern_spec(ts,id,s) -> - let typsch,_,_ = to_typschm k_env default_order ts in - VS_aux(VS_extern_spec(typsch,id,s),(l,NoTyp)),(names,k_env,default_order) - | VS_extern_no_rename(ts,id) -> - let typsch,_,_ = to_typschm k_env default_order ts in - VS_aux(VS_extern_no_rename(typsch,id),(l,NoTyp)),(names,k_env,default_order)) - -let to_namescm ns = ns - -let rec to_range (BF_aux(r,l)) = (* TODO add check that ranges are sensible for some definition of sensible *) - BF_aux( - (match r with - | BF_single(i) -> BF_single(i) - | BF_range(i1,i2) -> BF_range(i1,i2) - | BF_concat(ir1,ir2) -> BF_concat( to_range ir1, to_range ir2)), - l) - -let to_type_union k_env default_order (Tu_aux(tu,l)) = - match tu with - | Tu_ty_id(atyp,id) -> (Tu_aux(Tu_ty_id ((to_typ k_env default_order atyp),id),l)) - | Tu_id id -> (Tu_aux(Tu_id(id),l)) - -let to_typedef (names,k_env,def_ord) (td: tannot type_def) : (tannot type_def) envs_out = - match td with - |TD_aux(td,(l,_)) -> - (match td with - | TD_abbrev(id,name_scm_opt,typschm) -> - let key = id_to_string id in - let typschm,k_env,_ = to_typschm k_env def_ord typschm in - let td_abrv = TD_aux(TD_abbrev(id,to_namescm name_scm_opt,typschm),(l,NoTyp)) in - let typ = (match typschm with - | TypSchm_aux(TypSchm_ts(tq,typ), _) -> - begin match (typquant_to_quantkinds k_env tq) with - | [] -> {k = K_Typ} - | typs -> {k= K_Lam(typs,{k=K_Typ})} - end) in - td_abrv,(names,Envmap.insert k_env (key,typ),def_ord) - | TD_record(id,name_scm_opt,typq,fields,_) -> - let key = id_to_string id in - let typq,k_env,_ = to_typquant k_env typq in - let fields = List.map (fun (atyp,id) -> (to_typ k_env def_ord atyp),id) fields in (* Add check that all arms have unique names locally *) - let td_rec = TD_aux(TD_record(id,to_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - td_rec, (names,Envmap.insert k_env (key,typ), def_ord) - | TD_variant(id,name_scm_opt,typq,arms,_) -> - let key = id_to_string id in - let typq,k_env,_ = to_typquant k_env typq in - let arms = List.map (to_type_union k_env def_ord) arms in (* Add check that all arms have unique names *) - let td_var = TD_aux(TD_variant(id,to_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - td_var, (names,Envmap.insert k_env (key,typ), def_ord) - | TD_enum(id,name_scm_opt,enums,_) -> - let key = id_to_string id in - let keys = List.map id_to_string enums in - let td_enum = TD_aux(TD_enum(id,to_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *) - let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in - td_enum, (names,k_env,def_ord) - | TD_register(id,t1,t2,ranges) -> - let key = id_to_string id in - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - let ranges = List.map (fun (range,id) -> (to_range range),id) ranges in - TD_aux(TD_register(id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord)) - -let to_kinddef (names,k_env,def_ord) (kd: tannot kind_def) : (tannot kind_def) envs_out = - match kd with - |KD_aux(td,(l,_)) -> - (match td with - | KD_abbrev(kind,id,name_scm_opt,typschm) -> - let key = id_to_string id in - let _,k = to_kind k_env kind in - (match k.k with - | K_Typ | K_Lam _ -> - let typschm,k_env,_ = to_typschm k_env def_ord typschm in - let kd_abrv = KD_aux(KD_abbrev(kind,id,to_namescm name_scm_opt,typschm),(l,NoTyp)) in - let typ = (match typschm with - | TypSchm_aux(TypSchm_ts(tq,typ), _) -> - begin match (typquant_to_quantkinds k_env tq) with - | [] -> {k = K_Typ} - | typs -> {k= K_Lam(typs,{k=K_Typ})} - end) in - kd_abrv,(names,Envmap.insert k_env (key,typ),def_ord) - | _ -> typ_error l "Def abbreviation with type scheme had declared kind other than Type" None None (Some k)) - | KD_nabbrev(kind,id,name_scm_opt,nexp) -> - let key = id_to_string id in - let _,k = to_kind k_env kind in - (match k.k with - | K_Nat -> - let nexp = to_nexp k_env nexp in - let kd_nabrv = KD_aux(KD_nabbrev(kind,id,to_namescm name_scm_opt, nexp),(l,NoTyp)) in - kd_nabrv,(names,Envmap.insert k_env (key,k),def_ord) - | _ -> typ_error l "Def abbreviation binding a number declared with kind other than Nat" None None (Some k)) - | KD_record(kind,id,name_scm_opt,typq,fields,_) -> - let key = id_to_string id in - let _,k = to_kind k_env kind in - let typq,k_env,_ = to_typquant k_env typq in - (match k.k with - | K_Typ | K_Lam _ -> - let fields = List.map (fun (atyp,id) -> (to_typ k_env def_ord atyp),id) fields in (* Add check that all arms have unique names locally *) - let kd_rec = KD_aux(KD_record(kind,id,to_namescm name_scm_opt,typq,fields,false),(l,NoTyp)) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - kd_rec, (names,Envmap.insert k_env (key,typ), def_ord) - | _ -> typ_error l "Def abbreviation binding a record has kind other than Type" None None (Some k)) - | KD_variant(kind,id,name_scm_opt,typq,arms,_) -> - let key = id_to_string id in - let _,k = to_kind k_env kind in - let typq,k_env,_ = to_typquant k_env typq in - (match k.k with - | K_Typ | K_Lam _ -> - let arms = List.map (to_type_union k_env def_ord) arms in (* Add check that all arms have unique names *) - let kd_var = KD_aux(KD_variant(kind,id,to_namescm name_scm_opt,typq,arms,false),(l,NoTyp)) in - let typ = (match (typquant_to_quantkinds k_env typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - kd_var, (names,Envmap.insert k_env (key,typ), def_ord) - | _ -> typ_error l "Def abbreviation binding a variant has kind other than Type" None None (Some k)) - | KD_enum(kind,id,name_scm_opt,enums,_) -> - let key = id_to_string id in - let keys = List.map id_to_string enums in - let _,k= to_kind k_env kind in - (match k.k with - | K_Typ -> - let kd_enum = KD_aux(KD_enum(kind,id,to_namescm name_scm_opt,enums,false),(l,NoTyp)) in (* Add check that all enums have unique names *) - let k_env = List.fold_right (fun k k_env -> Envmap.insert k_env (k,{k=K_Nat})) keys (Envmap.insert k_env (key,{k=K_Typ})) in - kd_enum, (names,k_env,def_ord) - | _ -> typ_error l "Def abbreviation binding an enum has kind other than Type" None None (Some k)) - | KD_register(kind,id,t1,t2,ranges) -> - let key = id_to_string id in - let n1 = to_nexp k_env t1 in - let n2 = to_nexp k_env t2 in - let _,k = to_kind k_env kind in - match k.k with - | K_Typ -> - let ranges = List.map (fun (range,id) -> (to_range range),id) ranges in - KD_aux(KD_register(kind,id,n1,n2,ranges),(l,NoTyp)), (names,Envmap.insert k_env (key, {k=K_Typ}),def_ord) - | _ -> typ_error l "Def abbreviation binding a register type has kind other than Type" None None (Some k)) - - -let to_tannot_opt (k_env:kind Envmap.t) (def_ord:Ast.order) (Typ_annot_opt_aux(tp,l)) - :tannot_opt * kind Envmap.t * kind Envmap.t= - match tp with - | Typ_annot_opt_some(tq,typ) -> - let typq,k_env,k_local = to_typquant k_env tq in - Typ_annot_opt_aux(Typ_annot_opt_some(typq,to_typ k_env def_ord typ),l),k_env,k_local - -let to_effects_opt (k_env : kind Envmap.t) (Effect_opt_aux(e,l)) : effect_opt = - match e with - | Effect_opt_pure -> Effect_opt_aux(Effect_opt_pure,l) - | Effect_opt_effect(typ) -> Effect_opt_aux(Effect_opt_effect(to_effects k_env typ),l) - -let to_funcl (names,k_env,def_ord) (FCL_aux(fcl,(l,_)) : tannot funcl) : (tannot funcl) = - match fcl with - | FCL_Funcl(id,pat,exp) -> - FCL_aux(FCL_Funcl(id, to_pat k_env def_ord pat, to_exp k_env def_ord exp),(l,NoTyp)) - -let to_fundef (names,k_env,def_ord) (FD_aux(fd,(l,_)): tannot fundef) : (tannot fundef) envs_out = - match fd with - | FD_function(rec_opt,tannot_opt,effects_opt,funcls) -> - let tannot_opt, k_env,_ = to_tannot_opt k_env def_ord tannot_opt in - FD_aux(FD_function(rec_opt, tannot_opt, to_effects_opt k_env effects_opt, - List.map (to_funcl (names, k_env, def_ord)) funcls), (l,NoTyp)), (names,k_env,def_ord) - -type def_progress = - No_def - | Def_place_holder of id * Parse_ast.l - | Finished of tannot def - -type partial_def = ((tannot def) * bool) ref * kind Envmap.t - -let rec def_in_progress (id : id) (partial_defs : (id * partial_def) list) : partial_def option = - match partial_defs with - | [] -> None - | (n,pd)::defs -> - (match n,id with - | Id_aux(Id(n),_), Id_aux(Id(i),_) -> if (n = i) then Some(pd) else def_in_progress id defs - | _,_ -> def_in_progress id defs) - -let to_alias_spec k_env def_ord (AL_aux(ae,(le,_))) = - AL_aux( - (match ae with - | AL_subreg(reg, field) -> AL_subreg(reg, field) - | AL_bit(reg,range) -> AL_bit(reg,to_exp k_env def_ord range) - | AL_slice(reg,base,stop) -> - AL_slice(reg,to_exp k_env def_ord base,to_exp k_env def_ord stop) - | AL_concat(first,second) -> AL_concat(first,second) - ), (le,NoTyp)) - -let to_dec (names,k_env,def_ord) (DEC_aux(regdec,(l,_))) = - DEC_aux( - (match regdec with - | DEC_reg(typ,id) -> - DEC_reg(to_typ k_env def_ord typ,id) - | DEC_alias(id,ae) -> - DEC_alias(id,to_alias_spec k_env def_ord ae) - | DEC_typ_alias(typ,id,ae) -> - DEC_typ_alias(to_typ k_env def_ord typ,id,to_alias_spec k_env def_ord ae) - ),(l,NoTyp)) - -let to_def (names, k_env, def_ord) partial_defs def : def_progress envs_out * (id * partial_def) list = - let envs = (names,k_env,def_ord) in - match def with - | DEF_kind(k_def) -> - let kd,envs = to_kinddef envs k_def in - ((Finished(DEF_kind(kd))),envs),partial_defs - | DEF_type(t_def) -> - let td,envs = to_typedef envs t_def in - ((Finished(DEF_type(td))),envs),partial_defs - | DEF_fundef(f_def) -> - let fd,envs = to_fundef envs f_def in - ((Finished(DEF_fundef(fd))),envs),partial_defs - | DEF_val(lbind) -> - let lb = to_letbind k_env def_ord lbind in - ((Finished(DEF_val(lb))),envs),partial_defs - | DEF_spec(val_spec) -> - let vs,envs = to_spec envs val_spec in - ((Finished(DEF_spec(vs))),envs),partial_defs - | DEF_default(typ_spec) -> - let default,envs = to_default envs typ_spec in - ((Finished(DEF_default(default))),envs),partial_defs - | DEF_comm c-> ((Finished(DEF_comm c)),envs),partial_defs - | DEF_reg_dec(dec) -> - let d = to_dec envs dec in - ((Finished(DEF_reg_dec(d))),envs),partial_defs - | DEF_scattered(SD_aux(sd,(l,_))) -> - (match sd with - | SD_scattered_function(rec_opt, tannot_opt, effects_opt, id) -> - let tannot,k_env',k_local = to_tannot_opt k_env def_ord tannot_opt in - let effects_opt = to_effects_opt k_env' effects_opt in - (match (def_in_progress id partial_defs) with - | None -> - let partial_def = ref ((DEF_fundef(FD_aux(FD_function(rec_opt,tannot,effects_opt,[]),(l,NoTyp)))),false) in - (No_def,envs),((id,(partial_def,k_local))::partial_defs) - | Some(d,k) -> - typ_error l - "Scattered function definition header name already in use by scattered definition" (Some id) None None) - | SD_scattered_funcl(funcl) -> - (match funcl with - | FCL_aux(FCL_Funcl(id,_,_),_) -> - (match (def_in_progress id partial_defs) with - | None -> - typ_error l - "Scattered function definition clause does not match any exisiting function definition headers" - (Some id) None None - | Some(d,k) -> - (match !d with - | DEF_fundef(FD_aux(FD_function(r,t,e,fcls),fl)),false -> - let funcl = to_funcl (names,Envmap.union k k_env,def_ord) funcl in - d:= DEF_fundef(FD_aux(FD_function(r,t,e,fcls@[funcl]),fl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered funciton definition clauses extends ended defintion" (Some id) None None - | _ -> typ_error l - "Scattered function definition clause matches an existing scattered type definition header" - (Some id) None None))) - | SD_scattered_variant(id,naming_scheme_opt,typquant) -> - let name = to_namescm naming_scheme_opt in - let typq, k_env',_ = to_typquant k_env typquant in - let kind = (match (typquant_to_quantkinds k_env' typq) with - | [ ] -> {k = K_Typ} - | typs -> {k = K_Lam(typs,{k=K_Typ})}) in - (match (def_in_progress id partial_defs) with - | None -> let partial_def = ref ((DEF_type(TD_aux(TD_variant(id,name,typq,[],false),(l,NoTyp)))),false) in - (Def_place_holder(id,l), - (names,Envmap.insert k_env ((id_to_string id),kind),def_ord)),(id,(partial_def,k_env'))::partial_defs - | Some(d,k) -> - typ_error l "Scattered type definition header name already in use by scattered definition" (Some id) None None) - | SD_scattered_unioncl(id,tu) -> - (match (def_in_progress id partial_defs) with - | None -> typ_error l - "Scattered type definition clause does not match any existing type definition headers" - (Some id) None None - | Some(d,k) -> - (match !d with - | DEF_type(TD_aux(TD_variant(id,name,typq,arms,false),tl)), false -> - d:= DEF_type(TD_aux(TD_variant(id,name,typq,arms@[to_type_union k def_ord tu],false),tl)),false; - (No_def,envs),partial_defs - | _,true -> typ_error l "Scattered type definition clause extends ended definition" (Some id) None None - | _ -> typ_error l - "Scattered type definition clause matches an existing scattered function definition header" - (Some id) None None)) - | SD_scattered_end(id) -> - (match (def_in_progress id partial_defs) with - | None -> typ_error l "Scattered definition end does not match any open scattered definitions" (Some id) None None - | Some(d,k) -> - (match !d with - | (DEF_type(_) as def),false -> - d:= (def,true); - (No_def,envs),partial_defs - | (DEF_fundef(_) as def),false -> - d:= (def,true); - ((Finished def), envs),partial_defs - | _, true -> - typ_error l "Scattered definition ended multiple times" (Some id) None None - | _ -> raise (Reporting_basic.err_unreachable l "Something in partial_defs other than fundef and type")))) - -let rec to_defs_helper envs partial_defs = function - | [] -> ([],envs,partial_defs) - | d::ds -> let ((d', envs), partial_defs) = to_def envs partial_defs d in - let (defs,envs,partial_defs) = to_defs_helper envs partial_defs ds in - (match d' with - | Finished def -> (def::defs,envs, partial_defs) - | No_def -> defs,envs,partial_defs - | Def_place_holder(id,l) -> - (match (def_in_progress id partial_defs) with - | None -> - raise - (Reporting_basic.err_unreachable l "Id stored in place holder not retrievable from partial defs") - | Some(d,k) -> - if (snd !d) - then (fst !d) :: defs, envs, partial_defs - else typ_error l "Scattered type definition never ended" (Some id) None None)) - -let to_checked_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : Ast.order) (Defs(defs)) = - let defs,(_,k_env,def_ord),partial_defs = to_defs_helper (default_names,kind_env,def_ord) [] defs in - List.iter - (fun (id,(d,k)) -> - (match !d with - | (d,false) -> typ_error Parse_ast.Unknown "Scattered definition never ended" (Some id) None None - | (_, true) -> ())) - partial_defs; - (Defs defs),k_env,def_ord diff --git a/src/lexer.mll b/src/lexer.mll index 7f11355f..45d8b3c2 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -76,10 +76,12 @@ let kw_table = ("else", (fun _ -> Else)); ("exit", (fun _ -> Exit)); ("extern", (fun _ -> Extern)); + ("cast", (fun _ -> Cast)); ("false", (fun _ -> False)); ("forall", (fun _ -> Forall)); ("foreach", (fun _ -> Foreach)); ("function", (fun x -> Function_)); + ("overload", (fun _ -> Overload)); ("if", (fun x -> If_)); ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); @@ -87,6 +89,7 @@ let kw_table = ("let", (fun x -> Let_)); ("member", (fun x -> Member)); ("Nat", (fun x -> Nat)); + ("Num", (fun x -> NatNum)); ("Order", (fun x -> Order)); ("pure", (fun x -> Pure)); ("rec", (fun x -> Rec)); @@ -94,6 +97,7 @@ let kw_table = ("return", (fun x -> Return)); ("scattered", (fun x -> Scattered)); ("sizeof", (fun x -> Sizeof)); + ("constraint", (fun x -> Constraint)); ("struct", (fun x -> Struct)); ("switch", (fun x -> Switch)); ("then", (fun x -> Then)); @@ -103,6 +107,7 @@ let kw_table = ("undefined", (fun x -> Undefined)); ("union", (fun x -> Union)); ("with", (fun x -> With)); + ("when", (fun x -> When)); ("val", (fun x -> Val)); ("div", (fun x -> Div_)); @@ -130,7 +135,7 @@ let kw_table = ] -let default_type_names = ["bool";"unit";"vector";"range";"list";"bit";"nat"; "int"; +let default_type_names = ["bool";"unit";"vector";"range";"list";"bit";"nat"; "int"; "real"; "uint8";"uint16";"uint32";"uint64";"atom";"implicit";"string";"option"] let custom_type_names : string list ref = ref [] @@ -306,16 +311,18 @@ rule token = parse | "*_ui" oper_char+ as i { (StarUnderUiI(r i)) } | "2^" oper_char+ as i { (TwoCarrotI(r i)) } - | digit+ as i { (Num(int_of_string i)) } - | "-" digit+ as i { (Num(int_of_string i)) } - | "0b" (binarydigit+ as i) { (Bin(i)) } - | "0x" (hexdigit+ as i) { (Hex(i)) } - | '"' { (String( - string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf)) } - | eof { Eof } - | _ as c { raise (LexError( - Printf.sprintf "Unexpected character: %c" c, - Lexing.lexeme_start_p lexbuf)) } + | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } + | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } + | digit+ as i { (Num(int_of_string i)) } + | "-" digit+ as i { (Num(int_of_string i)) } + | "0b" (binarydigit+ as i) { (Bin(i)) } + | "0x" (hexdigit+ as i) { (Hex(i)) } + | '"' { (String( + string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf)) } + | eof { Eof } + | _ as c { raise (LexError( + Printf.sprintf "Unexpected character: %c" c, + Lexing.lexeme_start_p lexbuf)) } and comment pos depth = parse diff --git a/src/monomorphise.ml b/src/monomorphise.ml new file mode 100644 index 00000000..7bfc3a3d --- /dev/null +++ b/src/monomorphise.ml @@ -0,0 +1,1045 @@ +open Parse_ast +open Ast +open Ast_util +open Type_check + +let disable_const_propagation = false +let size_set_limit = 8 +let vector_split_limit = 4 + +let optmap v f = + match v with + | None -> None + | Some v -> Some (f v) + +let env_typ_expected l : tannot -> Env.t * typ = function + | None -> raise (Reporting_basic.err_unreachable l "Missing type environment") + | Some (env,ty,_) -> env,ty + +module KSubst = Map.Make(Kid) +module ISubst = Map.Make(Id) +let ksubst_from_list = List.fold_left (fun s (v,i) -> KSubst.add v i s) KSubst.empty +let isubst_from_list = List.fold_left (fun s (v,i) -> ISubst.add v i s) ISubst.empty +(* union was introduced in 4.03.0, a bit too recently *) +let isubst_union s1 s2 = + ISubst.merge (fun _ x y -> match x,y with + | _, (Some x) -> Some x + | (Some x), _ -> Some x + | _, _ -> None) s1 s2 + +let subst_src_typ substs t = + let rec s_snexp (Nexp_aux (ne,l) as nexp) = + let re ne = Nexp_aux (ne,l) in + match ne with + | Nexp_var (Kid_aux (_,l) as kid) -> + (try KSubst.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)) + in + let rec s_styp ((Typ_aux (t,l)) as ty) = + let re t = Typ_aux (t,l) in + match t with + | Typ_wild + | Typ_id _ + | Typ_var _ + -> ty + | Typ_fn (t1,t2,e) -> re (Typ_fn (s_styp t1, s_styp t2,e)) + | Typ_tup ts -> re (Typ_tup (List.map s_styp ts)) + | Typ_app (id,tas) -> re (Typ_app (id,List.map s_starg tas)) + and s_starg (Typ_arg_aux (ta,l) as targ) = + match ta with + | Typ_arg_nexp ne -> Typ_arg_aux (Typ_arg_nexp (s_snexp ne),l) + | Typ_arg_typ t -> Typ_arg_aux (Typ_arg_typ (s_styp t),l) + | Typ_arg_order _ + | Typ_arg_effect _ -> targ + in s_styp t + +let make_vector_lit sz i = + let f j = if (i lsr (sz-j-1)) mod 2 = 0 then '0' else '1' in + let s = String.init sz f in + L_aux (L_bin s,Generated Unknown) + +let tabulate f n = + let rec aux acc n = + let acc' = f n::acc in + if n = 0 then acc' else aux acc' (n-1) + in if n = 0 then [] else aux [] (n-1) + +let make_vectors sz = + tabulate (make_vector_lit sz) (1 lsl sz) + + + + +(* Based on current type checker's behaviour *) +let pat_id_is_variable env id = + match Env.lookup_id id env with + | 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 _ + | Union _ + -> false + + +let rec is_value (E_aux (e,(l,annot))) = + match e with + | E_id id -> + (match annot with + | None -> + (Reporting_basic.print_err false true l "Monomorphisation" + ("Missing type information for identifier " ^ string_of_id id); + false) (* Be conservative if we have no info *) + | Some (env,_,_) -> + match Env.lookup_id id env with + | Enum _ | Union _ -> true + | Unbound | Local _ | Register _ -> false) + | E_lit _ -> true + | E_tuple es -> List.for_all is_value es +(* TODO: more? *) + | _ -> false + +let is_pure (Effect_opt_aux (e,_)) = + match e with + | Effect_opt_pure -> true + | Effect_opt_effect (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 + | (x,l)::t -> + let t' = cross t in + List.concat (List.map (fun y -> List.map (fun l' -> (x,y)::l') t') l) + +(* Given a type for a constructor, work out which refinements we ought to produce *) +(* TODO collision avoidance *) +let split_src_type id ty (TypQ_aux (q,ql)) = + let i = string_of_id id in + let rec size_nvars_nexp (Nexp_aux (ne,_)) = + match ne with + | Nexp_var v -> [v] + | Nexp_id _ + | Nexp_constant _ + -> [] + | Nexp_times (n1,n2) + | Nexp_sum (n1,n2) + | Nexp_minus (n1,n2) + -> size_nvars_nexp n1 @ size_nvars_nexp n2 + | Nexp_exp n + | Nexp_neg n + -> size_nvars_nexp n + in + let rec size_nvars_ty (Typ_aux (ty,l)) = + match ty with + | Typ_wild + | Typ_id _ + | Typ_var _ + -> [] + | Typ_fn _ -> + raise (Reporting_basic.err_general l ("Function type in constructor " ^ i)) + | Typ_tup ts -> List.concat (List.map size_nvars_ty ts) + | Typ_app (Id_aux (Id "vector",_), + [_;Typ_arg_aux (Typ_arg_nexp sz,_); + _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + size_nvars_nexp sz + | Typ_app (_, tas) -> + [] (* We only support sizes for bitvectors mentioned explicitly, not any buried + inside another type *) + in + let nvars = List.sort_uniq Kid.compare (size_nvars_ty ty) in + match nvars with + | [] -> None + | sample::__ -> + (* Only check for constraints if we found a size to constrain *) + let qs = + match q with + | TypQ_no_forall -> + raise (Reporting_basic.err_general ql + ("No set constraint for variable " ^ string_of_kid sample ^ " in constructor " ^ i)) + | TypQ_tq qs -> qs + in + let find_set (Kid_aux (Var nvar,_) as kid) = + match list_extract (function + | QI_aux (QI_const (NC_aux (NC_nat_set_bounded (Kid_aux (Var nvar',_),vals),_)),_) + -> if nvar = nvar' then Some vals else None + | _ -> None) qs with + | None -> + raise (Reporting_basic.err_general ql + ("No set constraint for variable " ^ nvar ^ " in constructor " ^ i)) + | Some vals -> (kid,vals) + in + let nvar_sets = List.map find_set nvars in + let total_variants = List.fold_left ( * ) 1 (List.map (fun (_,l) -> List.length l) nvar_sets) in + let () = if total_variants > size_set_limit then + raise (Reporting_basic.err_general ql + (string_of_int total_variants ^ "variants for constructor " ^ i ^ + "bigger than limit " ^ string_of_int size_set_limit)) else () + in + let variants = cross nvar_sets in + let wrap = match id with + | Id_aux (Id i,l) -> (fun f -> Id_aux (Id (f i),Generated l)) + | Id_aux (DeIid i,l) -> (fun f -> Id_aux (DeIid (f i),l)) + in + let name l i = String.concat "_" (i::(List.map (fun (v,i) -> string_of_kid v ^ string_of_int i) l)) in + Some (List.map (fun l -> (l, wrap (name l))) variants) + +(* TODO: maybe fold this into subst_src_typ? *) +let inst_src_type insts ty = + let insts = List.map (fun (v,i) -> (v,Nexp_aux (Nexp_constant i,Generated Unknown))) insts in + let subst = ksubst_from_list insts in + subst_src_typ subst ty + +let reduce_nexp subst ne = + let rec eval (Nexp_aux (ne,_) as nexp) = + match ne with + | Nexp_constant i -> i + | Nexp_sum (n1,n2) -> (eval n1) + (eval n2) + | Nexp_minus (n1,n2) -> (eval n1) - (eval n2) + | Nexp_times (n1,n2) -> (eval n1) * (eval n2) + | Nexp_exp n -> 1 lsl (eval n) + | Nexp_neg n -> - (eval n) + | _ -> + raise (Reporting_basic.err_general Unknown ("Couldn't turn nexp " ^ + string_of_nexp nexp ^ " into concrete value")) + in eval ne + +(* Check to see if we need to monomorphise a use of a constructor. Currently + assumes that bitvector sizes are always given as a variable; don't yet handle + more general cases (e.g., 8 * var) *) + +(* TODO: use type checker's instantiation instead *) +let refine_constructor refinements id substs (E_aux (_,(l,_)) as arg) t = + let rec derive_vars (Typ_aux (t,_)) (E_aux (e,(l,tannot))) = + match t with + | Typ_app (Id_aux (Id "vector",_), [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var v,_)),_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + (match tannot with + | Some (_,Typ_aux (Typ_app (Id_aux (Id "vector",_), [_;Typ_arg_aux (Typ_arg_nexp ne,_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]),_),_) -> + [(v,reduce_nexp substs ne)] + | _ -> []) + | Typ_wild + | Typ_var _ + | Typ_id _ + | Typ_fn _ + | Typ_app _ + -> [] + | Typ_tup ts -> + match e with + | E_tuple es -> List.concat (List.map2 derive_vars ts es) + | _ -> [] (* TODO? *) + in + try + let (_,irefinements) = List.find (fun (id',_) -> Id.compare id id' = 0) refinements in + let vars = List.sort_uniq (fun x y -> Kid.compare (fst x) (fst y)) (derive_vars t arg) in + try + Some (List.assoc vars irefinements) + with Not_found -> + (Reporting_basic.print_err false true l "Monomorphisation" + ("Failed to find a monomorphic constructor for " ^ string_of_id id ^ " instance " ^ + match vars with [] -> "<empty>" + | _ -> String.concat "," (List.map (fun (x,y) -> string_of_kid x ^ "=" ^ string_of_int y) vars)); None) + with Not_found -> None + + +(* Substitute found nexps for variables in an expression, and rename constructors to reflect + specialisation *) + +let nexp_subst_fns substs refinements = +(* + let s_t t = typ_subst substs true 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 = function + | Base ((params,t),tag,ranges,effl,effc,bounds) -> + (* TODO: do other fields need mapped? *) + Base ((params,s_t t),tag,ranges,effl,effc,bounds) + | tannot -> tannot + 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_as (p',id) -> re (P_as (s_pat p', id)) + | P_typ (ty,p') -> re (P_typ (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_indexed ips -> re (P_vector_indexed (List.map (fun (i,p) -> (i,s_pat p)) ips)) + | P_vector_concat ps -> re (P_vector_concat (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)) + 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_lit _ + | E_comment _ -> re e + | E_sizeof ne -> re (E_sizeof ne) (* TODO: does this need done? does it appear in type checked code? *) + | E_internal_exp (l,annot) -> re (E_internal_exp (l, (*s_tannot*) annot)) + | E_sizeof_internal (l,annot) -> re (E_sizeof_internal (l, (*s_tannot*) annot)) + | E_internal_exp_user ((l1,annot1),(l2,annot2)) -> + re (E_internal_exp_user ((l1, (*s_tannot*) annot1),(l2, (*s_tannot*) annot2))) + | E_cast (t,e') -> re (E_cast (t, s_exp e')) + | E_app (id,es) -> + let es' = List.map s_exp es in + let arg = + match es' with + | [] -> E_aux (E_lit (L_aux (L_unit,Unknown)),(l,None)) + | [e] -> e + | _ -> E_aux (E_tuple es',(l,None)) + in + let id' = + match Env.lookup_id id (fst (env_typ_expected l annot)) with + | Union (qs,Typ_aux (Typ_fn(inty,outty,_),_)) -> + (match refine_constructor refinements id substs arg inty with + | None -> id + | Some id' -> id') + | _ -> id + in re (E_app (id',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_vector es -> re (E_vector (List.map s_exp es)) + | E_vector_indexed (ies,ed) -> re (E_vector_indexed (List.map (fun (i,e) -> (i,s_exp e)) ies, + s_opt_default ed)) + | 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 (s_fexps fes)) + | E_record_update (e,fes) -> re (E_record_update (s_exp e, s_fexps 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_internal_cast ((l,ann),e) -> re (E_internal_cast ((l,(*s_tannot*) ann),s_exp e)) + | E_comment_struc e -> re (E_comment_struc e) + | E_internal_let (le,e1,e2) -> re (E_internal_let (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)) + and s_opt_default (Def_val_aux (ed,(l,annot))) = + match ed with + | Def_val_empty -> Def_val_aux (Def_val_empty,(l,(*s_tannot*) annot)) + | Def_val_dec e -> Def_val_aux (Def_val_dec (s_exp e),(l,(*s_tannot*) annot)) + and s_fexps (FES_aux (FES_Fexps (fes,flag), (l,annot))) = + FES_aux (FES_Fexps (List.map s_fexp fes, flag), (l,(*s_tannot*) annot)) + 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_explicit (tysch,p,e) -> + LB_aux (LB_val_explicit ((*s_typschm*) tysch,(*s_pat*) p,s_exp e), (l,(*s_tannot*) annot)) + | LB_val_implicit (p,e) -> LB_aux (LB_val_implicit ((*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 _ + | LEXP_cast _ + -> re e + | 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_field (le,id) -> re (LEXP_field (s_lexp le, id)) + in ((fun x -> x (*s_pat*)),s_exp) +let nexp_subst_pat substs refinements = fst (nexp_subst_fns substs refinements) +let nexp_subst_exp substs refinements = snd (nexp_subst_fns substs refinements) + +let bindings_from_pat p = + let rec aux_pat (P_aux (p,(l,annot))) = + let env,_ = env_typ_expected l annot in + match p with + | P_lit _ + | P_wild + -> [] + | 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_vector ps + | P_vector_concat 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_vector_indexed ips -> List.concat (List.map (fun (_,p) -> aux_pat p) ips) + and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p + in aux_pat p + +let remove_bound env pat = + let bound = bindings_from_pat pat in + List.fold_left (fun sub v -> ISubst.remove v env) env bound + + +(* 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 + | l1,l2 -> l1 = l2 + +type 'a matchresult = + | DoesMatch of 'a + | DoesNotMatch + | GiveUp + +let can_match (E_aux (e,(l,annot)) as exp0) cases = + let (env,_) = env_typ_expected l annot in + let rec findpat_generic check_pat description = function + | [] -> (Reporting_basic.print_err false true 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 ((Pat_aux (Pat_exp (p,exp),ann))::tl) + | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tl + when pat_id_is_variable env id' -> + Some (exp, [(id', exp0)]) + | (Pat_aux (Pat_when _,_))::_ -> None + | (Pat_aux (Pat_exp (p,exp),_))::tl -> + match check_pat p with + | DoesNotMatch -> findpat_generic check_pat description tl + | DoesMatch subst -> Some (exp,subst) + | 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_basic.print_err false true l' "Monomorphisation" + "Unexpected kind of pattern for enumeration"; GiveUp) + in findpat_generic checkpat (string_of_id id) cases + | _ -> None) + | E_lit (L_aux (lit_e, _)) -> + let checkpat = function + | P_aux (P_lit (L_aux (lit_p, _)),_) -> + if lit_match (lit_e,lit_p) then DoesMatch [] else DoesNotMatch + | P_aux (_,(l',_)) -> + (Reporting_basic.print_err false true l' "Monomorphisation" + "Unexpected kind of pattern for bit"; GiveUp) + in findpat_generic checkpat "bit" cases + | _ -> None + + +(* Similarly, simple conditionals *) +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_undef, _ | _, L_undef -> None + | _ -> Some (l1 = l2) + + +let try_app_infix (l,ann) (E_aux (e1,ann1)) (Id_aux (id,_)) (E_aux (e2,ann2)) = + let i = match id with Id x -> x | DeIid x -> x in + let new_l = Generated l in + match e1, i, e2 with + | E_lit l1, ("=="|"!="), E_lit l2 -> + let lit b = if b then L_true else L_false in + let lit b = lit (if i = "==" then b else not b) in + (match lit_eq l1 l2 with + | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)), (l,ann))) + | None -> None) + | _ -> None + + +(* We may need to split up a pattern match if (1) we've been told to case split + on a variable by the user, or (2) we monomorphised a constructor that's used + in the pattern. *) +type split = + | NoSplit + | VarSplit of (tannot pat * (id * tannot Ast.exp)) list + | ConstrSplit of (tannot pat * nexp KSubst.t) list + +let split_defs splits defs = + let split_constructors (Defs defs) = + let sc_type_union q (Tu_aux (tu,l) as tua) = + match tu with + | Tu_id id -> [],[tua] + | Tu_ty_id (ty,id) -> + (match split_src_type id ty q with + | None -> ([],[Tu_aux (Tu_ty_id (ty,id),l)]) + | Some variants -> + ([(id,variants)], + List.map (fun (insts, id') -> Tu_aux (Tu_ty_id (inst_src_type insts ty,id'),Generated l)) variants)) + in + let sc_type_def ((TD_aux (tda,annot)) as td) = + match tda with + | TD_variant (id,nscm,quant,tus,flag) -> + let (refinements, tus') = List.split (List.map (sc_type_union quant) tus) in + (List.concat refinements, TD_aux (TD_variant (id,nscm,quant,List.concat tus',flag),annot)) + | _ -> ([],td) + in + let sc_def d = + match d with + | DEF_type td -> let (refinements,td') = sc_type_def td in (refinements, DEF_type td') + | _ -> ([], d) + in + let (refinements, defs') = List.split (List.map sc_def defs) + in (List.concat refinements, Defs defs') + in + + let (refinements, defs') = split_constructors defs in + + (* Extract nvar substitution by comparing two types *) + let build_nexp_subst l t1 t2 = [] (* + let rec from_types t1 t2 = + let t1 = match t1.t with Tabbrev(_,t) -> t | _ -> t1 in + let t2 = match t2.t with Tabbrev(_,t) -> t | _ -> t2 in + if t1 = t2 then [] else + match t1.t,t2.t with + | Tapp (s1,args1), Tapp (s2,args2) -> + if s1 = s2 then + List.concat (List.map2 from_args args1 args2) + else (Reporting_basic.print_err false true l "Monomorphisation" + "Unexpected type mismatch"; []) + | Ttup ts1, Ttup ts2 -> + if List.length ts1 = List.length ts2 then + List.concat (List.map2 from_types ts1 ts2) + else (Reporting_basic.print_err false true l "Monomorphisation" + "Unexpected type mismatch"; []) + | _ -> [] + and from_args arg1 arg2 = + match arg1,arg2 with + | TA_typ t1, TA_typ t2 -> from_types t1 t2 + | TA_nexp n1, TA_nexp n2 -> from_nexps n1 n2 + | _ -> [] + and from_nexps n1 n2 = + match n1.nexp, n2.nexp with + | Nvar s, Nvar s' when s = s' -> [] + | Nvar s, _ -> [(s,n2)] + | Nadd (n3,n4), Nadd (n5,n6) + | Nsub (n3,n4), Nsub (n5,n6) + | Nmult (n3,n4), Nmult (n5,n6) + -> from_nexps n3 n5 @ from_nexps n4 n6 + | N2n (n3,p1), N2n (n4,p2) when p1 = p2 -> from_nexps n3 n4 + | Npow (n3,p1), Npow (n4,p2) when p1 = p2 -> from_nexps n3 n4 + | Nneg n3, Nneg n4 -> from_nexps n3 n4 + | _ -> [] + in match t1,t2 with + | Base ((_,t1),_,_,_,_,_),Base ((_,t2),_,_,_,_,_) -> from_types t1 t2 + | _ -> []*) + in + + let nexp_substs = ref [] in + + (* Constant propogation *) + let rec const_prop_exp substs ((E_aux (e,(l,annot))) as exp) = + let re e = E_aux (e,(l,annot)) in + match e with + (* TODO: are there more circumstances in which we should get rid of these? *) + | E_block [e] -> const_prop_exp substs e + | E_block es -> re (E_block (List.map (const_prop_exp substs) es)) + | E_nondet es -> re (E_nondet (List.map (const_prop_exp substs) es)) + + | E_id id -> + (try ISubst.find id substs + with Not_found -> exp) + | E_lit _ + | E_sizeof _ + | E_internal_exp _ + | E_sizeof_internal _ + | E_internal_exp_user _ + | E_comment _ + -> exp + | E_cast (t,e') -> re (E_cast (t, const_prop_exp substs e')) + | E_app (id,es) -> + let es' = List.map (const_prop_exp substs) es in + (match const_prop_try_fn (id,es') with + | None -> re (E_app (id,es')) + | Some r -> r) + | E_app_infix (e1,id,e2) -> + let e1',e2' = const_prop_exp substs e1,const_prop_exp substs e2 in + (match try_app_infix (l,annot) e1' id e2' with + | Some exp -> exp + | None -> re (E_app_infix (e1',id,e2'))) + | E_tuple es -> re (E_tuple (List.map (const_prop_exp substs) es)) + | E_if (e1,e2,e3) -> + let e1' = const_prop_exp substs e1 in + let e2',e3' = const_prop_exp substs e2, const_prop_exp substs e3 in + (match e1' with + | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) -> + let e' = match lit with L_true -> e2' | _ -> e3' in + (match e' with E_aux (_,(_,annot')) -> + nexp_substs := build_nexp_subst l annot annot' @ !nexp_substs; + e') + | _ -> re (E_if (e1',e2',e3'))) + | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,const_prop_exp substs e1,const_prop_exp substs e2,const_prop_exp substs e3,ord,const_prop_exp (ISubst.remove id substs) e4)) + | E_vector es -> re (E_vector (List.map (const_prop_exp substs) es)) + | E_vector_indexed (ies,ed) -> re (E_vector_indexed (List.map (fun (i,e) -> (i,const_prop_exp substs e)) ies, + const_prop_opt_default substs ed)) + | E_vector_access (e1,e2) -> re (E_vector_access (const_prop_exp substs e1,const_prop_exp substs e2)) + | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (const_prop_exp substs e1,const_prop_exp substs e2,const_prop_exp substs e3)) + | E_vector_update (e1,e2,e3) -> re (E_vector_update (const_prop_exp substs e1,const_prop_exp substs e2,const_prop_exp substs e3)) + | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (const_prop_exp substs e1,const_prop_exp substs e2,const_prop_exp substs e3,const_prop_exp substs e4)) + | E_vector_append (e1,e2) -> re (E_vector_append (const_prop_exp substs e1,const_prop_exp substs e2)) + | E_list es -> re (E_list (List.map (const_prop_exp substs) es)) + | E_cons (e1,e2) -> re (E_cons (const_prop_exp substs e1,const_prop_exp substs e2)) + | E_record fes -> re (E_record (const_prop_fexps substs fes)) + | E_record_update (e,fes) -> re (E_record_update (const_prop_exp substs e, const_prop_fexps substs fes)) + | E_field (e,id) -> re (E_field (const_prop_exp substs e,id)) + | E_case (e,cases) -> + let e' = const_prop_exp substs e in + (match can_match e' cases with + | None -> re (E_case (e', List.map (const_prop_pexp substs) cases)) + | Some (E_aux (_,(_,annot')) as exp,newbindings) -> + let newbindings_env = isubst_from_list newbindings in + let substs' = isubst_union substs newbindings_env in + nexp_substs := build_nexp_subst l annot annot' @ !nexp_substs; + const_prop_exp substs' exp) + | E_let (lb,e) -> + let (lb',substs') = const_prop_letbind substs lb in + re (E_let (lb', const_prop_exp substs' e)) + | E_assign (le,e) -> re (E_assign (const_prop_lexp substs le, const_prop_exp substs e)) + | E_exit e -> re (E_exit (const_prop_exp substs e)) + | E_return e -> re (E_return (const_prop_exp substs e)) + | E_assert (e1,e2) -> re (E_assert (const_prop_exp substs e1,const_prop_exp substs e2)) + | E_internal_cast (ann,e) -> re (E_internal_cast (ann,const_prop_exp substs e)) + | E_comment_struc e -> re (E_comment_struc e) + | E_internal_let _ + | E_internal_plet _ + | E_internal_return _ + -> raise (Reporting_basic.err_unreachable l + "Unexpected internal expression encountered in monomorphisation") + and const_prop_opt_default substs ((Def_val_aux (ed,annot)) as eda) = + match ed with + | Def_val_empty -> eda + | Def_val_dec e -> Def_val_aux (Def_val_dec (const_prop_exp substs e),annot) + and const_prop_fexps substs (FES_aux (FES_Fexps (fes,flag), annot)) = + FES_aux (FES_Fexps (List.map (const_prop_fexp substs) fes, flag), annot) + and const_prop_fexp substs (FE_aux (FE_Fexp (id,e), annot)) = + FE_aux (FE_Fexp (id,const_prop_exp substs e),annot) + and const_prop_pexp substs = function + | (Pat_aux (Pat_exp (p,e),l)) -> + Pat_aux (Pat_exp (p,const_prop_exp (remove_bound substs p) e),l) + | (Pat_aux (Pat_when (p,e1,e2),l)) -> + let substs' = remove_bound substs p in + Pat_aux (Pat_when (p, const_prop_exp substs' e1, const_prop_exp substs' e2),l) + and const_prop_letbind substs (LB_aux (lb,annot)) = + match lb with + | LB_val_explicit (tysch,p,e) -> + (LB_aux (LB_val_explicit (tysch,p,const_prop_exp substs e), annot), + remove_bound substs p) + | LB_val_implicit (p,e) -> + (LB_aux (LB_val_implicit (p,const_prop_exp substs e), annot), + remove_bound substs p) + and const_prop_lexp substs ((LEXP_aux (e,annot)) as le) = + let re e = LEXP_aux (e,annot) in + match e with + | LEXP_id _ (* shouldn't end up substituting here *) + | LEXP_cast _ + -> le + | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map (const_prop_exp substs) es)) (* or here *) + | LEXP_tup les -> re (LEXP_tup (List.map (const_prop_lexp substs) les)) + | LEXP_vector (le,e) -> re (LEXP_vector (const_prop_lexp substs le, const_prop_exp substs e)) + | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (const_prop_lexp substs le, const_prop_exp substs e1, const_prop_exp substs e2)) + | LEXP_field (le,id) -> re (LEXP_field (const_prop_lexp substs le, id)) + (* 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 (id,args) = + if not (List.for_all is_value args) then + None + else + let Defs ds = defs in + match 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 (eff,fcls) else None + | _ -> None) ds with + | None -> None + | Some (eff,_) when not (is_pure eff) -> None + | Some (_,fcls) -> + let arg = match args with + | [] -> E_aux (E_lit (L_aux (L_unit,Unknown)),(Unknown,None)) + | [e] -> e + | _ -> E_aux (E_tuple args,(Unknown,None)) in + let cases = List.map (function + | FCL_aux (FCL_Funcl (_,pat,exp), ann) -> Pat_aux (Pat_exp (pat,exp),ann)) + fcls in + match can_match arg cases with + | Some (exp,bindings) -> + let substs = isubst_from_list bindings in + let result = const_prop_exp substs exp in + if is_value result then Some result else None + | None -> None + in + + let subst_exp subst exp = + if disable_const_propagation then + let (subi,(E_aux (_,subannot) as sube)) = subst in + let E_aux (e,(l,annot)) = exp in + let lg = Generated l in + let id = match subi with Id_aux (i,l) -> Id_aux (i,lg) in + let p = P_aux (P_id id, subannot) in + E_aux (E_let (LB_aux (LB_val_implicit (p,sube),(lg,annot)), exp),(lg,annot)) + else + let substs = isubst_from_list [subst] in + let () = nexp_substs := [] in + let exp' = const_prop_exp substs exp in + (* Substitute what we've learned about nvars into the term *) + let nsubsts = isubst_from_list !nexp_substs in + let () = nexp_substs := [] in + nexp_subst_exp nsubsts refinements exp' + in + + (* Split a variable pattern into every possible value *) + + let split var l annot = + let v = string_of_id var in + let env, typ = env_typ_expected l annot in + let typ = Env.expand_synonyms env typ in + let Typ_aux (ty,l) = typ in + let new_l = Generated l in + let renew_id (Id_aux (id,l)) = Id_aux (id,new_l) in + let cannot () = + raise (Reporting_basic.err_general l + ("Cannot split type " ^ string_of_typ typ ^ " for variable " ^ v)) + in + match ty with + | Typ_id id -> + (try + (* enumerations *) + let ns = Env.get_enum id env in + List.map (fun n -> (P_aux (P_id (renew_id n),(l,annot)), + (var,E_aux (E_id (renew_id n),(new_l,annot))))) ns + with Type_error _ -> + match id with + | Id_aux (Id "bit",_) -> + List.map (fun b -> + P_aux (P_lit (L_aux (b,new_l)),(l,annot)), + (var,E_aux (E_lit (L_aux (b,new_l)),(new_l, annot)))) + [L_zero; L_one] + | _ -> cannot ()) + | Typ_app (Id_aux (Id "vector",_), [_;Typ_arg_aux (Typ_arg_nexp len,_);_;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + (match len with + | Nexp_aux (Nexp_constant sz,_) -> + if sz <= vector_split_limit then + let lits = make_vectors sz in + List.map (fun lit -> + P_aux (P_lit lit,(l,annot)), + (var,E_aux (E_lit lit,(new_l,annot)))) lits + else + raise (Reporting_basic.err_general l + ("Refusing to split vector type of length " ^ string_of_int sz ^ + " above limit " ^ string_of_int vector_split_limit ^ + " for variable " ^ v)) + | _ -> + cannot () + ) + (*| set constrained numbers TODO *) + | _ -> cannot () + in + + + (* Split variable patterns at the given locations *) + + let map_locs ls (Defs defs) = + let rec match_l = function + | Unknown + | Int _ -> [] + | Generated l -> [] (* Could do match_l l, but only want to split user-written patterns *) + | Range (p,q) -> + List.filter (fun ((filename,line),_) -> + Filename.basename p.Lexing.pos_fname = filename && + p.Lexing.pos_lnum <= line && line <= q.Lexing.pos_lnum) ls + in + + let split_pat var p = + let id_matches = function + | Id_aux (Id x,_) -> x = var + | Id_aux (DeIid x,_) -> x = var + in + + let rec list f = function + | [] -> None + | h::t -> + match f h with + | None -> (match list f t with None -> None | Some (l,ps,r) -> Some (h::l,ps,r)) + | Some ps -> Some ([],ps,t) + in + let rec spl (P_aux (p,(l,annot))) = + let relist f ctx ps = + optmap (list f ps) + (fun (left,ps,right) -> + List.map (fun (p,sub) -> P_aux (ctx (left@p::right),(l,annot)),sub) ps) + in + let re f p = + optmap (spl p) + (fun ps -> List.map (fun (p,sub) -> (P_aux (f p,(l,annot)), sub)) ps) + in + let fpat (FP_aux ((FP_Fpat (id,p),annot))) = + optmap (spl p) + (fun ps -> List.map (fun (p,sub) -> FP_aux (FP_Fpat (id,p), annot), sub) ps) + in + let ipat (i,p) = optmap (spl p) (List.map (fun (p,sub) -> (i,p),sub)) + in + match p with + | P_lit _ + | P_wild + -> None + | P_as (p',id) when id_matches id -> + raise (Reporting_basic.err_general l + ("Cannot split " ^ var ^ " on 'as' pattern")) + | P_as (p',id) -> + re (fun p -> P_as (p,id)) p' + | P_typ (t,p') -> re (fun p -> P_typ (t,p)) p' + | P_id id when id_matches id -> + Some (split id l annot) + | P_id _ -> + None + | P_app (id,ps) -> + relist spl (fun ps -> P_app (id,ps)) ps + | P_record (fps,flag) -> + relist fpat (fun fps -> P_record (fps,flag)) fps + | P_vector ps -> + relist spl (fun ps -> P_vector ps) ps + | P_vector_indexed ips -> + relist ipat (fun ips -> P_vector_indexed ips) ips + | P_vector_concat ps -> + relist spl (fun ps -> P_vector_concat ps) ps + | P_tup ps -> + relist spl (fun ps -> P_tup ps) ps + | P_list ps -> + relist spl (fun ps -> P_list ps) ps + in spl p + in + + let map_pat_by_loc (P_aux (p,(l,_)) as pat) = + match match_l l with + | [] -> None + | [(_,var)] -> split_pat var pat + | lvs -> raise (Reporting_basic.err_general l + ("Multiple variables to split on: " ^ String.concat ", " (List.map snd lvs))) + in + let map_pat (P_aux (p,(l,tannot)) as pat) = + match map_pat_by_loc pat with + | Some l -> VarSplit l + | None -> + match p with + | P_app (id,args) -> + (try + let (_,variants) = List.find (fun (id',_) -> Id.compare id id' = 0) refinements in + let env,_ = env_typ_expected l tannot in + let constr_out_typ = + match Env.lookup_id id env with + | Union (qs,Typ_aux (Typ_fn(_,outt,_),_)) -> outt + | _ -> raise (Reporting_basic.err_general l + ("Constructor " ^ string_of_id id ^ " is not a construtor!")) + in + let varmap = build_nexp_subst l constr_out_typ tannot in + let map_inst (insts,id') = + let insts = List.map (fun (v,i) -> + ((match List.assoc (string_of_kid v) varmap with + | Nexp_aux (Nexp_var s, _) -> s + | _ -> raise (Reporting_basic.err_general l + ("Constructor parameter not a variable: " ^ string_of_kid v))), + Nexp_aux (Nexp_constant i,Generated l))) + insts in + P_aux (P_app (id',args),(Generated l,tannot)), + ksubst_from_list insts + in + ConstrSplit (List.map map_inst variants) + with Not_found -> NoSplit) + | _ -> NoSplit + in + + let check_single_pat (P_aux (_,(l,annot)) as p) = + match match_l l with + | [] -> p + | lvs -> + let pvs = 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 () = + if overlap then + Reporting_basic.print_err false true l "Monomorphisation" + "Splitting a singleton pattern is not possible" + in p + in + + let rec map_exp ((E_aux (e,annot)) as ea) = + let re e = E_aux (e,annot) in + match e with + | E_block es -> re (E_block (List.map map_exp es)) + | E_nondet es -> re (E_nondet (List.map map_exp es)) + | E_id _ + | E_lit _ + | E_sizeof _ + | E_internal_exp _ + | E_sizeof_internal _ + | E_internal_exp_user _ + | E_comment _ + -> ea + | E_cast (t,e') -> re (E_cast (t, map_exp e')) + | E_app (id,es) -> re (E_app (id,List.map map_exp es)) + | E_app_infix (e1,id,e2) -> re (E_app_infix (map_exp e1,id,map_exp e2)) + | E_tuple es -> re (E_tuple (List.map map_exp es)) + | E_if (e1,e2,e3) -> re (E_if (map_exp e1, map_exp e2, map_exp e3)) + | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,map_exp e1,map_exp e2,map_exp e3,ord,map_exp e4)) + | E_vector es -> re (E_vector (List.map map_exp es)) + | E_vector_indexed (ies,ed) -> re (E_vector_indexed (List.map (fun (i,e) -> (i,map_exp e)) ies, + map_opt_default ed)) + | E_vector_access (e1,e2) -> re (E_vector_access (map_exp e1,map_exp e2)) + | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (map_exp e1,map_exp e2,map_exp e3)) + | E_vector_update (e1,e2,e3) -> re (E_vector_update (map_exp e1,map_exp e2,map_exp e3)) + | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (map_exp e1,map_exp e2,map_exp e3,map_exp e4)) + | E_vector_append (e1,e2) -> re (E_vector_append (map_exp e1,map_exp e2)) + | E_list es -> re (E_list (List.map map_exp es)) + | E_cons (e1,e2) -> re (E_cons (map_exp e1,map_exp e2)) + | E_record fes -> re (E_record (map_fexps fes)) + | E_record_update (e,fes) -> re (E_record_update (map_exp e, map_fexps fes)) + | E_field (e,id) -> re (E_field (map_exp e,id)) + | E_case (e,cases) -> re (E_case (map_exp e, List.concat (List.map map_pexp cases))) + | E_let (lb,e) -> re (E_let (map_letbind lb, map_exp e)) + | E_assign (le,e) -> re (E_assign (map_lexp le, map_exp e)) + | E_exit e -> re (E_exit (map_exp e)) + | E_return e -> re (E_return (map_exp e)) + | E_assert (e1,e2) -> re (E_assert (map_exp e1,map_exp e2)) + | E_internal_cast (ann,e) -> re (E_internal_cast (ann,map_exp e)) + | E_comment_struc e -> re (E_comment_struc e) + | E_internal_let (le,e1,e2) -> re (E_internal_let (map_lexp le, map_exp e1, map_exp e2)) + | E_internal_plet (p,e1,e2) -> re (E_internal_plet (check_single_pat p, map_exp e1, map_exp e2)) + | E_internal_return e -> re (E_internal_return (map_exp e)) + and map_opt_default ((Def_val_aux (ed,annot)) as eda) = + match ed with + | Def_val_empty -> eda + | Def_val_dec e -> Def_val_aux (Def_val_dec (map_exp e),annot) + and map_fexps (FES_aux (FES_Fexps (fes,flag), annot)) = + FES_aux (FES_Fexps (List.map map_fexp fes, flag), annot) + and map_fexp (FE_aux (FE_Fexp (id,e), annot)) = + FE_aux (FE_Fexp (id,map_exp e),annot) + and map_pexp = function + | Pat_aux (Pat_exp (p,e),l) -> + (match map_pat p with + | NoSplit -> [Pat_aux (Pat_exp (p,map_exp e),l)] + | VarSplit patsubsts -> + List.map (fun (pat',subst) -> + let exp' = subst_exp subst e in + Pat_aux (Pat_exp (pat', map_exp exp'),l)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + (* Leave refinements to later *) + let pat' = nexp_subst_pat nsubst [] pat' in + let exp' = nexp_subst_exp nsubst [] e in + Pat_aux (Pat_exp (pat', map_exp exp'),l) + ) patnsubsts) + | Pat_aux (Pat_when (p,e1,e2),l) -> + (match map_pat p with + | NoSplit -> [Pat_aux (Pat_when (p,map_exp e1,map_exp e2),l)] + | VarSplit patsubsts -> + List.map (fun (pat',subst) -> + let exp1' = subst_exp subst e1 in + let exp2' = subst_exp subst e2 in + Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + (* Leave refinements to later *) + let pat' = nexp_subst_pat nsubst [] pat' in + let exp1' = nexp_subst_exp nsubst [] e1 in + let exp2' = 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)) = + match lb with + | LB_val_explicit (tysch,p,e) -> LB_aux (LB_val_explicit (tysch,check_single_pat p,map_exp e), annot) + | LB_val_implicit (p,e) -> LB_aux (LB_val_implicit (check_single_pat p,map_exp e), annot) + and map_lexp ((LEXP_aux (e,annot)) as le) = + let re e = LEXP_aux (e,annot) in + match e with + | LEXP_id _ + | LEXP_cast _ + -> le + | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map map_exp es)) + | LEXP_tup les -> re (LEXP_tup (List.map map_lexp les)) + | LEXP_vector (le,e) -> re (LEXP_vector (map_lexp le, map_exp e)) + | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (map_lexp le, map_exp e1, map_exp e2)) + | LEXP_field (le,id) -> re (LEXP_field (map_lexp le, id)) + in + + let map_funcl (FCL_aux (FCL_Funcl (id,pat,exp),annot)) = + match map_pat pat with + | NoSplit -> [FCL_aux (FCL_Funcl (id, pat, map_exp exp), annot)] + | VarSplit patsubsts -> + List.map (fun (pat',subst) -> + let exp' = subst_exp subst exp in + FCL_aux (FCL_Funcl (id, pat', map_exp exp'), annot)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + (* Leave refinements to later *) + let pat' = nexp_subst_pat nsubst [] pat' in + let exp' = nexp_subst_exp nsubst [] exp in + FCL_aux (FCL_Funcl (id, pat', map_exp exp'), annot) + ) patnsubsts + in + + let map_fundef (FD_aux (FD_function (r,t,e,fcls),annot)) = + FD_aux (FD_function (r,t,e,List.concat (List.map map_funcl fcls)),annot) + in + let map_scattered_def sd = + match sd with + | SD_aux (SD_scattered_funcl fcl, annot) -> + List.map (fun fcl' -> SD_aux (SD_scattered_funcl fcl', annot)) (map_funcl fcl) + | _ -> [sd] + in + let map_def d = + match d with + | DEF_kind _ + | DEF_type _ + | DEF_spec _ + | DEF_default _ + | DEF_reg_dec _ + | DEF_comm _ + | DEF_overload _ + -> [d] + | DEF_fundef fd -> [DEF_fundef (map_fundef fd)] + | DEF_val lb -> [DEF_val (map_letbind lb)] + | DEF_scattered sd -> List.map (fun x -> DEF_scattered x) (map_scattered_def sd) + + in + Defs (List.concat (List.map map_def defs)) + in + map_locs splits defs' + diff --git a/src/parse_ast.ml b/src/parse_ast.ml index e069462a..526dffa8 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -160,20 +160,20 @@ n_constraint_aux = (* constraint over kind $_$ *) NC_fixed of atyp * atyp | NC_bounded_ge of atyp * atyp | NC_bounded_le of atyp * atyp + | NC_not_equal of atyp * atyp | NC_nat_set_bounded of kid * (int) list + | NC_or of n_constraint * n_constraint + | NC_and of n_constraint * n_constraint +and +n_constraint = + NC_aux of n_constraint_aux * l type kinded_id = KOpt_aux of kinded_id_aux * l - -type -n_constraint = - NC_aux of n_constraint_aux * l - - -type +type quant_item_aux = (* Either a kinded identifier or a nexp constraint for a typquant *) QI_id of kinded_id (* An optionally kinded identifier *) | QI_const of n_constraint (* A constraint for this type *) @@ -207,7 +207,7 @@ lit_aux = (* Literal constant *) | L_bin of string (* bit vector constant, C-style *) | L_undef (* undefined value *) | L_string of string (* string constant *) - + | L_real of string type typschm_aux = (* type scheme *) @@ -238,6 +238,7 @@ pat_aux = (* Pattern *) | P_vector_concat of (pat) list (* concatenated vector pattern *) | P_tup of (pat) list (* tuple pattern *) | P_list of (pat) list (* list pattern *) + | P_cons of pat * pat (* cons pattern *) and pat = P_aux of pat_aux * l @@ -277,6 +278,7 @@ exp_aux = (* Expression *) | E_let of letbind * exp (* let expression *) | E_assign of exp * exp (* imperative assignment *) | E_sizeof of atyp + | E_constraint of n_constraint | E_exit of exp | E_return of exp | E_assert of exp * exp @@ -305,6 +307,7 @@ and opt_default = and pexp_aux = (* Pattern match *) Pat_exp of pat * exp + | Pat_when of pat * exp * exp and pexp = Pat_aux of pexp_aux * l @@ -418,6 +421,7 @@ val_spec_aux = (* Value type specification *) VS_val_spec of typschm * id | VS_extern_no_rename of typschm * id | VS_extern_spec of typschm * id * string + | VS_cast_spec of typschm * id type @@ -487,6 +491,7 @@ def = (* Top-level definition *) | DEF_type of type_def (* type definition *) | DEF_fundef of fundef (* function definition *) | DEF_val of letbind (* value definition *) + | DEF_overload of id * id list (* operator overload specifications *) | DEF_spec of val_spec (* top-level type constraint *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) diff --git a/src/parser.mly b/src/parser.mly index bd68cfdc..8e5023c8 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -129,9 +129,9 @@ let make_vector_sugar order_set is_inc typ typ1 = /*Terminals with no content*/ %token And Alias As Assert Bitzero Bitone Bits By Case Clause Const Dec Def Default Deinfix Effect EFFECT End -%token Enumerate Else Exit Extern False Forall Foreach Function_ If_ In IN Inc Let_ Member Nat Order +%token Enumerate Else Exit Extern False Forall Foreach Overload Function_ If_ In IN Inc Let_ Member Nat NatNum Order Cast %token Pure Rec Register Return Scattered Sizeof Struct Switch Then True TwoStarStar Type TYPE Typedef -%token Undefined Union With Val +%token Undefined Union With When Val Constraint %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape @@ -150,7 +150,7 @@ let make_vector_sugar order_set is_inc typ typ1 = %token <string> Id TyVar TyId %token <int> Num -%token <string> String Bin Hex +%token <string> String Bin Hex Real %token <string> Amp At Carrot Div Eq Excl Gt Lt Plus Star Tilde %token <string> AmpAmp CarrotCarrot Colon ColonColon EqEq ExclEq ExclExcl @@ -209,6 +209,10 @@ id: { idl (DeIid($3)) } | Lparen Deinfix Lt Rparen { idl (DeIid($3)) } + | Lparen Deinfix GtUnderS Rparen + { idl (DeIid($3)) } + | Lparen Deinfix LtUnderS Rparen + { idl (DeIid($3)) } | Lparen Deinfix Minus Rparen { idl (DeIid("-")) } | Lparen Deinfix MinusUnderS Rparen @@ -226,7 +230,7 @@ id: | Lparen Deinfix AmpAmp Rparen { idl (DeIid($3)) } | Lparen Deinfix Bar Rparen - { idl (DeIid("||")) } + { idl (DeIid("|")) } | Lparen Deinfix BarBar Rparen { idl (DeIid("||")) } | Lparen Deinfix CarrotCarrot Rparen @@ -243,6 +247,8 @@ id: { idl (DeIid($3)) } | Lparen Deinfix GtEq Rparen { idl (DeIid($3)) } + | Lparen Deinfix GtEqUnderS Rparen + { idl (DeIid($3)) } | Lparen Deinfix GtEqPlus Rparen { idl (DeIid($3)) } | Lparen Deinfix GtGt Rparen @@ -257,6 +263,8 @@ id: { idl (DeIid($3)) } | Lparen Deinfix LtEq Rparen { idl (DeIid($3)) } + | Lparen Deinfix LtEqUnderS Rparen + { idl (DeIid($3)) } | Lparen Deinfix LtLt Rparen { idl (DeIid($3)) } | Lparen Deinfix LtLtLt Rparen @@ -283,6 +291,8 @@ atomic_kind: { bkloc BK_type } | Nat { bkloc BK_nat } + | NatNum + { bkloc BK_nat } | Order { bkloc BK_order } | EFFECT @@ -342,29 +352,7 @@ effect_typ: | Pure { tloc (ATyp_set([])) } -atomic_typ: - | tid - { tloc (ATyp_id $1) } - | tyvar - { tloc (ATyp_var $1) } - | effect_typ - { $1 } - | Inc - { tloc (ATyp_inc) } - | Dec - { tloc (ATyp_dec) } - | SquareBar nexp_typ BarSquare - { tloc (make_range_sugar $2) } - | SquareBar nexp_typ Colon nexp_typ BarSquare - { tloc (make_range_sugar_bounded $2 $4) } - | SquareColon nexp_typ ColonSquare - { tloc (make_atom_sugar $2) } - | Lparen typ Rparen - { $2 } - vec_typ: - | atomic_typ - { $1 } | tid Lsquare nexp_typ Rsquare { tloc (make_vector_sugar false false (ATyp_aux ((ATyp_id $1), locn 1 1)) $3) } | tid Lsquare nexp_typ Colon nexp_typ Rsquare @@ -383,68 +371,75 @@ vec_typ: { tloc (make_vector_sugar_bounded true false "vector" (ATyp_aux ((ATyp_var $1), locn 1 1)) $3 $5) } app_typs: - | nexp_typ + | atomic_typ { [$1] } - | nexp_typ Comma app_typs + | atomic_typ Comma app_typs { $1::$3 } -app_typ: +atomic_typ: | vec_typ { $1 } + | range_typ + { $1 } + | nexp_typ + { $1 } + | Inc + { tloc (ATyp_inc) } + | Dec + { tloc (ATyp_dec) } | tid Lt app_typs Gt { tloc (ATyp_app($1,$3)) } | Register Lt app_typs Gt { tloc (ATyp_app(Id_aux(Id "register", locn 1 1),$3)) } -app_num_typ: - | app_typ - { $1 } - | Num - { tloc (ATyp_constant $1) } +range_typ: + | SquareBar nexp_typ BarSquare + { tloc (make_range_sugar $2) } + | SquareBar nexp_typ Colon nexp_typ BarSquare + { tloc (make_range_sugar_bounded $2 $4) } + | SquareColon nexp_typ ColonSquare + { tloc (make_atom_sugar $2) } -star_typ: - | app_num_typ +nexp_typ: + | nexp_typ Plus nexp_typ2 + { tloc (ATyp_sum ($1, $3)) } + | nexp_typ Minus nexp_typ2 + { tloc (ATyp_minus ($1, $3)) } + | Minus nexp_typ2 + { tloc (ATyp_neg $2) } + | nexp_typ2 { $1 } - | app_num_typ Star nexp_typ - { tloc (ATyp_times ($1, $3)) } -exp_typ: - | star_typ - { $1 } - | TwoStarStar atomic_typ - { tloc (ATyp_exp($2)) } - | TwoStarStar Num - { tloc (ATyp_exp (tloc (ATyp_constant $2))) } +nexp_typ2: + | nexp_typ2 Star nexp_typ3 + { tloc (ATyp_times ($1, $3)) } + | nexp_typ3 + { $1 } -nexp_typ: - | exp_typ +nexp_typ3: + | TwoStarStar nexp_typ4 + { tloc (ATyp_exp $2) } + | nexp_typ4 { $1 } - | atomic_typ Plus nexp_typ - { tloc (ATyp_sum($1,$3)) } - | Lparen atomic_typ Plus nexp_typ Rparen - { tloc (ATyp_sum($2,$4)) } - | Num Plus nexp_typ - { tloc (ATyp_sum((tlocl (ATyp_constant $1) 1 1),$3)) } - | Lparen Num Plus nexp_typ Rparen - { tloc (ATyp_sum((tlocl (ATyp_constant $2) 2 2),$4)) } - | atomic_typ Minus nexp_typ - { tloc (ATyp_minus($1,$3)) } - | Lparen atomic_typ Minus nexp_typ Rparen - { tloc (ATyp_minus($2,$4)) } - | Num Minus nexp_typ - { tloc (ATyp_minus((tlocl (ATyp_constant $1) 1 1),$3)) } - | Lparen Num Minus nexp_typ Rparen - { tloc (ATyp_minus((tlocl (ATyp_constant $2) 2 2),$4)) } +nexp_typ4: + | Num + { tlocl (ATyp_constant $1) 1 1 } + | tid + { tloc (ATyp_id $1) } + | tyvar + { tloc (ATyp_var $1) } + | Lparen tup_typ Rparen + { $2 } tup_typ_list: - | app_typ Comma app_typ + | atomic_typ Comma atomic_typ { [$1;$3] } - | app_typ Comma tup_typ_list + | atomic_typ Comma tup_typ_list { $1::$3 } tup_typ: - | app_typ + | atomic_typ { $1 } | Lparen tup_typ_list Rparen { tloc (ATyp_tup $2) } @@ -452,7 +447,7 @@ tup_typ: typ: | tup_typ { $1 } - | tup_typ MinusGt typ Effect effect_typ + | tup_typ MinusGt tup_typ Effect effect_typ { tloc (ATyp_fn($1,$3,$5)) } lit: @@ -470,6 +465,8 @@ lit: { lloc (L_bin $1) } | Hex { lloc (L_hex $1) } + | Real + { lloc (L_real $1) } | Undefined { lloc L_undef } | Bitzero @@ -477,7 +474,6 @@ lit: | Bitone { lloc L_one } - atomic_pat: | lit { ploc (P_lit $1) } @@ -485,8 +481,8 @@ atomic_pat: { ploc P_wild } | Lparen pat As id Rparen { ploc (P_as($2,$4)) } - | Lparen typ Rparen atomic_pat - { ploc (P_typ($2,$4)) } + | Lparen tup_typ Rparen atomic_pat + { ploc (P_typ($2,$4)) } | id { ploc (P_app($1,[])) } | Lcurly fpats Rcurly @@ -507,6 +503,8 @@ atomic_pat: { ploc (P_list([$2])) } | SquareBarBar comma_pats BarBarSquare { ploc (P_list($2)) } + | atomic_pat ColonColon pat + { ploc (P_cons ($1, $3)) } | Lparen pat Rparen { $2 } @@ -569,7 +567,7 @@ atomic_exp: { eloc (E_lit($1)) } | Lparen exp Rparen { $2 } - | Lparen typ Rparen atomic_exp + | Lparen tup_typ Rparen atomic_exp { eloc (E_cast($2,$4)) } | Lparen comma_exps Rparen { eloc (E_tuple($2)) } @@ -597,6 +595,8 @@ atomic_exp: { eloc (E_case($2,$4)) } | Sizeof atomic_typ { eloc (E_sizeof($2)) } + | Constraint Lparen nexp_constraint Rparen + { eloc (E_constraint $3) } | Exit atomic_exp { eloc (E_exit $2) } | Return atomic_exp @@ -656,7 +656,7 @@ right_atomic_exp: if $6 <> "to" && $6 <> "downto" then raise (Parse_error_locn ((loc ()),"Missing \"to\" or \"downto\" in foreach loop")); let step = eloc (E_lit(lloc (L_num 1))) in - let ord = + let ord = if $6 = "to" then ATyp_aux(ATyp_inc,(locn 6 6)) else ATyp_aux(ATyp_dec,(locn 6 6)) in @@ -970,6 +970,8 @@ case_exps: patsexp: | atomic_pat MinusGt exp { peloc (Pat_exp($1,$3)) } + | atomic_pat When exp MinusGt exp + { peloc (Pat_when ($1, $3, $5)) } letbind: | Let_ atomic_pat Eq exp @@ -1023,6 +1025,10 @@ val_spec: { vloc (VS_val_spec(mk_typschm $2 $3 2 3,$4)) } | Val typ id { vloc (VS_val_spec(mk_typschm (mk_typqn ()) $2 2 2,$3)) } + | Val Cast typquant typ id + { vloc (VS_cast_spec (mk_typschm $3 $4 3 4,$5)) } + | Val Cast typ id + { vloc (VS_cast_spec (mk_typschm (mk_typqn ()) $3 3 3, $4)) } | Val Extern typquant typ id { vloc (VS_extern_no_rename (mk_typschm $3 $4 3 4,$5)) } | Val Extern typ id @@ -1051,14 +1057,32 @@ nums: { $1::$3 } nexp_constraint: + | nexp_constraint1 + { $1 } + | nexp_constraint1 Bar nexp_constraint + { NC_aux (NC_or ($1, $3), loc ()) } + +nexp_constraint1: + | nexp_constraint2 + { $1 } + | nexp_constraint2 Amp nexp_constraint1 + { NC_aux (NC_and ($1, $3), loc ()) } + +nexp_constraint2: | nexp_typ Eq nexp_typ { NC_aux(NC_fixed($1,$3), loc () ) } + | nexp_typ ExclEq nexp_typ + { NC_aux (NC_not_equal ($1, $3), loc ()) } | nexp_typ GtEq nexp_typ { NC_aux(NC_bounded_ge($1,$3), loc () ) } | nexp_typ LtEq nexp_typ { NC_aux(NC_bounded_le($1,$3), loc () ) } + | tyvar In Lcurly nums Rcurly + { NC_aux(NC_nat_set_bounded($1,$4), loc ()) } | tyvar IN Lcurly nums Rcurly { NC_aux(NC_nat_set_bounded($1,$4), loc ()) } + | Lparen nexp_constraint Rparen + { $2 } id_constraint: | nexp_constraint @@ -1266,6 +1290,8 @@ def: { dloc (DEF_spec($1)) } | default_typ { dloc (DEF_default($1)) } + | Overload id Lsquare enum_body Rsquare + { dloc (DEF_overload($2,$4)) } | Register typ id { dloc (DEF_reg_dec(DEC_aux(DEC_reg($2,$3),loc ()))) } | Register Alias id Eq exp diff --git a/src/pretty_print.ml b/src/pretty_print.ml index 442c368b..e827320b 100644 --- a/src/pretty_print.ml +++ b/src/pretty_print.ml @@ -40,9 +40,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -include Pretty_print_t_ascii include Pretty_print_lem_ast include Pretty_print_sail include Pretty_print_ocaml include Pretty_print_lem - diff --git a/src/pretty_print.mli b/src/pretty_print.mli index 9a002454..24816206 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -41,18 +41,15 @@ (**************************************************************************) open Ast -open Type_internal +open Type_check (* Prints the defs following source syntax *) -val pp_defs : out_channel -> tannot defs -> unit -val pp_exp : Buffer.t -> exp -> unit -val pat_to_string : tannot pat -> string +val pp_defs : out_channel -> 'a defs -> unit +val pp_exp : Buffer.t -> 'a exp -> unit +val pat_to_string : 'a pat -> string (* Prints on formatter the defs as Lem Ast nodes *) val pp_lem_defs : Format.formatter -> tannot defs -> unit val pp_defs_ocaml : out_channel -> tannot defs -> string -> string list -> unit val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit - - -val pp_format_annot_ascii : tannot -> string diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 3699e1ac..5c3339c6 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -125,6 +125,7 @@ let doc_typ, doc_atomic_typ, doc_nexp = (*TODO Need to un bid-endian-ify this here, since both can transform to the shorthand, especially with <: and :> *) (* Special case simple vectors to improve legibility * XXX we assume big-endian here, as usual *) +(* | Typ_app(Id_aux (Id "vector", _), [ Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant m, _)), _); @@ -159,6 +160,7 @@ let doc_typ, doc_atomic_typ, doc_nexp = Typ_arg_aux (Typ_arg_order (Ord_aux (Ord_dec, _)), _); Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) -> (doc_id id) ^^ (brackets (if n' = m_nexp then nexp m_nexp else doc_op colon (nexp m_nexp) (nexp n_n))) + *) | Typ_app(Id_aux (Id "range", _), [ Typ_arg_aux(Typ_arg_nexp (Nexp_aux(Nexp_constant n, _)), _); Typ_arg_aux(Typ_arg_nexp m, _);]) -> diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 9758b2de..95ddc580 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Thomas Bauereiss *) (* *) (* All rights reserved. *) (* *) @@ -40,8 +41,10 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal +open Type_check open Ast +open Ast_util +open Rewriter open Big_int open PPrint open Pretty_print_common @@ -118,26 +121,19 @@ let doc_id_lem_ctor (Id_aux(i,_)) = * token in case of x ending with star. *) separate space [colon; string (String.capitalize x); empty] +let effectful_set = + List.exists + (fun (BE_aux (eff,_)) -> + match eff with + | BE_rreg | BE_wreg | BE_rmem | BE_rmemt | BE_wmem | BE_eamem + | BE_exmem | BE_wmv | BE_wmvt | BE_barr | BE_depend | BE_nondet + | BE_escape -> true + | _ -> false) + let effectful (Effect_aux (eff,_)) = match eff with | Effect_var _ -> failwith "effectful: Effect_var not supported" - | Effect_set effs -> - List.exists - (fun (BE_aux (eff,_)) -> - match eff with - | BE_rreg | BE_wreg | BE_rmem | BE_rmemt | BE_wmem | BE_eamem - | BE_exmem | BE_wmv | BE_wmvt | BE_barr | BE_depend | BE_nondet - | BE_escape -> true - | _ -> false) - effs - -let rec is_number {t=t} = - match t with - | Tabbrev (t1,t2) -> is_number t1 || is_number t2 - | Tapp ("range",_) - | Tapp ("implicit",_) - | Tapp ("atom",_) -> true - | _ -> false + | Effect_set effs -> effectful_set effs let doc_typ_lem, doc_atomic_typ_lem = (* following the structure of parser for precedence *) @@ -160,9 +156,26 @@ let doc_typ_lem, doc_atomic_typ_lem = if atyp_needed then parens tpp else tpp | _ -> app_typ regtypes atyp_needed ty and app_typ regtypes atyp_needed ((Typ_aux (t, _)) as ty) = match t with - | Typ_app(Id_aux (Id "vector", _),[_;_;_;Typ_arg_aux (Typ_arg_typ typa, _)]) -> - let tpp = string "vector" ^^ space ^^ typ regtypes typa in + | Typ_app(Id_aux (Id "vector", _), [ + Typ_arg_aux (Typ_arg_nexp n, _); + Typ_arg_aux (Typ_arg_nexp m, _); + Typ_arg_aux (Typ_arg_order ord, _); + Typ_arg_aux (Typ_arg_typ elem_typ, _)]) -> + let tpp = match elem_typ with + | Typ_aux (Typ_id (Id_aux (Id "bit",_)),_) -> + let len = match m with + | (Nexp_aux(Nexp_constant i,_)) -> string "ty" ^^ doc_int i + | _ -> doc_nexp m in + string "bitvector" ^^ space ^^ len + | _ -> string "vector" ^^ space ^^ typ regtypes elem_typ in if atyp_needed then parens tpp else tpp + | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + (* TODO: Better distinguish register names and contents? + The former are represented in the Lem library using a type + "register" (without parameters), the latter just using the content + type (e.g. "bitvector ty64"). We assume the latter is meant here + and drop the "register" keyword. *) + fn_typ regtypes atyp_needed etyp | Typ_app(Id_aux (Id "range", _),_) -> (string "integer") | Typ_app(Id_aux (Id "implicit", _),_) -> @@ -177,8 +190,8 @@ let doc_typ_lem, doc_atomic_typ_lem = | Typ_id (Id_aux (Id "bool",_)) -> string "bitU" | Typ_id (Id_aux (Id "boolean",_)) -> string "bitU" | Typ_id (Id_aux (Id "bit",_)) -> string "bitU" - | Typ_id ((Id_aux (Id name,_)) as id) -> - if List.exists ((=) name) regtypes + | Typ_id (id) -> + if List.exists ((=) (string_of_id id)) regtypes then string "register" else doc_id_lem_type id | Typ_var v -> doc_var v @@ -189,12 +202,17 @@ let doc_typ_lem, doc_atomic_typ_lem = let tpp = typ regtypes ty in if atyp_needed then parens tpp else tpp and doc_typ_arg_lem regtypes (Typ_arg_aux(t,_)) = match t with - | Typ_arg_typ t -> app_typ regtypes false t + | Typ_arg_typ t -> app_typ regtypes true t | Typ_arg_nexp n -> empty | Typ_arg_order o -> empty | Typ_arg_effect e -> empty in typ', atomic_typ +let doc_tannot_lem regtypes eff typ = + let ta = doc_typ_lem regtypes typ in + if eff then string " : M " ^^ parens ta + else string " : " ^^ ta + (* doc_lit_lem gets as an additional parameter the type information from the * expression around it: that's a hack, but how else can we distinguish between * undefined values of different types ? *) @@ -213,15 +231,14 @@ let doc_lit_lem in_pat (L_aux(lit,l)) a = | L_hex n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*)*) | L_bin n -> failwith "Shouldn't happen" (*"(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*)*) | L_undef -> - let (Base ((_,{t = t}),_,_,_,_,_)) = a in - (match t with - | Tid "bit" - | Tabbrev ({t = Tid "bit"},_) -> "BU" - | Tapp ("register",_) - | Tabbrev ({t = Tapp ("register",_)},_) -> "UndefinedRegister 0" - | Tid "string" - | Tabbrev ({t = Tapp ("string",_)},_) -> "\"\"" - | _ -> "(failwith \"undefined value of unsupported type\")") + (match a with + | Some (_, Typ_aux (t,_), _) -> + (match t with + | Typ_id (Id_aux (Id "bit", _)) + | Typ_app (Id_aux (Id "register", _),_) -> "UndefinedRegister 0" + | Typ_id (Id_aux (Id "string", _)) -> "\"\"" + | _ -> "(failwith \"undefined value of unsupported type\")") + | _ -> "(failwith \"undefined value of unsupported type\")") | L_string s -> "\"" ^ s ^ "\"") (* typ_doc is the doc for the type being quantified *) @@ -231,20 +248,24 @@ let doc_typquant_lem (TypQ_aux(tq,_)) typ_doc = typ_doc let doc_typschm_lem regtypes (TypSchm_aux(TypSchm_ts(tq,t),_)) = (doc_typquant_lem tq (doc_typ_lem regtypes t)) +let is_ctor env id = match Env.lookup_id id env with +| Enum _ | Union _ -> true +| _ -> false + (*Note: vector concatenation, literal vectors, indexed vectors, and record should be removed prior to pp. The latter two have never yet been seen *) let rec doc_pat_lem regtypes apat_needed (P_aux (p,(l,annot)) as pa) = match p with | P_app(id, ((_ :: _) as pats)) -> (match annot with - | Base(_,(Constructor _ | Enum _),_,_,_,_) -> + | Some (env, _, _) when (is_ctor env id) -> let ppp = doc_unop (doc_id_lem_ctor id) (parens (separate_map comma (doc_pat_lem regtypes true) pats)) in if apat_needed then parens ppp else ppp | _ -> empty) | P_app(id,[]) -> (match annot with - | Base(_,(Constructor _| Enum _),_,_,_,_) -> doc_id_lem_ctor id + | Some (env, _, _) when (is_ctor env id) -> doc_id_lem_ctor id | _ -> empty) | P_lit lit -> doc_lit_lem true lit annot | P_wild -> underscore @@ -253,7 +274,7 @@ let rec doc_pat_lem regtypes apat_needed (P_aux (p,(l,annot)) as pa) = match p w | Id_aux (Id "None",_) -> string "Nothing" (* workaround temporary issue *) | _ -> doc_id_lem id end | P_as(p,id) -> parens (separate space [doc_pat_lem regtypes true p; string "as"; doc_id_lem id]) - | P_typ(typ,p) -> doc_op colon (doc_pat_lem regtypes true p) (doc_typ_lem regtypes typ) + | P_typ(typ,p) -> parens (doc_op colon (doc_pat_lem regtypes true p) (doc_typ_lem regtypes typ)) | P_vector pats -> let ppp = (separate space) @@ -269,23 +290,58 @@ let rec doc_pat_lem regtypes apat_needed (P_aux (p,(l,annot)) as pa) = match p w | [p] -> doc_pat_lem regtypes apat_needed p | _ -> parens (separate_map comma_sp (doc_pat_lem regtypes false) pats)) | P_list pats -> brackets (separate_map semi (doc_pat_lem regtypes false) pats) (*Never seen but easy in lem*) + | P_record (_,_) | P_vector_indexed _ -> empty (* TODO *) + +let rec contains_bitvector_typ (Typ_aux (t,_) as typ) = match t with + | Typ_tup ts -> List.exists contains_bitvector_typ ts + | Typ_app (_, targs) -> is_bitvector_typ typ || List.exists contains_bitvector_typ_arg targs + | Typ_fn (t1,t2,_) -> contains_bitvector_typ t1 || contains_bitvector_typ t2 + | _ -> false +and contains_bitvector_typ_arg (Typ_arg_aux (targ, _)) = match targ with + | Typ_arg_typ t -> contains_bitvector_typ t + | _ -> false + +let const_nexp (Nexp_aux (nexp,_)) = match nexp with + | Nexp_constant _ -> true + | _ -> false + +(* Check for variables in types that would be pretty-printed. + In particular, in case of vector types, only the element type and the + length argument are checked for variables, and the latter only if it is + a bitvector; for other types of vectors, the length is not pretty-printed + in the type, and the start index is never pretty-printed in vector types. *) +let rec contains_t_pp_var (Typ_aux (t,a) as typ) = match t with + | Typ_wild -> true + | Typ_id _ -> false + | Typ_var _ -> true + | Typ_fn (t1,t2,_) -> contains_t_pp_var t1 || contains_t_pp_var t2 + | Typ_tup ts -> List.exists contains_t_pp_var ts + | Typ_app (c,targs) -> + if is_bitvector_typ typ then + let (_,length,_,_) = vector_typ_args_of typ in + not (const_nexp ((*normalize_nexp*) length)) + else List.exists contains_t_arg_pp_var targs +and contains_t_arg_pp_var (Typ_arg_aux (targ, _)) = match targ with + | Typ_arg_typ t -> contains_t_pp_var t + | Typ_arg_nexp nexp -> not (const_nexp ((*normalize_nexp*) nexp)) + | _ -> false let prefix_recordtype = true let report = Reporting_basic.err_unreachable let doc_exp_lem, doc_let_lem = - let rec top_exp regtypes (aexp_needed : bool) (E_aux (e, (l,annot))) = + let rec top_exp regtypes (aexp_needed : bool) (E_aux (e, (l,annot)) as full_exp) = let expY = top_exp regtypes true in let expN = top_exp regtypes false in let expV = top_exp regtypes in match e with - | E_assign((LEXP_aux(le_act,tannot) as le),e) -> + | E_assign((LEXP_aux(le_act,tannot) as le), e) -> (* can only be register writes *) - let (_,(Base ((_,{t = t}),tag,_,_,_,_))) = tannot in - (match le_act, t, tag with - | LEXP_vector_range (le,e2,e3),_,_ -> + let t = typ_of_annot tannot in + (match le_act (*, t, tag*) with + | LEXP_vector_range (le,e2,e3) -> (match le with - | LEXP_aux (LEXP_field (le,id), (_,((Base ((_,{t = t}),_,_,_,_,_))))) -> - if t = Tid "bit" then + | LEXP_aux (LEXP_field (le,id), lannot) -> + if is_bit_typ (typ_of_annot lannot) then raise (report l "indexing a register's (single bit) bitfield not supported") else (prefix 2 1) @@ -297,10 +353,10 @@ let doc_exp_lem, doc_let_lem = (string "write_reg_range") (align (doc_lexp_deref_lem regtypes le ^^ space ^^ expY e2 ^/^ expY e3 ^/^ expY e)) ) - | LEXP_vector (le,e2), (Tid "bit" | Tabbrev (_,{t=Tid "bit"})),_ -> + | LEXP_vector (le,e2) when is_bit_typ t -> (match le with - | LEXP_aux (LEXP_field (le,id), (_,((Base ((_,{t = t}),_,_,_,_,_))))) -> - if t = Tid "bit" then + | LEXP_aux (LEXP_field (le,id), lannot) -> + if is_bit_typ (typ_of_annot lannot) then raise (report l "indexing a register's (single bit) bitfield not supported") else (prefix 2 1) @@ -311,16 +367,16 @@ let doc_exp_lem, doc_let_lem = (string "write_reg_bit") (doc_lexp_deref_lem regtypes le ^^ space ^^ expY e2 ^/^ expY e) ) - | LEXP_field (le,id), (Tid "bit"| Tabbrev (_,{t=Tid "bit"})), _ -> + | LEXP_field (le,id) when is_bit_typ t -> (prefix 2 1) (string "write_reg_bitfield") (doc_lexp_deref_lem regtypes le ^^ space ^^ string_lit(doc_id_lem id) ^/^ expY e) - | LEXP_field (le,id), _, _ -> + | LEXP_field (le,id) -> (prefix 2 1) (string "write_reg_field") (doc_lexp_deref_lem regtypes le ^^ space ^^ string_lit(doc_id_lem id) ^/^ expY e) - | (LEXP_id id | LEXP_cast (_,id)), t, Alias alias_info -> + (* | (LEXP_id id | LEXP_cast (_,id)), t, Alias alias_info -> (match alias_info with | Alias_field(reg,field) -> let f = match t with @@ -332,14 +388,21 @@ let doc_exp_lem, doc_let_lem = (separate space [string reg;string_lit(string field);expY e]) | Alias_pair(reg1,reg2) -> string "write_two_regs" ^^ space ^^ string reg1 ^^ space ^^ - string reg2 ^^ space ^^ expY e) + string reg2 ^^ space ^^ expY e) *) | _ -> (prefix 2 1) (string "write_reg") (doc_lexp_deref_lem regtypes le ^/^ expY e)) - | E_vector_append(l,r) -> + | E_vector_append(le,re) -> + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let (call,ta,aexp_needed) = + if is_bitvector_typ t then + if not (contains_t_pp_var t) + then ("bitvector_concat", doc_tannot_lem regtypes false t, true) + else ("bitvector_concat", empty, aexp_needed) + else ("vector_concat",empty,aexp_needed) in let epp = - align (group (separate space [expY l;string "^^"] ^/^ expY r)) in + align (group (separate space [string call;expY le;expY re])) ^^ ta in if aexp_needed then parens epp else epp - | E_cons(l,r) -> doc_op (group (colon^^colon)) (expY l) (expY r) + | E_cons(le,re) -> doc_op (group (colon^^colon)) (expY le) (expY re) | E_if(c,t,e) -> let (E_aux (_,(_,cannot))) = c in let epp = @@ -382,22 +445,39 @@ let doc_exp_lem, doc_let_lem = if aexp_needed then parens (align epp) else epp | Id_aux (Id "slice_raw",_) -> let [e1;e2;e3] = args in - let epp = separate space [string "slice_raw";expY e1;expY e2;expY e3] in + let t1 = typ_of e1 in + let eff1 = effect_of e1 in + let call = if is_bitvector_typ t1 then "bvslice_raw" else "slice_raw" in + let epp = separate space [string call;expY e1;expY e2;expY e3] in + let (taepp,aexp_needed) = + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let eff = effect_of full_exp in + if contains_bitvector_typ t && not (contains_t_pp_var t) + then (align epp ^^ (doc_tannot_lem regtypes (effectful eff) t), true) + else (epp, aexp_needed) in + if aexp_needed then parens (align taepp) else taepp + | Id_aux (Id "length",_) -> + let [arg] = args in + let targ = typ_of arg in + let call = if is_bitvector_typ targ then "bvlength" else "length" in + let epp = separate space [string call;expY arg] in + if aexp_needed then parens (align epp) else epp + | Id_aux (Id "bool_not", _) -> + let [a] = args in + let epp = align (string "~" ^^ expY a) in if aexp_needed then parens (align epp) else epp | _ -> begin match annot with - | Base (_,External (Some "bitwise_not_bit"),_,_,_,_) -> - let [a] = args in - let epp = align (string "~" ^^ expY a) in - if aexp_needed then parens (align epp) else epp - | Base (_,Constructor _,_,_,_,_) -> + | Some (env, _, _) when (is_ctor env f) -> let argpp a_needed arg = - let (E_aux (_,(_,Base((_,{t=t}),_,_,_,_,_)))) = arg in - match t with - | Tapp("vector",_) -> - let epp = concat [string "reset_vector_start";space;expY arg] in - if a_needed then parens epp else epp - | _ -> expV a_needed arg in + let t = typ_of arg in + if is_vector_typ t then + let call = + if is_bitvector_typ t then "reset_bitvector_start" + else "reset_vector_start" in + let epp = concat [string call;space;expY arg] in + if a_needed then parens epp else epp + else expV a_needed arg in let epp = match args with | [] -> doc_id_lem_ctor f @@ -407,55 +487,77 @@ let doc_exp_lem, doc_let_lem = parens (separate_map comma (argpp false) args) in if aexp_needed then parens (align epp) else epp | _ -> - let call = match annot with + let call = (*match annot with | Base(_,External (Some n),_,_,_,_) -> string n - | _ -> doc_id_lem f in + | _ ->*) doc_id_lem f in let argpp a_needed arg = - let (E_aux (_,(_,Base((_,{t=t}),_,_,_,_,_)))) = arg in - match t with - | Tapp("vector",_) -> - let epp = concat [string "reset_vector_start";space;expY arg] in - if a_needed then parens epp else epp - | _ -> expV a_needed arg in + let t = typ_of arg in + if is_vector_typ t then + let call = + if is_bitvector_typ t then "reset_bitvector_start" + else "reset_vector_start" in + let epp = concat [string call;space;expY arg] in + if a_needed then parens epp else epp + else expV a_needed arg in let argspp = match args with | [arg] -> argpp true arg | args -> parens (align (separate_map (comma ^^ break 0) (argpp false) args)) in let epp = align (call ^//^ argspp) in - if aexp_needed then parens (align epp) else epp + let (taepp,aexp_needed) = + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let eff = effect_of full_exp in + if contains_bitvector_typ t && not (contains_t_pp_var t) + then (align epp ^^ (doc_tannot_lem regtypes (effectful eff) t), true) + else (epp, aexp_needed) in + if aexp_needed then parens (align taepp) else taepp end end | E_vector_access (v,e) -> - let (Base (_,_,_,_,eff,_)) = annot in + let eff = effect_of full_exp in let epp = - if has_rreg_effect eff then + if has_effect eff BE_rreg then separate space [string "read_reg_bit";expY v;expY e] else - separate space [string "access";expY v;expY e] in + let tv = typ_of v in + let call = if is_bitvector_typ tv then "bvaccess" else "access" in + separate space [string call;expY v;expY e] in if aexp_needed then parens (align epp) else epp | E_vector_subrange (v,e1,e2) -> - let (Base (_,_,_,_,eff,_)) = annot in - let epp = - if has_rreg_effect eff then - align (string "read_reg_range" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2) + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let eff = effect_of full_exp in + let (epp,aexp_needed) = + if has_effect eff BE_rreg then + let epp = align (string "read_reg_range" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2) in + if contains_bitvector_typ t && not (contains_t_pp_var t) + then (epp ^^ doc_tannot_lem regtypes true t, true) + else (epp, aexp_needed) else - align (string "slice" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2) in + if is_bitvector_typ t then + let bepp = string "bvslice" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2 in + if not (contains_t_pp_var t) + then (bepp ^^ doc_tannot_lem regtypes false t, true) + else (bepp, aexp_needed) + else (string "slice" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2, aexp_needed) in if aexp_needed then parens (align epp) else epp | E_field((E_aux(_,(l,fannot)) as fexp),id) -> - let (Base ((_,{t = t}),_,_,_,_,_)) = fannot in - (match t with - | Tabbrev({t = Tid regtyp},{t=Tapp("register",_)}) -> - let field_f = match annot with - | Base((_,{t = Tid "bit"}),_,_,_,_,_) - | Base((_,{t = Tabbrev(_,{t=Tid "bit"})}),_,_,_,_,_) -> - string "read_reg_bitfield" - | _ -> string "read_reg_field" in + let ft = typ_of_annot (l,fannot) in + (match fannot with + | Some(env, (Typ_aux (Typ_id tid, _)), _) when Env.is_regtyp tid env -> + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let field_f = string + (if is_bit_typ t + then "read_reg_bitfield" + else "read_reg_field") in + let (ta,aexp_needed) = + if contains_bitvector_typ t && not (contains_t_pp_var t) + then (doc_tannot_lem regtypes true t, true) + else (empty, aexp_needed) in let epp = field_f ^^ space ^^ (expY fexp) ^^ space ^^ string_lit (doc_id_lem id) in - if aexp_needed then parens (align epp) else epp - | Tid recordtyp - | Tabbrev ({t = Tid recordtyp},_) -> + if aexp_needed then parens (align epp ^^ ta) else (epp ^^ ta) + | Some(env, (Typ_aux (Typ_id tid, _)), _) when Env.is_record tid env -> let fname = if prefix_recordtype - then (string (recordtyp ^ "_")) ^^ doc_id_lem id + then (string (string_of_id tid ^ "_")) ^^ doc_id_lem id else doc_id_lem id in expY fexp ^^ dot ^^ fname | _ -> @@ -464,93 +566,124 @@ let doc_exp_lem, doc_let_lem = | E_block exps -> raise (report l "Blocks should have been removed till now.") | E_nondet exps -> raise (report l "Nondet blocks not supported.") | E_id id -> + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in (match annot with - | Base((_, ({t = Tapp("register",_)} | {t=Tabbrev(_,{t=Tapp("register",_)})})), - External _,_,eff,_,_) -> - if has_rreg_effect eff then - separate space [string "read_reg";doc_id_lem id] + | Some (env, Typ_aux (Typ_id tid, _), eff) when Env.is_regtyp tid env -> + if has_effect eff BE_rreg then + let epp = separate space [string "read_reg";doc_id_lem id] in + if contains_bitvector_typ t && not (contains_t_pp_var t) + then parens (epp ^^ doc_tannot_lem regtypes true t) + else epp else doc_id_lem id - | Base(_,(Constructor i |Enum i),_,_,_,_) -> doc_id_lem_ctor id - | Base((_,t),Alias alias_info,_,eff,_,_) -> + | Some (env, _, _) when (is_ctor env id) -> doc_id_lem_ctor id + (*| Base((_,t),Alias alias_info,_,eff,_,_) -> (match alias_info with | Alias_field(reg,field) -> - let epp = match t.t with - | Tid "bit" | Tabbrev (_,{t=Tid "bit"}) -> - (separate space) - [string "read_reg_bitfield"; string reg;string_lit(string field)] - | _ -> - (separate space) - [string "read_reg_field"; string reg; string_lit(string field)] in - if aexp_needed then parens (align epp) else epp + let call = match t.t with + | Tid "bit" | Tabbrev (_,{t=Tid "bit"}) -> "read_reg_bitfield" + | _ -> "read_reg_field" in + let ta = + if contains_bitvector_typ t && not (contains_t_pp_var t) + then doc_tannot_lem regtypes true t else empty in + let epp = separate space [string call;string reg;string_lit(string field)] ^^ ta in + if aexp_needed then parens (align epp) else epp | Alias_pair(reg1,reg2) -> - let epp = - if has_rreg_effect eff then - separate space [string "read_two_regs";string reg1;string reg2] - else - separate space [string "RegisterPair";string reg1;string reg2] in - if aexp_needed then parens (align epp) else epp + let (call,ta) = + if has_effect eff BE_rreg then + let ta = + if contains_bitvector_typ t && not (contains_t_pp_var t) + then doc_tannot_lem regtypes true t else empty in + ("read_two_regs", ta) + else + ("RegisterPair", empty) in + let epp = separate space [string call;string reg1;string reg2] ^^ ta in + if aexp_needed then parens (align epp) else epp | Alias_extract(reg,start,stop) -> - let epp = - if start = stop then - (separate space) - [string "access";doc_int start; - parens (string "read_reg" ^^ space ^^ string reg)] - else - (separate space) - [string "slice"; doc_int start; doc_int stop; - parens (string "read_reg" ^^ space ^^ string reg)] in - if aexp_needed then parens (align epp) else epp - ) + let epp = + if start = stop then + separate space [string "read_reg_bit";string reg;doc_int start] + else + let ta = + if contains_bitvector_typ t && not (contains_t_pp_var t) + then doc_tannot_lem regtypes true t else empty in + separate space [string "read_reg_range";string reg;doc_int start;doc_int stop] ^^ ta in + if aexp_needed then parens (align epp) else epp + )*) | _ -> doc_id_lem id) | E_lit lit -> doc_lit_lem false lit annot - | E_cast(Typ_aux (typ,_),e) -> + | E_cast(typ,e) -> + let typ = Env.base_typ_of (env_of full_exp) typ in + if is_vector_typ typ then + let (start,_,_,_) = vector_typ_args_of typ in + let call = + if is_bitvector_typ typ then "set_bitvector_start" + else "set_vector_start" in + let epp = (concat [string call;space;doc_nexp start]) ^//^ + expY e in + if aexp_needed then parens epp else epp + else + expV aexp_needed e (* (match annot with - | Base(_,External _,_,_,_,_) -> string "read_reg" ^^ space ^^ expY e - | _ -> + | Base((_,t),External _,_,_,_,_) -> + (* TODO: Does this case still exist with the new type checker? *) + let epp = string "read_reg" ^^ space ^^ expY e in + if contains_bitvector_typ t && not (contains_t_pp_var t) + then parens (epp ^^ doc_tannot_lem regtypes true t) else epp + | Base((_,t),_,_,_,_,_) -> (match typ with | Typ_app (Id_aux (Id "vector",_), [Typ_arg_aux (Typ_arg_nexp(Nexp_aux (Nexp_constant i,_)),_);_;_;_]) -> - let epp = (concat [string "set_vector_start";space;string (string_of_int i)]) ^//^ + let call = + if is_bitvector_typ t then "set_bitvector_start" + else "set_vector_start" in + let epp = (concat [string call;space;string (string_of_int i)]) ^//^ expY e in if aexp_needed then parens epp else epp + (* | Typ_var (Kid_aux (Var "length",_)) -> - let epp = (string "set_vector_start_to_length") ^//^ expY e in + (* TODO: Does this case still exist with the new type checker? *) + let call = + if is_bitvector_typ t then "set_bitvector_start_to_length" + else "set_vector_start_to_length" in + let epp = (string call) ^//^ expY e in if aexp_needed then parens epp else epp + *) | _ -> expV aexp_needed e)) (*(parens (doc_op colon (group (expY e)) (doc_typ_lem typ)))) *) + *) | E_tuple exps -> - (match exps with - (* | [e] -> expV aexp_needed e *) + (match exps with (* + | [e] -> expV aexp_needed e *) | _ -> parens (separate_map comma expN exps)) | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> - let (Base ((_,{t = t}),_,_,_,_,_)) = annot in - let recordtyp = match t with - | Tid recordtyp - | Tabbrev ({t = Tid recordtyp},_) -> recordtyp + let recordtyp = match annot with + | Some (env, Typ_aux (Typ_id tid,_), _) when Env.is_record tid env -> + tid | _ -> raise (report l "cannot get record type") in let epp = anglebars (space ^^ (align (separate_map (semi_sp ^^ break 1) (doc_fexp regtypes recordtyp) fexps)) ^^ space) in if aexp_needed then parens epp else epp | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> - let (Base ((_,{t = t}),_,_,_,_,_)) = annot in - let recordtyp = match t with - | Tid recordtyp - | Tabbrev ({t = Tid recordtyp},_) -> recordtyp + let recordtyp = match annot with + | Some (env, Typ_aux (Typ_id tid,_), _) when Env.is_record tid env -> + tid | _ -> raise (report l "cannot get record type") in anglebars (doc_op (string "with") (expY e) (separate_map semi_sp (doc_fexp regtypes recordtyp) fexps)) | E_vector exps -> - (match annot with + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let (start, len, order, etyp) = + if is_vector_typ t then vector_typ_args_of t + else raise (Reporting_basic.err_unreachable l + "E_vector of non-vector type") in + (*match annot with | Base((_,t),_,_,_,_,_) -> match t.t with - | Tapp("vector", [TA_nexp start; _; TA_ord order; _]) - | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; _; TA_ord order; _])}) -> - let dir,dir_out = match order.order with - | Oinc -> true,"true" - | _ -> false, "false" in - let start = match start.nexp with - | Nconst i -> string_of_big_int i - | N2n(_,Some i) -> string_of_big_int i + | Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; TA_typ etyp]) + | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; TA_typ etyp])}) ->*) + let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in + let start = match start with + | Nexp_aux (Nexp_constant i, _) -> string_of_int i | _ -> if dir then "0" else string_of_int (List.length exps) in let expspp = match exps with @@ -566,37 +699,42 @@ let doc_exp_lem, doc_let_lem = align (group expspp) in let epp = group (separate space [string "Vector"; brackets expspp;string start;string dir_out]) in + let (epp,aexp_needed) = + if is_bit_typ etyp then + let bepp = string "vec_to_bvec" ^^ space ^^ parens (align epp) in + if contains_t_pp_var t + then (bepp, aexp_needed) + else (bepp ^^ doc_tannot_lem regtypes false t, true) + else (epp,aexp_needed) in if aexp_needed then parens (align epp) else epp - ) + (* *) | E_vector_indexed (iexps, (Def_val_aux (default,(dl,dannot)))) -> - let (Base((_,t),_,_,_,_,_)) = annot in - let call = string "make_indexed_vector" in - let (start,len,order) = match t.t with - | Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _]) - | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _])}) - | Tapp("reg", [TA_typ {t =Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _])}]) -> - (start,len,order.order) in - let dir,dir_out = match order with - | Oinc -> true,"true" - | _ -> false, "false" in - let start = match start.nexp with - | Nconst i | N2n(_,Some i)-> string_of_big_int i - | N2n({nexp=Nconst i},_) -> string_of_int (Util.power 2 (int_of_big_int i)) + let t = Env.base_typ_of (env_of full_exp) (typ_of full_exp) in + let (start, len, order, etyp) = + if is_vector_typ t then vector_typ_args_of t + else raise (Reporting_basic.err_unreachable l "E_vector_indexed of non-vector type") in + let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in + let start = match start with + | Nexp_aux (Nexp_constant i, _) -> string_of_int i | _ -> if dir then "0" else string_of_int (List.length iexps) in - let size = match len.nexp with - | Nconst i | N2n(_,Some i)-> string_of_big_int i - | N2n({nexp=Nconst i},_) -> string_of_int (Util.power 2 (int_of_big_int i)) in + let size = match len with + | Nexp_aux (Nexp_constant i, _)-> string_of_int i + | Nexp_aux (Nexp_exp (Nexp_aux (Nexp_constant i, _)), _) -> + string_of_int (Util.power 2 i) + | _ -> + raise (Reporting_basic.err_unreachable l + "trying to pretty-print indexed vector without constant size") in let default_string = match default with | Def_val_empty -> - if is_bit_vector t then string "BU" + if is_bitvector_typ t then string "BU" else failwith "E_vector_indexed of non-bitvector type without default argument" | Def_val_dec e -> - let (Base ((_,{t = t}),_,_,_,_,_)) = dannot in + (*let (Base ((_,{t = t}),_,_,_,_,_)) = dannot in match t with | Tapp ("register", [TA_typ ({t = rt})]) -> - + (* TODO: Does this case still occur with the new type checker? *) let n = match rt with | Tapp ("vector",TA_nexp {nexp = Nconst i} :: TA_nexp {nexp = Nconst j} ::_) -> abs_big_int (sub_big_int i j) @@ -605,7 +743,7 @@ let doc_exp_lem, doc_let_lem = ("not the right type information available to construct "^ "undefined register")) in parens (string ("UndefinedRegister " ^ string_of_big_int n)) - | _ -> expY e in + | _ ->*) expY e in let iexp (i,e) = parens (doc_int i ^^ comma ^^ expN e) in let expspp = match iexps with @@ -618,35 +756,42 @@ let doc_exp_lem, doc_let_lem = if count = 5 then 0 else count + 1) (iexp e,0) es in align (expspp) in + let call = string "make_indexed_vector" in let epp = align (group (call ^//^ brackets expspp ^/^ separate space [default_string;string start;string size;string dir_out])) in - if aexp_needed then parens (align epp) else epp + let (bepp, aexp_needed) = + if is_bitvector_typ t + then (string "vec_to_bvec" ^^ space ^^ parens (epp) ^^ doc_tannot_lem regtypes false t, true) + else (epp, aexp_needed) in + if aexp_needed then parens (align bepp) else bepp | E_vector_update(v,e1,e2) -> - let epp = separate space [string "update_pos";expY v;expY e1;expY e2] in + let t = typ_of full_exp in + let call = if is_bitvector_typ t then "bvupdate_pos" else "update_pos" in + let epp = separate space [string call;expY v;expY e1;expY e2] in if aexp_needed then parens (align epp) else epp | E_vector_update_subrange(v,e1,e2,e3) -> - let epp = align (string "update" ^//^ + let t = typ_of full_exp in + let call = if is_bitvector_typ t then "bvupdate" else "update" in + let epp = align (string call ^//^ group (group (expY v) ^/^ group (expY e1) ^/^ group (expY e2)) ^/^ group (expY e3)) in if aexp_needed then parens (align epp) else epp | E_list exps -> brackets (separate_map semi (expN) exps) | E_case(e,pexps) -> - - let only_integers (E_aux(_,(_,annot)) as e) = - match annot with - | Base((_,t),_,_,_,_,_) -> - if is_number t then - let e_pp = expY e in - align (string "toNatural" ^//^ e_pp) - else - (match t with - | {t = Ttup ([t1;t2;t3;t4;t5] as ts)} when List.for_all is_number ts -> - let e_pp = expY e in - align (string "toNaturalFiveTup" ^//^ e_pp) - | _ -> expY e) - | _ -> expY e + let only_integers e = + let typ = typ_of e in + if Ast_util.is_number typ then + let e_pp = expY e in + align (string "toNatural" ^//^ e_pp) + else + (* TODO: Where does this come from?? *) + (match typ with + | Typ_aux (Typ_tup ([t1;t2;t3;t4;t5] as ts), _) when List.for_all Ast_util.is_number ts -> + let e_pp = expY e in + align (string "toNaturalFiveTup" ^//^ e_pp) + | _ -> expY e) in (* This is a hack, incomplete. It's because lem does not allow @@ -661,12 +806,19 @@ let doc_exp_lem, doc_let_lem = let epp = separate space [string "assert'"; expY e1; expY e2] in if aexp_needed then parens (align epp) else align epp | E_app_infix (e1,id,e2) -> - (match annot with + (* TODO: Should have been removed by the new type checker; check with Alasdair *) + raise (Reporting_basic.err_unreachable l + "E_app_infix should have been rewritten before pretty-printing") + (*match annot with | Base((_,t),External(Some name),_,_,_,_) -> let argpp arg = - let (E_aux (_,(_,Base((_,{t=t}),_,_,_,_,_)))) = arg in - match t with - | Tapp("vector",_) -> parens (concat [string "reset_vector_start";space;expY arg]) + let (E_aux (_,(_,Base((_,t),_,_,_,_,_)))) = arg in + match t.t with + | Tapp("vector",_) -> + let call = + if is_bitvector_typ t then "reset_bitvector_start" + else "reset_vector_start" in + parens (concat [string call;space;expY arg]) | _ -> expY arg in let epp = let aux name = align (argpp e1 ^^ space ^^ string name ^//^ argpp e2) in @@ -734,11 +886,15 @@ let doc_exp_lem, doc_let_lem = | _ -> string name ^//^ parens (expN e1 ^^ comma ^/^ expN e2)) in + let (epp,aexp_needed) = + if contains_bitvector_typ t && not (contains_t_pp_var t) + then (parens epp ^^ doc_tannot_lem regtypes false t, true) + else (epp, aexp_needed) in if aexp_needed then parens (align epp) else epp | _ -> let epp = align (doc_id_lem id ^//^ parens (expN e1 ^^ comma ^/^ expN e2)) in - if aexp_needed then parens (align epp) else epp) + if aexp_needed then parens (align epp) else epp*) | E_internal_let(lexp, eq_exp, in_exp) -> raise (report l "E_internal_lets should have been removed till now") (* (separate @@ -761,6 +917,19 @@ let doc_exp_lem, doc_let_lem = if aexp_needed then parens (align epp) else epp | E_internal_return (e1) -> separate space [string "return"; expY e1;] + | E_sizeof nexp -> + (match nexp with + | Nexp_aux (Nexp_constant i, _) -> doc_lit_lem false (L_aux (L_num i, l)) annot + | _ -> + raise (Reporting_basic.err_unreachable l + "pretty-printing non-constant sizeof expressions to Lem not supported")) + | E_return _ -> + raise (Reporting_basic.err_todo l + "pretty-printing early return statements to Lem not yet supported") + | E_comment _ | E_comment_struc _ -> empty + | E_internal_cast _ | E_internal_exp _ | E_sizeof_internal _ | E_internal_exp_user _ -> + raise (Reporting_basic.err_unreachable l + "unsupported internal expression encountered while pretty-printing") and let_exp regtypes (LB_aux(lb,_)) = match lb with | LB_val_explicit(_,pat,e) | LB_val_implicit(pat,e) -> @@ -771,7 +940,7 @@ let doc_exp_lem, doc_let_lem = and doc_fexp regtypes recordtyp (FE_aux(FE_Fexp(id,e),_)) = let fname = if prefix_recordtype - then (string (recordtyp ^ "_")) ^^ doc_id_lem id + then (string (string_of_id recordtyp ^ "_")) ^^ doc_id_lem id else doc_id_lem id in group (doc_op equals fname (top_exp regtypes true e)) @@ -1056,7 +1225,14 @@ let rec doc_fundef_lem regtypes (FD_aux(FD_function(r, typa, efa, fcls),fannot)) (fun (already_used_fnames,auxiliary_functions,clauses) funcl -> match funcl with | FCL_aux (FCL_Funcl (Id_aux (Id _,l),pat,exp),annot) -> - let (P_aux (P_app (Id_aux (Id ctor,l),argspat),pannot)) = pat in + let ctor, l, argspat, pannot = (match pat with + | P_aux (P_app (Id_aux (Id ctor,l),argspat),pannot) -> + (ctor, l, argspat, pannot) + | P_aux (P_id (Id_aux (Id ctor,l)), pannot) -> + (ctor, l, [], pannot) + | _ -> + raise (Reporting_basic.err_unreachable l + "unsupported parameter pattern in function clause")) in let rec pick_name_not_clashing_with already_used candidate = if StringSet.mem candidate already_used then pick_name_not_clashing_with already_used (candidate ^ "'") @@ -1108,33 +1284,34 @@ let rec doc_fundef_lem regtypes (FD_aux(FD_function(r, typa, efa, fcls),fannot)) let doc_dec_lem (DEC_aux (reg,(l,annot))) = match reg with | DEC_reg(typ,id) -> - (match annot with - | Base((_,t),_,_,_,_,_) -> - (match t.t with - | Tapp("register", [TA_typ {t= Tapp("vector", [TA_nexp start; TA_nexp size; TA_ord order; TA_typ itemt])}]) - | Tapp("register", [TA_typ {t= Tabbrev(_,{t=Tapp("vector", [TA_nexp start; TA_nexp size; TA_ord order; TA_typ itemt])})}]) -> - (match itemt.t,start.nexp,size.nexp with - | Tid "bit", Nconst start, Nconst size -> - let o = if order.order = Oinc then "true" else "false" in + (match typ with + | Typ_aux (Typ_app (r, [Typ_arg_aux (Typ_arg_typ rt, _)]), _) + when string_of_id r = "register" && is_vector_typ rt -> + let env = env_of_annot (l,annot) in + let (start, size, order, etyp) = vector_typ_args_of (Env.base_typ_of env rt) in + (match is_bit_typ (Env.base_typ_of env etyp), start, size with + | true, Nexp_aux (Nexp_constant start, _), Nexp_aux (Nexp_constant size, _) -> + let o = if is_order_inc order then "true" else "false" in (doc_op equals) (string "let" ^^ space ^^ doc_id_lem id) (string "Register" ^^ space ^^ align (separate space [string_lit(doc_id_lem id); - doc_int (int_of_big_int size); - doc_int (int_of_big_int start); + doc_int (size); + doc_int (start); string o; string "[]"])) ^/^ hardline | _ -> let (Id_aux (Id name,_)) = id in failwith ("can't deal with register " ^ name)) - | Tapp("register", [TA_typ {t=Tid idt}]) - | Tid idt - | Tabbrev( {t= Tid idt}, _) -> - separate space [string "let";doc_id_lem id;equals; - string "build_" ^^ string idt;string_lit (doc_id_lem id)] ^/^ hardline - |_-> empty) - | _ -> empty) + | Typ_aux (Typ_app(r, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id idt, _)), _)]), _) + when string_of_id r = "register" -> + separate space [string "let";doc_id_lem id;equals; + string "build_" ^^ string (string_of_id idt);string_lit (doc_id_lem id)] ^/^ hardline + | Typ_aux (Typ_id idt, _) -> + separate space [string "let";doc_id_lem id;equals; + string "build_" ^^ string (string_of_id idt);string_lit (doc_id_lem id)] ^/^ hardline + |_-> empty) | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty @@ -1142,12 +1319,13 @@ let doc_spec_lem regtypes (VS_aux (valspec,annot)) = match valspec with | VS_extern_no_rename _ | VS_extern_spec _ -> empty (* ignore these at the moment *) - | VS_val_spec (typschm,id) -> empty + | VS_val_spec (typschm,id) | VS_cast_spec (typschm,id) -> empty (* separate space [string "val"; doc_id_lem id; string ":";doc_typschm_lem regtypes typschm] ^/^ hardline *) let rec doc_def_lem regtypes def = match def with | DEF_spec v_spec -> (doc_spec_lem regtypes v_spec,empty) + | DEF_overload _ -> (empty,empty) | DEF_type t_def -> (group (doc_typdef_lem regtypes t_def) ^/^ hardline,empty) | DEF_reg_dec dec -> (group (doc_dec_lem dec),empty) @@ -1176,10 +1354,6 @@ let find_regtypes (Defs defs) = | _ -> acc ) [] defs - -let typ_to_t env = - Type_check.typ_to_t env false false - let pp_defs_lem (types_file,types_modules) (prompt_file,prompt_modules) (state_file,state_modules) d top_line = let regtypes = find_regtypes d in let (typdefs,valdefs) = doc_defs_lem regtypes d in diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index ef7a8b95..6809826a 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -40,7 +40,7 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal +open Type_check open Ast open Format open Big_int @@ -284,68 +284,6 @@ let pp_format_lit_lem (L_aux(lit,l)) = let pp_lem_lit ppf l = base ppf (pp_format_lit_lem l) -let rec pp_format_t_lem t = - match t.t with - | Tid i -> "(T_id \"" ^ i ^ "\")" - | Tvar i -> "(T_var \"" ^ i ^ "\")" - | Tfn(t1,t2,_,e) -> "(T_fn " ^ (pp_format_t_lem t1) ^ " " ^ (pp_format_t_lem t2) ^ " " ^ pp_format_e_lem e ^ ")" - | Ttup(tups) -> "(T_tup [" ^ (list_format "; " pp_format_t_lem tups) ^ "])" - | Tapp(i,args) -> "(T_app \"" ^ i ^ "\" (T_args [" ^ list_format "; " pp_format_targ_lem args ^ "]))" - | Tabbrev(ti,ta) -> "(T_abbrev " ^ (pp_format_t_lem ti) ^ " " ^ (pp_format_t_lem ta) ^ ")" - | Tuvar(_) -> "(T_var \"fresh_v\")" - | Toptions _ -> "(T_var \"fresh_v\")" -and pp_format_targ_lem = function - | TA_typ t -> "(T_arg_typ " ^ pp_format_t_lem t ^ ")" - | TA_nexp n -> "(T_arg_nexp " ^ pp_format_n_lem n ^ ")" - | TA_eft e -> "(T_arg_effect " ^ pp_format_e_lem e ^ ")" - | TA_ord o -> "(T_arg_order " ^ pp_format_o_lem o ^ ")" -and pp_format_n_lem n = - match n.nexp with - | Nid (i, n) -> "(Ne_id \"" ^ i ^ " " ^ "\")" - | Nvar i -> "(Ne_var \"" ^ i ^ "\")" - | Nconst i -> "(Ne_const " ^ (lemnum string_of_int (int_of_big_int i)) ^ ")" - | Npos_inf -> "Ne_inf" - | Nadd(n1,n2) -> "(Ne_add [" ^ (pp_format_n_lem n1) ^ "; " ^ (pp_format_n_lem n2) ^ "])" - | Nsub(n1,n2) -> "(Ne_minus "^ (pp_format_n_lem n1) ^ " " ^ (pp_format_n_lem n2) ^ ")" - | Nmult(n1,n2) -> "(Ne_mult " ^ (pp_format_n_lem n1) ^ " " ^ (pp_format_n_lem n2) ^ ")" - | N2n(n,Some i) -> "(Ne_exp " ^ (pp_format_n_lem n) ^ "(*" ^ string_of_big_int i ^ "*)" ^ ")" - | N2n(n,None) -> "(Ne_exp " ^ (pp_format_n_lem n) ^ ")" - | Nneg n -> "(Ne_unary " ^ (pp_format_n_lem n) ^ ")" - | Nuvar _ -> "(Ne_var \"fresh_v_" ^ string_of_int (get_index n) ^ "\")" - | Nneg_inf -> "(Ne_unary Ne_inf)" - | Npow _ -> "power_not_implemented" - | Ninexact -> "(Ne_add Ne_inf (Ne_unary Ne_inf)" -and pp_format_e_lem e = - "(Effect_aux " ^ - (match e.effect with - | Evar i -> "(Effect_var (Kid_aux (Var \"" ^ i ^ "\") Unknown))" - | Eset es -> "(Effect_set [" ^ - (list_format "; " pp_format_base_effect_lem es) ^ " ])" - | Euvar(_) -> "(Effect_var (Kid_aux (Var \"fresh_v\") Unknown))") - ^ " Unknown)" -and pp_format_o_lem o = - "(Ord_aux " ^ - (match o.order with - | Ovar i -> "(Ord_var (Kid_aux (Var \"" ^ i ^ "\") Unknown))" - | Oinc -> "Ord_inc" - | Odec -> "Ord_dec" - | Ouvar(_) -> "(Ord_var (Kid_aux (Var \"fresh_v\") Unknown))") - ^ " Unknown)" - -let rec pp_format_tag = function - | Emp_local -> "Tag_empty" - | Emp_intro -> "Tag_intro" - | Emp_set -> "Tag_set" - | Emp_global -> "Tag_global" - | Tuple_assign tags -> (*"(Tag_tuple_assign [" ^ list_format " ;" pp_format_tag tags ^ "])"*) "Tag_tuple_assign" - | External (Some s) -> "(Tag_extern (Just \""^s^"\"))" - | External None -> "(Tag_extern Nothing)" - | Default -> "Tag_default" - | Constructor _ -> "Tag_ctor" - | Enum i -> "(Tag_enum " ^ (lemnum string_of_int i) ^ ")" - | Alias alias_inf -> "Tag_alias" - | Spec -> "Tag_spec" - let rec pp_format_nes nes = "[" ^ (* (list_format "; " @@ -365,12 +303,16 @@ let rec pp_format_nes nes = nes) ^*) "]" let pp_format_annot = function + | None -> "Nothing" + | Some (_, typ, eff) -> + "(Just (Env.empty, " ^ pp_format_typ_lem typ ^ ", " ^ pp_format_effects_lem eff ^ "))" +(* | NoTyp -> "Nothing" | Base((_,t),tag,nes,efct,efctsum,_) -> (*TODO print out bindings for use in pattern match in interpreter*) "(Just (" ^ pp_format_t_lem t ^ ", " ^ pp_format_tag tag ^ ", " ^ pp_format_nes nes ^ ", " ^ pp_format_e_lem efct ^ ", " ^ pp_format_e_lem efctsum ^ "))" - | Overload _ -> "Nothing" + | Overload _ -> "Nothing" *) let pp_annot ppf ant = base ppf (pp_format_annot ant) @@ -423,7 +365,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = | E_lit(lit) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_lit" pp_lem_lit lit pp_lem_l l pp_annot annot | E_cast(typ,exp) -> fprintf ppf "@[<0>(E_aux (E_cast %a %a) (%a, %a))@]" pp_lem_typ typ pp_lem_exp exp pp_lem_l l pp_annot annot - | E_internal_cast((_,NoTyp),e) -> pp_lem_exp ppf e + | E_internal_cast((_,None),e) -> pp_lem_exp ppf e | E_app(f,args) -> fprintf ppf "@[<0>(E_aux (E_app %a [%a]) (%a, %a))@]" pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l pp_annot annot | E_app_infix(l',op,r) -> fprintf ppf "@[<0>(E_aux (E_app_infix %a %a %a) (%a, %a))@]" @@ -490,6 +432,7 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = fprintf ppf "@[<0>(E_aux (E_return %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_assert(c,msg) -> fprintf ppf "@[<0>(E_aux (E_assert %a %a) (%a, %a))@]" pp_lem_exp c pp_lem_exp msg pp_lem_l l pp_annot annot + (* | E_internal_exp ((l, Base((_,t),_,_,_,_,bindings))) -> (*TODO use bindings where appropriate*) (match t.t with @@ -508,16 +451,22 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = | Nvar v -> fprintf ppf "@[<0>(E_aux (E_id (Id_aux (Id \"%a\") %a)) (%a,%a))@]" kwd v pp_lem_l l pp_lem_l l pp_annot (Base(([],nat_t),Emp_local,[],pure_e,pure_e,nob)) | _ -> raise (Reporting_basic.err_unreachable l "Internal_exp given implicit without variable or const")) - | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given non-vector or implicit")) + | _ -> raise (Reporting_basic.err_unreachable l "Internal exp given non-vector or implicit")*) | E_comment _ | E_comment_struc _ -> fprintf ppf "@[(E_aux (E_lit (L_aux L_unit %a)) (%a,%a))@]" pp_lem_l l pp_lem_l l pp_annot annot | E_internal_cast _ | E_internal_exp _ -> raise (Reporting_basic.err_unreachable l "Found internal cast or exp") | E_internal_exp_user _ -> (raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_exp_user")) | E_sizeof_internal _ -> (raise (Reporting_basic.err_unreachable l "Internal sizeof not removed")) - | E_internal_let _ -> (raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_let")) - | E_internal_return _ -> (raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_return")) - | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l "Found non-rewritten internal_plet") + | E_internal_let (lexp,exp1,exp2) -> + fprintf ppf "@[<0>(E_aux (E_internal_let %a %a %a) (%a, %a))@]" + pp_lem_lexp lexp pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot + | E_internal_return exp -> + fprintf ppf "@[<0>(E_aux (E_internal_return %a) (%a, %a))@]" + pp_lem_exp exp pp_lem_l l pp_annot annot + | E_internal_plet (pat,exp1,exp2) -> + fprintf ppf "@[<0>(E_aux (E_internal_plet %a %a %a) (%a, %a))@]" + pp_lem_pat pat pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_l l pp_annot annot in print_e ppf e @@ -547,6 +496,7 @@ and pp_lem_lexp ppf (LEXP_aux(lexp,(l,annot))) = fprintf ppf "@[(LEXP_aux %a (%a, %a))@]" print_le lexp pp_lem_l l pp_annot annot and pp_semi_lem_lexp ppf le = fprintf ppf "@[<1>%a%a@]" pp_lem_lexp le kwd ";" +let pp_semi_lem_id ppf id = fprintf ppf "@[<1>%a%a@]" pp_lem_id id kwd ";" let pp_lem_default ppf (DT_aux(df,l)) = let print_de ppf df = @@ -566,6 +516,8 @@ let pp_lem_spec ppf (VS_aux(v,(l,annot))) = fprintf ppf "@[<0>(%a %a %a \"%s\")@]@\n" kwd "VS_extern_spec" pp_lem_typscm ts pp_lem_id id s | VS_extern_no_rename(ts,id) -> fprintf ppf "@[<0>(%a %a %a)@]@\n" kwd "VS_extern_no_rename" pp_lem_typscm ts pp_lem_id id + | VS_cast_spec(ts,id) -> + fprintf ppf "@[<0>(%a %a %a)@]@\n" kwd "VS_cast_spec" pp_lem_typscm ts pp_lem_id id in fprintf ppf "@[<0>(VS_aux %a (%a, %a))@]" print_spec v pp_lem_l l pp_annot annot @@ -655,6 +607,8 @@ let pp_lem_tannot_opt ppf (Typ_annot_opt_aux(t,l)) = match t with | Typ_annot_opt_some(tq,typ) -> fprintf ppf "(Typ_annot_opt_aux (Typ_annot_opt_some %a %a) %a)" pp_lem_typquant tq pp_lem_typ typ pp_lem_l l + | Typ_annot_opt_none -> + fprintf ppf "(Typ_annot_opt_aux (Typ_annot_opt_none) %a)" pp_lem_l l let pp_lem_effects_opt ppf (Effect_opt_aux(e,l)) = match e with @@ -701,6 +655,7 @@ let pp_lem_def ppf d = match d with | DEF_default(df) -> fprintf ppf "(DEF_default %a);@\n" pp_lem_default df | DEF_spec(v_spec) -> fprintf ppf "(DEF_spec %a);@\n" pp_lem_spec v_spec + | DEF_overload(id,ids) -> fprintf ppf "(DEF_overload %a [%a]);@\n" pp_lem_id id (list_pp pp_semi_lem_id pp_lem_id) ids | DEF_type(t_def) -> fprintf ppf "(DEF_type %a);@\n" pp_lem_typdef t_def | DEF_kind(k_def) -> fprintf ppf "(DEF_kind %a);@\n" pp_lem_kindef k_def | DEF_fundef(f_def) -> fprintf ppf "(DEF_fundef %a);@\n" pp_lem_fundef f_def @@ -711,4 +666,3 @@ let pp_lem_def ppf d = let pp_lem_defs ppf (Defs(defs)) = fprintf ppf "Defs [@[%a@]]@\n" (list_pp pp_lem_def pp_lem_def) defs - diff --git a/src/pretty_print_ocaml.ml b/src/pretty_print_ocaml.ml index 3772f549..652b0ce9 100644 --- a/src/pretty_print_ocaml.ml +++ b/src/pretty_print_ocaml.ml @@ -41,8 +41,9 @@ (**************************************************************************) open Big_int -open Type_internal open Ast +open Ast_util +open Type_check open PPrint open Pretty_print_common @@ -73,10 +74,10 @@ let doc_id_ocaml_type (Id_aux(i,_)) = * token in case of x ending with star. *) parens (separate space [colon; string (String.uncapitalize x); empty]) -let doc_id_ocaml_ctor n (Id_aux(i,_)) = +let doc_id_ocaml_ctor (Id_aux(i,_)) = match i with | Id("bit") -> string "vbit" - | Id i -> string ((if n > 246 then "`" else "") ^ (String.capitalize i)) + | Id i -> string ((* TODO if n > 246 then "`" else "") ^ *) (String.capitalize i)) | DeIid x -> (* add an extra space through empty to avoid a closing-comment * token in case of x ending with star. *) @@ -154,10 +155,17 @@ let doc_pat_ocaml = let rec pat pa = app_pat pa and app_pat ((P_aux(p,(l,annot))) as pa) = match p with | P_app(id, ((_ :: _) as pats)) -> - (match annot with - | Base(_,Constructor n,_,_,_,_) -> - doc_unop (doc_id_ocaml_ctor n id) (parens (separate_map comma_sp pat pats)) - | _ -> empty) + (* TODO This check fails for some reason in the MIPS execute function; + lookup_id returns Unbound, maybe because the environment is not + propagated correctly during rewriting. + I comment out the check for now. *) + (* (match annot with + | Some (env, typ, eff) -> + (match Env.lookup_id id env with + | Union _ -> *) + doc_unop (doc_id_ocaml_ctor id) (parens (separate_map comma_sp pat pats)) + (* | _ -> empty) + | _ -> empty) *) | P_lit lit -> doc_lit_ocaml true lit | P_wild -> underscore | P_id id -> doc_id_ocaml id @@ -165,8 +173,10 @@ let doc_pat_ocaml = | P_typ(typ,p) -> doc_op colon (pat p) (doc_typ_ocaml typ) | P_app(id,[]) -> (match annot with - | Base(_,(Constructor n | Enum n),_,_,_,_) -> - doc_id_ocaml_ctor n id + | Some (env, typ, eff) -> + (match Env.lookup_id id env with + | Union _ | Enum _ -> doc_id_ocaml_ctor id + | _ -> failwith "encountered unexpected P_app pattern") | _ -> failwith "encountered unexpected P_app pattern") | P_vector pats -> let non_bit_print () = @@ -176,14 +186,14 @@ let doc_pat_ocaml = underscore; underscore])]) in (match annot with - | Base(([],t),_,_,_,_,_) -> - if is_bit_vector t - then parens (separate space [string "Vvector"; - parens (separate comma_sp [squarebars (separate_map semi pat pats); - underscore; - underscore])]) - else non_bit_print() - | _ -> non_bit_print ()) + | Some (env, typ, _) -> + if is_bitvector_typ (Env.base_typ_of env typ) + then parens (separate space [string "Vvector"; + parens (separate comma_sp [squarebars (separate_map semi pat pats); + underscore; + underscore])]) + else non_bit_print() + | None -> non_bit_print()) | P_tup pats -> parens (separate_map comma_sp pat pats) | P_list pats -> brackets (separate_map semi pat pats) (*Never seen but easy in ocaml*) | P_record _ -> raise (Reporting_basic.err_unreachable l "unhandled record pattern") @@ -191,26 +201,47 @@ let doc_pat_ocaml = | P_vector_concat _ -> raise (Reporting_basic.err_unreachable l "unhandled vector_concat pattern") in pat +let id_is_local_var id env = match Env.lookup_id id env with + | Local _ | Unbound -> true + | _ -> false + +let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_local_var id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local lexp env + +let is_regtyp (Typ_aux (typ,_)) env = match typ with + | Typ_app (register, _) -> string_of_id register = "register" + | Typ_id id -> Env.is_regtyp id env + | _ -> false + let doc_exp_ocaml, doc_let_ocaml = - let rec top_exp read_registers (E_aux (e, (_,annot))) = + let rec top_exp read_registers (E_aux (e, (l,annot)) as full_exp) = let exp = top_exp read_registers in + let (env, typ, eff) = match annot with + | Some (env, typ, eff) -> (env, typ, eff) + | None -> raise (Reporting_basic.err_unreachable l "no type annotation") in match e with | E_assign((LEXP_aux(le_act,tannot) as le),e) -> - (match annot with - | Base(_,(Emp_local | Emp_set),_,_,_,_) -> - (match le_act with - | LEXP_id _ | LEXP_cast _ -> - (*Setting local variable fully *) - doc_op coloneq (doc_lexp_ocaml true le) (exp e) - | LEXP_vector _ -> - doc_op (string "<-") (doc_lexp_array_ocaml le) (exp e) - | LEXP_vector_range _ -> - doc_lexp_rwrite le e) - | _ -> - (match le_act with - | LEXP_vector _ | LEXP_vector_range _ | LEXP_cast _ | LEXP_field _ | LEXP_id _ -> - (doc_lexp_rwrite le e) - | LEXP_memory _ -> (doc_lexp_fcall le e))) + if lexp_is_local le env + then + (match le_act with + | LEXP_id _ | LEXP_cast _ -> + (*Setting local variable fully *) + doc_op coloneq (doc_lexp_ocaml true le) (exp e) + | LEXP_vector _ -> + doc_op (string "<-") (doc_lexp_array_ocaml le) (exp e) + | LEXP_vector_range _ -> + doc_lexp_rwrite le e) + else + (match le_act with + | LEXP_vector _ | LEXP_vector_range _ | LEXP_cast _ | LEXP_field _ | LEXP_id _ -> + (doc_lexp_rwrite le e) + | LEXP_memory _ -> (doc_lexp_fcall le e)) | E_vector_append(l,r) -> parens ((string "vector_concat ") ^^ (exp l) ^^ space ^^ (exp r)) | E_cons(l,r) -> doc_op (group (colon^^colon)) (exp l) (exp r) @@ -258,9 +289,8 @@ let doc_exp_ocaml, doc_let_ocaml = *)*) | E_let(leb,e) -> doc_op (string "in") (let_exp leb) (exp e) | E_app(f,args) -> - let call,ctor = match annot with - | Base(_,External (Some n),_,_,_,_) -> string n,false - | Base(_,Constructor i,_,_,_,_) -> doc_id_ocaml_ctor i f,true + let call,ctor = match Env.lookup_id f env with + | Union _ -> doc_id_ocaml_ctor f,true | _ -> doc_id_ocaml f,false in let base_print () = parens (doc_unop call (parens (separate_map comma exp args))) in if not(ctor) @@ -272,39 +302,38 @@ let doc_exp_ocaml, doc_let_ocaml = | _ -> base_print()) | args -> base_print()) | E_vector_access(v,e) -> - let call = (match annot with - | Base((_,t),_,_,_,_,_) -> - (match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> (string "bit_vector_access") - | _ -> (string "vector_access")) - | _ -> (string "vector_access")) in + let call = + if is_bit_typ (Env.base_typ_of env typ) + then (string "bit_vector_access") + else (string "vector_access") in parens (call ^^ space ^^ exp v ^^ space ^^ exp e) | E_vector_subrange(v,e1,e2) -> parens ((string "vector_subrange") ^^ space ^^ (exp v) ^^ space ^^ (exp e1) ^^ space ^^ (exp e2)) - | E_field((E_aux(_,(_,fannot)) as fexp),id) -> - (match fannot with - | Base((_,{t= Tapp("register",_)}),_,_,_,_,_) | - Base((_,{t= Tabbrev(_,{t=Tapp("register",_)})}),_,_,_,_,_)-> - let field_f = match annot with - | Base((_,{t = Tid "bit"}),_,_,_,_,_) | - Base((_,{t = Tabbrev(_,{t=Tid "bit"})}),_,_,_,_,_) -> - string "get_register_field_bit" - | _ -> string "get_register_field_vec" in - parens (field_f ^^ space ^^ (exp fexp) ^^ space ^^ string_lit (doc_id id)) - | _ -> exp fexp ^^ dot ^^ doc_id_ocaml id) + | E_field((E_aux(_,(fl,fannot)) as fexp),id) -> + let ftyp = typ_of_annot (fl,fannot) in + if (is_regtyp ftyp env) then + let field_f = + if (is_bit_typ (Env.base_typ_of env ftyp)) + then string "get_register_field_bit" + else string "get_register_field_vec" in + parens (field_f ^^ space ^^ (exp fexp) ^^ space ^^ string_lit (doc_id id)) + else exp fexp ^^ dot ^^ doc_id_ocaml id | E_block [] -> string "()" | E_block exps | E_nondet exps -> let exps_doc = separate_map (semi ^^ hardline) exp exps in surround 2 1 (string "begin") exps_doc (string "end") | E_id id -> - (match annot with - | Base((_, ({t = Tapp("reg",_)} | {t=Tabbrev(_,{t=Tapp("reg",_)})})),_,_,_,_,_) -> - string "!" ^^ doc_id_ocaml id - | Base((_, ({t = Tapp("register",_)} | {t=Tabbrev(_,{t=Tapp("register",_)})})),_,_,_,_,_) -> - if read_registers - then string "(read_register " ^^ doc_id_ocaml id ^^ string ")" - else doc_id_ocaml id - | Base(_,(Constructor i |Enum i),_,_,_,_) -> doc_id_ocaml_ctor i id + (match Env.lookup_id id env with + | Local (Mutable, _) -> + string "!" ^^ doc_id_ocaml id + | Union _ | Enum _ -> doc_id_ocaml_ctor id + | _ -> + if (is_regtyp typ env) then + if read_registers + then string "(read_register " ^^ doc_id_ocaml id ^^ string ")" + else doc_id_ocaml id + else doc_id_ocaml id) + (*match annot with | Base((_,t),Alias alias_info,_,_,_,_) -> (match alias_info with | Alias_field(reg,field) -> @@ -320,16 +349,15 @@ let doc_exp_ocaml, doc_let_ocaml = | Alias_pair(reg1,reg2) -> parens (separate space [string "vector_concat"; string (sanitize_name reg1); - string (sanitize_name reg2)])) - | _ -> doc_id_ocaml id) + string (sanitize_name reg2)])) *) | E_lit lit -> doc_lit_ocaml false lit | E_cast(typ,e) -> - (match annot with + (* (match annot with | Base(_,External _,_,_,_,_) -> if read_registers then parens (string "read_register" ^^ space ^^ exp e) else exp e - | _ -> + | _ -> *) let (Typ_aux (t,_)) = typ in (match t with | Typ_app (Id_aux (Id "vector",_), [Typ_arg_aux (Typ_arg_nexp(Nexp_aux (Nexp_constant i,_)),_);_;_;_]) -> @@ -339,9 +367,6 @@ let doc_exp_ocaml, doc_let_ocaml = parens ((string "set_start_to_length") ^//^ exp e) | _ -> parens (doc_op colon (group (exp e)) (doc_typ_ocaml typ))) - - -) | E_tuple exps -> parens (separate_map comma exp exps) | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> @@ -349,41 +374,47 @@ let doc_exp_ocaml, doc_let_ocaml = | E_record_update(e,(FES_aux(FES_Fexps(fexps,_),_))) -> braces (doc_op (string "with") (exp e) (separate_map semi_sp doc_fexp fexps)) | E_vector exps -> - (match annot with + let (start, _, order, _) = vector_typ_args_of (Env.base_typ_of env typ) in + (*match annot with | Base((_,t),_,_,_,_,_) -> match t.t with | Tapp("vector", [TA_nexp start; _; TA_ord order; _]) - | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; _; TA_ord order; _])}) -> - let call = if is_bit_vector t then (string "Vvector") else (string "VvectorR") in - let dir,dir_out = match order.order with - | Oinc -> true,"true" - | _ -> false, "false" in - let start = match start.nexp with - | Nconst i -> string_of_big_int i - | N2n(_,Some i) -> string_of_big_int i + | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; _; TA_ord order; _])}) ->*) + let call = if is_bitvector_typ typ then (string "Vvector") else (string "VvectorR") in + let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in + let start = match start with + | Nexp_aux (Nexp_constant i, _) -> string_of_int i + | Nexp_aux (Nexp_exp (Nexp_aux (Nexp_constant i, _)), _) -> + string_of_int (Util.power 2 i) | _ -> if dir then "0" else string_of_int (List.length exps) in parens (separate space [call; parens (separate comma_sp [squarebars (separate_map semi exp exps); string start; - string dir_out])])) + string dir_out])]) | E_vector_indexed (iexps, (Def_val_aux (default,_))) -> - (match annot with + let (start, len, order, _) = vector_typ_args_of (Env.base_typ_of env typ) in + (*match annot with | Base((_,t),_,_,_,_,_) -> match t.t with | Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _]) | Tabbrev(_,{t= Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _])}) - | Tapp("reg", [TA_typ {t =Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _])}]) -> - let call = if is_bit_vector t then (string "make_indexed_bitv") else (string "make_indexed_v") in - let dir,dir_out = match order.order with - | Oinc -> true,"true" - | _ -> false, "false" in - let start = match start.nexp with - | Nconst i | N2n(_,Some i)-> string_of_big_int i - | N2n({nexp=Nconst i},_) -> string_of_int (Util.power 2 (int_of_big_int i)) + | Tapp("reg", [TA_typ {t =Tapp("vector", [TA_nexp start; TA_nexp len; TA_ord order; _])}]) ->*) + let call = + if is_bitvector_typ (Env.base_typ_of env typ) + then (string "make_indexed_bitv") + else (string "make_indexed_v") in + let dir,dir_out = if is_order_inc order then (true,"true") else (false, "false") in + let start = match start with + | Nexp_aux (Nexp_constant i, _) -> string_of_int i + | Nexp_aux (Nexp_exp (Nexp_aux (Nexp_constant i, _)), _) -> + string_of_int (Util.power 2 i) | _ -> if dir then "0" else string_of_int (List.length iexps) in - let size = match len.nexp with - | Nconst i | N2n(_,Some i)-> string_of_big_int i - | N2n({nexp=Nconst i},_) -> string_of_int (Util.power 2 (int_of_big_int i)) - in + let size = match len with + | Nexp_aux (Nexp_constant i, _) -> string_of_int i + | Nexp_aux (Nexp_exp (Nexp_aux (Nexp_constant i, _)), _) -> + string_of_int (Util.power 2 i) + | _ -> + raise (Reporting_basic.err_unreachable l + "indexed vector without known length") in let default_string = (match default with | Def_val_empty -> string "None" @@ -394,7 +425,7 @@ let doc_exp_ocaml, doc_let_ocaml = default_string; string start; string size; - string dir_out])) + string dir_out]) | E_vector_update(v,e1,e2) -> (*Has never happened to date*) brackets (doc_op (string "with") (exp v) (doc_op equals (exp e1) (exp e2))) @@ -415,9 +446,9 @@ let doc_exp_ocaml, doc_let_ocaml = separate space [string "begin ret := Some" ; exp e ; string "; raise Sail_return; end"] | E_app_infix (e1,id,e2) -> let call = - match annot with + (* match annot with | Base((_,t),External(Some name),_,_,_,_) -> string name - | _ -> doc_id_ocaml id in + | _ -> *) doc_id_ocaml id in parens (separate space [call; parens (separate_map comma exp [e1;e2])]) | E_internal_let(lexp, eq_exp, in_exp) -> separate space [string "let"; @@ -461,37 +492,30 @@ let doc_exp_ocaml, doc_let_ocaml = | LEXP_id id | LEXP_cast(_,id) -> let name = doc_id_ocaml id in match annot,top_call with - | Base((_,{t=Tapp("reg",_)}),Emp_set,_,_,_,_),false | Base((_,{t=Tabbrev(_,{t=Tapp("reg",_)})}),Emp_set,_,_,_,_),false -> - string "!" ^^ name + | Some (env, _, _), false -> + (match Env.lookup_id id env with + | Local (Mutable, _) -> string "!" ^^ name + | _ -> name) | _ -> name and doc_lexp_array_ocaml ((LEXP_aux(lexp,(l,annot))) as le) = match lexp with | LEXP_vector(v,e) -> (match annot with - | Base((_,t),_,_,_,_,_) -> - let t_act = match t.t with | Tapp("reg",[TA_typ t]) | Tabbrev(_,{t=Tapp("reg",[TA_typ t])}) -> t | _ -> t in - (match t_act.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> - parens ((string "get_barray") ^^ space ^^ doc_lexp_ocaml false v) ^^ dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (top_exp false e)) - | _ -> parens ((string "get_varray") ^^ space ^^ doc_lexp_ocaml false v) ^^ dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (top_exp false e))) + | Some (env, t, _) -> + if (is_bit_typ (Env.base_typ_of env t)) + then parens ((string "get_barray") ^^ space ^^ doc_lexp_ocaml false v) ^^ dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (top_exp false e)) + else parens ((string "get_varray") ^^ space ^^ doc_lexp_ocaml false v) ^^ dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (top_exp false e)) | _ -> parens ((string "get_varray") ^^ space ^^ doc_lexp_ocaml false v) ^^ dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (top_exp false e))) | _ -> empty and doc_lexp_rwrite ((LEXP_aux(lexp,(l,annot))) as le) e_new_v = let exp = top_exp false in - let (is_bit,is_bitv) = match e_new_v with - | E_aux(_,(_,Base((_,t),_,_,_,_,_))) -> - (match t.t with - | Tapp("vector", [_;_;_;(TA_typ ({t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})}))]) | - Tabbrev(_,{t=Tapp("vector",[_;_;_;TA_typ ({t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})])}) | - Tapp("reg", [TA_typ {t= Tapp("vector", [_;_;_;(TA_typ ({t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})}))])}]) - -> - (false,true) - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) | Tapp("reg",[TA_typ ({t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) - -> (true,false) - | _ -> (false,false)) - | _ -> (false,false) in + let (is_bit,is_bitv) = match annot with + | Some (env, typ, _) -> + let typ = Env.base_typ_of env typ in + (is_bit_typ typ, is_bitvector_typ typ) + | _ -> (false, false) in match lexp with | LEXP_vector(v,e) -> if is_bit then (* XXX check whether register or not?? *) @@ -507,7 +531,7 @@ let doc_exp_ocaml, doc_let_ocaml = parens ((string (if is_bit then "set_register_field_bit" else "set_register_field_v")) ^^ space ^^ doc_lexp_ocaml false v ^^ space ^^string_lit (doc_id id) ^^ space ^^ exp e_new_v) | LEXP_id id | LEXP_cast (_,id) -> - (match annot with + (* (match annot with | Base(_,Alias alias_info,_,_,_,_) -> (match alias_info with | Alias_field(reg,field) -> @@ -525,8 +549,8 @@ let doc_exp_ocaml, doc_let_ocaml = string reg ^^ space ^^ doc_int start ^^ space ^^ doc_int stop ^^ space ^^ exp e_new_v) | Alias_pair(reg1,reg2) -> parens ((string "set_two_regs") ^^ space ^^ string reg1 ^^ space ^^ string reg2 ^^ space ^^ exp e_new_v)) - | _ -> - parens (separate space [string "set_register"; doc_id_ocaml id; exp e_new_v])) + | _ -> *) + parens (separate space [string "set_register"; doc_id_ocaml id; exp e_new_v]) and doc_lexp_fcall ((LEXP_aux(lexp,(l,annot))) as le) e_new_v = match lexp with | LEXP_memory(id,args) -> doc_id_ocaml id ^^ parens (separate_map comma (top_exp false) (args@[e_new_v])) @@ -536,8 +560,8 @@ let doc_exp_ocaml, doc_let_ocaml = (*TODO Upcase and downcase type and constructors as needed*) let doc_type_union_ocaml n (Tu_aux(typ_u,_)) = match typ_u with - | Tu_ty_id(typ,id) -> separate space [pipe; doc_id_ocaml_ctor n id; string "of"; doc_typ_ocaml typ;] - | Tu_id id -> separate space [pipe; doc_id_ocaml_ctor n id] + | Tu_ty_id(typ,id) -> separate space [pipe; doc_id_ocaml_ctor id; string "of"; doc_typ_ocaml typ;] + | Tu_id id -> separate space [pipe; doc_id_ocaml_ctor id] let rec doc_range_ocaml (BF_aux(r,_)) = match r with | BF_single i -> parens (doc_op comma (doc_int i) (doc_int i)) @@ -562,7 +586,7 @@ let doc_typdef_ocaml (TD_aux(td,_)) = match td with else (doc_typquant_ocaml typq ar_doc)) | TD_enum(id,nm,enums,_) -> let n = List.length enums in - let enums_doc = group (separate_map (break 1 ^^ pipe) (doc_id_ocaml_ctor n) enums) in + let enums_doc = group (separate_map (break 1 ^^ pipe) (doc_id_ocaml_ctor) enums) in doc_op equals (concat [string "type"; space; doc_id_ocaml_type id;]) (enums_doc) @@ -618,7 +642,7 @@ let doc_kdef_ocaml (KD_aux(kd,_)) = match kd with else (doc_typquant_ocaml typq ar_doc)) | KD_enum(_,id,nm,enums,_) -> let n = List.length enums in - let enums_doc = group (separate_map (break 1 ^^ pipe) (doc_id_ocaml_ctor n) enums) in + let enums_doc = group (separate_map (break 1 ^^ pipe) (doc_id_ocaml_ctor) enums) in doc_op equals (concat [string "type"; space; doc_id_ocaml_type id;]) (enums_doc) @@ -659,8 +683,9 @@ let doc_tannot_opt_ocaml (Typ_annot_opt_aux(t,_)) = match t with | Typ_annot_opt_some(tq,typ) -> doc_typquant_ocaml tq (doc_typ_ocaml typ) let doc_funcl_exp_ocaml (E_aux (e, (l, annot)) as ea) = match annot with - | Base((_,t),tag,nes,efct,efctsum,_) -> - if has_lret_effect efctsum then + | Some (_, t, efctsum) -> + (* | Base((_,t),tag,nes,efct,efctsum,_) -> *) + if has_effect efctsum BE_lret then separate hardline [string "let ret = ref None in"; string "try"; (doc_exp_ocaml ea); @@ -699,14 +724,16 @@ let doc_fundef_ocaml (FD_aux(FD_function(r, typa, efa, fcls),_)) = let doc_dec_ocaml (DEC_aux (reg,(l,annot))) = match reg with | DEC_reg(typ,id) -> - (match annot with + if is_vector_typ typ then + let (start, size, order, itemt) = vector_typ_args_of typ in + (* (match annot with | Base((_,t),_,_,_,_,_) -> (match t.t with | Tapp("register", [TA_typ {t= Tapp("vector", [TA_nexp start; TA_nexp size; TA_ord order; TA_typ itemt])}]) - | Tapp("register", [TA_typ {t= Tabbrev(_,{t=Tapp("vector", [TA_nexp start; TA_nexp size; TA_ord order; TA_typ itemt])})}]) -> - (match itemt.t,start.nexp,size.nexp with - | Tid "bit", Nconst start, Nconst size -> - let o = if order.order = Oinc then string "true" else string "false" in + | Tapp("register", [TA_typ {t= Tabbrev(_,{t=Tapp("vector", [TA_nexp start; TA_nexp size; TA_ord order; TA_typ itemt])})}]) -> *) + (match is_bit_typ itemt, start, size with + | true, Nexp_aux (Nexp_constant start, _), Nexp_aux (Nexp_constant size, _) -> + let o = if is_order_inc order then string "true" else string "false" in separate space [string "let"; doc_id_ocaml id; equals; @@ -714,22 +741,25 @@ let doc_dec_ocaml (DEC_aux (reg,(l,annot))) = parens (separate comma [separate space [string "ref"; parens (separate space [string "Array.make"; - doc_int (int_of_big_int size); + doc_int size; string "Vzero";])]; - doc_int (int_of_big_int start); + doc_int start; o; string_lit (doc_id id); brackets empty])] | _ -> empty) - | Tapp("register", [TA_typ {t=Tid idt}]) | - Tabbrev( {t= Tid idt}, _) -> + else + (match typ with + | Typ_aux (Typ_id idt, _) -> + (* | Tapp("register", [TA_typ {t=Tid idt}]) | + Tabbrev( {t= Tid idt}, _) -> *) separate space [string "let"; doc_id_ocaml id; equals; - doc_id_ocaml (Id_aux (Id idt, Unknown)); + doc_id_ocaml idt; string "None"] |_-> failwith "type was not handled in register declaration") - | _ -> failwith "annot was not Base") + (* | _ -> failwith "annot was not Base") *) | DEC_alias(id,alspec) -> empty (* doc_op equals (string "register alias" ^^ space ^^ doc_id id) (doc_alias alspec) *) | DEC_typ_alias(typ,id,alspec) -> empty (* @@ -744,6 +774,7 @@ let doc_def_ocaml def = group (match def with | DEF_reg_dec dec -> doc_dec_ocaml dec | DEF_scattered sdef -> empty (*shoulnd't still be here*) | DEF_kind k_def -> doc_kdef_ocaml k_def + | DEF_overload _ -> empty | DEF_comm _ -> failwith "unhandled DEF_comm" ) ^^ hardline @@ -753,4 +784,3 @@ let pp_defs_ocaml f d top_line opens = print f (string "(*" ^^ (string top_line) ^^ string "*)" ^/^ (separate_map hardline (fun lib -> (string "open") ^^ space ^^ (string lib)) opens) ^/^ (doc_defs_ocaml d)) - diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index 22cb707b..668e791c 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -40,7 +40,6 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal open Ast open PPrint open Pretty_print_common @@ -49,9 +48,6 @@ open Pretty_print_common * PPrint-based source-to-source pretty printer ****************************************************************************) - - - let doc_bkind (BK_aux(k,_)) = string (match k with | BK_type -> "Type" @@ -62,13 +58,18 @@ let doc_bkind (BK_aux(k,_)) = let doc_kind (K_aux(K_kind(klst),_)) = separate_map (spaces arrow) doc_bkind klst -let doc_nexp_constraint (NC_aux(nc,_)) = match nc with +let rec doc_nexp_constraint (NC_aux(nc,_)) = match nc with | NC_fixed(n1,n2) -> doc_op equals (doc_nexp n1) (doc_nexp n2) + | NC_not_equal (n1, n2) -> doc_op (string "!=") (doc_nexp n1) (doc_nexp n2) | NC_bounded_ge(n1,n2) -> doc_op (string ">=") (doc_nexp n1) (doc_nexp n2) | NC_bounded_le(n1,n2) -> doc_op (string "<=") (doc_nexp n1) (doc_nexp n2) | NC_nat_set_bounded(v,bounds) -> doc_op (string "IN") (doc_var v) - (braces (separate_map comma_sp doc_int bounds)) + (braces (separate_map comma_sp doc_int bounds)) + | NC_or (nc1, nc2) -> + parens (separate space [doc_nexp_constraint nc1; string "|"; doc_nexp_constraint nc2]) + | NC_and (nc1, nc2) -> + separate space [doc_nexp_constraint nc1; string "&"; doc_nexp_constraint nc2] let doc_qi (QI_aux(qi,_)) = match qi with | QI_const n_const -> doc_nexp_constraint n_const @@ -80,7 +81,7 @@ let doc_qi (QI_aux(qi,_)) = match qi with (* typ_doc is the doc for the type being quantified *) let doc_typquant (TypQ_aux(tq,_)) typ_doc = match tq with | TypQ_no_forall -> typ_doc - | TypQ_tq [] -> failwith "TypQ_tq with empty list" + | TypQ_tq [] -> typ_doc | TypQ_tq qlist -> (* include trailing break because the caller doesn't know if tq is empty *) doc_op dot @@ -103,8 +104,9 @@ let doc_lit (L_aux(l,_)) = | L_num i -> string_of_int i | L_hex n -> "0x" ^ n | L_bin n -> "0b" ^ n + | L_real r -> r | L_undef -> "undefined" - | L_string s -> "\"" ^ s ^ "\"") + | L_string s -> "\"" ^ String.escaped s ^ "\"") let doc_pat, doc_atomic_pat = let rec pat pa = pat_colons pa @@ -128,6 +130,7 @@ let doc_pat, doc_atomic_pat = | P_vector_indexed ipats -> brackets (separate_map comma_sp npat ipats) | P_tup pats -> parens (separate_map comma_sp atomic_pat pats) | P_list pats -> squarebarbars (separate_map semi_sp atomic_pat pats) + | P_cons (pat1, pat2) -> separate space [atomic_pat pat1; string "::"; pat pat2] | P_app(_, _ :: _) | P_vector_concat _ -> group (parens (pat pa)) and fpat (FP_aux(FP_Fpat(id,fpat),_)) = doc_op equals (doc_id id) (pat fpat) @@ -238,6 +241,7 @@ let doc_exp, doc_let = | E_id id -> doc_id id | E_lit lit -> doc_lit lit | E_cast(typ,e) -> prefix 2 1 (parens (doc_typ typ)) (group (atomic_exp e)) + (* | E_internal_cast((_,NoTyp),e) -> atomic_exp e | E_internal_cast((_,Base((_,t),_,_,_,_,bindings)), (E_aux(_,(_,eannot)) as e)) -> (match t.t,eannot with @@ -247,6 +251,7 @@ let doc_exp, doc_let = | Tapp("vector",[TA_nexp n1;_;_;_]),Base((_,{t=Tapp("vector",[TA_nexp n2;_;_;_])}),_,_,_,_,_) when nexp_eq n1 n2 -> atomic_exp e | _ -> prefix 2 1 (parens (doc_typ (t_to_typ t))) (group (atomic_exp e))) + *) | E_tuple exps -> parens (separate_map comma exp exps) | E_record(FES_aux(FES_Fexps(fexps,_),_)) -> @@ -290,7 +295,9 @@ let doc_exp, doc_let = let cases = separate_map (break 1) doc_case pexps in surround 2 1 opening cases rbrace | E_sizeof n -> - separate space [string "sizeof"; doc_nexp n] + separate space [string "sizeof"; doc_nexp n] + | E_constraint nc -> + string "constraint" ^^ parens (doc_nexp_constraint nc) | E_exit e -> separate space [string "exit"; atomic_exp e;] | E_return e -> @@ -325,6 +332,7 @@ let doc_exp, doc_let = (* doc_op (doc_id op) (exp l) (exp r) *) | E_comment s -> comment (string s) | E_comment_struc e -> comment (exp e) + (* | E_internal_exp((l, Base((_,t),_,_,_,_,bindings))) -> (*TODO use bindings, and other params*) (match t.t with | Tapp("register",[TA_typ {t=Tapp("vector",[TA_nexp _;TA_nexp r;_;_])}]) @@ -342,7 +350,7 @@ let doc_exp, doc_let = | _ -> raise (Reporting_basic.err_unreachable l ("Internal exp given non-vector, non-implicit " ^ t_to_string t))) | E_internal_exp_user _ -> raise (Reporting_basic.err_unreachable Unknown ("internal_exp_user not rewritten away")) | E_internal_cast ((_, Overload (_, _,_ )), _) | E_internal_exp _ -> assert false - + *) and let_exp (LB_aux(lb,_)) = match lb with | LB_val_explicit(ts,pat,e) -> (match ts with @@ -361,8 +369,12 @@ let doc_exp, doc_let = and doc_fexp (FE_aux(FE_Fexp(id,e),_)) = doc_op equals (doc_id id) (exp e) - and doc_case (Pat_aux(Pat_exp(pat,e),_)) = - doc_op arrow (separate space [string "case"; doc_atomic_pat pat]) (group (exp e)) + and doc_case (Pat_aux (pexp, _)) = + match pexp with + | Pat_exp(pat, e) -> + doc_op arrow (separate space [string "case"; doc_atomic_pat pat]) (group (exp e)) + | Pat_when(pat, guard, e) -> + doc_op arrow (separate space [string "case"; doc_atomic_pat pat; string "when"; exp guard]) (group (exp e)) (* lexps are parsed as eq_exp - we need to duplicate the precedence * structure for them *) @@ -391,16 +403,18 @@ let doc_exp, doc_let = let doc_default (DT_aux(df,_)) = match df with | DT_kind(bk,v) -> separate space [string "default"; doc_bkind bk; doc_var v] | DT_typ(ts,id) -> separate space [string "default"; doc_typscm ts; doc_id id] - | DT_order(ord) -> separate space [string "default"; string "order"; doc_ord ord] + | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] let doc_spec (VS_aux(v,_)) = match v with | VS_val_spec(ts,id) -> - separate space [string "val"; doc_typscm ts; doc_id id] + separate space [string "val"; doc_typscm ts; doc_id id] + | VS_cast_spec (ts, id) -> + separate space [string "val"; string "cast"; doc_typscm ts; doc_id id] | VS_extern_no_rename(ts,id) -> - separate space [string "val"; string "extern"; doc_typscm ts; doc_id id] + separate space [string "val"; string "extern"; doc_typscm ts; doc_id id] | VS_extern_spec(ts,id,s) -> - separate space [string "val"; string "extern"; doc_typscm ts; - doc_op equals (doc_id id) (dquotes (string s))] + separate space [string "val"; string "extern"; doc_typscm ts; + doc_op equals (doc_id id) (dquotes (string s))] let doc_namescm (Name_sect_aux(ns,_)) = match ns with | Name_sect_none -> empty @@ -479,10 +493,11 @@ let doc_rec (Rec_aux(r,_)) = match r with | Rec_nonrec -> empty (* include trailing space because caller doesn't know if we return * empty *) - | Rec_rec -> string "rec" ^^ space + | Rec_rec -> space ^^ string "rec" let doc_tannot_opt (Typ_annot_opt_aux(t,_)) = match t with - | Typ_annot_opt_some(tq,typ) -> doc_typquant tq (doc_typ typ) + | Typ_annot_opt_some(tq,typ) -> space ^^ doc_typquant tq (doc_typ typ) + | Typ_annot_opt_none -> empty let doc_effects_opt (Effect_opt_aux(e,_)) = match e with | Effect_opt_pure -> string "pure" @@ -497,8 +512,7 @@ let doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),_)) = | _ -> let sep = hardline ^^ string "and" ^^ space in let clauses = separate_map sep doc_funcl fcls in - separate space ([string "function"; - doc_rec r ^^ doc_tannot_opt typa;]@ + separate space ([string "function" ^^ doc_rec r ^^ doc_tannot_opt typa]@ (match efa with | Effect_opt_aux (Effect_opt_pure,_) -> [] | _ -> [string "effect"; @@ -549,6 +563,9 @@ let rec doc_def def = group (match def with | DEF_val lbind -> doc_let lbind | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef + | DEF_overload (id, ids) -> + let ids_doc = group (separate_map (semi ^^ break 1) doc_id ids) in + string "overload" ^^ space ^^ doc_id id ^^ space ^^ brackets ids_doc | DEF_comm (DC_comm s) -> comment (string s) | DEF_comm (DC_comm_struct d) -> comment (doc_def d) ) ^^ hardline diff --git a/src/pretty_print_t_ascii.ml b/src/pretty_print_t_ascii.ml deleted file mode 100644 index 273ceb29..00000000 --- a/src/pretty_print_t_ascii.ml +++ /dev/null @@ -1,152 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* *) -(* 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 Type_internal -open Ast -open Pretty_print_common -open Big_int - -(* ************************************************************************** - * pp from tannot to ASCII source, for pp of built-in type environment - *) - -let rec pp_format_t_ascii t = - match t.t with - | Tid i -> i - | Tvar i -> "'" ^ i - | Tfn(t1,t2,_,e) -> (pp_format_t_ascii t1) ^ " -> " ^ (pp_format_t_ascii t2) ^ (match e.effect with Eset [] -> "" | _ -> " effect " ^ pp_format_e_ascii e) - | Ttup(tups) -> "(" ^ (list_format ", " pp_format_t_ascii tups) ^ ")" - | Tapp(i,args) -> i ^ "<" ^ list_format ", " pp_format_targ_ascii args ^ ">" - | Tabbrev(ti,ta) -> (pp_format_t_ascii ti) (* (pp_format_t_ascii ta) *) - | Tuvar(_) -> failwith "Tuvar in pp_format_t_ascii" - | Toptions _ -> failwith "Toptions in pp_format_t_ascii" -and pp_format_targ_ascii = function - | TA_typ t -> pp_format_t_ascii t - | TA_nexp n -> pp_format_n_ascii n - | TA_eft e -> pp_format_e_ascii e - | TA_ord o -> pp_format_o_ascii o -and pp_format_n_ascii n = - match n.nexp with - | Nid (i, n) -> i (* from an abbreviation *) - | Nvar i -> "'" ^ i - | Nconst i -> (string_of_int (int_of_big_int i)) - | Npos_inf -> "infinity" - | Nadd(n1,n2) -> (pp_format_n_ascii n1) ^ "+" ^ (pp_format_n_ascii n2) - | Nsub(n1,n2) -> (pp_format_n_ascii n1) ^ "-" ^ (pp_format_n_ascii n2) - | Nmult(n1,n2) -> (pp_format_n_ascii n1) ^ "*" ^ (pp_format_n_ascii n2) - | N2n(n,_) -> "2**"^(pp_format_n_ascii n) (* string_of_big_int i ^ *) - | Nneg n -> "-" ^ (pp_format_n_ascii n) - | Nuvar _ -> failwith "Nuvar in pp_format_n_ascii" - | Nneg_inf -> "-infinity" - | Npow _ -> failwith "Npow in pp_format_n_ascii" - | Ninexact -> failwith "Ninexact in pp_format_n_ascii" -and pp_format_e_ascii e = - match e.effect with - | Evar i -> "'" ^ i - | Eset es -> "{" ^ - (list_format ", " pp_format_base_effect_ascii es) ^ "}" - | Euvar(_) -> failwith "Euvar in pp_format_e_ascii" -and pp_format_o_ascii o = - match o.order with - | Ovar i -> "'" ^ i - | Oinc -> "inc" - | Odec -> "dec" - | Ouvar(_) -> failwith "Ouvar in pp_format_o_ascii" -and pp_format_base_effect_ascii (BE_aux(e,l)) = - match e with - | BE_rreg -> "rreg" - | BE_wreg -> "wreg" - | BE_rmem -> "rmem" - | BE_rmemt -> "rmemt" - | BE_wmem -> "wmem" - | BE_wmv -> "wmv" - | BE_wmvt -> "wmvt" - | BE_eamem -> "eamem" - | BE_exmem -> "exmem" - | BE_barr -> "barr" - | BE_depend -> "depend" - | BE_undef -> "undef" - | BE_unspec -> "unspec" - | BE_nondet -> "nondet" - | BE_lset -> "lset" - | BE_lret -> "lret" - | BE_escape -> "escape" - -and pp_format_nes_ascii nes = - list_format ", " pp_format_ne_ascii nes - -and pp_format_ne_ascii ne = - match ne with - | Lt(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " < " ^ pp_format_n_ascii n2 - | LtEq(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " <= " ^ pp_format_n_ascii n2 - | NtEq(_,n1,n2) -> pp_format_n_ascii n1 ^ " != " ^ pp_format_n_ascii n2 - | Eq(_,n1,n2) -> pp_format_n_ascii n1 ^ " = " ^ pp_format_n_ascii n2 - | GtEq(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " >= " ^ pp_format_n_ascii n2 - | Gt(_,_,n1,n2) -> pp_format_n_ascii n1 ^ " > " ^ pp_format_n_ascii n2 - | In(_,i,ns) | InS(_,{nexp=Nvar i},ns) -> - i ^ " IN {" ^ (list_format ", " string_of_int ns)^ "}" - | InS(_,_,ns) -> (* when the variable has been replaced by a unification variable, we use this *) - failwith "InS in pp_format_nes_ascii" (*"(Nec_in \"fresh\" [" ^ (list_format "; " string_of_int ns)^ "])"*) - | Predicate(_,n1,n2) -> "flow_constraints(" ^ pp_format_ne_ascii n1 ^", "^ pp_format_ne_ascii n2 ^")" - | CondCons(_,_,_,nes_c,nes_t) -> - failwith "CondCons in pp_format_nes_ascii" (*"(Nec_cond " ^ (pp_format_nes nes_c) ^ " " ^ (pp_format_nes nes_t) ^ ")"*) - | BranchCons(_,_,nes_b) -> - failwith "BranchCons in pp_format_nes_ascii" (*"(Nec_branch " ^ (pp_format_nes nes_b) ^ ")"*) - -let rec pp_format_annot_ascii = function - | NoTyp -> "Nothing" - | Base((targs,t),tag,nes,efct,efctsum,_) -> - (*TODO print out bindings for use in pattern match in interpreter*) - (match tag with External (Some s) -> "("^s^") " | _ -> "") ^ - (match (targs,nes) with ([],[]) -> "\n" | _ -> - "forall " ^ list_format ", " (function (i,k) -> kind_to_string k ^" '"^ i) targs ^ - (match nes with [] -> "" | _ -> ", " ^ pp_format_nes_ascii nes) - ^ ".\n") ^ " " - ^ pp_format_t_ascii t - ^ "\n" -(* -^ " ********** " ^ pp_format_tag tag ^ ", " ^ pp_format_nes nes ^ ", " ^ - pp_format_e_lem efct ^ ", " ^ pp_format_e_lem efctsum ^ "))" -*) - | Overload (tannot, return_type_overloading_allowed, tannots) -> - (*pp_format_annot_ascii tannot*) "\n" ^ String.concat "" (List.map (function tannot' -> " " ^ pp_format_annot_ascii tannot' ) tannots) - diff --git a/src/process_file.ml b/src/process_file.ml index 273979cf..0601bfab 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -40,8 +40,6 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal - type out_type = | Lem_ast_out | Lem_out of string option @@ -57,7 +55,7 @@ let get_lexbuf fn = let parse_file (f : string) : Parse_ast.defs = let scanbuf = get_lexbuf f in - let type_names = + let type_names = try Pre_parser.file Pre_lexer.token scanbuf with @@ -81,27 +79,35 @@ let parse_file (f : string) : Parse_ast.defs = | Lexer.LexError(s,p) -> raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) + (*Should add a flag to say whether we want to consider Oinc or Odec the default order *) -let convert_ast (defs : Parse_ast.defs) : (Type_internal.tannot Ast.defs * kind Envmap.t * Ast.order)= - Initial_check.to_ast Nameset.empty Type_internal.initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown)) defs - -let initi_check_ast (defs : Type_internal.tannot Ast.defs) : (Type_internal.tannot Ast.defs * kind Envmap.t * Ast.order)= - Initial_check_full_ast.to_checked_ast Nameset.empty Type_internal.initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown)) defs - -let check_ast (defs : Type_internal.tannot Ast.defs) (k : kind Envmap.t) (o:Ast.order) : Type_internal.tannot Ast.defs * Type_check.envs = - let d_env = { Type_internal.k_env = k; Type_internal.abbrevs = Type_internal.initial_abbrev_env; - Type_internal.nabbrevs = Envmap.empty; - Type_internal.namesch = Envmap.empty; Type_internal.enum_env = Envmap.empty; - Type_internal.rec_env = []; Type_internal.alias_env = Envmap.empty; - Type_internal.default_o = - {Type_internal.order = (match o with | (Ast.Ord_aux(Ast.Ord_inc,_)) -> Type_internal.Oinc - | (Ast.Ord_aux(Ast.Ord_dec,_)) -> Type_internal.Odec - | _ -> Type_internal.Oinc)};} in - Type_check.check (Type_check.Env (d_env, Type_internal.initial_typ_env,Type_internal.nob,Envmap.empty)) defs - -let rewrite_ast (defs: Type_internal.tannot Ast.defs) = Rewriter.rewrite_defs defs -let rewrite_ast_lem (defs: Type_internal.tannot Ast.defs) = Rewriter.rewrite_defs_lem defs -let rewrite_ast_ocaml (defs: Type_internal.tannot Ast.defs) = Rewriter.rewrite_defs_ocaml defs +let convert_ast (defs : Parse_ast.defs) : unit Ast.defs = Initial_check.process_ast defs + +let load_file env f = + let ast = parse_file f in + let ast = convert_ast ast in + Type_check.check env ast + +let opt_new_typecheck = ref false +let opt_just_check = ref false +let opt_ddump_tc_ast = ref false +let opt_dno_cast = ref false + +let check_ast (defs : unit Ast.defs) : Type_check.tannot Ast.defs * Type_check.Env.t = + let ienv = if !opt_dno_cast then Type_check.Env.no_casts Type_check.initial_env else Type_check.initial_env in + let ast, env = Type_check.check ienv defs in + let () = if !opt_ddump_tc_ast then Pretty_print.pp_defs stdout ast else () in + let () = if !opt_just_check then exit 0 else () in + (ast, env) + +let monomorphise_ast locs ast = + let ast = Monomorphise.split_defs locs ast in + let ienv = Type_check.Env.no_casts Type_check.initial_env in + Type_check.check ienv ast + +let rewrite_ast (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs defs +let rewrite_ast_lem (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs_lem defs +let rewrite_ast_ocaml (defs: Type_check.tannot Ast.defs) = Rewriter.rewrite_defs_ocaml defs let open_output_with_check file_name = let (temp_file_name, o) = Filename.open_temp_file "ll_temp" "" in @@ -217,10 +223,8 @@ let output1 libpath out_arg filename defs = Pretty_print.pp_defs_ocaml o defs (generated_line filename) ["Big_int_Z"; "Sail_values"; lib]; close_output_with_check ext_o - let output libpath out_arg files = List.iter (fun (f, defs) -> output1 libpath out_arg f defs) files - diff --git a/src/process_file.mli b/src/process_file.mli index 2c18b830..b15523bb 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -41,12 +41,19 @@ (**************************************************************************) val parse_file : string -> Parse_ast.defs -val convert_ast : Parse_ast.defs -> Type_internal.tannot Ast.defs * Type_internal.kind Type_internal.Envmap.t * Ast.order -val initi_check_ast : Type_internal.tannot Ast.defs -> Type_internal.tannot Ast.defs * Type_internal.kind Type_internal.Envmap.t * Ast.order -val check_ast: Type_internal.tannot Ast.defs -> Type_internal.kind Type_internal.Envmap.t -> Ast.order -> Type_internal.tannot Ast.defs * Type_check.envs -val rewrite_ast: Type_internal.tannot Ast.defs -> Type_internal.tannot Ast.defs -val rewrite_ast_lem : Type_internal.tannot Ast.defs -> Type_internal.tannot Ast.defs -val rewrite_ast_ocaml : Type_internal.tannot Ast.defs -> Type_internal.tannot Ast.defs +val convert_ast : Parse_ast.defs -> unit Ast.defs +val check_ast: unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t +val monomorphise_ast : ((string * int) * string) list -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t +val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs + +val load_file : Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t + +val opt_new_typecheck : bool ref +val opt_just_check : bool ref +val opt_ddump_tc_ast : bool ref +val opt_dno_cast : bool ref type out_type = | Lem_ast_out @@ -56,7 +63,7 @@ type out_type = val output : string -> (* The path to the library *) out_type -> (* Backend kind *) - (string * Type_internal.tannot Ast.defs) list -> (*File names paired with definitions *) + (string * Type_check.tannot Ast.defs) list -> (*File names paired with definitions *) unit (** [always_replace_files] determines whether Sail only updates modified files. diff --git a/src/rewriter.ml b/src/rewriter.ml index d26879e9..166c31f0 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Thomas Bauereiss *) (* *) (* All rights reserved. *) (* *) @@ -42,19 +43,15 @@ open Big_int open Ast -open Type_internal +open Ast_util +open Type_check open Spec_analysis -type typ = Type_internal.t -type 'a exp = 'a Ast.exp -type 'a emap = 'a Envmap.t -type envs = Type_check.envs -type 'a namemap = (typ * 'a exp) emap type 'a rewriters = { - rewrite_exp : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a exp -> 'a exp; - rewrite_lexp : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a lexp -> 'a lexp; - rewrite_pat : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a pat -> 'a pat; - rewrite_let : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a letbind -> 'a letbind; + rewrite_exp : 'a rewriters -> 'a exp -> 'a exp; + rewrite_lexp : 'a rewriters -> 'a lexp -> 'a lexp; + rewrite_pat : 'a rewriters -> 'a pat -> 'a pat; + rewrite_let : 'a rewriters -> 'a letbind -> 'a letbind; rewrite_fun : 'a rewriters -> 'a fundef -> 'a fundef; rewrite_def : 'a rewriters -> 'a def -> 'a def; rewrite_defs : 'a rewriters -> 'a defs -> 'a defs; @@ -63,6 +60,23 @@ type 'a rewriters = { let (>>) f g = fun x -> g(f(x)) +let effect_of_fpat (FP_aux (_,(_,a))) = effect_of_annot a +let effect_of_lexp (LEXP_aux (_,(_,a))) = effect_of_annot a +let effect_of_fexp (FE_aux (_,(_,a))) = effect_of_annot a +let effect_of_fexps (FES_aux (FES_Fexps (fexps,_),_)) = + List.fold_left union_effects no_effect (List.map effect_of_fexp fexps) +let effect_of_opt_default (Def_val_aux (_,(_,a))) = effect_of_annot a +let effect_of_pexp (Pat_aux (_,(_,a))) = effect_of_annot a +let effect_of_lb (LB_aux (_,(_,a))) = effect_of_annot a + +let get_loc_exp (E_aux (_,(l,_))) = l + +let simple_annot l typ = (Parse_ast.Generated l, Some (Env.empty, typ, no_effect)) +let simple_num l n = E_aux ( + E_lit (L_aux (L_num n, Parse_ast.Generated l)), + simple_annot (Parse_ast.Generated l) + (atom_typ (Nexp_aux (Nexp_constant n, Parse_ast.Generated l)))) + let fresh_name_counter = ref 0 let fresh_name () = @@ -72,151 +86,162 @@ let fresh_name () = let reset_fresh_name_counter () = fresh_name_counter := 0 -let get_effsum_annot (_,t) = match t with - | Base (_,_,_,_,effs,_) -> effs - | NoTyp -> failwith "no effect information" - | _ -> failwith "get_effsum_annot doesn't support Overload" - -let get_localeff_annot (_,t) = match t with - | Base (_,_,_,eff,_,_) -> eff - | NoTyp -> failwith "no effect information" - | _ -> failwith "get_localeff_annot doesn't support Overload" - -let get_type_annot (_,t) = match t with - | Base((_,t),_,_,_,_,_) -> t - | NoTyp -> failwith "no type information" - | _ -> failwith "get_type_annot doesn't support Overload" - -let get_type (E_aux (_,a)) = get_type_annot a - -let union_effs effs = - List.fold_left (fun acc eff -> union_effects acc eff) pure_e effs - -let get_effsum_exp (E_aux (_,a)) = get_effsum_annot a -let get_effsum_fpat (FP_aux (_,a)) = get_effsum_annot a -let get_effsum_lexp (LEXP_aux (_,a)) = get_effsum_annot a -let get_effsum_fexp (FE_aux (_,a)) = get_effsum_annot a -let get_effsum_fexps (FES_aux (FES_Fexps (fexps,_),_)) = - union_effs (List.map get_effsum_fexp fexps) -let get_effsum_opt_default (Def_val_aux (_,a)) = get_effsum_annot a -let get_effsum_pexp (Pat_aux (_,a)) = get_effsum_annot a -let get_effsum_lb (LB_aux (_,a)) = get_effsum_annot a - -let eff_union_exps es = - union_effs (List.map get_effsum_exp es) - -let fix_effsum_exp (E_aux (e,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match e with - | E_block es -> eff_union_exps es - | E_nondet es -> eff_union_exps es +let fresh_id pre l = + let current = fresh_name () in + Id_aux (Id (pre ^ string_of_int current), Parse_ast.Generated l) + +let fresh_id_exp pre ((l,annot)) = + let id = fresh_id pre l in + E_aux (E_id id, (Parse_ast.Generated l, annot)) + +let fresh_id_pat pre ((l,annot)) = + let id = fresh_id pre l in + P_aux (P_id id, (Parse_ast.Generated l, annot)) + +let union_eff_exps es = + List.fold_left union_effects no_effect (List.map effect_of es) + +let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match e with + | E_block es -> union_eff_exps es + | E_nondet es -> union_eff_exps es | E_id _ - | E_lit _ -> pure_e - | E_cast (_,e) -> get_effsum_exp e + | E_lit _ -> no_effect + | E_cast (_,e) -> effect_of e | E_app (_,es) - | E_tuple es -> eff_union_exps es - | E_app_infix (e1,_,e2) -> eff_union_exps [e1;e2] - | E_if (e1,e2,e3) -> eff_union_exps [e1;e2;e3] - | E_for (_,e1,e2,e3,_,e4) -> eff_union_exps [e1;e2;e3;e4] - | E_vector es -> eff_union_exps es + | E_tuple es -> union_eff_exps es + | E_app_infix (e1,_,e2) -> union_eff_exps [e1;e2] + | E_if (e1,e2,e3) -> union_eff_exps [e1;e2;e3] + | E_for (_,e1,e2,e3,_,e4) -> union_eff_exps [e1;e2;e3;e4] + | E_vector es -> union_eff_exps es | E_vector_indexed (ies,opt_default) -> let (_,es) = List.split ies in - union_effs (get_effsum_opt_default opt_default :: List.map get_effsum_exp es) - | E_vector_access (e1,e2) -> eff_union_exps [e1;e2] - | E_vector_subrange (e1,e2,e3) -> eff_union_exps [e1;e2;e3] - | E_vector_update (e1,e2,e3) -> eff_union_exps [e1;e2;e3] - | E_vector_update_subrange (e1,e2,e3,e4) -> eff_union_exps [e1;e2;e3;e4] - | E_vector_append (e1,e2) -> eff_union_exps [e1;e2] - | E_list es -> eff_union_exps es - | E_cons (e1,e2) -> eff_union_exps [e1;e2] - | E_record fexps -> get_effsum_fexps fexps - | E_record_update(e,fexps) -> union_effs ((get_effsum_exp e)::[(get_effsum_fexps fexps)]) - | E_field (e,_) -> get_effsum_exp e - | E_case (e,pexps) -> union_effs (get_effsum_exp e :: List.map get_effsum_pexp pexps) - | E_let (lb,e) -> union_effs [get_effsum_lb lb;get_effsum_exp e] - | E_assign (lexp,e) -> union_effs [get_effsum_lexp lexp;get_effsum_exp e] - | E_exit e -> get_effsum_exp e - | E_return e -> get_effsum_exp e - | E_sizeof _ | E_sizeof_internal _ -> pure_e - | E_assert (c,m) -> pure_e - | E_comment _ | E_comment_struc _ -> pure_e - | E_internal_cast (_,e) -> get_effsum_exp e - | E_internal_exp _ -> pure_e - | E_internal_exp_user _ -> pure_e - | E_internal_let (lexp,e1,e2) -> union_effs [get_effsum_lexp lexp; - get_effsum_exp e1;get_effsum_exp e2] - | E_internal_plet (_,e1,e2) -> union_effs [get_effsum_exp e1;get_effsum_exp e2] - | E_internal_return e1 -> get_effsum_exp e1 + union_effects (effect_of_opt_default opt_default) (union_eff_exps es) + | E_vector_access (e1,e2) -> union_eff_exps [e1;e2] + | E_vector_subrange (e1,e2,e3) -> union_eff_exps [e1;e2;e3] + | E_vector_update (e1,e2,e3) -> union_eff_exps [e1;e2;e3] + | E_vector_update_subrange (e1,e2,e3,e4) -> union_eff_exps [e1;e2;e3;e4] + | E_vector_append (e1,e2) -> union_eff_exps [e1;e2] + | E_list es -> union_eff_exps es + | E_cons (e1,e2) -> union_eff_exps [e1;e2] + | E_record fexps -> effect_of_fexps fexps + | E_record_update(e,fexps) -> + union_effects (effect_of e) (effect_of_fexps fexps) + | E_field (e,_) -> effect_of e + | E_case (e,pexps) -> + List.fold_left union_effects (effect_of e) (List.map effect_of_pexp pexps) + | E_let (lb,e) -> union_effects (effect_of_lb lb) (effect_of e) + | E_assign (lexp,e) -> union_effects (effect_of_lexp lexp) (effect_of e) + | E_exit e -> effect_of e + | E_return e -> effect_of e + | E_sizeof _ | E_sizeof_internal _ -> no_effect + | E_assert (c,m) -> no_effect + | E_comment _ | E_comment_struc _ -> no_effect + | E_internal_cast (_,e) -> effect_of e + | E_internal_exp _ -> no_effect + | E_internal_exp_user _ -> no_effect + | E_internal_let (lexp,e1,e2) -> + union_effects (effect_of_lexp lexp) + (union_effects (effect_of e1) (effect_of e2)) + | E_internal_plet (_,e1,e2) -> union_effects (effect_of e1) (effect_of e2) + | E_internal_return e1 -> effect_of e1) in - E_aux (e,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let fix_effsum_lexp (LEXP_aux (lexp,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match lexp with - | LEXP_id _ -> pure_e - | LEXP_cast _ -> pure_e - | LEXP_memory (_,es) -> eff_union_exps es - | LEXP_vector (lexp,e) -> union_effs [get_effsum_lexp lexp;get_effsum_exp e] - | LEXP_vector_range (lexp,e1,e2) -> union_effs [get_effsum_lexp lexp;get_effsum_exp e1; - get_effsum_exp e2] - | LEXP_field (lexp,_) -> get_effsum_lexp lexp in - LEXP_aux (lexp,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let fix_effsum_fexp (FE_aux (fexp,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match fexp with - | FE_Fexp (_,e) -> get_effsum_exp e in - FE_aux (fexp,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let fix_effsum_fexps fexps = fexps (* FES_aux have no effect information *) - -let fix_effsum_opt_default (Def_val_aux (opt_default,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match opt_default with - | Def_val_empty -> pure_e - | Def_val_dec e -> get_effsum_exp e in - Def_val_aux (opt_default,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let fix_effsum_pexp (Pat_aux (pexp,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match pexp with - | Pat_exp (_,e) -> get_effsum_exp e in - Pat_aux (pexp,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let fix_effsum_lb (LB_aux (lb,(l,annot))) = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - let effsum = match lb with - | LB_val_explicit (_,_,e) -> get_effsum_exp e - | LB_val_implicit (_,e) -> get_effsum_exp e in - LB_aux (lb,(l,(Base (t,tag,nexps,eff,union_effects eff effsum,bounds)))) - -let effectful_effs {effect = Eset effs} = - List.exists - (fun (BE_aux (be,_)) -> - match be with - | BE_nondet | BE_unspec | BE_undef | BE_lset -> false - | _ -> true - ) effs - -let effectful eaux = effectful_effs (get_effsum_exp eaux) - -let updates_vars_effs {effect = Eset effs} = - List.exists - (fun (BE_aux (be,_)) -> - match be with - | BE_lset -> true - | _ -> false - ) effs - -let updates_vars eaux = updates_vars_effs (get_effsum_exp eaux) - - -let rec partial_assoc (eq: 'a -> 'a -> bool) (v: 'a) (ls : ('a *'b) list ) : 'b option = match ls with + E_aux (e, (l, Some (env, typ, effsum))) +| None -> + E_aux (e, (l, None)) + +let fix_eff_lexp (LEXP_aux (lexp,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match lexp with + | LEXP_id _ -> no_effect + | LEXP_cast _ -> no_effect + | LEXP_memory (_,es) -> union_eff_exps es + | LEXP_vector (lexp,e) -> union_effects (effect_of_lexp lexp) (effect_of e) + | LEXP_vector_range (lexp,e1,e2) -> + union_effects (effect_of_lexp lexp) + (union_effects (effect_of e1) (effect_of e2)) + | LEXP_field (lexp,_) -> effect_of_lexp lexp) in + LEXP_aux (lexp, (l, Some (env, typ, effsum))) +| None -> + LEXP_aux (lexp, (l, None)) + +let fix_eff_fexp (FE_aux (fexp,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match fexp with + | FE_Fexp (_,e) -> effect_of e) in + FE_aux (fexp, (l, Some (env, typ, effsum))) +| None -> + FE_aux (fexp, (l, None)) + +let fix_eff_fexps fexps = fexps (* FES_aux have no effect information *) + +let fix_eff_opt_default (Def_val_aux (opt_default,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match opt_default with + | Def_val_empty -> no_effect + | Def_val_dec e -> effect_of e) in + Def_val_aux (opt_default, (l, Some (env, typ, effsum))) +| None -> + Def_val_aux (opt_default, (l, None)) + +let fix_eff_pexp (Pat_aux (pexp,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match pexp with + | Pat_exp (_,e) -> effect_of e) in + Pat_aux (pexp, (l, Some (env, typ, effsum))) +| None -> + Pat_aux (pexp, (l, None)) + +let fix_eff_lb (LB_aux (lb,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> + let effsum = union_effects eff (match lb with + | LB_val_explicit (_,_,e) -> effect_of e + | LB_val_implicit (_,e) -> effect_of e) in + LB_aux (lb, (l, Some (env, typ, effsum))) +| None -> + LB_aux (lb, (l, None)) + +let effectful_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_nondet | BE_unspec | BE_undef | BE_lset -> false + | _ -> true + ) effs + | _ -> true + +let effectful eaux = effectful_effs (effect_of eaux) + +let updates_vars_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_lset -> true + | _ -> false + ) effs + | _ -> true + +let updates_vars eaux = updates_vars_effs (effect_of eaux) + +let id_to_string (Id_aux(id,l)) = + match id with + | Id(s) -> s + | DeIid(s) -> s + + +(*let rec partial_assoc (eq: 'a -> 'a -> bool) (v: 'a) (ls : ('a *'b) list ) : 'b option = match ls with | [] -> None | (v1,v2)::ls -> if (eq v1 v) then Some v2 else partial_assoc eq v ls let mk_atom_typ i = {t=Tapp("atom",[TA_nexp i])} +let simple_num l n : tannot exp = + let typ = simple_annot (mk_atom_typ (mk_c (big_int_of_int n))) in + E_aux (E_lit (L_aux (L_num n,l)), (l,typ)) + let rec rewrite_nexp_to_exp program_vars l nexp = let rewrite n = rewrite_nexp_to_exp program_vars l n in let typ = mk_atom_typ nexp in @@ -266,7 +291,7 @@ let rec match_to_program_vars ns bounds = | None -> match_to_program_vars ns bounds | Some(augment,ev) -> (*let _ = Printf.eprintf "adding n %s to program var %s\n" (n_to_string n) ev in*) - (n,(augment,ev))::(match_to_program_vars ns bounds) + (n,(augment,ev))::(match_to_program_vars ns bounds)*) let explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in @@ -303,17 +328,17 @@ let vector_string_to_bit_list l lit = | '1' -> L_aux (L_one,Parse_ast.Generated l) | _ -> raise (Reporting_basic.err_unreachable (Parse_ast.Generated l) "binary had non-zero or one")) s_bin -let rewrite_pat rewriters nmap (P_aux (pat,(l,annot))) = +let rewrite_pat rewriters (P_aux (pat,(l,annot))) = let rewrap p = P_aux (p,(l,annot)) in - let rewrite = rewriters.rewrite_pat rewriters nmap in + let rewrite = rewriters.rewrite_pat rewriters in match pat with | P_lit (L_aux ((L_hex _ | L_bin _) as lit,_)) -> - let ps = List.map (fun p -> P_aux (P_lit p,(Parse_ast.Generated l,simple_annot {t = Tid "bit"}))) + let ps = List.map (fun p -> P_aux (P_lit p, simple_annot l bit_typ)) (vector_string_to_bit_list l lit) in rewrap (P_vector ps) | P_lit _ | P_wild | P_id _ -> rewrap pat - | P_as(pat,id) -> rewrap (P_as( rewrite pat, id)) - | P_typ(typ,pat) -> rewrite pat + | P_as(pat,id) -> rewrap (P_as(rewrite pat, id)) + | P_typ(typ,pat) -> rewrap (P_typ(typ, rewrite pat)) | P_app(id ,pats) -> rewrap (P_app(id, List.map rewrite pats)) | P_record(fpats,_) -> rewrap (P_record(List.map (fun (FP_aux(FP_Fpat(id,pat),pannot)) -> FP_aux(FP_Fpat(id, rewrite pat), pannot)) fpats, @@ -323,16 +348,17 @@ let rewrite_pat rewriters nmap (P_aux (pat,(l,annot))) = | P_vector_concat pats -> rewrap (P_vector_concat (List.map rewrite pats)) | P_tup pats -> rewrap (P_tup (List.map rewrite pats)) | P_list pats -> rewrap (P_list (List.map rewrite pats)) + | P_cons (pat1, pat2) -> rewrap (P_cons (rewrite pat1, rewrite pat2)) -let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = +let rewrite_exp rewriters (E_aux (exp,(l,annot))) = let rewrap e = E_aux (e,(l,annot)) in - let rewrite = rewriters.rewrite_exp rewriters nmap in + let rewrite = rewriters.rewrite_exp rewriters in match exp with | E_comment _ | E_comment_struc _ -> rewrap exp | E_block exps -> rewrap (E_block (List.map rewrite exps)) | E_nondet exps -> rewrap (E_nondet (List.map rewrite exps)) | E_lit (L_aux ((L_hex _ | L_bin _) as lit,_)) -> - let es = List.map (fun p -> E_aux (E_lit p ,(Parse_ast.Generated l,simple_annot {t = Tid "bit"}))) + let es = List.map (fun p -> E_aux (E_lit p, simple_annot l bit_typ)) (vector_string_to_bit_list l lit) in rewrap (E_vector es) | E_id _ | E_lit _ -> rewrap exp @@ -374,15 +400,17 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = rewrap (E_case (rewrite exp, (List.map (fun (Pat_aux (Pat_exp(p,e),pannot)) -> - Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite e),pannot)) pexps))) - | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite body)) - | E_assign (lexp,exp) -> rewrap (E_assign(rewriters.rewrite_lexp rewriters nmap lexp,rewrite exp)) + Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters p,rewrite e),pannot)) pexps))) + | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters letbind,rewrite body)) + | E_assign (lexp,exp) -> rewrap (E_assign(rewriters.rewrite_lexp rewriters lexp,rewrite exp)) | E_sizeof n -> rewrap (E_sizeof n) | E_exit e -> rewrap (E_exit (rewrite e)) | E_return e -> rewrap (E_return (rewrite e)) | E_assert(e1,e2) -> rewrap (E_assert(rewrite e1,rewrite e2)) - | E_internal_cast ((l,casted_annot),exp) -> - let new_exp = rewrite exp in + | E_internal_cast (casted_annot,exp) -> + rewrap (E_internal_cast (casted_annot, rewrite exp)) + (* check_exp (env_of exp) (strip_exp exp) (typ_of_annot casted_annot) *) + (*let new_exp = rewrite exp in (*let _ = Printf.eprintf "Removing an internal_cast with %s\n" (tannot_to_string casted_annot) in*) (match casted_annot,exp with | Base((_,t),_,_,_,_,_),E_aux(ec,(ecl,Base((_,exp_t),_,_,_,_,_))) -> @@ -403,7 +431,7 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = rewrap (E_cast (Typ_aux (Typ_var (Kid_aux((Var "length"),Parse_ast.Generated l)), Parse_ast.Generated l),new_exp)) | _ -> new_exp)) - | _ -> new_exp) + | _ -> new_exp | Base((_,t),_,_,_,_,_),_ -> (*let _ = Printf.eprintf "Considering removing an internal cast where the remaining type is %s\n%!" (t_to_string t) in*) @@ -417,9 +445,9 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = Parse_ast.Generated l), new_exp)) | _ -> new_exp) | _ -> new_exp) - | _ -> (*let _ = Printf.eprintf "Not a base match?\n" in*) new_exp) - | E_internal_exp (l,impl) -> - (match impl with + | _ -> (*let _ = Printf.eprintf "Not a base match?\n" in*) new_exp*) + (*| E_internal_exp (l,impl) -> + match impl with | Base((_,t),_,_,_,_,bounds) -> (*let _ = Printf.eprintf "Rewriting internal expression, with type %s, and bounds %s\n" (t_to_string t) (bounds_to_string bounds) in*) @@ -445,8 +473,8 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp given unexpected types " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp given none Base annot"))) - | E_sizeof_internal (l,impl) -> + | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp given none Base annot"))*) + (*| E_sizeof_internal (l,impl) -> (match impl with | Base((_,t),_,_,_,_,bounds) -> let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in @@ -458,8 +486,8 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = | [] -> rewrite_nexp_to_exp None l n | map -> rewrite_nexp_to_exp (Some map) l n) | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had non-atom type " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had none base annot"))) - | E_internal_exp_user ((l,user_spec),(_,impl)) -> + | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had none base annot"))*) + (*| E_internal_exp_user ((l,user_spec),(_,impl)) -> (match (user_spec,impl) with | (Base((_,tu),_,_,_,_,_), Base((_,ti),_,_,_,_,bounds)) -> (*let _ = Printf.eprintf "E_interal_user getting rewritten two types are %s and %s\n" @@ -476,13 +504,14 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp_user given unexpected types " ^ (t_to_string tu) ^ ", " ^ (t_to_string ti)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp_user given none Base annot"))) + | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp_user given none Base annot")))*) | E_internal_let _ -> raise (Reporting_basic.err_unreachable l "Internal let found before it should have been introduced") | E_internal_return _ -> raise (Reporting_basic.err_unreachable l "Internal return found before it should have been introduced") | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l " Internal plet found before it should have been introduced") + | _ -> rewrap exp -let rewrite_let rewriters map (LB_aux(letbind,(l,annot))) = - let local_map = get_map_tannot annot in +let rewrite_let rewriters (LB_aux(letbind,(l,annot))) = + (*let local_map = get_map_tannot annot in let map = match map,local_map with | None,None -> None @@ -490,47 +519,47 @@ let rewrite_let rewriters map (LB_aux(letbind,(l,annot))) = | Some(m,s), None -> Some(m,s) | Some(m,s), Some m' -> match merge_option_maps (Some m) local_map with | None -> Some(m,s) (*Shouldn't happen*) - | Some new_m -> Some(new_m,s) in + | Some new_m -> Some(new_m,s) in*) match letbind with | LB_val_explicit (typschm, pat,exp) -> - LB_aux(LB_val_explicit (typschm,rewriters.rewrite_pat rewriters map pat, - rewriters.rewrite_exp rewriters map exp),(l,annot)) + LB_aux(LB_val_explicit (typschm,rewriters.rewrite_pat rewriters pat, + rewriters.rewrite_exp rewriters exp),(l,annot)) | LB_val_implicit ( pat, exp) -> - LB_aux(LB_val_implicit (rewriters.rewrite_pat rewriters map pat, - rewriters.rewrite_exp rewriters map exp),(l,annot)) + LB_aux(LB_val_implicit (rewriters.rewrite_pat rewriters pat, + rewriters.rewrite_exp rewriters exp),(l,annot)) -let rewrite_lexp rewriters map (LEXP_aux(lexp,(l,annot))) = +let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrap le = LEXP_aux(le,(l,annot)) in match lexp with | LEXP_id _ | LEXP_cast _ -> rewrap lexp - | LEXP_tup tupls -> rewrap (LEXP_tup (List.map (rewriters.rewrite_lexp rewriters map) tupls)) - | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters map) exps)) + | LEXP_tup tupls -> rewrap (LEXP_tup (List.map (rewriters.rewrite_lexp rewriters) tupls)) + | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters) exps)) | LEXP_vector (lexp,exp) -> - rewrap (LEXP_vector (rewriters.rewrite_lexp rewriters map lexp,rewriters.rewrite_exp rewriters map exp)) + rewrap (LEXP_vector (rewriters.rewrite_lexp rewriters lexp,rewriters.rewrite_exp rewriters exp)) | LEXP_vector_range (lexp,exp1,exp2) -> - rewrap (LEXP_vector_range (rewriters.rewrite_lexp rewriters map lexp, - rewriters.rewrite_exp rewriters map exp1, - rewriters.rewrite_exp rewriters map exp2)) - | LEXP_field (lexp,id) -> rewrap (LEXP_field (rewriters.rewrite_lexp rewriters map lexp,id)) + rewrap (LEXP_vector_range (rewriters.rewrite_lexp rewriters lexp, + rewriters.rewrite_exp rewriters exp1, + rewriters.rewrite_exp rewriters exp2)) + | LEXP_field (lexp,id) -> rewrap (LEXP_field (rewriters.rewrite_lexp rewriters lexp,id)) let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = let _ = reset_fresh_name_counter () in (*let _ = Printf.eprintf "Rewriting function %s, pattern %s\n" (match id with (Id_aux (Id i,_)) -> i) (Pretty_print.pat_to_string pat) in*) - let map = get_map_tannot fdannot in + (*let map = get_map_tannot fdannot in let map = match map with | None -> None - | Some m -> Some(m, Envmap.empty) in - (FCL_aux (FCL_Funcl (id,rewriters.rewrite_pat rewriters map pat, - rewriters.rewrite_exp rewriters map exp),(l,annot))) + | Some m -> Some(m, Envmap.empty) in*) + (FCL_aux (FCL_Funcl (id,rewriters.rewrite_pat rewriters pat, + rewriters.rewrite_exp rewriters exp),(l,annot))) in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) let rewrite_def rewriters d = match d with - | DEF_type _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_comm _ -> d + | DEF_type _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_comm _ | DEF_overload _ -> d | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef) - | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters None letbind) + | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind) | DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "DEF_scattered survived to rewritter") let rewrite_defs_base rewriters (Defs defs) = @@ -538,32 +567,40 @@ let rewrite_defs_base rewriters (Defs defs) = | [] -> [] | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) in Defs (rewrite defs) + +let rewriters_base = + {rewrite_exp = rewrite_exp; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} -let rewrite_defs (Defs defs) = rewrite_defs_base - {rewrite_exp = rewrite_exp; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} (Defs defs) +let rewrite_defs (Defs defs) = rewrite_defs_base rewriters_base (Defs defs) +module Envmap = Finite_map.Fmap_map(String) -let rec introduced_variables (E_aux (exp,(l,annot))) = +(* TODO: This seems to only consider a single assignment (or possibly two, in + separate branches of an if-expression). Hence, it seems the result is always + at most one variable. Is this intended? + It is only used below when pulling out local variables inside if-expressions + into the outer scope, which seems dubious. I comment it out for now. *) +(*let rec introduced_variables (E_aux (exp,(l,annot))) = match exp with | E_cast (typ, exp) -> introduced_variables exp | E_if (c,t,e) -> Envmap.intersect (introduced_variables t) (introduced_variables e) | E_assign (lexp,exp) -> introduced_vars_le lexp exp | _ -> Envmap.empty -and introduced_vars_le (LEXP_aux(lexp,(l,annot))) exp = +and introduced_vars_le (LEXP_aux(lexp,annot)) exp = match lexp with | LEXP_id (Id_aux (Id id,_)) | LEXP_cast(_,(Id_aux (Id id,_))) -> (match annot with | Base((_,t),Emp_intro,_,_,_,_) -> Envmap.insert Envmap.empty (id,(t,exp)) | _ -> Envmap.empty) - | _ -> Envmap.empty + | _ -> Envmap.empty*) type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = { p_lit : lit -> 'pat_aux @@ -656,6 +693,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_case : 'exp * 'pexp list -> 'exp_aux ; e_let : 'letbind * 'exp -> 'exp_aux ; e_assign : 'lexp * 'exp -> 'exp_aux + ; e_sizeof : nexp -> 'exp_aux ; e_exit : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux @@ -720,6 +758,7 @@ let rec fold_exp_aux alg = function | E_case (e,pexps) -> alg.e_case (fold_exp alg e, List.map (fold_pexp alg) pexps) | E_let (letbind,e) -> alg.e_let (fold_letbind alg letbind, fold_exp alg e) | E_assign (lexp,e) -> alg.e_assign (fold_lexp alg lexp, fold_exp alg e) + | E_sizeof nexp -> alg.e_sizeof nexp | E_exit e -> alg.e_exit (fold_exp alg e) | E_return e -> alg.e_return (fold_exp alg e) | E_assert(e1,e2) -> alg.e_assert (fold_exp alg e1, fold_exp alg e2) @@ -784,6 +823,7 @@ let id_exp_alg = ; e_case = (fun (e1,pexps) -> E_case (e1,pexps)) ; e_let = (fun (lb,e2) -> E_let (lb,e2)) ; e_assign = (fun (lexp,e2) -> E_assign (lexp,e2)) + ; e_sizeof = (fun nexp -> E_sizeof nexp) ; e_exit = (fun e1 -> E_exit (e1)) ; e_return = (fun e1 -> E_return e1) ; e_assert = (fun (e1,e2) -> E_assert(e1,e2)) @@ -816,7 +856,281 @@ let id_exp_alg = ; lB_aux = (fun (lb,annot) -> LB_aux (lb,annot)) ; pat_alg = id_pat_alg } - + +(* Folding algorithms for not only rewriting patterns/expressions, but also + computing some additional value. Usage: Pass default value (bot) and a + binary join operator as arguments, and specify the non-default cases of + rewriting/computation by overwriting fields of the record. + See rewrite_sizeof for examples. *) +let compute_pat_alg bot join = + let join_list vs = List.fold_left join bot vs in + let split_join f ps = let (vs,ps) = List.split ps in (join_list vs, f ps) in + { p_lit = (fun lit -> (bot, P_lit lit)) + ; p_wild = (bot, P_wild) + ; p_as = (fun ((v,pat),id) -> (v, P_as (pat,id))) + ; p_typ = (fun (typ,(v,pat)) -> (v, P_typ (typ,pat))) + ; p_id = (fun id -> (bot, P_id id)) + ; p_app = (fun (id,ps) -> split_join (fun ps -> P_app (id,ps)) ps) + ; p_record = (fun (ps,b) -> split_join (fun ps -> P_record (ps,b)) ps) + ; p_vector = split_join (fun ps -> P_vector ps) + ; p_vector_indexed = (fun ps -> + let (is,ps) = List.split ps in + let (vs,ps) = List.split ps in + (join_list vs, P_vector_indexed (List.combine is ps))) + ; p_vector_concat = split_join (fun ps -> P_vector_concat ps) + ; p_tup = split_join (fun ps -> P_tup ps) + ; p_list = split_join (fun ps -> P_list ps) + ; p_aux = (fun ((v,pat),annot) -> (v, P_aux (pat,annot))) + ; fP_aux = (fun ((v,fpat),annot) -> (v, FP_aux (fpat,annot))) + ; fP_Fpat = (fun (id,(v,pat)) -> (v, FP_Fpat (id,pat))) + } + +let compute_exp_alg bot join = + let join_list vs = List.fold_left join bot vs in + let split_join f es = let (vs,es) = List.split es in (join_list vs, f es) in + { e_block = split_join (fun es -> E_block es) + ; e_nondet = split_join (fun es -> E_nondet es) + ; e_id = (fun id -> (bot, E_id id)) + ; e_lit = (fun lit -> (bot, E_lit lit)) + ; e_cast = (fun (typ,(v,e)) -> (v, E_cast (typ,e))) + ; e_app = (fun (id,es) -> split_join (fun es -> E_app (id,es)) es) + ; e_app_infix = (fun ((v1,e1),id,(v2,e2)) -> (join v1 v2, E_app_infix (e1,id,e2))) + ; e_tuple = split_join (fun es -> E_tuple es) + ; e_if = (fun ((v1,e1),(v2,e2),(v3,e3)) -> (join_list [v1;v2;v3], E_if (e1,e2,e3))) + ; e_for = (fun (id,(v1,e1),(v2,e2),(v3,e3),order,(v4,e4)) -> + (join_list [v1;v2;v3;v4], E_for (id,e1,e2,e3,order,e4))) + ; e_vector = split_join (fun es -> E_vector es) + ; e_vector_indexed = (fun (es,(v2,opt2)) -> + let (is,es) = List.split es in + let (vs,es) = List.split es in + (join_list (vs @ [v2]), E_vector_indexed (List.combine is es,opt2))) + ; e_vector_access = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_vector_access (e1,e2))) + ; e_vector_subrange = (fun ((v1,e1),(v2,e2),(v3,e3)) -> (join_list [v1;v2;v3], E_vector_subrange (e1,e2,e3))) + ; e_vector_update = (fun ((v1,e1),(v2,e2),(v3,e3)) -> (join_list [v1;v2;v3], E_vector_update (e1,e2,e3))) + ; e_vector_update_subrange = (fun ((v1,e1),(v2,e2),(v3,e3),(v4,e4)) -> (join_list [v1;v2;v3;v4], E_vector_update_subrange (e1,e2,e3,e4))) + ; e_vector_append = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_vector_append (e1,e2))) + ; e_list = split_join (fun es -> E_list es) + ; e_cons = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_cons (e1,e2))) + ; e_record = (fun (vs,fexps) -> (vs, E_record fexps)) + ; e_record_update = (fun ((v1,e1),(vf,fexp)) -> (join v1 vf, E_record_update (e1,fexp))) + ; e_field = (fun ((v1,e1),id) -> (v1, E_field (e1,id))) + ; e_case = (fun ((v1,e1),pexps) -> + let (vps,pexps) = List.split pexps in + (join_list (v1::vps), E_case (e1,pexps))) + ; e_let = (fun ((vl,lb),(v2,e2)) -> (join vl v2, E_let (lb,e2))) + ; e_assign = (fun ((vl,lexp),(v2,e2)) -> (join vl v2, E_assign (lexp,e2))) + ; e_sizeof = (fun nexp -> (bot, E_sizeof nexp)) + ; e_exit = (fun (v1,e1) -> (v1, E_exit (e1))) + ; e_return = (fun (v1,e1) -> (v1, E_return e1)) + ; e_assert = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_assert(e1,e2)) ) + ; e_internal_cast = (fun (a,(v1,e1)) -> (v1, E_internal_cast (a,e1))) + ; e_internal_exp = (fun a -> (bot, E_internal_exp a)) + ; e_internal_exp_user = (fun (a1,a2) -> (bot, E_internal_exp_user (a1,a2))) + ; e_internal_let = (fun ((vl, lexp), (v2,e2), (v3,e3)) -> + (join_list [vl;v2;v3], E_internal_let (lexp,e2,e3))) + ; e_internal_plet = (fun ((vp,pat), (v1,e1), (v2,e2)) -> + (join_list [vp;v1;v2], E_internal_plet (pat,e1,e2))) + ; e_internal_return = (fun (v,e) -> (v, E_internal_return e)) + ; e_aux = (fun ((v,e),annot) -> (v, E_aux (e,annot))) + ; lEXP_id = (fun id -> (bot, LEXP_id id)) + ; lEXP_memory = (fun (id,es) -> split_join (fun es -> LEXP_memory (id,es)) es) + ; lEXP_cast = (fun (typ,id) -> (bot, LEXP_cast (typ,id))) + ; lEXP_tup = split_join (fun tups -> LEXP_tup tups) + ; lEXP_vector = (fun ((vl,lexp),(v2,e2)) -> (join vl v2, LEXP_vector (lexp,e2))) + ; lEXP_vector_range = (fun ((vl,lexp),(v2,e2),(v3,e3)) -> + (join_list [vl;v2;v3], LEXP_vector_range (lexp,e2,e3))) + ; lEXP_field = (fun ((vl,lexp),id) -> (vl, LEXP_field (lexp,id))) + ; lEXP_aux = (fun ((vl,lexp),annot) -> (vl, LEXP_aux (lexp,annot))) + ; fE_Fexp = (fun (id,(v,e)) -> (v, FE_Fexp (id,e))) + ; fE_aux = (fun ((vf,fexp),annot) -> (vf, FE_aux (fexp,annot))) + ; fES_Fexps = (fun (fexps,b) -> + let (vs,fexps) = List.split fexps in + (join_list vs, FES_Fexps (fexps,b))) + ; fES_aux = (fun ((vf,fexp),annot) -> (vf, FES_aux (fexp,annot))) + ; def_val_empty = (bot, Def_val_empty) + ; def_val_dec = (fun (v,e) -> (v, Def_val_dec e)) + ; def_val_aux = (fun ((v,defval),aux) -> (v, Def_val_aux (defval,aux))) + ; pat_exp = (fun ((vp,pat),(v,e)) -> (join vp v, Pat_exp (pat,e))) + ; pat_aux = (fun ((v,pexp),a) -> (v, Pat_aux (pexp,a))) + ; lB_val_explicit = (fun (typ,(vp,pat),(v,e)) -> (join vp v, LB_val_explicit (typ,pat,e))) + ; lB_val_implicit = (fun ((vp,pat),(v,e)) -> (join vp v, LB_val_implicit (pat,e))) + ; lB_aux = (fun ((vl,lb),annot) -> (vl,LB_aux (lb,annot))) + ; pat_alg = compute_pat_alg bot join + } + + +(* 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 (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, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id atom = "atom" -> + [nexp, E_id id] + | Typ_app (vector, _) when string_of_id vector = "vector" -> + let (_,len,_,_) = vector_typ_args_of typ_aux in + let exp = E_app + (Id_aux (Id "length", Parse_ast.Generated l), + [E_aux (E_id id, annot)]) in + [len, exp] + | _ -> []) + | _ -> [] 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 + (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 + + (* 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, ((l,_) as annot)) = + let full_exp = E_aux (exp, 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 current environment *) + let inst = instantiation_of full_exp in + let kid_exp kid = begin + match KBindings.find kid inst with + | U_nexp nexp -> E_aux (E_sizeof nexp, simple_annot l (atom_typ nexp)) + | _ -> + raise (Reporting_basic.err_unreachable l + ("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) + else full_exp + | _ -> full_exp 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,pat,exp), annot)) (funcls,nvars) = + let body_env = env_of exp in + let body_typ = typ_of exp in + let nmap = nexps_from_params pat in + (* first rewrite calls to other functions... *) + let exp' = fold_exp { id_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 + (FCL_aux (FCL_Funcl (id,pat,exp''), 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_kid kid), l)), + kid_annot kid)), kid_annot kid) in + let kid_eaux kid = E_id (Id_aux (Id (string_of_kid kid), 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, pat, exp), annot) as funcl) = + let rec rewrite_pat (P_aux (pat,(l,_)) as paux) = + if KidSet.is_empty nvars then paux else + match pat_typ_of paux with + | Typ_aux (Typ_tup _, _) -> + (match pat with + | P_tup pats -> + P_aux (P_tup (kid_pats @ pats), (l, None)) + | P_wild -> paux + | 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, None)) + | 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_basic.err_todo l + "rewriting as- or id-patterns for sizeof expressions not yet implemented") + | _ -> + raise (Reporting_basic.err_unreachable l + "unexpected pattern while rewriting function parameters for sizeof expressions")) + | _ -> P_aux (P_tup (kid_pats @ [paux]), (l, None)) in + let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in + FCL_aux (FCL_Funcl (id, rewrite_pat pat, exp'), annot) in + let funcls = List.map rewrite_funcl_params funcls in + (nvars, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in + + let rewrite_sizeof_fundef (params_map, defs) = function + | DEF_fundef fd -> + let (nvars, fd') = rewrite_sizeof_fun params_map fd 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', defs @ [DEF_fundef fd']) + | 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_arg, vtyp_ret, declared_eff), vl) -> + let vtyp_arg' = begin + match vtyp_arg with + | Typ_aux (Typ_tup typs, vl) -> + Typ_aux (Typ_tup (kid_typs @ typs), vl) + | _ -> Typ_aux (Typ_tup (kid_typs @ [vtyp_arg]), vl) + end in + Typ_aux (Typ_fn (vtyp_arg', vtyp_ret, declared_eff), vl) + | _ -> raise (Reporting_basic.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), a)) -> + DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id), a)) + | DEF_spec (VS_aux (VS_extern_no_rename (typschm, id), a)) -> + DEF_spec (VS_aux (VS_extern_no_rename (rewrite_typschm typschm id, id), a)) + | DEF_spec (VS_aux (VS_extern_spec (typschm, id, e), a)) -> + DEF_spec (VS_aux (VS_extern_spec (rewrite_typschm typschm id, id, e), a)) + | DEF_spec (VS_aux (VS_cast_spec (typschm, id), a)) -> + DEF_spec (VS_aux (VS_cast_spec (rewrite_typschm typschm id, id), a)) + | _ -> def in + + let (params_map, defs) = List.fold_left rewrite_sizeof_fundef + (Bindings.empty, []) defs in + let defs = List.map (rewrite_sizeof_valspec params_map) defs in + fst (check initial_env (Defs defs)) + let remove_vector_concat_pat pat = @@ -830,12 +1144,10 @@ let remove_vector_concat_pat pat = ) } in - let pat = remove_typed_patterns pat in + (* let pat = remove_typed_patterns pat in *) + + let fresh_id_v = fresh_id "v__" in - let fresh_name l = - let current = fresh_name () in - Id_aux (Id ("v__" ^ string_of_int current), Parse_ast.Generated l) in - (* expects that P_typ elements have been removed from AST, that the length of all vectors involved is known, that we don't have indexed vectors *) @@ -860,7 +1172,7 @@ let remove_vector_concat_pat pat = | P_vector_concat pats -> (if contained_in_p_as then P_aux (pat,annot) - else P_aux (P_as (P_aux (pat,annot),fresh_name l),annot)) + else P_aux (P_as (P_aux (pat,annot),fresh_id_v l),annot)) | _ -> P_aux (pat,annot) ) ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) @@ -872,10 +1184,11 @@ let remove_vector_concat_pat pat = (* introduce names for all unnamed child nodes of P_vector_concat *) let name_vector_concat_elements = let p_vector_concat pats = - let aux ((P_aux (p,((l,_) as a))) as pat) = match p with - | P_vector _ -> P_aux (P_as (pat,fresh_name l),a) + let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with + | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) | P_id id -> P_aux (P_id id,a) | P_as (p,id) -> P_aux (P_as (p,id),a) + | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) | P_wild -> P_aux (P_wild,a) | _ -> raise @@ -886,7 +1199,7 @@ let remove_vector_concat_pat pat = let pat = fold_pat name_vector_concat_elements pat in - + let rec tag_last = function | x :: xs -> let is_last = xs = [] in (x,is_last) :: tag_last xs @@ -903,102 +1216,78 @@ let remove_vector_concat_pat pat = pat_alg = *) (* build a let-expression of the form "let child = root[i..j] in body" *) - let letbind_vec (rootid,rannot) (child,cannot) (i,j) = + let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = let (l,_) = cannot in let (Id_aux (Id rootname,_)) = rootid in let (Id_aux (Id childname,_)) = child in - let simple_num n : tannot exp = - let typ = simple_annot (mk_atom_typ (mk_c (big_int_of_int n))) in - E_aux (E_lit (L_aux (L_num n,l)), (l,typ)) in - - let vlength_info (Base ((_,{t = Tapp("vector",[_;TA_nexp nexp;_;_])}),_,_,_,_,_)) = - nexp in - - let root : tannot exp = E_aux (E_id rootid,rannot) in - let index_i = simple_num i in - let index_j : tannot exp = match j with - | Some j -> simple_num j - | None -> - let length_root_nexp = vlength_info (snd rannot) in - let length_app_exp : tannot exp = - let typ = mk_atom_typ length_root_nexp in - let annot = (l,tag_annot typ (External (Some "length"))) in - E_aux (E_app (Id_aux (Id "length",l),[root]),annot) in - let minus = Id_aux (Id "-",l) in - let one_exp : tannot exp = - let typ = (mk_atom_typ (mk_c unit_big_int)) in - let annot = (l,simple_annot typ) in - E_aux (E_lit (L_aux (L_num 1,l)),annot) in - - let typ = mk_atom_typ (mk_sub length_root_nexp (mk_c unit_big_int)) in - let annot = (l,tag_annot typ (External (Some "minus"))) in - let exp : tannot exp = - E_aux (E_app_infix(length_app_exp,minus,one_exp),annot) in - exp in - - let subv = E_aux (E_app (Id_aux (Id "slice_raw",Unknown), - [root;index_i;index_j]),cannot) in - - let typ = (Parse_ast.Generated l,simple_annot {t = Tid "unit"}) in + let root = E_aux (E_id rootid, rannot) in + let index_i = simple_num l i in + let index_j = simple_num l j in - let letbind = LB_val_implicit (P_aux (P_id child,cannot),subv) in - (LB_aux (letbind,typ), - (fun body -> E_aux (E_let (LB_aux (letbind,cannot),body),typ)), + let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in + + let id_pat = + match typ_opt with + | Some typ -> P_aux (P_typ (typ, P_aux (P_id child,cannot)), cannot) + | None -> P_aux (P_id child,cannot) in + let letbind = fix_eff_lb (LB_aux (LB_val_implicit (id_pat,subv),cannot)) in + (letbind, + (fun body -> fix_eff_exp (E_aux (E_let (letbind,body), simple_annot l (typ_of body)))), (rootname,childname)) in let p_aux = function | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> - let aux (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = match cannot with - | (_,Base((_,{t = Tapp ("vector",[_;TA_nexp {nexp = Nconst length};_;_])}),_,_,_,_,_)) - | (_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",[_;TA_nexp {nexp = Nconst length};_;_])})}),_,_,_,_,_)) -> - let length = int_of_big_int length in + let rtyp = Env.base_typ_of (env_of_annot rannot') (typ_of_annot rannot') in + let (start,last_idx) = (match vector_typ_args_of rtyp with + | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> + (start, if is_order_inc ord then start + length - 1 else start - length + 1) + | _ -> + raise (Reporting_basic.err_unreachable (fst rannot') + ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in + let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = + let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in + let (_,length,ord,_) = vector_typ_args_of ctyp in + (*)| (_,length,ord,_) ->*) + let (pos',index_j) = match length with + | Nexp_aux (Nexp_constant i,_) -> + if is_order_inc ord then (pos+i, pos+i-1) + else (pos-i, pos-i+1) + | Nexp_aux (_,l) -> + if is_last then (pos,last_idx) + else + raise + (Reporting_basic.err_unreachable + l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in (match p with (* if we see a named vector pattern, remove the name and remember to declare it later *) | P_as (P_aux (p,cannot),cname) -> - let (lb,decl,info) = letbind_vec (rootid,rannot) (cname,cannot) (pos,Some(pos+length-1)) in - (pos + length, pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) (* if we see a P_id variable, remember to declare it later *) | P_id cname -> - let (lb,decl,info) = letbind_vec (rootid,rannot) (cname,cannot) (pos,Some(pos+length-1)) in - (pos + length, pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) + | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) (* normal vector patterns are fine *) - | _ -> (pos + length, pat_acc @ [P_aux (p,cannot)],decl_acc) ) + | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc) ) (* non-vector patterns aren't *) - | (l,Base((_,{t = Tapp ("vector",[_;_;_;_])}),_,_,_,_,_)) - | (l,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",[_;_;_;_])})}),_,_,_,_,_)) -> - if is_last then - match p with - (* if we see a named vector pattern, remove the name and remember to - declare it later *) - | P_as (P_aux (p,cannot),cname) -> - let (lb,decl,info) = letbind_vec (rootid,rannot) (cname,cannot) (pos,None) in - (pos, pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) - (* if we see a P_id variable, remember to declare it later *) - | P_id cname -> - let (lb,decl,info) = letbind_vec (rootid,rannot) (cname,cannot) (pos,None) in - (pos, pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) - (* normal vector patterns are fine *) - | _ -> (pos, pat_acc @ [P_aux (p,cannot)],decl_acc) - else + (*)| _ -> raise (Reporting_basic.err_unreachable - l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) - | (l,Base((_,t),_,_,_,_,_)) -> - raise - (Reporting_basic.err_unreachable - l ("unname_vector_concat_elements: Non-vector in vector-concat pattern:" ^ - t_to_string t) - ) in + (fst cannot) + ("unname_vector_concat_elements: Non-vector in vector-concat pattern:" ^ + string_of_typ (typ_of_annot cannot)) + )*) in let pats_tagged = tag_last pats in - let (_,pats',decls') = List.fold_left aux (0,[],[]) pats_tagged in + let (_,pats',decls') = List.fold_left (aux None) (start,[],[]) pats_tagged in (* abuse P_vector_concat as a P_vector_const pattern: it has the of patterns as an argument but they're meant to be consed together *) (P_aux (P_as (P_aux (P_vector_concat pats',rannot'),rootid),rannot), decls @ decls') | ((p,decls),annot) -> (P_aux (p,annot),decls) in - + { p_lit = (fun lit -> (P_lit lit,[])) ; p_wild = (P_wild,[]) ; p_as = (fun ((pat,decls),id) -> (P_as (pat,id),decls)) @@ -1079,41 +1368,28 @@ let remove_vector_concat_pat pat = let remove_vector_concats = let p_vector_concat ps = let aux acc (P_aux (p,annot),is_last) = + let env = env_of_annot annot in + let typ = Env.base_typ_of env (typ_of_annot annot) in + let eff = effect_of_annot (snd annot) in let (l,_) = annot in - match p,annot with - | P_vector ps,_ -> acc @ ps - | P_id _,(_,Base((_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])}),_,_,_,_,_)) - | P_id _,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",[_;TA_nexp {nexp = Nconst length};_;_])})}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])})}),_,_,_,_,_)) -> - let wild _ = P_aux (P_wild,(Parse_ast.Generated l,simple_annot {t = Tid "bit"})) in - acc @ (List.map wild (range 0 ((int_of_big_int length) - 1))) - | P_id _,(_,Base((_,{t = Tapp ("vector", _)}),_,_,_,_,_)) - | P_id _,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",_)})}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tapp ("vector", _)}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector", _)})}),_,_,_,_,_)) - when is_last -> - let wild _ = P_aux (P_wild,(Parse_ast.Generated l,simple_annot {t = Tid "bit"})) in - acc @ [P_aux(P_wild,annot)] - | P_lit _,(l,_) -> - raise (Reporting_basic.err_unreachable l "remove_vector_concats: P_lit pattern in vector-concat pattern") - | _,(l,Base((_,t),_,_,_,_,_)) -> - raise (Reporting_basic.err_unreachable l ("remove_vector_concats: Non-vector in vector-concat pattern " ^ - t_to_string t)) in + let wild _ = P_aux (P_wild,(Parse_ast.Generated l, Some (env, bit_typ, eff))) in + if is_vector_typ typ then + match p, vector_typ_args_of typ with + | P_vector ps,_ -> acc @ ps + | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> + acc @ (List.map wild (range 0 (length - 1))) + | _, _ -> + (*if is_last then*) acc @ [wild 0] + else raise + (Reporting_basic.err_unreachable l + ("remove_vector_concats: Non-vector in vector-concat pattern " ^ + string_of_typ (typ_of_annot annot))) in let has_length (P_aux (p,annot)) = - match p,annot with - | P_vector _,_ -> true - | P_id _,(_,Base((_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])}),_,_,_,_,_)) - | P_id _,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",[_;TA_nexp {nexp = Nconst length};_;_])})}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector", [_;TA_nexp {nexp = Nconst length};_;_])})}),_,_,_,_,_)) -> - true - | P_id _,(_,Base((_,{t = Tapp ("vector", _)}),_,_,_,_,_)) - | P_id _,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector",_)})}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tapp ("vector", _)}),_,_,_,_,_)) - | P_wild,(_,Base((_,{t = Tabbrev (_,{t = Tapp ("vector", _)})}),_,_,_,_,_)) -> - false in + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + match vector_typ_args_of typ with + | (_,Nexp_aux (Nexp_constant length,_),_,_) -> true + | _ -> false in let ps_tagged = tag_last ps in let ps' = List.fold_left aux [] ps_tagged in @@ -1135,16 +1411,16 @@ let remove_vector_concat_pat pat = (pat,letbinds,decls) (* assumes there are no more E_internal expressions *) -let rewrite_exp_remove_vector_concat_pat rewriters nmap (E_aux (exp,(l,annot)) as full_exp) = +let rewrite_exp_remove_vector_concat_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters nmap in - let rewrite_base = rewrite_exp rewriters nmap in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in match exp with | E_case (e,ps) -> let aux (Pat_aux (Pat_exp (pat,body),annot')) = let (pat,_,decls) = remove_vector_concat_pat pat in - Pat_aux (Pat_exp (pat,decls (rewrite_rec body)),annot') in - rewrap (E_case (rewrite_rec e,List.map aux ps)) + Pat_aux (Pat_exp (pat, decls (rewrite_rec body)),annot') in + rewrap (E_case (rewrite_rec e, List.map aux ps)) | E_let (LB_aux (LB_val_explicit (typ,pat,v),annot'),body) -> let (pat,_,decls) = remove_vector_concat_pat pat in rewrap (E_let (LB_aux (LB_val_explicit (typ,pat,rewrite_rec v),annot'), @@ -1158,11 +1434,20 @@ let rewrite_exp_remove_vector_concat_pat rewriters nmap (E_aux (exp,(l,annot)) a let rewrite_fun_remove_vector_concat_pat rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = - let (pat,_,decls) = remove_vector_concat_pat pat in - (FCL_aux (FCL_Funcl (id,pat,rewriters.rewrite_exp rewriters None (decls exp)),(l,annot))) + let (pat',_,decls) = remove_vector_concat_pat pat in + let exp' = decls (rewriters.rewrite_exp rewriters exp) in + (FCL_aux (FCL_Funcl (id,pat',exp'),(l,annot))) in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) -let rewrite_defs_remove_vector_concat_pat rewriters (Defs defs) = +let rewrite_defs_remove_vector_concat (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_vector_concat_pat; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun_remove_vector_concat_pat; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} in let rewrite_def d = let d = rewriters.rewrite_def rewriters d in match d with @@ -1174,41 +1459,464 @@ let rewrite_defs_remove_vector_concat_pat rewriters (Defs defs) = let (pat,letbinds,_) = remove_vector_concat_pat pat in let defvals = List.map (fun lb -> DEF_val lb) letbinds in [DEF_val (LB_aux (LB_val_implicit (pat,exp),a))] @ defvals - | d -> [rewriters.rewrite_def rewriters d] in + | d -> [d] in Defs (List.flatten (List.map rewrite_def defs)) -let rewrite_defs_remove_vector_concat defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_remove_vector_concat_pat; +let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with +| P_lit _ | P_wild | P_id _ -> false +| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat +| P_vector _ | P_vector_concat _ | P_vector_indexed _ -> + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + is_bitvector_typ typ +| P_app (_,pats) | P_tup pats | P_list pats -> + List.exists contains_bitvector_pat pats +| P_record (fpats,_) -> + List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats + +let remove_bitvector_pat pat = + + (* first introduce names for bitvector patterns *) + let name_bitvector_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) + ; p_record = (fun (fpats,b) -> P_record (fpats, b)) + ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) + ; p_vector_indexed = (fun ps -> P_vector_indexed (List.map (fun (i,p) -> (i,p false)) ps)) + ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) + ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) + ; p_aux = + (fun (pat,annot) contained_in_p_as -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + let (l,_) = annot in + match pat, is_bitvector_typ t, contained_in_p_as with + | P_vector _, true, false + | P_vector_indexed _, true, false -> + P_aux (P_as (P_aux (pat,annot),fresh_id "b__" l), annot) + | _ -> P_aux (pat,annot) + ) + ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + let pat = (fold_pat name_bitvector_roots pat) false in + + (* Then collect guard expressions testing whether the literal bits of a + bitvector pattern match those of a given bitvector, and collect let + bindings for the bits bound by P_id or P_as patterns *) + + (* Helper functions for generating guard expressions *) + let access_bit_exp (rootid,rannot) l idx = + let root : tannot exp = E_aux (E_id rootid,rannot) in + E_aux (E_vector_access (root,simple_num l idx), simple_annot l bit_typ) in + + let test_bit_exp rootid l t idx exp = + let rannot = simple_annot l t in + let elem = access_bit_exp (rootid,rannot) l idx in + let eqid = Id_aux (Id "eq", Parse_ast.Generated l) in + let eqannot = simple_annot l bool_typ in + let eqexp : tannot exp = E_aux (E_app(eqid,[elem;exp]), eqannot) in + Some (eqexp) in + + let test_subvec_exp rootid l typ i j lits = + let (start, length, ord, _) = vector_typ_args_of typ in + let length' = nconstant (List.length lits) in + let start' = + if is_order_inc ord then nconstant 0 + else nminus length' (nconstant 1) in + let typ' = vector_typ start' length' ord bit_typ in + let subvec_exp = + match start, length with + | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) + when s = i && l = List.length lits -> + E_id rootid + | _ -> + (*if vec_start t = i && vec_length t = List.length lits + then E_id rootid + else*) E_vector_subrange ( + E_aux (E_id rootid, simple_annot l typ), + simple_num l i, + simple_num l j) in + E_aux (E_app( + Id_aux (Id "eq_vec", Parse_ast.Generated l), + [E_aux (subvec_exp, simple_annot l typ'); + E_aux (E_vector lits, simple_annot l typ')]), + simple_annot l bool_typ) in + + let letbind_bit_exp rootid l typ idx id = + let rannot = simple_annot l typ in + let elem = access_bit_exp (rootid,rannot) l idx in + let e = P_aux (P_id id, simple_annot l bit_typ) in + let letbind = LB_aux (LB_val_implicit (e,elem), simple_annot l bit_typ) in + let letexp = (fun body -> + let (E_aux (_,(_,bannot))) = body in + E_aux (E_let (letbind,body), (Parse_ast.Generated l, bannot))) in + (letexp, letbind) in + + (* Helper functions for composing guards *) + let bitwise_and exp1 exp2 = + let (E_aux (_,(l,_))) = exp1 in + let andid = Id_aux (Id "bool_and", Parse_ast.Generated l) in + E_aux (E_app(andid,[exp1;exp2]), simple_annot l bool_typ) in + + let compose_guards guards = + List.fold_right (Util.option_binop bitwise_and) guards None in + + let flatten_guards_decls gd = + let (guards,decls,letbinds) = Util.split3 gd in + (compose_guards guards, (List.fold_right (@@) decls), List.flatten letbinds) in + + (* Collect guards and let bindings *) + let guard_bitvector_pat = + let collect_guards_decls ps rootid t = + let (start,_,ord,_) = vector_typ_args_of t in + let rec collect current (guards,dls) idx ps = + let idx' = if is_order_inc ord then idx + 1 else idx - 1 in + (match ps with + | pat :: ps' -> + (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let e = E_aux (E_lit lit, (Parse_ast.Generated l, annot)) in + let current' = (match current with + | Some (l,i,j,lits) -> Some (l,i,idx,lits @ [e]) + | None -> Some (l,idx,idx,[e])) in + collect current' (guards, dls) idx' ps' + | P_aux (P_as (pat',id), (l,annot)) -> + let dl = letbind_bit_exp rootid l t idx id in + collect current (guards, dls @ [dl]) idx (pat' :: ps') + | _ -> + let dls' = (match pat with + | P_aux (P_id id, (l,annot)) -> + dls @ [letbind_bit_exp rootid l t idx id] + | _ -> dls) in + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + collect None (guards', dls') idx' ps') + | [] -> + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + (guards',dls)) in + let (guards,dls) = match start with + | Nexp_aux (Nexp_constant s, _) -> + collect None ([],[]) s ps + | _ -> + let (P_aux (_, (l,_))) = pat in + raise (Reporting_basic.err_unreachable l + "guard_bitvector_pat called on pattern with non-constant start index") in + let (decls,letbinds) = List.split dls in + (compose_guards guards, List.fold_right (@@) decls, letbinds) in + + let collect_guards_decls_indexed ips rootid t = + let rec guard_decl (idx,pat) = (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let exp = E_aux (E_lit lit, (l,annot)) in + (test_bit_exp rootid l t idx exp, (fun b -> b), []) + | P_aux (P_as (pat',id), (l,annot)) -> + let (guard,decls,letbinds) = guard_decl (idx,pat') in + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (guard, decls >> letexp, letbind :: letbinds) + | P_aux (P_id id, (l,annot)) -> + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (None, letexp, [letbind]) + | _ -> (None, (fun b -> b), [])) in + let (guards,decls,letbinds) = Util.split3 (List.map guard_decl ips) in + (compose_guards guards, List.fold_right (@@) decls, List.flatten letbinds) in + + { p_lit = (fun lit -> (P_lit lit, (None, (fun b -> b), []))) + ; p_wild = (P_wild, (None, (fun b -> b), [])) + ; p_as = (fun ((pat,gdls),id) -> (P_as (pat,id), gdls)) + ; p_typ = (fun (typ,(pat,gdls)) -> (P_typ (typ,pat), gdls)) + ; p_id = (fun id -> (P_id id, (None, (fun b -> b), []))) + ; p_app = (fun (id,ps) -> let (ps,gdls) = List.split ps in + (P_app (id,ps), flatten_guards_decls gdls)) + ; p_record = (fun (ps,b) -> let (ps,gdls) = List.split ps in + (P_record (ps,b), flatten_guards_decls gdls)) + ; p_vector = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector ps, flatten_guards_decls gdls)) + ; p_vector_indexed = (fun p -> let (is,p) = List.split p in + let (ps,gdls) = List.split p in + let ps = List.combine is ps in + (P_vector_indexed ps, flatten_guards_decls gdls)) + ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector_concat ps, flatten_guards_decls gdls)) + ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in + (P_tup ps, flatten_guards_decls gdls)) + ; p_list = (fun ps -> let (ps,gdls) = List.split ps in + (P_list ps, flatten_guards_decls gdls)) + ; p_aux = (fun ((pat,gdls),annot) -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + (match pat, is_bitvector_typ t with + | P_as (P_aux (P_vector ps, _), id), true -> + (P_aux (P_id id, annot), collect_guards_decls ps id t) + | P_as (P_aux (P_vector_indexed ips, _), id), true -> + (P_aux (P_id id, annot), collect_guards_decls_indexed ips id t) + | _, _ -> (P_aux (pat,annot), gdls))) + ; fP_aux = (fun ((fpat,gdls),annot) -> (FP_aux (fpat,annot), gdls)) + ; fP_Fpat = (fun (id,(pat,gdls)) -> (FP_Fpat (id,pat), gdls)) + } in + fold_pat guard_bitvector_pat pat + +let remove_wildcards pre (P_aux (_,(l,_)) as pat) = + fold_pat + {id_pat_alg with + p_aux = function + | (P_wild,(l,annot)) -> P_aux (P_id (fresh_id pre l),(l,annot)) + | (p,annot) -> P_aux (p,annot) } + pat + +(* Check if one pattern subsumes the other, and if so, calculate a + substitution of variables that are used in the same position. + TODO: Check somewhere that there are no variable clashes (the same variable + name used in different positions of the patterns) + *) +let rec subsumes_pat (P_aux (p1,annot1) as pat1) (P_aux (p2,annot2) as pat2) = + let rewrap p = P_aux (p,annot1) in + let subsumes_list s pats1 pats2 = + if List.length pats1 = List.length pats2 + then + let subs = List.map2 s pats1 pats2 in + List.fold_right + (fun p acc -> match p, acc with + | Some subst, Some substs -> Some (subst @ substs) + | _ -> None) + subs (Some []) + else None in + match p1, p2 with + | P_lit (L_aux (lit1,_)), P_lit (L_aux (lit2,_)) -> + if lit1 = lit2 then Some [] else None + | P_as (pat1,_), _ -> subsumes_pat pat1 pat2 + | _, P_as (pat2,_) -> subsumes_pat pat1 pat2 + | P_typ (_,pat1), _ -> subsumes_pat pat1 pat2 + | _, P_typ (_,pat2) -> subsumes_pat pat1 pat2 + | P_id (Id_aux (id1,_) as aid1), P_id (Id_aux (id2,_) as aid2) -> + if id1 = id2 then Some [] + else if Env.lookup_id aid1 (env_of_annot annot1) = Unbound && + Env.lookup_id aid2 (env_of_annot annot2) = Unbound + then Some [(id2,id1)] else None + | P_id id1, _ -> + if Env.lookup_id id1 (env_of_annot annot1) = Unbound then Some [] else None + | P_wild, _ -> Some [] + | P_app (Id_aux (id1,l1),args1), P_app (Id_aux (id2,_),args2) -> + if id1 = id2 then subsumes_list subsumes_pat args1 args2 else None + | P_record (fps1,b1), P_record (fps2,b2) -> + if b1 = b2 then subsumes_list subsumes_fpat fps1 fps2 else None + | P_vector pats1, P_vector pats2 + | P_vector_concat pats1, P_vector_concat pats2 + | P_tup pats1, P_tup pats2 + | P_list pats1, P_list pats2 -> + subsumes_list subsumes_pat pats1 pats2 + | P_vector_indexed ips1, P_vector_indexed ips2 -> + let (is1,ps1) = List.split ips1 in + let (is2,ps2) = List.split ips2 in + if is1 = is2 then subsumes_list subsumes_pat ps1 ps2 else None + | _ -> None +and subsumes_fpat (FP_aux (FP_Fpat (id1,pat1),_)) (FP_aux (FP_Fpat (id2,pat2),_)) = + if id1 = id2 then subsumes_pat pat1 pat2 else None + +let equiv_pats pat1 pat2 = + match subsumes_pat pat1 pat2, subsumes_pat pat2 pat1 with + | Some _, Some _ -> true + | _, _ -> false + +let subst_id_pat pat (id1,id2) = + let p_id (Id_aux (id,l)) = (if id = id1 then P_id (Id_aux (id2,l)) else P_id (Id_aux (id,l))) in + fold_pat {id_pat_alg with p_id = p_id} pat + +let subst_id_exp exp (id1,id2) = + (* TODO Don't substitute bound occurrences inside let expressions etc *) + let e_id (Id_aux (id,l)) = (if id = id1 then E_id (Id_aux (id2,l)) else E_id (Id_aux (id,l))) in + fold_exp {id_exp_alg with e_id = e_id} exp + +let rec pat_to_exp (P_aux (pat,(l,annot))) = + let rewrap e = E_aux (e,(l,annot)) in + match pat with + | P_lit lit -> rewrap (E_lit lit) + | P_wild -> raise (Reporting_basic.err_unreachable l + "pat_to_exp given wildcard pattern") + | P_as (pat,id) -> rewrap (E_id id) + | P_typ (_,pat) -> pat_to_exp pat + | P_id id -> rewrap (E_id id) + | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) + | P_record (fpats,b) -> + rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) + | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) + | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l + "pat_to_exp not implemented for P_vector_concat") + (* We assume that vector concatenation patterns have been transformed + away already *) + | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) + | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) + | P_vector_indexed ipats -> raise (Reporting_basic.err_unreachable l + "pat_to_exp not implemented for P_vector_indexed") (* TODO *) +and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = + FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) + +let case_exp e t cs = + let pexp (pat,body,annot) = Pat_aux (Pat_exp (pat,body),annot) in + let ps = List.map pexp cs in + (* let efr = union_effs (List.map effect_of_pexp ps) in *) + fix_eff_exp (E_aux (E_case (e,ps), (get_loc_exp e, Some (env_of e, t, no_effect)))) + +let rewrite_guarded_clauses l cs = + let rec group clauses = + let add_clause (pat,cls,annot) c = (pat,cls @ [c],annot) in + let rec group_aux current acc = (function + | ((pat,guard,body,annot) as c) :: cs -> + let (current_pat,_,_) = current in + (match subsumes_pat current_pat pat with + | Some substs -> + let pat' = List.fold_left subst_id_pat pat substs in + let guard' = (match guard with + | Some exp -> Some (List.fold_left subst_id_exp exp substs) + | None -> None) in + let body' = List.fold_left subst_id_exp body substs in + let c' = (pat',guard',body',annot) in + group_aux (add_clause current c') acc cs + | None -> + let pat = remove_wildcards "g__" pat in + group_aux (pat,[c],annot) (acc @ [current]) cs) + | [] -> acc @ [current]) in + let groups = match clauses with + | ((pat,guard,body,annot) as c) :: cs -> + group_aux (remove_wildcards "g__" pat, [c], annot) [] cs + | _ -> + raise (Reporting_basic.err_unreachable l + "group given empty list in rewrite_guarded_clauses") in + List.map (fun cs -> if_pexp cs) groups + and if_pexp (pat,cs,annot) = (match cs with + | c :: _ -> + (* fix_eff_pexp (pexp *) + let body = if_exp pat cs in + let pexp = fix_eff_pexp (Pat_aux (Pat_exp (pat,body),annot)) in + let (Pat_aux (Pat_exp (_,_),annot)) = pexp in + (pat, body, annot) + | [] -> + raise (Reporting_basic.err_unreachable l + "if_pexp given empty list in rewrite_guarded_clauses")) + and if_exp current_pat = (function + | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> + (match guard with + | Some exp -> + let else_exp = + if equiv_pats current_pat pat' + then if_exp current_pat (c' :: cs) + else case_exp (pat_to_exp current_pat) (typ_of body') (group (c' :: cs)) in + fix_eff_exp (E_aux (E_if (exp,body,else_exp), simple_annot (fst annot) (typ_of body))) + | None -> body) + | [(pat,guard,body,annot)] -> body + | [] -> + raise (Reporting_basic.err_unreachable l + "if_exp given empty list in rewrite_guarded_clauses")) in + group cs + +let rewrite_exp_remove_bitvector_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) + when List.exists (fun (Pat_aux (Pat_exp (pat,_),_)) -> contains_bitvector_pat pat) ps -> + let clause (Pat_aux (Pat_exp (pat,body),annot')) = + let (pat',(guard,decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (pat',guard,body',annot') in + let clauses = rewrite_guarded_clauses l (List.map clause ps) in + if (effectful e) then + let e = rewrite_rec e in + let (E_aux (_,(el,eannot))) = e in + let pat_e' = fresh_id_pat "p__" (el,eannot) in + let exp_e' = pat_to_exp pat_e' in + (* let fresh = fresh_id "p__" el in + let exp_e' = E_aux (E_id fresh, gen_annot l (get_type e) pure_e) in + let pat_e' = P_aux (P_id fresh, gen_annot l (get_type e) pure_e) in *) + let letbind_e = LB_aux (LB_val_implicit (pat_e',e), (el,eannot)) in + let exp' = case_exp exp_e' (typ_of full_exp) clauses in + rewrap (E_let (letbind_e, exp')) + else case_exp e (typ_of full_exp) clauses + | E_let (LB_aux (LB_val_explicit (typ,pat,v),annot'),body) -> + let (pat,(_,decls,_)) = remove_bitvector_pat pat in + rewrap (E_let (LB_aux (LB_val_explicit (typ,pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | E_let (LB_aux (LB_val_implicit (pat,v),annot'),body) -> + let (pat,(_,decls,_)) = remove_bitvector_pat pat in + rewrap (E_let (LB_aux (LB_val_implicit (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | _ -> rewrite_base full_exp + +let rewrite_fun_remove_bitvector_pat + rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = + let _ = reset_fresh_name_counter () in + (* TODO Can there be clauses with different id's in one FD_function? *) + let funcls = match funcls with + | (FCL_aux (FCL_Funcl(id,_,_),_) :: _) -> + let clause (FCL_aux (FCL_Funcl(_,pat,exp),annot)) = + let (pat,(guard,decls,_)) = remove_bitvector_pat pat in + let exp = decls (rewriters.rewrite_exp rewriters exp) in + (pat,guard,exp,annot) in + let cs = rewrite_guarded_clauses l (List.map clause funcls) in + List.map (fun (pat,exp,annot) -> FCL_aux (FCL_Funcl(id,pat,exp),annot)) cs + | _ -> funcls (* TODO is the empty list possible here? *) in + FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot)) + +let rewrite_defs_remove_bitvector_pats (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_bitvector_pat; rewrite_pat = rewrite_pat; rewrite_let = rewrite_let; rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun_remove_vector_concat_pat; + rewrite_fun = rewrite_fun_remove_bitvector_pat; rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_remove_vector_concat_pat} defs - + rewrite_defs = rewrite_defs_base } in + let rewrite_def d = + let d = rewriters.rewrite_def rewriters d in + match d with + | DEF_val (LB_aux (LB_val_explicit (t,pat,exp),a)) -> + let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val_explicit (t,pat',exp),a))] @ defvals + | DEF_val (LB_aux (LB_val_implicit (pat,exp),a)) -> + let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val_implicit (pat',exp),a))] @ defvals + | d -> [d] in + Defs (List.flatten (List.map rewrite_def defs)) + + (*Expects to be called after rewrite_defs; thus the following should not appear: internal_exp of any form lit vectors in patterns or expressions *) -let rewrite_exp_lift_assign_intro rewriters nmap ((E_aux (exp,(l,annot))) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrap_effects e effsum = - let (Base (t,tag,nexps,eff,_,bounds)) = annot in - E_aux (e,(l,Base (t,tag,nexps,eff,effsum,bounds))) in - let rewrite_rec = rewriters.rewrite_exp rewriters nmap in - let rewrite_base = rewrite_exp rewriters nmap in +let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + let rewrap e = E_aux (e,annot) in + let rewrap_effects e eff = + E_aux (e, (l,Some (env_of_annot annot, typ_of_annot annot, eff))) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in match exp with | E_block exps -> let rec walker exps = match exps with | [] -> [] - | (E_aux(E_assign(le,e), (l, Base((_,t),Emp_intro,_,_,_,_))))::exps -> - let le' = rewriters.rewrite_lexp rewriters nmap le in - let e' = rewrite_base e in - let exps' = walker exps in - let effects = eff_union_exps exps' in - [E_aux (E_internal_let(le', e', E_aux(E_block exps', (l, simple_annot_efr {t=Tid "unit"} effects))), - (l, simple_annot_efr t (eff_union_exps (e::exps'))))] - | ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> + | (E_aux(E_assign((LEXP_aux ((LEXP_id id | LEXP_cast (_,id)),_)) as le,e), + ((l, Some (env,typ,eff)) as annot)) as exp)::exps -> + (match Env.lookup_id id env with + | Unbound -> + let le' = rewriters.rewrite_lexp rewriters le in + let e' = rewrite_base e in + let exps' = walker exps in + let effects = union_eff_exps exps' in + let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in + [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] + | _ -> (rewrite_rec exp)::(walker exps)) + (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> let vars_t = introduced_variables t in let vars_e = introduced_variables e in let new_vars = Envmap.intersect vars_t vars_e in @@ -1249,43 +1957,34 @@ let rewrite_exp_lift_assign_intro rewriters nmap ((E_aux (exp,(l,annot))) as ful set_exp, E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) - (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars) + (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) | e::exps -> (rewrite_rec e)::(walker exps) in rewrap (E_block (walker exps)) - | E_assign(le,e) -> - (match annot with - | Base((_,t),Emp_intro,_,_,_,_) -> - let le' = rewriters.rewrite_lexp rewriters nmap le in - let e' = rewrite_base e in - let effects = get_effsum_exp e' in - (match le' with - | LEXP_aux(_, (_,Base(_,Emp_intro,_,_,_,_))) -> - rewrap_effects - (E_internal_let(le', e', E_aux(E_block [], (l, simple_annot_efr unit_t effects)))) - effects - | LEXP_aux(_, (_,Base(_,_,_,_,efr,_))) -> - let effects' = union_effects effects efr in - E_aux((E_assign(le', e')),(l, tag_annot_efr unit_t Emp_set effects')) - | _ -> assert false) + | E_assign(((LEXP_aux ((LEXP_id id | LEXP_cast (_,id)),lannot)) as le),e) -> + let le' = rewriters.rewrite_lexp rewriters le in + let e' = rewrite_base e in + let effects = effect_of e' in + (match Env.lookup_id id (env_of_annot annot) with + | Unbound -> + rewrap_effects + (E_internal_let(le', e', E_aux(E_block [], simple_annot l unit_typ))) + effects + | Local _ -> + let effects' = union_effects effects (effect_of_annot (snd lannot)) in + let annot' = Some (env_of_annot annot, unit_typ, effects') in + E_aux((E_assign(le', e')),(l, annot')) | _ -> rewrite_base full_exp) | _ -> rewrite_base full_exp -let rewrite_lexp_lift_assign_intro rewriters map ((LEXP_aux(lexp,(l,annot))) as le) = - let rewrap le = LEXP_aux(le,(l,annot)) in - let rewrite_base = rewrite_lexp rewriters map in - match lexp with - | LEXP_id (Id_aux (Id i, _)) | LEXP_cast (_,(Id_aux (Id i,_))) -> - (match annot with - | Base((p,t),Emp_intro,cs,e1,e2,bs) -> - (match map with - | Some(_,s) -> - (match Envmap.apply s i with - | None -> rewrap lexp - | Some _ -> - let ls = BE_aux(BE_lset,l) in - LEXP_aux(lexp,(l,(Base((p,t),Emp_set,cs,add_effect ls e1, add_effect ls e2,bs))))) - | _ -> rewrap lexp) +let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = + let rewrap le = LEXP_aux(le,annot) in + let rewrite_base = rewrite_lexp rewriters in + match lexp, annot with + | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> + (match Env.lookup_id id env with + | Unbound | Local _ -> + LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) | _ -> rewrap lexp) | _ -> rewrite_base le @@ -1298,16 +1997,16 @@ let rewrite_defs_exp_lift_assign defs = rewrite_defs_base rewrite_fun = rewrite_fun; rewrite_def = rewrite_def; rewrite_defs = rewrite_defs_base} defs - -let rewrite_exp_separate_ints rewriters nmap ((E_aux (exp,(l,annot))) as full_exp) = - let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with + +(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds - | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in - let rewrap e = E_aux (e,(l,annot)) in - let rewrap_effects e effsum = - E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in - let rewrite_rec = rewriters.rewrite_exp rewriters nmap in - let rewrite_base = rewrite_exp rewriters nmap in + | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) + let rewrap e = E_aux (e,annot) in + (*let rewrap_effects e effsum = + E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in match exp with | E_lit (L_aux (((L_num _) as lit),_)) -> (match (is_within_machine64 t nexps) with @@ -1344,25 +2043,25 @@ let rewrite_defs_separate_numbs defs = rewrite_defs_base rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) rewrite_fun = rewrite_fun; rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs + rewrite_defs = rewrite_defs_base} defs*) -let rewrite_defs_ocaml defs = - let defs_sorted = top_sort_defs defs in - let defs_vec_concat_removed = rewrite_defs_remove_vector_concat defs_sorted in - let defs_lifted_assign = rewrite_defs_exp_lift_assign defs_vec_concat_removed in -(* let defs_separate_nums = rewrite_defs_separate_numbs defs_lifted_assign in *) - defs_lifted_assign +let rewrite_defs_ocaml = + top_sort_defs >> + rewrite_defs_remove_vector_concat >> + rewrite_sizeof >> + rewrite_defs_exp_lift_assign (* >> + rewrite_defs_separate_numbs *) let rewrite_defs_remove_blocks = let letbind_wild v body = - let (E_aux (_,(l,_))) = v in - let annot_pat = (Parse_ast.Generated l,simple_annot (get_type v)) in - let annot_lb = (Parse_ast.Generated l,simple_annot_efr (get_type v) (get_effsum_exp v)) in - let annot_let = (Parse_ast.Generated l,simple_annot_efr (get_type body) (eff_union_exps [v;body])) in + let (E_aux (_,(l,tannot))) = v in + let annot_pat = (simple_annot l (typ_of v)) in + let annot_lb = (Parse_ast.Generated l, tannot) in + let annot_let = (Parse_ast.Generated l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in E_aux (E_let (LB_aux (LB_val_implicit (P_aux (P_wild,annot_pat),v),annot_lb),body),annot_let) in let rec f l = function - | [] -> E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)), (Parse_ast.Generated l,simple_annot ({t = Tid "unit"}))) + | [] -> E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)), (simple_annot l unit_typ)) | [e] -> e (* check with Kathy if that annotation is fine *) | e :: es -> letbind_wild e (f l es) in @@ -1373,7 +2072,7 @@ let rewrite_defs_remove_blocks = let alg = { id_exp_alg with e_aux = e_aux } in rewrite_defs_base - {rewrite_exp = (fun _ _ -> fold_exp alg) + {rewrite_exp = (fun _ -> fold_exp alg) ; rewrite_pat = rewrite_pat ; rewrite_let = rewrite_let ; rewrite_lexp = rewrite_lexp @@ -1384,36 +2083,32 @@ let rewrite_defs_remove_blocks = -let fresh_id ((l,_) as annot) = - let current = fresh_name () in - let id = Id_aux (Id ("w__" ^ string_of_int current), Parse_ast.Generated l) in - let annot_var = (Parse_ast.Generated l,simple_annot (get_type_annot annot)) in - E_aux (E_id id, annot_var) - let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = (* body is a function : E_id variable -> actual body *) - match get_type v with - | {t = Tid "unit"} -> - let (E_aux (_,(l,annot))) = v in - let e = E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)),(Parse_ast.Generated l,simple_annot unit_t)) in + let (E_aux (_,(l,annot))) = v in + match annot with + | Some (env, Typ_aux (Typ_id tid, _), eff) when string_of_id tid = "unit" -> + let e = E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)),(simple_annot l unit_typ)) in let body = body e in - let annot_pat = (Parse_ast.Generated l,simple_annot unit_t) in + let annot_pat = simple_annot l unit_typ in let annot_lb = annot_pat in - let annot_let = (Parse_ast.Generated l,simple_annot_efr (get_type body) (eff_union_exps [v;body])) in + let annot_let = (Parse_ast.Generated l, Some (env, typ_of body, union_eff_exps [v;body])) in let pat = P_aux (P_wild,annot_pat) in E_aux (E_let (LB_aux (LB_val_implicit (pat,v),annot_lb),body),annot_let) - | _ -> - let (E_aux (_,((l,_) as annot))) = v in - let ((E_aux (E_id id,_)) as e_id) = fresh_id annot in + | Some (env, typ, eff) -> + let id = fresh_id "w__" l in + let annot_pat = simple_annot l (typ_of v) in + let e_id = E_aux (E_id id, (Parse_ast.Generated l, Some (env, typ, no_effect))) in let body = body e_id in - - let annot_pat = (Parse_ast.Generated l,simple_annot (get_type v)) in + let annot_lb = annot_pat in - let annot_let = (Parse_ast.Generated l,simple_annot_efr (get_type body) (eff_union_exps [v;body])) in + let annot_let = (Parse_ast.Generated l, Some (env, typ_of body, union_eff_exps [v;body])) in let pat = P_aux (P_id id,annot_pat) in E_aux (E_let (LB_aux (LB_val_implicit (pat,v),annot_lb),body),annot_let) + | None -> + raise (Reporting_basic.err_unreachable l "no type information") let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = @@ -1424,7 +2119,7 @@ let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list let rewrite_defs_letbind_effects = let rec value ((E_aux (exp_aux,_)) as exp) = - not (effectful exp) && not (updates_vars exp) + not (effectful exp || updates_vars exp) and value_optdefault (Def_val_aux (o,_)) = match o with | Def_val_empty -> true | Def_val_dec e -> value e @@ -1436,7 +2131,7 @@ let rewrite_defs_letbind_effects = n_exp exp (fun exp -> if value exp then k exp else letbind exp k) and n_exp_pure (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - n_exp exp (fun exp -> if not (effectful exp || updates_vars exp) then k exp else letbind exp k) + n_exp exp (fun exp -> if value exp then k exp else letbind exp k) and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = mapCont n_exp_name exps k @@ -1444,14 +2139,14 @@ let rewrite_defs_letbind_effects = and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in n_exp_name exp (fun exp -> - k (fix_effsum_fexp (FE_aux (FE_Fexp (id,exp),annot)))) + k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = mapCont n_fexp fexps k and n_pexp (newreturn : bool) (pexp : 'a pexp) (k : 'a pexp -> 'a exp) : 'a exp = let (Pat_aux (Pat_exp (pat,exp),annot)) = pexp in - k (fix_effsum_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) + k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = mapCont (n_pexp newreturn) pexps k @@ -1459,7 +2154,7 @@ let rewrite_defs_letbind_effects = and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in n_fexpL fexps_aux (fun fexps_aux -> - k (fix_effsum_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) + k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = let (Def_val_aux (opt_default,annot)) = opt_default in @@ -1467,17 +2162,17 @@ let rewrite_defs_letbind_effects = | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) | Def_val_dec exp -> n_exp_name exp (fun exp -> - k (fix_effsum_opt_default (Def_val_aux (Def_val_dec exp,annot)))) + k (fix_eff_opt_default (Def_val_aux (Def_val_dec exp,annot)))) and n_lb (lb : 'a letbind) (k : 'a letbind -> 'a exp) : 'a exp = let (LB_aux (lb,annot)) = lb in match lb with | LB_val_explicit (typ,pat,exp1) -> n_exp exp1 (fun exp1 -> - k (fix_effsum_lb (LB_aux (LB_val_explicit (typ,pat,exp1),annot)))) + k (fix_eff_lb (LB_aux (LB_val_explicit (typ,pat,exp1),annot)))) | LB_val_implicit (pat,exp1) -> n_exp exp1 (fun exp1 -> - k (fix_effsum_lb (LB_aux (LB_val_implicit (pat,exp1),annot)))) + k (fix_eff_lb (LB_aux (LB_val_implicit (pat,exp1),annot)))) and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = let (LEXP_aux (lexp_aux,annot)) = lexp in @@ -1485,27 +2180,28 @@ let rewrite_defs_letbind_effects = | LEXP_id _ -> k lexp | LEXP_memory (id,es) -> n_exp_nameL es (fun es -> - k (fix_effsum_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) + k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) | LEXP_cast (typ,id) -> - k (fix_effsum_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) + k (fix_eff_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) | LEXP_vector (lexp,e) -> n_lexp lexp (fun lexp -> n_exp_name e (fun e -> - k (fix_effsum_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) + k (fix_eff_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) | LEXP_vector_range (lexp,e1,e2) -> n_lexp lexp (fun lexp -> n_exp_name e1 (fun e1 -> n_exp_name e2 (fun e2 -> - k (fix_effsum_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) + k (fix_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) | LEXP_field (lexp,id) -> n_lexp lexp (fun lexp -> - k (fix_effsum_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) + k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = - let (E_aux (_,(l,_))) = exp in + let (E_aux (_,(l,tannot))) = exp in let exp = if newreturn then - E_aux (E_internal_return exp,(Parse_ast.Generated l,simple_annot_efr (get_type exp) (get_effsum_exp exp))) + let typ = typ_of exp in + E_aux (E_internal_return exp, simple_annot l typ) else exp in (* n_exp_term forces an expression to be translated into a form @@ -1515,7 +2211,7 @@ let rewrite_defs_letbind_effects = and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - let rewrap e = fix_effsum_exp (E_aux (e,annot)) in + let rewrap e = fix_eff_exp (E_aux (e,annot)) in match exp_aux with | E_block es -> failwith "E_block should have been removed till now" @@ -1602,7 +2298,7 @@ let rewrite_defs_letbind_effects = | E_case (exp1,pexps) -> let newreturn = List.fold_left - (fun b (Pat_aux (_,(_,Base (_,_,_,_,effs,_)))) -> b || effectful_effs effs) + (fun b (Pat_aux (_,(_,annot))) -> b || effectful_effs (effect_of_annot annot)) false pexps in n_exp_name exp1 (fun exp1 -> n_pexpL newreturn pexps (fun pexps -> @@ -1648,8 +2344,8 @@ let rewrite_defs_letbind_effects = let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = let newreturn = List.fold_left - (fun b (FCL_aux (FCL_Funcl(id,pat,exp),annot)) -> - b || effectful_effs (get_localeff_annot annot)) false funcls in + (fun b (FCL_aux (FCL_Funcl(id,pat,exp),(_,annot))) -> + b || effectful_effs (effect_of_annot annot)) false funcls in let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),annot)) = let _ = reset_fresh_name_counter () in FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) @@ -1685,7 +2381,7 @@ let rewrite_defs_effectful_let_expressions = let alg = { id_exp_alg with e_let = e_let; e_internal_let = e_internal_let } in rewrite_defs_base - {rewrite_exp = (fun _ _ -> fold_exp alg) + {rewrite_exp = (fun _ -> fold_exp alg) ; rewrite_pat = rewrite_pat ; rewrite_let = rewrite_let ; rewrite_lexp = rewrite_lexp @@ -1742,6 +2438,7 @@ let find_updated_vars exp = ; e_case = (fun (e1,pexps) -> e1 @@ lapp2 pexps) ; e_let = (fun (lb,e2) -> lb @@ e2) ; e_assign = (fun ((ids,acc),e2) -> ([],ids) @@ acc @@ e2) + ; e_sizeof = (fun nexp -> ([],[])) ; e_exit = (fun e1 -> ([],[])) ; e_return = (fun e1 -> e1) ; e_assert = (fun (e1,e2) -> ([],[])) @@ -1764,8 +2461,10 @@ let find_updated_vars exp = ; lEXP_field = (fun ((ids,acc),_) -> (None,ids,acc)) ; lEXP_aux = (function - | ((Some id,ids,acc),((_,Base (_,(Emp_set | Emp_intro),_,_,_,_)) as annot)) -> - ((id,annot) :: ids,acc) + | ((Some id,ids,acc),(annot)) -> + (match Env.lookup_id id (env_of_annot annot) with + | Unbound | Local _ -> ((id,annot) :: ids,acc) + | _ -> (ids,acc)) | ((_,ids,acc),_) -> (ids,acc) ) ; fE_Fexp = (fun (_,e) -> e) @@ -1784,29 +2483,33 @@ let find_updated_vars exp = } exp in dedup eqidtyp updates -let swaptyp t (l,(Base ((t_params,_),tag,nexps,eff,effsum,bounds))) = - (l,Base ((t_params,t),tag,nexps,eff,effsum,bounds)) +let swaptyp typ (l,tannot) = match tannot with + | Some (env, typ', eff) -> (l, Some (env, typ, eff)) + | _ -> raise (Reporting_basic.err_unreachable l "swaptyp called with empty type annotation") let mktup l es = match es with - | [] -> E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)),(Parse_ast.Generated l,simple_annot unit_t)) + | [] -> E_aux (E_lit (L_aux (L_unit,Parse_ast.Generated l)),(simple_annot l unit_typ)) | [e] -> e - | _ -> + | e :: _ -> let effs = - List.fold_left (fun acc e -> union_effects acc (get_effsum_exp e)) {effect = Eset []} es in - let typs = List.map get_type es in - E_aux (E_tuple es,(Parse_ast.Generated l,simple_annot_efr {t = Ttup typs} effs)) + List.fold_left (fun acc e -> union_effects acc (effect_of e)) no_effect es in + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + E_aux (E_tuple es,(Parse_ast.Generated l, Some (env_of e, typ, effs))) let mktup_pat l es = match es with - | [] -> P_aux (P_wild,(Parse_ast.Generated l,simple_annot unit_t)) + | [] -> P_aux (P_wild,(simple_annot l unit_typ)) | [E_aux (E_id id,_) as exp] -> - P_aux (P_id id,(Parse_ast.Generated l,simple_annot (get_type exp))) + P_aux (P_id id,(simple_annot l (typ_of exp))) | _ -> - let typs = List.map get_type es in - let pats = List.map (fun (E_aux (E_id id,_) as exp) -> - P_aux (P_id id,(Parse_ast.Generated l,simple_annot (get_type exp)))) es in - P_aux (P_tup pats,(Parse_ast.Generated l,simple_annot {t = Ttup typs})) + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + let pats = List.map (function + | (E_aux (E_id id,_) as exp) -> + P_aux (P_id id,(simple_annot l (typ_of exp))) + | exp -> + P_aux (P_wild,(simple_annot l (typ_of exp)))) es in + P_aux (P_tup pats,(simple_annot l typ)) type 'a updated_term = @@ -1819,36 +2522,48 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = match expaux with | E_let (lb,exp) -> let exp = add_vars overwrite exp vars in - E_aux (E_let (lb,exp),swaptyp (get_type exp) annot) + E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) | E_internal_let (lexp,exp1,exp2) -> let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (get_type exp2) annot) + E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) | E_internal_plet (pat,exp1,exp2) -> let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (get_type exp2) annot) + E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) | E_internal_return exp2 -> let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_return exp2,swaptyp (get_type exp2) annot) + E_aux (E_internal_return exp2,swaptyp (typ_of exp2) annot) | _ -> (* after rewrite_defs_letbind_effects there cannot be terms that have effects/update local variables in "tail-position": check n_exp_term and where it is used. *) if overwrite then - let () = if get_type exp = {t = Tid "unit"} then () - else failwith "nono" in - vars + match typ_of exp with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> vars + | _ -> raise (Reporting_basic.err_unreachable l + "add_vars: trying to overwrite a non-unit expression in tail-position") else - E_aux (E_tuple [exp;vars],swaptyp {t = Ttup [get_type exp;get_type vars]} annot) in + let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], Parse_ast.Generated l) in + E_aux (E_tuple [exp;vars],swaptyp typ' annot) in let rewrite (E_aux (expaux,((el,_) as annot))) (P_aux (_,(pl,pannot)) as pat) = - let overwrite = match get_type_annot annot with - | {t = Tid "unit"} -> true + let overwrite = match typ_of_annot annot with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true | _ -> false in match expaux with | E_for(id,exp1,exp2,exp3,order,exp4) -> + (* Translate for loops into calls to one of the foreach combinators. + The loop body becomes a function of the loop variable and any + mutable local variables that are updated inside the loop. + Since the foreach* combinators are higher-order functions, + they cannot be represented faithfully in the AST. The following + code abuses the parameters of an E_app node, embedding the loop body + function as an expression followed by the list of variables it + expects. In (Lem) pretty-printing, this turned into an anonymous + function and passed to foreach*. *) let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars exp4) in let vartuple = mktup el vars in let exp4 = rewrite_var_updates (add_vars overwrite exp4 vartuple) in + let (E_aux (_,(_,annot4))) = exp4 in let fname = match effectful exp4,order with | false, Ord_aux (Ord_inc,_) -> "foreach_inc" | false, Ord_aux (Ord_dec,_) -> "foreach_dec" @@ -1856,13 +2571,15 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" in let funcl = Id_aux (Id fname,Parse_ast.Generated el) in let loopvar = - let (bf,tf) = match get_type exp1 with + (* Don't bother with creating a range type annotation, since the + Lem pretty-printing does not use it. *) + (* let (bf,tf) = match typ_of exp1 with | {t = Tapp ("atom",[TA_nexp f])} -> (TA_nexp f,TA_nexp f) | {t = Tapp ("reg", [TA_typ {t = Tapp ("atom",[TA_nexp f])}])} -> (TA_nexp f,TA_nexp f) | {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])} -> (TA_nexp bf,TA_nexp tf) | {t = Tapp ("reg", [TA_typ {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])}])} -> (TA_nexp bf,TA_nexp tf) | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in - let (bt,tt) = match get_type exp2 with + let (bt,tt) = match typ_of exp2 with | {t = Tapp ("atom",[TA_nexp t])} -> (TA_nexp t,TA_nexp t) | {t = Tapp ("atom",[TA_typ {t = Tapp ("atom", [TA_nexp t])}])} -> (TA_nexp t,TA_nexp t) | {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])} -> (TA_nexp bt,TA_nexp tt) @@ -1870,14 +2587,14 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in let t = {t = Tapp ("range",match order with | Ord_aux (Ord_inc,_) -> [bf;tt] - | Ord_aux (Ord_dec,_) -> [tf;bt])} in - E_aux (E_id id,(Parse_ast.Generated el,simple_annot t)) in + | Ord_aux (Ord_dec,_) -> [tf;bt])} in *) + E_aux (E_id id, simple_annot l int_typ) in let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), - (Parse_ast.Generated el,simple_annot_efr (get_type exp4) (get_effsum_exp exp4))) in + (Parse_ast.Generated el, annot4)) in let pat = if overwrite then mktup_pat el vars else P_aux (P_tup [pat; mktup_pat pl vars], - (Parse_ast.Generated pl,simple_annot (get_type v))) in + simple_annot pl (typ_of v)) in Added_vars (v,pat) | E_if (c,e1,e2) -> let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) @@ -1889,12 +2606,14 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = let e1 = rewrite_var_updates (add_vars overwrite e1 vartuple) in let e2 = rewrite_var_updates (add_vars overwrite e2 vartuple) in (* after rewrite_defs_letbind_effects c has no variable updates *) - let t = get_type e1 in - let v = E_aux (E_if (c,e1,e2), (Parse_ast.Generated el,simple_annot_efr t (eff_union_exps [e1;e2]))) in + let env = env_of_annot annot in + let typ = typ_of e1 in + let eff = union_eff_exps [e1;e2] in + let v = E_aux (E_if (c,e1,e2), (Parse_ast.Generated el, Some (env, typ, eff))) in let pat = if overwrite then mktup_pat el vars else P_aux (P_tup [pat; mktup_pat pl vars], - (Parse_ast.Generated pl,simple_annot (get_type v))) in + (simple_annot pl (typ_of v))) in Added_vars (v,pat) | E_case (e1,ps) -> (* after rewrite_defs_letbind_effects e1 needs no rewriting *) @@ -1909,48 +2628,53 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = let vartuple = mktup el vars in let typ = let (Pat_aux (Pat_exp (_,first),_)) = List.hd ps in - get_type first in + typ_of first in let (ps,typ,effs) = let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = - let etyp = get_type e in - let () = assert (simple_annot etyp = simple_annot typ) in + let etyp = typ_of e in + let () = assert (string_of_typ etyp = string_of_typ typ) in let e = rewrite_var_updates (add_vars overwrite e vartuple) in - let pannot = (Parse_ast.Generated pl,simple_annot (get_type e)) in - let effs = union_effects effs (get_effsum_exp e) in + let pannot = simple_annot pl (typ_of e) in + let effs = union_effects effs (effect_of e) in let pat' = Pat_aux (Pat_exp (p,e),pannot) in (acc @ [pat'],typ,effs) in - List.fold_left f ([],typ,{effect = Eset []}) ps in - let v = E_aux (E_case (e1,ps), (Parse_ast.Generated pl,simple_annot_efr typ effs)) in + List.fold_left f ([],typ,no_effect) ps in + let v = E_aux (E_case (e1,ps), (Parse_ast.Generated pl, Some (env_of_annot annot, typ, effs))) in let pat = if overwrite then mktup_pat el vars else P_aux (P_tup [pat; mktup_pat pl vars], - (Parse_ast.Generated pl,simple_annot (get_type v))) in + (simple_annot pl (typ_of v))) in Added_vars (v,pat) | E_assign (lexp,vexp) -> - let {effect = Eset effs} = get_effsum_annot annot in + let effs = match effect_of_annot (snd annot) with + | Effect_aux (Effect_set effs, _) -> effs + | _ -> + raise (Reporting_basic.err_unreachable l + "assignment without effects annotation") in if not (List.exists (function BE_aux (BE_lset,_) -> true | _ -> false) effs) then Same_vars (E_aux (E_assign (lexp,vexp),annot)) else (match lexp with | LEXP_aux (LEXP_id id,annot) -> - let pat = P_aux (P_id id,(Parse_ast.Generated pl,simple_annot (get_type vexp))) in + let pat = P_aux (P_id id, simple_annot pl (typ_of vexp)) in Added_vars (vexp,pat) | LEXP_aux (LEXP_cast (_,id),annot) -> - let pat = P_aux (P_id id,(Parse_ast.Generated pl,simple_annot (get_type vexp))) in + let pat = P_aux (P_id id, simple_annot pl (typ_of vexp)) in Added_vars (vexp,pat) | LEXP_aux (LEXP_vector (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i),((l1,_) as annot)) -> - let eid = E_aux (E_id id,(Parse_ast.Generated l2,simple_annot (get_type_annot annot2))) in + let eid = E_aux (E_id id, simple_annot l2 (typ_of_annot annot2)) in let vexp = E_aux (E_vector_update (eid,i,vexp), - (Parse_ast.Generated l1,simple_annot (get_type_annot annot))) in - let pat = P_aux (P_id id,(Parse_ast.Generated pl,simple_annot (get_type vexp))) in + simple_annot l1 (typ_of_annot annot)) in + let pat = P_aux (P_id id, simple_annot pl (typ_of vexp)) in Added_vars (vexp,pat) | LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i,j), ((l,_) as annot)) -> - let eid = E_aux (E_id id,(Parse_ast.Generated l2,simple_annot (get_type_annot annot2))) in + let eid = E_aux (E_id id, simple_annot l2 (typ_of_annot annot2)) in let vexp = E_aux (E_vector_update_subrange (eid,i,j,vexp), - (Parse_ast.Generated l,simple_annot (get_type_annot annot))) in - let pat = P_aux (P_id id,(Parse_ast.Generated pl,simple_annot (get_type vexp))) in - Added_vars (vexp,pat)) + simple_annot l (typ_of_annot annot)) in + let pat = P_aux (P_id id, simple_annot pl (typ_of vexp)) in + Added_vars (vexp,pat) + | _ -> Same_vars (E_aux (E_assign (lexp,vexp),annot))) | _ -> (* after rewrite_defs_letbind_effects this expression is pure and updates no variables: check n_exp_term and where it's used. *) @@ -1964,27 +2688,33 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = (match rewrite v pat with | Added_vars (v,pat) -> let (E_aux (_,(l,_))) = v in - let lbannot = (Parse_ast.Generated l,simple_annot (get_type v)) in - (get_effsum_exp v,LB_aux (LB_val_implicit (pat,v),lbannot)) - | Same_vars v -> (get_effsum_exp v,LB_aux (LB_val_implicit (pat,v),lbannot))) + let lbannot = (simple_annot l (typ_of v)) in + (effect_of v,LB_aux (LB_val_implicit (pat,v),lbannot)) + | Same_vars v -> (effect_of v,LB_aux (LB_val_implicit (pat,v),lbannot))) | LB_aux (LB_val_explicit (typ,pat,v),lbannot) -> (match rewrite v pat with | Added_vars (v,pat) -> let (E_aux (_,(l,_))) = v in - let lbannot = (Parse_ast.Generated l,simple_annot (get_type v)) in - (get_effsum_exp v,LB_aux (LB_val_implicit (pat,v),lbannot)) - | Same_vars v -> (get_effsum_exp v,LB_aux (LB_val_explicit (typ,pat,v),lbannot))) in - let typ = simple_annot_efr (get_type body) (union_effects eff (get_effsum_exp body)) in - E_aux (E_let (lb,body),(Parse_ast.Generated l,typ)) + let lbannot = (simple_annot l (typ_of v)) in + (effect_of v,LB_aux (LB_val_implicit (pat,v),lbannot)) + | Same_vars v -> (effect_of v,LB_aux (LB_val_explicit (typ,pat,v),lbannot))) in + let tannot = Some (env_of_annot annot, typ_of body, union_effects eff (effect_of body)) in + E_aux (E_let (lb,body),(Parse_ast.Generated l,tannot)) | E_internal_let (lexp,v,body) -> (* Rewrite E_internal_let into E_let and call recursively *) let id = match lexp with | LEXP_aux (LEXP_id id,_) -> id | LEXP_aux (LEXP_cast (_,id),_) -> id in - let pat = P_aux (P_id id, (Parse_ast.Generated l,simple_annot (get_type v))) in - let lbannot = (Parse_ast.Generated l,simple_annot_efr (get_type v) (get_effsum_exp v)) in + let env = env_of_annot annot in + let vtyp = typ_of v in + let veff = effect_of v in + let bodyenv = env_of body in + let bodytyp = typ_of body in + let bodyeff = effect_of body in + let pat = P_aux (P_id id, (simple_annot l vtyp)) in + let lbannot = (Parse_ast.Generated l, Some (env, vtyp, veff)) in let lb = LB_aux (LB_val_implicit (pat,v),lbannot) in - let exp = E_aux (E_let (lb,body),(Parse_ast.Generated l,simple_annot_efr (get_type body) (eff_union_exps [v;body]))) in + let exp = E_aux (E_let (lb,body),(Parse_ast.Generated l, Some (bodyenv, bodytyp, union_effects veff bodyeff))) in rewrite_var_updates exp | E_internal_plet (pat,v,body) -> failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" @@ -2003,42 +2733,23 @@ let replace_memwrite_e_assign exp = let remove_reference_types exp = - let rec rewrite_t {t = t_aux} = {t = rewrite_t_aux t_aux} + let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) and rewrite_t_aux t_aux = match t_aux with - | Tapp ("reg",[TA_typ {t = t_aux2}]) -> rewrite_t_aux t_aux2 - | Tapp (name,t_args) -> Tapp (name,List.map rewrite_t_arg t_args) - | Tfn (t1,t2,imp,e) -> Tfn (rewrite_t t1,rewrite_t t2,imp,e) - | Ttup ts -> Ttup (List.map rewrite_t ts) - | Tabbrev (t1,t2) -> Tabbrev (rewrite_t t1,rewrite_t t2) - | Toptions (t1,t2) -> - let t2 = match t2 with Some t2 -> Some (rewrite_t t2) | None -> None in - Toptions (rewrite_t t1,t2) - | Tuvar t_uvar -> Tuvar t_uvar (*(rewrite_t_uvar t_uvar) *) + | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> + rewrite_t_aux t_aux2 + | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) + | Typ_fn (t1,t2,eff) -> Typ_fn (rewrite_t t1,rewrite_t t2,eff) + | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) | _ -> t_aux -(* and rewrite_t_uvar t_uvar = - t_uvar.subst <- (match t_uvar.subst with None -> None | Some t -> Some (rewrite_t t)) *) and rewrite_t_arg t_arg = match t_arg with - | TA_typ t -> TA_typ (rewrite_t t) + | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) | _ -> t_arg in let rec rewrite_annot = function - | NoTyp -> NoTyp - | Base ((tparams,t),tag,nexprs,effs,effsum,bounds) -> - Base ((tparams,rewrite_t t),tag,nexprs,effs,effsum,bounds) - | Overload (tannot1,b,tannots) -> - Overload (rewrite_annot tannot1,b,List.map rewrite_annot tannots) in - - - fold_exp - { id_exp_alg with - e_aux = (fun (e,(l,annot)) -> E_aux (e,(l,rewrite_annot annot))) - ; lEXP_aux = (fun (lexp,(l,annot)) -> LEXP_aux (lexp,(l,rewrite_annot annot))) - ; fE_aux = (fun (fexp,(l,annot)) -> FE_aux (fexp,(l,(rewrite_annot annot)))) - ; fES_aux = (fun (fexp,(l,annot)) -> FES_aux (fexp,(l,rewrite_annot annot))) - ; pat_aux = (fun (pexp,(l,annot)) -> Pat_aux (pexp,(l,rewrite_annot annot))) - ; lB_aux = (fun (lb,(l,annot)) -> LB_aux (lb,(l,rewrite_annot annot))) - } - exp + | (l, None) -> (l, None) + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in + + map_exp_annot rewrite_annot exp @@ -2082,7 +2793,7 @@ let rewrite_defs_remove_superfluous_letbinds = let alg = { id_exp_alg with e_aux = e_aux } in rewrite_defs_base - { rewrite_exp = (fun _ _ -> fold_exp alg) + { rewrite_exp = (fun _ -> fold_exp alg) ; rewrite_pat = rewrite_pat ; rewrite_let = rewrite_let ; rewrite_lexp = rewrite_lexp @@ -2094,9 +2805,9 @@ let rewrite_defs_remove_superfluous_letbinds = let rewrite_defs_remove_superfluous_returns = - let has_unittype e = - let {t = t} = get_type e in - t = Tid "unit" in + let has_unittype e = match typ_of e with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true + | _ -> false in let e_aux (exp,annot) = match exp with | E_internal_plet (pat,exp1,exp2) -> @@ -2119,7 +2830,7 @@ let rewrite_defs_remove_superfluous_returns = let alg = { id_exp_alg with e_aux = e_aux } in rewrite_defs_base - {rewrite_exp = (fun _ _ -> fold_exp alg) + {rewrite_exp = (fun _ -> fold_exp alg) ; rewrite_pat = rewrite_pat ; rewrite_let = rewrite_let ; rewrite_lexp = rewrite_lexp @@ -2130,7 +2841,7 @@ let rewrite_defs_remove_superfluous_returns = let rewrite_defs_remove_e_assign = - let rewrite_exp _ _ e = + let rewrite_exp _ e = replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in rewrite_defs_base { rewrite_exp = rewrite_exp @@ -2146,6 +2857,8 @@ let rewrite_defs_remove_e_assign = let rewrite_defs_lem = top_sort_defs >> rewrite_defs_remove_vector_concat >> + rewrite_defs_remove_bitvector_pats >> + rewrite_sizeof >> rewrite_defs_exp_lift_assign >> rewrite_defs_remove_blocks >> rewrite_defs_letbind_effects >> @@ -2154,4 +2867,3 @@ let rewrite_defs_lem = rewrite_defs_remove_superfluous_letbinds >> rewrite_defs_remove_superfluous_returns - diff --git a/src/rewriter.mli b/src/rewriter.mli index 615d0fa0..b2b0bf5e 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Thomas Bauereiss *) (* *) (* All rights reserved. *) (* *) @@ -42,23 +43,18 @@ open Big_int open Ast -open Type_internal -type typ = Type_internal.t -type 'a exp = 'a Ast.exp -type 'a emap = 'a Envmap.t -type envs = Type_check.envs -type 'a namemap = (typ * 'a exp) emap +open Type_check -type 'a rewriters = { rewrite_exp : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a exp -> 'a exp; - rewrite_lexp : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a lexp -> 'a lexp; - rewrite_pat : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a pat -> 'a pat; - rewrite_let : 'a rewriters -> (nexp_map * 'a namemap) option -> 'a letbind -> 'a letbind; +type 'a rewriters = { rewrite_exp : 'a rewriters -> 'a exp -> 'a exp; + rewrite_lexp : 'a rewriters -> 'a lexp -> 'a lexp; + rewrite_pat : 'a rewriters -> 'a pat -> 'a pat; + rewrite_let : 'a rewriters -> 'a letbind -> 'a letbind; rewrite_fun : 'a rewriters -> 'a fundef -> 'a fundef; rewrite_def : 'a rewriters -> 'a def -> 'a def; rewrite_defs : 'a rewriters -> 'a defs -> 'a defs; } -val rewrite_exp : tannot rewriters -> (nexp_map * tannot namemap) option -> tannot exp -> tannot exp +val rewrite_exp : tannot rewriters -> tannot exp -> tannot exp val rewrite_defs : tannot defs -> tannot defs val rewrite_defs_ocaml : tannot defs -> tannot defs (*Perform rewrites to exclude AST nodes not supported for ocaml out*) val rewrite_defs_lem : tannot defs -> tannot defs (*Perform rewrites to exclude AST nodes not supported for lem out*) @@ -114,6 +110,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_case : 'exp * 'pexp list -> 'exp_aux ; e_let : 'letbind * 'exp -> 'exp_aux ; e_assign : 'lexp * 'exp -> 'exp_aux + ; e_sizeof : nexp -> 'exp_aux ; e_exit : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux @@ -153,4 +150,3 @@ val fold_exp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_a 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg -> 'a exp -> 'exp val id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg - diff --git a/src/sail.ml b/src/sail.ml index 4e76551f..3500b213 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -53,6 +53,7 @@ let opt_print_ocaml = ref false let opt_libs_lem = ref ([]:string list) let opt_libs_ocaml = ref ([]:string list) let opt_file_arguments = ref ([]:string list) +let opt_mono_split = ref ([]:((string * int) * string) list) let options = Arg.align ([ ( "-o", Arg.String (fun f -> opt_file_out := Some f), @@ -77,15 +78,34 @@ let options = Arg.align ([ Arg.String (fun l -> lib := l::!lib), "<library_filename> treat this file as input only and generate no output for it"); *) - ( "-print_initial_env", - Arg.Set opt_print_initial_env, - " print the built-in initial type environment and terminate"); ( "-verbose", Arg.Set opt_print_verbose, " (debug) pretty-print the input to standard output"); - ( "-skip_constraints", - Arg.Clear Type_internal.do_resolve_constraints, - " (debug) skip constraint resolution in type-checking"); + ( "-mono-split", + Arg.String (fun s -> + let l = Util.split_on_char ':' s in + match l with + | [fname;line;var] -> opt_mono_split := ((fname,int_of_string line),var)::!opt_mono_split + | _ -> raise (Arg.Bad (s ^ " not of form <filename>:<line>:<variable>"))), + "<filename>:<line>:<variable> to case split for monomorphisation"); + ( "-new_typecheck", + Arg.Set opt_new_typecheck, + " (experimental) use new typechecker with Z3 constraint solving"); + ( "-just_check", + Arg.Tuple [Arg.Set opt_new_typecheck; Arg.Set opt_just_check], + " (experimental) terminate immediately after typechecking, implies -new_typecheck"); + ( "-ddump_tc_ast", + Arg.Set opt_ddump_tc_ast, + " (debug) dump the typechecked ast to stdout"); + ( "-dtc_verbose", + Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity), + " (debug) verbose typechecker output: 0 is silent"); + ( "-dno_cast", + Arg.Set opt_dno_cast, + " (debug) typecheck without any implicit casting"); + ( "-no_effects", + Arg.Set Type_check.opt_no_effects, + " turn off effect checking"); ( "-v", Arg.Set opt_print_version, " print version"); @@ -106,35 +126,27 @@ let _ = let main() = if !(opt_print_version) then Printf.printf "Sail private release \n" - else if !(opt_print_initial_env) then - let ppd_initial_typ_env = - String.concat "" - (List.map - (function (comment,tenv) -> - "(* "^comment^" *)\n" ^ - String.concat "" - (List.map - (function (id,tannot) -> - id ^ " : " ^ - Pretty_print.pp_format_annot_ascii tannot - ^ "\n") - tenv)) - Type_internal.initial_typ_env_list) in - Printf.printf "%s" ppd_initial_typ_env ; - else + else let parsed = (List.map (fun f -> (f,(parse_file f))) !opt_file_arguments) in - let ast = + let ast = List.fold_right (fun (_,(Parse_ast.Defs ast_nodes)) (Parse_ast.Defs later_nodes) -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in - let (ast,kenv,ord) = convert_ast ast in - let (ast,type_envs) = check_ast ast kenv ord in + let ast = convert_ast ast in + let (ast, type_envs) = check_ast ast in + + let (ast, type_envs) = + match !opt_mono_split with + | [] -> ast, type_envs + | locs -> monomorphise_ast locs ast + in + let ast = rewrite_ast ast in let out_name = match !opt_file_out with | None -> fst (List.hd parsed) | Some f -> f ^ ".sail" in (*let _ = Printf.eprintf "Type checked, next to pretty print" in*) - begin + begin (if !(opt_print_verbose) then ((Pretty_print.pp_defs stdout) ast) else ()); diff --git a/src/sail.odocl b/src/sail.odocl index 0872c3f9..445d6b73 100644 --- a/src/sail.odocl +++ b/src/sail.odocl @@ -12,5 +12,4 @@ pretty_print process_file reporting_basic type_check -type_internal util diff --git a/src/sail_lib.ml b/src/sail_lib.ml deleted file mode 100644 index df2b6d61..00000000 --- a/src/sail_lib.ml +++ /dev/null @@ -1,76 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* *) -(* 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. *) -(**************************************************************************) - -(** A Sail library *) - -(* This library is not well-thought. It has grown driven by the need to - * reuse some components of Sail in the Power XML extraction tool. It - * should by no means by considered stable (hence the lack of mli - * interface file), and is not intended for general consumption. Use at - * your own risks. *) - -module Pretty = Pretty_print - -let parse_exps s = - let lexbuf = Lexing.from_string s in - try - let pre_exps = Parser.nonempty_exp_list Lexer.token lexbuf in - List.map (Initial_check.to_ast_exp Type_internal.initial_kind_env (Ast.Ord_aux(Ast.Ord_inc,Parse_ast.Unknown))) pre_exps - with - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p lexbuf in - let msg = Printf.sprintf "syntax error on character %d" pos.Lexing.pos_cnum in - failwith msg - | Parse_ast.Parse_error_locn(l,m) -> - let rec format l = match l with - | Parse_ast.Unknown -> "???" - | Parse_ast.Range(p1,p2) -> Printf.sprintf "%d:%d" p1.Lexing.pos_cnum p2.Lexing.pos_cnum - | Parse_ast.Generated l -> Printf.sprintf "code generated near: %s" (format l) - | Parse_ast.Int(s,_) -> Printf.sprintf "code for by: %s" s in - let msg = Printf.sprintf "syntax error: %s %s" (format l) m in - failwith msg - | Lexer.LexError(s,p) -> - let msg = Printf.sprintf "lexing error: %s %d" s p.Lexing.pos_cnum in - failwith msg - - - diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index 8cb5a796..1447ff02 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -42,10 +42,9 @@ open Ast open Util -open Big_int -open Type_internal +open Ast_util -type typ = Type_internal.t +module Nameset = Set.Make(String) let mt = Nameset.empty @@ -58,7 +57,7 @@ let set_to_string n = (*Query a spec for its default order if one is provided. Assumes Inc if not *) -let get_default_order_sp (DT_aux(spec,_)) = +(* let get_default_order_sp (DT_aux(spec,_)) = match spec with | DT_order (Ord_aux(o,_)) -> (match o with @@ -77,11 +76,11 @@ let rec default_order (Defs defs) = | def::defs -> match get_default_order_def def with | None -> default_order (Defs defs) - | Some o -> o + | Some o -> o *) (*Is within range*) -let check_in_range (candidate : big_int) (range : typ) : bool = +(* let check_in_range (candidate : big_int) (range : typ) : bool = match range.t with | Tapp("range", [TA_nexp min; TA_nexp max]) | Tabbrev(_,{t=Tapp("range", [TA_nexp min; TA_nexp max])}) -> let min,max = @@ -182,21 +181,18 @@ let is_within_range candidate range constraints = | _ -> Maybe) | _ -> Maybe -let is_within_machine64 candidate constraints = is_within_range candidate int64_t constraints +let is_within_machine64 candidate constraints = is_within_range candidate int64_t constraints *) (************************************************************************************************) (*FV finding analysis: identifies the free variables of a function, expression, etc *) -let id_to_string (Ast.Id_aux (i,_)) = match i with - | Ast.Id s | Ast.DeIid s -> s - let conditional_add typ_or_exp bound used id = let known_list = if typ_or_exp (*true for typ*) then ["bit";"vector";"unit";"string";"int";"bool";"boolean"] else ["=="; "!="; "|";"~";"&";"add_int"] in - let i = (id_to_string id) in - if Nameset.mem i bound || List.mem i known_list + let i = (string_of_id id) in + if Nameset.mem i bound || List.mem i known_list then used else Nameset.add i used @@ -207,34 +203,28 @@ let conditional_add_exp = conditional_add false let nameset_bigunion = List.fold_left Nameset.union mt -let rec free_type_names_t consider_var {t = t} = match t with - | Tvar name -> if consider_var then Nameset.add name mt else mt - | Tid name -> Nameset.add name mt - | Tfn (t1,t2,_,_) -> Nameset.union (free_type_names_t consider_var t1) - (free_type_names_t consider_var t2) - | Ttup ts -> free_type_names_ts consider_var ts - | Tapp (name,targs) -> Nameset.add name (free_type_names_t_args consider_var targs) - | Tabbrev (t1,t2) -> Nameset.union (free_type_names_t consider_var t1) +let rec free_type_names_t consider_var (Typ_aux (t, _)) = match t with + | Typ_var name -> if consider_var then Nameset.add (string_of_kid name) mt else mt + | Typ_id name -> Nameset.add (string_of_id name) mt + | Typ_fn (t1,t2,_) -> Nameset.union (free_type_names_t consider_var t1) (free_type_names_t consider_var t2) - | Toptions (t,m_t) -> Nameset.union (free_type_names_t consider_var t) - (free_type_names_maybe_t consider_var m_t) - | Tuvar _ -> mt + | Typ_tup ts -> free_type_names_ts consider_var ts + | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs) + | Typ_wild -> mt and free_type_names_ts consider_var ts = nameset_bigunion (List.map (free_type_names_t consider_var) ts) and free_type_names_maybe_t consider_var = function | Some t -> free_type_names_t consider_var t | None -> mt and free_type_names_t_arg consider_var = function - | TA_typ t -> free_type_names_t consider_var t + | Typ_arg_aux (Typ_arg_typ t, _) -> free_type_names_t consider_var t | _ -> mt and free_type_names_t_args consider_var targs = nameset_bigunion (List.map (free_type_names_t_arg consider_var) targs) let rec free_type_names_tannot consider_var = function - | NoTyp -> mt - | Base ((_,t),_ ,_,_,_,_) -> free_type_names_t consider_var t - | Overload (tannot,_,tannots) -> - nameset_bigunion (List.map (free_type_names_tannot consider_var) (tannot :: tannots)) + | None -> mt + | Some (_, t, _) -> free_type_names_t consider_var t let rec fv_of_typ consider_var bound used (Typ_aux (t,_)) : Nameset.t = @@ -285,16 +275,16 @@ let rec pat_bindings consider_var bound used (P_aux(p,(_,tannot))) = let list_fv bound used ps = List.fold_right (fun p (b,n) -> pat_bindings consider_var b n p) ps (bound, used) in match p with | P_as(p,id) -> let b,ns = pat_bindings consider_var bound used p in - Nameset.add (id_to_string id) b,ns + Nameset.add (string_of_id id) b,ns | P_typ(t,p) -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in let ns = fv_of_typ consider_var bound used t in pat_bindings consider_var bound ns p | P_id id -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in - Nameset.add (id_to_string id) bound,used + Nameset.add (string_of_id id) bound,used | P_app(id,pats) -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in - list_fv bound (Nameset.add (id_to_string id) used) pats + list_fv bound (Nameset.add (string_of_id id) used) pats | P_record(fpats,_) -> List.fold_right (fun (Ast.FP_aux(Ast.FP_Fpat(_,p),_)) (b,n) -> pat_bindings consider_var bound used p) fpats (bound,used) @@ -324,7 +314,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. | E_if(c,t,e) -> list_fv bound used set [c;t;e] | E_for(id,from,to_,by,_,body) -> let _,used,set = list_fv bound used set [from;to_;by] in - fv_of_exp consider_var (Nameset.add (id_to_string id) bound) used set body + fv_of_exp consider_var (Nameset.add (string_of_id id) bound) used set body | E_vector_indexed (es_i,(Ast.Def_val_aux(default,_))) -> let bound,used,set = List.fold_right @@ -383,13 +373,13 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = match lexp with | LEXP_id id -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in - let i = id_to_string id in + let i = string_of_id id in if Nameset.mem i bound then bound, used, Nameset.add i set else Nameset.add i bound, Nameset.add i used, set | LEXP_cast(typ,id) -> let used = Nameset.union (free_type_names_tannot consider_var tannot) used in - let i = id_to_string id in + let i = string_of_id id in let used_t = fv_of_typ consider_var bound used typ in if Nameset.mem i bound then bound, used_t, Nameset.add i set @@ -401,7 +391,7 @@ and fv_of_lexp consider_var bound used set (LEXP_aux(lexp,(_,tannot))) = List.fold_right (fun e (b,u,s) -> fv_of_exp consider_var b u s e) args (bound,used,set) in - bound,Nameset.add (id_to_string id) used,set + bound,Nameset.add (string_of_id id) used,set | LEXP_field(lexp,_) -> fv_of_lexp consider_var bound used set lexp | LEXP_vector(lexp,exp) -> let bound_l,used,set = fv_of_lexp consider_var bound used set lexp in @@ -418,47 +408,49 @@ let init_env s = Nameset.singleton s let typ_variants consider_var bound tunions = List.fold_right (fun (Tu_aux(t,_)) (b,n) -> match t with - | Tu_id id -> Nameset.add (id_to_string id) b,n - | Tu_ty_id(t,id) -> Nameset.add (id_to_string id) b, fv_of_typ consider_var b n t) + | Tu_id id -> Nameset.add (string_of_id id) b,n + | Tu_ty_id(t,id) -> Nameset.add (string_of_id id) b, fv_of_typ consider_var b n t) tunions (bound,mt) let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with - | KD_nabbrev(_,id,_,nexp) -> init_env (id_to_string id), fv_of_nexp consider_var mt mt nexp + | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp | KD_abbrev(_,id,_,typschm) -> - init_env (id_to_string id), snd (fv_of_typschm consider_var mt mt typschm) + init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) | KD_record(_,id,_,typq,tids,_) -> - let binds = init_env (id_to_string id) in + let binds = init_env (string_of_id id) in let bounds = if consider_var then typq_bindings typq else mt in binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt | KD_variant(_,id,_,typq,tunions,_) -> - let bindings = Nameset.add (id_to_string id) (if consider_var then typq_bindings typq else mt) in + let bindings = Nameset.add (string_of_id id) (if consider_var then typq_bindings typq else mt) in typ_variants consider_var bindings tunions | KD_enum(_,id,_,ids,_) -> - Nameset.of_list (List.map id_to_string (id::ids)),mt + Nameset.of_list (List.map string_of_id (id::ids)),mt | KD_register(_,id,n1,n2,_) -> - init_env (id_to_string id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 + init_env (string_of_id id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 let fv_of_type_def consider_var (TD_aux(t,_)) = match t with - | TD_abbrev(id,_,typschm) -> init_env (id_to_string id), snd (fv_of_typschm consider_var mt mt typschm) + | TD_abbrev(id,_,typschm) -> init_env (string_of_id id), snd (fv_of_typschm consider_var mt mt typschm) | TD_record(id,_,typq,tids,_) -> - let binds = init_env (id_to_string id) in + let binds = init_env (string_of_id id) in let bounds = if consider_var then typq_bindings typq else mt in binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt | TD_variant(id,_,typq,tunions,_) -> - let bindings = Nameset.add (id_to_string id) (if consider_var then typq_bindings typq else mt) in + let bindings = Nameset.add (string_of_id id) (if consider_var then typq_bindings typq else mt) in typ_variants consider_var bindings tunions | TD_enum(id,_,ids,_) -> - Nameset.of_list (List.map id_to_string (id::ids)),mt + Nameset.of_list (List.map string_of_id (id::ids)),mt | TD_register(id,n1,n2,_) -> - init_env (id_to_string id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 + init_env (string_of_id id), fv_of_nexp consider_var mt (fv_of_nexp consider_var mt mt n1) n2 let fv_of_tannot_opt consider_var (Typ_annot_opt_aux (t,_)) = match t with | Typ_annot_opt_some (typq,typ) -> let bindings = if consider_var then typq_bindings typq else mt in let free = fv_of_typ consider_var bindings mt typ in - (bindings,free) + (bindings,free) + | Typ_annot_opt_none -> + (mt, mt) (*Unlike the other fv, the bound returns are the names bound by the pattern for use in the exp*) let fv_of_funcl consider_var base_bounds (FCL_aux(FCL_Funcl(id,pat,exp),l)) = @@ -469,7 +461,7 @@ let fv_of_funcl consider_var base_bounds (FCL_aux(FCL_Funcl(id,pat,exp),l)) = let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_)) = let fun_name = match funcls with | [] -> failwith "fv_of_fun fell off the end looking for the function name" - | FCL_aux(FCL_Funcl(id,_,_),_)::_ -> id_to_string id in + | FCL_aux(FCL_Funcl(id,_,_),_)::_ -> string_of_id id in let base_bounds = match rec_opt with | Rec_aux(Ast.Rec_rec,_) -> init_env fun_name | _ -> mt in @@ -477,7 +469,9 @@ let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_)) | Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ),_) -> let bindings = if consider_var then typq_bindings typq else mt in let bound = Nameset.union bindings base_bounds in - bound, fv_of_typ consider_var bound mt typ in + bound, fv_of_typ consider_var bound mt typ + | Typ_annot_opt_aux(Typ_annot_opt_none, _) -> + base_bounds, mt in let ns = List.fold_right (fun (FCL_aux(FCL_Funcl(_,pat,exp),_)) ns -> let pat_bs,pat_ns = pat_bindings consider_var base_bounds ns pat in let _, exp_ns,_ = fv_of_exp consider_var pat_bs pat_ns Nameset.empty exp in @@ -485,8 +479,9 @@ let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_)) init_env fun_name,Nameset.union ns ns_r let fv_of_vspec consider_var (VS_aux(vspec,_)) = match vspec with - | VS_val_spec(ts,id) | VS_extern_no_rename (ts,id) | VS_extern_spec(ts,id,_)-> - init_env ("val:" ^ (id_to_string id)), snd (fv_of_typschm consider_var mt mt ts) + | VS_val_spec(ts,id) | VS_extern_no_rename (ts,id) | VS_extern_spec(ts,id,_) + | VS_cast_spec(ts,id) -> + init_env ("val:" ^ (string_of_id id)), snd (fv_of_typschm consider_var mt mt ts) let rec find_scattered_of name = function | [] -> [] @@ -495,7 +490,7 @@ let rec find_scattered_of name = function | SD_scattered_function(_,_,_,id) | SD_scattered_funcl(FCL_aux(FCL_Funcl(id,_,_),_)) | SD_scattered_unioncl(id,_) -> - if name = id_to_string id + if name = string_of_id id then [sd] else [] | _ -> [])@ (find_scattered_of name defs) @@ -506,17 +501,19 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd let b,ns = (match tannot_opt with | Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ),_) -> let bindings = if consider_var then typq_bindings typq else mt in - bindings, fv_of_typ consider_var bindings mt typ) in - init_env (id_to_string id),ns + bindings, fv_of_typ consider_var bindings mt typ + | Typ_annot_opt_aux(Typ_annot_opt_none, _) -> + mt, mt) in + init_env (string_of_id id),ns | SD_scattered_funcl (FCL_aux(FCL_Funcl(id,pat,exp),_)) -> let pat_bs,pat_ns = pat_bindings consider_var mt mt pat in let _,exp_ns,_ = fv_of_exp consider_var pat_bs pat_ns Nameset.empty exp in let scattered_binds = match pat with - | P_aux(P_app(pid,_),_) -> init_env ((id_to_string id) ^ "/" ^ (id_to_string pid)) + | P_aux(P_app(pid,_),_) -> init_env ((string_of_id id) ^ "/" ^ (string_of_id pid)) | _ -> mt in scattered_binds, exp_ns | SD_scattered_variant (id,_,_) -> - let name = id_to_string id in + let name = string_of_id id in let uses = if consider_scatter_as_one then @@ -528,12 +525,12 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd else mt in init_env name, uses | SD_scattered_unioncl(id, type_union) -> - let typ_name = id_to_string id in + let typ_name = string_of_id id in let b = init_env typ_name in let (b,r) = typ_variants consider_var b [type_union] in (Nameset.remove typ_name b, Nameset.add typ_name r) | SD_scattered_end id -> - let name = id_to_string id in + let name = string_of_id id in let uses = if consider_scatter_as_one (*Note: if this is a function ending, the dec is included *) then @@ -545,11 +542,11 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd let fv_of_rd consider_var (DEC_aux (d,_)) = match d with | DEC_reg(t,id) -> - init_env (id_to_string id), fv_of_typ consider_var mt mt t + init_env (string_of_id id), fv_of_typ consider_var mt mt t | DEC_alias(id,alias) -> - init_env (id_to_string id),mt + init_env (string_of_id id),mt | DEC_typ_alias(t,id,alias) -> - init_env (id_to_string id), mt + init_env (string_of_id id), mt let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_kind kdef -> fv_of_kind_def consider_var kdef @@ -557,6 +554,7 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function | DEF_fundef fdef -> fv_of_fun consider_var fdef | DEF_val lebind -> ((fun (b,u,_) -> (b,u)) (fv_of_let consider_var mt mt mt lebind)) | DEF_spec vspec -> fv_of_vspec consider_var vspec + | DEF_overload (id,ids) -> init_env (string_of_id id), List.fold_left (fun ns id -> Nameset.add (string_of_id id) ns) mt ids | DEF_default def -> mt,mt | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef | DEF_reg_dec rdec -> fv_of_rd consider_var rdec diff --git a/src/spec_analysis.mli b/src/spec_analysis.mli index fa8dad3b..6295a7ec 100644 --- a/src/spec_analysis.mli +++ b/src/spec_analysis.mli @@ -42,13 +42,7 @@ open Ast open Util -open Big_int -open Type_internal - -type typ = Type_internal.t - -(*Returns the declared default order of a set of definitions, defaulting to Inc if no default is provided *) -val default_order : tannot defs -> order +open Type_check (*Determines if the first typ is within the range of the the second typ, using the constraints provided when the first typ contains variables. @@ -58,19 +52,19 @@ val default_order : tannot defs -> order to be anything other than a vector, a range, an atom, or a bit (after suitable unwrapping of abbreviations, reg, and registers). *) -val is_within_range: typ -> typ -> nexp_range list -> triple -val is_within_machine64 : typ -> nexp_range list -> triple +(* val is_within_range: typ -> typ -> nexp_range list -> triple +val is_within_machine64 : typ -> nexp_range list -> triple *) (* free variables and dependencies *) (*fv_of_def consider_ty_vars consider_scatter_as_one all_defs all_defs def -> (bound_by_def, free_in_def) *) -val fv_of_def: bool -> bool -> (tannot def) list -> tannot def -> Nameset.t * Nameset.t +(* val fv_of_def: bool -> bool -> ('a def) list -> 'a def -> Nameset.t * Nameset.t *) (*group_defs consider_scatter_as_one all_defs -> ((bound_by_def, free_in_def), def) list *) -val group_defs : bool -> tannot defs -> ((Nameset.t * Nameset.t) * (tannot def)) list +(* val group_defs : bool -> 'a defs -> ((Nameset.t * Nameset.t) * ('a def)) list *) (*reodering definitions, initial functions *) (* produce a new ordering for defs, limiting to those listed in the list, which respects dependencies *) -val restrict_defs : tannot defs -> string list -> tannot defs +(* val restrict_defs : 'a defs -> string list -> 'a defs *) val top_sort_defs : tannot defs -> tannot defs diff --git a/src/type_check.ml b/src/type_check.ml index c4119281..c2351a8a 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Alasdair Armstrong *) (* *) (* All rights reserved. *) (* *) @@ -40,2490 +41,2684 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Big_int open Ast -open Type_internal -type kind = Type_internal.kind -type typ = Type_internal.t -type 'a exp = 'a Ast.exp -type 'a emap = 'a Envmap.t - -type envs = Env of def_envs * tannot emap * bounds_env * t_arg emap -type 'a envs_out = 'a * envs - -let id_to_string (Id_aux(id,l)) = - match id with - | Id(s) -> s - | DeIid(s) -> s - -let get_e_typ (E_aux(_,(_,a))) = - match a with - | Base((_,t),_,_,_,_,_) -> t - | _ -> new_t () - -let typ_error l msg = raise (Reporting_basic.err_typ l msg) - -let rec field_equivs fields fmaps = - match fields with - | [] -> Some [] - | (FP_aux(FP_Fpat(id,pat),(l,annot)))::fields -> - if (List.mem_assoc (id_to_string id) fmaps) - then match (field_equivs fields fmaps) with - | None -> None - | Some [] -> None - | Some fs -> Some(((List.assoc (id_to_string id) fmaps),id,l,pat)::fs) - else None - -let rec fields_to_rec fields rec_env = - match rec_env with - | [] -> None - | (id,Register,tannot,fmaps)::rec_env -> fields_to_rec fields rec_env - | (id,Record,tannot,fmaps)::rec_env -> - if (List.length fields) = (List.length fmaps) then - match field_equivs fields fmaps with - | Some(ftyps) -> Some(id,tannot,ftyps) - | None -> fields_to_rec fields rec_env - else fields_to_rec fields rec_env - -let kind_to_k (K_aux((K_kind baseks),l)) = - let bk_to_k (BK_aux(bk,l')) = - match bk with - | BK_type -> { k = K_Typ} - | BK_nat -> { k = K_Nat} - | BK_order -> { k = K_Ord} - | BK_effect -> { k = K_Efct} - in - match baseks with - | [] -> raise (Reporting_basic.err_unreachable l "Empty kind") - | [bk] -> bk_to_k bk - | bks -> (match List.rev bks with - | [] -> raise (Reporting_basic.err_unreachable l "Empty after reverse") - | out::args -> {k = K_Lam( List.map bk_to_k (List.rev args), bk_to_k out) }) - -let rec has_typ_app check_nested name (Typ_aux(typ,_)) = - match typ with - | Typ_id i -> name = (id_to_string i) - | Typ_tup ts -> List.exists (has_typ_app check_nested name) ts - | Typ_app(i,args) -> name = (id_to_string i) || - (check_nested && (List.exists (has_typ_app_ta check_nested name) args)) - | _ -> false -and has_typ_app_ta check_nested name (Typ_arg_aux(ta,_)) = - match ta with - | Typ_arg_typ t -> has_typ_app check_nested name t - | _ -> false +open Util +open Ast_util +open Big_int -let rec extract_if_first recur name (Typ_aux(typ,l)) = - match (typ,recur) with - | (Typ_id i,_) | (Typ_app(i,_),_) -> - if name = (id_to_string i) then Some(typ, Typ_aux(Typ_id (Id_aux (Id "unit", l)),l)) else None - | (Typ_tup[t'],true) -> extract_if_first false name t' - | (Typ_tup[t1;t2],true) -> (match extract_if_first false name t1 with - | Some(t,_) -> Some(t,t2) - | None -> None) - | (Typ_tup(t'::ts),true) -> (match (extract_if_first false name t') with - | Some(t,_) -> Some(t, Typ_aux(Typ_tup ts,l)) - | None -> None) - | _ -> None - -let rec typ_to_t envs imp_ok fun_ok (Typ_aux(typ,l)) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - let trans t = typ_to_t envs false false t in - match typ with - | Typ_id i -> - let t_init = {t = Tid (id_to_string i)} in - let t_abbrev,_ = get_abbrev d_env t_init in - t_abbrev - | Typ_var (Kid_aux((Var i),l')) -> {t = Tvar i} - | Typ_fn (ty1,ty2,e) -> - if fun_ok - then - if has_typ_app false "implicit" ty1 - then - if imp_ok - then (match extract_if_first true "implicit" ty1 with - | Some(imp,new_ty1) -> (match imp with - | Typ_app(_,[Typ_arg_aux(Typ_arg_nexp ((Nexp_aux(n,l')) as ne),_)]) -> - {t = Tfn (trans new_ty1, trans ty2, IP_user (anexp_to_nexp envs ne), aeffect_to_effect e)} - | _ -> typ_error l "Declaring an implicit parameter requires a Nat specification") - | None -> typ_error l "A function type with an implicit parameter must declare the implicit first") - else typ_error l "This function has one (or more) implicit parameter(s) not permitted here" - else {t = Tfn (trans ty1,trans ty2,IP_none,aeffect_to_effect e)} - else typ_error l "Function types are only permitted at the top level." - | Typ_tup(tys) -> {t = Ttup (List.map trans tys) } - | Typ_app(i,args) -> {t = Tapp (id_to_string i,List.map (typ_arg_to_targ envs) args) } - | Typ_wild -> new_t () -and typ_arg_to_targ envs (Typ_arg_aux(ta,l)) = - match ta with - | Typ_arg_nexp n -> TA_nexp (anexp_to_nexp envs n) - | Typ_arg_typ t -> TA_typ (typ_to_t envs false false t) - | Typ_arg_order o -> TA_ord (aorder_to_ord o) - | Typ_arg_effect e -> TA_eft (aeffect_to_effect e) -and anexp_to_nexp envs ((Nexp_aux(n,l)) : Ast.nexp) : nexp = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match n with - | Nexp_var (Kid_aux((Var i),l')) -> mk_nv i - | Nexp_id id -> - let s = id_to_string id in - (match Envmap.apply d_env.nabbrevs s with - |Some n -> n - | None -> typ_error l ("Unbound nat id " ^ s)) - | Nexp_constant i -> mk_c_int i - | Nexp_times(n1,n2) -> mk_mult (anexp_to_nexp envs n1) (anexp_to_nexp envs n2) - | Nexp_sum(n1,n2) -> mk_add (anexp_to_nexp envs n1) (anexp_to_nexp envs n2) - | Nexp_minus(n1,n2) -> mk_sub (anexp_to_nexp envs n1) (anexp_to_nexp envs n2) - | Nexp_exp n -> mk_2n(anexp_to_nexp envs n) - | Nexp_neg n -> mk_neg(anexp_to_nexp envs n) -and aeffect_to_effect ((Effect_aux(e,l)) : Ast.effect) : effect = - match e with - | Effect_var (Kid_aux((Var i),l')) -> {effect = Evar i} - | Effect_set effects -> {effect = Eset effects} -and aorder_to_ord (Ord_aux(o,l) : Ast.order) = - match o with - | Ord_var (Kid_aux((Var i),l')) -> {order = Ovar i} - | Ord_inc -> {order = Oinc} - | Ord_dec -> {order = Odec} - -let rec quants_to_consts ((Env (d_env,t_env,b_env,tp_env)) as env) qis : (t_params * t_arg list * nexp_range list) = - match qis with - | [] -> [],[],[] - | (QI_aux(qi,l))::qis -> - let (ids,typarms,cs) = quants_to_consts env qis in - (match qi with - | QI_id(KOpt_aux(ki,l')) -> - (match ki with - | KOpt_none (Kid_aux((Var i),l'')) -> - (match Envmap.apply d_env.k_env i with - | Some k -> - let targ = match k.k with - | K_Typ -> TA_typ {t = Tvar i} - | K_Nat -> TA_nexp (mk_nv i) - | K_Ord -> TA_ord { order = Ovar i} - | K_Efct -> TA_eft { effect = Evar i} - | _ -> raise (Reporting_basic.err_unreachable l'' "illegal kind allowed") in - ((i,k)::ids,targ::typarms,cs) - | None -> raise (Reporting_basic.err_unreachable l'' "Unkinded id without default after initial check")) - | KOpt_kind(kind,Kid_aux((Var i),l'')) -> - let k = kind_to_k kind in - let targ = match k.k with - | K_Typ -> TA_typ {t = Tvar i} - | K_Nat -> TA_nexp (mk_nv i) - | K_Ord -> TA_ord { order = Ovar i} - | K_Efct -> TA_eft { effect = Evar i} - | K_Lam _ -> typ_error l'' "kind -> kind not permitted here" - | _ -> raise (Reporting_basic.err_unreachable l'' "Kind either infer or internal here") in - ((i,k)::ids,targ::typarms,cs)) - | QI_const(NC_aux(nconst,l')) -> - (*TODO: somehow the requirement vs best guarantee needs to be derived from user or context*) - (match nconst with - | NC_fixed(n1,n2) -> - (ids,typarms,Eq(Specc l',anexp_to_nexp env n1,anexp_to_nexp env n2)::cs) - | NC_bounded_ge(n1,n2) -> - (ids,typarms,GtEq(Specc l',Guarantee,anexp_to_nexp env n1,anexp_to_nexp env n2)::cs) - | NC_bounded_le(n1,n2) -> - (ids,typarms,LtEq(Specc l',Guarantee,anexp_to_nexp env n1,anexp_to_nexp env n2)::cs) - | NC_nat_set_bounded(Kid_aux((Var i),l''), bounds) -> (ids,typarms,In(Specc l',i,bounds)::cs))) - -let typq_to_params envs (TypQ_aux(tq,l)) = - match tq with - | TypQ_tq(qis) -> quants_to_consts envs qis - | TypQ_no_forall -> [],[],[] - -let typschm_to_tannot envs imp_parm_ok fun_ok ((TypSchm_aux(typschm,l)):typschm) (tag : tag) : tannot = - match typschm with - | TypSchm_ts(tq,typ) -> - let t = typ_to_t envs imp_parm_ok fun_ok typ in - let (ids,_,constraints) = typq_to_params envs tq in - Base((ids,t),tag,constraints,pure_e,pure_e,nob) - -let into_register_typ t = - match t.t with - | Tapp("register",_) -> t - | Tabbrev(ti,{t=Tapp("register",_)}) -> t - | _ -> {t=Tapp("register",[TA_typ t])} - -let into_register d_env (t : tannot) : tannot = - match t with - | Base((ids,ty),tag,constraints,eftl,eftr,bindings) -> - let ty',_ = get_abbrev d_env ty in - Base((ids,into_register_typ ty'),tag,constraints,eftl,eftr,bindings) - | t -> t - -let rec check_pattern envs emp_tag expect_t (P_aux(p,(l,annot))) : ((tannot pat) * (tannot emap) * nexp_range list * bounds_env * t) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - (*let _ = Printf.eprintf "checking pattern with expected type %s\n" (t_to_string expect_t) in*) - let expect_t,cs = get_abbrev d_env expect_t in - (*let _ = Printf.eprintf "check pattern expect_t after abbrev %s\n" (t_to_string expect_t) in*) - let expect_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in - match p with - | P_lit (L_aux(lit,l')) -> - let t,lit = - (match lit with - | L_unit -> unit_t,lit - | L_zero -> bit_t,lit - | L_one -> bit_t,lit - | L_true -> bit_t,L_one - | L_false -> bit_t,L_zero - | L_num i -> - (match expect_actual.t with - | Tid "bit" -> - if i = 0 then bit_t,L_zero - else if i = 1 then bit_t,L_one - else {t = Tapp("atom", - [TA_nexp (mk_c_int i)])},lit - | _ -> {t = Tapp("atom", - [TA_nexp (mk_c_int i)])},lit) - | L_hex s -> - let size = big_int_of_int ((String.length s) * 4) in - let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in - {t = Tapp("vector", - [TA_nexp (if is_inc then n_zero else mk_c(sub_big_int size one)); - TA_nexp (mk_c size); - TA_ord d_env.default_o; TA_typ{t=Tid "bit"}])},lit - | L_bin s -> - let size = big_int_of_int (String.length s) in - let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in - {t = Tapp("vector", - [TA_nexp(if is_inc then n_zero else mk_c(sub_big_int size one)); - TA_nexp (mk_c size); - TA_ord d_env.default_o;TA_typ{t = Tid"bit"}])},lit - | L_string s -> {t = Tid "string"},lit - | L_undef -> typ_error l' "Cannot pattern match on undefined") in - (*let _ = Printf.eprintf "checking pattern literal. expected type is %s. t is %s\n" - (t_to_string expect_t) (t_to_string t) in*) - let t',cs' = type_consistent (Patt l) d_env Require true t expect_t in - let cs_l = cs@cs' in - (P_aux(P_lit(L_aux(lit,l')),(l,cons_tag_annot t emp_tag cs_l)),Envmap.empty,cs_l,nob,t) - | P_wild -> - (P_aux(p,(l,cons_tag_annot expect_t emp_tag cs)),Envmap.empty,cs,nob,expect_t) - | P_as(pat,id) -> - let v = id_to_string id in - let (pat',env,constraints,bounds,t) = check_pattern envs emp_tag expect_t pat in - let bounds = extract_bounds d_env v t in - let tannot = Base(([],t),emp_tag,cs,pure_e,pure_e,bounds) in - (P_aux(P_as(pat',id),(l,tannot)),Envmap.insert env (v,tannot),cs@constraints,bounds,t) - | P_typ(typ,pat) -> - let t = typ_to_t envs false false typ in - let t = typ_subst tp_env false t in - let (pat',env,constraints,bounds,u) = check_pattern envs emp_tag t pat in - let t,cs_consistent = type_consistent (Patt l) d_env Guarantee false t expect_t in - (P_aux(P_typ(typ,pat'),(l,tag_annot t emp_tag)),env,cs@constraints@cs_consistent,bounds,t) - | P_id id -> - let i = id_to_string id in - let default_bounds = extract_bounds d_env i expect_t in - let default = let id_annot = Base(([],expect_t),emp_tag,cs,pure_e,pure_e,default_bounds) in - let pat_annot = match is_enum_typ d_env expect_t with - | None -> id_annot - | Some n -> Base(([],expect_t), Enum n, cs,pure_e,pure_e,default_bounds) in - (P_aux(p,(l,pat_annot)),Envmap.from_list [(i,id_annot)],cs,default_bounds,expect_t) in - (match Envmap.apply t_env i with - | Some(Base((params,t),Constructor n,cs,efl,efr,bounds)) -> - let t,cs,ef,_ = subst params false false t cs efl in - (match t.t with - | Tfn({t = Tid "unit"},t',_,ef) -> - if conforms_to_t d_env true false t' expect_t - then - let tp,cp = type_consistent (Expr l) d_env Guarantee false t' expect_t in - (P_aux(P_app(id,[]),(l,tag_annot t (Constructor n))),Envmap.empty,cs@cp,bounds,tp) - else default - | Tfn(t1,t',_,e) -> - if conforms_to_t d_env true false t' expect_t - then typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none") - else default - | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type")) - | Some(Base((params,t),Enum max,cs,efl,efr,bounds)) -> - let t,cs,ef,_ = subst params false false t cs efl in - if conforms_to_t d_env false false t expect_t - then - let tp,cp = type_consistent (Expr l) d_env Guarantee false t expect_t in - (P_aux(P_app(id,[]),(l,tag_annot t (Enum max))),Envmap.empty,cs@cp,bounds,tp) - else default - | _ -> default) - | P_app(id,pats) -> - let i = id_to_string id in - (*let _ = Printf.eprintf "checking constructor pattern %s with expected type %s \n" i (t_to_string expect_t) in*) - (match Envmap.apply t_env i with - | None | Some NoTyp | Some Overload _ -> typ_error l ("Constructor " ^ i ^ " in pattern is undefined") - | Some(Base((params,t),Constructor n,constraints,efl,efr,bounds)) -> - let t,dec_cs,_,_ = subst params false false t constraints efl in - (match t.t with - | Tid id -> if pats = [] - then let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t expect_t in - (P_aux(p,(l,cons_tag_annot t' (Constructor n) dec_cs)), Envmap.empty,dec_cs@ret_cs,nob,t') - else typ_error l ("Constructor " ^ i ^ " does not expect arguments") - | Tfn(t1,t2,IP_none,ef) -> - let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t2 expect_t in - (match pats with - | [] -> let _ = type_consistent (Patt l) d_env Guarantee false unit_t t1 in - (P_aux(P_app(id,[]),(l,cons_tag_annot t' (Constructor n) dec_cs)), - Envmap.empty,dec_cs@ret_cs,nob,t') - | [p] -> let (p',env,p_cs,bounds,u) = check_pattern envs emp_tag t1 p in - (*let _ = Printf.eprintf "return constraints are %s\n" (constraints_to_string ret_cs) in*) - (P_aux(P_app(id,[p']), - (l,cons_tag_annot t' (Constructor n) dec_cs)),env,dec_cs@p_cs@ret_cs,bounds,t') - | pats -> let (pats',env,p_cs,bounds,u) = - match check_pattern envs emp_tag t1 (P_aux(P_tup(pats),(l,annot))) with - | ((P_aux(P_tup(pats'),_)),env,constraints,bounds,u) -> (pats',env,constraints,bounds,u) - | _ -> assert false in - (*let _ = Printf.eprintf "return constraints are %s\n" (constraints_to_string ret_cs) in*) - (P_aux(P_app(id,pats'), - (l,cons_tag_annot t' (Constructor n) dec_cs)),env,dec_cs@p_cs@ret_cs,bounds,t')) - | _ -> typ_error l ("Identifier " ^ i ^ " must be a union constructor")) - | Some(Base((params,t),tag,constraints,efl,efr,bounds)) -> - typ_error l ("Identifier " ^ i ^ " used in pattern is not a union constructor")) - | P_record(fpats,_) -> - (match (fields_to_rec fpats d_env.rec_env) with - | None -> typ_error l ("No struct exists with the listed fields") - | Some(id,tannot,typ_pats) -> - (match tannot with - | (Base((vs,t),tag,cs,eft,_,bounds)) -> - (*let tup = {t = Ttup(List.map (fun (t,_,_,_) -> t) typ_pats)} in*) - (*let ft = {t = Tfn(tup,t, IP_none,pure_e) } in*) - let (ft_subst,cs,_,_) = subst vs false false t cs pure_e in - let subst_rtyp,subst_typs = - match ft_subst.t with | Tfn({t=Ttup tups},rt,_,_) -> rt,tups - | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec gave a non function type") in - let pat_checks = - List.map2 (fun (_,id,l,pat) styp -> - let (pat,env,constraints,new_bounds,u) = check_pattern envs emp_tag styp pat in - let pat = FP_aux(FP_Fpat(id,pat),(l,Base(([],styp),tag,constraints,pure_e,pure_e,new_bounds))) in - (pat,env,constraints,new_bounds)) typ_pats subst_typs in - let pats' = List.map (fun (a,_,_,_) -> a) pat_checks in - (*Need to check for variable duplication here*) - let env = List.fold_right (fun (_,env,_,_) env' -> Envmap.union env env') pat_checks Envmap.empty in - let constraints = (List.fold_right (fun (_,_,cs,_) cons -> cs@cons) pat_checks [])@cs in - let bounds = List.fold_right (fun (_,_,_,bounds) b_env -> merge_bounds bounds b_env) pat_checks nob in - let t',cs' = type_consistent (Patt l) d_env Guarantee false ft_subst expect_t in - (P_aux((P_record(pats',false)),(l,cons_tag_annot t' emp_tag (cs@cs'))),env,constraints@cs',bounds,t') - | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec returned a non Base tannot"))) - | P_vector pats -> - let (item_t, base, rise, ord) = match expect_actual.t with - | Tapp("vector",[TA_nexp b;TA_nexp r;TA_ord o;TA_typ i]) -> (i,b,r,o) - | Tuvar _ -> (new_t (),new_n (),new_n(), d_env.default_o) - | _ -> typ_error l ("Expected a " ^ t_to_string expect_actual ^ " but found a vector") in - let (pats',ts,t_envs,constraints,bounds) = - List.fold_right - (fun pat (pats,ts,t_envs,constraints,bounds) -> - let (pat',t_env,cons,bs,t) = check_pattern envs emp_tag item_t pat in - ((pat'::pats),(t::ts),(t_env::t_envs),(cons@constraints),merge_bounds bs bounds)) - pats ([],[],[],[],nob) in - let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*Need to check for non-duplication of variables*) - let (u,cs) = List.fold_right (fun u (t,cs) -> - let t',cs = type_consistent (Patt l) d_env Require true u t in t',cs) ts (item_t,[]) in - let len = List.length ts in - let t = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) | (Ovar _, Oinc) | (Ouvar _,Oinc) -> - {t = Tapp("vector",[TA_nexp n_zero; - TA_nexp (mk_c_int len); - TA_ord{order=Oinc}; - TA_typ u])} - | (Odec,_) | (Ovar _, Odec) | (Ouvar _,Odec) -> - {t= Tapp("vector", [TA_nexp (mk_c (if len = 0 then zero else (big_int_of_int (len -1)))); - TA_nexp (mk_c_int len); - TA_ord{order=Odec}; - TA_typ u;])} - | _ -> raise (Reporting_basic.err_unreachable l "Default order not set") in - let _,v_cs = type_consistent (Patt l) d_env Guarantee true t expect_t in - (*TODO Should gather the constraints here, with regard to the expected base and rise, and potentially reset them above*) - (P_aux(P_vector(pats'),(l,cons_tag_annot t emp_tag (cs@v_cs))), env,cs@v_cs@constraints,bounds,t) - | P_vector_indexed(ipats) -> - let item_t = match expect_actual.t with - | Tapp("vector",[b;r;o;TA_typ i]) -> i - | Tuvar _ -> new_t () - | _ -> typ_error l ("Expected a vector by pattern form, but a " ^ t_to_string expect_actual ^ " by type") in - let (is,pats) = List.split ipats in - let (fst,lst) = (List.hd is),(List.hd (List.rev is)) in - let inc_or_dec = - if fst < lst then - (let _ = List.fold_left - (fun i1 i2 -> if i1 < i2 then i2 - else typ_error l "Indexed vector pattern was inconsistently increasing") fst (List.tl is) in - true) - else if lst < fst then - (let _ = List.fold_left - (fun i1 i2 -> if i1 > i2 then i2 - else typ_error l "Indexed vector pattern was inconsistently decreasing") fst (List.tl is) in - false) - else typ_error l "Indexed vector cannot be determined as either increasing or decreasing" in - let base,rise = new_n (), new_n () in - let (pats',ts,t_envs,constraints,bounds) = - List.fold_right - (fun (i,pat) (pats,ts,t_envs,constraints,bounds) -> - let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag item_t pat in - (((i,pat')::pats),(t::ts),(env::t_envs),(cons@constraints),merge_bounds new_bounds bounds)) - ipats ([],[],[],[],nob) in - let co = Patt l in - let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*TODO Need to check for non-duplication of variables*) - let (u,cs) = List.fold_right (fun u (t,cs) -> type_consistent co d_env Require true u t) ts (item_t,[]) in - let t = {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise); - (TA_ord{order=(if inc_or_dec then Oinc else Odec)});(TA_typ u)])} in - let cs = if inc_or_dec - then [LtEq(co, Require, base, mk_c_int fst); GtEq(co,Require, rise, mk_c_int(lst-fst));]@cs - else [GtEq(co, Require, base, mk_c_int fst); LtEq(co,Require, rise, mk_c_int(fst -lst));]@cs in - (P_aux(P_vector_indexed(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t) - | P_tup(pats) -> - let item_ts = match expect_actual.t with - | Ttup ts -> - if (List.length ts) = (List.length pats) - then ts - else typ_error l ("Expected a pattern with a tuple with " ^ (string_of_int (List.length ts)) ^ " elements") - | Tuvar _ -> List.map (fun _ -> new_t ()) pats - | _ -> typ_error l ("Expected a tuple by pattern form, but a " ^ (t_to_string expect_actual) ^ " by type") in - let (pats',ts,t_envs,constraints,bounds) = - List.fold_right - (fun (pat,t) (pats,ts,t_envs,constraints,bounds) -> - let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag t pat in - ((pat'::pats),(t::ts),(env::t_envs),cons@constraints,merge_bounds new_bounds bounds)) - (List.combine pats item_ts) ([],[],[],[],nob) in - let env = List.fold_right (fun e env -> Envmap.union e env) t_envs Envmap.empty in (*Need to check for non-duplication of variables*) - let t = {t = Ttup ts} in - (P_aux(P_tup(pats'),(l,tag_annot t emp_tag)), env,constraints,bounds,t) - | P_vector_concat pats -> - let item_t,base,rise,order = - match expect_t.t with - | Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item]) - | Tabbrev(_,{t=Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])}) -> item,b,r,o - | _ -> new_t (),new_n (), new_n (), d_env.default_o in - let vec_ti _ = {t= Tapp("vector",[TA_nexp (new_n ());TA_nexp (new_n ());TA_ord order;TA_typ item_t])} in - let (pats',ts,envs,constraints,bounds) = - List.fold_right - (fun pat (pats,ts,t_envs,constraints,bounds) -> - let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag (vec_ti ()) pat in - (pat'::pats,t::ts,env::t_envs,cons@constraints,merge_bounds new_bounds bounds)) - pats ([],[],[],[],nob) in - let env = - List.fold_right (fun e env -> Envmap.union e env) envs Envmap.empty in (*Need to check for non-duplication of variables*) - let t = {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);(TA_ord order);(TA_typ item_t)])} in - let base_c,r1 = match (List.hd ts).t with - | Tapp("vector",[(TA_nexp b);(TA_nexp r);(TA_ord o);(TA_typ u)]) -> b,r - | _ -> raise (Reporting_basic.err_unreachable l "vector concat pattern impossibility") in - let range_c = List.fold_right - (fun t rn -> - match t.t with - | Tapp("vector",[(TA_nexp b);(TA_nexp r);(TA_ord o);(TA_typ u)]) -> mk_add r rn - | _ -> raise (Reporting_basic.err_unreachable l "vector concat pattern impossibility") ) (List.tl ts) r1 in - let cs = [Eq((Patt l),rise,range_c)]@cs in - (P_aux(P_vector_concat(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t) - | P_list(pats) -> - let item_t = match expect_actual.t with - | Tapp("list",[TA_typ i]) -> i - | Tuvar _ -> new_t () - | _ -> typ_error l ("Expected a list here by pattern form, but expected a " ^ t_to_string expect_actual ^ " by type") in - let (pats',ts,envs,constraints,bounds) = - List.fold_right - (fun pat (pats,ts,t_envs,constraints,bounds) -> - let (pat',env,cons,new_bounds,t) = check_pattern envs emp_tag item_t pat in - (pat'::pats,t::ts,env::t_envs,cons@constraints,merge_bounds new_bounds bounds)) - pats ([],[],[],[],nob) in - let env = List.fold_right (fun e env -> Envmap.union e env) envs Envmap.empty in (*TODO Need to check for non-duplication of variables*) - let u,cs = List.fold_right (fun u (t,cs) -> let t',cs' = type_consistent (Patt l) d_env Require true u t in t',cs@cs') ts (item_t,[]) in - let t = {t = Tapp("list",[TA_typ u])} in - (P_aux(P_list(pats'),(l,cons_tag_annot t emp_tag cs)), env,constraints@cs,bounds,t) - -let rec check_pattern_after_constraint_res envs concrete_length_req expect_t (P_aux(p,(l,annot))) : t = - let check_pat = check_pattern_after_constraint_res envs in - let (Env(d_env,t_env,b_env,tp_env)) = envs in - (*let _ = Printf.eprintf "checking pattern after constraints with expected type %s\n" (t_to_string expect_t) in*) - let expect_t,_ = get_abbrev d_env expect_t in - (*let _ = Printf.eprintf "check pattern after constraints expect_t after abbrev %s\n" (t_to_string expect_t) in*) - let expect_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in - let t_inferred = match annot with - | Base((_,t),tag,cs,_,_,_) -> t - | _ -> failwith "Inference pass did not annotate a pattern with Base annot" in - match p with - | P_lit (L_aux(lit,l')) -> - let t_from_lit = (match lit with - | L_unit -> unit_t - | L_zero | L_one | L_true | L_false -> bit_t - | L_num i -> - (match expect_actual.t with - | Tid "bit" -> if i = 0 || i = 1 then bit_t else typ_error l' "Given number but expected bit" - | _ -> {t = Tapp("atom", [TA_nexp (mk_c_int i)])}) - | L_hex s -> - let size = big_int_of_int ((String.length s) * 4) in - let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in - mk_vector bit_t d_env.default_o (if is_inc then n_zero else mk_c (sub_big_int size one)) (mk_c size) - | L_bin s -> - let size = big_int_of_int (String.length s) in - let is_inc = match d_env.default_o.order with | Oinc -> true | _ -> false in - mk_vector bit_t d_env.default_o (if is_inc then n_zero else mk_c(sub_big_int size one)) (mk_c size) - | L_string s -> string_t - | L_undef -> typ_error l' "Cannot pattern match on undefined") in - let t_c,_ = type_consistent (Patt l) d_env Require true t_from_lit t_inferred in - let t,_ = type_consistent (Patt l) d_env Require true t_c expect_t in - t - | P_wild -> - let t,_ = type_consistent (Patt l) d_env Require true t_inferred expect_t in t - | P_as(pat,id) -> check_pat concrete_length_req expect_t pat - | P_typ(typ,pat) -> - let tdec = typ_to_t envs false false typ in - let tdec = typ_subst tp_env false tdec in - let default _ = let tdec = check_pat false tdec pat in - let t,_ = type_consistent (Patt l) d_env Guarantee false tdec t_inferred in - let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in - t +let opt_tc_debug = ref 0 +let opt_no_effects = ref false +let depth = ref 0 + +let rec indent n = match n with + | 0 -> "" + | n -> "| " ^ indent (n - 1) + +let typ_debug m = if !opt_tc_debug > 1 then prerr_endline (indent !depth ^ m) else () + +let typ_print m = if !opt_tc_debug > 0 then prerr_endline (indent !depth ^ m) else () + +let typ_warning m = prerr_endline ("Warning: " ^ m) + +exception Type_error of l * string;; + +let typ_error l m = raise (Type_error (l, m)) + +let deinfix = function + | Id_aux (Id v, l) -> Id_aux (DeIid v, l) + | Id_aux (DeIid v, l) -> Id_aux (DeIid v, l) + +let string_of_bind (typquant, typ) = string_of_typquant typquant ^ ". " ^ string_of_typ typ + +let unaux_nexp (Nexp_aux (nexp, _)) = nexp +let unaux_order (Ord_aux (ord, _)) = ord +let unaux_typ (Typ_aux (typ, _)) = typ + +let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown) +let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) +let mk_id str = Id_aux (Id str, Parse_ast.Unknown) +let mk_infix_id str = Id_aux (DeIid str, Parse_ast.Unknown) + +let mk_id_typ id = Typ_aux (Typ_id id, Parse_ast.Unknown) + +let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown) +let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown) + +let mk_ord ord_aux = Ord_aux (ord_aux, Parse_ast.Unknown) + +let int_typ = mk_id_typ (mk_id "int") +let nat_typ = mk_id_typ (mk_id "nat") +let unit_typ = mk_id_typ (mk_id "unit") +let bit_typ = mk_id_typ (mk_id "bit") +let real_typ = mk_id_typ (mk_id "real") +let app_typ id args = mk_typ (Typ_app (id, args)) +let atom_typ nexp = mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)])) +let range_typ nexp1 nexp2 = mk_typ (Typ_app (mk_id "range", [mk_typ_arg (Typ_arg_nexp nexp1); mk_typ_arg (Typ_arg_nexp nexp2)])) +let bool_typ = mk_id_typ (mk_id "bool") +let string_typ = mk_id_typ (mk_id "string") +let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (Typ_arg_typ typ)])) + +let vector_typ n m ord typ = + mk_typ (Typ_app (mk_id "vector", + [mk_typ_arg (Typ_arg_nexp n); + mk_typ_arg (Typ_arg_nexp m); + mk_typ_arg (Typ_arg_order ord); + mk_typ_arg (Typ_arg_typ typ)])) + +let is_range (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)]) + when string_of_id f = "atom" -> Some (n, n) + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]) + when string_of_id f = "range" -> Some (n1, n2) + | _ -> None + +let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown) +let nminus n1 n2 = Nexp_aux (Nexp_minus (n1, n2), Parse_ast.Unknown) +let nsum n1 n2 = Nexp_aux (Nexp_sum (n1, n2), Parse_ast.Unknown) +let ntimes n1 n2 = Nexp_aux (Nexp_times (n1, n2), Parse_ast.Unknown) +let npow2 n = Nexp_aux (Nexp_exp n, Parse_ast.Unknown) +let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown) + +let nc_eq n1 n2 = mk_nc (NC_fixed (n1, n2)) +let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2)) +let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown) +let nc_gteq n1 n2 = NC_aux (NC_bounded_ge (n1, n2), Parse_ast.Unknown) +let nc_lt n1 n2 = nc_lteq n1 (nsum n2 (nconstant 1)) +let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nconstant 1)) + +let mk_lit l = E_aux (E_lit (L_aux (l, Parse_ast.Unknown)), (Parse_ast.Unknown, ())) + +(* FIXME: Can now negate all n_constraints *) +let rec nc_negate (NC_aux (nc, _)) = + match nc with + | NC_bounded_ge (n1, n2) -> nc_lt n1 n2 + | NC_bounded_le (n1, n2) -> nc_gt n1 n2 + | NC_fixed (n1, n2) -> nc_neq n1 n2 + | NC_not_equal (n1, n2) -> nc_eq n1 n2 + | NC_and (n1, n2) -> mk_nc (NC_or (nc_negate n1, nc_negate n2)) + | NC_or (n1, n2) -> mk_nc (NC_and (nc_negate n1, nc_negate n2)) + | NC_nat_set_bounded (kid, []) -> typ_error Parse_ast.Unknown "Cannot negate empty nexp set" + | NC_nat_set_bounded (kid, [int]) -> nc_neq (nvar kid) (nconstant int) + | NC_nat_set_bounded (kid, int :: ints) -> + mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_nat_set_bounded (kid, ints))))) + +(* Utilities for constructing effect sets *) + +let mk_effect effs = + Effect_aux (Effect_set (List.map (fun be_aux -> BE_aux (be_aux, Parse_ast.Unknown)) effs), Parse_ast.Unknown) + +let no_effect = mk_effect [] + +module BESet = Set.Make(BE) + +let union_effects e1 e2 = + match e1, e2 with + | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> + let base_effs3 = BESet.elements (BESet.of_list (base_effs1 @ base_effs2)) in + Effect_aux (Effect_set base_effs3, Parse_ast.Unknown) + | _, _ -> assert false (* We don't do Effect variables *) + +let equal_effects e1 e2 = + match e1, e2 with + | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) -> + BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0 + | _, _ -> assert false (* We don't do Effect variables *) + +(* An index_sort is a more general form of range type: it can either + be IS_int, which represents every natural number, or some set of + natural numbers given by an IS_prop expression of the form + {'n. f('n) <= g('n) /\ ...} *) +type index_sort = + | IS_int + | IS_prop of kid * (nexp * nexp) list + +let string_of_index_sort = function + | IS_int -> "INT" + | IS_prop (kid, constraints) -> + "{" ^ string_of_kid kid ^ " | " + ^ string_of_list " & " (fun (x, y) -> string_of_nexp x ^ " <= " ^ string_of_nexp y) constraints + ^ "}" + +let quant_items : typquant -> quant_item list = function + | TypQ_aux (TypQ_tq qis, _) -> qis + | TypQ_aux (TypQ_no_forall, _) -> [] + +let kopt_kid (KOpt_aux (kopt_aux, _)) = + match kopt_aux with + | KOpt_none kid | KOpt_kind (_, kid) -> kid + +let is_nat_kopt = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), _), _) -> true + | KOpt_aux (KOpt_none _, _) -> true + | _ -> false + +let is_order_kopt = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), _), _) -> true + | _ -> false + +let is_typ_kopt = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), _), _) -> true + | _ -> false + +(**************************************************************************) +(* 1. Substitutions *) +(**************************************************************************) + +let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l) +and nexp_subst_aux sv subst = function + | Nexp_id v -> Nexp_id v + | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid + | Nexp_constant c -> Nexp_constant c + | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) + | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp) + | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp) + +let rec nexp_set_to_or l subst = function + | [] -> typ_error l "Cannot substitute into empty nexp set" + | [int] -> NC_fixed (subst, nconstant int) + | (int :: ints) -> NC_or (mk_nc (NC_fixed (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints)) + +let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l) +and nc_subst_nexp_aux l sv subst = function + | NC_fixed (n1, n2) -> NC_fixed (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_nat_set_bounded (kid, ints) as set_nc -> + if Kid.compare kid sv = 0 + then nexp_set_to_or l (mk_nexp subst) ints + else set_nc + | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2) + +let rec typ_subst_nexp sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_nexp_aux sv subst typ, l) +and typ_subst_nexp_aux sv subst = function + | Typ_wild -> Typ_wild + | Typ_id v -> Typ_id v + | Typ_var kid -> Typ_var kid + | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_nexp sv subst typ1, typ_subst_nexp sv subst typ2, effs) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_nexp sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_nexp sv subst) args) +and typ_subst_arg_nexp sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_nexp_aux sv subst arg, l) +and typ_subst_arg_nexp_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv subst nexp) + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_nexp sv subst typ) + | Typ_arg_order ord -> Typ_arg_order ord + | Typ_arg_effect eff -> Typ_arg_effect eff + +let rec typ_subst_typ sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_typ_aux sv subst typ, l) +and typ_subst_typ_aux sv subst = function + | Typ_wild -> Typ_wild + | Typ_id v -> Typ_id v + | Typ_var kid -> if Kid.compare kid sv = 0 then subst else Typ_var kid + | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_typ sv subst typ1, typ_subst_typ sv subst typ2, effs) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_typ sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_typ sv subst) args) +and typ_subst_arg_typ sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_typ_aux sv subst arg, l) +and typ_subst_arg_typ_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp nexp + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_typ sv subst typ) + | Typ_arg_order ord -> Typ_arg_order ord + | Typ_arg_effect eff -> Typ_arg_effect eff + +let order_subst_aux sv subst = function + | Ord_var kid -> if Kid.compare kid sv = 0 then subst else Ord_var kid + | Ord_inc -> Ord_inc + | Ord_dec -> Ord_dec + +let order_subst sv subst (Ord_aux (ord, l)) = Ord_aux (order_subst_aux sv subst ord, l) + +let rec typ_subst_order sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_order_aux sv subst typ, l) +and typ_subst_order_aux sv subst = function + | Typ_wild -> Typ_wild + | Typ_id v -> Typ_id v + | Typ_var kid -> Typ_var kid + | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_order sv subst typ1, typ_subst_order sv subst typ2, effs) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_order sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_order sv subst) args) +and typ_subst_arg_order sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_order_aux sv subst arg, l) +and typ_subst_arg_order_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp nexp + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_order sv subst typ) + | Typ_arg_order ord -> Typ_arg_order (order_subst sv subst ord) + | Typ_arg_effect eff -> Typ_arg_effect eff + +let rec typ_subst_kid sv subst (Typ_aux (typ, l)) = Typ_aux (typ_subst_kid_aux sv subst typ, l) +and typ_subst_kid_aux sv subst = function + | Typ_wild -> Typ_wild + | Typ_id v -> Typ_id v + | Typ_var kid -> if Kid.compare kid sv = 0 then Typ_var subst else Typ_var kid + | Typ_fn (typ1, typ2, effs) -> Typ_fn (typ_subst_kid sv subst typ1, typ_subst_kid sv subst typ2, effs) + | Typ_tup typs -> Typ_tup (List.map (typ_subst_kid sv subst) typs) + | Typ_app (f, args) -> Typ_app (f, List.map (typ_subst_arg_kid sv subst) args) +and typ_subst_arg_kid sv subst (Typ_arg_aux (arg, l)) = Typ_arg_aux (typ_subst_arg_kid_aux sv subst arg, l) +and typ_subst_arg_kid_aux sv subst = function + | Typ_arg_nexp nexp -> Typ_arg_nexp (nexp_subst sv (Nexp_var subst) nexp) + | Typ_arg_typ typ -> Typ_arg_typ (typ_subst_kid sv subst typ) + | Typ_arg_order ord -> Typ_arg_order (order_subst sv (Ord_var subst) ord) + | Typ_arg_effect eff -> Typ_arg_effect eff + +let quant_item_subst_kid_aux sv subst = function + | QI_id (KOpt_aux (KOpt_none kid, l)) as qid -> + if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_none subst, l)) else qid + | QI_id (KOpt_aux (KOpt_kind (k, kid), l)) as qid -> + if Kid.compare kid sv = 0 then QI_id (KOpt_aux (KOpt_kind (k, subst), l)) else qid + | QI_const nc -> QI_const (nc_subst_nexp sv (Nexp_var subst) nc) + +let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l) +and nexp_simp_aux = function + | Nexp_sum (n1, n2) -> + begin + let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in + let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in + match n1_simp, n2_simp with + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 + c2) + | _, Nexp_neg n2 -> Nexp_minus (n1, n2) + | _, _ -> Nexp_sum (n1, n2) + end + | Nexp_times (n1, n2) -> + begin + let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in + let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in + match n1_simp, n2_simp with + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 * c2) + | _, _ -> Nexp_times (n1, n2) + end + | Nexp_minus (n1, n2) -> + begin + let (Nexp_aux (n1_simp, _) as n1) = nexp_simp n1 in + let (Nexp_aux (n2_simp, _) as n2) = nexp_simp n2 in + typ_debug ("SIMP: " ^ string_of_nexp n1 ^ " - " ^ string_of_nexp n2); + match n1_simp, n2_simp with + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (c1 - c2) + | _, _ -> Nexp_minus (n1, n2) + end + | nexp -> nexp + +let quant_item_subst_kid sv subst (QI_aux (quant, l)) = QI_aux (quant_item_subst_kid_aux sv subst quant, l) + +let typquant_subst_kid_aux sv subst = function + | TypQ_tq quants -> TypQ_tq (List.map (quant_item_subst_kid sv subst) quants) + | TypQ_no_forall -> TypQ_no_forall + +let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l) + +(**************************************************************************) +(* 2. Environment *) +(**************************************************************************) + +type mut = Immutable | Mutable + +type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound + +module Env : sig + type t + val add_val_spec : id -> typquant * typ -> t -> t + val get_val_spec : id -> t -> typquant * typ + val is_union_constructor : id -> t -> bool + val add_record : id -> typquant -> (typ * id) list -> t -> t + val is_record : id -> t -> bool + val get_accessor : id -> t -> typquant * typ + val add_local : id -> mut * typ -> t -> t + val add_variant : id -> typquant * type_union list -> t -> t + val add_union_id : id -> typquant * typ -> t -> t + val add_flow : id -> (typ -> typ) -> t -> t + val get_flow : id -> t -> typ -> typ + val get_register : id -> t -> typ + val add_register : id -> typ -> t -> t + val add_regtyp : id -> int -> int -> (index_range * id) list -> t -> t + val is_regtyp : id -> t -> bool + val get_regtyp : id -> t -> int * int * (index_range * id) list + val is_mutable : id -> t -> bool + val get_constraints : t -> n_constraint list + val add_constraint : n_constraint -> t -> t + val get_typ_var : kid -> t -> base_kind_aux + val get_typ_vars : t -> base_kind_aux KBindings.t + val add_typ_var : kid -> base_kind_aux -> t -> t + val get_ret_typ : t -> typ option + val add_ret_typ : typ -> t -> t + val add_typ_synonym : id -> (typ_arg list -> typ) -> t -> t + val get_typ_synonym : id -> t -> typ_arg list -> typ + val add_overloads : id -> id list -> t -> t + val get_overloads : id -> t -> id list + val get_default_order : t -> order + val set_default_order_inc : t -> t + val set_default_order_dec : t -> t + val add_enum : id -> id list -> t -> t + val get_enum : id -> t -> id list + val get_casts : t -> id list + val allow_casts : t -> bool + val no_casts : t -> t + val enable_casts : t -> t + val add_cast : id -> t -> t + val lookup_id : id -> t -> lvar + val fresh_kid : t -> kid + val expand_synonyms : t -> typ -> typ + val base_typ_of : t -> typ -> typ + val empty : t +end = struct + type t = + { top_val_specs : (typquant * typ) Bindings.t; + locals : (mut * typ) Bindings.t; + union_ids : (typquant * typ) Bindings.t; + registers : typ Bindings.t; + regtyps : (int * int * (index_range * id) list) Bindings.t; + variants : (typquant * type_union list) Bindings.t; + typ_vars : base_kind_aux KBindings.t; + typ_synonyms : (typ_arg list -> typ) Bindings.t; + overloads : (id list) Bindings.t; + flow : (typ -> typ) Bindings.t; + enums : IdSet.t Bindings.t; + records : (typquant * (typ * id) list) Bindings.t; + accessors : (typquant * typ) Bindings.t; + casts : id list; + allow_casts : bool; + constraints : n_constraint list; + default_order : order option; + ret_typ : typ option + } + + let empty = + { top_val_specs = Bindings.empty; + locals = Bindings.empty; + union_ids = Bindings.empty; + registers = Bindings.empty; + regtyps = Bindings.empty; + variants = Bindings.empty; + typ_vars = KBindings.empty; + typ_synonyms = Bindings.empty; + overloads = Bindings.empty; + flow = Bindings.empty; + enums = Bindings.empty; + records = Bindings.empty; + accessors = Bindings.empty; + casts = []; + allow_casts = true; + constraints = []; + default_order = None; + ret_typ = None; + } + + let counter = ref 0 + + let fresh_kid env = + let fresh = Kid_aux (Var ("'fv" ^ string_of_int !counter), Parse_ast.Unknown) in + incr counter; fresh + + let freshen_kid env kid (typq, typ) = + let fresh = fresh_kid env in + (typquant_subst_kid kid fresh typq, typ_subst_kid kid fresh typ) + + let freshen_bind env bind = + List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) + + let get_val_spec id env = + try + let bind = Bindings.find id env.top_val_specs in + typ_debug ("get_val_spec: Env has " ^ string_of_list ", " (fun (kid, bk) -> string_of_kid kid ^ " => " ^ string_of_base_kind_aux bk) (KBindings.bindings env.typ_vars)); + let bind' = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in + typ_debug ("get_val_spec: freshened to " ^ string_of_bind bind'); + bind' + with + | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id) + + let add_val_spec id bind env = + if Bindings.mem id env.top_val_specs + then typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound") + else + begin + typ_print ("Adding val spec binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind); + { env with top_val_specs = Bindings.add id bind env.top_val_specs } + end + + let is_union_constructor id env = + let is_ctor id (Tu_aux (tu, _)) = match tu with + | Tu_id ctor_id when Id.compare id ctor_id = 0 -> true + | Tu_ty_id (_, ctor_id) when Id.compare id ctor_id = 0 -> true + | _ -> false in - (match tdec.t, concrete_length_req with - | Tapp ("vector", [_;TA_nexp {nexp = Nconst _};_;_]), true -> default () - | Tapp ("vector",_), true -> - (try (let tdec = check_pat true tdec pat in - let t,_ = type_consistent (Patt l) d_env Guarantee false tdec t_inferred in - let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in t) with - | Reporting_basic.Fatal_error(Reporting_basic.Err_type _) -> - typ_error l "Type annotation does not provide a concrete vector length and one cannot be inferred") - | _ -> default ()) - | P_id id -> - let i = id_to_string id in - let default t = - let t,_ = type_consistent (Patt l) d_env Guarantee false t t_inferred in - let t,_ = type_consistent (Patt l) d_env Guarantee false t expect_t in t in - (match Envmap.apply t_env i with - | Some(Base((params,t),Constructor n,cs,efl,efr,bounds)) -> - let t,cs,ef,_ = subst params false false t cs efl in - (match t.t with - | Tfn({t = Tid "unit"},t',IP_none,ef) -> - if conforms_to_t d_env false false t' expect_t then default t' else default t - | Tfn(t1,t',IP_none,e) -> - if conforms_to_t d_env false false t' expect_t - then typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none") - else default t' - | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type")) - | Some(Base((params,t),Enum max,cs,efl,efr,bounds)) -> - let t,cs,ef,_ = subst params false false t cs efl in default t - | _ -> (match t_inferred.t, concrete_length_req with - | Tapp ("vector", [_;TA_nexp {nexp = Nconst _};_;_]), true -> default t_inferred - | Tapp ("vector", _), true -> - typ_error l ("Unable to infer a vector length for paramter " ^ i ^ ", a type annotation may be required.") - | _ -> default t_inferred)) - | P_app(id,pats) -> - let i = id_to_string id in - (*let _ = Printf.eprintf "checking constructor pattern %s\n" i in*) - (match Envmap.apply t_env i with - | None | Some NoTyp | Some Overload _ -> typ_error l ("Constructor " ^ i ^ " in pattern is undefined") - | Some(Base((params,t),Constructor n,constraints,efl,efr,bounds)) -> - let t,dec_cs,_,_ = subst params false false t constraints efl in - (match t.t with - | Tid id -> if pats = [] - then let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t expect_t in t' - else typ_error l ("Constructor " ^ i ^ " does not expect arguments") - | Tfn(t1,t2,IP_none,ef) -> - let t',ret_cs = type_consistent (Patt l) d_env Guarantee false t2 expect_t in - (match pats with - | [] -> let _ = type_consistent (Patt l) d_env Guarantee false unit_t t1 in t' - | [p] -> check_pat concrete_length_req t1 p - | pats -> check_pat concrete_length_req t1 (P_aux(P_tup(pats),(l,annot)))) - | _ -> typ_error l ("Identifier " ^ i ^ " must be a union constructor")) - | Some(Base((params,t),tag,constraints,efl,efr,bounds)) -> - typ_error l ("Identifier " ^ i ^ " used in pattern is not a union constructor")) - | P_record(fpats,_) -> - (match (fields_to_rec fpats d_env.rec_env) with - | None -> typ_error l ("No struct exists with the listed fields") - | Some(id,tannot,typ_pats) -> - (match tannot with - | (Base((vs,t),tag,cs,eft,_,bounds)) -> - let (ft_subst,cs,_,_) = subst vs false false t cs pure_e in - let subst_rtyp,subst_typs = - match ft_subst.t with | Tfn({t=Ttup tups},rt,_,_) -> rt,tups - | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec gave a non function type") in - let _ = - List.map2 (fun (_,id,l,pat) styp -> check_pat concrete_length_req styp pat) typ_pats subst_typs in - let t',cs' = type_consistent (Patt l) d_env Guarantee false ft_subst expect_t in t' - | _ -> raise (Reporting_basic.err_unreachable l "fields_to_rec returned a non Base tannot"))) - | P_vector pats -> - let (item_t, base, rise, ord) = match expect_actual.t with - | Tapp("vector",[TA_nexp b;TA_nexp r;TA_ord o;TA_typ i]) -> (i,b,r,o) - | Tuvar _ -> (new_t (),new_n (),new_n(), d_env.default_o) - | _ -> typ_error l ("Expected a " ^ t_to_string expect_actual ^ " but found a vector") in - let ts = List.map (check_pat false item_t) pats in - let (u,cs) = List.fold_right (fun u (t,cs) -> - let t',cs = type_consistent (Patt l) d_env Require true u t in t',cs) ts (item_t,[]) in - let len = List.length ts in - let t = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) | (Ovar _, Oinc) | (Ouvar _,Oinc) -> - {t = Tapp("vector",[TA_nexp n_zero; - TA_nexp (mk_c_int len); - TA_ord{order=Oinc}; - TA_typ u])} - | (Odec,_) | (Ovar _, Odec) | (Ouvar _,Odec) -> - {t= Tapp("vector", [TA_nexp (mk_c (if len = 0 then zero else (big_int_of_int (len -1)))); - TA_nexp (mk_c_int len); - TA_ord{order=Odec}; - TA_typ u;])} - | _ -> raise (Reporting_basic.err_unreachable l "Default order not set") in - let _,_ = type_consistent (Patt l) d_env Guarantee true t expect_t in t - | P_vector_indexed(ipats) -> - let item_t = match expect_actual.t with - | Tapp("vector",[b;r;o;TA_typ i]) -> i - | Tuvar _ -> new_t () - | _ -> typ_error l ("Expected a vector by pattern form, but a " ^ t_to_string expect_actual ^ " by type") in - let (is,pats) = List.split ipats in - let (fst,lst) = (List.hd is),(List.hd (List.rev is)) in - let inc_or_dec = - if fst < lst then - (let _ = List.fold_left - (fun i1 i2 -> if i1 < i2 then i2 - else typ_error l "Indexed vector pattern was inconsistently increasing") fst (List.tl is) in - true) - else if lst < fst then - (let _ = List.fold_left - (fun i1 i2 -> if i1 > i2 then i2 - else typ_error l "Indexed vector pattern was inconsistently decreasing") fst (List.tl is) in - false) - else typ_error l "Indexed vector cannot be determined as either increasing or decreasing" in - let base,rise = new_n (), new_n () in - let ts = List.map (fun (_,pat) -> check_pat concrete_length_req item_t pat) ipats in - let co = Patt l in - let (u,cs) = List.fold_right (fun u (t,cs) -> type_consistent co d_env Require true u t) ts (item_t,[]) in - {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise); - (TA_ord{order=(if inc_or_dec then Oinc else Odec)});(TA_typ u)])} - | P_tup(pats) -> - let item_ts = match expect_actual.t with - | Ttup ts -> - if (List.length ts) = (List.length pats) - then ts - else typ_error l ("Expected a pattern with a tuple with " ^ - (string_of_int (List.length ts)) ^ " elements, found one with " ^ - (string_of_int (List.length pats))) - | Tuvar _ -> List.map (fun _ -> new_t ()) pats - | _ -> typ_error l ("Expected a tuple by pattern form, but a " ^ (t_to_string expect_actual) ^ " by type") in - let ts = List.map (fun (pat,t) -> check_pat false t pat) (List.combine pats item_ts) in - {t = Ttup ts} - | P_vector_concat pats -> - let item_t,base,rise,order = - match expect_t.t with - | Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item]) - | Tabbrev(_,{t=Tapp("vector",[TA_nexp(b);TA_nexp(r);TA_ord(o);TA_typ item])}) -> item,b,r,o - | _ -> new_t (),new_n (), new_n (), d_env.default_o in - let vec_ti _ = {t= Tapp("vector",[TA_nexp (new_n ());TA_nexp (new_n ());TA_ord order;TA_typ item_t])} in - let _ = - let rec walk = function + let type_unions = List.concat (List.map (fun (_, (_, tus)) -> tus) (Bindings.bindings env.variants)) in + List.exists (is_ctor id) type_unions + + let get_typ_var kid env = + try KBindings.find kid env.typ_vars with + | Not_found -> typ_error (kid_loc kid) ("No kind identifier " ^ string_of_kid kid) + + let get_typ_vars env = env.typ_vars + + (* FIXME: Add an IdSet for builtin types *) + let bound_typ_id env id = + Bindings.mem id env.typ_synonyms + || Bindings.mem id env.variants + || Bindings.mem id env.records + || Bindings.mem id env.regtyps + || Bindings.mem id env.enums + || Id.compare id (mk_id "range") = 0 + || Id.compare id (mk_id "vector") = 0 + || Id.compare id (mk_id "register") = 0 + || Id.compare id (mk_id "bit") = 0 + || Id.compare id (mk_id "unit") = 0 + || Id.compare id (mk_id "int") = 0 + || Id.compare id (mk_id "nat") = 0 + || Id.compare id (mk_id "bool") = 0 + || Id.compare id (mk_id "real") = 0 + || Id.compare id (mk_id "list") = 0 + || Id.compare id (mk_id "string") = 0 + + (* Check if a type, order, or n-expression is well-formed. Throws a + type error if the type is badly formed. FIXME: Add arity to type + constructors, although arity checking for the builtin types does + seem to be done by the initial ast check. *) + let rec wf_typ env (Typ_aux (typ_aux, l)) = + match typ_aux with + | Typ_wild -> () + | Typ_id id when bound_typ_id env id -> () + | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id) + | Typ_var kid when KBindings.mem kid env.typ_vars -> () + | Typ_var kid -> typ_error l ("Unbound kind identifier " ^ string_of_kid kid) + | Typ_fn (typ_arg, typ_ret, effs) -> wf_typ env typ_arg; wf_typ env typ_ret + | Typ_tup typs -> List.iter (wf_typ env) typs + | Typ_app (id, args) when bound_typ_id env id -> List.iter (wf_typ_arg env) args + | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id) + and wf_typ_arg env (Typ_arg_aux (typ_arg_aux, _)) = + match typ_arg_aux with + | Typ_arg_nexp nexp -> wf_nexp env nexp + | Typ_arg_typ typ -> wf_typ env typ + | Typ_arg_order ord -> wf_order env ord + | Typ_arg_effect _ -> () (* Check: is this ever used? *) + and wf_nexp env (Nexp_aux (nexp_aux, l)) = + match nexp_aux with + | Nexp_id _ -> typ_error l "Unimplemented: Nexp_id" + | Nexp_var kid -> + begin + match get_typ_var kid env with + | BK_nat -> () + | kind -> typ_error l ("Constraint is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ string_of_base_kind_aux kind ^ " but should have kind Nat") + end + | Nexp_constant _ -> () + | Nexp_times (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2 + | Nexp_sum (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2 + | Nexp_minus (nexp1, nexp2) -> wf_nexp env nexp1; wf_nexp env nexp2 + | Nexp_exp nexp -> wf_nexp env nexp (* MAYBE: Could put restrictions on what is allowed here *) + | Nexp_neg nexp -> wf_nexp env nexp + and wf_order env (Ord_aux (ord_aux, l)) = + match ord_aux with + | Ord_var kid -> + begin + match get_typ_var kid env with + | BK_order -> () + | kind -> typ_error l ("Order is badly formed, " + ^ string_of_kid kid ^ " has kind " + ^ string_of_base_kind_aux kind ^ " but should have kind Order") + end + | Ord_inc | Ord_dec -> () + + let add_enum id ids env = + if bound_typ_id env id + then typ_error (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound") + else + begin + typ_print ("Adding enum " ^ string_of_id id); + { env with enums = Bindings.add id (IdSet.of_list ids) env.enums } + end + + let get_enum id env = + try IdSet.elements (Bindings.find id env.enums) + with + | Not_found -> typ_error (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist") + + let is_record id env = Bindings.mem id env.records + + let add_record id typq fields env = + if bound_typ_id env id + then typ_error (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound") + else + begin + typ_print ("Adding record " ^ string_of_id id); + let rec record_typ_args = function | [] -> [] - | [p] -> - [check_pat concrete_length_req (*use enclosing pattern status in case of nested concats*) (vec_ti ()) p] - | p::ps -> (check_pat true (vec_ti ()) p)::(walk ps) in - walk pats in - {t = Tapp("vector",[(TA_nexp base);(TA_nexp rise);(TA_ord order);(TA_typ item_t)])} - | P_list(pats) -> - let item_t = match expect_actual.t with - | Tapp("list",[TA_typ i]) -> i - | Tuvar _ -> new_t () - | _ -> typ_error l ("Expected a list here by pattern form, but expected a " ^ t_to_string expect_actual ^ " by type") in - let ts = List.map (check_pat false item_t) pats in - let u = List.fold_right (fun u t -> let t',_ = type_consistent (Patt l) d_env Require true u t in t') ts item_t in - {t = Tapp("list",[TA_typ u])} - -let simp_exp e l t = E_aux(e,(l,simple_annot t)) - -(*widen lets outer expressions control whether inner expressions should widen in the presence of literals or not. - also controls whether we consider vector base to be unconstrained or constrained - This is relevent largely for vector accesses and sub ranges, - where if there's a constant we really want to look at that constant, - and if there's a known vector base, we want to use that directly, vs assignments or branching values *) -let rec check_exp envs (imp_param:nexp option) (widen_num:bool) (widen_vec:bool) - (ret_t:t) (expect_t:t) (E_aux(e,(l,annot)):tannot exp) - : (tannot exp * t * tannot emap * nexp_range list * bounds_env * effect) = - let Env(d_env,t_env,b_env,tp_env) = envs in - let expect_t,_ = get_abbrev d_env expect_t in - let expect_t_actual = match expect_t.t with | Tabbrev(_,t) -> t | _ -> expect_t in - let ret_t,_ = get_abbrev d_env ret_t in - let rebuild annot = E_aux(e,(l,annot)) in - match e with - | E_block exps -> - let (exps',annot',sc,t,ef) = check_block envs imp_param ret_t expect_t exps in - (E_aux(E_block(exps'),(l,annot')),t,Envmap.empty,sc,nob,ef) - | E_nondet exps -> - let base_ef = add_effect (BE_aux(BE_nondet,l)) pure_e in - let (ces, sc, ef) = - List.fold_right - (fun e (es,sc,ef) -> - let (e,_,_,sc',_,ef') = (check_exp envs imp_param true true ret_t unit_t e) in - (e::es,sc@sc',union_effects ef ef')) exps ([],[],base_ef) in - let _,_ = type_consistent (Expr l) d_env Require false unit_t expect_t in - (E_aux (E_nondet ces,(l,cons_efs_annot unit_t sc base_ef ef)),unit_t,t_env,sc,nob,ef) - | E_id id -> - let i = id_to_string id in - (match Envmap.apply t_env i with - | Some(Base((params,t),(Constructor n),cs,ef,_,bounds)) -> - let t,cs,ef,_ = subst params false false t cs ef in - (match t.t with - | Tfn({t = Tid "unit"},t',IP_none,ef) -> - let e = E_aux(E_app(id, []), - (l, (Base(([],{t=Tfn(unit_t,t',IP_none,ef)}), (Constructor n), cs, ef,pure_e, bounds)))) in - let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t' e expect_t in - (e',t',t_env,cs@cs',nob,union_effects ef ef') - | Tfn(t1,t',IP_none,e) -> - typ_error l ("Constructor " ^ i ^ " expects arguments of type " ^ (t_to_string t) ^ ", found none") - | _ -> raise (Reporting_basic.err_unreachable l "Constructor tannot does not have function type")) - | Some(Base((params,t),(Enum max),cs,ef,_,bounds)) -> - let t',cs,_,_ = subst params false false t cs ef in - let t',cs',ef',e' = - type_coerce (Expr l) d_env Require false false b_env t' - (rebuild (cons_tag_annot t' (Enum max) cs)) expect_t in - (e',t',t_env,cs@cs',nob,ef') - | Some(Base(tp,Default,cs,ef,_,_)) | Some(Base(tp,Spec,cs,ef,_,_)) -> - typ_error l ("Identifier " ^ i ^ " must be defined, not just specified, before use") - | Some(Base((params,t),tag,cs,ef,_,bounds)) -> - let ((t,cs,ef,_),is_alias) = - match tag with | Emp_global | External _ -> (subst params false false t cs ef),false - | Alias alias_inf -> (t,cs, add_effect (BE_aux(BE_rreg, Parse_ast.Unknown)) ef, Envmap.empty),true - | _ -> (t,cs,ef,Envmap.empty),false + | ((QI_aux (QI_id kopt, _)) :: qis) when is_nat_kopt kopt -> + mk_typ_arg (Typ_arg_nexp (nvar (kopt_kid kopt))) :: record_typ_args qis + | ((QI_aux (QI_id kopt, _)) :: qis) when is_typ_kopt kopt -> + mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kopt)))) :: record_typ_args qis + | ((QI_aux (QI_id kopt, _)) :: qis) when is_order_kopt kopt -> + mk_typ_arg (Typ_arg_order (mk_ord (Ord_var (kopt_kid kopt)))) :: record_typ_args qis + | (_ :: qis) -> record_typ_args qis + in + let rectyp = match record_typ_args (quant_items typq) with + | [] -> mk_id_typ id + | args -> mk_typ (Typ_app (id, args)) in - let t,cs' = get_abbrev d_env t in - let cs = cs@cs' in - let t_actual = match t.t with - | Tabbrev(_,t) -> t - | _ -> t in - (*let _ = Printf.eprintf "On general id check of %s, expect_t %s, t %s, tactual %s, expect_actual %s\n" - (id_to_string id) - (t_to_string expect_t) (t_to_string t) (t_to_string t_actual) (t_to_string expect_t_actual) in*) - (match t_actual.t,expect_t_actual.t with - | Tfn _,_ -> typ_error l - ("Identifier " ^ (id_to_string id) ^ " is bound to a function and cannot be used as a value") - | Tapp("register",[TA_typ(t')]),Tapp("register",[TA_typ(expect_t')]) -> - let tannot = Base(([],t),(match tag with | External _ -> Emp_global | _ -> tag), - cs,pure_e,pure_e,bounds) in - let t',cs' = type_consistent (Expr l) d_env Require widen_vec t' expect_t' in - (rebuild tannot,t,t_env,cs@cs',bounds,ef) - | Tapp("register",[TA_typ(t')]),Tuvar _ -> - (*let ef' = add_effect (BE_aux(BE_rreg,l)) ef in - let tannot = Base(([],t),(if is_alias then tag else External (Some i)),cs,ef',ef',bounds) in*) - let tannot = Base(([],t), - (if is_alias then tag else (if tag = Emp_local then tag else Emp_global)), - cs,pure_e,pure_e,bounds) in - let _,cs',ef',e' = - type_coerce (Expr l) d_env Require false widen_vec b_env t' (rebuild tannot) expect_t_actual in - (e',t,t_env,cs@cs',bounds,ef') - | Tapp("register",[TA_typ(t')]),_ -> - let ef' = add_effect (BE_aux(BE_rreg,l)) ef in - let tannot = Base(([],t),(if is_alias then tag else External (Some i)),cs,ef',ef',bounds) in - let t',cs',_,e' = - type_coerce (Expr l) d_env Require false widen_vec b_env t' (rebuild tannot) expect_t_actual in - (e',t',t_env,cs@cs',bounds,ef') - | Tapp("reg",[TA_typ(t')]),_ -> - let tannot = cons_bs_annot t cs bounds in - let t',cs',_,e' = - type_coerce (Expr l) d_env Require false widen_num b_env t' (rebuild tannot) expect_t_actual in - (e',t',t_env,cs@cs',bounds,pure_e) - | _ -> - let t',cs',ef',e' = type_coerce (Expr l) d_env Require false widen_num b_env - t (rebuild (Base(([],t),tag,cs,pure_e,ef,bounds))) expect_t in - (e',t',t_env,cs@cs',bounds,union_effects ef ef') - ) - | Some NoTyp | Some Overload _ | None -> typ_error l ("Identifier " ^ (id_to_string id) ^ " is unbound")) - | E_lit (L_aux(lit,l')) -> - let e,cs,effect = (match lit with - | L_unit -> (rebuild (simple_annot unit_t)),[],pure_e - | L_zero -> - (match expect_t_actual.t with - | Tid "bool" -> simp_exp (E_lit(L_aux(L_zero,l'))) l bool_t,[],pure_e - | _ -> simp_exp e l bit_t,[],pure_e) - | L_one -> - (match expect_t_actual.t with - | Tid "bool" -> simp_exp (E_lit(L_aux(L_one,l'))) l bool_t,[],pure_e - | _ -> simp_exp e l bit_t,[],pure_e) - | L_true -> simp_exp e l bool_t,[],pure_e - | L_false -> simp_exp e l bool_t,[],pure_e - | L_num i -> - (*let _ = Printf.eprintf "expected type of number literal %i is %s\n" i (t_to_string expect_t_actual) in*) - (match expect_t_actual.t with - | Tid "bit" | Toptions({t=Tid"bit"},_) -> - if i = 0 then simp_exp (E_lit(L_aux(L_zero,l'))) l bit_t,[],pure_e - else if i = 1 then simp_exp (E_lit(L_aux(L_one,l'))) l bit_t,[],pure_e - else typ_error l ("Expected a bit, found " ^ string_of_int i) - | Tid "bool" | Toptions({t=Tid"bool"},_)-> - if i = 0 then simp_exp (E_lit(L_aux(L_zero,l'))) l bit_t,[],pure_e - else if i = 1 then simp_exp (E_lit(L_aux(L_one,l'))) l bit_t ,[],pure_e - else typ_error l ("Expected bool or a bit, found " ^ string_of_int i) - | Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})]) -> - let n = mk_c_int i in - let t = {t=Tapp("atom", [TA_nexp n;])} in - let cs = [LtEq(Expr l,Guarantee,n,mk_sub (mk_2n rise) n_one)] in - let f = match o.order with | Oinc -> "to_vec_inc" | Odec -> "to_vec_dec" | _ -> "to_vec_inc" in - (*let _ = Printf.eprintf "adding a call to to_vec_*: bounds are %s\n" (bounds_to_string b_env) in*) - let internal_tannot = (l,(cons_bs_annot {t = Tapp("implicit",[TA_nexp rise])} [] b_env)) in - let tannot = (l,cons_tag_annot expect_t (External (Some f)) cs) in - E_aux(E_app((Id_aux((Id f),l)), - [(E_aux (E_internal_exp(internal_tannot), tannot));simp_exp e l t]),tannot),cs,pure_e - | _ -> simp_exp e l {t = Tapp("atom", [TA_nexp (mk_c_int i)])},[],pure_e) - | L_hex s -> - let size = (String.length s) * 4 in - let start = match d_env.default_o.order with - | Oinc -> n_zero | Odec -> mk_c_int (size - 1) | _ -> n_zero in - simp_exp e l {t = Tapp("vector", - [TA_nexp start; - TA_nexp (mk_c_int size); - TA_ord d_env.default_o;TA_typ{t = Tid "bit"}])},[],pure_e - | L_bin s -> - let size = String.length s in - let start = match d_env.default_o.order with - | Oinc -> n_zero | Odec -> mk_c_int (size -1) | _ -> n_zero in - simp_exp e l {t = Tapp("vector", - [TA_nexp start; - TA_nexp (mk_c_int size); - TA_ord d_env.default_o ;TA_typ{t = Tid"bit"}])},[],pure_e - | L_string s -> simp_exp e l {t = Tid "string"},[],pure_e - | L_undef -> - let ef = {effect=Eset[BE_aux(BE_undef,l)]} in - (match expect_t_actual.t with - | Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})]) - | Toptions({t = Tapp ("vector",[TA_nexp base;TA_nexp rise;TA_ord o;(TA_typ {t=Tid "bit"})])}, None) -> - let f = match o.order with | Oinc -> "to_vec_inc_undef" | Odec -> "to_vec_dec_undef" - | _ -> (match d_env.default_o.order with - | Oinc -> "to_vec_inc_undef" | Odec -> "to_vec_dec_undef" - | _ -> "to_vec_inc_undef") in - let _ = set_imp_param rise in - let internal_tannot = (l,(cons_bs_annot {t = Tapp("implicit",[TA_nexp rise])} [] b_env)) in - let tannot = (l,Base(([],{t = Tapp("vector",[TA_nexp base; TA_nexp rise; TA_ord o; TA_typ bit_t])}), - External (Some f),[],ef,ef,b_env)) in - E_aux(E_app((Id_aux((Id f),l)), - [(E_aux (E_internal_exp(internal_tannot), tannot));]),tannot),[],ef - | _ -> simp_exp e l (new_t ()),[],ef)) in - let t',cs',_,e' = type_coerce (Expr l) d_env Require false widen_num b_env (get_e_typ e) e expect_t in - (e',t',t_env,cs@cs',nob,effect) - | E_cast(typ,e) -> - let cast_t = typ_to_t envs false false typ in - let cast_t,cs_a = get_abbrev d_env cast_t in - let cast_t = typ_subst tp_env false cast_t in - let ct = {t = Toptions(cast_t,None)} in - let (e',u,t_env,cs,bounds,ef) = check_exp envs imp_param true true ret_t ct e in - (*let _ = Printf.eprintf "Type checking cast: cast_t is %s constraints after checking e are %s\n" - (t_to_string cast_t) (constraints_to_string cs) in*) - let t',cs2,ef',e' = type_coerce (Expr l) d_env Require true true b_env u e' cast_t in - (*let _ = Printf.eprintf "Type checking cast: after first coerce with u %s, t' %s is and constraints are %s\n" - (t_to_string u) (t_to_string t') (constraints_to_string cs2) in*) - let t',cs3,ef'',e'' = type_coerce (Expr l) d_env Guarantee false false b_env cast_t e' expect_t in - (*let _ = Printf.eprintf "Type checking cast: after second coerce expect_t %s, t' %s and constraints are %s\n" - (t_to_string expect_t) (t_to_string t') (constraints_to_string cs3) in*) - (e'',t',t_env,cs_a@cs@cs2@cs3,bounds,union_effects ef' (union_effects ef'' ef)) - | E_app(id,parms) -> - let i = id_to_string id in - let check_parms p_typ parms = (match parms with - | [] | [(E_aux (E_lit (L_aux (L_unit,_)),_))] - -> let (_,cs') = type_consistent (Expr l) d_env Require false unit_t p_typ in [],unit_t,cs',pure_e - | [parm] -> let (parm',arg_t,t_env,cs',_,ef_p) = check_exp envs imp_param true true ret_t p_typ parm - in [parm'],arg_t,cs',ef_p - | parms -> - (match check_exp envs imp_param true true ret_t p_typ (E_aux (E_tuple parms,(l,NoTyp))) with - | ((E_aux(E_tuple parms',tannot')),arg_t,t_env,cs',_,ef_p) -> parms',arg_t,cs',ef_p - | _ -> - raise (Reporting_basic.err_unreachable l - "check_exp, given a tuple and a tuple type, didn't return a tuple"))) - in - let coerce_parms arg_t parms expect_arg_t = - (match parms with - | [] | [(E_aux (E_lit (L_aux(L_unit, _)), _))] -> [],pure_e,[] - | [parm] -> - let _,cs,ef,parm' = - type_coerce (Expr l) d_env Guarantee false false b_env arg_t parm expect_arg_t in [parm'],ef,cs - | parms -> - (match type_coerce (Expr l) d_env Guarantee false false b_env arg_t - (E_aux (E_tuple parms,(l,NoTyp))) expect_arg_t with - | (_,cs,ef,(E_aux(E_tuple parms',tannot'))) -> (parms',ef,cs) - | _ -> - raise (Reporting_basic.err_unreachable l "type coerce given tuple and tuple type returned non-tuple"))) - in - let check_result ret imp tag cs ef efr parms = - match (imp,imp_param) with - | (IP_length n ,None) | (IP_user n,None) | (IP_start n,None) -> - (*let _ = Printf.eprintf "app of %s implicit required, no imp_param %s\n!" i (n_to_string n) in*) - let internal_exp = - let _ = set_imp_param n in - let implicit = {t= Tapp("implicit",[TA_nexp n])} in - let annot_i = Base(([],implicit),Emp_local,[],pure_e,pure_e,b_env) in - E_aux(E_internal_exp((l,annot_i)),(l,simple_annot nat_t)) in - type_coerce (Expr l) d_env Require false true b_env ret - (E_aux (E_app(id, internal_exp::parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t - | (IP_length n ,Some ne) | (IP_user n,Some ne) | (IP_start n,Some ne) -> - (*let _ = Printf.eprintf "app of %s implicit length or var required %s with imp_param %s\n" - i (n_to_string n) (n_to_string ne) in - let _ = Printf.eprintf "and expected type is %s and return type is %s\n" - (t_to_string expect_t) (t_to_string ret) in*) - let _ = set_imp_param n; set_imp_param ne in - let internal_exp = - let implicit_user = {t = Tapp("implicit",[TA_nexp ne])} in - let implicit = {t= Tapp("implicit",[TA_nexp n])} in - let annot_iu = Base(([],implicit_user),Emp_local,[],pure_e,pure_e,b_env)in - let annot_i = Base(([],implicit),Emp_local,[],pure_e,pure_e,b_env) in - E_aux (E_internal_exp_user((l, annot_iu),(l,annot_i)), (l,simple_annot nat_t)) - in - type_coerce (Expr l) d_env Require false true b_env ret - (E_aux (E_app(id,internal_exp::parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t - | (IP_none,_) -> - (*let _ = Printf.eprintf "no implicit: ret %s and expect_t %s\n" - (t_to_string ret) (t_to_string expect_t) in*) - type_coerce (Expr l) d_env Require false true b_env ret - (E_aux (E_app(id, parms),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t - in - (match Envmap.apply t_env i with - | Some(Base(tp,Enum _,_,_,_,_)) -> - typ_error l ("Expected function with name " ^ i ^ " but found an enumeration identifier") - | Some(Base(tp,Default,_,_,_,_)) -> - typ_error l ("Function " ^ i ^ " must be specified, not just declared as a default, before use") - | Some(Base((params,t),tag,cs,efl,_,bounds)) -> - (*let _ = Printf.eprintf "Going to check func call %s with unsubstituted types %s and constraints %s \n" - i (t_to_string t) (constraints_to_string cs) in*) - let t,cs,efl,_ = subst params false false t cs efl in - (match t.t with - | Tfn(arg,ret,imp,efl') -> - (*let _ = Printf.eprintf "Checking funcation call of %s\n" i in - let _ = Printf.eprintf "Substituted types and constraints are %s and %s\n" - (t_to_string t) (constraints_to_string cs) in*) - let ret,_ = get_abbrev d_env ret in - let parms,arg_t,cs_p,ef_p = check_parms arg parms in - (*let _ = Printf.eprintf "Checked parms of %s\n" i in*) - let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs efl' (union_effects efl' ef_p) parms in - (*let _ = Printf.eprintf "Checked result of %s and constraints are %s\n" - i (constraints_to_string cs_r) in*) - (e',ret_t,t_env,cs@cs_p@cs_r, bounds,union_effects efl' (union_effects ef_p ef_r)) - | _ -> typ_error l - ("Expected a function or constructor, found identifier " ^ i ^ " bound to type " ^ - (t_to_string t))) - | Some(Overload(Base((params,t),tag,cs,efl,_,_),overload_return,variants)) -> - let t_p,cs_p,ef_p,_ = subst params false false t cs efl in - let args,arg_t,arg_cs,arg_ef = - (match t_p.t with - | Tfn(arg,ret,_,ef') -> check_parms arg parms - | _ -> - typ_error l ("Expected a function or constructor, found identifier " ^ i - ^ " bound to type " ^ (t_to_string t))) in - (match (select_overload_variant d_env true overload_return variants arg_t) with - | [] -> typ_error l - ("No function found with name " ^ i ^ " that expects parameters " ^ (t_to_string arg_t)) - | [Base((params,t),tag,cs,efl,_,bounds)] -> - (match t.t with - | Tfn(arg,ret,imp,ef') -> - let ret,_ = get_abbrev d_env ret in - let args',arg_ef',arg_cs' = coerce_parms arg_t args arg in - let cummulative_effects = union_effects (union_effects arg_ef arg_ef') (union_effects ef' ef_p) in - let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef' cummulative_effects args' in - (e',ret_t,t_env,cs_p@arg_cs@arg_cs'@cs_r,nob, - union_effects ef_r cummulative_effects) - | _ -> raise (Reporting_basic.err_unreachable l "Overloaded variant not a function")) - | variants' -> - (match select_overload_variant d_env false true variants' expect_t with - | [] -> - typ_error l ("No function found with name " ^ i ^ ", expecting parameters " ^ - (t_to_string arg_t) ^ " and returning " ^ (t_to_string expect_t)) - | [Base((params,t),tag,cs,efl,_,bounds)] -> - (match t.t with - |Tfn(arg,ret,imp,ef') -> - let ret,_ = get_abbrev d_env ret in - let args',arg_ef',arg_cs' = coerce_parms arg_t args arg in - let cummulative_effects = union_effects (union_effects arg_ef arg_ef') (union_effects ef' ef_p) in - let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef' cummulative_effects args' in - (e',ret_t,t_env,cs_p@arg_cs@arg_cs'@cs_r,nob,union_effects ef_r cummulative_effects) - | _ -> raise (Reporting_basic.err_unreachable l "Overloaded variant not a function")) - | _ -> - typ_error l ("More than one definition of " ^ i ^ " found with type " ^ - (t_to_string arg_t) ^ " -> " ^ (t_to_string expect_t) ^ ". A cast may be required"))) - | _ -> typ_error l ("Unbound function " ^ i)) - | E_app_infix(lft,op,rht) -> - let i = id_to_string op in - let check_parms arg_t lft rht = - match check_exp envs imp_param true true ret_t arg_t (E_aux(E_tuple [lft;rht],(l,NoTyp))) with - | ((E_aux(E_tuple [lft';rht'],_)),arg_t,_,cs',_,ef') -> (lft',rht',arg_t,cs',ef') - | _ -> - raise (Reporting_basic.err_unreachable l "check exp given tuple and tuple type and returned non-tuple") - in - let check_result ret imp tag cs ef efr lft rht = - match imp with - | _ -> (*implicit isn't allowed at the moment on any infix functions *) - type_coerce (Expr l) d_env Require false true b_env ret - (E_aux (E_app_infix(lft,op,rht),(l,(Base(([],ret),tag,cs,ef,efr,nob))))) expect_t - in - (match Envmap.apply t_env i with - | Some(Base(tp,Enum _,cs,ef,_,b)) -> - typ_error l ("Expected function with name " ^ i ^ " but found an enumeration identifier") - | Some(Base(tp,Default,cs,ef,_,b)) -> - typ_error l ("Function " ^ i ^ " must be defined, not just declared as default, before use") - | Some(Base((params,t),tag,cs,ef,_,b)) -> - let t,cs,ef,_ = subst params false false t cs ef in - (match t.t with - | Tfn(arg,ret,imp,ef) -> - let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in - let cummulative_effects = union_effects ef ef_p in - let ret_t,cs_r',ef_r,e' = check_result ret imp tag cs ef cummulative_effects lft' rht' in - (e',ret_t,t_env,cs@cs_p@cs_r',nob,union_effects ef_r cummulative_effects) - | _ -> - typ_error l ("Expected a function, found identifier " ^ i ^ " bound to type " ^ (t_to_string t))) - | Some(Overload(Base((params,t),tag,cs,ef,_,_),overload_return,variants)) -> - let t_p,cs_p,ef_p,_ = subst params false false t cs ef in - let lft',rht',arg_t,arg_cs,arg_ef = - (match t_p.t with - | Tfn(arg,ret,_,ef') -> check_parms arg lft rht - | _ -> typ_error l ("Expected a function, found identifier " ^ i ^ " bound to type " ^ (t_to_string t))) in - (*let _ = Printf.eprintf "Looking for overloaded function %s, generic type is %s, arg_t is %s\n" - i (t_to_string t_p) (t_to_string arg_t) in*) - (match (select_overload_variant d_env true overload_return variants arg_t) with - | [] -> - typ_error l ("No function found with name " ^ i ^ - " that expects parameters " ^ (t_to_string arg_t)) - | [Base((params,t),tag,cs,ef,_,b)] -> - (*let _ = Printf.eprintf "Selected an overloaded function for %s, - variant with function type %s for actual type %s\n" i (t_to_string t) (t_to_string arg_t) in*) - (match t.t with - | Tfn(arg,ret,imp,ef') -> - (match arg.t,arg_t.t with - | Ttup([tlft;trght]),Ttup([tlft_t;trght_t]) -> - let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in - let cummulative_effects = union_effects ef' (union_effects arg_ef ef_p) in - let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef cummulative_effects lft' rht' in - (e',ret_t,t_env,cs_p@arg_cs@cs@cs_r,nob, union_effects ef_r cummulative_effects) - |_ -> raise (Reporting_basic.err_unreachable l "function no longer has tuple type")) - | _ -> raise (Reporting_basic.err_unreachable l "overload variant does not have function")) - | variants -> - (*let _ = Printf.eprintf "Number of variants found before looking at return value %i\n%!" - (List.length variants) in*) - (match (select_overload_variant d_env false true variants expect_t) with - | [] -> - typ_error l ("No matching function found with name " ^ i ^ " that expects parameters " ^ - (t_to_string arg_t) ^ " returning " ^ (t_to_string expect_t)) - | [Base((params,t),tag,cs,ef,_,b)] -> - (*let _ = Printf.eprintf "Selected an overloaded function for %s, - variant with function type %s for actual type %s\n" i (t_to_string t) (t_to_string arg_t) in*) - (match t.t with - | Tfn(arg,ret,imp,ef') -> - (match arg.t,arg_t.t with - | Ttup([tlft;trght]),Ttup([tlft_t;trght_t]) -> - let (lft',rht',arg_t,cs_p,ef_p) = check_parms arg lft rht in - let cummulative_effects = union_effects ef' (union_effects ef_p arg_ef) in - let (ret_t,cs_r,ef_r,e') = check_result ret imp tag cs ef cummulative_effects lft' rht' in - (e',ret_t,t_env,cs_p@arg_cs@cs@cs_r,nob, union_effects ef_r cummulative_effects) - |_ -> raise (Reporting_basic.err_unreachable l "function no longer has tuple type")) - | _ -> raise (Reporting_basic.err_unreachable l "overload variant does not have function")) - | _ -> - typ_error l ("More than one variant of " ^ i ^ " found with type " - ^ (t_to_string arg_t) ^ " -> " ^ (t_to_string expect_t) ^ ". A cast may be required"))) - | _ -> typ_error l ("Unbound infix function " ^ i)) - | E_tuple(exps) -> - (match expect_t_actual.t with - | Ttup ts -> - let tl = List.length ts in - let el = List.length exps in - if tl = el then - let exps,typs,consts,effect = - List.fold_right2 - (fun e t (exps,typs,consts,effect) -> - let (e',t',_,c,_,ef) = - check_exp envs imp_param true true ret_t t e in - ((e'::exps),(t'::typs),c@consts,union_effects ef effect)) - exps ts ([],[],[],pure_e) in - let t = {t = Ttup typs} in - (E_aux(E_tuple(exps),(l,simple_annot_efr t effect)),t,t_env,consts,nob,effect) - else typ_error l ("Expected a tuple with " ^ (string_of_int tl) ^ - " arguments; found one with " ^ (string_of_int el)) - | _ -> - let exps,typs,consts,effect = - List.fold_right - (fun e (exps,typs,consts,effect) -> - let (e',t,_,c,_,ef) = check_exp envs imp_param true true ret_t (new_t ()) e in - ((e'::exps),(t::typs),c@consts,union_effects ef effect)) - exps ([],[],[],pure_e) in - let t = { t=Ttup typs } in - let t',cs',ef',e' = - type_coerce (Expr l) d_env Guarantee false false b_env - t (E_aux(E_tuple(exps),(l,simple_annot_efr t effect))) expect_t in - (e',t',t_env,consts@cs',nob,union_effects ef' effect)) - | E_if(cond,then_,else_) -> - let (cond',_,_,c1,_,ef1) = check_exp envs imp_param true true ret_t bit_t cond in - let (c1,c1p,c1n) = split_conditional_constraints c1 in - (match expect_t.t with - | Tuvar _ -> - let then',then_t,then_env,then_c,then_bs,then_ef = - check_exp envs imp_param true true ret_t (new_t ()) then_ in - let else',else_t,else_env,else_c,else_bs,else_ef = - check_exp envs imp_param true true ret_t (new_t ()) else_ in - (*TOTHINK Possibly I should first consistency check else and then, with Guarantee, - then check against expect_t with Require*) - let then_t',then_c' = type_consistent (Expr l) d_env Require true then_t expect_t in - let else_t',else_c' = type_consistent (Expr l) d_env Require true else_t expect_t in - let t_cs = CondCons((Expr l),Positive,None,c1p,then_c@then_c') in - let e_cs = CondCons((Expr l),Negative,None,c1n,else_c@else_c') in - let sub_effects = union_effects ef1 (union_effects then_ef else_ef) in - let resulting_env = Envmap.intersect_merge (tannot_merge (Expr l) d_env true) then_env else_env in - (E_aux(E_if(cond',then',else'),(l,simple_annot_efr expect_t sub_effects)), - expect_t, resulting_env, - c1@[BranchCons(Expr l, None, [t_cs;e_cs])], - merge_bounds then_bs else_bs, (*TODO Should be an intersecting merge*) - sub_effects) - | _ -> - let then',then_t,then_env,then_c,then_bs,then_ef = check_exp envs imp_param true true ret_t expect_t then_ in - let else',else_t,else_env,else_c,else_bs,else_ef = check_exp envs imp_param true true ret_t expect_t else_ in - let t_cs = CondCons((Expr l),Positive,None,c1,then_c) in - let e_cs = CondCons((Expr l),Negative,None,[],else_c) in - let sub_effects = union_effects ef1 (union_effects then_ef else_ef) in - (E_aux(E_if(cond',then',else'),(l,simple_annot_efr expect_t sub_effects)), - expect_t,Envmap.intersect_merge (tannot_merge (Expr l) d_env true) then_env else_env, - c1@[BranchCons(Expr l, None, [t_cs;e_cs])], - merge_bounds then_bs else_bs, - sub_effects)) - | E_for(id,from,to_,step,order,block) -> - (*TOTHINK Instead of making up new ns here, perhaps I should instead make sure they conform to range - without coercion as these nu variables are likely floating*) - let f,t,s = new_n(),new_n(),new_n() in - let ft,tt,st = mk_atom f, mk_atom t, mk_atom s in - let from',from_t,_,from_c,_,from_ef = check_exp envs imp_param false false ret_t ft from in - let to_',to_t,_,to_c,_,to_ef = check_exp envs imp_param false false ret_t tt to_ in - let step',step_t,_,step_c,_,step_ef = check_exp envs imp_param false false ret_t st step in - let new_annot,local_cs = - match (aorder_to_ord order).order with - | Oinc -> - (simple_annot {t=Tapp("range",[TA_nexp f;TA_nexp t])},[LtEq((Expr l),Guarantee ,f,t)]) - | Odec -> - (simple_annot {t=Tapp("range",[TA_nexp t; TA_nexp f])},[GtEq((Expr l),Guarantee,f,t)]) - | _ -> (typ_error l "Order specification in a foreach loop must be either inc or dec, not polymorphic") - in - (*TODO Might want to extend bounds here for the introduced variable*) - let (block',b_t,_,b_c,_,b_ef)= - check_exp (Env(d_env,Envmap.insert t_env (id_to_string id,new_annot),b_env,tp_env)) - imp_param true true ret_t expect_t block - in - let sub_effects = union_effects b_ef (union_effects step_ef (union_effects to_ef from_ef)) in - (E_aux(E_for(id,from',to_',step',order,block'),(l,constrained_annot_efr b_t local_cs sub_effects)),expect_t, - Envmap.empty, - b_c@from_c@to_c@step_c@local_cs,nob,sub_effects) - | E_vector(es) -> - let item_t,ord = match expect_t_actual.t with - | Tapp("vector",[base;rise;TA_ord ord;TA_typ item_t]) -> item_t,ord - | _ -> new_t (),d_env.default_o in - let es,cs,effect,item_t = (List.fold_right - (fun (e,t,_,c,_,ef) (es,cs,effect,_) -> (e::es),(c@cs),union_effects ef effect,t) - (List.map (check_exp envs imp_param true true ret_t item_t) es) ([],[],pure_e,item_t)) in - let len = List.length es in - let t = match ord.order,d_env.default_o.order with - | (Oinc,_) | (Ouvar _,Oinc) | (Ovar _,Oinc) -> - {t = Tapp("vector", [TA_nexp n_zero; TA_nexp (mk_c_int len); - TA_ord {order = Oinc}; TA_typ item_t])} - | (Odec,_) | (Ouvar _,Odec) | (Ovar _,Odec) -> - {t = Tapp("vector",[TA_nexp (mk_c_int (len-1)); - TA_nexp (mk_c_int len); - TA_ord {order= Odec}; TA_typ item_t])} - | _ -> raise (Reporting_basic.err_unreachable l "Default order was neither inc or dec") in - let t',cs',ef',e' = type_coerce (Expr l) d_env Guarantee false true b_env t - (E_aux(E_vector es,(l,simple_annot_efr t effect))) expect_t in - (e',t',t_env,cs@cs',nob,union_effects effect ef') - | E_vector_indexed(eis,(Def_val_aux(default,(ld,annot)))) -> - let item_t,base_n,rise_n = match expect_t_actual.t with - | Tapp("vector",[TA_nexp base;TA_nexp rise;ord;TA_typ item_t]) -> item_t,base,rise - | _ -> new_t (),new_n (), new_n () in - let first,last = fst (List.hd eis), fst (List.hd (List.rev eis)) in - let is_inc = first <= last in - let es,cs,effect,contains_skip,_ = - (List.fold_right - (fun ((i,e),c,ef) (es,cs,effect,skips,prev) -> - (*let _ = Printf.eprintf "Checking increasing %b %i %i\n" is_increasing prev i in*) - let (esn, csn, efn) = (((i,e)::es), (c@cs), union_effects ef effect) in - if (is_inc && prev > i) - then (esn,csn,efn,(((prev-i) > 1) || skips),i) - else if prev < i - then (esn,csn,efn,(((i-prev) > 1) || skips),i) - else if i = prev - then (typ_error l ("Indexed vector contains a duplicate definition of index " ^ (string_of_int i))) - else (typ_error l ("Indexed vector is not consistently " ^ - (if is_inc then "increasing" else "decreasing")))) - (List.map (fun (i,e) -> - let (e,_,_,cs,_,eft) = (check_exp envs imp_param true true ret_t item_t e) in ((i,e),cs,eft)) - eis) ([],[],pure_e,false,(if is_inc then (last+1) else (last-1)))) in - let (default',fully_enumerate,cs_d,ef_d) = match (default,contains_skip) with - | (Def_val_empty,false) -> (Def_val_aux(Def_val_empty,(ld,simple_annot item_t)),true,[],pure_e) - | (Def_val_empty,true) -> - let ef = add_effect (BE_aux(BE_unspec,l)) pure_e in - let de = E_aux(E_lit (L_aux(L_undef,l)), (l,simple_annot item_t)) in - (Def_val_aux(Def_val_dec de, (l, cons_efs_annot item_t [] ef ef)),false,[],ef) - | (Def_val_dec e,_) -> let (de,t,_,cs_d,_,ef_d) = (check_exp envs imp_param true true ret_t item_t e) in - (*Check that ef_d doesn't write to memory or registers? *) - (Def_val_aux(Def_val_dec de,(ld,cons_efs_annot item_t cs_d pure_e ef_d)),false,cs_d,ef_d) in - let (base_bound,length_bound,cs_bounds) = - if fully_enumerate - then (mk_c_int first, mk_c_int (List.length eis),[]) - else (base_n,rise_n,[LtEq(Expr l,Require, base_n,mk_c_int first); - GtEq(Expr l,Require, rise_n,mk_c_int (List.length eis))]) - in - let t = {t = Tapp("vector", - [TA_nexp(base_bound);TA_nexp length_bound; - TA_ord({order= if is_inc then Oinc else Odec});TA_typ item_t])} in - let sub_effects = union_effects ef_d effect in - let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t - (E_aux (E_vector_indexed(es,default'),(l,simple_annot_efr t sub_effects))) expect_t in - (e',t',t_env,cs@cs_d@cs_bounds@cs',nob,union_effects ef' sub_effects) - | E_vector_access(vec,i) -> - let base,len,ord = new_n(),new_n(),new_o() in - let item_t = new_t () in - let index = new_n () in - let vt = {t= Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord ord; TA_typ item_t])} in - let (vec',t',cs,ef),va_lef,tag = recheck_for_register envs imp_param false false ret_t vt vec in - let it = mk_atom index in - let (i',ti',_,cs_i,_,ef_i) = check_exp envs imp_param false false ret_t it i in - let ord,item_t = match t'.t with - | Tabbrev(_,{t=Tapp("vector",[_;_;TA_ord ord;TA_typ t])}) | Tapp("vector",[_;_;TA_ord ord;TA_typ t]) - | Tabbrev(_,{t=Tapp("register",[TA_typ{t=Tapp ("vector",[_;_;TA_ord ord;TA_typ t])}])}) - | Tapp("register", [TA_typ{t=Tapp ("vector",[_;_;TA_ord ord;TA_typ t])}]) -> ord,t - | _ -> ord,item_t in - let oinc_max_access = mk_sub (mk_add base len) n_one in - let odec_min_access = mk_add (mk_sub base len) n_one in - let cs_loc = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) -> - [LtEq((Expr l),Require,base,index);LtEq((Expr l),Require, index,oinc_max_access);] - | (Odec,_) -> - [GtEq((Expr l),Require,base,index); GtEq((Expr l),Require,index,odec_min_access);] - | (_,Oinc) -> - [LtEq((Expr l),Require,base,index);LtEq((Expr l),Require, index,oinc_max_access);] - | (_,Odec) -> - [GtEq((Expr l),Require,base,index); GtEq((Expr l),Require,index,odec_min_access);] - | _ -> typ_error l "A vector must be either increasing or decreasing to access a single element" - in - (*let _ = Printf.eprintf "Type checking vector access. item_t is %s and expect_t is %s\n" - (t_to_string item_t) (t_to_string expect_t) in*) - let sub_effects = union_effects (union_effects va_lef ef) ef_i in - let t',cs',ef',e'=type_coerce (Expr l) d_env Require false true b_env item_t - (E_aux(E_vector_access(vec',i'),(l,tag_efs_annot item_t tag va_lef sub_effects))) expect_t in - (e',t',t_env,cs_loc@cs_i@cs@cs',nob,union_effects ef' sub_effects) - | E_vector_subrange(vec,i1,i2) -> - (*let _ = Printf.eprintf "checking e_vector_subrange: expect_t is %s\n" (t_to_string expect_t) in*) - let base,length,ord = new_n(),new_n(),new_o() in - let new_length = new_n() in - let n1_start = new_n() in - let n2_end = new_n() in - let item_t = match expect_t_actual.t with - | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t - | _ -> new_t() in - let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp length;TA_ord ord;TA_typ item_t])} in - let (vec',vt',cs,ef),v_efs,tag = recheck_for_register envs imp_param false false ret_t vt vec in - let i1t = {t=Tapp("atom",[TA_nexp n1_start])} in - let (i1', ti1, _,cs_i1,_,ef_i1) = check_exp envs imp_param false false ret_t i1t i1 in - let i2t = {t=Tapp("atom",[TA_nexp n2_end])} in - let (i2', ti2, _,cs_i2,_,ef_i2) = check_exp envs imp_param false false ret_t i2t i2 in - let cs_loc = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) -> - [LtEq((Expr l), Require, base, n1_start); - LtEq((Expr l), Require, n1_start, n2_end); - LtEq((Expr l), Require, n2_end, mk_sub (mk_add base length) n_one); - Eq((Expr l), new_length, mk_add (mk_sub n2_end n1_start) n_one)] - | (Odec,_) -> - [GtEq((Expr l), Require, base, n1_start); - GtEq((Expr l), Require, n1_start, n2_end); - GtEq((Expr l), Require, n2_end, mk_add (mk_sub base length) n_one); - Eq((Expr l), new_length, mk_add (mk_sub n1_start n2_end) n_one)] - | (_,Oinc) -> - [LtEq((Expr l), Require, base, n1_start); - LtEq((Expr l), Require, n1_start, n2_end); - LtEq((Expr l), Require, n2_end, mk_sub (mk_add base length) n_one); - Eq((Expr l), new_length, mk_add (mk_sub n2_end n1_start) n_one)] - | (_,Odec) -> - [GtEq((Expr l), Require, base, n1_start); - GtEq((Expr l), Require, n1_start, n2_end); - GtEq((Expr l), Require, n2_end, mk_add (mk_sub base length) n_one); - Eq((Expr l), new_length, mk_add (mk_sub n1_start n2_end) n_one)] - | _ -> typ_error l "A vector must be either increasing or decreasing to access a slice" in - let nt = {t = Tapp("vector", [TA_nexp n1_start; TA_nexp new_length; TA_ord ord; TA_typ item_t]) } in - let sub_effects = union_effects v_efs (union_effects ef (union_effects ef_i1 ef_i2)) in - let (t,cs3,ef3,e') = - type_coerce (Expr l) d_env Require false true b_env nt - (E_aux(E_vector_subrange(vec',i1',i2'),(l,Base(([], nt),tag, cs_loc,v_efs, sub_effects,nob)))) expect_t in - (e',t,t_env,cs3@cs@cs_i1@cs_i2@cs_loc,nob,union_effects ef3 sub_effects) - | E_vector_update(vec,i,e) -> - let base,rise,ord = new_n(),new_n(),new_o() in - let min,m_rise = new_n(),new_n() in - let item_t = match expect_t_actual.t with - | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t - | _ -> new_t() in - let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t])} in - let (vec',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t vt vec in - let it = {t=Tapp("range",[TA_nexp min;TA_nexp m_rise])} in - let (i', ti, _,cs_i,_,ef_i) = check_exp envs imp_param false false ret_t it i in - let (e', te, _,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t item_t e in - let cs_loc = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) -> - [LtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_add base rise)] - | (Odec,_) -> - [GtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_sub base rise)] - | (_,Oinc) -> - [LtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise, mk_add base rise)] - | (_,Odec) -> - [GtEq((Expr l),Require,base,min); LtEq((Expr l),Require,mk_add min m_rise,mk_sub base rise)] - | _ -> typ_error l "A vector must be either increasing or decreasing to change a single element" - in - let nt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise; TA_ord ord;TA_typ item_t])} in - let sub_effects = union_effects ef (union_effects ef_i ef_e) in - let (t,cs3,ef3,e') = - type_coerce (Expr l) d_env Require false false b_env nt - (E_aux(E_vector_update(vec',i',e'),(l,constrained_annot_efr nt cs_loc sub_effects))) expect_t in - (e',t,t_env,cs3@cs@cs_i@cs_e@cs_loc,nob,(union_effects ef3 sub_effects)) - | E_vector_update_subrange(vec,i1,i2,e) -> - let base,rise,ord = new_n(),new_n(),new_o() in - let min1,m_rise1 = new_n(),new_n() in - let min2,m_rise2 = new_n(),new_n() in - let item_t = match expect_t_actual.t with - | Tapp("vector",[TA_nexp base_n;TA_nexp rise_n; TA_ord ord_n; TA_typ item_t]) -> item_t - | _ -> new_t() in - let vt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t])} in - let (vec',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t vt vec in - let i1t = {t=Tapp("range",[TA_nexp min1;TA_nexp m_rise1])} in - let (i1', ti1, _,cs_i1,_,ef_i1) = check_exp envs imp_param false false ret_t i1t i1 in - let i2t = {t=Tapp("range",[TA_nexp min2;TA_nexp m_rise2])} in - let (i2', ti2, _,cs_i2,_,ef_i2) = check_exp envs imp_param false false ret_t i2t i2 in - let (e',item_t',_,cs_e,_,ef_e) = - try check_exp envs imp_param true true ret_t item_t e with - | _ -> - let (base_e,rise_e) = new_n(),new_n() in - let (e',ti',env_e,cs_e,bs_e,ef_e) = - check_exp envs imp_param true true ret_t - {t=Tapp("vector",[TA_nexp base_e;TA_nexp rise_e;TA_ord ord;TA_typ item_t])} e - in - let cs_add = [Eq((Expr l),base_e,min1);LtEq((Expr l),Guarantee,rise,m_rise2)] in - (e',ti',env_e,cs_e@cs_add,bs_e,ef_e) in - let cs_loc = - match (ord.order,d_env.default_o.order) with - | (Oinc,_) -> - [LtEq((Expr l),Require,base,min1); LtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2); - LtEq((Expr l),Require,mk_add min2 m_rise2,mk_add base rise);] - | (Odec,_) -> - [GtEq((Expr l),Require,base,mk_add min1 m_rise1); - GtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2); - GtEq((Expr l),Require,mk_add min2 m_rise2,mk_sub base rise);] - | (_,Oinc) -> - [LtEq((Expr l),Require,base,min1); LtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2); - LtEq((Expr l),Require,mk_add min2 m_rise2,mk_add base rise);] - | (_,Odec) -> - [GtEq((Expr l),Require,base,mk_add min1 m_rise1); - GtEq((Expr l),Require,mk_add min1 m_rise1,mk_add min2 m_rise2); - GtEq((Expr l),Require,mk_add min2 m_rise2,mk_sub base rise);] - | _ -> typ_error l "A vector must be either increasing or decreasing to modify a slice" in - let nt = {t=Tapp("vector",[TA_nexp base;TA_nexp rise; TA_ord ord;TA_typ item_t])} in - let sub_effects = union_effects ef (union_effects ef_i1 (union_effects ef_i2 ef_e)) in - let (t,cs3,ef3,e') = - type_coerce (Expr l) d_env Require false false b_env nt - (E_aux(E_vector_update_subrange(vec',i1',i2',e'), - (l,constrained_annot_efr nt cs_loc sub_effects))) expect_t in - (e',t,t_env,cs3@cs@cs_i1@cs_i2@cs_loc@cs_e,nob,(union_effects ef3 sub_effects)) - | E_vector_append(v1,v2) -> - let item_t,ord = match expect_t_actual.t with - | Tapp("vector",[_;_;TA_ord o;TA_typ i]) -> i,o - | Tapp("range",_) -> bit_t,new_o () - | Tapp("atom",_) -> bit_t, new_o () - | _ -> new_t (),new_o () in - let base1,rise1 = new_n(), new_n() in - let base2,rise2 = new_n(),new_n() in - let (v1',t1',_,cs_1,_,ef_1) = - check_exp envs imp_param true true ret_t - {t=Tapp("vector",[TA_nexp base1;TA_nexp rise1;TA_ord ord;TA_typ item_t])} v1 in - let (v2',t2',_,cs_2,_,ef_2) = - check_exp envs imp_param true true ret_t - {t=Tapp("vector",[TA_nexp base2;TA_nexp rise2;TA_ord ord;TA_typ item_t])} v2 in - let result_rise = mk_add rise1 rise2 in - let result_base = match ord.order with - | Odec -> mk_sub result_rise n_one - | _ -> n_zero in - let ti = {t=Tapp("vector",[TA_nexp result_base;TA_nexp result_rise;TA_ord ord; TA_typ item_t])} in - let sub_effects = union_effects ef_1 ef_2 in - let (t,cs_c,ef_c,e') = - type_coerce (Expr l) d_env Require false true b_env ti - (E_aux(E_vector_append(v1',v2'),(l,simple_annot_efr ti sub_effects))) expect_t in - (e',t,t_env,cs_1@cs_2,nob,(union_effects ef_c sub_effects)) - | E_list(es) -> - let item_t = match expect_t_actual.t with - | Tapp("list",[TA_typ i]) -> i - | _ -> new_t() in - let es,cs,effect,item_t = - (List.fold_left (fun (es,cs,effect,_) (e,t,_,c,_,ef) -> (e::es),(c@cs),union_effects ef effect,t) - ([],[],pure_e,item_t) (List.map (check_exp envs imp_param true true ret_t item_t) es) ) in - let t = {t = Tapp("list",[TA_typ item_t])} in - let t',cs',ef',e' = type_coerce (Expr l) d_env Require false false b_env t - (E_aux(E_list es,(l,simple_annot_efr t effect))) expect_t in - (e',t',t_env,cs@cs',nob,union_effects ef' effect) - | E_cons(i, ls) -> - let item_t = match expect_t_actual.t with - | Tapp("list",[TA_typ i]) -> i - | _ -> new_t() in - let lt = {t=Tapp("list",[TA_typ item_t])} in - let (ls',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t lt ls in - let (i', ti, _,cs_i,_,ef_i) = check_exp envs imp_param true true ret_t item_t i in - let sub_effects = union_effects ef ef_i in - let (t',cs',ef',e') = - type_coerce (Expr l) d_env Require false false b_env lt - (E_aux(E_cons(i',ls'),(l,simple_annot_efr lt sub_effects))) expect_t in - (e',t',t_env,cs@cs'@cs_i,nob,union_effects ef' sub_effects) - | E_record(FES_aux(FES_Fexps(fexps,_),l')) -> - let u,_ = get_abbrev d_env expect_t in - let u_actual = match u.t with | Tabbrev(_, u) -> u | _ -> u in - let field_walker r subst_env bounds tag n = - (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) (fexps,cons,ef') -> - let i = id_to_string id in - match lookup_field_type i r with - | None -> - typ_error l ("Expected a struct of type " ^ n ^ ", which should not have a field " ^ i) - | Some(ft) -> - let ft = typ_subst subst_env false ft in - let (e,t',_,c,_,ef) = check_exp envs imp_param true true ret_t ft exp in - (FE_aux(FE_Fexp(id,e),(l,Base(([],t'),tag,c,ef,ef,bounds)))::fexps,cons@c,union_effects ef ef')) in - (match u_actual.t with - | Tid(n) | Tapp(n,_)-> - (match lookup_record_typ n d_env.rec_env with - | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - if (List.length fexps = List.length fields) - then let fexps,cons,ef = - List.fold_right (field_walker r subst_env bounds tag n) fexps ([],[],pure_e) in - let e = E_aux(E_record(FES_aux(FES_Fexps(fexps,false),l')),(l,simple_annot_efr u ef)) in - let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in - (e',t',t_env,cs@cons@cs',nob,union_effects ef ef') - else typ_error l ("Expected a struct of type " ^ n ^ ", which should have " ^ - string_of_int (List.length fields) ^ " fields") - | Some(i,Register,tannot,fields) -> typ_error l ("Expected a value with register type, found a struct") - | _ -> typ_error l ("Expected a value of type " ^ n ^ " but found a struct")) - | Tuvar _ -> - let field_names = List.map (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) -> id_to_string id) fexps in - (match lookup_record_fields field_names d_env.rec_env with - | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in - let e = E_aux(E_record(FES_aux(FES_Fexps(fexps,false),l')),(l,simple_annot_efr ts ef)) in - let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in - (e',t',t_env,cs@cons@cs',nob,union_effects ef ef') - | Some(i,Register,tannot,fields) -> typ_error l "Expected a value with register type, found a struct" - | _ -> typ_error l "No struct type matches the set of fields given") - | _ -> typ_error l ("Expected an expression of type " ^ t_to_string expect_t ^ " but found a struct")) - | E_record_update(exp,FES_aux(FES_Fexps(fexps,_),l')) -> - let (e',t',_,c,_,ef) = check_exp envs imp_param true true ret_t expect_t exp in - let field_walker r subst_env bounds tag i = - (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) (fexps,cons,ef') -> - let fi = id_to_string id in - match lookup_field_type fi r with - | None -> typ_error l ("Expected a struct with type " ^ i ^ ", which does not have a field " ^ fi) - | Some ft -> - let ft = typ_subst subst_env false ft in - let (e,t',_,c,_,ef) = check_exp envs imp_param true true ret_t ft exp in - (FE_aux(FE_Fexp(id,e),(l,Base(([],t'),tag,c,pure_e,ef,bounds)))::fexps,cons@c,union_effects ef ef')) in - (match t'.t with - | Tid i | Tabbrev(_, {t=Tid i}) | Tapp(i,_) -> - (match lookup_record_typ i d_env.rec_env with - | Some((i,Register,tannot,fields)) -> - typ_error l "Expected a struct for this update, instead found a register" - | Some(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) -> - if (List.length fexps <= List.length fields) - then - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in - let e = E_aux(E_record_update(e',FES_aux(FES_Fexps(fexps,false),l')), (l,simple_annot_efr ts ef)) in - let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in - (e',t',t_env,cs@cons@cs',nob,union_effects ef ef') - else typ_error l ("Expected fields from struct " ^ i ^ ", given more fields than struct includes") - | _ -> - typ_error l ("Expected a struct or register, instead found an expression with type " ^ i)) - | Tuvar _ -> - let field_names = List.map (fun (FE_aux(FE_Fexp(id,exp),(l,annot))) -> id_to_string id) fexps in - (match lookup_possible_records field_names d_env.rec_env with - | [] -> typ_error l "No struct matches the set of fields given for this struct update" - | [(((i,Record,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r))] -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - let fexps,cons,ef = List.fold_right (field_walker r subst_env bounds tag i) fexps ([],[],pure_e) in - let e = E_aux(E_record_update(e',FES_aux(FES_Fexps(fexps,false),l')), (l,simple_annot_efr ts ef)) in - let (t',cs',ef',e') = type_coerce (Expr l) d_env Guarantee false false b_env ts e expect_t in - (e',t',t_env,cs@cons@cs',nob,union_effects ef ef') - | [(i,Register,tannot,fields)] -> typ_error l "Expected a value with register type, found a struct" - | records -> typ_error l "Multiple structs contain this set of fields, try adding a cast") - | _ -> typ_error l ("Expected a struct to update but found an expression of type " ^ t_to_string expect_t)) - | E_field(exp,id) -> - let (e',t',env_sub,c_sub,bounds,ef_sub) = check_exp envs imp_param true true ret_t (new_t()) exp in - let fi = id_to_string id in - (match t'.t with - | Tabbrev({t=Tid i}, _) | Tabbrev({t=Tapp(i,_)},_) | Tid i | Tapp(i,_) -> - (match lookup_record_typ i d_env.rec_env with - | Some(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - (match lookup_field_type fi r with - | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi) - | Some t -> - let ft = typ_subst subst_env false t in - let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee true ts t' in - let (e',t',_,c_sub,_,ef_sub),ef_update = - match rec_kind with - | Register -> - (check_exp envs imp_param true true ret_t (into_register_typ t') exp, - add_effect (BE_aux(BE_rreg, l)) pure_e) - | Record -> ((e',t',env_sub,c_sub,bounds,ef_sub), pure_e) in - let (et',c',ef',acc) = - type_coerce (Expr l) d_env Require false true b_env ft - (E_aux(E_field(e',id), - (l,Base(([],ft), - tag,cs,union_effects eft ef_update,union_effects ef_sub ef_update,bounds)))) - expect_t in - (acc,et',t_env,cs@c'@c_sub@cs_sub',nob,union_effects ef' (union_effects ef_update ef_sub))) - | _ -> - typ_error l ("Expected a struct or register, instead found an expression with type " ^ i)) - | Tuvar _ -> - (match lookup_possible_records [fi] d_env.rec_env with - | [] -> typ_error l ("No struct or register has a field " ^ fi) - | [(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r))] -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - (match lookup_field_type fi r with - | None -> - raise - (Reporting_basic.err_unreachable l "lookup_possible_records returned a record without the field") - | Some t -> - let ft = typ_subst subst_env false t in - let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee false ts t' in - let (e',t',_,c_sub,_,ef_sub),ef_update = - match rec_kind with - | Register -> - (check_exp envs imp_param true true ret_t (into_register_typ t') exp, - add_effect (BE_aux(BE_rreg, l)) pure_e) - | Record -> ((e',t',env_sub,c_sub,bounds,ef_sub), pure_e) in - let (et',c',ef',acc) = - type_coerce (Expr l) d_env Require false false b_env ft - (E_aux(E_field(e',id), - (l,Base(([],ft),tag, - cs,union_effects eft ef_update,union_effects ef_sub ef_update,bounds)))) expect_t in - (acc,et',t_env,cs@c'@c_sub@cs_sub',nob,union_effects ef' (union_effects ef_update ef_sub))) - | records -> - typ_error l ("Multiple structs or registers contain field " ^ fi ^ ", try adding a cast to disambiguate")) - | _ -> typ_error l ("Expected a struct or register but found an expression of type " ^ t_to_string t')) - | E_case(exp,pexps) -> - let (e',t',_,cs,_,ef) = check_exp envs imp_param true true ret_t (new_t()) exp in - (*let _ = Printf.eprintf "Type of pattern after expression check %s\n" (t_to_string t') in*) - let t' = - match t'.t with - | Tapp("register",[TA_typ t]) -> t - | _ -> t' in - (*let _ = Printf.eprintf "Type of pattern after register check %s\n" (t_to_string t') in*) - let (pexps',t,cs',ef') = - check_cases envs imp_param ret_t t' expect_t (if (List.length pexps) = 1 then Solo else Switch) pexps in - let effects = union_effects ef ef' in - (E_aux(E_case(e',pexps'),(l,simple_annot_efr t effects)),t, - t_env,cs@[BranchCons(Expr l, None, cs')],nob,effects) - | E_let(lbind,body) -> - let (lb',t_env',cs,b_env',ef) = (check_lbind envs imp_param false (Some ret_t) Emp_local lbind) in - let new_env = - (Env(d_env,Envmap.union_merge (tannot_merge (Expr l) d_env false) - t_env t_env', merge_bounds b_env' b_env,tp_env)) - in - let (e,t,_,cs',_,ef') = check_exp new_env imp_param true true ret_t expect_t body in - let effects = union_effects ef ef' in - (E_aux(E_let(lb',e),(l,simple_annot_efr t effects)),t,t_env,cs@cs',nob,effects) - | E_assign(lexp,exp) -> - let (lexp',t',_,t_env',tag,cs,b_env',efl,efr) = check_lexp envs imp_param ret_t true lexp in - let t' = match t'.t with | Tapp("reg",[TA_typ t]) | Tapp("register",[TA_typ t]) - | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t - | _ -> t' in - let (exp',t'',_,cs',_,efr') = check_exp envs imp_param true true ret_t t' exp in - let (t',c') = type_consistent (Expr l) d_env Require false unit_t expect_t in - let effects = union_effects efl (union_effects efr efr') in - (E_aux(E_assign(lexp',exp'),(l,(Base(([],unit_t),tag,[],efl,effects,nob)))), - unit_t,t_env',cs@cs'@c',b_env',effects) - | E_exit e -> - let (e',t',_,_,_,_) = check_exp envs imp_param true true ret_t (new_t ()) e in - let efs = add_effect (BE_aux(BE_escape, l)) pure_e in - (E_aux (E_exit e',(l,(simple_annot_efr expect_t efs))),expect_t,t_env,[],nob,efs) - | E_return e -> - let (e', t'',_,cs,_,efr) = check_exp envs imp_param true true ret_t ret_t e in - let ers = add_effect (BE_aux (BE_lret,l)) pure_e in - (E_aux (E_return e', (l, (simple_annot_efr ret_t ers))), ret_t, t_env,cs,nob,union_effects efr ers) - | E_sizeof nexp -> - let n = anexp_to_nexp envs nexp in - let n_subst = subst_n_with_env tp_env n in - let n_typ = mk_atom n_subst in - let nannot = bounds_annot n_typ b_env in - let e = E_aux (E_sizeof_internal (l, nannot), (l,nannot)) in - let t',cs,ef,e' = type_coerce (Expr l) d_env Require false false b_env n_typ e expect_t in - (e',t',t_env,cs,nob,ef) - | E_assert(cond,msg) -> - let (cond',t',_,_,_,_) = check_exp envs imp_param true true ret_t bit_t cond in - let (msg',mt',_,_,_,_) = check_exp envs imp_param true true ret_t {t= Tapp("option",[TA_typ string_t])} msg in - let (t',c') = type_consistent (Expr l) d_env Require false unit_t expect_t in - (E_aux (E_assert(cond',msg'), (l, (simple_annot expect_t))), expect_t,t_env,c',nob,pure_e) - | E_comment s -> - (E_aux (E_comment s, (l, simple_annot unit_t)), expect_t,t_env,[],nob,pure_e) - | E_comment_struc e -> - (E_aux (E_comment_struc e, (l, simple_annot unit_t)), expect_t,t_env,[],nob,pure_e) - | E_internal_cast _ | E_internal_exp _ | E_internal_exp_user _ | E_internal_let _ - | E_internal_plet _ | E_internal_return _ | E_sizeof_internal _ -> - raise (Reporting_basic.err_unreachable l "Internal expression passed back into type checker") - -and recheck_for_register envs imp_param widen_num widen_vec ret_t expect_t exp = - match check_exp envs imp_param widen_num widen_vec ret_t expect_t exp with - | exp',t',_,cs,_,ef -> - match exp' with - | E_aux(_, (l, Base(_, _, _, leff, ceff, _))) -> - if has_rreg_effect ceff - then try let (exp',t',_,cs,_,ef) = - check_exp envs imp_param widen_num widen_vec ret_t (into_register_typ t') exp in - (exp',t',cs,ef),(add_effect (BE_aux(BE_rreg,l)) pure_e),External None - with | _ -> (exp',t',cs,ef),pure_e, Emp_local - else (exp',t',cs,ef),pure_e, Emp_local - | _ -> (exp',t',cs,ef),pure_e, Emp_local - -and check_block envs imp_param ret_t expect_t exps:((tannot exp) list * tannot * nexp_range list * t * effect) = - let Env(d_env,t_env,b_env,tp_env) = envs in - match exps with - | [] -> ([],NoTyp,[],unit_t,pure_e) - | [e] -> - let (E_aux(e',(l,annot)),t,envs,sc,_,ef) = check_exp envs imp_param true true ret_t expect_t e in - ([E_aux(e',(l,annot))],annot,sc,t,ef) - | e::exps -> - let (e',t',t_env',sc,b_env',ef') = check_exp envs imp_param true true ret_t unit_t e in - let (exps',annot',sc',t,ef) = - check_block (Env(d_env, - Envmap.union_merge (tannot_merge (Expr Parse_ast.Unknown) d_env false) t_env t_env', - merge_bounds b_env' b_env, tp_env)) imp_param ret_t expect_t exps in - let annot' = match annot' with - | Base(pt,tag,cs,efl,efr,bounds) -> Base(pt,tag,cs,efl,union_effects efr ef',bounds) - | _ -> annot' in - ((e'::exps'),annot',sc@sc',t,union_effects ef ef') - -and check_cases envs imp_param ret_t check_t expect_t kind pexps - : ((tannot pexp) list * typ * nexp_range list * effect) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match pexps with - | [] -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "switch with no cases found") - | [(Pat_aux(Pat_exp(pat,exp),(l,annot)))] -> - let pat',env,cs_p,bounds,u = check_pattern envs Emp_local check_t pat in - let e,t,_,cs_e,_,ef = - check_exp (Env(d_env, - Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env env, - merge_bounds b_env bounds, tp_env)) imp_param true true ret_t expect_t exp in - let cs = [CondCons(Expr l,kind,None, cs_p, cs_e)] in - [Pat_aux(Pat_exp(pat',e),(l,cons_efs_annot t cs pure_e ef))],t,cs,ef - | ((Pat_aux(Pat_exp(pat,exp),(l,annot)))::pexps) -> - let pat',env,cs_p,bounds,u = check_pattern envs Emp_local check_t pat in - let (e,t,_,cs_e,_,ef) = - check_exp (Env(d_env, - Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env env, - merge_bounds b_env bounds, tp_env)) imp_param true true ret_t expect_t exp in - let cs = CondCons(Expr l,kind,None,cs_p,cs_e) in - let (pes,tl,csl,efl) = check_cases envs imp_param ret_t check_t expect_t kind pexps in - ((Pat_aux(Pat_exp(pat',e),(l,cons_efs_annot t [cs] pure_e ef)))::pes,tl,cs::csl,union_effects efl ef) - -and check_lexp envs imp_param ret_t is_top (LEXP_aux(lexp,(l,annot))) - : (tannot lexp * typ * bool * tannot emap * tag * nexp_range list * bounds_env * effect * effect ) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match lexp with - | LEXP_id id -> - let i = id_to_string id in - (match Envmap.apply t_env i with - | Some(Base((parms,t),Default,_,_,_,_)) -> - let t = {t=Tapp("reg",[TA_typ t])} in - let bounds = extract_bounds d_env i t in - let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in - (LEXP_aux(lexp,(l,tannot)),t,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e) - | Some(Base(([],t),Alias alias_inf,_,_,_,_)) -> - let ef = {effect = Eset[BE_aux(BE_wreg,l)]} in - (match Envmap.apply d_env.alias_env i with - | Some(OneReg(reg, (Base(([],t'),_,_,_,_,_)))) -> - (LEXP_aux(lexp,(l,(Base(([],t'),Alias alias_inf,[],ef,ef,nob)))), t, false, - Envmap.empty, External (Some reg),[],nob,ef,ef) - | Some(TwoReg(reg1,reg2, (Base(([],t'),_,_,_,_,_)))) -> - let u = match t.t with - | Tapp("register", [TA_typ u]) -> u - | _ -> raise (Reporting_basic.err_unreachable l "TwoReg didn't contain a register type") in - (LEXP_aux(lexp,(l,Base(([],t'),Alias alias_inf,[],ef,ef,nob))), - u, false, Envmap.empty, External None,[],nob,ef,ef) - | _ -> assert false) - | Some(Base((parms,t),tag,cs,_,_,b)) -> - let t,cs,ef,_ = - match tag with | External _ | Emp_global -> subst parms false false t cs pure_e - | _ -> t,cs,{effect = Eset[BE_aux(BE_lset,l)]},Envmap.empty + let fold_accessors accs (typ, fid) = + let acc_typ = mk_typ (Typ_fn (rectyp, typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in + typ_print (indent 1 ^ "Adding accessor " ^ string_of_id fid ^ " :: " ^ string_of_bind (typq, acc_typ)); + Bindings.add fid (typq, acc_typ) accs + in + { env with records = Bindings.add id (typq, fields) env.records; + accessors = List.fold_left fold_accessors env.accessors fields } + end + + let get_accessor id env = + let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in + try freshen_bind (Bindings.find id env.accessors) + with + | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id id) + + let is_mutable id env = + try + let (mut, _) = Bindings.find id env.locals in + match mut with + | Mutable -> true + | Immutable -> false + with + | Not_found -> typ_error (id_loc id) ("No local binding found for " ^ string_of_id id) + + let string_of_mtyp (mut, typ) = match mut with + | Immutable -> string_of_typ typ + | Mutable -> "ref<" ^ string_of_typ typ ^ ">" + + let add_local id mtyp env = + begin + wf_typ env (snd mtyp); + typ_print ("Adding local binding " ^ string_of_id id ^ " :: " ^ string_of_mtyp mtyp); + { env with locals = Bindings.add id mtyp env.locals } + end + + let add_variant id variant env = + begin + typ_print ("Adding variant " ^ string_of_id id); + { env with variants = Bindings.add id variant env.variants } + end + + let add_union_id id bind env = + begin + typ_print ("Adding union identifier binding " ^ string_of_id id ^ " :: " ^ string_of_bind bind); + { env with union_ids = Bindings.add id bind env.union_ids } + end + + let get_flow id env = + try Bindings.find id env.flow with + | Not_found -> fun typ -> typ + + let add_flow id f env = + begin + typ_print ("Adding flow constraints for " ^ string_of_id id); + { env with flow = Bindings.add id (fun typ -> f (get_flow id env typ)) env.flow } + end + + let get_register id env = + try Bindings.find id env.registers with + | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id) + + let get_overloads id env = + try Bindings.find id env.overloads with + | Not_found -> [] + + let add_overloads id ids env = + typ_print ("Adding overloads for " ^ string_of_id id ^ " [" ^ string_of_list ", " string_of_id ids ^ "]"); + { env with overloads = Bindings.add id ids env.overloads } + + let get_casts env = env.casts + + let check_index_range cmp f t (BF_aux (ir, l)) = + match ir with + | BF_single n -> + if cmp f n && cmp n t + then n + else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n; t]) + | BF_range (n1, n2) -> + if cmp f n1 && cmp n1 n2 && cmp n2 t + then n2 + else typ_error l ("Badly ordered index range: " ^ string_of_list ", " string_of_int [f; n1; n2; t]) + | BF_concat _ -> typ_error l "Index range concatenation currently unsupported" + + let rec check_index_ranges ids cmp base top = function + | [] -> () + | ((range, id) :: ranges) -> + if IdSet.mem id ids + then typ_error (id_loc id) ("Duplicate id " ^ string_of_id id ^ " in register typedef") + else + begin + let base' = check_index_range cmp base top range in + check_index_ranges (IdSet.add id ids) cmp base' top ranges + end + + let add_register id typ env = + if Bindings.mem id env.registers + then typ_error (id_loc id) ("Register " ^ string_of_id id ^ " is already bound") + else + begin + typ_print ("Adding register binding " ^ string_of_id id ^ " :: " ^ string_of_typ typ); + { env with registers = Bindings.add id typ env.registers } + end + + let add_regtyp id base top ranges env = + if Bindings.mem id env.regtyps + then typ_error (id_loc id) ("Register type " ^ string_of_id id ^ " is already bound") + else + begin + typ_print ("Adding register type " ^ string_of_id id); + if base > top + then check_index_ranges IdSet.empty (fun x y -> x > y) (base + 1) (top - 1) ranges + else check_index_ranges IdSet.empty (fun x y -> x < y) (base - 1) (top + 1) ranges; + { env with regtyps = Bindings.add id (base, top, ranges) env.regtyps } + end + + let is_regtyp id env = Bindings.mem id env.regtyps + + let get_regtyp id env = + try Bindings.find id env.regtyps with + | Not_found -> typ_error (id_loc id) (string_of_id id ^ " is not a register type") + + let lookup_id id env = + try + let (mut, typ) = Bindings.find id env.locals in + let flow = get_flow id env in + Local (mut, flow typ) + with + | Not_found -> + begin + try Register (Bindings.find id env.registers) with + | Not_found -> + begin + try + let (enum, _) = List.find (fun (enum, ctors) -> IdSet.mem id ctors) (Bindings.bindings env.enums) in + Enum (mk_typ (Typ_id enum)) + with + | Not_found -> + begin + try + let (typq, typ) = freshen_bind env (Bindings.find id env.union_ids) in + Union (typq, typ) + with + | Not_found -> Unbound + end + end + end + + let add_typ_var kid k env = + if KBindings.mem kid env.typ_vars + then typ_error (kid_loc kid) ("Kind identifier " ^ string_of_kid kid ^ " is already bound") + else + begin + typ_debug ("Adding kind identifier binding " ^ string_of_kid kid ^ " :: " ^ string_of_base_kind_aux k); + { env with typ_vars = KBindings.add kid k env.typ_vars } + end + + let rec wf_constraint env (NC_aux (nc, _)) = + match nc with + | NC_fixed (n1, n2) -> wf_nexp env n1; wf_nexp env n2 + | NC_not_equal (n1, n2) -> wf_nexp env n1; wf_nexp env n2 + | NC_bounded_ge (n1, n2) -> wf_nexp env n1; wf_nexp env n2 + | NC_bounded_le (n1, n2) -> wf_nexp env n1; wf_nexp env n2 + | NC_nat_set_bounded (kid, ints) -> () (* MAYBE: We could demand that ints are all unique here *) + | NC_or (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2 + | NC_and (nc1, nc2) -> wf_constraint env nc1; wf_constraint env nc2 + + let get_constraints env = env.constraints + + let add_constraint (NC_aux (_, l) as constr) env = + wf_constraint env constr; + begin + typ_print ("Adding constraint " ^ string_of_n_constraint constr); + { env with constraints = constr :: env.constraints } + end + + let get_ret_typ env = env.ret_typ + + let add_ret_typ typ env = { env with ret_typ = Some typ } + + let allow_casts env = env.allow_casts + + let no_casts env = { env with allow_casts = false } + let enable_casts env = { env with allow_casts = true } + + let add_cast cast env = + typ_print ("Adding cast " ^ string_of_id cast); + { env with casts = cast :: env.casts } + + let add_typ_synonym id synonym env = + if Bindings.mem id env.typ_synonyms + then typ_error (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists") + else + begin + typ_print ("Adding type synonym " ^ string_of_id id); + { env with typ_synonyms = Bindings.add id synonym env.typ_synonyms } + end + + let get_typ_synonym id env = Bindings.find id env.typ_synonyms + + let rec expand_synonyms env (Typ_aux (typ, l) as t) = + match typ with + | Typ_tup typs -> Typ_aux (Typ_tup (List.map (expand_synonyms env) typs), l) + | Typ_fn (typ1, typ2, effs) -> Typ_aux (Typ_fn (expand_synonyms env typ1, expand_synonyms env typ2, effs), l) + | Typ_app (id, args) -> + begin + try + let synonym = Bindings.find id env.typ_synonyms in + expand_synonyms env (synonym args) + with + | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l) + end + | Typ_id id -> + begin + try + let synonym = Bindings.find id env.typ_synonyms in + expand_synonyms env (synonym []) + with + | Not_found -> Typ_aux (Typ_id id, l) + end + | typ -> Typ_aux (typ, l) + and expand_synonyms_arg env (Typ_arg_aux (typ_arg, l)) = + match typ_arg with + | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (expand_synonyms env typ), l) + | arg -> Typ_arg_aux (arg, l) + + let base_typ_of env typ = + let rec aux (Typ_aux (t,a)) = + let rewrap t = Typ_aux (t,a) in + match t with + | Typ_fn (t1, t2, eff) -> + rewrap (Typ_fn (aux t1, aux t2, eff)) + | Typ_tup ts -> + rewrap (Typ_tup (List.map aux ts)) + | Typ_app (register, [Typ_arg_aux (Typ_arg_typ rtyp,_)]) + when string_of_id register = "register" -> + aux rtyp + | Typ_app (id, targs) -> + rewrap (Typ_app (id, List.map aux_arg targs)) + | t -> rewrap t + and aux_arg (Typ_arg_aux (targ,a)) = + let rewrap targ = Typ_arg_aux (targ,a) in + match targ with + | Typ_arg_typ typ -> rewrap (Typ_arg_typ (aux typ)) + | targ -> rewrap targ in + aux (expand_synonyms env typ) + + let get_default_order env = + match env.default_order with + | None -> typ_error Parse_ast.Unknown ("No default order has been set") + | Some ord -> ord + + let set_default_order o env = + match env.default_order with + | None -> { env with default_order = Some (Ord_aux (o, Parse_ast.Unknown)) } + | Some _ -> typ_error Parse_ast.Unknown ("Cannot change default order once already set") + + let set_default_order_inc = set_default_order Ord_inc + let set_default_order_dec = set_default_order Ord_dec + +end + + +let add_typquant (quant : typquant) (env : Env.t) : Env.t = + let rec add_quant_item env = function + | QI_aux (qi, _) -> add_quant_item_aux env qi + and add_quant_item_aux env = function + | QI_const constr -> Env.add_constraint constr env + | QI_id (KOpt_aux (KOpt_none kid, _)) -> Env.add_typ_var kid BK_nat env + | QI_id (KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (k, _)], _), kid), _)) -> Env.add_typ_var kid k env + | QI_id (KOpt_aux (_, l)) -> typ_error l "Type variable had non base kinds!" + in + match quant with + | TypQ_aux (TypQ_no_forall, _) -> env + | TypQ_aux (TypQ_tq quants, _) -> List.fold_left add_quant_item env quants + +(* Create vectors with the default order from the environment *) + +let dvector_typ env n m typ = vector_typ n m (Env.get_default_order env) typ + +let lvector_typ env l typ = + match Env.get_default_order env with + | Ord_aux (Ord_inc, _) as ord -> + vector_typ (nconstant 0) l ord typ + | Ord_aux (Ord_dec, _) as ord -> + vector_typ (nminus l (nconstant 1)) l ord typ + +let initial_env = + Env.empty + |> Env.add_typ_synonym (mk_id "atom") (fun args -> mk_typ (Typ_app (mk_id "range", args @ args))) + +(**************************************************************************) +(* 3. Subtyping and constraint solving *) +(**************************************************************************) + +let order_eq (Ord_aux (ord_aux1, _)) (Ord_aux (ord_aux2, _)) = + match ord_aux1, ord_aux2 with + | Ord_inc, Ord_inc -> true + | Ord_dec, Ord_dec -> true + | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0 + | _, _ -> false + +let rec props_subst sv subst props = + match props with + | [] -> [] + | ((nexp1, nexp2) :: props) -> (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2) :: props_subst sv subst props + +type tnf = + | Tnf_wild + | Tnf_id of id + | Tnf_var of kid + | Tnf_tup of tnf list + | Tnf_index_sort of index_sort + | Tnf_app of id * tnf_arg list +and tnf_arg = + | Tnf_arg_nexp of nexp + | Tnf_arg_typ of tnf + | Tnf_arg_order of order + | Tnf_arg_effect of effect + +let rec string_of_tnf = function + | Tnf_wild -> "_" + | Tnf_id id -> string_of_id id + | Tnf_var kid -> string_of_kid kid + | Tnf_tup tnfs -> "(" ^ string_of_list ", " string_of_tnf tnfs ^ ")" + | Tnf_app (id, args) -> string_of_id id ^ "<" ^ string_of_list ", " string_of_tnf_arg args ^ ">" + | Tnf_index_sort IS_int -> "INT" + | Tnf_index_sort (IS_prop (kid, props)) -> + "{" ^ string_of_kid kid ^ " | " ^ string_of_list " & " (fun (n1, n2) -> string_of_nexp n1 ^ " <= " ^ string_of_nexp n2) props ^ "}" +and string_of_tnf_arg = function + | Tnf_arg_nexp n -> string_of_nexp n + | Tnf_arg_typ tnf -> string_of_tnf tnf + | Tnf_arg_order o -> string_of_order o + | Tnf_arg_effect eff -> string_of_effect eff + +let rec normalize_typ env (Typ_aux (typ, l)) = + match typ with + | Typ_wild -> Tnf_wild + | Typ_id (Id_aux (Id "int", _)) -> Tnf_index_sort IS_int + | Typ_id (Id_aux (Id "nat", _)) -> + let kid = Env.fresh_kid env in Tnf_index_sort (IS_prop (kid, [(nconstant 0, nvar kid)])) + | Typ_id v -> + begin + try normalize_typ env (Env.get_typ_synonym v env []) with + | Not_found -> Tnf_id v + end + | Typ_var kid -> Tnf_var kid + | Typ_tup typs -> Tnf_tup (List.map (normalize_typ env) typs) + | Typ_app (f, []) -> normalize_typ env (Typ_aux (Typ_id f, l)) + | Typ_app (Id_aux (Id "range", _), [Typ_arg_aux (Typ_arg_nexp n1, _); Typ_arg_aux (Typ_arg_nexp n2, _)]) -> + let kid = Env.fresh_kid env in + Tnf_index_sort (IS_prop (kid, [(n1, nvar kid); (nvar kid, n2)])) + | Typ_app ((Id_aux (Id "vector", _) as vector), args) -> + Tnf_app (vector, List.map (normalize_typ_arg env) args) + | Typ_app (id, args) -> + begin + try normalize_typ env (Env.get_typ_synonym id env args) with + | Not_found -> Tnf_app (id, List.map (normalize_typ_arg env) args) + end + | Typ_fn _ -> typ_error l ("Cannot normalize function type " ^ string_of_typ (Typ_aux (typ, l))) +and normalize_typ_arg env (Typ_arg_aux (typ_arg, _)) = + match typ_arg with + | Typ_arg_nexp n -> Tnf_arg_nexp n + | Typ_arg_typ typ -> Tnf_arg_typ (normalize_typ env typ) + | Typ_arg_order o -> Tnf_arg_order o + | Typ_arg_effect e -> Tnf_arg_effect e + +(* Here's how the constraint generation works for subtyping + +X(b,c...) --> {a. Y(a,b,c...)} \subseteq {a. Z(a,b,c...)} + +this is equivalent to + +\forall b c. X(b,c) --> \forall a. Y(a,b,c) --> Z(a,b,c) + +\forall b c. X(b,c) --> \forall a. !Y(a,b,c) \/ !Z^-1(a,b,c) + +\forall b c. X(b,c) --> !\exists a. Y(a,b,c) /\ Z^-1(a,b,c) + +\forall b c. !X(b,c) \/ !\exists a. Y(a,b,c) /\ Z^-1(a,b,c) + +!\exists b c. X(b,c) /\ \exists a. Y(a,b,c) /\ Z^-1(a,b,c) + +!\exists a b c. X(b,c) /\ Y(a,b,c) /\ Z^-1(a,b,c) + +which is then a problem we can feed to the constraint solver expecting unsat. + *) + +let rec nexp_constraint var_of (Nexp_aux (nexp, l)) = + match nexp with + | Nexp_id v -> typ_error l "Unimplemented: Cannot generate constraint from Nexp_id" + | Nexp_var kid -> Constraint.variable (var_of kid) + | Nexp_constant c -> Constraint.constant (big_int_of_int c) + | Nexp_times (nexp1, nexp2) -> Constraint.mult (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint var_of nexp) + | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint var_of nexp) + +let rec nc_constraint var_of (NC_aux (nc, l)) = + match nc with + | NC_fixed (nexp1, nexp2) -> Constraint.eq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | NC_not_equal (nexp1, nexp2) -> Constraint.neq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | NC_bounded_ge (nexp1, nexp2) -> Constraint.gteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | NC_bounded_le (nexp1, nexp2) -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | NC_nat_set_bounded (_, []) -> Constraint.literal false + | NC_nat_set_bounded (kid, (int :: ints)) -> + List.fold_left Constraint.disj + (Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int int))) + (List.map (fun i -> Constraint.eq (nexp_constraint var_of (nvar kid)) (Constraint.constant (big_int_of_int i))) ints) + | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint var_of nc1) (nc_constraint var_of nc2) + | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint var_of nc1) (nc_constraint var_of nc2) + +let rec nc_constraints var_of ncs = + match ncs with + | [] -> Constraint.literal true + | [nc] -> nc_constraint var_of nc + | (nc :: ncs) -> + Constraint.conj (nc_constraint var_of nc) (nc_constraints var_of ncs) + +let prove_z3 env nc = + typ_print ("Prove " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc); + let module Bindings = Map.Make(Kid) in + let bindings = ref Bindings.empty in + let fresh_var kid = + let n = Bindings.cardinal !bindings in + bindings := Bindings.add kid n !bindings; + n + in + let var_of kid = + try Bindings.find kid !bindings with + | Not_found -> fresh_var kid + in + let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.negate (nc_constraint var_of nc)) in + match Constraint.call_z3 constr with + | Constraint.Unsat _ -> typ_debug "unsat"; true + | Constraint.Unknown [] -> typ_debug "sat"; false + | Constraint.Unknown _ -> typ_debug "unknown"; false + +let prove env (NC_aux (nc_aux, _) as nc) = + let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) = + match n1, n2 with + | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true + | _, _ -> false + in + match nc_aux with + | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 = c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 >= c2) (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_fixed (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 <> c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false + | NC_bounded_le (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 > c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false + | NC_bounded_ge (nexp1, nexp2) when compare_const (fun c1 c2 -> c1 < c2) (nexp_simp nexp1) (nexp_simp nexp2) -> false + | _ -> prove_z3 env nc + +let rec subtyp_tnf env tnf1 tnf2 = + typ_print ("Subset " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_tnf tnf1 ^ " " ^ string_of_tnf tnf2); + let module Bindings = Map.Make(Kid) in + let bindings = ref Bindings.empty in + let fresh_var kid = + let n = Bindings.cardinal !bindings in + bindings := Bindings.add kid n !bindings; + n + in + let var_of kid = + try Bindings.find kid !bindings with + | Not_found -> fresh_var kid + in + let rec neg_props props = + match props with + | [] -> Constraint.literal false + | [(nexp1, nexp2)] -> Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | ((nexp1, nexp2) :: props) -> + Constraint.disj (Constraint.gt (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (neg_props props) + in + let rec pos_props props = + match props with + | [] -> Constraint.literal true + | [(nexp1, nexp2)] -> Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2) + | ((nexp1, nexp2) :: props) -> + Constraint.conj (Constraint.lteq (nexp_constraint var_of nexp1) (nexp_constraint var_of nexp2)) (pos_props props) + in + match (tnf1, tnf2) with + | Tnf_wild, Tnf_wild -> true + | Tnf_id v1, Tnf_id v2 -> Id.compare v1 v2 = 0 + | Tnf_var kid1, Tnf_var kid2 -> Kid.compare kid1 kid2 = 0 + | Tnf_tup tnfs1, Tnf_tup tnfs2 -> + begin + try List.for_all2 (subtyp_tnf env) tnfs1 tnfs2 with + | Invalid_argument _ -> false + end + | Tnf_app (v1, args1), Tnf_app (v2, args2) -> Id.compare v1 v2 = 0 && List.for_all2 (tnf_args_eq env) args1 args2 + | Tnf_index_sort IS_int, Tnf_index_sort IS_int -> true + | Tnf_index_sort (IS_prop _), Tnf_index_sort IS_int -> true + | Tnf_index_sort (IS_prop (kid1, prop1)), Tnf_index_sort (IS_prop (kid2, prop2)) -> + begin + let kid3 = Env.fresh_kid env in + let (prop1, prop2) = props_subst kid1 (Nexp_var kid3) prop1, props_subst kid2 (Nexp_var kid3) prop2 in + let constr = Constraint.conj (nc_constraints var_of (Env.get_constraints env)) (Constraint.conj (pos_props prop1) (neg_props prop2)) in + match Constraint.call_z3 constr with + | Constraint.Unsat _ -> typ_debug "unsat"; true + | Constraint.Unknown [] -> typ_debug "sat"; false + | Constraint.Unknown _ -> typ_debug "unknown"; false + end + | _, _ -> false + +and tnf_args_eq env arg1 arg2 = + match arg1, arg2 with + | Tnf_arg_nexp n1, Tnf_arg_nexp n2 -> prove env (NC_aux (NC_fixed (n1, n2), Parse_ast.Unknown)) + | Tnf_arg_order ord1, Tnf_arg_order ord2 -> order_eq ord1 ord2 + | Tnf_arg_typ tnf1, Tnf_arg_typ tnf2 -> subtyp_tnf env tnf1 tnf2 && subtyp_tnf env tnf2 tnf1 + | _, _ -> assert false + +let subtyp l env typ1 typ2 = + if subtyp_tnf env (normalize_typ env typ1) (normalize_typ env typ2) + then () + else typ_error l (string_of_typ typ1 + ^ " is not a subtype of " ^ string_of_typ typ2 + ^ " in context " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)) + +let typ_equality l env typ1 typ2 = + subtyp l env typ1 typ2; subtyp l env typ2 typ1 + +(**************************************************************************) +(* 4. Unification *) +(**************************************************************************) + +let order_frees (Ord_aux (ord_aux, l)) = + match ord_aux with + | Ord_var kid -> KidSet.singleton kid + | _ -> KidSet.empty + +let rec typ_frees (Typ_aux (typ_aux, l)) = + match typ_aux with + | Typ_wild -> KidSet.empty + | Typ_id v -> KidSet.empty + | Typ_var kid -> KidSet.singleton kid + | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map typ_frees typs) + | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map typ_arg_frees args) +and typ_arg_frees (Typ_arg_aux (typ_arg_aux, l)) = + match typ_arg_aux with + | Typ_arg_nexp n -> nexp_frees n + | Typ_arg_typ typ -> typ_frees typ + | Typ_arg_order ord -> order_frees ord + | Typ_arg_effect _ -> assert false + +let ord_identical (Ord_aux (ord1, _)) (Ord_aux (ord2, _)) = + match ord1, ord2 with + | Ord_var kid1, Ord_var kid2 -> Kid.compare kid1 kid2 = 0 + | Ord_inc, Ord_inc -> true + | Ord_dec, Ord_dec -> true + | _, _ -> false + +let rec typ_identical (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) = + match typ1, typ2 with + | Typ_wild, Typ_wild -> true + | Typ_id v1, Typ_id v2 -> Id.compare v1 v2 = 0 + | Typ_var kid1, Typ_var kid2 -> Kid.compare kid1 kid2 = 0 + | Typ_tup typs1, Typ_tup typs2 -> + begin + try List.for_all2 typ_identical typs1 typs2 with + | Invalid_argument _ -> false + end + | Typ_app (f1, args1), Typ_app (f2, args2) -> + begin + try Id.compare f1 f2 = 0 && List.for_all2 typ_arg_identical args1 args2 with + | Invalid_argument _ -> false + end + | _, _ -> false +and typ_arg_identical (Typ_arg_aux (arg1, _)) (Typ_arg_aux (arg2, _)) = + match arg1, arg2 with + | Typ_arg_nexp n1, Typ_arg_nexp n2 -> nexp_identical n1 n2 + | Typ_arg_typ typ1, Typ_arg_typ typ2 -> typ_identical typ1 typ2 + | Typ_arg_order ord1, Typ_arg_order ord2 -> ord_identical ord1 ord2 + | Typ_arg_effect _, Typ_arg_effect _ -> assert false + +type uvar = + | U_nexp of nexp + | U_order of order + | U_effect of effect + | U_typ of typ + +exception Unification_error of l * string;; + +let unify_error l str = raise (Unification_error (l, str)) + +let rec unify_nexps l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_aux2, _) as nexp2) = + typ_debug ("UNIFYING NEXPS " ^ string_of_nexp nexp1 ^ " AND " ^ string_of_nexp nexp2 ^ " FOR GOALS " ^ string_of_list ", " string_of_kid (KidSet.elements goals)); + if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals) + then + begin + if prove env (NC_aux (NC_fixed (nexp1, nexp2), Parse_ast.Unknown)) + then None + else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal") + end + else + match nexp_aux1 with + | Nexp_id v -> unify_error l "Unimplemented Nexp_id in unify nexp" + | Nexp_var kid when KidSet.mem kid goals -> Some (kid, nexp2) + | Nexp_constant c1 -> + begin + match nexp_aux2 with + | Nexp_constant c2 -> if c1 = c2 then None else unify_error l "Constants are not the same" + | _ -> unify_error l "Unification error" + end + | Nexp_sum (n1a, n1b) -> + if KidSet.is_empty (nexp_frees n1b) + then unify_nexps l env goals n1a (nminus nexp2 n1b) + else + if KidSet.is_empty (nexp_frees n1a) + then unify_nexps l env goals n1b (nminus nexp2 n1a) + else unify_error l ("Both sides of Nat expression " ^ string_of_nexp nexp1 + ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2) + | Nexp_minus (n1a, n1b) -> + if KidSet.is_empty (nexp_frees n1b) + then unify_nexps l env goals n1a (nsum nexp2 n1b) + else unify_error l ("Cannot unify minus Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + | Nexp_times (n1a, n1b) -> + if KidSet.is_empty (nexp_frees n1a) + then + begin + match nexp_aux2 with + | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1a, n2a), Parse_ast.Unknown)) -> + unify_nexps l env goals n1b n2b + | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + end + else if KidSet.is_empty (nexp_frees n1b) + then + begin + match nexp_aux2 with + | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_fixed (n1b, n2b), Parse_ast.Unknown)) -> + unify_nexps l env goals n1a n2a + | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + end + else unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + +let string_of_uvar = function + | U_nexp n -> string_of_nexp n + | U_order o -> string_of_order o + | U_effect eff -> string_of_effect eff + | U_typ typ -> string_of_typ typ + +let unify_order l (Ord_aux (ord_aux1, _) as ord1) (Ord_aux (ord_aux2, _) as ord2) = + typ_debug ("UNIFYING ORDERS " ^ string_of_order ord1 ^ " AND " ^ string_of_order ord2); + match ord_aux1, ord_aux2 with + | Ord_var kid, _ -> KBindings.singleton kid (U_order ord2) + | Ord_inc, Ord_inc -> KBindings.empty + | Ord_dec, Ord_dec -> KBindings.empty + | _, _ -> unify_error l (string_of_order ord1 ^ " cannot be unified with " ^ string_of_order ord2) + +let subst_unifiers unifiers typ = + let subst_unifier typ (kid, uvar) = + match uvar with + | U_nexp nexp -> typ_subst_nexp kid (unaux_nexp nexp) typ + | U_order ord -> typ_subst_order kid (unaux_order ord) typ + | U_typ subst -> typ_subst_typ kid (unaux_typ subst) typ + | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier" + in + List.fold_left subst_unifier typ (KBindings.bindings unifiers) + +let subst_args_unifiers unifiers typ_args = + let subst_unifier typ_args (kid, uvar) = + match uvar with + | U_nexp nexp -> List.map (typ_subst_arg_nexp kid (unaux_nexp nexp)) typ_args + | U_order ord -> List.map (typ_subst_arg_order kid (unaux_order ord)) typ_args + | U_typ subst -> List.map (typ_subst_arg_typ kid (unaux_typ subst)) typ_args + | _ -> typ_error Parse_ast.Unknown "Cannot subst unifier" + in + List.fold_left subst_unifier typ_args (KBindings.bindings unifiers) + +let merge_unifiers l kid uvar1 uvar2 = + match uvar1, uvar2 with + | Some (U_nexp n1), Some (U_nexp n2) -> + if nexp_identical n1 n2 then Some (U_nexp n1) + else unify_error l ("Multiple non-identical unifiers for " ^ string_of_kid kid + ^ ": " ^ string_of_nexp n1 ^ " and " ^ string_of_nexp n2) + | Some _, Some _ -> unify_error l "Multiple non-identical non-nexp unifiers" + | None, Some u2 -> Some u2 + | Some u1, None -> Some u1 + | None, None -> None + +let unify l env typ1 typ2 = + typ_print ("Unify " ^ string_of_typ typ1 ^ " with " ^ string_of_typ typ2); + let goals = KidSet.inter (KidSet.diff (typ_frees typ1) (typ_frees typ2)) (typ_frees typ1) in + let rec unify_typ l (Typ_aux (typ1_aux, _) as typ1) (Typ_aux (typ2_aux, _) as typ2) = + typ_debug ("UNIFYING TYPES " ^ string_of_typ typ1 ^ " AND " ^ string_of_typ typ2); + match typ1_aux, typ2_aux with + | Typ_wild, Typ_wild -> KBindings.empty + | Typ_id v1, Typ_id v2 -> + if Id.compare v1 v2 = 0 then KBindings.empty + else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) + | Typ_id v1, Typ_app (f2, []) -> + if Id.compare v1 f2 = 0 then KBindings.empty + else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) + | Typ_app (f1, []), Typ_id v2 -> + if Id.compare f1 v2 = 0 then KBindings.empty + else unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) + | Typ_var kid, _ when KidSet.mem kid goals -> KBindings.singleton kid (U_typ typ2) + | Typ_var kid1, Typ_var kid2 when Kid.compare kid1 kid2 = 0 -> KBindings.empty + | Typ_tup typs1, Typ_tup typs2 -> + begin + try List.fold_left (KBindings.merge (merge_unifiers l)) KBindings.empty (List.map2 (unify_typ l) typs1 typs2) with + | Invalid_argument _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2 + ^ " tuple type is of different length") + end + | Typ_app (f1, args1), Typ_app (f2, args2) when Id.compare f1 f2 = 0 -> + unify_typ_arg_list 0 KBindings.empty [] [] args1 args2 + | _, _ -> unify_error l (string_of_typ typ1 ^ " cannot be unified with " ^ string_of_typ typ2) + + and unify_typ_arg_list unified acc uargs1 uargs2 args1 args2 = + match args1, args2 with + | [], [] when unified = 0 && List.length uargs1 > 0 -> + unify_error l "Could not unify arg lists" (*FIXME improve error *) + | [], [] when unified > 0 && List.length uargs1 > 0 -> unify_typ_arg_list 0 acc [] [] uargs1 uargs2 + | [], [] when List.length uargs1 = 0 -> acc + | (a1 :: a1s), (a2 :: a2s) -> + begin + let unifiers, success = + try unify_typ_args l a1 a2, true with + | Unification_error _ -> KBindings.empty, false + in + let a1s = subst_args_unifiers unifiers a1s in + let a2s = subst_args_unifiers unifiers a2s in + let uargs1 = subst_args_unifiers unifiers uargs1 in + let uargs2 = subst_args_unifiers unifiers uargs2 in + if success + then unify_typ_arg_list (unified + 1) (KBindings.merge (merge_unifiers l) unifiers acc) uargs1 uargs2 a1s a2s + else unify_typ_arg_list unified acc (a1 :: uargs1) (a2 :: uargs2) a1s a2s + end + | _, _ -> unify_error l "Cannot unify type lists of different length" + + and unify_typ_args l (Typ_arg_aux (typ_arg_aux1, _) as typ_arg1) (Typ_arg_aux (typ_arg_aux2, _) as typ_arg2) = + match typ_arg_aux1, typ_arg_aux2 with + | Typ_arg_nexp n1, Typ_arg_nexp n2 -> + begin + match unify_nexps l env goals (nexp_simp n1) (nexp_simp n2) with + | Some (kid, unifier) -> KBindings.singleton kid (U_nexp unifier) + | None -> KBindings.empty + end + | Typ_arg_typ typ1, Typ_arg_typ typ2 -> unify_typ l typ1 typ2 + | Typ_arg_order ord1, Typ_arg_order ord2 -> unify_order l ord1 ord2 + | Typ_arg_effect _, Typ_arg_effect _ -> assert false + | _, _ -> unify_error l (string_of_typ_arg typ_arg1 ^ " cannot be unified with type argument " ^ string_of_typ_arg typ_arg2) + in + let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in + unify_typ l typ1 typ2 + +let merge_uvars l unifiers1 unifiers2 = + try KBindings.merge (merge_unifiers l) unifiers1 unifiers2 + with + | Unification_error (_, m) -> typ_error l ("Could not merge unification variables: " ^ m) + +(**************************************************************************) +(* 5. Type checking expressions *) +(**************************************************************************) + +(* The type checker produces a fully annoted AST - tannot is the type + of these type annotations. *) +type tannot = (Env.t * typ * effect) option + +let infer_lit env (L_aux (lit_aux, l) as lit) = + match lit_aux with + | L_unit -> unit_typ + | L_zero -> bit_typ + | L_one -> bit_typ + | L_num n -> atom_typ (nconstant n) + | L_true -> bool_typ + | L_false -> bool_typ + | L_string _ -> string_typ + | L_real _ -> real_typ + | L_bin str -> + begin + match Env.get_default_order env with + | Ord_aux (Ord_inc, _) -> + dvector_typ env (nconstant 0) (nconstant (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_dec, _) -> + dvector_typ env + (nconstant (String.length str - 1)) + (nconstant (String.length str)) + (mk_typ (Typ_id (mk_id "bit"))) + end + | L_hex str -> + begin + match Env.get_default_order env with + | Ord_aux (Ord_inc, _) -> + dvector_typ env (nconstant 0) (nconstant (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_dec, _) -> + dvector_typ env + (nconstant (String.length str * 4 - 1)) + (nconstant (String.length str * 4)) + (mk_typ (Typ_id (mk_id "bit"))) + end + | L_undef -> typ_error l "Cannot infer the type of undefined" + +let is_nat_kid kid = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | KOpt_aux (KOpt_none kid', _) -> Kid.compare kid kid' = 0 + | _ -> false + +let is_order_kid kid = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | _ -> false + +let is_typ_kid kid = function + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid'), _) -> Kid.compare kid kid' = 0 + | _ -> false + +let rec instantiate_quants quants kid uvar = match quants with + | [] -> [] + | ((QI_aux (QI_id kinded_id, _) as quant) :: quants) -> + typ_debug ("instantiating quant " ^ string_of_quant_item quant); + begin + match uvar with + | U_nexp nexp -> + if is_nat_kid kid kinded_id + then instantiate_quants quants kid uvar + else quant :: instantiate_quants quants kid uvar + | U_order ord -> + if is_order_kid kid kinded_id + then instantiate_quants quants kid uvar + else quant :: instantiate_quants quants kid uvar + | U_typ typ -> + if is_typ_kid kid kinded_id + then instantiate_quants quants kid uvar + else quant :: instantiate_quants quants kid uvar + | _ -> typ_error Parse_ast.Unknown "Cannot instantiate quantifier" + end + | ((QI_aux (QI_const nc, l)) :: quants) -> + begin + match uvar with + | U_nexp nexp -> + QI_aux (QI_const (nc_subst_nexp kid (unaux_nexp nexp) nc), l) :: instantiate_quants quants kid uvar + | _ -> (QI_aux (QI_const nc, l)) :: instantiate_quants quants kid uvar + end + +let destructure_vec_typ l env typ = + let destructure_vec_typ' l = function + | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp n1, _); + Typ_arg_aux (Typ_arg_nexp n2, _); + Typ_arg_aux (Typ_arg_order o, _); + Typ_arg_aux (Typ_arg_typ vtyp, _)] + ), _) when string_of_id id = "vector" -> (n1, n2, o, vtyp) + | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ) + in + destructure_vec_typ' l (Env.expand_synonyms env typ) + + +let env_of_annot (l, tannot) = match tannot with + | Some (env, _, _) -> env + | None -> raise (Reporting_basic.err_unreachable l "no type annotation") + +let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) + +let typ_of_annot (l, tannot) = match tannot with + | Some (_, typ, _) -> typ + | None -> raise (Reporting_basic.err_unreachable l "no type annotation") + +let env_of_annot (l, tannot) = match tannot with + | Some (env, _, _) -> env + | None -> raise (Reporting_basic.err_unreachable l "no type annotation") + +let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot) + +let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot) + +let pat_typ_of (P_aux (_, (l, tannot))) = typ_of_annot (l, tannot) + +(* Flow typing *) + +let destructure_atom (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c, _)), _)]) + when string_of_id f = "atom" -> c + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c1, _)), _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)]) + when string_of_id f = "range" && c1 = c2 -> c1 + | _ -> assert false + +let destructure_atom_nexp (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)]) + when string_of_id f = "atom" -> n + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_nexp _, _)]) + when string_of_id f = "range" -> n + | _ -> assert false + +let restrict_range_upper c1 (Typ_aux (typ_aux, l) as typ) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp, _); Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _)]) + when string_of_id f = "range" -> + range_typ nexp (nconstant (min c1 c2)) + | _ -> typ + +let restrict_range_lower c1 (Typ_aux (typ_aux, l) as typ) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant c2, _)), _); Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id f = "range" -> + range_typ (nconstant (max c1 c2)) nexp + | _ -> typ + +type flow_constraint = + | Flow_lteq of int + | Flow_gteq of int + +let apply_flow_constraint = function + | Flow_lteq c -> (restrict_range_upper c, restrict_range_lower (c + 1)) + | Flow_gteq c -> (restrict_range_lower c, restrict_range_upper (c - 1)) + +let rec infer_flow env (E_aux (exp_aux, (l, _))) = + match exp_aux with + | E_app (f, [x; y]) when string_of_id f = "lteq_atom_atom" -> + let n1 = destructure_atom_nexp (typ_of x) in + let n2 = destructure_atom_nexp (typ_of y) in + [], [nc_lteq n1 n2] + | E_app (f, [x; y]) when string_of_id f = "gteq_atom_atom" -> + let n1 = destructure_atom_nexp (typ_of x) in + let n2 = destructure_atom_nexp (typ_of y) in + [], [nc_gteq n1 n2] + | E_app (f, [x; y]) when string_of_id f = "lt_atom_atom" -> + let n1 = destructure_atom_nexp (typ_of x) in + let n2 = destructure_atom_nexp (typ_of y) in + [], [nc_lt n1 n2] + | E_app (f, [x; y]) when string_of_id f = "gt_atom_atom" -> + let n1 = destructure_atom_nexp (typ_of x) in + let n2 = destructure_atom_nexp (typ_of y) in + [], [nc_gt n1 n2] + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lt_range_atom" -> + let kid = Env.fresh_kid env in + let c = destructure_atom (typ_of y) in + [(v, Flow_lteq (c - 1))], [] + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" -> + let kid = Env.fresh_kid env in + let c = destructure_atom (typ_of y) in + [(v, Flow_lteq c)], [] + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gt_range_atom" -> + let kid = Env.fresh_kid env in + let c = destructure_atom (typ_of y) in + [(v, Flow_gteq (c + 1))], [] + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" -> + let kid = Env.fresh_kid env in + let c = destructure_atom (typ_of y) in + [(v, Flow_gteq c)], [] + | _ -> [], [] + +let rec add_flows b flows env = + match flows with + | [] -> env + | (id, flow) :: flows when b -> add_flows true flows (Env.add_flow id (fst (apply_flow_constraint flow)) env) + | (id, flow) :: flows -> add_flows false flows (Env.add_flow id (snd (apply_flow_constraint flow)) env) + +let rec add_constraints constrs env = + List.fold_left (fun env constr -> Env.add_constraint constr env) env constrs + +(* When doing implicit type coercion, for performance reasons we want + to filter out the possible casts to only those that could + reasonably apply. We don't mind if we try some coercions that are + impossible, but we should be careful to never rule out a possible + cast - match_typ and filter_casts implement this logic. It must be + the case that if two types unify, then they match. *) +let rec match_typ (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) = + match typ1, typ2 with + | Typ_wild, Typ_wild -> true + | _, Typ_var kid2 -> true + | Typ_id v1, Typ_id v2 when Id.compare v1 v2 = 0 -> true + | Typ_id v1, Typ_id v2 when string_of_id v1 = "int" && string_of_id v2 = "nat" -> true + | Typ_tup typs1, Typ_tup typs2 -> List.for_all2 match_typ typs1 typs2 + | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "atom" -> true + | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "atom" -> true + | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" && string_of_id f = "range" -> true + | Typ_id v, Typ_app (f, _) when string_of_id v = "int" && string_of_id f = "range" -> true + | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "range" && string_of_id f2 = "atom" -> true + | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "atom" && string_of_id f2 = "range" -> true + | Typ_app (f1, _), Typ_app (f2, _) when Id.compare f1 f2 = 0 -> true + | Typ_id v1, Typ_app (f2, _) when Id.compare v1 f2 = 0 -> true + | Typ_app (f1, _), Typ_id v2 when Id.compare f1 v2 = 0 -> true + | _, _ -> false + +let rec filter_casts env from_typ to_typ casts = + match casts with + | (cast :: casts) -> + begin + let (quant, cast_typ) = Env.get_val_spec cast env in + match cast_typ with + | Typ_aux (Typ_fn (cast_from_typ, cast_to_typ, _), _) + when match_typ from_typ cast_from_typ && match_typ to_typ cast_to_typ -> + typ_print ("Considering cast " ^ string_of_typ cast_typ ^ " for " ^ string_of_typ from_typ ^ " to " ^ string_of_typ to_typ); + cast :: filter_casts env from_typ to_typ casts + | _ -> filter_casts env from_typ to_typ casts + end + | [] -> [] + +let is_union_id id env = + match Env.lookup_id id env with + | Union (_, _) -> true + | _ -> false + +let crule r env exp typ = + incr depth; + typ_print ("Check " ^ string_of_exp exp ^ " <= " ^ string_of_typ typ); + try + let checked_exp = r env exp typ in + decr depth; checked_exp + with + | Type_error (l, m) -> decr depth; typ_error l m + +let irule r env exp = + incr depth; + try + let inferred_exp = r env exp in + typ_print ("Infer " ^ string_of_exp exp ^ " => " ^ string_of_typ (typ_of inferred_exp)); + decr depth; + inferred_exp + with + | Type_error (l, m) -> decr depth; typ_error l m + +let strip_exp : 'a exp -> unit exp = function exp -> map_exp_annot (fun (l, _) -> (l, ())) exp +let strip_pat : 'a pat -> unit pat = function pat -> map_pat_annot (fun (l, _) -> (l, ())) pat + +let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp = + let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in + let annot_exp exp typ = annot_exp_effect exp typ no_effect in + match (exp_aux, typ_aux) with + | E_block exps, _ -> + begin + let rec check_block l env exps typ = match exps with + | [] -> typ_error l "Empty block found" + | [exp] -> [crule check_exp env exp typ] + | (E_aux (E_assign (lexp, bind), _) :: exps) -> + let texp, env = bind_assignment env lexp bind in + texp :: check_block l env exps typ + | ((E_aux (E_assert (E_aux (E_constraint nc, _), assert_msg), _) as exp) :: exps) -> + typ_print ("Adding constraint " ^ string_of_n_constraint nc ^ " for assert"); + let inferred_exp = irule infer_exp env exp in + inferred_exp :: check_block l (Env.add_constraint nc env) exps typ + | (exp :: exps) -> + let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in + texp :: check_block l env exps typ + in + annot_exp (E_block (check_block l env exps typ)) typ + end + | E_case (exp, cases), _ -> + let inferred_exp = irule infer_exp env exp in + let check_case pat typ = match pat with + | Pat_aux (Pat_exp (pat, case), (l, _)) -> + let tpat, env = bind_pat env pat (typ_of inferred_exp) in + Pat_aux (Pat_exp (tpat, crule check_exp env case typ), (l, None)) + | Pat_aux (Pat_when (pat, guard, case), (l, _)) -> + let tpat, env = bind_pat env pat (typ_of inferred_exp) in + let checked_guard = check_exp env guard bool_typ in + Pat_aux (Pat_when (tpat, checked_guard, crule check_exp env case typ), (l, None)) + in + annot_exp (E_case (inferred_exp, List.map (fun case -> check_case case typ) cases)) typ + | E_let (LB_aux (letbind, (let_loc, _)), exp), _ -> + begin + match letbind with + | LB_val_explicit (typschm, pat, bind) -> assert false + | LB_val_implicit (P_aux (P_typ (ptyp, _), _) as pat, bind) -> + let checked_bind = crule check_exp env bind ptyp in + let tpat, env = bind_pat env pat (typ_of checked_bind) in + annot_exp (E_let (LB_aux (LB_val_implicit (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ + | LB_val_implicit (pat, bind) -> + let inferred_bind = irule infer_exp env bind in + let tpat, env = bind_pat env pat (typ_of inferred_bind) in + annot_exp (E_let (LB_aux (LB_val_implicit (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ + end + | E_app_infix (x, op, y), _ when List.length (Env.get_overloads (deinfix op) env) > 0 -> + check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ + | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_prove") = 0 -> + if prove env nc + then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ + else typ_error l ("Cannot prove " ^ string_of_n_constraint nc) + | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 -> + let rec try_overload = function + | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp) + | (f :: fs) -> begin + typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with + | Type_error (_, m) -> typ_print ("Error : " ^ m); try_overload fs + end + in + try_overload (Env.get_overloads f env) + | E_app (f, xs), _ -> + let inferred_exp = infer_funapp l env f xs (Some typ) in + type_coercion env inferred_exp typ + | E_if (cond, then_branch, else_branch), _ -> + let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in + let flows, constrs = infer_flow env cond' in + let then_branch' = crule check_exp (add_constraints constrs (add_flows true flows env)) then_branch typ in + let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch typ in + annot_exp (E_if (cond', then_branch', else_branch')) typ + | E_exit exp, _ -> + let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in + annot_exp_effect (E_exit checked_exp) typ (mk_effect [BE_escape]) + | E_vector vec, _ -> + begin + let (start, len, ord, vtyp) = destructure_vec_typ l env typ in + let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in + match len with + | Nexp_aux (Nexp_constant lenc, _) -> + if List.length vec = lenc then annot_exp (E_vector checked_items) typ + else typ_error l "List length didn't match" (* FIXME: improve error message *) + | _ -> typ_error l "Cannot check list constant against non-constant length vector type" + end + | E_lit (L_aux (L_undef, _) as lit), _ -> + annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef]) + (* This rule allows registers of type t to be passed by name with type register<t>*) + | E_id reg, Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "register" -> + let rtyp = Env.get_register reg env in + subtyp l env rtyp typ; annot_exp (E_id reg) typ (* CHECK: is this subtyp the correct way around? *) + | E_id id, _ when is_union_id id env -> + begin + match Env.lookup_id id env with + | Union (typq, ctor_typ) -> + let inferred_exp = fst (infer_funapp' l env id (typq, mk_typ (Typ_fn (unit_typ, ctor_typ, no_effect))) [mk_lit L_unit] (Some typ)) in + annot_exp (E_id id) (typ_of inferred_exp) + | _ -> assert false (* Unreachble due to guard *) + end + | _, _ -> + let inferred_exp = irule infer_exp env exp in + type_coercion env inferred_exp typ + +(* type_coercion env exp typ takes a fully annoted (i.e. already type + checked) expression exp, and attempts to cast (coerce) it to the + type typ by inserting a coercion function that transforms the + annotated expression into the correct type. Returns an annoted + expression consisting of a type coercion function applied to exp, + or throws a type error if the coercion cannot be performed. *) +and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ = + let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in + let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in + let rec try_casts m = function + | [] -> typ_error l ("No valid casts:\n" ^ m) + | (cast :: casts) -> begin + typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ); + try + let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in + annot_exp (E_cast (typ, checked_cast)) typ + with + | Type_error (_, m) -> try_casts m casts + end + in + begin + try + typ_debug "PERFORMING TYPE COERCION"; + subtyp l env (typ_of annotated_exp) typ; annotated_exp + with + | Type_error (_, m) when Env.allow_casts env -> + let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in + try_casts "" casts + | Type_error (l, m) -> typ_error l ("Subtype error " ^ m) + end + +(* type_coercion_unify env exp typ attempts to coerce exp to a type + exp_typ in the same way as type_coercion, except it is only + required that exp_typ unifies with typ. Returns the annotated + coercion as with type_coercion and also a set of unifiers, or + throws a unification error *) +and type_coercion_unify env (E_aux (_, (l, _)) as annotated_exp) typ = + let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in + let annot_exp exp typ = E_aux (exp, (l, Some (env, typ, no_effect))) in + let rec try_casts m = function + | [] -> unify_error l ("No valid casts resulted in unification:\n" ^ m) + | (cast :: casts) -> begin + typ_print ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification"); + try + let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in + let ityp = typ_of inferred_cast in + annot_exp (E_cast (ityp, inferred_cast)) ityp, unify l env typ ityp + with + | Type_error (_, m) -> try_casts m casts + | Unification_error (_, m) -> try_casts m casts + end + in + begin + try + typ_debug "PERFORMING COERCING UNIFICATION"; + annotated_exp, unify l env typ (typ_of annotated_exp) + with + | Unification_error (_, m) when Env.allow_casts env -> + let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in + try_casts "" casts + end + +and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) = + typ_print ("Binding " ^ string_of_typ typ); + let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in + let switch_typ (P_aux (pat_aux, (l, Some (env, _, eff)))) typ = P_aux (pat_aux, (l, Some (env, typ, eff))) in + let bind_tuple_pat (tpats, env) pat typ = + let tpat, env = bind_pat env pat typ in tpat :: tpats, env + in + match pat_aux with + | P_id v -> + begin + match Env.lookup_id v env with + | Local (Immutable, _) | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env + | Local (Mutable, _) | Register _ -> + typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) + | Enum enum -> subtyp l env enum typ; annot_pat (P_id v) typ, env + | Union (typq, ctor_typ) -> + begin + try + let _ = unify l env ctor_typ typ in + annot_pat (P_id v) typ, env + with + | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m) + end + end + | P_wild -> annot_pat P_wild typ, env + | P_cons (hd_pat, tl_pat) -> + begin + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]) when Id.compare f (mk_id "list") = 0 -> + let hd_pat, env = bind_pat env hd_pat ltyp in + let tl_pat, env = bind_pat env tl_pat typ in + annot_pat (P_cons (hd_pat, tl_pat)) typ, env + | _ -> typ_error l "Cannot match cons pattern against non-list type" + end + | P_list pats -> + begin + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_typ ltyp, _)]) when Id.compare f (mk_id "list") = 0 -> + let rec process_pats env = function + | [] -> [], env + | (pat :: pats) -> + let pat', env = bind_pat env pat ltyp in + let pats', env = process_pats env pats in + pat' :: pats', env in - let t,cs' = get_abbrev d_env t in - let t_actual = match t.t with | Tabbrev(i,t) -> t | _ -> t in - let cs_o = cs@cs' in - (*let _ = Printf.eprintf "Assigning to %s, t is %s\n" i (t_to_string t_actual) in*) - (match t_actual.t,is_top with - | Tapp("register",[TA_typ u]),true -> - let ef = {effect=Eset[BE_aux(BE_wreg,l)]} in - (LEXP_aux(lexp,(l,(Base(([],t),External (Some i),cs_o,ef,pure_e,nob)))),u,false, - Envmap.empty,External (Some i),[],nob,ef,ef) - | Tapp("register",[TA_typ u]),false -> - (LEXP_aux(lexp,(l,(Base(([],t), Emp_global, cs_o, pure_e,pure_e,nob)))), t,false, - Envmap.empty, Emp_global, [],nob,pure_e,pure_e) - | Tapp("reg",[TA_typ u]),_ -> - (LEXP_aux(lexp,(l,(Base(([],t),Emp_set,cs_o,ef,ef,b)))),u,false,Envmap.empty,Emp_set,[],nob,ef,ef) - | Tapp("vector",_),false -> - (LEXP_aux(lexp,(l,(Base(([],t),tag,cs_o,ef,ef,b)))),t,true,Envmap.empty,Emp_set,[],nob,ef,ef) - | (Tfn _ ,_) -> - (match tag with - | External _ | Spec | Emp_global -> - let u = new_t() in - let t = {t = Tapp("reg",[TA_typ u])} in - let bounds = extract_bounds d_env i t in - let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in - (LEXP_aux(lexp,(l,tannot)),u,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e) - | _ -> - typ_error l ("Cannot assign to " ^ i ^" with type " ^ t_to_string t ^ - ". Assignment must be to registers or non-parameter, non-let-bound local variables.")) - | _,_ -> - if is_top - then - typ_error l ("Cannot assign to " ^ i ^" with type " ^ t_to_string t ^ - ". Assignment must be to registers or non-parameter, non-let-bound local variables.") - else - (LEXP_aux(lexp,(l,constrained_annot t cs_o)),t,true,Envmap.empty,Emp_local,[],nob,pure_e,pure_e)) - | _ -> - let u = new_t() in - let t = {t=Tapp("reg",[TA_typ u])} in - let bounds = extract_bounds d_env i u in - let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,bounds)) in - (LEXP_aux(lexp,(l,tannot)),u,false,Envmap.from_list [i,tannot],Emp_intro,[],bounds,pure_e,pure_e)) - | LEXP_memory(id,exps) -> - let i = id_to_string id in - (match Envmap.apply t_env i with - | Some(Base((parms,t),tag,cs,ef,_,_)) -> - let t,cs,ef,_ = subst parms false false t cs ef in - (match t.t with - | Tfn(apps,out,_,ef') -> - (match ef'.effect with - | Eset effects -> - let mem_write = List.exists (fun (BE_aux(b,_)) -> - match b with | BE_wmem -> true | _ -> false) effects in - let memv_write = List.exists (fun (BE_aux(b,_)) -> - match b with |BE_wmv -> true | _ -> false) effects in - let reg_write = List.exists (fun (BE_aux(b,_)) -> - match b with | BE_wreg -> true | _ -> false) effects in - if (mem_write || memv_write || reg_write) - then - let app,cs_a = get_abbrev d_env apps in - let out,cs_o = get_abbrev d_env out in - let cs_call = cs@cs_o@cs_a in - (match app.t with - | Ttup ts | Tabbrev(_,{t=Ttup ts}) -> - let (args,item_t) = ((fun ts -> (List.rev (List.tl ts), List.hd ts)) (List.rev ts)) in - let args_t = {t = Ttup args} in - let (es, cs_es, ef_es) = - match args,exps with - | [],[] -> ([],[],pure_e) - | [],[e] -> let (e',_,_,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t unit_t e - in ([e'],cs_e,ef_e) - | [],es -> typ_error l ("Expected no arguments for assignment function " ^ i) - | args,[] -> - typ_error l ("Expected arguments with types " ^ (t_to_string args_t) ^ - "for assignment function " ^ i) - | args,es -> - (match check_exp envs imp_param true true ret_t args_t - (E_aux (E_tuple exps,(l,NoTyp))) with - | (E_aux(E_tuple es,(l',tannot)),_,_,cs_e,_,ef_e) -> (es,cs_e,ef_e) - | _ -> - raise (Reporting_basic.err_unreachable l - "Gave check_exp a tuple, didn't get a tuple back")) - in - let ef_all = union_effects ef' ef_es in - (LEXP_aux(LEXP_memory(id,es),(l,Base(([],out),tag,cs_call,ef',ef_all,nob))), - item_t,false,Envmap.empty,tag,cs_call@cs_es,nob,ef',ef_all) - | _ -> - let e = match exps with - | [] -> E_aux(E_lit(L_aux(L_unit,l)),(l,NoTyp)) - | [(E_aux(E_lit(L_aux(L_unit,_)),(_,NoTyp)) as e)] -> e - | es -> typ_error l ("Expected no arguments for assignment function " ^ i) in - let (e,_,_,cs_e,_,ef_e) = check_exp envs imp_param true true ret_t apps e in - let ef_all = union_effects ef ef_e in - (LEXP_aux(LEXP_memory(id,[e]),(l,Base(([],out),tag,cs_call,ef,ef_all,nob))), - app,false,Envmap.empty,tag,cs_call@cs_e,nob,ef,ef_all)) - else typ_error l ("Assignments require functions with a wmem, wmv, or wreg effect") - | _ -> typ_error l ("Assignments require functions with a wmem, wmv, or wreg effect")) - | _ -> - typ_error l ("Assignments require a function here, found " ^ i ^ " which has type " ^ (t_to_string t))) - | _ -> typ_error l ("Unbound identifier " ^ i)) - | LEXP_cast(typ,id) -> - let i = id_to_string id in - let ty = typ_to_t envs false false typ in - let ty = typ_subst tp_env false ty in - let new_bounds = extract_bounds d_env i ty in - (match Envmap.apply t_env i with - | Some(Base((parms,t),tag,cs,_,_,bounds)) -> - let t,cs,ef,_ = - match tag with | External _ | Emp_global -> subst parms false false t cs pure_e - | _ -> t,cs,{effect=Eset[BE_aux(BE_lset,l)]},Envmap.empty + let pats, env = process_pats env pats in + annot_pat (P_list pats) typ, env + | _ -> typ_error l "Cannot match list pattern against non-list type" + end + | P_tup pats -> + begin + match typ_aux with + | Typ_tup typs -> + let tpats, env = + try List.fold_left2 bind_tuple_pat ([], env) pats typs with + | Invalid_argument _ -> typ_error l "Tuple pattern and tuple type have different length" in - let t,cs' = get_abbrev d_env t in - let t_actual = match t.t with | Tabbrev(_,t) -> t | _ -> t in - let bs = merge_bounds bounds new_bounds in - (match t_actual.t,is_top with - | Tapp("register",[TA_typ u]),true -> - let t',cs = type_consistent (Expr l) d_env Require false ty u in - let ef = {effect=Eset[BE_aux(BE_wreg,l)]} in - (LEXP_aux(lexp,(l,(Base(([],t),External (Some i),cs,ef,pure_e,nob)))),ty,false, - Envmap.empty,External (Some i),[],nob,ef,ef) - | Tapp("register",[TA_typ u]),false -> - (LEXP_aux(lexp,(l,(Base(([],t), Emp_global, cs', pure_e,pure_e,nob)))), t,false, - Envmap.empty, Emp_global, [],nob,pure_e,pure_e) - | Tapp("reg",[TA_typ u]),_ -> - let t',cs = type_consistent (Expr l) d_env Require false ty u in - (LEXP_aux(lexp,(l,(Base(([],t),Emp_set,cs,ef,pure_e,bs)))),ty,false, - Envmap.empty,Emp_set,[],bs,ef,ef) - | Tapp("vector",_),false -> - (LEXP_aux(lexp,(l,(Base(([],t),tag,cs,ef,pure_e,bs)))),ty,true,Envmap.empty,Emp_set,[],bs,ef,ef) - | Tuvar _,_ -> - let u' = {t=Tapp("reg",[TA_typ ty])} in - equate_t t u'; - (LEXP_aux(lexp,(l,(Base((([],u'),Emp_set,cs,ef,pure_e,bs))))), - ty,false,Envmap.empty,Emp_set,[],bs,ef,ef) - | (Tfn _ ,_) -> - (match tag with - | External _ | Spec | Emp_global -> - let u' = {t=Tapp("reg",[TA_typ ty])} in - let tannot = (Base(([],u'),Emp_intro,[],pure_e,pure_e,new_bounds)) in - (LEXP_aux(lexp,(l,tannot)),u', - false,Envmap.from_list [i,tannot],Emp_intro,[],new_bounds,pure_e,pure_e) - | _ -> - typ_error l ("Cannot assign to " ^ i ^ " with type " ^ t_to_string t)) - | _,_ -> - if is_top - then typ_error l - ("Cannot assign to " ^ i ^ " with type " ^ t_to_string t ^ - ". May only assign to registers, and non-paremeter, non-let bound local variables") - else - (* TODO, make sure this is a record *) - (LEXP_aux(lexp,(l,(Base(([],t),Emp_local,cs,pure_e,pure_e,nob)))), - ty,false,Envmap.empty,Emp_local,[],nob,pure_e,pure_e)) - | _ -> - let t = {t=Tapp("reg",[TA_typ ty])} in - let tannot = (Base(([],t),Emp_intro,[],pure_e,pure_e,new_bounds)) in - (LEXP_aux(lexp,(l,tannot)),ty,false,Envmap.from_list [i,tannot],Emp_intro,[],new_bounds,pure_e,pure_e)) - | LEXP_tup tuples -> - if is_top - then - if tuples = [] - then typ_error l "Attempt to set an empty tuple, which is not allowed" - else - let tuple_checks = List.map (check_lexp envs imp_param ret_t true) tuples in - let tuple_vs = List.map (fun (le,_,_,_,_,_,_,_,_) -> le) tuple_checks in - let tuple_typs = List.map (fun (_,le_t,_,_,_,_,_,_,_) -> le_t) tuple_checks in - let tuple_tags = List.map (fun (_,_,_,_,tag,_,_,_,_) -> tag) tuple_checks in - let env = List.fold_right (fun (_,_,_,env,_,_,_,_,_) envf -> Envmap.union env envf) - tuple_checks Envmap.empty in - let cs = List.fold_right (fun (_,_,_,_,_,cs,_,_,_) csf -> cs @csf) tuple_checks [] in - let bounds = List.fold_right (fun (_,_,_,_,_,_,bs,_,_) bf -> merge_bounds bs bf) tuple_checks nob in - let efr = List.fold_right (fun (_,_,_,_,_,_,_,_,efr) efrf -> union_effects efr efrf) tuple_checks pure_e in - let ty = mk_tup tuple_typs in - let tag = Tuple_assign tuple_tags in - let tannot = (Base(([],ty),tag,[],pure_e,efr,bounds)) in - (LEXP_aux (LEXP_tup tuple_vs, (l,tannot)), ty,false,env, tag,cs,bounds,pure_e,efr) - else typ_error l "Tuples in assignments may only be at the top level or within other tuples" - | LEXP_vector(vec,acc) -> - let (vec',vec_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in - let vec_t,cs' = get_abbrev d_env vec_t in - let vec_actual,writing_reg_bit = match vec_t.t with - | Tapp("register",[TA_typ {t=Tabbrev(_,t)}]) | Tapp("register",[TA_typ t]) - | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true - | Tabbrev(_,t) -> t,false | _ -> vec_t,false in - (match vec_actual.t with - | Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ item_t]) -> - let acc_n = new_n () in - let acc_t,cs_t = match ord.order with - | Oinc -> mk_atom acc_n, [LtEq(Specc l, Require, base, acc_n); - LtEq(Specc l, Require, acc_n, (mk_sub (mk_add base rise) n_one))] - | Odec -> mk_atom acc_n, [GtEq(Specc l, Require, base, acc_n); - GtEq(Specc l, Require, acc_n, (mk_sub (mk_add base n_one) rise))] - | _ -> typ_error l ("Assignment to one vector element requires a non-polymorphic order") + annot_pat (P_tup (List.rev tpats)) typ, env + | _ -> typ_error l "Cannot bind tuple pattern against non tuple type" + end + | P_app (f, pats) when Env.is_union_constructor f env -> + begin + let (typq, ctor_typ) = Env.get_val_spec f env in + let quants = quant_items typq in + let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with + | Typ_tup typs -> typs + | _ -> [typ] + in + match Env.expand_synonyms env ctor_typ with + | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) -> + begin + try + typ_debug ("Unifying " ^ string_of_bind (typq, ctor_typ) ^ " for pattern " ^ string_of_typ typ); + let unifiers = unify l env ret_typ typ in + typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + let arg_typ' = subst_unifiers unifiers arg_typ in + let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + if (match quants' with [] -> false | _ -> true) + then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat) + else (); + let ret_typ' = subst_unifiers unifiers ret_typ in + let tpats, env = + try List.fold_left2 bind_tuple_pat ([], env) pats (untuple arg_typ') with + | Invalid_argument _ -> typ_error l "Union constructor pattern arguments have incorrect length" + in + annot_pat (P_app (f, List.rev tpats)) typ, env + with + | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m) + end + | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f) + end + | P_app (f, _) when not (Env.is_union_constructor f env) -> + typ_error l (string_of_id f ^ " is not a union constructor in pattern " ^ string_of_pat pat) + | _ -> + let (inferred_pat, env) = infer_pat env pat in + subtyp l env (pat_typ_of inferred_pat) typ; + switch_typ inferred_pat typ, env + +and infer_pat env (P_aux (pat_aux, (l, ())) as pat) = + let annot_pat pat typ = P_aux (pat, (l, Some (env, typ, no_effect))) in + match pat_aux with + | P_id v -> + begin + match Env.lookup_id v env with + | Local (Immutable, _) | Unbound -> + typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation") + | Local (Mutable, _) | Register _ -> + typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat) + | Enum enum -> annot_pat (P_id v) enum, env + end + | P_typ (typ_annot, pat) -> + let (typed_pat, env) = bind_pat env pat typ_annot in + annot_pat (P_typ (typ_annot, typed_pat)) typ_annot, env + | P_lit lit -> + annot_pat (P_lit lit) (infer_lit env lit), env + | P_vector (pat :: pats) -> + let fold_pats (pats, env) pat = + let inferred_pat, env = infer_pat env pat in + pats @ [inferred_pat], env + in + let ((inferred_pat :: inferred_pats) as pats), env = + List.fold_left fold_pats ([], env) (pat :: pats) in + let len = nexp_simp (nconstant (List.length pats)) in + let etyp = pat_typ_of inferred_pat in + List.map (fun pat -> typ_equality l env etyp (pat_typ_of pat)) pats; + annot_pat (P_vector pats) (lvector_typ env len etyp), env + | P_vector_concat (pat :: pats) -> + let fold_pats (pats, env) pat = + let inferred_pat, env = infer_pat env pat in + pats @ [inferred_pat], env + in + let (inferred_pat :: inferred_pats), env = List.fold_left fold_pats ([], env) (pat :: pats) in + let (_, len, _, vtyp) = destructure_vec_typ l env (pat_typ_of inferred_pat) in + let fold_len len pat = + let (_, len', _, vtyp') = destructure_vec_typ l env (pat_typ_of pat) in + typ_equality l env vtyp vtyp'; + nsum len len' + in + let len = nexp_simp (List.fold_left fold_len len inferred_pats) in + annot_pat (P_vector_concat (inferred_pat :: inferred_pats)) (lvector_typ env len vtyp), env + | _ -> typ_error l ("Couldn't infer type of pattern " ^ string_of_pat pat) + +and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) = + let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, Some (env, mk_typ (Typ_id (mk_id "unit")), no_effect))) in + let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in + let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in + let has_typ v env = + match Env.lookup_id v env with + | Local (Mutable, _) | Register _ -> true + | _ -> false + in + match lexp_aux with + | LEXP_field (LEXP_aux (flexp, _), field) -> + begin + let infer_flexp = function + | LEXP_id v -> + begin match Env.lookup_id v env with + | Register typ -> typ, LEXP_id v + | _ -> typ_error l "l-expression field is not a register" + end + | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) -> + begin + (* Check: is this ok if the vector is immutable? *) + let is_immutable, vtyp = match Env.lookup_id v env with + | Unbound -> typ_error l "Cannot assign to element of unbound vector" + | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Local (Immutable, vtyp) -> true, vtyp + | Local (Mutable, vtyp) | Register vtyp -> false, vtyp + in + let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in + let E_aux (E_app (_, [_; inferred_exp]), _) = access in + typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp) + end + in + let regtyp, inferred_flexp = infer_flexp flexp in + typ_debug ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp)); + match Env.expand_synonyms env regtyp with + | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> + let base, top, ranges = Env.get_regtyp regtyp_id env in + let range, _ = + try List.find (fun (_, id) -> Id.compare id field = 0) ranges with + | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp_id) in - let (e,acc_t',_,cs',_,ef_e) = check_exp envs imp_param false false ret_t acc_t acc in - let item_t_act,_ = get_abbrev d_env item_t in - let item_t,add_reg_write,reg_still_required = - match item_t_act.t with - | Tapp("register",[TA_typ t]) | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true,false - | Tapp("reg",[TA_typ t]) -> t,false,false - | _ -> item_t,false,not(writing_reg_bit) in - let efl,tag = if add_reg_write || writing_reg_bit then (add_effect (BE_aux(BE_wreg,l)) efl,External None) - else match tag with | External _ -> (efl,Emp_local) | _ -> (efl,tag) in - let efr = union_effects efl (union_effects efr ef_e) in - if is_top && reg_still_required && reg_required && not(writing_reg_bit) - then typ_error l "Assignment expected a register or non-parameter non-letbound identifier to mutate" - else - (LEXP_aux(LEXP_vector(vec',e),(l,Base(([],item_t_act),tag,csi,efl,efr,nob))), - item_t_act,reg_required && reg_still_required, - env,tag,csi@cs'@cs_t,bounds,efl,efr) - | Tuvar _ -> - typ_error l "Assignment expected a vector with a known order, try adding an annotation." - | _ -> typ_error l ("Assignment expected vector, found assignment to type " ^ (t_to_string vec_t))) - | LEXP_vector_range(vec,e1,e2)-> - let (vec',vec_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in - let vec_t,cs = get_abbrev d_env vec_t in - let vec_actual,writing_reg_bits = match vec_t.t with - | Tapp("register",[TA_typ {t=Tabbrev(_,t)}]) | Tapp("register",[TA_typ t]) - | Tabbrev(_,{t=Tapp("register",[TA_typ t])}) -> t,true - | Tabbrev(_,t) -> t,false | _ -> vec_t,false in - let vec_actual,add_reg_write,reg_still_required,cs = - match vec_actual.t,is_top with - | Tapp("register",[TA_typ t]),true -> - (match get_abbrev d_env t with | {t=Tabbrev(_,t)},cs' | t,cs' -> t,true,false,cs@cs') - | Tapp("register",[TA_typ t]),false -> vec_actual,false,false,cs - | Tapp("reg",[TA_typ t]),_ -> - (match get_abbrev d_env t with | {t=Tabbrev(_,t)},cs' | t,cs' -> t,false,false,cs@cs') - | _ -> vec_actual,false,true,cs in - (match vec_actual.t with - | Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ t]) - | Tapp("register", [TA_typ {t= Tapp("vector",[TA_nexp base;TA_nexp rise;TA_ord ord;TA_typ t])}]) -> - let size_e1,size_e2 = new_n(),new_n() in - let e1_t = {t=Tapp("atom",[TA_nexp size_e1])} in - let e2_t = {t=Tapp("atom",[TA_nexp size_e2])} in - let (e1',e1_t',_,cs1,_,ef_e) = check_exp envs imp_param false false ret_t e1_t e1 in - let (e2',e2_t',_,cs2,_,ef_e') = check_exp envs imp_param false false ret_t e2_t e2 in - let len = new_n() in - let needs_reg = match t.t with - | Tapp("reg",_) -> false - | Tapp("register",_) -> false - | _ -> true in - let cs_t,res_t = match ord.order with - | Oinc -> ([LtEq((Expr l),Require,base,size_e1); - LtEq((Expr l),Require,size_e1, size_e2); - LtEq((Expr l),Require,size_e2, rise); - Eq((Expr l),len, mk_add (mk_sub size_e2 size_e1) n_one)], - if is_top - then {t=Tapp("vector",[TA_nexp size_e1;TA_nexp len;TA_ord ord;TA_typ t])} - else vec_actual) - | Odec -> ([GtEq((Expr l),Require,base,size_e1); - GtEq((Expr l),Require,size_e1,size_e2); - GtEq((Expr l),Require,size_e2,mk_sub base rise); - Eq((Expr l),len, mk_add (mk_sub size_e1 size_e2) n_one)], - if is_top - then {t=Tapp("vector",[TA_nexp size_e1;TA_nexp len;TA_ord ord; TA_typ t])} - else vec_actual) - | _ -> typ_error l ("Assignment to a range of vector elements requires either inc or dec order") + let vec_typ = match range, Env.get_default_order env with + | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> + dvector_typ env (nconstant n) (nconstant 1) (mk_typ (Typ_id (mk_id "bit"))) + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> + dvector_typ env (nconstant n) (nconstant (n - m + 1)) (mk_typ (Typ_id (mk_id "bit"))) + | _, _ -> typ_error l "Not implemented this register field type yet..." in - let efl,tag = - if add_reg_write || writing_reg_bits - then (add_effect (BE_aux(BE_wreg,l)) efl,External None) - else match tag with | External _ -> (efl,Emp_local) | _ -> (efl,tag) in - let cs = cs_t@cs@cs1@cs2 in - let ef = union_effects efl (union_effects efr (union_effects ef_e ef_e')) in - if is_top && reg_required && reg_still_required && needs_reg && not(writing_reg_bits) - then typ_error l "Assignment requires a register or a non-parameter, non-letbound local identifier" - else (LEXP_aux(LEXP_vector_range(vec',e1',e2'),(l,Base(([],res_t),tag,cs,efl,ef,nob))), - res_t,reg_required&®_still_required && needs_reg,env,tag,cs,bounds,efl,ef) - | Tuvar _ -> - typ_error l - "Assignement to a range of items requires a vector with a known order, try adding an annotation." - | _ -> typ_error l ("Assignment expected vector, found assignment to type " ^ (t_to_string vec_t))) - | LEXP_field(vec,id)-> - let (vec',item_t,reg_required,env,tag,csi,bounds,efl,efr) = check_lexp envs imp_param ret_t false vec in - let vec_t = match vec' with - | LEXP_aux(_,(l',Base((parms,t),_,_,_,_,_))) -> t - | _ -> item_t in - let fi = id_to_string id in - (match vec_t.t with - | Tid i | Tabbrev({t=Tid i},_) | Tabbrev({t=Tapp(i,_)},_) | Tapp(i,_)-> - (match lookup_record_typ i d_env.rec_env with - | Some(((i,rec_kind,(Base((params,t),tag,cs,eft,_,bounds)),fields) as r)) -> - let (ts,cs,eft,subst_env) = subst params false false t cs eft in - (match lookup_field_type fi r with - | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi) - | Some t -> - let eft = if rec_kind = Register then add_effect (BE_aux(BE_wreg, l)) eft else eft in - let efr = union_effects eft efr in - let ft = typ_subst subst_env false t in - let (_,cs_sub') = type_consistent (Expr l) d_env Guarantee false ts vec_t in - (LEXP_aux(LEXP_field(vec',id),(l,(Base(([],ft),tag,csi@cs,eft,efr,nob)))), - ft,false,env,tag,csi@cs@cs_sub',bounds,eft,efr)) - | _ -> - typ_error l - ("Expected a register or struct for this update, instead found an expression with type " ^ i)) - | _ -> typ_error l ("Expected a register binding here, found " ^ (t_to_string item_t))) - -and check_lbind envs imp_param is_top_level opt_ret_t emp_tag (LB_aux(lbind,(l,annot))) - : tannot letbind * tannot emap * nexp_range list * bounds_env * effect = - let Env(d_env,t_env,b_env,tp_env) = envs in - match lbind with - | LB_val_explicit(typ,pat,e) -> - let tan = typschm_to_tannot envs false false typ emp_tag in - (match tan with - | Base((params,t),tag,cs,ef,_,b) -> - let t,cs,ef,tp_env' = subst params false true t cs ef in - let envs' = (Env(d_env,t_env,b_env,Envmap.union tp_env tp_env')) in - let (pat',env,cs1,bounds,u) = check_pattern envs' emp_tag t pat in - let ret_t = match opt_ret_t with Some t -> t | None -> t in - let (e,t,_,cs2,_,ef2) = check_exp envs' imp_param true true ret_t t e in - let (cs,map) = if is_top_level then resolve_constraints (cs@cs1@cs2) else (cs@cs1@cs2,None) in - let ef = union_effects ef ef2 in - (*let _ = Printf.eprintf "checking tannot in let1\n" in*) - let tannot = - if is_top_level - then check_tannot l (Base((params,t),tag,cs,ef,pure_e, - match map with | None -> bounds | Some m -> add_map_to_bounds m bounds)) - None cs ef (*in top level, must be pure_e*) - else (Base ((params,t),tag,cs,pure_e,ef,bounds)) - in - (*let _ = Printf.eprintf "done checking tannot in let1\n" in*) - (LB_aux (LB_val_explicit(typ,pat',e),(l,tannot)),env,cs,merge_bounds b_env bounds,ef) - | NoTyp | Overload _ -> raise (Reporting_basic.err_unreachable l "typschm_to_tannot failed to produce a Base")) - | LB_val_implicit(pat,e) -> - let (pat',env,cs1,bounds,u) = check_pattern envs emp_tag (new_t ()) pat in - let ret_t = match opt_ret_t with Some t -> t | None -> u in - let (e,t',_,cs2,_,ef) = check_exp envs imp_param true true ret_t u e in - let (cs,map) = if is_top_level then resolve_constraints (cs1@cs2) else (cs1@cs2),None in - (*let _ = Printf.eprintf "checking tannot in let2\n" in*) - let tannot = - if is_top_level - then check_tannot l (Base(([],t'),emp_tag,cs,ef,pure_e, - match map with | None -> bounds | Some m -> add_map_to_bounds m bounds)) - None cs ef (* see above *) - else (Base (([],t'),emp_tag,cs,pure_e,ef,merge_bounds bounds b_env)) - in - (*let _ = Printf.eprintf "done checking tannot in let2\n" in*) - (LB_aux (LB_val_implicit(pat',e),(l,tannot)), env,cs,merge_bounds bounds b_env,ef) - -let check_record_typ envs (id: string) (typq : typquant) (fields : (Ast.typ * id) list) - : (tannot * (string * typ) list) = - let (params,typarms,constraints) = typq_to_params envs typq in - let ty = match typarms with | [] -> {t = Tid id} | parms -> {t = Tapp(id,parms)} in - let tyannot = Base((params,ty),Emp_global,constraints,pure_e,pure_e,nob) in - let fields' = List.map (fun (ty,i)->(id_to_string i),(typ_to_t envs false false ty)) fields in - (tyannot, fields') - -let check_variant_typ envs (id: string) typq arms = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - let (params,typarms,constraints) = typq_to_params envs typq in - let num_arms = List.length arms in - let ty = match params with - | [] -> {t=Tid id} - | params -> {t = Tapp(id, typarms) }in - let tyannot = Base((params,ty),Constructor num_arms,constraints,pure_e,pure_e,nob) in - let arm_t input = Base((params,{t=Tfn(input,ty,IP_none,pure_e)}),Constructor num_arms,constraints,pure_e,pure_e,nob) in - let arms' = List.map - (fun (Tu_aux(tu,l')) -> - match tu with - | Tu_id i -> ((id_to_string i),(arm_t unit_t)) - | Tu_ty_id(typ,i)-> ((id_to_string i),(arm_t (typ_to_t envs false false typ)))) - arms in - let t_env = List.fold_right (fun (id,tann) t_env -> Envmap.insert t_env (id,tann)) arms' t_env in - tyannot, t_env - -let check_enum_type envs (id: string) ids = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - let ids' = List.map id_to_string ids in - let max = (List.length ids') -1 in - let ty = Base (([],{t = Tid id }),Enum max,[],pure_e,pure_e,nob) in - let t_env = List.fold_right (fun id t_env -> Envmap.insert t_env (id,ty)) ids' t_env in - let enum_env = Envmap.insert d_env.enum_env (id,ids') in - ty, t_env, enum_env - -let check_register_type envs l (id: string) base top ranges = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - let basei = normalize_nexp(anexp_to_nexp envs base) in - let topi = normalize_nexp(anexp_to_nexp envs top) in - match basei.nexp,topi.nexp with - | Nconst b, Nconst t -> - if (le_big_int b t) then ( - let ty = {t = Tapp("vector",[TA_nexp basei; TA_nexp (mk_c(add_big_int (sub_big_int t b) (big_int_of_int 1))); - TA_ord({order = Oinc}); TA_typ({t = Tid "bit"});])} in - let rec range_to_type_inc (BF_aux(idx,l)) = - (match idx with - | BF_single i -> - if (le_big_int b (big_int_of_int i)) && (le_big_int (big_int_of_int i) t) - then {t = Tid "bit"}, i, 1 - else typ_error l - ("register type declaration " ^ id ^ - " contains a field specification outside of the declared register size") - | BF_range(i1,i2) -> - if i1<i2 - then - if (le_big_int b (big_int_of_int i1)) && (le_big_int (big_int_of_int i2) t) - then let size = i2 - i1 + 1 in - ({t=Tapp("vector",[TA_nexp (mk_c_int i1); TA_nexp (mk_c_int size); - TA_ord({order=Oinc}); TA_typ {t=Tid "bit"}])}, i1, size) - else typ_error l ("register type declaration " ^ id - ^ " contains a field specification outside of the declared register size") - else typ_error l ("register type declaration " ^ id ^ " is not consistently increasing") - | BF_concat(bf1, bf2) -> - (match (range_to_type_inc bf1, range_to_type_inc bf2) with - | ({t = Tid "bit"}, start, size1),({t= Tid "bit"}, start2, size2) - | (({t = Tid "bit"}, start, size1), ({t= Tapp("vector", _)}, start2, size2)) - | (({t=Tapp("vector", _)}, start, size1), ({t=Tid "bit"}, start2, size2)) - | (({t=Tapp("vector",_)}, start, size1), ({t=Tapp("vector",_)}, start2, size2)) -> - if start < start2 - then let size = size1 + size2 in - ({t=Tapp("vector", [TA_nexp (mk_c_int start); TA_nexp (mk_c_int size); - TA_ord({order = Oinc}); TA_typ {t=Tid"bit"}])}, start, size) - else typ_error l ("register type declaration " ^ id ^ " is not consistently increasing") - | _ -> raise (Reporting_basic.err_unreachable l "range_to_type returned something odd"))) - in - let franges = - List.map - (fun (bf,id) -> - let (bf_t, _, _) = range_to_type_inc bf in ((id_to_string id),bf_t)) - ranges - in - let tannot = into_register d_env (Base(([],ty),External None,[],pure_e,pure_e,nob)) in - tannot, franges) - else ( - let ty = {t = Tapp("vector",[TA_nexp basei; TA_nexp (mk_c(add_big_int (sub_big_int b t) one)); - TA_ord({order = Odec}); TA_typ({t = Tid "bit"});])} in - let rec range_to_type_dec (BF_aux(idx,l)) = - (match idx with - | BF_single i -> - if (ge_big_int b (big_int_of_int i)) && (ge_big_int (big_int_of_int i) t) - then {t = Tid "bit"}, i, 1 - else typ_error l - ("register type declaration " ^ id ^ - " contains a field specification outside of the declared register size") - | BF_range(i1,i2) -> - if i1>i2 - then - if (ge_big_int b (big_int_of_int i1)) && (ge_big_int (big_int_of_int i2) t) - then let size = (i1 - i2) + 1 in - ({t=Tapp("vector",[TA_nexp (mk_c_int i1); TA_nexp (mk_c_int size); - TA_ord({order=Odec}); TA_typ {t=Tid "bit"}])}, i1, size) - else typ_error l ("register type declaration " ^ id - ^ " contains a field specification outside of the declared register size") - else typ_error l ("register type declaration " ^ id ^ " is not consistently decreasing") - | BF_concat(bf1, bf2) -> - (match (range_to_type_dec bf1, range_to_type_dec bf2) with - | ({t = Tid "bit"}, start, size1),({t= Tid "bit"}, start2, size2) - | (({t = Tid "bit"}, start, size1), ({t= Tapp("vector", _)}, start2, size2)) - | (({t=Tapp("vector", _)}, start, size1), ({t=Tid "bit"}, start2, size2)) - | (({t=Tapp("vector",_)}, start, size1), ({t=Tapp("vector",_)}, start2, size2)) -> - if start > start2 - then let size = size1 + size2 in - ({t=Tapp("vector", [TA_nexp (mk_c_int start); TA_nexp (mk_c_int size); - TA_ord({order = Oinc}); TA_typ {t=Tid"bit"}])}, start, size) - else typ_error l ("register type declaration " ^ id ^ " is not consistently decreasing") - | _ -> raise (Reporting_basic.err_unreachable l "range_to_type has returned something odd"))) - in - let franges = - List.map - (fun (bf,id) -> let (bf_t, _, _) = range_to_type_dec bf in (id_to_string id, bf_t)) - ranges - in - let tannot = into_register d_env (Base(([],ty),External None,[],pure_e,pure_e,nob)) in - tannot, franges) - | _,_ -> raise (Reporting_basic.err_unreachable l "Nexps in register declaration do not evaluate to constants") - -(*val check_type_def : envs -> (tannot type_def) -> (tannot type_def) envs_out*) -let check_type_def envs (TD_aux(td,(l,annot))) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match td with - | TD_abbrev(id,nmscm,typschm) -> - let tan = typschm_to_tannot envs false false typschm Emp_global in - (TD_aux(td,(l,tan)), - Env( { d_env with abbrevs = Envmap.insert d_env.abbrevs ((id_to_string id),tan)},t_env,b_env,tp_env)) - | TD_record(id,nmscm,typq,fields,_) -> - let id' = id_to_string id in - let (tyannot, fields') = check_record_typ envs id' typq fields in - (TD_aux(td,(l,tyannot)), - Env({d_env with rec_env = (id',Record,tyannot,fields')::d_env.rec_env},t_env,b_env,tp_env)) - | TD_variant(id,nmscm,typq,arms,_) -> - let id' = id_to_string id in - let tyannot, t_env = check_variant_typ envs id' typq arms in - (TD_aux(td,(l,tyannot)),(Env (d_env,t_env,b_env,tp_env))) - | TD_enum(id,nmscm,ids,_) -> - let id' = id_to_string id in - let ty,t_env,enum_env = check_enum_type envs id' ids in - (TD_aux(td,(l,ty)),Env({d_env with enum_env = enum_env;},t_env,b_env,tp_env)) - | TD_register(id,base,top,ranges) -> - let id' = id_to_string id in - let (tannot, franges) = check_register_type envs l id' base top ranges in - (TD_aux(td,(l,tannot)), - Env({d_env with rec_env = ((id',Register,tannot,franges)::d_env.rec_env); - abbrevs = Envmap.insert d_env.abbrevs (id',tannot)},t_env,b_env,tp_env)) - -(*val check_kind_def : envs -> (tannot kind_def) -> (tannot kind_def) envs_out*) -let check_kind_def envs (KD_aux(kd,(l,annot))) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match kd with - | KD_nabbrev(kind,id,nmscm,n) -> - let id' = id_to_string id in - let n = normalize_nexp (anexp_to_nexp envs n) in - (KD_aux(kd,(l,annot)), - Env( { d_env with nabbrevs = Envmap.insert d_env.nabbrevs (id', (mk_nid id' n))},t_env,b_env,tp_env)) - | KD_abbrev(kind,id,nmscm,typschm) -> - let tan = typschm_to_tannot envs false false typschm Emp_global in - (KD_aux(kd,(l,tan)), - Env( { d_env with abbrevs = Envmap.insert d_env.abbrevs ((id_to_string id),tan)},t_env,b_env,tp_env)) - | KD_record(kind,id,nmscm,typq,fields,_) -> - let id' = id_to_string id in - let (tyannot, fields') = check_record_typ envs id' typq fields in - (KD_aux(kd,(l,tyannot)),Env({d_env with rec_env = (id',Record,tyannot,fields')::d_env.rec_env},t_env,b_env,tp_env)) - | KD_variant(kind,id,nmscm,typq,arms,_) -> - let id' = id_to_string id in - let tyannot, t_env = check_variant_typ envs id' typq arms in - (KD_aux(kd,(l,tyannot)),(Env (d_env,t_env,b_env,tp_env))) - | KD_enum(kind,id,nmscm,ids,_) -> - let id' = id_to_string id in - let ty,t_env,enum_env = check_enum_type envs id' ids in - (KD_aux(kd,(l,ty)),Env({d_env with enum_env = enum_env;},t_env,b_env,tp_env)) - | KD_register(kind,id,base,top,ranges) -> - let id' = id_to_string id in - let (tannot, franges) = check_register_type envs l id' base top ranges in - (KD_aux(kd,(l,tannot)), - Env({d_env with rec_env = ((id',Register,tannot,franges)::d_env.rec_env); - abbrevs = Envmap.insert d_env.abbrevs (id',tannot)},t_env,b_env,tp_env)) - -let check_val_spec envs (VS_aux(vs,(l,annot))) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match vs with - | VS_val_spec(typs,id) -> - let tannot = typschm_to_tannot envs true true typs Spec in - (VS_aux(vs,(l,tannot)), - (*Should maybe add to bounds here*) - Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env)) - | VS_extern_no_rename(typs,id) -> - let tannot = typschm_to_tannot envs true true typs (External None) in - (VS_aux(vs,(l,tannot)), - Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env)) - | VS_extern_spec(typs,id,s) -> - let tannot = typschm_to_tannot envs true true typs (External (Some s)) in - (VS_aux(vs,(l,tannot)), - Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)), b_env,tp_env)) - -let check_default envs (DT_aux(ds,l)) = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - match ds with - | DT_kind _ -> ((DT_aux(ds,l)),envs) - | DT_order ord -> (DT_aux(ds,l), Env({d_env with default_o = (aorder_to_ord ord)},t_env,b_env,tp_env)) - | DT_typ(typs,id) -> - let tannot = typschm_to_tannot envs false false typs Default in - (DT_aux(ds,l), - Env(d_env,(Envmap.insert t_env (id_to_string id,tannot)),b_env,tp_env)) - -let check_fundef envs (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,annot))) = - (*let _ = Printf.eprintf "checking fundef\n" in*) - let Env(d_env,t_env,b_env,tp_env) = envs in - let _ = reset_fresh () in - let is_rec = match recopt with - | Rec_aux(Rec_nonrec,_) -> false - | Rec_aux(Rec_rec,_) -> true in - let id = match (List.fold_right - (fun (FCL_aux((FCL_Funcl(id,pat,exp)),(l,annot))) id' -> - match id' with - | Some(id') -> if id' = id_to_string id then Some(id') - else typ_error l ("Function declaration expects all definitions to have the same name, " - ^ id_to_string id ^ " differs from other definitions of " ^ id') - | None -> Some(id_to_string id)) funcls None) with - | Some id -> id - | None -> raise (Reporting_basic.err_unreachable l "funcl list might be empty") in - let in_env = Envmap.apply t_env id in - let (typ_params,has_spec) = match in_env with - | Some(Base( (params,u),Spec,constraints,eft,_,_)) -> params,true - | _ -> [],false in - let ret_t,param_t,tannot,t_param_env = match tannotopt with - | Typ_annot_opt_aux(Typ_annot_opt_some(typq,typ),l') -> - let (ids,_,constraints) = typq_to_params envs typq in - let t = typ_to_t envs false false typ in - (*TODO add check that ids == typ_params when has_spec*) - let t,constraints,_,t_param_env = - subst (if has_spec then typ_params else ids) true true t constraints pure_e in - let p_t = new_t () in - let ef = new_e () in - t,p_t,Base((ids,{t=Tfn(p_t,t,IP_none,ef)}),Emp_global,constraints,ef,pure_e,nob),t_param_env in - let cond_kind = if (List.length funcls) = 1 then Solo else Switch in - let check t_env tp_env imp_param = - List.split - (List.map (fun (FCL_aux((FCL_Funcl(id,pat,exp)),(l,_))) -> - (*let _ = Printf.eprintf "checking function %s : %s -> %s\n" - (id_to_string id) (t_to_string param_t) (t_to_string ret_t) in*) - let (pat',t_env',cs_p,b_env',t') = check_pattern (Env(d_env,t_env,b_env,tp_env)) Emp_local param_t pat in - let _, _ = type_consistent (Patt l) d_env Require false param_t t' in - let exp',_,_,cs_e,_,ef = - check_exp (Env(d_env,Envmap.union_merge (tannot_merge (Expr l) d_env true) t_env t_env', - merge_bounds b_env b_env',tp_env)) imp_param true true ret_t ret_t exp in - (*let _ = Printf.eprintf "checked function %s : %s -> %s\n" - (id_to_string id) (t_to_string param_t) (t_to_string ret_t) in - let _ = Printf.eprintf "constraints were pattern: %s\n expression: %s\n" - (constraints_to_string cs_p) (constraints_to_string cs_e) in*) - let cs = CondCons(Fun l,cond_kind,None,cs_p,cs_e) in - (FCL_aux((FCL_Funcl(id,pat',exp')),(l,(Base(([],ret_t),Emp_global,[cs],ef,pure_e,nob)))),(cs,ef))) funcls) in - let check_pattern_after_constraints (FCL_aux ((FCL_Funcl (_, pat, _)), _)) = - check_pattern_after_constraint_res (Env(d_env,t_env,b_env,tp_env)) false param_t pat in - let update_pattern var (FCL_aux ((FCL_Funcl(id,(P_aux(pat,t)),exp)),annot)) = - let pat' = match pat with - | P_lit (L_aux (L_unit,l')) -> P_aux(P_id (Id_aux (Id var, l')), t) - | P_tup pats -> P_aux(P_tup ((P_aux (P_id (Id_aux (Id var, l)), t))::pats), t) - | _ -> P_aux(P_tup [(P_aux (P_id (Id_aux (Id var,l)), t));(P_aux(pat,t))], t) - in (FCL_aux ((FCL_Funcl(id,pat',exp)),annot)) + let checked_exp = crule check_exp env exp vec_typ in + annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp (mk_effect [BE_wreg]), field)) vec_typ) checked_exp, env + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor field env in + let unifiers = try unify l env rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let field_typ' = subst_unifiers unifiers field_typ in + let checked_exp = crule check_exp env exp field_typ' in + annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp (mk_effect [BE_wreg]), field)) field_typ') checked_exp, env + | _ -> typ_error l "Field l-expression has invalid type" + end + | LEXP_memory (f, xs) -> + check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env + | LEXP_cast (typ_annot, v) -> + let checked_exp = crule check_exp env exp typ_annot in + let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in + annot_assign tlexp checked_exp, env' + | LEXP_id v when has_typ v env -> + begin match Env.lookup_id v env with + | Local (Mutable, vtyp) | Register vtyp -> + let checked_exp = crule check_exp env exp vtyp in + let tlexp, env' = bind_lexp env lexp (typ_of checked_exp) in + annot_assign tlexp checked_exp, env' + | _ -> assert false + end + | _ -> + let inferred_exp = irule infer_exp env exp in + let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in + annot_assign tlexp inferred_exp, env' + +and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ = + let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some (env, typ, eff))) in + let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in + match lexp_aux with + | LEXP_id v -> + begin match Env.lookup_id v env with + | Local (Immutable, _) | Enum _ -> + typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, env + | Register vtyp -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ (mk_effect [BE_wreg]), env + | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env + end + | LEXP_cast (typ_annot, v) -> + begin + match Env.lookup_id v env with + | Local (Immutable, _) | Enum _ -> + typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v) + | Local (Mutable, vtyp) -> + begin + subtyp l env typ typ_annot; + subtyp l env typ_annot vtyp; + annot_lexp (LEXP_cast (typ_annot, v)) typ, env + end + | Register vtyp -> + begin + subtyp l env typ typ_annot; + subtyp l env typ_annot vtyp; + annot_lexp_effect (LEXP_cast (typ_annot, v)) typ (mk_effect [BE_wreg]), env + end + | Unbound -> + begin + subtyp l env typ typ_annot; + annot_lexp (LEXP_cast (typ_annot, v)) typ, Env.add_local v (Mutable, typ_annot) env + end + end + | LEXP_tup lexps -> + begin + let (Typ_aux (typ_aux, _)) = typ in + match typ_aux with + | Typ_tup typs -> + let bind_tuple_lexp (tlexps, env) lexp typ = + let tlexp, env = bind_lexp env lexp typ in tlexp :: tlexps, env + in + let tlexps, env = + try List.fold_left2 bind_tuple_lexp ([], env) lexps typs with + | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length" + in + annot_lexp (LEXP_tup tlexps) typ, env + | _ -> typ_error l "Cannot bind tuple l-expression against non tuple type" + end + | LEXP_vector_range (LEXP_aux (LEXP_id v, _), exp1, exp2) -> + begin + let is_immutable, is_register, vtyp = match Env.lookup_id v env with + | Unbound -> typ_error l "Cannot assign to element of unbound vector" + | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Local (Immutable, vtyp) -> true, false, vtyp + | Local (Mutable, vtyp) -> false, false, vtyp + | Register vtyp -> false, true, vtyp + in + let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_subrange", [E_aux (E_id v, (l, ())); exp1; exp2]), (l, ()))) in + let E_aux (E_app (_, [_; inferred_exp1; inferred_exp2]), _) = access in + match typ_of access with + | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> + subtyp l env typ deref_typ; + annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env + | _ when not is_immutable && is_register -> + subtyp l env typ (typ_of access); + annot_lexp (LEXP_vector_range (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp1, inferred_exp2)) typ, env + | _ when not is_immutable -> + subtyp l env typ (typ_of access); + annot_lexp (LEXP_vector_range (annot_lexp (LEXP_id v) vtyp, inferred_exp1, inferred_exp2)) typ, env + | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp) + end + (* Not sure about this case... can the left lexp be anything other than an identifier? *) + | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) -> + begin + let is_immutable, vtyp = match Env.lookup_id v env with + | Unbound -> typ_error l "Cannot assign to element of unbound vector" + | Enum _ -> typ_error l "Cannot vector assign to enumeration element" + | Local (Immutable, vtyp) -> true, vtyp + | Local (Mutable, vtyp) | Register vtyp -> false, vtyp + in + let access = infer_exp (Env.enable_casts env) (E_aux (E_app (mk_id "vector_access", [E_aux (E_id v, (l, ())); exp]), (l, ()))) in + let E_aux (E_app (_, [_; inferred_exp]), _) = access in + match typ_of access with + | Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_typ deref_typ, _)]), _) when string_of_id id = "register" -> + subtyp l env typ deref_typ; + annot_lexp (LEXP_vector (annot_lexp_effect (LEXP_id v) vtyp (mk_effect [BE_wreg]), inferred_exp)) typ, env + | _ when not is_immutable -> + subtyp l env typ (typ_of access); + annot_lexp (LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp)) typ, env + | _ -> typ_error l ("Bad vector assignment: " ^ string_of_lexp lexp) + end + | _ -> typ_error l ("Unhandled l-expression") + +and infer_exp env (E_aux (exp_aux, (l, ())) as exp) = + let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in + let annot_exp exp typ = annot_exp_effect exp typ no_effect in + match exp_aux with + | E_nondet exps -> + annot_exp (E_nondet (List.map (fun exp -> crule check_exp env exp unit_typ) exps)) unit_typ + | E_id v -> + begin + match Env.lookup_id v env with + | Local (_, typ) | Enum typ -> annot_exp (E_id v) typ + | Register typ -> annot_exp_effect (E_id v) typ (mk_effect [BE_rreg]) + | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound") + | Union (typq, typ) -> + if quant_items typq = [] + then annot_exp (E_id v) typ + else typ_error l ("Cannot infer the type of polymorphic union indentifier " ^ string_of_id v) + end + | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit) + | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (Typ_arg_nexp nexp)]))) + | E_constraint nc -> + annot_exp (E_constraint nc) bool_typ + | E_return exp -> + begin + match Env.get_ret_typ env with + | Some typ -> annot_exp (E_return (crule check_exp env exp typ)) (mk_typ (Typ_id (mk_id "unit"))) + | None -> typ_error l "Return found in non-function environment" + end + | E_field (exp, field) -> + begin + let inferred_exp = irule infer_exp env exp in + match Env.expand_synonyms env (typ_of inferred_exp) with + (* Accessing a (bit) field of a register *) + | Typ_aux (Typ_id regtyp, _) when Env.is_regtyp regtyp env -> + let base, top, ranges = Env.get_regtyp regtyp env in + let range, _ = + try List.find (fun (_, id) -> Id.compare id field = 0) ranges with + | Not_found -> typ_error l ("Field " ^ string_of_id field ^ " doesn't exist for register type " ^ string_of_id regtyp) + in + begin + match range, Env.get_default_order env with + | BF_aux (BF_single n, _), Ord_aux (Ord_dec, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in + annot_exp (E_field (inferred_exp, field)) vec_typ + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant (n - m + 1)) bit_typ in + annot_exp (E_field (inferred_exp, field)) vec_typ + | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant 1) bit_typ in + annot_exp (E_field (inferred_exp, field)) vec_typ + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant (m - n + 1)) bit_typ in + annot_exp (E_field (inferred_exp, field)) vec_typ + | _, _ -> typ_error l "Invalid register field type" + end + (* Accessing a field of a record *) + | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env -> + begin + let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor field env) [strip_exp inferred_exp] None in + match inferred_acc with + | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc) + | _ -> assert false (* Unreachable *) + end + | _ -> typ_error l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid") + end + | E_tuple exps -> + let inferred_exps = List.map (irule infer_exp env) exps in + annot_exp (E_tuple inferred_exps) (mk_typ (Typ_tup (List.map typ_of inferred_exps))) + | E_assign (lexp, bind) -> + fst (bind_assignment env lexp bind) + | E_cast (typ, exp) -> + let checked_exp = crule check_exp env exp typ in + annot_exp (E_cast (typ, checked_exp)) typ + | E_app_infix (x, op, y) when List.length (Env.get_overloads (deinfix op) env) > 0 -> infer_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) + | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 -> + let rec try_overload = function + | [] -> typ_error l ("No valid overloading for " ^ string_of_exp exp) + | (f :: fs) -> begin + typ_print ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"); + try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with + | Type_error (_, m) -> typ_print ("Error: " ^ m); try_overload fs + end + in + try_overload (Env.get_overloads f env) + | E_app (f, xs) -> infer_funapp l env f xs None + | E_for (v, f, t, step, ord, body) -> + begin + let f, t = match ord with + | Ord_aux (Ord_inc, _) -> f, t + | Ord_aux (Ord_dec, _) -> t, f (* reverse direction for downto loop *) + in + let inferred_f = irule infer_exp env f in + let inferred_t = irule infer_exp env t in + let checked_step = crule check_exp env step int_typ in + match is_range (typ_of inferred_f), is_range (typ_of inferred_t) with + | None, _ -> typ_error l ("Type of " ^ string_of_exp f ^ " in foreach must be a range") + | _, None -> typ_error l ("Type of " ^ string_of_exp t ^ " in foreach must be a range") + | Some (l1, l2), Some (u1, u2) when prove env (nc_lteq l2 u1) -> + let checked_body = crule check_exp (Env.add_local v (Immutable, range_typ l1 u2) env) body unit_typ in + annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ + | _, _ -> typ_error l "Ranges in foreach overlap" + end + | E_if (cond, then_branch, else_branch) -> + let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in + let flows, constrs = infer_flow env cond' in + let then_branch' = irule infer_exp (add_constraints constrs (add_flows true flows env)) then_branch in + let else_branch' = crule check_exp (add_constraints (List.map nc_negate constrs) (add_flows false flows env)) else_branch (typ_of then_branch') in + annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch') + | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ()))) + | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "vector_append", [v1; v2]), (l, ()))) + | E_vector_subrange (v, n, m) -> infer_exp env (E_aux (E_app (mk_id "vector_subrange", [v; n; m]), (l, ()))) + | E_vector [] -> typ_error l "Cannot infer type of empty vector" + | E_vector ((item :: items) as vec) -> + let inferred_item = irule infer_exp env item in + let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in + let vec_typ = match Env.get_default_order env with + | Ord_aux (Ord_inc, _) -> + mk_typ (Typ_app (mk_id "vector", + [mk_typ_arg (Typ_arg_nexp (nconstant 0)); + mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec))); + mk_typ_arg (Typ_arg_order (Env.get_default_order env)); + mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) + | Ord_aux (Ord_dec, _) -> + mk_typ (Typ_app (mk_id "vector", + [mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec - 1))); + mk_typ_arg (Typ_arg_nexp (nconstant (List.length vec))); + mk_typ_arg (Typ_arg_order (Env.get_default_order env)); + mk_typ_arg (Typ_arg_typ (typ_of inferred_item))])) + in + annot_exp (E_vector (inferred_item :: checked_items)) vec_typ + | E_assert (test, msg) -> + let checked_test = crule check_exp env test bool_typ in + let checked_msg = crule check_exp env msg string_typ in + annot_exp (E_assert (checked_test, checked_msg)) unit_typ + | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp) + +and infer_funapp l env f xs ret_ctx_typ = fst (infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ) + +and instantiation_of (E_aux (exp_aux, (l, _)) as exp) = + let env = env_of exp in + match exp_aux with + | E_app (f, xs) -> snd (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) (Some (typ_of exp))) + | _ -> invalid_arg ("instantiation_of expected application, got " ^ string_of_exp exp) + +and infer_funapp' l env f (typq, f_typ) xs ret_ctx_typ = + let annot_exp exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in + let all_unifiers = ref KBindings.empty in + let rec number n = function + | [] -> [] + | (x :: xs) -> (n, x) :: number (n + 1) xs + in + let solve_quant = function + | QI_aux (QI_id _, _) -> false + | QI_aux (QI_const nc, _) -> prove env nc + in + let rec instantiate quants typs ret_typ args = + match typs, args with + | (utyps, []), (uargs, []) -> + begin + typ_debug ("Got unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs); + if List.for_all solve_quant quants + then + let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in + (iuargs, ret_typ) + else typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants + ^ " not resolved during application of " ^ string_of_id f) + end + | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) when KidSet.is_empty (typ_frees typ) -> + begin + let carg = crule check_exp env arg typ in + let (iargs, ret_typ') = instantiate quants (utyps, typs) ret_typ (uargs, args) in + ((n, carg) :: iargs, ret_typ') + end + | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) -> + begin + typ_debug ("INSTANTIATE: " ^ string_of_exp arg ^ " with " ^ string_of_typ typ ^ " NF " ^ string_of_tnf (normalize_typ env typ)); + let iarg = irule infer_exp env arg in + typ_debug ("INFER: " ^ string_of_exp arg ^ " type " ^ string_of_typ (typ_of iarg) ^ " NF " ^ string_of_tnf (normalize_typ env (typ_of iarg))); + try + let iarg, unifiers = type_coercion_unify env iarg typ in + typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + all_unifiers := merge_uvars l !all_unifiers unifiers; + let utyps' = List.map (subst_unifiers unifiers) utyps in + let typs' = List.map (subst_unifiers unifiers) typs in + let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let ret_typ' = subst_unifiers unifiers ret_typ in + let (iargs, ret_typ'') = instantiate quants' (utyps', typs') ret_typ' (uargs, args) in + ((n, iarg) :: iargs, ret_typ'') + with + | Unification_error (l, str) -> + typ_debug ("Unification error: " ^ str); + instantiate quants (typ :: utyps, typs) ret_typ ((n, arg) :: uargs, args) + end + | (_, []), _ -> typ_error l ("Function " ^ string_of_id f ^ " applied to too many arguments") + | _, (_, []) -> typ_error l ("Function " ^ string_of_id f ^ " not applied to enough arguments") + in + let instantiate_ret quants typs ret_typ = + match ret_ctx_typ with + | None -> (quants, typs, ret_typ) + | Some rct -> + begin + typ_debug ("RCT is " ^ string_of_typ rct); + typ_debug ("INSTANTIATE RETURN:" ^ string_of_typ ret_typ); + let unifiers = try unify l env ret_typ rct with Unification_error _ -> typ_debug "UERROR"; KBindings.empty in + typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + all_unifiers := merge_uvars l !all_unifiers unifiers; + let typs' = List.map (subst_unifiers unifiers) typs in + let quants' = List.fold_left (fun qs (kid, uvar) -> instantiate_quants qs kid uvar) quants (KBindings.bindings unifiers) in + let ret_typ' = subst_unifiers unifiers ret_typ in + (quants', typs', ret_typ') + end + in + let exp = + match Env.expand_synonyms env f_typ with + | Typ_aux (Typ_fn (Typ_aux (Typ_tup typ_args, _), typ_ret, eff), _) -> + let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) typ_args typ_ret in + let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in + let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in + annot_exp (E_app (f, xs_reordered)) typ_ret eff + | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) -> + let (quants, typ_args, typ_ret) = instantiate_ret (quant_items typq) [typ_arg] typ_ret in + let (xs_instantiated, typ_ret) = instantiate quants ([], typ_args) typ_ret ([], number 0 xs) in + let xs_reordered = List.map snd (List.sort (fun (n, _) (m, _) -> compare n m) xs_instantiated) in + annot_exp (E_app (f, xs_reordered)) typ_ret eff + | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type") + in + match ret_ctx_typ with + | None -> exp, !all_unifiers + | Some rct -> type_coercion env exp rct, !all_unifiers + +(**************************************************************************) +(* 6. Effect system *) +(**************************************************************************) + +let effect_of_annot = function +| Some (_, _, eff) -> eff +| None -> no_effect + +let effect_of (E_aux (exp, (l, annot))) = effect_of_annot annot + +let add_effect (E_aux (exp, (l, annot))) eff1 = + match annot with + | Some (env, typ, eff2) -> E_aux (exp, (l, Some (env, typ, union_effects eff1 eff2))) + | None -> assert false + +let effect_of_lexp (LEXP_aux (exp, (l, annot))) = effect_of_annot annot + +let add_effect_lexp (LEXP_aux (lexp, (l, annot))) eff1 = + match annot with + | Some (env, typ, eff2) -> LEXP_aux (lexp, (l, Some (env, typ, union_effects eff1 eff2))) + | None -> assert false + +let effect_of_pat (P_aux (exp, (l, annot))) = effect_of_annot annot + +let add_effect_pat (P_aux (pat, (l, annot))) eff1 = + match annot with + | Some (env, typ, eff2) -> P_aux (pat, (l, Some (env, typ, union_effects eff1 eff2))) + | None -> assert false + +let collect_effects xs = List.fold_left union_effects no_effect (List.map effect_of xs) + +let collect_effects_lexp xs = List.fold_left union_effects no_effect (List.map effect_of_lexp xs) + +let collect_effects_pat xs = List.fold_left union_effects no_effect (List.map effect_of_pat xs) + +(* Traversal that propagates effects upwards through expressions *) + +let rec propagate_exp_effect (E_aux (exp, annot)) = + let p_exp, eff = propagate_exp_effect_aux exp in + add_effect (E_aux (p_exp, annot)) eff +and propagate_exp_effect_aux = function + | E_block xs -> + let p_xs = List.map propagate_exp_effect xs in + E_block p_xs, collect_effects p_xs + | E_nondet xs -> + let p_xs = List.map propagate_exp_effect xs in + E_nondet p_xs, collect_effects p_xs + | E_id id -> E_id id, no_effect + | E_lit lit -> E_lit lit, no_effect + | E_cast (typ, exp) -> + let p_exp = propagate_exp_effect exp in + E_cast (typ, p_exp), effect_of p_exp + | E_app (id, xs) -> + let p_xs = List.map propagate_exp_effect xs in + E_app (id, p_xs), collect_effects p_xs + | E_vector xs -> + let p_xs = List.map propagate_exp_effect xs in + E_vector p_xs, collect_effects p_xs + | E_tuple xs -> + let p_xs = List.map propagate_exp_effect xs in + E_tuple p_xs, collect_effects p_xs + | E_if (cond, t, e) -> + let p_cond = propagate_exp_effect cond in + let p_t = propagate_exp_effect t in + let p_e = propagate_exp_effect e in + E_if (p_cond, p_t, p_e), collect_effects [p_cond; p_t; p_e] + | E_case (exp, cases) -> + let p_exp = propagate_exp_effect exp in + let p_cases = List.map propagate_pexp_effect cases in + let case_eff = List.fold_left union_effects no_effect (List.map snd p_cases) in + E_case (p_exp, List.map fst p_cases), union_effects (effect_of p_exp) case_eff + | E_for (v, f, t, step, ord, body) -> + let p_f = propagate_exp_effect f in + let p_t = propagate_exp_effect t in + let p_step = propagate_exp_effect step in + let p_body = propagate_exp_effect body in + E_for (v, p_f, p_t, p_step, ord, p_body), + collect_effects [p_f; p_t; p_step; p_body] + | E_let (letbind, exp) -> + let p_lb, eff = propagate_letbind_effect letbind in + let p_exp = propagate_exp_effect exp in + E_let (p_lb, p_exp), union_effects (effect_of p_exp) eff + | E_assign (lexp, exp) -> + let p_lexp = propagate_lexp_effect lexp in + let p_exp = propagate_exp_effect exp in + E_assign (p_lexp, p_exp), union_effects (effect_of p_exp) (effect_of_lexp p_lexp) + | E_sizeof nexp -> E_sizeof nexp, no_effect + | E_constraint nc -> E_constraint nc, no_effect + | E_exit exp -> + let p_exp = propagate_exp_effect exp in + E_exit p_exp, effect_of p_exp + | E_return exp -> + let p_exp = propagate_exp_effect exp in + E_return p_exp, effect_of p_exp + | E_assert (test, msg) -> + let p_test = propagate_exp_effect test in + let p_msg = propagate_exp_effect msg in + E_assert (p_test, p_msg), collect_effects [p_test; p_msg] + | E_field (exp, id) -> + let p_exp = propagate_exp_effect exp in + E_field (p_exp, id), effect_of p_exp + | exp_aux -> typ_error Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression " + ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None)))) + +and propagate_pexp_effect = function + | Pat_aux (Pat_exp (pat, exp), (l, annot)) -> + begin + let p_pat = propagate_pat_effect pat in + let p_exp = propagate_exp_effect exp in + let p_eff = union_effects (effect_of_pat p_pat) (effect_of p_exp) in + match annot with + | Some (typq, typ, eff) -> + Pat_aux (Pat_exp (p_pat, p_exp), (l, Some (typq, typ, union_effects eff p_eff))), + union_effects eff p_eff + | None -> Pat_aux (Pat_exp (p_pat, p_exp), (l, None)), p_eff + end + | Pat_aux (Pat_when (pat, guard, exp), (l, annot)) -> + begin + let p_pat = propagate_pat_effect pat in + let p_guard = propagate_exp_effect guard in + let p_exp = propagate_exp_effect exp in + let p_eff = union_effects (effect_of_pat p_pat) + (union_effects (effect_of p_guard) (effect_of p_exp)) + in + match annot with + | Some (typq, typ, eff) -> + Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, Some (typq, typ, union_effects eff p_eff))), + union_effects eff p_eff + | None -> Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, None)), p_eff + end + +and propagate_pat_effect (P_aux (pat, annot)) = + let p_pat, eff = propagate_pat_effect_aux pat in + add_effect_pat (P_aux (p_pat, annot)) eff +and propagate_pat_effect_aux = function + | P_lit lit -> P_lit lit, no_effect + | P_wild -> P_wild, no_effect + | P_cons (pat1, pat2) -> + let p_pat1 = propagate_pat_effect pat1 in + let p_pat2 = propagate_pat_effect pat2 in + P_cons (p_pat1, p_pat2), union_effects (effect_of_pat p_pat1) (effect_of_pat p_pat2) + | P_as (pat, id) -> + let p_pat = propagate_pat_effect pat in + P_as (p_pat, id), effect_of_pat p_pat + | P_typ (typ, pat) -> + let p_pat = propagate_pat_effect pat in + P_typ (typ, p_pat), effect_of_pat p_pat + | P_id id -> P_id id, no_effect + | P_app (id, pats) -> + let p_pats = List.map propagate_pat_effect pats in + P_app (id, p_pats), collect_effects_pat p_pats + | P_tup pats -> + let p_pats = List.map propagate_pat_effect pats in + P_tup p_pats, collect_effects_pat p_pats + | P_list pats -> + let p_pats = List.map propagate_pat_effect pats in + P_list p_pats, collect_effects_pat p_pats + | P_vector_concat pats -> + let p_pats = List.map propagate_pat_effect pats in + P_vector_concat p_pats, collect_effects_pat p_pats + | P_vector pats -> + let p_pats = List.map propagate_pat_effect pats in + P_vector p_pats, collect_effects_pat p_pats + | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat" + +and propagate_letbind_effect (LB_aux (lb, (l, annot))) = + let p_lb, eff = propagate_letbind_effect_aux lb in + match annot with + | Some (typq, typ, eff) -> LB_aux (p_lb, (l, Some (typq, typ, eff))), eff + | None -> LB_aux (p_lb, (l, None)), eff +and propagate_letbind_effect_aux = function + | LB_val_explicit (typschm, pat, exp) -> + let p_pat = propagate_pat_effect pat in + let p_exp = propagate_exp_effect exp in + LB_val_explicit (typschm, p_pat, p_exp), + union_effects (effect_of_pat p_pat) (effect_of p_exp) + | LB_val_implicit (pat, exp) -> + let p_pat = propagate_pat_effect pat in + let p_exp = propagate_exp_effect exp in + LB_val_implicit (p_pat, p_exp), + union_effects (effect_of_pat p_pat) (effect_of p_exp) + +and propagate_lexp_effect (LEXP_aux (lexp, annot)) = + let p_lexp, eff = propagate_lexp_effect_aux lexp in + add_effect_lexp (LEXP_aux (p_lexp, annot)) eff +and propagate_lexp_effect_aux = function + | LEXP_id id -> LEXP_id id, no_effect + | LEXP_memory (id, exps) -> + let p_exps = List.map propagate_exp_effect exps in + LEXP_memory (id, p_exps), collect_effects p_exps + | LEXP_cast (typ, id) -> LEXP_cast (typ, id), no_effect + | LEXP_tup lexps -> + let p_lexps = List.map propagate_lexp_effect lexps in + LEXP_tup p_lexps, collect_effects_lexp p_lexps + | LEXP_vector (lexp, exp) -> + let p_lexp = propagate_lexp_effect lexp in + let p_exp = propagate_exp_effect exp in + LEXP_vector (p_lexp, p_exp), union_effects (effect_of p_exp) (effect_of_lexp p_lexp) + | LEXP_vector_range (lexp, exp1, exp2) -> + let p_lexp = propagate_lexp_effect lexp in + let p_exp1 = propagate_exp_effect exp1 in + let p_exp2 = propagate_exp_effect exp2 in + LEXP_vector_range (p_lexp, p_exp1, p_exp2), + union_effects (collect_effects [p_exp1; p_exp2]) (effect_of_lexp p_lexp) + | LEXP_field (lexp, id) -> + let p_lexp = propagate_lexp_effect lexp in + LEXP_field (p_lexp, id),effect_of_lexp p_lexp + | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in lexp" + +(**************************************************************************) +(* 6. Checking toplevel definitions *) +(**************************************************************************) + +let check_letdef env (LB_aux (letbind, (l, _))) = + begin + match letbind with + | LB_val_explicit (typschm, pat, bind) -> assert false + | LB_val_implicit (P_aux (P_typ (typ_annot, pat), _), bind) -> + let checked_bind = crule check_exp env (strip_exp bind) typ_annot in + let tpat, env = bind_pat env (strip_pat pat) typ_annot in + [DEF_val (LB_aux (LB_val_implicit (P_aux (P_typ (typ_annot, tpat), (l, Some (env, typ_annot, no_effect))), checked_bind), (l, None)))], env + | LB_val_implicit (pat, bind) -> + let inferred_bind = irule infer_exp env (strip_exp bind) in + let tpat, env = bind_pat env (strip_pat pat) (typ_of inferred_bind) in + [DEF_val (LB_aux (LB_val_implicit (tpat, inferred_bind), (l, None)))], env + end + +let check_funcl env (FCL_aux (FCL_Funcl (id, pat, exp), (l, _))) typ = + match typ with + | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) -> + begin + let typed_pat, env = bind_pat env (strip_pat pat) typ_arg in + let env = Env.add_ret_typ typ_ret env in + let exp = propagate_exp_effect (crule check_exp env (strip_exp exp) typ_ret) in + FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, Some (env, typ, effect_of exp))) + end + | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type") + +let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pat, exp), (l, annot))) = + match annot with + | Some (_, _, eff) -> eff + | None -> no_effect (* Maybe could be assert false. This should never happen *) + +let infer_funtyp l env tannotopt funcls = + match tannotopt with + | Typ_annot_opt_aux (Typ_annot_opt_some (quant, ret_typ), _) -> + begin + let rec typ_from_pat (P_aux (pat_aux, (l, _)) as pat) = + match pat_aux with + | P_lit lit -> infer_lit env lit + | P_typ (typ, _) -> typ + | P_tup pats -> mk_typ (Typ_tup (List.map typ_from_pat pats)) + | _ -> typ_error l ("Cannot infer type from pattern " ^ string_of_pat pat) + in + match funcls with + | [FCL_aux (FCL_Funcl (_, pat, _), _)] -> + let arg_typ = typ_from_pat pat in + let fn_typ = mk_typ (Typ_fn (arg_typ, ret_typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in + (quant, fn_typ) + | _ -> typ_error l "Cannot infer function type for function with multiple clauses" + end + | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error l "Cannot infer function type for unannotated function" + +let mk_val_spec typq typ id = DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id), (Parse_ast.Unknown, None))) + +let check_tannotopt typq ret_typ = function + | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> () + | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_ret_typ), l) -> + if typ_identical ret_typ annot_ret_typ + then () + else typ_error l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec") + +let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, _)) as fd_aux) = + let id = id_of_fundef fd_aux in + typ_print ("\nChecking function " ^ string_of_id id); + let have_val_spec, (quant, (Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) as typ)), env = + try true, Env.get_val_spec id env, env with + | Type_error (l, _) -> + let (quant, typ) = infer_funtyp l env tannotopt funcls in + false, (quant, typ), env in - match (in_env,tannot) with - | Some(Base( (params,u),Spec,constraints,eft,_,_)), Base( (p',t),_,c',eft',_,_) -> - (*let _ = Printf.eprintf "Function %s is in env\n" id in*) - let u,constraints,eft,t_param_env = subst_with_env t_param_env true u constraints eft in - let _,cs_decs = type_consistent (Specc l) d_env Require false t u in - (*let _ = Printf.eprintf "valspec consistent with type for %s, %s ~< %s with %s deriveds and %s stated\n" - id (t_to_string t) (t_to_string u) (constraints_to_string cs_decs) - (constraints_to_string (constraints@c')) in*) - let imp_param = match u.t with - | Tfn(_,_,IP_user n,_) -> Some n - | _ -> None in - let (t_env,orig_env) = if is_rec then (t_env,t_env) else (Envmap.remove t_env id,t_env) in - let funcls,cs_ef = check t_env t_param_env imp_param in - let cses,ef = ((fun (cses,efses) -> - cses,(List.fold_right union_effects efses pure_e)) (List.split cs_ef)) in - let cs = if List.length funcls = 1 then cses else [BranchCons(Fun l,None, cses)] in - let cs',map = resolve_constraints (cs@cs_decs@constraints@c') in - let tannot = - check_tannot l (match map with | None -> tannot | Some m -> add_map_tannot m tannot) imp_param cs' ef in - (*let _ = Printf.eprintf "remaining constraints are: %s\n" (constraints_to_string cs') in - let _ = Printf.eprintf "check_tannot ok for %s val type %s derived type %s \n" - id (t_to_string u) (t_to_string t) in*) - let _ = List.map check_pattern_after_constraints funcls in - let funcls = match imp_param with - | Some {nexp = Nvar i} -> List.map (update_pattern i) funcls - | _ -> funcls - in - (*let _ = Printf.eprintf "done funcheck case 1 of %s\n%!" id in*) - (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,tannot))), - Env(d_env,orig_env (*Envmap.insert t_env (id,tannot)*),b_env,tp_env) - | _ , _-> - (*let _ = Printf.eprintf "checking %s, not in env\n%!" id in*) - (*let t_env = if is_rec then Envmap.insert t_env (id,tannot) else t_env in*) - let funcls,cs_ef = check t_env t_param_env None in - let cses,ef = - ((fun (cses,efses) -> (cses,(List.fold_right union_effects efses pure_e))) (List.split cs_ef)) in - let cs = if List.length funcls = 1 then cses else [BranchCons(Fun l, None, cses)] in - (*let _ = Printf.eprintf "unresolved constraints are %s\n%!" (constraints_to_string cs) in*) - let (cs',map) = resolve_constraints cs in - (*let _ = Printf.eprintf "checking tannot for %s 2 remaining constraints are %s\n" - id (constraints_to_string cs') in*) - let tannot = check_tannot l - (match map with | None -> tannot | Some m -> add_map_tannot m tannot) - None cs' ef in - let _ = List.map check_pattern_after_constraints funcls in - (*let _ = Printf.eprintf "done funcheck case2\n" in*) - (FD_aux(FD_function(recopt,tannotopt,effectopt,funcls),(l,tannot))), - Env(d_env,(if is_rec then t_env else Envmap.insert t_env (id,tannot)),b_env,tp_env) - -(*TODO Only works for inc vectors, need to add support for dec*) -let check_alias_spec envs alias (AL_aux(al,(l,annot))) e_typ = - let (Env(d_env,t_env,b_env,tp_env)) = envs in - let check_reg (RI_aux ((RI_id (Id_aux(_,l) as id)), _)) : (string * tannot reg_id * typ * typ) = - let i = id_to_string id in - (match Envmap.apply t_env i with - | Some(Base(([],t), External (Some j), [], _,_,_)) -> - let t,_ = get_abbrev d_env t in - let t_actual,t_id = match t.t with - | Tabbrev(i,t) -> t,i - | _ -> t,t in - (match t_actual.t with - | Tapp("register",[TA_typ t']) -> - if i = j then (i,(RI_aux (RI_id id, (l,Base(([],t),External (Some j), [], pure_e,pure_e,nob)))),t_id,t') - else assert false - | _ -> typ_error l - ("register alias " ^ alias ^ " to " ^ i ^ " expected a register, found " ^ (t_to_string t))) - | _ -> typ_error l ("register alias " ^ alias ^ " to " ^ i ^ " exepcted a register.")) in - match al with - | AL_subreg(reg_a,subreg) -> - let (reg,reg_a,reg_t,t) = check_reg reg_a in - (match reg_t.t with - | Tid i -> - (match lookup_record_typ i d_env.rec_env with - | None -> typ_error l ("Expected a register with bit fields, given " ^ i) - | Some(((i,rec_kind,tannot,fields) as r)) -> - let fi = id_to_string subreg in - (match lookup_field_type fi r with - | None -> typ_error l ("Type " ^ i ^ " does not have a field " ^ fi) - | Some et -> - let tannot = Base(([],et),Alias (Alias_field(reg,fi)),[],pure_e,pure_e,nob) in - let d_env = {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in - (AL_aux(AL_subreg(reg_a,subreg),(l,tannot)),tannot,d_env))) - | _ -> typ_error l ("Expected a register with fields, given " ^ (t_to_string reg_t))) - | AL_bit(reg_a,bit) -> - let (reg,reg_a,reg_t,t) = check_reg reg_a in - let (E_aux(bit,(le,eannot)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) bit in - (match t.t with - | Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord order;TA_typ item_t]) -> - (match (base.nexp,len.nexp,order.order, bit) with - | (Nconst i,Nconst j,Oinc, E_lit (L_aux((L_num k), ll))) -> - if (int_of_big_int i) <= k && ((int_of_big_int i) + (int_of_big_int j)) >= k - then let tannot = Base(([],item_t),Alias (Alias_extract(reg, k,k)),[],pure_e,pure_e,nob) in - let d_env = - {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in - (AL_aux(AL_bit(reg_a,(E_aux(bit,(le,eannot)))), (l,tannot)), tannot,d_env) - else typ_error ll ("Alias bit lookup must be in the range of the vector in the register") - | _ -> typ_error l ("Alias bit lookup must have a constant index")) - | _ -> typ_error l ("Alias bit lookup must refer to a register with type vector, found " ^ (t_to_string t))) - | AL_slice(reg_a,sl1,sl2) -> - let (reg,reg_a,reg_t,t) = check_reg reg_a in - let (E_aux(sl1,(le1,eannot1)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) sl1 in - let (E_aux(sl2,(le2,eannot2)),_,_,_,_,_) = check_exp envs None true true (new_t ()) (new_t ()) sl2 in - (match t.t with - | Tapp("vector",[TA_nexp base;TA_nexp len;TA_ord order;TA_typ item_t]) -> - (match (base.nexp,len.nexp,order.order, sl1,sl2) with - | (Nconst i,Nconst j,Oinc, E_lit (L_aux((L_num k), ll)),E_lit (L_aux((L_num k2), ll2))) -> - if (int_of_big_int i) <= k && ((int_of_big_int i) + (int_of_big_int j)) >= k2 && k < k2 - then let t = {t = Tapp("vector",[TA_nexp (int_to_nexp k);TA_nexp (int_to_nexp ((k2-k) +1)); - TA_ord order; TA_typ item_t])} in - let tannot = Base(([],t),Alias (Alias_extract(reg, k, k2)),[],pure_e,pure_e,nob) in - let d_env = - {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, (OneReg(reg,tannot)))} in - (AL_aux(AL_slice(reg_a,(E_aux(sl1,(le1,eannot1))),(E_aux(sl2,(le2,eannot2)))), - (l,tannot)), tannot,d_env) - else typ_error ll ("Alias slices must be in the range of the vector in the register") - | _ -> typ_error l ("Alias slices must have constant slices")) - | _ -> typ_error l ("Alias slices must point to a register with a vector type: found " ^ (t_to_string t))) - | AL_concat(reg1_a,reg2_a) -> - let (reg1,reg1_a,reg_t,t1) = check_reg reg1_a in - let (reg2,reg2_a,reg_t,t2) = check_reg reg2_a in - (match (t1.t,t2.t) with - | (Tapp("vector",[TA_nexp b1;TA_nexp r; TA_ord {order = Oinc}; TA_typ item_t]), - Tapp("vector",[TA_nexp _ ;TA_nexp r2; TA_ord {order = Oinc}; TA_typ item_t2])) -> - let _ = type_consistent (Specc l) d_env Guarantee false item_t item_t2 in - let t = {t= Tapp("register", - [TA_typ {t= Tapp("vector",[TA_nexp b1; TA_nexp (mk_add r r2); - TA_ord {order = Oinc}; TA_typ item_t])}])} in - let tannot = Base(([],t),Alias (Alias_pair(reg1,reg2)),[],pure_e,pure_e,nob) in - let d_env = {d_env with alias_env = Envmap.insert (d_env.alias_env) (alias, TwoReg(reg1,reg2,tannot))} in - (AL_aux (AL_concat(reg1_a,reg2_a), (l,tannot)), tannot, d_env) - | _ -> typ_error l - ("Alias concatentaion must connect two registers with vector type, found " ^ t_to_string t1 ^ " and " ^ t_to_string t2)) - -(*val check_def : envs -> tannot def -> (tannot def) envs_out*) -let check_def envs def = - let (Env(d_env,t_env,b_env,tp_env)) = envs in + check_tannotopt quant vtyp_ret tannotopt; + typ_debug ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)); + let funcl_env = add_typquant quant env in + let funcls = List.map (fun funcl -> check_funcl funcl_env funcl typ) funcls in + let eff = List.fold_left union_effects no_effect (List.map funcl_effect funcls) in + let vs_def, env, declared_eff = + if not have_val_spec + then + let typ = Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, eff), vl) in + [mk_val_spec quant typ id], Env.add_val_spec id (quant, typ) env, eff + else [], env, declared_eff + in + if (equal_effects eff declared_eff || !opt_no_effects) + then + vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env + else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found") + +(* Checking a val spec simply adds the type as a binding in the + context. We have to destructure the various kinds of val specs, but + the difference is irrelevant for the typechecker. *) +let check_val_spec env (VS_aux (vs, (l, _))) = + let (id, quants, typ, env) = match vs with + | VS_val_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env) + | VS_cast_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, Env.add_cast id env) + | VS_extern_no_rename (TypSchm_aux (TypSchm_ts (quants, typ), _), id) -> (id, quants, typ, env) + | VS_extern_spec (TypSchm_aux (TypSchm_ts (quants, typ), _), id, _) -> (id, quants, typ, env) in + [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, typ) env + +let check_default env (DT_aux (ds, l)) = + match ds with + | DT_kind _ -> [DEF_default (DT_aux (ds,l))], env (* Check: Is this supposed to do nothing? *) + | DT_order (Ord_aux (Ord_inc, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_inc env + | DT_order (Ord_aux (Ord_dec, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_dec env + | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order" + (* This branch allows us to write something like: default forall Nat 'n. [|'n|] name... what does this even mean?! *) + | DT_typ (typschm, id) -> typ_error l ("Unsupported default construct") + +let check_register env id base top ranges = + match base, top with + | Nexp_aux (Nexp_constant basec, _), Nexp_aux (Nexp_constant topc, _) -> + let no_typq = TypQ_aux (TypQ_tq [], Parse_ast.Unknown) (* Maybe could be TypQ_no_forall? *) in + (* FIXME: wrong for default Order inc? *) + let vec_typ = dvector_typ env base (nconstant ((basec - topc) + 1)) bit_typ in + let cast_typ = mk_typ (Typ_fn (mk_id_typ id, vec_typ, no_effect)) in + let cast_to_typ = mk_typ (Typ_fn (vec_typ, mk_id_typ id, no_effect)) in + env + |> Env.add_regtyp id basec topc ranges + (* |> Env.add_typ_synonym id (fun _ -> vec_typ) *) + |> Env.add_val_spec (mk_id ("cast_" ^ string_of_id id)) (no_typq, cast_typ) + |> Env.add_cast (mk_id ("cast_" ^ string_of_id id)) + |> Env.add_val_spec (mk_id ("cast_to_" ^ string_of_id id)) (no_typq, cast_to_typ) + |> Env.add_cast (mk_id ("cast_to_" ^ string_of_id id)) + | _, _ -> typ_error (id_loc id) "Num expressions in register type declaration do not evaluate to constants" + +let kinded_id_arg kind_id = + let typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) in + match kind_id with + | KOpt_aux (KOpt_none kid, _) -> typ_arg (Typ_arg_nexp (nvar kid)) + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_nat, _)], _), kid), _) -> typ_arg (Typ_arg_nexp (nvar kid)) + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_order, _)], _), kid), _) -> + typ_arg (Typ_arg_order (Ord_aux (Ord_var kid, Parse_ast.Unknown))) + | KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (BK_type, _)], _), kid), _) -> + typ_arg (Typ_arg_typ (mk_typ (Typ_var kid))) + +let fold_union_quant quants (QI_aux (qi, l)) = + match qi with + | QI_id kind_id -> quants @ [kinded_id_arg kind_id] + | _ -> quants + +let check_type_union env variant typq (Tu_aux (tu, l)) = + let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in + match tu with + | Tu_id v -> Env.add_union_id v (typq, ret_typ) env + | Tu_ty_id (typ, v) -> Env.add_val_spec v (typq, mk_typ (Typ_fn (typ, ret_typ, no_effect))) env + +let check_typedef env (TD_aux (tdef, (l, _))) = + let td_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Typedef") in + match tdef with + | TD_abbrev(id, nmscm, (TypSchm_aux (TypSchm_ts (typq, typ), _))) -> + [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (fun _ -> typ) env + | TD_record(id, nmscm, typq, fields, _) -> + [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env + | TD_variant(id, nmscm, typq, arms, _) -> + let env = + env + |> Env.add_variant id (typq, arms) + |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms) + in + [DEF_type (TD_aux (tdef, (l, None)))], env + | TD_enum(id, nmscm, ids, _) -> + [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env + | TD_register(id, base, top, ranges) -> [DEF_type (TD_aux (tdef, (l, None)))], check_register env id base top ranges + +let rec check_def env def = + let cd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented Case") in match def with - | DEF_kind kdef -> - (*let _ = Printf.eprintf "checking kind def\n" in*) - let kd,envs = check_kind_def envs kdef in - (*let _ = Printf.eprintf "checked kind def\n" in*) - (DEF_kind kd,envs) - | DEF_type tdef -> - (*let _ = Printf.eprintf "checking type def\n" in*) - let td,envs = check_type_def envs tdef in - (*let _ = Printf.eprintf "checked type def\n" in*) - (DEF_type td,envs) - | DEF_fundef fdef -> - (*let _ = Printf.eprintf "checking fun def\n" in*) - let fd,envs = check_fundef envs fdef in - (*let _ = Printf.eprintf "checked fun def\n" in*) - (DEF_fundef fd,envs) - | DEF_val letdef -> - (*let _ = Printf.eprintf "checking letdef\n" in*) - let (letbind,t_env_let,_,b_env_let,eft) = check_lbind envs None true None Emp_global letdef in - (*let _ = Printf.eprintf "checked letdef\n" in*) - (DEF_val letbind,Env(d_env,Envmap.union t_env t_env_let, merge_bounds b_env b_env_let, tp_env)) - | DEF_spec spec -> - (*let _ = Printf.eprintf "checking spec\n" in*) - let vs,envs = check_val_spec envs spec in - (*let _ = Printf.eprintf "checked spec\n" in*) - (DEF_spec vs, envs) - | DEF_default default -> let ds,envs = check_default envs default in - (DEF_default ds,envs) - | DEF_reg_dec(DEC_aux(DEC_reg(typ,id), (l,annot))) -> - (*let _ = Printf.eprintf "checking reg dec\n" in *) - let t = (typ_to_t envs false false typ) in - let i = id_to_string id in - let tannot = into_register d_env (Base(([],t),External (Some i),[],pure_e,pure_e,nob)) in - (*let _ = Printf.eprintf "done checking reg dec\n" in*) - (DEF_reg_dec(DEC_aux(DEC_reg(typ,id),(l,tannot))),(Env(d_env,Envmap.insert t_env (i,tannot),b_env, tp_env))) - | DEF_reg_dec(DEC_aux(DEC_alias(id,aspec), (l,annot))) -> - (*let _ = Printf.eprintf "checking reg dec b\n" in*) - let i = id_to_string id in - let (aspec,tannot,d_env) = check_alias_spec envs i aspec None in - (*let _ = Printf.eprintf "done checking reg dec b\n" in *) - (DEF_reg_dec(DEC_aux(DEC_alias(id,aspec),(l,tannot))),(Env(d_env, Envmap.insert t_env (i,tannot),b_env,tp_env))) - | DEF_reg_dec(DEC_aux(DEC_typ_alias(typ,id,aspec),(l,tannot))) -> - (*let _ = Printf.eprintf "checking reg dec c\n" in*) - let i = id_to_string id in - let t = typ_to_t envs false false typ in - let (aspec,tannot,d_env) = check_alias_spec envs i aspec (Some t) in - (*let _ = Printf.eprintf "done checking reg dec c\n" in*) - (DEF_reg_dec(DEC_aux(DEC_typ_alias(typ,id,aspec),(l,tannot))),(Env(d_env,Envmap.insert t_env (i,tannot),b_env,tp_env))) + | DEF_kind kdef -> cd_err () + | DEF_type tdef -> check_typedef env tdef + | DEF_fundef fdef -> check_fundef env fdef + | DEF_val letdef -> check_letdef env letdef + | DEF_spec vs -> check_val_spec env vs + | DEF_default default -> check_default env default + | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env + | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) -> + [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, None)))], Env.add_register id typ env + | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err () + | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err () | DEF_scattered _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Scattered given to type checker") - | _ -> def,envs (*Else a comment, so skip but keep*) + | DEF_comm (DC_comm str) -> [DEF_comm (DC_comm str)], env + | DEF_comm (DC_comm_struct def) -> + let defs, env = check_def env def + in List.map (fun def -> DEF_comm (DC_comm_struct def)) defs, env +let rec check' env (Defs defs) = + match defs with + | [] -> (Defs []), env + | def :: defs -> + let (def, env) = check_def env def in + let (Defs defs, env) = check' env (Defs defs) in + (Defs (def @ defs)), env -(*val check : envs -> tannot defs -> tannot defs*) -let rec check envs (Defs defs) = - match defs with - | [] -> (Defs []),envs - | def::defs -> let (def, envs) = check_def envs def in - let (Defs defs, envs) = check envs (Defs defs) in - (Defs (def::defs)), envs +let check env defs = + try check' env defs with + | Type_error (l, m) -> raise (Reporting_basic.err_typ l m) diff --git a/src/type_check.mli b/src/type_check.mli index 4f78dd03..92465cd5 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Alasdair Armstrong *) (* *) (* All rights reserved. *) (* *) @@ -41,14 +42,193 @@ (**************************************************************************) open Ast -open Type_internal -type kind = Type_internal.kind -type typ = Type_internal.t -type 'a emap = 'a Envmap.t +open Ast_util -type envs = Env of def_envs * tannot emap * bounds_env * t_arg emap -type 'a envs_out = 'a * envs +val opt_tc_debug : int ref +val opt_no_effects : bool ref +exception Type_error of l * string;; -val check : envs -> tannot defs -> tannot defs * envs -val typ_to_t : envs -> bool -> bool -> Ast.typ -> t +type mut = Immutable | Mutable + +type lvar = Register of typ | Enum of typ | Local of mut * typ | Union of typquant * typ | Unbound + +module Env : sig + (* Env.t is the type of environments *) + type t + + (* Note: Most get_ functions assume the identifiers exist, and throw type + errors if it doesn't. *) + + val get_val_spec : id -> t -> typquant * typ + + val get_register : id -> t -> typ + + val get_regtyp : id -> t -> int * int * (index_range * id) list + + (* Return all the identifiers in an enumeration. Throws a type error + if the enumeration doesn't exist. *) + val get_enum : id -> t -> id list + + (* Returns true if id is a register type, false otherwise *) + val is_regtyp : id -> t -> bool + + (* Check if a local variable is mutable. Throws Type_error if it + isn't a local variable. Probably best to use Env.lookup_id + instead *) + val is_mutable : id -> t -> bool + + (* Get the current set of constraints. *) + val get_constraints : t -> n_constraint list + + val get_typ_var : kid -> t -> base_kind_aux + + val get_typ_vars : t -> base_kind_aux KBindings.t + + val is_record : id -> t -> bool + + val get_accessor : id -> t -> typquant * typ + + (* If the environment is checking a function, then this will get the + expected return type of the function. It's useful for checking or + inserting early returns. Returns an option type and won't throw + any exceptions. *) + val get_ret_typ : t -> typ option + + val get_typ_synonym : id -> t -> typ_arg list -> typ + + val get_overloads : id -> t -> id list + + (* Lookup id searchs for a specified id in the environment, and + returns it's type and what kind of identifier it is, using the + lvar type. Returns Unbound if the identifier is unbound, and + won't throw any exceptions. *) + val lookup_id : id -> t -> lvar + + (* Return a fresh kind identifier that doesn't exist in the environment *) + val fresh_kid : t -> kid + + val expand_synonyms : t -> typ -> typ + + (* Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *) + val base_typ_of : t -> typ -> typ + + (* no_casts removes all the implicit type casts/coercions from the + environment, so checking a term with such an environment will + guarantee not to insert any casts. Not that this is only about + the implicit casting and has nothing to do with the E_cast AST + node. *) + val no_casts : t -> t + + (* Is casting allowed by the environment? *) + val allow_casts : t -> bool + + val empty : t + +end + +val add_typquant : typquant -> Env.t -> Env.t + +(* Some handy utility functions for constructing types. *) +val mk_typ : typ_aux -> typ +val mk_typ_arg : typ_arg_aux -> typ_arg +val mk_id : string -> id +val mk_id_typ : id -> typ + +val no_effect : effect +val mk_effect : base_effect_aux list -> effect + +val union_effects : effect -> effect -> effect +val equal_effects : effect -> effect -> bool + +val nconstant : int -> nexp +val nminus : nexp -> nexp -> nexp +val nsum : nexp -> nexp -> nexp +val ntimes : nexp -> nexp -> nexp +val npow2 : nexp -> nexp +val nvar : kid -> nexp + +(* Sail builtin types. *) +val int_typ : typ +val nat_typ : typ +val atom_typ : nexp -> typ +val range_typ : nexp -> nexp -> typ +val bit_typ : typ +val bool_typ : typ +val unit_typ : typ +val string_typ : typ +val real_typ : typ +val vector_typ : nexp -> nexp -> order -> typ -> typ +val list_typ : typ -> typ + +val inc_ord : order +val dec_ord : order + +(* Vector with default order. *) +val dvector_typ : Env.t -> nexp -> nexp -> typ -> typ + +(* Vector of specific length with default order, i.e. lvector_typ env n bit_typ = bit[n]. *) +val lvector_typ : Env.t -> nexp -> typ -> typ + +type tannot = (Env.t * typ * effect) option + +(* Strip the type annotations from an expression. *) +val strip_exp : 'a exp -> unit exp +val strip_pat : 'a pat -> unit pat + +(* Check an expression has some type. Returns a fully annotated + version of the expression, where each subexpression is annotated + with it's type and the Environment used while checking it. The can + be used to re-start the typechecking process on any + sub-expression. so local modifications to the AST can be + re-checked. *) +val check_exp : Env.t -> unit exp -> typ -> tannot exp + +(* Partial functions: The expressions and patterns passed to these + functions must be guaranteed to have tannots of the form Some (env, + typ) for these to work. *) + +val env_of : tannot exp -> Env.t +val env_of_annot : Ast.l * tannot -> Env.t + +val typ_of : tannot exp -> typ +val typ_of_annot : Ast.l * tannot -> typ + +val env_of : tannot exp -> Env.t + +val pat_typ_of : tannot pat -> typ + +val effect_of : tannot exp -> effect +val effect_of_annot : tannot -> effect + +type uvar = + | U_nexp of nexp + | U_order of order + | U_effect of effect + | U_typ of typ + +(* Throws Invalid_argument if the argument is not a E_app expression *) +val instantiation_of : tannot exp -> uvar KBindings.t + +val propagate_exp_effect : tannot exp -> tannot exp + +(* Fully type-check an AST + +Some invariants that will hold of a fully checked AST are: + + * No internal nodes, such as E_internal_exp, or E_comment nodes. + + * E_vector_access nodes and similar will be replaced by function + calls E_app to vector access functions. This is different to the + old type checker. + + * Every expressions type annotation (tannot) will be Some (typ, env). + + * Also every pattern will be annotated with the type it matches. + + * Toplevel expressions such as typedefs and some subexpressions such + as letbinds may have None as their tannots if it doesn't make sense + for them to have type annotations. *) +val check : Env.t -> 'a defs -> tannot defs * Env.t + +val initial_env : Env.t diff --git a/src/type_internal.ml b/src/type_internal.ml deleted file mode 100644 index 155e78f4..00000000 --- a/src/type_internal.ml +++ /dev/null @@ -1,4522 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* *) -(* 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 Util -open Big_int -module Envmap = Finite_map.Fmap_map(String) -module Nameset' = Set.Make(String) -module Nameset = struct - include Nameset' - let pp ppf nameset = - Format.fprintf ppf "{@[%a@]}" - (Pp.lst ",@ " Pp.pp_str) - (Nameset'.elements nameset) -end - -let zero = big_int_of_int 0 -let one = big_int_of_int 1 -let two = big_int_of_int 2 - -type kind = { mutable k : k_aux } -and k_aux = - | K_Typ - | K_Nat - | K_Ord - | K_Efct - | K_Val - | K_Lam of kind list * kind - | K_infer - - type t = { mutable t : t_aux } -and t_aux = - | Tvar of string - | Tid of string - | Tfn of t * t * implicit_parm * effect - | Ttup of t list - | Tapp of string * t_arg list - | Tabbrev of t * t - | Toptions of t * t option - | Tuvar of t_uvar -and t_uvar = { index : int; mutable subst : t option ; mutable torig_name : string option} -and implicit_parm = - | IP_none | IP_length of nexp | IP_start of nexp | IP_user of nexp -and nexp = { mutable nexp : nexp_aux; mutable imp_param : bool} -and nexp_aux = - | Nvar of string - | Nid of string * nexp (*First term is the name of this nid, second is the constant it represents*) - | Nconst of big_int - | Npos_inf - | Nneg_inf - | Nadd of nexp * nexp - | Nsub of nexp * nexp - | Nmult of nexp * nexp - | N2n of nexp * big_int option - | Npow of nexp * int (* nexp raised to the int *) - | Nneg of nexp (* Unary minus for representing new vector sizes after vector slicing *) - | Ninexact (*Result of +inf + -inf which is neither less than nor greater than other numbers really *) - | Nuvar of n_uvar -and n_uvar = - (*nindex is a counter; insubst are substitions 'inward'; outsubst are substitions 'outward'. Inward can be non nu - nin is in an in clause; leave_var flags if we should try to stay a variable; orig_var out inwardmost, name to use - *) - { nindex : int; mutable insubst : nexp option; mutable outsubst : nexp option; - mutable nin : bool; mutable leave_var : bool; mutable orig_var : string option ; mutable been_collapsed : bool } -and effect = { mutable effect : effect_aux } -and effect_aux = - | Evar of string - | Eset of base_effect list - | Euvar of e_uvar -and e_uvar = { eindex : int; mutable esubst : effect option } -and order = { mutable order : order_aux } -and order_aux = - | Ovar of string - | Oinc - | Odec - | Ouvar of o_uvar -and o_uvar = { oindex : int; mutable osubst : order option } -and t_arg = - | TA_typ of t - | TA_nexp of nexp - | TA_eft of effect - | TA_ord of order - -type alias_inf = - | Alias_field of string * string - | Alias_extract of string * int * int - | Alias_pair of string * string - -type tag = - | Emp_local - | Emp_global - | Emp_intro - | Emp_set - | Tuple_assign of tag list - | External of string option - | Default - | Constructor of int - | Enum of int - | Alias of alias_inf - | Spec - -let rec compare_nexps n1 n2 = - match n1.nexp,n2.nexp with - | Nneg_inf , Nneg_inf -> 0 - | Nneg_inf , _ -> -1 - | _ , Nneg_inf -> 1 - | Nconst n1, Nconst n2 -> compare_big_int n1 n2 - | Nconst _ , _ -> -1 - | _ , Nconst _ -> 1 - | Nid(i1,n1), Nid(i2,n2) -> - (match compare i1 i2 with - | 0 -> 0 - | _ -> compare_nexps n1 n2) - | Nid _ , _ -> -1 - | _ , Nid _ -> 1 - | Nvar i1 , Nvar i2 -> compare i1 i2 - | Nvar _ , _ -> -1 - | _ , Nvar _ -> 1 - | Nuvar {nindex = n1}, Nuvar {nindex = n2} -> compare n1 n2 - | Nuvar _ , _ -> -1 - | _ , Nuvar _ -> 1 - | Nmult(n0,n1),Nmult(n2,n3) -> - (match compare_nexps n0 n2 with - | 0 -> compare_nexps n1 n3 - | a -> a) - | Nmult _ , _ -> -1 - | _ , Nmult _ -> 1 - | Nadd(n1,n12),Nadd(n2,n22) -> - (match compare_nexps n1 n2 with - | 0 -> compare_nexps n12 n22 - | a -> a) - | Nadd _ , _ -> -1 - | _ , Nadd _ -> 1 - | Nsub(n1,n12),Nsub(n2,n22) -> - (match compare_nexps n1 n2 with - | 0 -> compare_nexps n12 n22 - | a -> a) - | Nsub _ , _ -> -1 - | _ , Nsub _ -> 1 - | Npow(n1,_),Npow(n2,_)-> compare_nexps n1 n2 - | Npow _ , _ -> -1 - | _ , Npow _ -> 1 - | N2n(_,Some i1), N2n(_,Some i2) -> compare_big_int i1 i2 - | N2n(n1,_), N2n(n2,_) -> compare_nexps n1 n2 - | N2n _ , _ -> -1 - | _ , N2n _ -> 1 - | Nneg n1 , Nneg n2 -> compare_nexps n1 n2 - | Nneg _ , _ -> -1 - | _ , Nneg _ -> 1 - | Npos_inf , Npos_inf -> 0 - | Npos_inf , _ -> -1 - | _ , Npos_inf -> 1 - | Ninexact , Ninexact -> 0 - -module NexpM = - struct - type t = nexp - let compare = compare_nexps -end -module Var_set = Set.Make(NexpM) -module Nexpmap = Finite_map.Fmap_map(NexpM) - -type nexp_map = nexp Nexpmap.t - -type constraint_origin = - | Patt of Parse_ast.l - | Expr of Parse_ast.l - | Fun of Parse_ast.l - | Specc of Parse_ast.l - -type range_enforcement = Require | Guarantee -type cond_kind = Positive | Negative | Solo | Switch -type 'a many = One of 'a | Two of 'a * 'a | Many of 'a list - -(* Constraints for nexps, plus the location which added the constraint *) -type nexp_range = - | LtEq of constraint_origin * range_enforcement * nexp * nexp - | Lt of constraint_origin * range_enforcement * nexp * nexp - | Eq of constraint_origin * nexp * nexp - | NtEq of constraint_origin * nexp * nexp - | GtEq of constraint_origin * range_enforcement * nexp * nexp - | Gt of constraint_origin * range_enforcement * nexp * nexp - | In of constraint_origin * string * int list - | InS of constraint_origin * nexp * int list - | Predicate of constraint_origin * nexp_range * nexp_range - | CondCons of constraint_origin * cond_kind * (nexp Nexpmap.t) option * nexp_range list * nexp_range list - | BranchCons of constraint_origin * ((nexp many) Nexpmap.t) option * nexp_range list - -type variable_range = - | VR_eq of string * nexp - | VR_range of string * nexp_range list - | VR_vec_eq of string * nexp - | VR_vec_r of string * nexp_range list - | VR_recheck of string * t (*For cases where inference hasn't yet determined the type of v*) - -type bounds_env = - | No_bounds - | Bounds of variable_range list * nexp_map option - -type t_params = (string * kind) list -type tannot = - | NoTyp - (*See .mli for purpose of attributes *) - | Base of (t_params * t) * tag * nexp_range list * effect * effect * bounds_env - (* First tannot is the most polymorphic version; the list includes all variants. All included t are Tfn *) - | Overload of tannot * bool * tannot list (* these tannot's should all be Base *) - -type 'a emap = 'a Envmap.t - -type rec_kind = Record | Register -type rec_env = (string * rec_kind * tannot * ((string * t) list)) -type alias_kind = OneReg of string * tannot | TwoReg of string * string * tannot | MultiReg of (string list) * tannot -type def_envs = { - k_env: kind emap; - abbrevs: tannot emap; - nabbrevs: nexp emap; - namesch : tannot emap; - enum_env : (string list) emap; - rec_env : rec_env list; - alias_env : alias_kind emap; - default_o : order; - } - -type triple = Yes | No | Maybe -let triple_negate = function - | Yes -> No - | No -> Yes - | Maybe -> Maybe - -type exp = tannot Ast.exp - -type minmax = (constraint_origin * nexp) option -type constraints = nexp_range list - -(*Nexpression Makers (as built so often)*) - -let mk_nv s = {nexp = Nvar s; imp_param = false} -let mk_nid s n = {nexp = Nid(s,n); imp_param = false} -let mk_add n1 n2 = {nexp = Nadd(n1,n2); imp_param = false} -let mk_sub n1 n2 = {nexp = Nsub(n1,n2); imp_param = false} -let mk_mult n1 n2 = {nexp = Nmult(n1,n2); imp_param = false} -let mk_c i = {nexp = Nconst i; imp_param = false} -let mk_c_int i = mk_c (big_int_of_int i) -let mk_neg n = {nexp = Nneg n; imp_param = false} -let mk_2n n = {nexp = N2n(n, None); imp_param = false} -let mk_2nc n i = {nexp = N2n(n, Some i); imp_param = false} -let mk_pow n i = {nexp = Npow(n, i); imp_param = false} -let mk_p_inf () = {nexp = Npos_inf; imp_param = false} -let mk_n_inf () = {nexp = Nneg_inf; imp_param = false} -let mk_inexact () = {nexp = Ninexact; imp_param = false} - -let merge_option_maps m1 m2 = - match m1,m2 with - | None,None -> None - | None,m | m, None -> m - | Some m1, Some m2 -> Some (Nexpmap.union m1 m2) - -(*Getters*) - -let get_index n = - match n.nexp with - | Nuvar {nindex = i} -> i - | _ -> assert false - -let get_c_loc = function - | Patt l | Expr l | Specc l | Fun l -> l - -let rec get_outer_most n = match n.nexp with - | Nuvar {outsubst= Some n} -> get_outer_most n - | _ -> n - -let rec get_inner_most n = match n.nexp with - | Nuvar {insubst=Some n} -> get_inner_most n - | _ -> n - -(*To string functions *) -let debug_mode = ref true;; - -let rec kind_to_string kind = match kind.k with - | K_Nat -> "Nat" - | K_Typ -> "Type" - | K_Ord -> "Order" - | K_Efct -> "Effect" - | K_infer -> "Infer" - | K_Val -> "Val" - | K_Lam (kinds,kind) -> "Lam [" ^ string_of_list ", " kind_to_string kinds ^ "] -> " ^ (kind_to_string kind) - -let co_to_string = function - | Patt l -> "Pattern " (*^ Reporting_basic.loc_to_string l *) - | Expr l -> "Expression " (*^ Reporting_basic.loc_to_string l *) - | Fun l -> "Function def " (*^ Reporting_basic.loc_to_string l *) - | Specc l -> "Specification " (*^ Reporting_basic.loc_to_string l *) - -let rec t_to_string t = - match t.t with - | Tid i -> i - | Tvar i -> i - | Tfn(t1,t2,imp,e) -> - let implicit = match imp with - | IP_none -> "" - | IP_length n | IP_start n | IP_user n -> " with implicit parameter " ^ n_to_string n ^ " " in - (t_to_string t1) ^ " -> " ^ (t_to_string t2) ^ " effect " ^ e_to_string e ^ implicit - | Ttup(tups) -> "(" ^ string_of_list ", " t_to_string tups ^ ")" - | Tapp(i,args) -> i ^ "<" ^ string_of_list ", " targ_to_string args ^ ">" - | Tabbrev(ti,ta) -> (t_to_string ti) ^ " : " ^ (t_to_string ta) - | Toptions(t1,None) -> if !debug_mode then ("optionally " ^ (t_to_string t1)) else (t_to_string t1) - | Toptions(t1,Some t2) -> if !debug_mode then ("(either "^ (t_to_string t1) ^ " or " ^ (t_to_string t2) ^ ")") else "_" - | Tuvar({index = i;subst = a}) -> - if !debug_mode then "Tu_" ^ string_of_int i ^ "("^ (match a with | None -> "None" | Some t -> t_to_string t) ^")" else "_" -and targ_to_string = function - | TA_typ t -> t_to_string t - | TA_nexp n -> n_to_string n - | TA_eft e -> e_to_string e - | TA_ord o -> o_to_string o -and n_to_string n = - match n.nexp with - | Nid(i,n) -> i ^ "(*" ^ (n_to_string n) ^ "*)" - | Nvar i -> i - | Nconst i -> string_of_big_int i - | Npos_inf -> "infinity" - | Nneg_inf -> "-infinity" - | Ninexact -> "infinity - infinity" - | Nadd(n1,n2) -> "("^ (n_to_string n1) ^ " + " ^ (n_to_string n2) ^")" - | Nsub(n1,n2) -> "("^ (n_to_string n1) ^ " - " ^ (n_to_string n2) ^ ")" - | Nmult(n1,n2) -> "(" ^ (n_to_string n1) ^ " * " ^ (n_to_string n2) ^ ")" - | N2n(n,None) -> "2**" ^ (n_to_string n) - | N2n(n,Some i) -> "2**" ^ (n_to_string n) ^ "(*" ^ (string_of_big_int i) ^ "*)" - | Npow(n, i) -> "(" ^ (n_to_string n) ^ ")**" ^ (string_of_int i) - | Nneg n -> "-" ^ (n_to_string n) - | Nuvar _ -> - if !debug_mode - then - let rec show_nuvar n = match n.nexp with - | Nuvar{insubst=None; nindex = i; orig_var = Some s} -> s^ "()" - | Nuvar{insubst=Some n; nindex = i; orig_var = Some s} -> s ^ "(" ^ show_nuvar n ^ ")" - | Nuvar{insubst=None; nindex = i;} -> "Nu_" ^ string_of_int i ^ "()" - | Nuvar{insubst=Some n; nindex =i;} -> "Nu_" ^ string_of_int i ^ "(" ^ show_nuvar n ^ ")" - | _ -> n_to_string n in - show_nuvar (get_outer_most n) - else "_" -and ef_to_string (Ast.BE_aux(b,l)) = - match b with - | Ast.BE_rreg -> "rreg" - | Ast.BE_wreg -> "wreg" - | Ast.BE_rmem -> "rmem" - | Ast.BE_rmemt -> "rmemt" - | Ast.BE_wmem -> "wmem" - | Ast.BE_wmv -> "wmv" - | Ast.BE_wmvt -> "wmvt" - | Ast.BE_eamem -> "eamem" - | Ast.BE_exmem -> "exmem" - | Ast.BE_barr -> "barr" - | Ast.BE_undef -> "undef" - | Ast.BE_depend -> "depend" - | Ast.BE_unspec-> "unspec" - | Ast.BE_nondet-> "nondet" - | Ast.BE_lset -> "lset" - | Ast.BE_lret -> "lret" - | Ast.BE_escape -> "escape" -and efs_to_string es = - match es with - | [] -> "" - | [ef] -> ef_to_string ef - | ef::es -> ef_to_string ef ^ ", " ^ efs_to_string es -and e_to_string e = - match e.effect with - | Evar i -> "'" ^ i - | Eset es -> if []=es then "pure" else "{" ^ (efs_to_string es) ^"}" - | Euvar({eindex=i;esubst=a}) -> if !debug_mode then string_of_int i ^ "()" else "_" -and o_to_string o = - match o.order with - | Ovar i -> "'" ^ i - | Oinc -> "inc" - | Odec -> "dec" - | Ouvar({oindex=i;osubst=a}) -> if !debug_mode then string_of_int i ^ "()" else "_" - -let rec tag_to_string = function - | Emp_local -> "Emp_local" - | Emp_global -> "Emp_global" - | Emp_intro -> "Emp_intro" - | Emp_set -> "Emp_set" - | Tuple_assign tags -> "Tuple_assign (" ^ string_of_list ", " tag_to_string tags ^ ")" - | External None -> "External" - | External (Some s) -> "External " ^ s - | Default -> "Default" - | Constructor _ -> "Constructor" - | Enum _ -> "Enum" - | Alias _ -> "Alias" - | Spec -> "Spec" - -let enforce_to_string = function - | Require -> "require" - | Guarantee -> "guarantee" - -let cond_kind_to_string = function - | Positive -> "positive" - | Negative -> "negative" - | Solo -> "solo" - | Switch -> "switch" - -let rec constraint_to_string = function - | LtEq (co,enforce,nexp1,nexp2) -> - "LtEq(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^ - n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | Lt (co,enforce,nexp1, nexp2) -> - "Lt(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^ - n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | Eq (co,nexp1,nexp2) -> - "Eq(" ^ co_to_string co ^ ", " ^ n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | NtEq(co,nexp1,nexp2) -> - "NtEq(" ^ co_to_string co ^ ", " ^ n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | GtEq (co,enforce,nexp1,nexp2) -> - "GtEq(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^ - n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | Gt (co,enforce,nexp1,nexp2) -> - "Gt(" ^ co_to_string co ^ ", " ^ enforce_to_string enforce ^ ", " ^ - n_to_string nexp1 ^ ", " ^ n_to_string nexp2 ^ ")" - | In(co,var,ints) -> "In of " ^ var - | InS(co,n,ints) -> "InS of " ^ n_to_string n - | Predicate(co,cp,cn) -> - "Pred(" ^ co_to_string co ^ ", " ^ constraint_to_string cp ^", " ^ constraint_to_string cn ^ ")" - | CondCons(co,kind,_,pats,exps) -> - "CondCons(" ^ co_to_string co ^ ", " ^ cond_kind_to_string kind ^ - ", [" ^ constraints_to_string pats ^ "], [" ^ constraints_to_string exps ^ "])" - | BranchCons(co,_,consts) -> - "BranchCons(" ^ co_to_string co ^ ", [" ^ constraints_to_string consts ^ "])" -and constraints_to_string l = string_of_list "; " constraint_to_string l - -let variable_range_to_string v = match v with - | VR_eq (s,n) -> "vr_eq(" ^ s ^ ", " ^ n_to_string n ^ ")" - | VR_range (s,cs) -> "vr_range(" ^ s ^ ", " ^ constraints_to_string cs ^ ")" - | VR_vec_eq (s,n) -> "vr_vec_eq(" ^ s ^ ", " ^ n_to_string n ^ ")" - | VR_vec_r (s,cs) -> "vr_vec_r(" ^ s ^ ", "^ constraints_to_string cs ^ ")" - | VR_recheck (s,t) -> "vr_recheck(" ^ s ^ ", "^ t_to_string t ^ ")" - -let bounds_to_string b = match b with - | No_bounds -> "Nobounds" - | Bounds(vs,map)-> "Bounds(" ^ string_of_list "; " variable_range_to_string vs ^ ")" - -let rec tannot_to_string = function - | NoTyp -> "No tannot" - | Base((vars,t),tag,ncs,ef_l,ef_r,bv) -> - "Tannot: type = " ^ (t_to_string t) ^ " tag = " ^ tag_to_string tag ^ " constraints = " ^ - constraints_to_string ncs ^ " effect_l = " ^ e_to_string ef_l ^ " effect_r = " ^ e_to_string ef_r ^ - "boundv = " ^ bounds_to_string bv - | Overload(poly,_,variants) -> - "Overloaded: poly = " ^ tannot_to_string poly - -(* nexp constants, commonly used*) -let n_zero = mk_c zero -let n_one = mk_c one -let n_two = mk_c two - -(*effect functions*) -let rec effect_remove_dups = function - | [] -> [] - | (BE_aux(be,l))::es -> - if (List.exists (fun (BE_aux(be',_)) -> be = be') es) - then effect_remove_dups es - else (BE_aux(be,l))::(effect_remove_dups es) - -let add_effect e ef = - match ef.effect with - | Evar s -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "add_effect given var instead of uvar") - | Eset bases -> {effect = Eset (effect_remove_dups (e::bases))} - | Euvar _ -> ef.effect <- Eset [e]; ef - -let union_effects e1 e2 = - match e1.effect,e2.effect with - | Evar s,_ | _,Evar s -> - raise (Reporting_basic.err_unreachable Parse_ast.Unknown "union_effects given var(s) instead of uvar(s)") - | Euvar _,_ -> e1.effect <- e2.effect; e2 - | _,Euvar _ -> e2.effect <- e1.effect; e2 - | Eset b1, Eset b2 -> - (*let _ = Printf.eprintf "union effects of length %s and %s\n" (e_to_string e1) (e_to_string e2) in*) - {effect= Eset (effect_remove_dups (b1@b2))} - -let remove_local_effects ef = match ef.effect with - | Evar _ | Euvar _ | Eset [] -> ef - | Eset effects -> - {effect = Eset (List.filter (fun (BE_aux(be,l)) -> (match be with | BE_lset | BE_lret -> false | _ -> true)) - (effect_remove_dups effects)) } - -let rec lookup_record_typ (typ : string) (env : rec_env list) : rec_env option = - match env with - | [] -> None - | ((id,_,_,_) as r)::env -> - if typ = id then Some(r) else lookup_record_typ typ env - -let rec fields_match f1 f2 = - match f1 with - | [] -> true - | f::fs -> (List.mem_assoc f f2) && fields_match fs f2 - -let rec lookup_record_fields (fields : string list) (env : rec_env list) : rec_env option = - match env with - | [] -> None - | ((id,r,t,fs) as re)::env -> - if ((List.length fields) = (List.length fs)) && - (fields_match fields fs) then - Some re - else lookup_record_fields fields env - -let rec lookup_possible_records (fields : string list) (env : rec_env list) : rec_env list = - match env with - | [] -> [] - | ((id,r,t,fs) as re)::env -> - if (((List.length fields) <= (List.length fs)) && - (fields_match fields fs)) - then re::(lookup_possible_records fields env) - else lookup_possible_records fields env - -let lookup_field_type (field: string) ((id,r_kind,tannot,fields) : rec_env) : t option = - if List.mem_assoc field fields - then Some(List.assoc field fields) - else None - -let rec pow_i i n = - match n with - | 0 -> one - | n -> mult_int_big_int i (pow_i i (n-1)) -let two_pow = pow_i 2 - -let is_bit_vector t = match t.t with - | Tapp("vector", [_;_;_; TA_typ t]) - | Tabbrev(_,{t=Tapp("vector",[_;_;_; TA_typ t])}) - | Tapp("reg", [TA_typ {t=Tapp("vector",[_;_;_; TA_typ t])}])-> - (match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) | Tapp("reg",[TA_typ {t=Tid "bit"}]) -> true - | _ -> false) - | _ -> false - -(* predicate to determine if pushing a constant in for addition or multiplication could change the form *) -let rec contains_const n = - match n.nexp with - | Nvar _ | Nuvar _ | Npow _ | N2n _ | Npos_inf | Nneg_inf | Ninexact -> false - | Nconst _ | Nid _ -> true - | Nneg n -> contains_const n - | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (contains_const n1) || (contains_const n2) - -let rec is_all_nuvar n = - match n.nexp with - | Nuvar { insubst = None } -> true - | Nuvar { insubst = Some n } -> is_all_nuvar n - | _ -> false - -let rec first_non_nu n = - match n.nexp with - | Nuvar {insubst = None } -> None - | Nuvar { insubst = Some n} -> first_non_nu n - | _ -> Some n - -(*Adds new_base to inner most position of n, when that is None - Report whether mutation happened*) -let add_to_nuvar_tail n new_base = - if n.nexp == new_base.nexp - then false - else - let n' = get_inner_most n in - let new_base' = get_outer_most new_base in - match n'.nexp,new_base'.nexp with - | Nuvar ({insubst = None} as nmu), Nuvar(nbmu) -> - nmu.insubst <- Some new_base'; - nbmu.outsubst <- Some n'; true - | Nuvar({insubst = None} as nmu),_ -> - if new_base.nexp == new_base'.nexp - then begin nmu.insubst <- Some new_base; true end - else false - | _ -> false - -let rec get_var n = - match n.nexp with - | Nvar _ | Nuvar _ | N2n _ -> Some n - | Nneg n -> get_var n - | Nmult (_,n1) -> get_var n1 - | _ -> None - -let rec get_all_nvar n = - match n.nexp with - | Nvar v -> [v] - | Nneg n | N2n(n,_) | Npow(n,_) -> get_all_nvar n - | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (get_all_nvar n1)@(get_all_nvar n2) - | _ -> [] - -let get_factor n = - match n.nexp with - | Nvar _ | Nuvar _ -> n_one - | Nmult (n1,_) -> n1 - | _ -> assert false - -let increment_factor n i = - match n.nexp with - | Nvar _ | Nuvar _ | N2n _-> - (match i.nexp with - | Nconst i -> - let ni = add_big_int i one in - if eq_big_int ni zero - then n_zero - else mk_mult (mk_c ni) n - | _ -> mk_mult (mk_add i n_one) n) - | Nmult(n1,n2) -> - (match n1.nexp,i.nexp with - | Nconst i2,Nconst i -> - let ni = add_big_int i i2 in - if eq_big_int ni zero - then n_zero - else mk_mult (mk_c(add_big_int i i2)) n2 - | _ -> mk_mult (mk_add n1 i) n2) - | _ -> let _ = Printf.eprintf "increment_factor failed with %s by %s\n" (n_to_string n) (n_to_string i) in assert false - -let negate n = match n.nexp with - | Nconst i -> mk_c (mult_int_big_int (-1) i) - | _ -> mk_mult (mk_c_int (-1)) n - -let odd n = (n mod 2) = 1 - -(*Expects a normalized nexp*) -let rec nexp_negative n = - match n.nexp with - | Nconst i -> if lt_big_int i zero then Yes else No - | Nneg_inf -> Yes - | Npos_inf | N2n _ | Nvar _ | Nuvar _ -> No - | Nmult(n1,n2) -> (match nexp_negative n1, nexp_negative n2 with - | Yes,Yes | No, No -> No - | No, Yes | Yes, No -> Yes - | Maybe,_ | _, Maybe -> Maybe) - | Nadd(n1,n2) -> (match nexp_negative n1, nexp_negative n2 with - | Yes,Yes -> Yes - | No, No -> No - | _ -> Maybe) - | Npow(n1,i) -> - (match nexp_negative n1 with - | Yes -> if odd i then Yes else No - | No -> No - | Maybe -> if odd i then Maybe else No) - | _ -> Maybe - -let rec normalize_n_rec recur_ok n = - (*let _ = Printf.eprintf "Working on normalizing %s\n" (n_to_string n) in *) - match n.nexp with - | Nid(_,n) -> normalize_n_rec true n - | Nuvar _ -> - (match first_non_nu (get_outer_most n) with - | None -> n - | Some n' -> n') - | Nconst _ | Nvar _ | Npos_inf | Nneg_inf | Ninexact -> n - | Nneg n -> - let n',to_recur,add_neg = (match n.nexp with - | Nconst i -> negate n,false,false - | Nadd(n1,n2) -> mk_add (negate n1) (negate n2),true,false - | Nsub(n1,n2) -> mk_sub n2 n1,true,false - | Nneg n -> n,true,false - | _ -> n,true,true) in - if to_recur - then (let n' = normalize_n_rec true n' in - if add_neg - then negate n' - else n') - else n' - | Npow(n,i) -> - let n' = normalize_n_rec true n in - (match n'.nexp with - | Nconst n -> mk_c (pow_i i (int_of_big_int n)) - | _ -> mk_pow n' i) - | N2n(n', Some i) -> n (*Because there is a value for Some, we know this is normalized and n' is constant*) - | N2n(n, None) -> - let n' = normalize_n_rec true n in - (match n'.nexp with - | Nconst i -> mk_2nc n' (two_pow (int_of_big_int i)) - | _ -> mk_2n n') - | Nadd(n1,n2) -> - let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in - (match n1'.nexp,n2'.nexp, recur_ok with - | Nneg_inf, Npos_inf,_ | Npos_inf, Nneg_inf,_ -> mk_inexact() - | Npos_inf, _,_ | _, Npos_inf, _ -> mk_p_inf() - | Nneg_inf, _,_ | _, Nneg_inf, _ -> mk_n_inf() - | Nconst i1, Nconst i2,_ | Nconst i1, N2n(_,Some i2),_ - | N2n(_,Some i2), Nconst i1,_ | N2n(_,Some i1),N2n(_,Some i2),_ - -> mk_c (add_big_int i1 i2) - | Nadd(n11,n12), Nconst i, true -> - if (eq_big_int i zero) then n1' - else normalize_n_rec false (mk_add n11 (normalize_n_rec false (mk_add n12 n2'))) - | Nadd(n11,n12), Nconst i, false -> - if (eq_big_int i zero) then n1' - else mk_add n11 (normalize_n_rec false (mk_add n12 n2')) - | Nconst i, Nadd(n21,n22), true -> - if (eq_big_int i zero) then n2' - else normalize_n_rec false (mk_add n21 (normalize_n_rec false (mk_add n22 n1'))) - | Nconst i, Nadd(n21,n22), false -> - if (eq_big_int i zero) then n2' - else mk_add n21 (normalize_n_rec false (mk_add n22 n1')) - | Nconst i, _,_ -> if (eq_big_int i zero) then n2' else mk_add n2' n1' - | _, Nconst i,_ -> if (eq_big_int i zero) then n1' else mk_add n1' n2' - | Nvar _, Nuvar _,_ | Nvar _, N2n _,_ | Nuvar _, Npow _,_ | Nuvar _, N2n _,_ -> mk_add n2' n1' - | Nadd(n11,n12), Nadd(n21,n22), true -> - (match compare_nexps n11 n21 with - | -1 -> normalize_n_rec false (mk_add n11 (normalize_n_rec false (mk_add n12 n2'))) - | 0 -> - (match compare_nexps n12 n22 with - | -1 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n22 n12)) - | 0 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_mult n_two n12)) - | _ -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n12 n22))) - | _ -> normalize_n_rec false (mk_add n21 (normalize_n_rec false (mk_add n22 n1')))) - | Nadd(n11,n12), Nadd(n21,n22), false -> - (match compare_nexps n11 n21 with - | -1 -> mk_add n11 (normalize_n_rec false (mk_add n12 n2')) - | 0 -> - (match compare_nexps n12 n22 with - | -1 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n22 n12)) - | 0 -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_mult n_two n12)) - | _ -> normalize_n_rec true (mk_add (mk_mult n_two n11) (mk_add n12 n22))) - | _ -> mk_add n21 (normalize_n_rec false (mk_add n22 n1'))) - | N2n(n11,_), N2n(n21,_),_ -> - (match compare_nexps n11 n21 with - | -1 -> mk_add n2' n1' - | 0 -> mk_2n (normalize_n_rec true (mk_add n11 n_one)) - | _ -> mk_add n1' n2') - | Npow(n11,i1), Npow (n21,i2),_ -> - (match compare_nexps n11 n21, compare i1 i2 with - | -1,-1 | 0,-1 -> mk_add n2' n1' - | 0,0 -> mk_mult n_two n1' - | _ -> mk_add n1' n2') - | N2n(n11,Some i),Nadd(n21,n22),_ -> - normalize_n_rec true (mk_add n21 (mk_add n22 (mk_c i))) - | Nadd(n11,n12), N2n(n21,Some i),_ -> - normalize_n_rec true (mk_add n11 (mk_add n12 (mk_c i))) - | N2n(n11,None),Nadd(n21,n22),_ -> - (match n21.nexp with - | N2n(n211,_) -> - (match compare_nexps n11 n211 with - | -1 -> mk_add n1' n2' - | 0 -> mk_add (mk_2n (normalize_n_rec true (mk_add n11 n_one))) n22 - | _ -> mk_add n21 (normalize_n_rec true (mk_add n11 n22))) - | _ -> mk_add n1' n2') - | Nadd(n11,n12),N2n(n21,None),_ -> - (match n11.nexp with - | N2n(n111,_) -> - (match compare_nexps n111 n21 with - | -1 -> mk_add n11 (normalize_n_rec true (mk_add n2' n12)) - | 0 -> mk_add (mk_2n (normalize_n_rec true (mk_add n111 n_one))) n12 - | _ -> mk_add n2' n1') - | _ -> mk_add n2' n1') - | _ -> - (match get_var n1', get_var n2' with - | Some(nv1),Some(nv2) -> - (match compare_nexps nv1 nv2 with - | -1 -> mk_add n2' n1' - | 0 -> increment_factor n1' (get_factor n2') - | _ -> mk_add n1' n2') - | Some(nv1),None -> mk_add n2' n1' - | None,Some(nv2) -> mk_add n1' n2' - | _ -> (match n1'.nexp,n2'.nexp with - | Nadd(n11',n12'), _ -> - (match compare_nexps n11' n2' with - | -1 -> mk_add n2' n1' - | 1 -> mk_add n11' (normalize_n_rec true (mk_add n12' n2')) - | _ -> let _ = Printf.eprintf "Neither term has var but are the same? %s %s\n" - (n_to_string n1') (n_to_string n2') in assert false) - | (_, Nadd(n21',n22')) -> - (match compare_nexps n1' n21' with - | -1 -> mk_add n21' (normalize_n_rec true (mk_add n1' n22')) - | 1 -> mk_add n1' n2' - | _ -> let _ = Printf.eprintf "pattern didn't match unexpextedly here %s %s\n" - (n_to_string n1') (n_to_string n2') in assert false) - | _ -> - (match compare_nexps n1' n2' with - | -1 -> mk_add n2' n1' - | 0 -> normalize_n_rec true (mk_mult n_two n1') - | _ -> mk_add n1' n2')))) - | Nsub(n1,n2) -> - let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in - (*let _ = Printf.eprintf "Normalizing subtraction of %s - %s \n" (n_to_string n1') (n_to_string n2') in*) - (match n1'.nexp,n2'.nexp with - | Nneg_inf, Npos_inf | Npos_inf, Nneg_inf -> mk_inexact() - | Npos_inf, _ | _,Nneg_inf -> mk_p_inf() - | Nneg_inf, _ | _,Npos_inf -> mk_n_inf() - | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some i2) | N2n(_,Some i1), Nconst i2 | N2n(_,Some i1), N2n(_,Some i2)-> - (*let _ = Printf.eprintf "constant subtraction of %s - %s gives %s" (Big_int.string_of_big_int i1) (Big_int.string_of_big_int i2) (Big_int.string_of_big_int (sub_big_int i1 i2)) in*) - mk_c (sub_big_int i1 i2) - | Nconst i, _ -> - if (eq_big_int i zero) - then normalize_n_rec true (negate n2') - else normalize_n_rec true (mk_add (negate n2') n1') - | _, Nconst i -> - if (eq_big_int i zero) - then n1' - else normalize_n_rec true (mk_add n1' (mk_c (mult_int_big_int (-1) i))) - | _,_ -> - (match compare_nexps n1 n2 with - | 0 -> n_zero - | -1 -> mk_add (negate n2') n1' - | _ -> mk_add n1' (negate n2'))) - | Nmult(n1,n2) -> - let n1',n2' = normalize_n_rec true n1, normalize_n_rec true n2 in - (match n1'.nexp,n2'.nexp with - | Nneg_inf,Nneg_inf -> mk_p_inf() - | Npos_inf, Nconst i | Nconst i, Npos_inf -> - if eq_big_int i zero then n_zero else mk_p_inf() - | Nneg_inf, Nconst i | Nconst i, Nneg_inf -> - if eq_big_int i zero then n_zero - else if lt_big_int i zero then mk_p_inf() - else mk_n_inf() - | Nneg_inf, _ | _, Nneg_inf -> - (match nexp_negative n1, nexp_negative n2 with - | Yes, Yes -> mk_p_inf() - | _ -> mk_n_inf()) - | Npos_inf, _ | _, Npos_inf -> - (match nexp_negative n1, nexp_negative n2 with - | Yes, Yes -> assert false (*One of them must be Npos_inf, so nexp_negative horribly broken*) - | No, Yes | Yes, No -> mk_n_inf() - | _ -> mk_p_inf()) - | Ninexact, _ | _, Ninexact -> mk_inexact() - | Nconst i1, Nconst i2 -> mk_c (mult_big_int i1 i2) - | Nconst i1, N2n(n,Some i2) | N2n(n,Some i2),Nconst i1 -> - if eq_big_int i1 two - then mk_2nc (normalize_n_rec true (mk_add n n_one)) (mult_big_int i1 i2) - else mk_c (mult_big_int i1 i2) - | Nconst i1, N2n(n,None) | N2n(n,None),Nconst i1 -> - if eq_big_int i1 two - then mk_2n (normalize_n_rec true (mk_add n n_one)) - else mk_mult (mk_c i1) (mk_2n n) - | (Nmult (_, _), (Nvar _|Npow (_, _)|Nuvar _)) -> mk_mult n1' n2' - | Nvar _, Nuvar _ -> mk_mult n2' n1' - | N2n(n1,Some i1),N2n(n2,Some i2) -> mk_2nc (normalize_n_rec true (mk_add n1 n2)) (mult_big_int i1 i2) - | N2n(n1,_), N2n(n2,_) -> mk_2n (normalize_n_rec true (mk_add n1 n2)) - | N2n _, Nvar _ | N2n _, Nuvar _ | N2n _, Nmult _ | Nuvar _, N2n _ -> mk_mult n2' n1' - | Nuvar _, Nuvar _ | Nvar _, Nvar _ -> - (match compare n1' n2' with - | 0 -> mk_pow n1' 2 - | 1 -> mk_mult n1' n2' - | _ -> mk_mult n2' n1') - | Npow(n1,i1),Npow(n2,i2) -> - (match compare_nexps n1 n2 with - | 0 -> mk_pow n1 (i1+i2) - | -1 -> mk_mult n2' n1' - | _ -> mk_mult n1' n2') - | Nconst _, Nadd(n21,n22) | Nvar _,Nadd(n21,n22) | Nuvar _,Nadd(n21,n22) | N2n _, Nadd(n21,n22) - | Npow _,Nadd(n21,n22) | Nmult _, Nadd(n21,n22) -> - normalize_n_rec true (mk_add (mk_mult n1' n21) (mk_mult n1' n21)) - | Nadd(n11,n12),Nconst _ | Nadd(n11,n12),Nvar _ | Nadd(n11,n12), Nuvar _ | Nadd(n11,n12), N2n _ - | Nadd(n11,n12),Npow _ | Nadd(n11,n12), Nmult _-> - normalize_n_rec true (mk_add (mk_mult n11 n2') (mk_mult n12 n2')) - | Nmult(n11,n12), Nconst _ -> mk_mult (mk_mult n11 n2') (mk_mult n12 n2') - | Nconst i1, _ -> - if (eq_big_int i1 zero) then n1' - else if (eq_big_int i1 one) then n2' - else mk_mult n1' n2' - | _, Nconst i1 -> - if (eq_big_int i1 zero) then n2' - else if (eq_big_int i1 one) then n1' - else mk_mult n2' n1' - | Nadd(n11,n12),Nadd(n21,n22) -> - normalize_n_rec true (mk_add (mk_mult n11 n21) - (mk_add (mk_mult n11 n22) - (mk_add (mk_mult n12 n21) (mk_mult n12 n22)))) - | Nuvar _, Nvar _ | Nmult _, N2n _-> mk_mult n1' n2' - | Nuvar _, Nmult(n1,n2) | Nvar _, Nmult(n1,n2) -> (*TODO What's happend to n1'*) - (match get_var n1, get_var n2 with - | Some(nv1),Some(nv2) -> - (match compare_nexps nv1 nv2, n2.nexp with - | 0, Nuvar _ | 0, Nvar _ -> mk_mult n1 (mk_pow nv1 2) - | 0, Npow(n2',i) -> mk_mult n1 (mk_pow n2' (i+1)) - | -1, Nuvar _ | -1, Nvar _ -> mk_mult n2' n1' - | _,_ -> mk_mult (normalize_n_rec true (mk_mult n1 n1')) n2) - | _ -> mk_mult (normalize_n_rec true (mk_mult n1 n1')) n2) - | (Npow (n1, i), (Nvar _ | Nuvar _)) -> - (match compare_nexps n1 n2' with - | 0 -> mk_pow n1 (i+1) - | _ -> mk_mult n1' n2') - | (Npow (_, _), N2n (_, _)) | (Nvar _, (N2n (_, _)|Npow (_, _))) | (Nuvar _, Npow (_, _)) -> mk_mult n2' n1' - | (N2n (_, _), Npow (_, _)) -> mk_mult n1' n2' - | Npow(n1,i),Nmult(n21,n22) -> - (match get_var n1, get_var n2 with - | Some(nv1),Some(nv2) -> - (match compare_nexps nv1 nv2,n22.nexp with - | 0, Nuvar _ | 0, Nvar _ -> mk_mult n21 (mk_pow n1 (i+1)) - | 0, Npow(_,i2) -> mk_mult n21 (mk_pow n1 (i+i2)) - | 1,Npow _ -> mk_mult (normalize_n_rec true (mk_mult n21 n1')) n22 - | _ -> mk_mult n2' n1') - | _ -> mk_mult (normalize_n_rec true (mk_mult n1' n21)) n22) - | Nmult _ ,Nmult(n21,n22) -> mk_mult (mk_mult n21 n1') (mk_mult n22 n1') - | Nsub _, _ | _, Nsub _ -> - let _ = Printf.eprintf "nsub case still around %s\n" (n_to_string n) in assert false - | Nneg _,_ | _,Nneg _ -> - let _ = Printf.eprintf "neg case still around %s\n" (n_to_string n) in assert false - | Nid _, _ | _, Nid _ -> - let _ = Printf.eprintf "nid case still around %s\n" (n_to_string n) in assert false - (* If things are normal, neg should be gone. *) - ) - -let normalize_nexp = normalize_n_rec true - -let int_to_nexp = mk_c_int - -let v_count = ref 0 -let t_count = ref 0 -let tuvars = ref [] -let n_count = ref 0 -let nuvars = ref [] -let o_count = ref 0 -let ouvars = ref [] -let e_count = ref 0 -let euvars = ref [] - -let reset_fresh _ = - begin v_count := 0; - t_count := 0; - tuvars := []; - n_count := 0; - nuvars := []; - o_count := 0; - ouvars := []; - e_count := 0; - euvars := []; - end -let new_id _ = - let i = !v_count in - v_count := i+1; - (string_of_int i) ^ "v" -let new_t _ = - let i = !t_count in - t_count := i + 1; - let t = {t = Tuvar { index = i; subst = None ; torig_name = None}} in - tuvars := t::!tuvars; - t -let new_tv rv = - let i = !t_count in - t_count := i + 1; - let t = {t = Tuvar { index = i; subst = None ; torig_name = Some rv}} in - tuvars := t::!tuvars; - t -let new_n _ = - let i = !n_count in - n_count := i + 1; - let n = { nexp = Nuvar { nindex = i; insubst = None; outsubst = None; - nin = false ; leave_var = false; orig_var = None; been_collapsed = false}; - imp_param = false} in - nuvars := n::!nuvars; - n -let new_nv s = - let i = !n_count in - n_count := i + 1; - let n = { nexp = Nuvar { nindex = i; insubst = None ; outsubst = None; - nin = false ; leave_var = false ; orig_var = Some s; been_collapsed = false}; - imp_param = false} in - nuvars := n::!nuvars; - n -let leave_nuvar n = match n.nexp with - | Nuvar u -> u.leave_var <- true; n - | _ -> n -let set_imp_param n = - match n.nexp with - | Nconst _ | Ninexact | Npos_inf | Nneg_inf -> () - | _ -> n.imp_param <- true - -let new_o _ = - let i = !o_count in - o_count := i + 1; - let o = { order = Ouvar { oindex = i; osubst = None }} in - ouvars := o::!ouvars; - o -let new_e _ = - let i = !e_count in - e_count := i + 1; - let e = { effect = Euvar { eindex = i; esubst = None }} in - euvars := e::!euvars; - e - -exception Occurs_exn of t_arg -let rec resolve_tsubst (t : t) : t = - (*let _ = Printf.eprintf "resolve_tsubst on %s\n" (t_to_string t) in*) - match t.t with - | Tuvar({ subst=Some(t') } as u) -> - let t'' = resolve_tsubst t' in - (match t''.t with - | Tuvar(_) -> u.subst <- Some(t''); t'' - | x -> t.t <- x; t) - | _ -> t -let rec resolve_osubst (o : order) : order = match o.order with - | Ouvar({ osubst=Some(o') } as u) -> - let o'' = resolve_osubst o' in - (match o''.order with - | Ouvar(_) -> u.osubst <- Some(o''); o'' - | x -> o.order <- x; o) - | _ -> o -let rec resolve_esubst (e : effect) : effect = match e.effect with - | Euvar({ esubst=Some(e') } as u) -> - let e'' = resolve_esubst e' in - (match e''.effect with - | Euvar(_) -> u.esubst <- Some(e''); e'' - | x -> e.effect <- x; e) - | _ -> e - -let rec occurs_check_t (t_box : t) (t : t) : unit = - let t = resolve_tsubst t in - if t_box == t then - raise (Occurs_exn (TA_typ t)) - else - match t.t with - | Tfn(t1,t2,_,_) -> - occurs_check_t t_box t1; - occurs_check_t t_box t2 - | Ttup(ts) -> - List.iter (occurs_check_t t_box) ts - | Tapp(_,targs) -> List.iter (occurs_check_ta (TA_typ t_box)) targs - | Tabbrev(t,ta) -> occurs_check_t t_box t; occurs_check_t t_box ta - | Toptions(t1,None) -> occurs_check_t t_box t1 - | Toptions(t1,Some t2) -> occurs_check_t t_box t1; occurs_check_t t_box t2 - | _ -> () -and occurs_check_ta (ta_box : t_arg) (ta : t_arg) : unit = - match ta_box,ta with - | TA_typ tbox,TA_typ t -> occurs_check_t tbox t - | TA_nexp nbox, TA_nexp n -> occurs_check_n nbox n - | TA_ord obox, TA_ord o -> occurs_check_o obox o - | TA_eft ebox, TA_eft e -> occurs_check_e ebox e - | _,_ -> () -(*light-weight occurs check, does not look within nuvar chains*) -and occurs_check_n (n_box : nexp) (n : nexp) : unit = - if n_box.nexp == n.nexp then - raise (Occurs_exn (TA_nexp n)) - else - match n.nexp with - | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> occurs_check_n n_box n1; occurs_check_n n_box n2 - | N2n(n,_) | Nneg n | Npow(n,_) -> occurs_check_n n_box n - | _ -> () -and occurs_check_o (o_box : order) (o : order) : unit = - let o = resolve_osubst o in - if o_box == o then - raise (Occurs_exn (TA_ord o)) - else () -and occurs_check_e (e_box : effect) (e : effect) : unit = - let e = resolve_esubst e in - if e_box == e then - raise (Occurs_exn (TA_eft e)) - else () - -(* Is checking for structural equality only, other forms of equality will be handeled by constraints *) -let rec nexp_eq_check n1 n2 = - match n1.nexp,n2.nexp with - | Npos_inf,Npos_inf | Nneg_inf,Nneg_inf | Ninexact,Ninexact -> true - | Nvar v1,Nvar v2 -> v1=v2 - | Nconst n1,Nconst n2 -> eq_big_int n1 n2 - | Nadd(nl1,nl2), Nadd(nr1,nr2) | Nmult(nl1,nl2), Nmult(nr1,nr2) | Nsub(nl1,nl2),Nsub(nr1,nr2) - -> nexp_eq_check nl1 nr1 && nexp_eq_check nl2 nr2 - | N2n(n,Some i),N2n(n2,Some i2) -> eq_big_int i i2 - | N2n(n,_),N2n(n2,_) -> nexp_eq_check n n2 - | Nneg n,Nneg n2 -> nexp_eq_check n n2 - | Npow(n1,i1),Npow(n2,i2) -> i1=i2 && nexp_eq_check n1 n2 - | Nuvar _,Nuvar _ -> - let n1_in,n2_in = get_inner_most n1, get_inner_most n2 in - (match n1_in.nexp, n2_in.nexp with - | Nuvar{insubst=None; nindex=i1},Nuvar{insubst=None; nindex=i2} -> i1 = i2 - | _ -> nexp_eq_check n1_in n2_in) - | _,_ -> false - -let nexp_eq n1 n2 = -(* let _ = Printf.eprintf "comparing nexps %s and %s\n" (n_to_string n1) (n_to_string n2) in*) - let b = nexp_eq_check (normalize_nexp n1) (normalize_nexp n2) in -(* let _ = Printf.eprintf "compared nexps %s\n" (string_of_bool b) in*) - b - - -(*determine if ne is divisble without remainder by n, - for now considering easily checked divisibility: - i.e. if ne is 2^n, where we otherwhere assume n>0 we just check for 2, - not for numbers 2^m where n >= m -*) -let divisible_by ne n = - let num,var,uvar,immediate_answer = match n.nexp with - | Nconst i | N2n(_,Some i)-> - if eq_big_int i unit_big_int || eq_big_int i (minus_big_int unit_big_int) - then None,None,None,Some true - else Some i,None,None,None - | Nvar v -> None, Some(v), None, None - | Nuvar _ -> None, None, Some(get_index n), None - | _ -> None, None, None, Some(false) - in - match immediate_answer with - | Some answer -> answer - | None -> - let rec walk_nexp n = match n.nexp with - | Npos_inf | Nneg_inf -> true - | Ninexact -> false - | Nvar v -> - (match var with - | Some v' -> v = v' - | _ -> false) - | Nuvar _ -> - (match uvar with - | Some n' -> (get_index n) = n' - | _ -> false) - | Nconst i | N2n(_,Some i) -> - (match num with - | Some i' -> eq_big_int (mod_big_int i i') zero_big_int - | _ -> false) - | N2n(n,_) -> - (match num with - | Some i -> eq_big_int i (big_int_of_int 2) - | _ -> false) - | Npow(n,_) | Nneg n | Nid(_,n) -> walk_nexp n - | Nmult(n1,n2) -> walk_nexp n1 || walk_nexp n2 - | Nadd(n1,n2) | Nsub(n1,n2) -> walk_nexp n1 && walk_nexp n2 - in walk_nexp ne - -(*divide ne by n, only gives correct answer when divisible_by is true*) -let divide_by ne n = - let num,var,uvar,immediate_answer = match n.nexp with - | Nconst i | N2n(_,Some i)-> - if eq_big_int i unit_big_int - then None,None,None,Some n - else if eq_big_int i (minus_big_int unit_big_int) - then None,None,None,Some (mk_neg n) - else Some i,None,None,None - | Nvar v -> None, Some(v), None, None - | Nuvar _ -> None, None, Some(get_index n), None - | _ -> None, None, None, Some n - in - match immediate_answer with - | Some answer -> answer - | None -> - let rec walk_nexp n = match n.nexp with - | Nid(_,n) -> walk_nexp n - | Npos_inf -> - (match num with - | Some(i) -> if lt_big_int i zero_big_int then mk_n_inf() else n - | _ -> n) - | Nneg_inf -> - (match num with - | Some(i) -> if lt_big_int i zero_big_int then mk_p_inf() else n - | _ -> n) - | Ninexact -> n - | Nvar v -> - (match var with - | Some v' -> if v = v' then n_one else n - | _ -> n) - | Nuvar _ -> - (match uvar with - | Some n' -> if (get_index n) = n' then n_one else n - | _ -> n) - | Nconst i | N2n(_,Some i) -> - (match num with - | Some i' -> mk_c (div_big_int i i') - | _ -> n) - | N2n(n1,_) -> - (match num with - | Some i -> if eq_big_int i (big_int_of_int 2) then mk_2n (mk_sub n1 n_one) else n - | _ -> n) - | Npow(nv,i) -> - (match nv.nexp,var,uvar with - | Nvar v, Some v', None -> if v = v' then mk_pow nv (i-1) else n - | Nuvar _,None, Some i -> if (get_index nv) = i then mk_pow nv (i-1) else n - | _ -> n) - | Nneg n -> mk_neg (walk_nexp n) - | Nmult(n1,n2) -> mk_mult (walk_nexp n1) (walk_nexp n2) - | Nadd(n1,n2) -> mk_add (walk_nexp n1) (walk_nexp n2) - | Nsub(n1,n2) -> mk_sub (walk_nexp n1) (walk_nexp n2) - in walk_nexp ne - -(*Remove nv (assumed to be either a nuvar or an nvar) from ne as much as possible. - Due to requiring integral values only, as well as variables multiplied by others, - there might be some non-removable factors - Returns the variable with any non-removable factors, and the rest of the expression -*) -let isolate_nexp nv ne = - let normal_ne = normalize_nexp ne in - let var,uvar = match nv.nexp with - | Nvar v -> Some v, None - | Nuvar _ -> None, Some (get_index nv) - | _ -> None, None in - (* returns isolated_nexp, - option nv plus any factors, - option factors other than 1, - bool whether factors need to be divided from other terms*) - let rec remove_from ne = match ne.nexp with - | Nid(_,n) -> remove_from n - | Npos_inf | Nneg_inf | Ninexact | Nconst _ | N2n(_,Some _)-> ne,None,None,false - | Nvar v -> - (match var with - | Some v' -> if v = v' then (n_zero,Some ne,None,false) else (ne,None,None,false) - | _ -> (ne,None,None,false)) - | Nuvar _ -> - (match uvar with - | Some n' -> if (get_index ne) = n' then n_zero,Some ne,None,false else ne,None,None,false - | _ -> ne,None,None,false) - | N2n(n1,_) | Npow(n1,_)-> - (match remove_from n1 with - | (_, None,_,_) -> ne,None,None,false - | (_,Some _,_,_) -> (n_zero,Some ne,Some ne,false)) - | Nneg n -> assert false (*Normal forms shouldn't have nneg*) - | Nmult(n1,n2) -> - (match (remove_from n1, remove_from n2) with - | (_, None,_,_),(_,None,_,_) -> (ne,None,None,false) - | (_, None,_,_),(nv,Some n,None,false) -> - if nexp_eq n1 n_one - then (nv,Some n, None, false) - else (n_zero, Some n, Some n1, true) - | (_, None,_,_),(nv, Some n, Some nf, true) -> - (nv, Some(mk_mult n1 n2), Some (mk_mult n1 nf), true) - | (_, None,_,_), (nv, Some n, Some nf, false) -> - (nv, Some (mk_mult n1 n2), Some (mk_mult n1 n2), false) - | _ -> (n_zero, Some ne, Some ne, false)) - | Nadd(n1,n2) -> - (match (remove_from n1, remove_from n2) with - | (_,None,_,_),(_,None,_,_) -> ne,None,None,false - | (new_n1,Some nv,factor,try_factor),(_,None,_,_) -> (mk_add new_n1 n2, Some nv,factor,try_factor) - | (_, None,_,_),(new_n2,Some nv,factor,try_factor) -> (mk_add n1 new_n2, Some nv,factor, try_factor) - | (nn1, Some nv1,Some f1,true), (nn2, Some nv2,Some f2,true) -> - if nexp_eq nv1 nv2 - then (mk_add nn1 nn2, Some nv1, Some (mk_add f1 f2), true) - else (mk_add nn1 nn2, Some (mk_add nv1 nv2), Some (mk_add f1 f2), false) - | (nn1, _,_,_),(nn2,_,_,_) -> - (mk_add nn1 nn2, Some ne, Some ne, false) (*It's all gone horribly wrong, punt*)) - | Nsub(n1,n2) -> assert false in (*Normal forms shouldn't have nsub*) - let (new_ne,new_nv,new_factor,attempt_factor) = remove_from normal_ne in - let new_ne = normalize_nexp new_ne in - match new_nv with - | None -> None,None, new_ne - | Some n_nv -> - (match n_nv.nexp,new_factor,attempt_factor with - | Nvar _, None, _ | Nuvar _, None, _ -> (Some n_nv,None,new_ne) - | Nvar _, Some f, true | Nuvar _, Some f, true -> - if divisible_by new_ne f - then (Some n_nv, Some f, normalize_nexp (divide_by new_ne f)) - else (Some (mk_mult f n_nv), None, new_ne) - | Nconst _,_,_ | Ninexact,_,_ | Npos_inf,_,_ | Nneg_inf,_,_ | Nid _,_,_ -> assert false (*double oh my*) - | N2n _,_,_ | Npow _,_,_ | Nadd _,_,_ | Nneg _,_,_ | Nsub _,_,_ | Nvar _,_,false | Nuvar _,_,false - -> (Some n_nv,None, new_ne) - | Nmult(n1,n2),_,_ -> - if nexp_eq n1 n_nv - then if divisible_by new_ne n2 - then (Some n1, Some n2, normalize_nexp (divide_by new_ne n2)) - else (Some n_nv, None, new_ne) - else if nexp_eq n2 n_nv - then if divisible_by new_ne n1 - then (Some n2, Some n1, normalize_nexp (divide_by new_ne n1)) - else (Some n_nv, None, new_ne) - else assert false (*really bad*)) - -let nexp_one_more_than n1 n2 = - let n1,n2 = (normalize_nexp (normalize_nexp n1)), (normalize_nexp (normalize_nexp n2)) in - match n1.nexp,n2.nexp with - | Nconst i, Nconst j -> (int_of_big_int i) = (int_of_big_int j)+1 - | _, Nsub(n2',{nexp = Nconst i}) -> - if (int_of_big_int i) = 1 then nexp_eq n1 n2' else false - | _, Nadd(n2',{nexp = Nconst i}) -> - if (int_of_big_int i) = -1 then nexp_eq n1 n2' else false - | Nadd(n1',{nexp = Nconst i}),_ -> - if (int_of_big_int i) = 1 then nexp_eq n1' n2 else false - | _ -> false - - -let rec nexp_gt_compare eq_ok n1 n2 = - let n1,n2 = (normalize_nexp (get_inner_most n1), normalize_nexp (get_inner_most n2)) in - let ge_test = if eq_ok then ge_big_int else gt_big_int in - let is_eq = nexp_eq n1 n2 in - if eq_ok && is_eq - then Yes - else if (not eq_ok) && is_eq then No - else - match n1.nexp,n2.nexp with - | Nconst i, Nconst j | N2n(_,Some i), N2n(_,Some j)-> if ge_test i j then Yes else No - | Npos_inf, _ | _, Nneg_inf -> Yes - | Nuvar _, Npos_inf | Nneg_inf, Nuvar _ -> if eq_ok then Maybe else No - | Nneg_inf, _ | _, Npos_inf -> No - | Ninexact, _ | _, Ninexact -> Maybe - | N2n(n1,_), N2n(n2,_) -> nexp_gt_compare eq_ok n1 n2 - | Nmult(n11,n12), Nmult(n21,n22) -> - if nexp_eq n12 n22 - then nexp_gt_compare eq_ok n11 n21 - else Maybe - | Nmult(n11,n12), _ -> - if nexp_eq n12 n2 - then triple_negate (nexp_negative n11) - else Maybe - | _, Nmult(n21,n22) -> - if nexp_eq n1 n22 - then nexp_negative n21 - else Maybe - | Nadd(n11,n12),Nadd(n21,n22) -> - (match (nexp_gt_compare eq_ok n11 n21, nexp_gt_compare eq_ok n12 n22, - (nexp_negative n11, nexp_negative n12, nexp_negative n21, nexp_negative n22)) with - | Yes, Yes, (No, No, No, No) -> Yes - | No, No, (No, No, No, No) -> No - | _ -> Maybe) - | Nadd(n11,n12), _ -> - if nexp_eq n11 n2 - then triple_negate (nexp_negative n12) - else if nexp_eq n12 n2 - then triple_negate (nexp_negative n11) - else Maybe - | _ , Nadd(n21,n22) -> - if nexp_eq n1 n21 - then nexp_negative n22 - else if nexp_eq n1 n22 - then nexp_negative n21 - else Maybe - | Npow(n11,i1), Npow(n21, i2) -> - if nexp_eq n11 n21 - then if i1 >= i2 then Yes else No - else Maybe - | Npow(n11,i1), _ -> - if nexp_eq n11 n2 - then if i1 = 0 then No else Yes - else Maybe - | _, Npow(n21,i2) -> - if nexp_eq n1 n21 - then if i2 = 0 then Yes else No - else Maybe - | _ -> Maybe - -let nexp_ge = nexp_gt_compare true -let nexp_gt = nexp_gt_compare false -let nexp_le n1 n2 = nexp_gt_compare true n2 n1 -let nexp_lt n1 n2 = nexp_gt_compare false n2 n1 - -let equate_t (t_box : t) (t : t) : unit = - let t = resolve_tsubst t in - if t_box == t then () - else - (occurs_check_t t_box t; - match t.t with - | Tuvar(_) -> - (match t_box.t with - | Tuvar(u) -> - u.subst <- Some(t) - | _ -> assert false) - | _ -> - t_box.t <- t.t) - -(*Assumes that both are nuvar, and both set initially on outermost of chain *) -let rec occurs_in_nuvar_chain n_box n : bool = - n_box.nexp == n.nexp || (*if both are at outermost and they are the same, then n occurs in n_box *) - let n_box' = get_inner_most n_box in - match n_box'.nexp with - | Nuvar( { insubst= None }) -> false - | Nuvar( { insubst= Some(n_box') }) -> occurs_in_nexp n_box' n - | _ -> occurs_in_nexp n_box' n - -(*Heavy-weight occurs check, including nuvar chains. Assumes second argument always a nuvar*) -and occurs_in_nexp n_box nuvar : bool = -(* let _ = Printf.eprintf "occurs_in_nexp given n_box %s nuvar %s eq? %b\n" - (n_to_string n_box) (n_to_string nuvar) (n_box.nexp == nuvar.nexp) in*) - if n_box.nexp == nuvar.nexp then true - else match n_box.nexp with - | Nuvar _ -> occurs_in_nuvar_chain (get_outer_most n_box) (get_outer_most nuvar) - | Nadd (nb1,nb2) | Nsub(nb1,nb2)| Nmult (nb1,nb2) -> occurs_in_nexp nb1 nuvar || occurs_in_nexp nb2 nuvar - | Nneg nb | N2n(nb,None) | Npow(nb,_) -> occurs_in_nexp nb nuvar - | _ -> false - -(*Assumes that n is set to it's outermost n*) -let collapse_nuvar_chain n = - let rec collapse n = - match n.nexp with - | Nuvar { insubst = None } -> (n,[n]) - | Nuvar ({insubst = Some ni } as u) -> - (*let _ = Printf.eprintf "Collapsing %s, about to collapse it's insubst\n" (n_to_string n) in*) - let _,internals = collapse ni in - (*let _ = Printf.eprintf "Collapsed %s, with inner %s\n" (n_to_string n) (n_to_string ni) in*) - (match ni.nexp with - | Nuvar nim -> - u.leave_var <- u.leave_var || nim.leave_var; - u.nin <- u.nin || nim.nin; - u.orig_var <- (match u.orig_var,nim.orig_var with - | None, None -> None - | Some i, Some j -> if i = j then Some i else None - | Some i,_ | _, Some i -> Some i); - u.insubst <- None; - u.outsubst <- None; - u.been_collapsed <- true; - (*Shouldn't need this but Somewhere somethings going wonky*) - (*nim.nindex <- u.nindex; *) - (n,n::internals) - | _ -> if u.leave_var then u.insubst <- Some ni else n.nexp <- ni.nexp; (n,[n])) - | _ -> (n,[n]) - in - let rec set_nexp n_from n_to_s = match n_to_s with - | [] -> n_from - | n_to::n_to_s -> n_to.nexp <- n_from.nexp; set_nexp n_from n_to_s in - let (n,all) = collapse n in - set_nexp n (List.tl all) - -(*assumes called on outermost*) -let rec leave_nu_as_var n = - match n.nexp with - | Nuvar nu -> - (match nu.insubst with - | None -> nu.leave_var - | Some(nexp) -> nu.leave_var || leave_nu_as_var nexp) - | _ -> false - -let equate_n (n_box : nexp) (n : nexp) : bool = - (*let _ = Printf.eprintf "equate_n given n_box %s and n %s\n" (n_to_string n_box) (n_to_string n) in*) - let n_box = get_outer_most n_box in - let n = get_outer_most n in - if n_box.nexp == n.nexp then true - else - let occur_nbox_n = occurs_in_nexp n_box n in - let occur_n_nbox = occurs_in_nexp n n_box in - match (occur_nbox_n,occur_n_nbox) with - | true,true -> false - | true,false | false,true -> true - | false,false -> - (*let _ = Printf.eprintf "equate_n has does not occur in %s and %s\n" (n_to_string n_box) (n_to_string n) in*) - (*If one is empty, set the empty one into the bottom of the other one if you can, but put it in the chain - If neither are empty, merge but make sure to set the nexp to be the same (not yet being done) - *) - match n_box.nexp,n.nexp with - | Nuvar _, Nuvar _ | Nuvar _, _ | _, Nuvar _ -> add_to_nuvar_tail n_box n - | _ -> false -let equate_o (o_box : order) (o : order) : unit = - let o = resolve_osubst o in - if o_box == o then () - else - (occurs_check_o o_box o; - match o.order with - | Ouvar(_) -> - (match o_box.order with - | Ouvar(u) -> - u.osubst <- Some(o) - | _ -> o.order <- o_box.order) - | _ -> - o_box.order <- o.order) -let equate_e (e_box : effect) (e : effect) : unit = - let e = resolve_esubst e in - if e_box == e then () - else - (occurs_check_e e_box e; - match e.effect with - | Euvar(_) -> - (match e_box.effect with - | Euvar(u) -> - u.esubst <- Some(e) - | _ -> assert false) - | _ -> - e_box.effect <- e.effect) - -let fresh_var just_use_base varbase i mkr bindings = - let v = if just_use_base then varbase else "'" ^ varbase ^ (string_of_int i) in - match Envmap.apply bindings v with - | Some _ -> mkr v false - | None -> mkr v true - -let rec fresh_tvar bindings t = - match t.t with - | Tuvar { index = i;subst = None } -> - fresh_var false "tv" i (fun v add -> equate_t t {t=Tvar v}; if add then Some (v,{k=K_Typ}) else None) bindings - | Tuvar { index = i; subst = Some ({t = Tuvar _} as t') } -> - let kv = fresh_tvar bindings t' in - equate_t t t'; - kv - | Tuvar { index = i; subst = Some t' } -> - t.t <- t'.t; - None - | _ -> None -let rec fresh_nvar bindings n = - (*let _ = Printf.eprintf "fresh_nvar for %s\n" (n_to_string n) in*) - match n.nexp with - | Nuvar { nindex = i;insubst = None ; orig_var = None } -> - fresh_var false "nv" i (fun v add -> n.nexp <- (Nvar v); - (*(Printf.eprintf "fresh nvar set %i to %s : %s\n" i v (n_to_string n));*) - if add then Some(v,{k=K_Nat}) else None) bindings - | Nuvar { nindex = i;insubst = None ; orig_var = Some v } -> - fresh_var true v 0 (fun v add -> n.nexp <- (Nvar v); - (*(Printf.eprintf "fresh nvar set %i to %s : %s\n" i v (n_to_string n));*) - if add then Some(v,{k=K_Nat}) else None) bindings - | Nuvar { nindex = i; insubst = Some n' } -> - n.nexp <- n'.nexp; - None - | _ -> None -let rec fresh_ovar bindings o = - match o.order with - | Ouvar { oindex = i;osubst = None } -> - fresh_var false "ov" i (fun v add -> equate_o o {order = (Ovar v)}; - if add then Some(v,{k=K_Nat}) else None) bindings - | Ouvar { oindex = i; osubst = Some({order=Ouvar _} as o')} -> - let kv = fresh_ovar bindings o' in - equate_o o o'; - kv - | Ouvar { oindex = i; osubst = Some o' } -> - o.order <- o'.order; - None - | _ -> None -let rec fresh_evar bindings e = - match e.effect with - | Euvar { eindex = i;esubst = None } -> - fresh_var false "ev" i (fun v add -> equate_e e {effect = (Evar v)}; - if add then Some(v,{k=K_Nat}) else None) bindings - | Euvar { eindex = i; esubst = Some({effect=Euvar _} as e')} -> - let kv = fresh_evar bindings e' in - equate_e e e'; - kv - | Euvar { eindex = i; esubst = Some e' } -> - e.effect <- e'.effect; - None - | _ -> None - -let contains_nuvar_nexp n ne = - let compare_to i = match n.nexp with - | Nuvar {nindex = i2} -> i = i2 - | _ -> false in - let rec search ne = - match ne.nexp with - | Nuvar {nindex =i}-> compare_to i - | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> search n1 || search n2 - | N2n(n,_) | Nneg n | Npow(n,_) -> search n - | _ -> false in - search ne - -let contains_nvar_nexp n ne = - let compare_to v = match n.nexp with - | Nvar v' -> v = v' - | _ -> false in - let rec search ne = - match ne.nexp with - | Nvar v-> compare_to v - | Nadd(n1,n2) | Nmult(n1,n2) | Nsub(n1,n2) -> search n1 || search n2 - | N2n(n,_) | Nneg n | Npow(n,_) -> search n - | _ -> false in - search ne - -let rec contains_n nexp_contains n cs = - let contains = contains_n nexp_contains in - match cs with - | [] -> [] - | ((LtEq(_,_,nl,nr) | Lt(_,_,nl,nr) | GtEq(_,_,nl,nr) | Gt(_,_,nl,nr) | Eq(_,nl,nr) | NtEq(_,nl,nr)) as co)::cs -> - if (nexp_contains n nl || nexp_contains n nr) - then co::(contains n cs) - else contains n cs - | CondCons(so,kind,_,conds,exps)::cs -> - let conds' = contains n conds in - let exps' = contains n exps in - (match conds',exps' with - | [],[] -> contains n cs - | _ -> CondCons(so,kind,None,conds',exps')::contains n cs) - | BranchCons(so,_,b_cs)::cs -> - (match contains n b_cs with - | [] -> contains n cs - | b -> BranchCons(so,None,b)::contains n cs) - | (Predicate(so,cp,cn) as co)::cs -> - (match contains n [cp;cn] with - | [] -> contains n cs - | _ -> co::contains n cs) - | _::cs -> contains n cs - -let contains_nuvar = contains_n contains_nuvar_nexp -let contains_nvar = contains_n contains_nvar_nexp - -let rec refine_guarantees check_nvar max_lt min_gt id cs = - match cs with - | [] -> - (match max_lt,min_gt with - | None,None -> [] - | Some(c,i),None -> [LtEq(c,Guarantee,id,i)] - | None,Some(c,i) -> [GtEq(c,Guarantee,id,i)] - | Some(cl,il),Some(cg,ig) -> [LtEq(cl,Guarantee,id,il);GtEq(cg,Guarantee,id,ig)]), max_lt, min_gt - | (LtEq(c,Guarantee,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in - curr::cs,max,min in - (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*) - (match nes.nexp,neb.nexp,check_nvar,max_lt,min_gt with - | Nuvar _ , _, false, None, _ | Nvar _, _, true, None, _ -> - (*let _ = Printf.eprintf "in var nill case of <=\n" in *) - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*new max*) - else no_match () - | _ , Nuvar _, false, _, None | _,Nvar _, true, _, None -> - (*let _ = Printf.eprintf "in var nill case of <=\n" in *) - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*new min*) - else no_match () - | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true,Some(cm, omax), _ -> - (*let _ = Printf.eprintf "in var case of <=\n" in *) - if nexp_eq id nes - then match nexp_ge neb omax with - | Yes -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*replace old max*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint *) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true,_, Some(cm, omin) -> - (*let _ = Printf.eprintf "in var case of <=\n" in *) - if nexp_eq id neb - then match nexp_le nes omin with - | Yes -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*replace old min*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint *) - | Maybe -> no_match () - else no_match () - | _ -> no_match ()) - | (Lt(c,Guarantee,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in - curr::cs,max,min in - (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*) - (match nes.nexp,neb.nexp,check_nvar,max_lt,min_gt with - | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _-> - (*let _ = Printf.eprintf "in var, nil case of <\n" in *) - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*new max*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None-> - (*let _ = Printf.eprintf "in var, nil case of <\n" in *) - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*new max*) - else no_match () - | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ -> - (*let _ = Printf.eprintf "in var case of <\n" in *) - if nexp_eq id nes - then match nexp_gt neb omax with - | Yes -> refine_guarantees check_nvar (Some(c,neb)) min_gt id cs (*replace old max*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) -> - (*let _ = Printf.eprintf "in var case of <\n" in *) - if nexp_eq id neb - then match nexp_lt nes omin with - | Yes -> refine_guarantees check_nvar max_lt (Some(c,nes)) id cs (*replace old min*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _ -> no_match ()) - | (GtEq(c,Guarantee,nes,neb) as curr)::cs -> - (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*) - let no_match _ = - let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in - curr::cs,max,min in - (match nes.nexp,neb.nexp,check_nvar,min_gt,max_lt with - | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _-> - (*let _ = Printf.eprintf "in var, nil case of >=\n" in *) - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*new min*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None-> - (*let _ = Printf.eprintf "in var, nil case of >=\n" in *) - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*new max*) - else no_match () - | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ -> - (*let _ = Printf.eprintf "in var case of >=\n" in *) - if nexp_eq id nes - then match nexp_le neb omin with - | Yes -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*replace old min*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) -> - (*let _ = Printf.eprintf "in var case of >=\n" in *) - if nexp_eq id neb - then match nexp_ge nes omax with - | Yes -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*replace old max*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _ -> no_match ()) - | (Gt(c,Guarantee,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in - curr::cs,max,min in - (* let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [curr]) in*) - (match nes.nexp,neb.nexp,check_nvar,min_gt,max_lt with - | Nuvar _,_, false, None,_ | Nvar _, _, true, None,_-> - (*let _ = Printf.eprintf "in var, nil case of >\n" in *) - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*new min*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None -> - (*let _ = Printf.eprintf "in var, nil case of >\n" in *) - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*new max*) - else no_match () - | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ -> - (*let _ = Printf.eprintf "in var case of >\n" in *) - if nexp_eq id nes - then match nexp_lt neb omin with - | Yes -> refine_guarantees check_nvar max_lt (Some(c,neb)) id cs (*replace old min*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) -> - (*let _ = Printf.eprintf "in var case of >\n" in *) - if nexp_eq id neb - then match nexp_gt nes omax with - | Yes -> refine_guarantees check_nvar (Some(c,nes)) min_gt id cs (*replace old min*) - | No -> refine_guarantees check_nvar max_lt min_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _ -> no_match ()) - | c::cs -> - (*let _ = Printf.eprintf "refine_guarantee %s\n" (constraints_to_string [c]) in*) - let (cs,max,min) = refine_guarantees check_nvar max_lt min_gt id cs in - c::cs,max,min - -let rec refine_requires check_nvar min_lt max_gt id cs = - match cs with - | [] -> - (match min_lt,max_gt with - | None,None -> [] - | Some(c,i),None -> [LtEq(c,Require,id,i)] - | None,Some(c,i) -> [GtEq(c,Require,id,i)] - | Some(cl,il),Some(cg,ig) -> [LtEq(cl,Require,id,il);GtEq(cg,Require,id,ig)]), min_lt,max_gt - | (LtEq(c,Require,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in - curr::cs,max,min in - (match nes.nexp,neb.nexp,check_nvar,min_lt,max_gt with - | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _ -> - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*new min*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None -> - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*) - else no_match () - | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ -> - if nexp_eq id nes - then match nexp_le neb omin with - | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match() - | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _, true, _, Some(cm, omax) -> - if nexp_eq id neb - then match nexp_ge nes omax with - | Yes -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*replace old max*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match() - | _ -> no_match()) - | (Lt(c,Require,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in - curr::cs,max,min in - (match nes.nexp,neb.nexp,check_nvar,min_lt,max_gt with - | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _-> - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar(Some(c,neb)) max_gt id cs (*new min*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None-> - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*new max*) - else no_match () - | Nuvar _, _, false, Some(cm, omin), _ | Nvar _, _, true, Some(cm, omin), _ -> - if nexp_eq id nes - then match nexp_lt neb omin with - | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omax) | _, Nvar _,true, _, Some(cm, omax) -> - if nexp_eq id neb - then match nexp_gt nes omax with - | Yes -> refine_requires check_nvar min_lt (Some(c,nes)) id cs (*replace old max*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _ -> no_match()) - | (GtEq(c,Require,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in - curr::cs,max,min in - (match nes.nexp,neb.nexp,check_nvar,max_gt,min_lt with - | Nuvar _, _, false, None, _ | Nvar _, _, true, None, _ -> - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*) - else no_match () - | _, Nuvar _, false, _, None | _, Nvar _, true, _, None -> - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*new min*) - else no_match () - | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ -> - if nexp_eq id nes - then match nexp_ge neb omax with - | Yes -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*replace old max*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) -> - if nexp_eq id neb - then match nexp_le nes omin with - | Yes -> refine_requires check_nvar (Some(c,neb)) max_gt id cs (*replace old min*) - | No -> refine_requires check_nvar min_lt max_gt id cs (*remove redundant constraint*) - | Maybe -> no_match () - else no_match () - | _ -> no_match ()) - | (Gt(c,Require,nes,neb) as curr)::cs -> - let no_match _ = - let (cs,max,min) = refine_requires check_nvar min_lt max_gt id cs in - curr::cs,max,min in - (match nes.nexp,neb.nexp,check_nvar,max_gt,min_lt with - | Nuvar _, _, true, None, _ | Nvar _, _, false, None, _ -> - if nexp_eq id nes - then match neb.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*new max*) - else refine_requires check_nvar min_lt max_gt id cs - | _, Nuvar _, true, _, None | _, Nvar _, false, _, None-> - if nexp_eq id neb - then match nes.nexp with - | Nuvar _ | Nvar _ -> no_match () (*Don't set a variable to a max/min*) - | _ -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*new min*) - else refine_requires check_nvar min_lt max_gt id cs - | Nuvar _, _, false, Some(cm, omax), _ | Nvar _, _, true, Some(cm, omax), _ -> - if nexp_eq id nes - then match nexp_gt neb omax with - | Yes -> refine_requires check_nvar min_lt (Some(c,neb)) id cs (*replace old max*) - | No -> refine_requires check_nvar min_lt max_gt id cs (* remove redundant constraint *) - | Maybe -> no_match () - else no_match () - | _, Nuvar _, false, _, Some(cm, omin) | _, Nvar _, true, _, Some(cm, omin) -> - if nexp_eq id neb - then match nexp_lt nes omin with - | Yes -> refine_requires check_nvar (Some(c,nes)) max_gt id cs (*replace old min*) - | No -> refine_requires check_nvar min_lt max_gt id cs (* remove redundant constraint *) - | Maybe -> no_match () - else no_match () - | _ -> no_match()) - | c::cs -> - let (cs,min,max) = refine_requires check_nvar min_lt max_gt id cs in - c::cs,min_lt,max_gt - -let nat_t = {t = Tapp("range",[TA_nexp n_zero;TA_nexp (mk_p_inf());])} -let int_t = {t = Tapp("range",[TA_nexp (mk_n_inf());TA_nexp (mk_p_inf());])} -let uint8_t = {t = Tapp("range",[TA_nexp n_zero; TA_nexp (mk_sub (mk_2nc (mk_c_int 8) (big_int_of_int 256)) n_one)])} -let uint16_t = {t = Tapp("range",[TA_nexp n_zero; - TA_nexp (mk_sub (mk_2nc (mk_c_int 16) (big_int_of_int 65536)) n_one)])} -let uint32_t = {t = Tapp("range",[TA_nexp n_zero; - TA_nexp (mk_sub (mk_2nc (mk_c_int 32) (big_int_of_string "4294967296")) n_one)])} -let uint64_t = {t = Tapp("range",[TA_nexp n_zero; - TA_nexp (mk_sub (mk_2nc (mk_c_int 64) (big_int_of_string "18446744073709551616")) - (mk_c_int 1)) - ])} - -let int8_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 7) (big_int_of_int 128))) ; - TA_nexp (mk_c_int 127)])} -let int16_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 15) (big_int_of_int 32768))); - TA_nexp (mk_c_int 32767)])} -let int32_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 31) (big_int_of_int 2147483648))) ; - TA_nexp (mk_c_int 2147483647)])} -let int64_t = {t = Tapp("range", [TA_nexp (mk_neg (mk_2nc (mk_c_int 63) (big_int_of_string "9223372036854775808"))); - TA_nexp (mk_c (big_int_of_string "9223372036854775807"))])} - -let unit_t = { t = Tid "unit" } -let bit_t = {t = Tid "bit" } -let bool_t = {t = Tid "bool" } -let nat_typ = {t=Tid "nat"} -let string_t = {t = Tid "string"} -let pure_e = {effect=Eset []} -let nob = No_bounds - -let rec get_cummulative_effects = function - | NoTyp -> pure_e - | Base(_,_,_,_,efr,_) -> efr - | _ -> pure_e - -let get_eannot (E_aux(_,(l,annot))) = annot - -let initial_kind_env = - Envmap.from_list [ - ("bool", {k = K_Typ}); - ("nat", {k = K_Typ}); - ("int", {k = K_Typ}); - ("uint8", {k = K_Typ}); - ("uint16", {k= K_Typ}); - ("uint32", {k=K_Typ}); - ("uint64", {k=K_Typ}); - ("unit", {k = K_Typ}); - ("bit", {k = K_Typ}); - ("string", {k = K_Typ}); - ("list", {k = K_Lam( [{k = K_Typ}], {k = K_Typ})}); - ("reg", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); - ("register", {k = K_Lam( [{k = K_Typ}], {k= K_Typ})}); - ("range", {k = K_Lam( [ {k = K_Nat}; {k= K_Nat}], {k = K_Typ}) }); - ("vector", {k = K_Lam( [ {k = K_Nat}; {k = K_Nat}; {k= K_Ord} ; {k=K_Typ}], {k=K_Typ}) } ); - ("atom", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); - ("option", { k = K_Lam( [{k=K_Typ}], {k=K_Typ}) }); - ("implicit", {k = K_Lam( [{k = K_Nat}], {k=K_Typ})} ); - ] - -let simple_annot t = Base(([],t),Emp_local,[],pure_e,pure_e,nob) -let simple_annot_efr t efr = Base(([],t),Emp_local,[],pure_e,efr,nob) -let global_annot t = Base(([],t),Emp_global,[],pure_e,pure_e,nob) -let tag_annot t tag = Base(([],t),tag,[],pure_e,pure_e,nob) -let tag_annot_efr t tag efr = Base(([],t),tag,[],pure_e,efr,nob) -let constrained_annot t cs = Base(([],t),Emp_local,cs,pure_e,pure_e,nob) -let constrained_annot_efr t cs efr = Base(([],t),Emp_local,cs,pure_e,efr,nob) -let bounds_annot t bs = Base(([],t),Emp_local,[],pure_e,pure_e,bs) -let bounds_annot_efr t bs efr = Base(([],t),Emp_local,[],pure_e,efr,bs) -let cons_tag_annot t tag cs = Base(([],t),tag,cs,pure_e,pure_e,nob) -let cons_tag_annot_efr t tag cs efr = Base(([],t),tag,cs,pure_e,efr,nob) -let cons_efl_annot t cs ef = Base(([],t),Emp_local,cs,ef,pure_e,nob) -let cons_efs_annot t cs efl efr = Base(([],t),Emp_local,cs,efl,efr,nob) -let efs_annot t efl efr = Base(([],t),Emp_local,[],efl,efr,nob) -let tag_efs_annot t tag efl efr = Base(([],t),tag,[],efl,efr,nob) -let cons_bs_annot t cs bs = Base(([],t),Emp_local,cs,pure_e,pure_e,bs) -let cons_bs_annot_efr t cs bs efr = Base(([],t), Emp_local, cs, pure_e, efr, bs) - -let initial_abbrev_env = - Envmap.from_list [ - ("nat",global_annot nat_t); - ("int",global_annot int_t); - ("uint8",global_annot uint8_t); - ("uint16",global_annot uint16_t); - ("uint32",global_annot uint32_t); - ("uint64",global_annot uint64_t); - ("bool",global_annot bit_t); - ] - -let mk_nat_params l = List.map (fun i -> (i,{k=K_Nat})) l -let mk_typ_params l = List.map (fun i -> (i,{k=K_Typ})) l -let mk_ord_params l = List.map (fun i -> (i,{k=K_Ord})) l - -let mk_tup ts = {t = Ttup ts } -let mk_pure_fun arg ret = {t = Tfn (arg,ret,IP_none,pure_e)} -let mk_pure_imp arg ret var = {t = Tfn (arg,ret,IP_length (mk_nv var),pure_e)} - -let lib_tannot param_typs func cs = - Base(param_typs, External func, cs, pure_e, pure_e, nob) - -let mk_ovar s = {order = Ovar s} -let mk_range n1 n2 = {t=Tapp("range",[TA_nexp n1;TA_nexp n2])} -let mk_atom n1 = {t = Tapp("atom",[TA_nexp n1])} -let mk_vector typ order start size = {t=Tapp("vector",[TA_nexp start; TA_nexp size; TA_ord order; TA_typ typ])} -let mk_bitwise_op name symb arity = - let ovar = mk_ovar "o" in - let vec_typ = mk_vector bit_t ovar (mk_nv "n") (mk_nv "m") in - let single_bit_vec_typ = mk_vector bit_t ovar (mk_nv "n") n_one in - let vec_args = Array.to_list (Array.make arity vec_typ) in - let single_bit_vec_args = Array.to_list (Array.make arity single_bit_vec_typ) in - let bit_args = Array.to_list (Array.make arity bit_t) in - let gen_args = Array.to_list (Array.make arity {t = Tvar "a"}) in - let svarg,varg,barg,garg = if (arity = 1) - then List.hd single_bit_vec_args,List.hd vec_args,List.hd bit_args,List.hd gen_args - else mk_tup single_bit_vec_args,mk_tup vec_args,mk_tup bit_args, mk_tup gen_args in - (symb, - Overload(lib_tannot ((mk_typ_params ["a"]),mk_pure_fun garg {t=Tvar "a"}) (Some name) [], true, - [lib_tannot ((mk_nat_params ["n";"m"]@mk_ord_params["o"]), mk_pure_fun varg vec_typ) (Some name) []; - (*lib_tannot (["n",{k=K_Nat};"o",{k=K_Ord}],mk_pure_fun svarg single_bit_vec_typ) (Some name) [];*) - lib_tannot ([],mk_pure_fun barg bit_t) (Some (name ^ "_bit")) []])) - -let initial_typ_env_list : (string * ((string * tannot) list)) list = - - [ - "bitwise logical operators", - [ - ("not", - Base(([], mk_pure_fun bit_t bit_t), External (Some "bitwise_not_bit"), [],pure_e,pure_e,nob)); - mk_bitwise_op "bitwise_not" "~" 1; - mk_bitwise_op "bitwise_or" "|" 2; - mk_bitwise_op "bitwise_xor" "^" 2; - mk_bitwise_op "bitwise_and" "&" 2; - ]; - "bitwise shifts and rotates", - [ - ("<<",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); - (mk_range n_zero (mk_nv "m"))]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - External (Some "bitwise_leftshift"),[],pure_e,pure_e,nob)); - (">>",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); - (mk_range n_zero (mk_nv "m"))]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - External (Some "bitwise_rightshift"),[],pure_e,pure_e,nob)); - ("<<<",Base((((mk_nat_params ["n";"m"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); - (mk_range n_zero (mk_nv "m"))]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - External (Some "bitwise_rotate"),[],pure_e,pure_e,nob)); - ]; - "bitvector duplicate, extension, and MSB", - [ - ("^^", - Overload( - Base((mk_nat_params["n";"o";"p"]@[("a",{k=K_Typ})], - (mk_pure_fun (mk_tup [{t=Tvar "a"}; mk_atom (mk_nv "n")]) - (mk_vector bit_t {order = Oinc} (mk_nv "o") (mk_nv "p")))), - External (Some "duplicate"), [], pure_e, pure_e, nob), - false, - [Base((mk_nat_params ["n"], - (mk_pure_fun (mk_tup [bit_t;mk_atom (mk_nv "n")]) - (mk_vector bit_t {order=Oinc} (mk_c zero) (mk_nv "n")))), - External (Some "duplicate"),[],pure_e,pure_e,nob); - Base((mk_nat_params ["n";"m";"o"]@mk_ord_params["ord"], - mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "m"); - mk_atom (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_mult (mk_nv "m") (mk_nv "n")))), - External (Some "duplicate_bits"),[],pure_e,pure_e,nob);])); - ("EXTZ",Base((((mk_nat_params ["n";"m";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_imp (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "m")) "m")), - External (Some "extz"),[],pure_e,pure_e,nob)); - ("EXTS",Base((((mk_nat_params ["n";"m";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_imp (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "m")) "m")), - External (Some "exts"),[],pure_e,pure_e,nob)); - ("most_significant", lib_tannot ((mk_nat_params ["n";"m"]@(mk_ord_params ["ord"])), - (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) bit_t)) - None []); - ]; - "arithmetic", - [ - ("+",Overload( - lib_tannot ((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) (Some "add") [], - true, - [lib_tannot ((mk_nat_params ["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_add (mk_nv "n") (mk_nv "m"))))) - (Some "add") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")))) - (Some "add_vec") []; - lib_tannot ((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_range (mk_nv "q") (mk_sub (mk_2n (mk_nv "n")) n_one)))) - (Some "add_vec_vec_range") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "add_vec_range") - [LtEq(Specc(Parse_ast.Int("+",None)),Require, (mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)]; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t]))) - (Some "add_overflow_vec") []; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "add_vec_range_range") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)]; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "add_range_vec") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)]; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_sub (mk_2n (mk_nv "m")) n_one))))) - (Some "add_range_vec_range") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)]; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")))) - (Some "add_vec_bit") []; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [bit_t; mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")))) - (Some "add_bit_vec") []; - ])); - ("+_s",Overload( - lib_tannot ((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) (Some "add") [], - true, - [lib_tannot ((mk_nat_params ["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_add (mk_nv "n") (mk_nv "m"))))) - (Some "add_signed") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")))) - (Some "add_vec_signed") []; - lib_tannot ((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_range (mk_nv "q") (mk_2n (mk_nv "n"))))) - (Some "add_vec_vec_range_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "add_vec_range_signed") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))]; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t]))) - (Some "add_overflow_vec_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "add_vec_range_range_signed") - [LtEq(Specc(Parse_ast.Int("+",None)),Require, (mk_nv "o"),mk_sub (mk_2n (mk_nv "m")) n_one)]; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "add_range_vec_signed") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))]; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "add_range_vec_range_signed") - [LtEq(Specc(Parse_ast.Int("+",None)),Require,(mk_nv "o"),(mk_sub (mk_2n (mk_nv "m")) n_one))]; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")))) - (Some "add_vec_bit_signed") []; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t]))) - (Some "add_overflow_vec_bit_signed") []; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [bit_t; mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")))) - (Some "add_bit_vec_signed") []; - ])); - ("-",Overload( - lib_tannot ((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) - (Some "minus") [], - true, - [lib_tannot ((mk_nat_params["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_sub (mk_nv "n") (mk_nv "m"))))) - (Some "minus") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")))) - (Some "minus_vec") []; - lib_tannot ((mk_nat_params ["m";"n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_atom (mk_nv "m")))) (Some "minus_vec_vec_range") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "minus_vec_range") []; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "minus_vec_range_range") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "minus_range_vec") []; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "minus_range_vec_range") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t]))) - (Some "minus_overflow_vec") []; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t]))) - (Some "minus_overflow_vec_bit") []; - ])); - ("-_s",Overload( - lib_tannot ((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})) - (Some "minus") [], - true, - [lib_tannot ((mk_nat_params["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_sub (mk_nv "n") (mk_nv "m"))))) - (Some "minus") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")))) - (Some "minus_vec_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "minus_vec_range_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o";])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "minus_vec_range_range_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))) - (Some "minus_range_vec_signed") []; - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m");]) - (mk_range (mk_nv "o") (mk_add (mk_nv "o") (mk_2n (mk_nv "m")))))) - (Some "minus_range_vec_range_signed") []; - lib_tannot ((mk_nat_params ["n";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n")); bit_t; bit_t]))) - (Some "minus_overflow_vec_signed") []; - lib_tannot ((mk_nat_params ["o";"p"]@(mk_ord_params["ord"])), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p"); bit_t]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "p")); bit_t; bit_t]))) - (Some "minus_overflow_vec_bit_signed") []; - ])); - ("*",Overload( - lib_tannot ((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]){t=Tvar "c"})) - (Some "multiply") [], - true, - [lib_tannot ((mk_nat_params["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_mult (mk_nv "n") (mk_nv "m"))))) - (Some "multiply") []; - Base(((mk_nat_params ["n";"o";"p";"q"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "n") (mk_nv "n"))))), - (External (Some "multiply_vec")), [],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "m") (mk_nv "m"))))), - (External (Some "mult_range_vec")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "q") (mk_add (mk_nv "m") (mk_nv "m"))))), - (External (Some "mult_vec_range")),[],pure_e,pure_e,nob); - ])); - ("*_s",Overload( - Base(((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]){t=Tvar "c"})), - (External (Some "multiply")),[],pure_e,pure_e,nob), - true, - [Base(((mk_nat_params["n";"m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) - (mk_atom (mk_mult (mk_nv "n") (mk_nv "m"))))), - (External (Some "multiply_signed")), [],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"o";"p";"m"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_add (mk_nv "n") (mk_nv "n"))))), - (External (Some "multiply_vec_signed")), [],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_add (mk_nv "m") (mk_nv "m"))))), - (External (Some "mult_range_vec_signed")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";"p"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_add (mk_nv "m") (mk_nv "m"))))), - (External (Some "mult_vec_range_signed")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"o";"p";"m"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_add (mk_nv "n") (mk_nv "n"))); - bit_t;bit_t]))), - (External (Some "mult_overflow_vec_signed")), [],pure_e,pure_e,nob); - ])); - ("mod", - Overload( - Base(((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})), - (External (Some "modulo")),[],pure_e,pure_e,nob), - true, - [Base(((mk_nat_params["n";"o";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ; mk_atom (mk_nv "o")]) - (mk_range n_zero (mk_sub (mk_nv "o") n_one)))), - (External (Some "modulo")), - [GtEq(Specc(Parse_ast.Int("modulo",None)),Require,(mk_nv "o"),n_one)],pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"o"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_range n_one (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "mod_vec_range")), - [GtEq(Specc(Parse_ast.Int("mod",None)),Require,(mk_nv "o"),n_one);],pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "mod_vec")),[],pure_e,pure_e,nob)])); - ("mod_s", - Overload( - Base(((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})), - (External (Some "mod_signed")),[],pure_e,pure_e,nob), - true, - [Base(((mk_nat_params["n";"o";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ; mk_atom (mk_nv "o")]) - (mk_range n_zero (mk_sub (mk_nv "o") n_one)))), - (External (Some "mod_signed")), - [GtEq(Specc(Parse_ast.Int("modulo",None)),Require,(mk_nv "o"),n_one)],pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"o"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_range n_one (mk_nv "o")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "mod_signed_vec_range")), - [GtEq(Specc(Parse_ast.Int("mod",None)),Require,(mk_nv "o"),n_one);],pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "mod_signed_vec")),[],pure_e,pure_e,nob)])); - ("div", - Base(((mk_nat_params["n";"m";"o";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) - (mk_atom (mk_nv "o")))), - (*This should really be != to 0, as negative is just fine*) - (External (Some "quot")),[(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "m"),n_one);*) - LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee, - (mk_mult (mk_nv "n") (mk_nv "o")),(mk_nv "m"))], - pure_e,pure_e,nob)); - ("quot", - Overload( - Base(((mk_typ_params ["a";"b";"c"]), - (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})), - (External (Some "quot")),[],pure_e,pure_e,nob), - true, - [Base(((mk_nat_params["n";"m";"o";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) - (mk_atom (mk_nv "o")))), - (*This should really be != to 0, as negative is just fine*) - (External (Some "quot")),[(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "m"),n_one);*) - LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee, - (mk_mult (mk_nv "n") (mk_nv "o")),(mk_nv "m"))], - pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "quot_vec")),[GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")], - pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); bit_t;bit_t]))), - (External (Some "quot_overflow_vec")), - [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")], - pure_e,pure_e,nob)])); - ("quot_s", - Overload( - Base(((mk_typ_params ["a";"b";"c"]), (mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) {t=Tvar "c"})), - (External (Some "quot_signed")),[],pure_e,pure_e,nob), - true, - [Base(((mk_nat_params["n";"m";"o";"p";"q";"r"]), - (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m"); mk_range (mk_nv "o") (mk_nv "p")]) - (mk_range (mk_nv "q") (mk_nv "r")))), - (External (Some "quot_signed")), - [(*GtEq(Specc(Parse_ast.Int("quot",None)),Require,(mk_nv "o"),n_one);*) - LtEq(Specc(Parse_ast.Int("quot",None)),Guarantee,(mk_mult (mk_nv "p") (mk_nv "r")),mk_nv "m")], - pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")]) - (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")))), - (External (Some "quot_vec_signed")), - [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],pure_e,pure_e,nob); - Base(((mk_nat_params["n";"m";"p";"q"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "q")]) - (mk_tup [(mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")); bit_t;bit_t]))), - (External (Some "quot_overflow_vec_signed")), - [GtEq(Specc(Parse_ast.Int("quot",None)),Require, mk_nv "m", mk_nv "q")],pure_e,pure_e,nob); - ])); - ]; - "additional arithmetic on singleton ranges; vector length", - [ - ("**", - Base(((mk_nat_params ["o"]), - (mk_pure_fun (mk_tup [(mk_atom n_two); (mk_atom (mk_nv "o"))]) - (mk_atom (mk_2n (mk_nv "o"))))), - (External (Some "power")), [],pure_e,pure_e,nob)); - - ("abs",Base(((mk_nat_params ["n";"m";]), - (mk_pure_fun (mk_atom (mk_nv "n")) (mk_range n_zero (mk_nv "m")))), - External (Some "abs"),[],pure_e,pure_e,nob)); - ("max", - Base(((mk_nat_params ["n";"m";"o"]), - (mk_pure_fun (mk_tup [(mk_atom (mk_nv "n"));(mk_atom (mk_nv "m"))]) - (mk_atom (mk_nv "o")))), - External (Some "max"),[],pure_e,pure_e,nob)); - ("min", - Base(((mk_nat_params ["n";"m";"o"]), - (mk_pure_fun (mk_tup [(mk_atom (mk_nv "n"));(mk_atom (mk_nv "m"))]) - (mk_atom (mk_nv "o")))), - External (Some "min"),[],pure_e,pure_e,nob)); - ("length", Base((["a",{k=K_Typ}]@(mk_nat_params["n";"m"])@(mk_ord_params["ord"]), - (mk_pure_fun (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) - (mk_atom (mk_nv "m")))), - (External (Some "length")),[],pure_e,pure_e,nob)); - ]; - - "comparisons", - [ - (*Correct types again*) - ("==", - Overload( - (lib_tannot (mk_typ_params ["a";"b"],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)) - (Some "eq") []), - false, - [(*== : 'a['m] * 'a['m] -> bit_t *) - lib_tannot ((mk_nat_params["n";"m";"o"]@mk_typ_params["a"]@mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "o") (mk_nv "m")]) - bit_t)) - (Some "eq_vec") - []; - (* == : bit['n] * [:'o:] -> bit_t *) - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - bit_t)) - (Some "eq_range_vec") - []; - (* == : [:'o:] * bit['n] -> bit_t *) - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - bit_t)) - (Some "eq_vec_range") - []; - (* == : [:'n:] * [:'m:] -> bit_t *) - lib_tannot ((mk_nat_params["n";"m";], - mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t)) - (Some "eq_range") - [Predicate(Specc(Parse_ast.Int("==",None)), - Eq(Specc(Parse_ast.Int("==",None)), mk_nv "n", mk_nv "m"), - NtEq(Specc(Parse_ast.Int("==",None)), mk_nv "n", mk_nv "m"))]; - (* == : (bit_t,bit_t) -> bit_t *) - lib_tannot ([], mk_pure_fun (mk_tup [bit_t;bit_t]) bit_t) - (Some "eq_bit") - []; - lib_tannot (["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)) - (Some "eq") []])); - ("!=", - Overload( - lib_tannot ((mk_typ_params ["a";"b"]),(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)) - (Some "neq") [], - false, - [(*!= : 'a['m] * 'a['m] -> bit_t *) - lib_tannot ((mk_nat_params["n";"m";"o"]@mk_typ_params["a"]@mk_ord_params["ord"]), - (mk_pure_fun (mk_tup [mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "o") (mk_nv "m")]) - bit_t)) - (Some "neq_vec") - []; - (* != : bit['n] * [:'o:] -> bit_t *) - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) - bit_t)) - (Some "neq_range_vec") - []; - (* != : [:'o:] * bit['n] -> bit_t *) - lib_tannot ((mk_nat_params ["n";"m";"o"])@(mk_ord_params ["ord"]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) - bit_t)) - (Some "neq_vec_range") - []; - (* != : [:'n:] * [:'m:] -> bit_t *) - lib_tannot ((mk_nat_params["n";"m";], - mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t)) - (Some "neq_range") - [Predicate(Specc(Parse_ast.Int("!=",None)), - Eq(Specc(Parse_ast.Int("!=",None)), mk_nv "n", mk_nv "m"), - NtEq(Specc(Parse_ast.Int("!=",None)), mk_nv "n", mk_nv "m"))]; - (* != : (bit_t,bit_t) -> bit_t *) - lib_tannot ([], mk_pure_fun (mk_tup [bit_t;bit_t]) bit_t) - (Some "neq_bit") - []; - lib_tannot (["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)) - (Some "neq") []])); - ("<", - Overload( - Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)), - (External (Some "lt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n"; "m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n") ;mk_atom (mk_nv "m")]) bit_t)), - (External (Some "lt")), - [Predicate(Specc(Parse_ast.Int("<",None)), - Lt(Specc(Parse_ast.Int("<",None)),Guarantee, mk_nv "n", mk_nv "m"), - GtEq(Specc(Parse_ast.Int("<",None)),Guarantee, mk_nv "n", mk_nv "m"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "lt_vec")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o"]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) bit_t)), - (External (Some "lt_vec_range")), [], pure_e,pure_e, nob); - ])); - ("<_u", - Overload( - Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)), - (External (Some "lt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n"; "m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) bit_t)), - (External (Some "lt_unsigned")), - [Predicate(Specc(Parse_ast.Int("<",None)), - Lt(Specc(Parse_ast.Int("<_u",None)),Guarantee, mk_nv "n", mk_nv "m"), - GtEq(Specc(Parse_ast.Int("<_u",None)),Guarantee, mk_nv "n", mk_nv "m"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "lt_vec_unsigned")),[],pure_e,pure_e,nob); - ])); - ("<_s", - Overload( - Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)), - (External (Some "lt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n"; "m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)), - (External (Some "lt_signed")), - [Predicate(Specc(Parse_ast.Int("<_s",None)), - Lt(Specc(Parse_ast.Int("<_s",None)),Guarantee, mk_nv "n", mk_nv "m"), - GtEq(Specc(Parse_ast.Int("<_s",None)),Guarantee, mk_nv "n", mk_nv "m"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "lt_vec_signed")),[],pure_e,pure_e,nob); - ])); - (">", - Overload( - Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)), - (External (Some "gt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n";"m"]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n"); mk_atom (mk_nv "m")]) bit_t)), - (External (Some "gt")), - [Predicate(Specc(Parse_ast.Int(">",None)), - Gt(Specc(Parse_ast.Int(">",None)),Guarantee, mk_nv "n", mk_nv "m"), - LtEq(Specc(Parse_ast.Int(">",None)),Guarantee, mk_nv "n", mk_nv "m"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "gt_vec")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) bit_t)), - (External (Some "gt_vec_range")), [], pure_e,pure_e, nob); - ])); - (">_u", - Overload( - Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)), - (External (Some "gt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n";"m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)), - (External (Some "gt_unsigned")), - [Predicate(Specc(Parse_ast.Int(">_u",None)), - Gt(Specc(Parse_ast.Int(">_u",None)),Guarantee, mk_nv "n", mk_nv "m"), - LtEq(Specc(Parse_ast.Int(">_u",None)),Guarantee, mk_nv "n", mk_nv "n"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "gt_vec_unsigned")),[],pure_e,pure_e,nob); - ])); - (">_s", - Overload( - Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)), - (External (Some "gt")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n";"m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)), - (External (Some "gt_signed")), - [Predicate(Specc(Parse_ast.Int(">_s",None)), - Gt(Specc(Parse_ast.Int(">_s",None)),Guarantee, mk_nv "n", mk_nv "m"), - LtEq(Specc(Parse_ast.Int(">_s",None)),Guarantee, mk_nv "m", mk_nv "m"))], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "gt_vec_signed")),[],pure_e,pure_e,nob); - ])); - ("<=", - Overload( - Base((["a",{k=K_Typ};"b",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "b"}]) bit_t)), - (External (Some "lteq")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n"; "m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)), - (External (Some "lteq")), - [Predicate(Specc(Parse_ast.Int("<=",None)), - LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "m"), - Gt(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "m"))], - pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) bit_t)), - (External (Some "lteq_vec_range")), [], pure_e,pure_e, nob); - Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) bit_t)), - (External (Some "lteq_range_vec")), [], pure_e,pure_e, nob); - Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "lteq_vec")),[],pure_e,pure_e,nob); - ])); - ("<=_s", - Overload( - Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)), - (External (Some "lteq")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n"; "m";]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "n");mk_atom (mk_nv "m")]) bit_t)), - (External (Some "lteq_signed")), - [LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "n",mk_nv "o"); - LtEq(Specc(Parse_ast.Int("<=",None)),Guarantee,mk_nv "m",mk_nv "p")], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "lteq_vec_signed")),[],pure_e,pure_e,nob); - ])); - (">=", - Overload( - Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)), - (External (Some "gteq")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n";"m";"o";"p"]), - (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m");mk_range (mk_nv "o") (mk_nv "p")]) bit_t)), - (External (Some "gteq")), - [GtEq(Specc(Parse_ast.Int(">=",None)),Guarantee, mk_nv "n", mk_nv "o"); - GtEq(Specc(Parse_ast.Int(">=",None)),Guarantee, mk_nv "m", mk_nv "p")], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "gteq_vec")),[],pure_e,pure_e,nob); - Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m"); - mk_atom (mk_nv "o")]) bit_t)), - (External (Some "gteq_vec_range")), [], pure_e,pure_e, nob); - Base(((mk_nat_params ["n";"m";"o";]@["ord",{k=K_Ord}]), - (mk_pure_fun (mk_tup [mk_atom (mk_nv "o"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")]) bit_t)), - (External (Some "gteq_range_vec")), [], pure_e,pure_e, nob); - ])); - (">=_s", - Overload( - Base((["a",{k=K_Typ}],(mk_pure_fun (mk_tup [{t=Tvar "a"};{t=Tvar "a"}]) bit_t)), - (External (Some "gteq")),[],pure_e,pure_e,nob), - false, - [Base(((mk_nat_params ["n";"m";"o";"p"]), - (mk_pure_fun (mk_tup [mk_range (mk_nv "n") (mk_nv "m");mk_range (mk_nv "o") (mk_nv "p")]) bit_t)), - (External (Some "gteq_signed")), - [GtEq(Specc(Parse_ast.Int(">=_s",None)),Guarantee, mk_nv "n", mk_nv "o"); - GtEq(Specc(Parse_ast.Int(">=_s",None)),Guarantee, mk_nv "m", mk_nv "p")], - pure_e,pure_e,nob); - Base((((mk_nat_params ["n";"o";"p"])@[("ord",{k=K_Ord})]), - (mk_pure_fun (mk_tup [mk_vector bit_t (mk_ovar "ord") (mk_nv "o") (mk_nv "n"); - mk_vector bit_t (mk_ovar "ord") (mk_nv "p") (mk_nv "n")]) bit_t)), - (External (Some "gteq_vec_signed")),[],pure_e,pure_e,nob); - ])); - ]; - -(** ? *) - "oddments", - [ - ("is_one",Base(([],(mk_pure_fun bit_t bit_t)),(External (Some "is_one")),[],pure_e,pure_e,nob)); - ("signed",Base((mk_nat_params["n";"m";"o"]@[("ord",{k=K_Ord})], - (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) - (mk_atom (mk_nv "o")))), - External (Some "signed"), - [(GtEq(Specc(Parse_ast.Int("signed",None)),Guarantee, - mk_nv "o", mk_neg(mk_2n (mk_nv "m")))); - (LtEq(Specc(Parse_ast.Int("signed",None)),Guarantee, - mk_nv "o", mk_sub (mk_2n (mk_nv "m")) n_one));],pure_e,pure_e,nob)); - ("unsigned",Base((mk_nat_params["n";"m";"o"]@[("ord",{k=K_Ord})], - (mk_pure_fun (mk_vector bit_t (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) - (mk_atom (mk_nv "o")))), - External (Some "unsigned"), - [(GtEq(Specc(Parse_ast.Int("unsigned",None)),Guarantee, - mk_nv "o", n_zero)); - (LtEq(Specc(Parse_ast.Int("unsigned",None)),Guarantee, - mk_nv "o", mk_sub (mk_2n (mk_nv "m")) n_one));],pure_e,pure_e,nob)); - - ("ignore",lib_tannot ([("a",{k=K_Typ})],mk_pure_fun {t=Tvar "a"} unit_t) None []); - - (* incorrect types for typechecking processed sail code; do we care? *) - ("mask",Base(((mk_typ_params ["a"])@(mk_nat_params["n";"m";"o";"p"])@(mk_ord_params["ord"]), - (mk_pure_imp (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "n") (mk_nv "m")) - (mk_vector {t=Tvar "a"} (mk_ovar "ord") (mk_nv "p") (mk_nv "o")) "o")), - (External (Some "mask")), - [GtEq(Specc(Parse_ast.Int("mask",None)),Guarantee, (mk_nv "m"), (mk_nv "o"))],pure_e,pure_e,nob)); - (*TODO These should be IP_start *) - ("to_vec_inc",Base(([("a",{k=K_Typ})],{t=Tfn(nat_typ,{t=Tvar "a"},IP_none,pure_e)}), - (External None),[],pure_e,pure_e,nob)); - ("to_vec_dec",Base(([("a",{k=K_Typ})],{t=Tfn(nat_typ,{t=Tvar "a"},IP_none,pure_e)}), - (External None),[],pure_e,pure_e,nob)); - ("print",Base(([],(mk_pure_fun string_t unit_t)),(External None),[],pure_e,pure_e,nob)); (* XXX not actually pure... *) - ]; - - -"option type constructors", - [ - ("Some", Base((["a",{k=K_Typ}], mk_pure_fun {t=Tvar "a"} {t=Tapp("option", [TA_typ {t=Tvar "a"}])}), - Constructor 2,[],pure_e,pure_e,nob)); - ("None", Base((["a", {k=K_Typ}], mk_pure_fun unit_t {t=Tapp("option", [TA_typ {t=Tvar "a"}])}), - Constructor 2,[],pure_e,pure_e,nob)); - ]; - -"list operations", - [ - ("append", - lib_tannot - (["a",{k=K_Typ}], mk_pure_fun (mk_tup [{t=Tapp("list", [TA_typ {t=Tvar "a"}])}; - {t=Tapp("list", [TA_typ {t=Tvar "a"}])}]) - {t=Tapp("list",[TA_typ {t=Tvar "a"}])}) - None []); - ]; - -] - - -let initial_typ_env : tannot Envmap.t = - Envmap.from_list (List.flatten (List.map snd initial_typ_env_list)) - - - -let rec typ_subst s_env leave_imp t = - match t.t with - | Tvar i -> (match Envmap.apply s_env i with - | Some(TA_typ t1) -> t1 - | _ -> { t = Tvar i}) - | Tuvar _ -> new_t() - | Tid i -> { t = Tid i} - | Tfn(t1,t2,imp,e) -> - {t =Tfn((typ_subst s_env false t1),(typ_subst s_env false t2),(ip_subst s_env leave_imp imp),(e_subst s_env e)) } - | Ttup(ts) -> { t= Ttup(List.map (typ_subst s_env leave_imp) ts) } - | Tapp(i,args) -> {t= Tapp(i,List.map (ta_subst s_env leave_imp) args)} - | Tabbrev(ti,ta) -> {t = Tabbrev(typ_subst s_env leave_imp ti,typ_subst s_env leave_imp ta) } - | Toptions(t1,None) -> {t = Toptions(typ_subst s_env leave_imp t1,None)} - | Toptions(t1,Some t2) -> {t = Toptions(typ_subst s_env leave_imp t1,Some (typ_subst s_env leave_imp t2)) } -and ip_subst s_env leave_imp ip = - let leave_nu = if leave_imp then leave_nuvar else (fun i -> i) in - match ip with - | IP_none -> ip - | IP_length n -> IP_length (leave_nu (n_subst s_env n)) - | IP_start n -> IP_start (leave_nu (n_subst s_env n)) - | IP_user n -> IP_user (leave_nu (n_subst s_env n)) -and ta_subst s_env leave_imp ta = - match ta with - | TA_typ t -> TA_typ (typ_subst s_env leave_imp t) - | TA_nexp n -> TA_nexp (n_subst s_env n) - | TA_eft e -> TA_eft (e_subst s_env e) - | TA_ord o -> TA_ord (o_subst s_env o) -and n_subst s_env n = - match n.nexp with - | Nvar i -> - (match Envmap.apply s_env i with - | Some(TA_nexp n1) -> n1 - | _ -> mk_nv i) - | Nid(i,n) -> n_subst s_env n - | Nuvar _ -> new_n() - | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> n - | N2n(n1,None) -> mk_2n (n_subst s_env n1) - | N2n(n1,Some(i)) -> mk_2nc (n_subst s_env n1) i - | Npow(n1,i) -> mk_pow (n_subst s_env n1) i - | Nneg n1 -> mk_neg (n_subst s_env n1) - | Nadd(n1,n2) -> mk_add (n_subst s_env n1) (n_subst s_env n2) - | Nsub(n1,n2) -> mk_sub (n_subst s_env n1) (n_subst s_env n2) - | Nmult(n1,n2) -> mk_mult(n_subst s_env n1) (n_subst s_env n2) -and o_subst s_env o = - match o.order with - | Ovar i -> (match Envmap.apply s_env i with - | Some(TA_ord o1) -> o1 - | _ -> { order = Ovar i }) - | Ouvar _ -> new_o () - | _ -> o -and e_subst s_env e = - match e.effect with - | Evar i -> (match Envmap.apply s_env i with - | Some(TA_eft e1) -> e1 - | _ -> {effect = Evar i}) - | Euvar _ -> new_e () - | _ -> e - -let rec cs_subst t_env cs = - match cs with - | [] -> [] - | Eq(l,n1,n2)::cs -> Eq(l,n_subst t_env n1,n_subst t_env n2)::(cs_subst t_env cs) - | NtEq(l,n1,n2)::cs -> NtEq(l, n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs) - | GtEq(l,enforce,n1,n2)::cs -> GtEq(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs) - | Gt(l,enforce,n1,n2)::cs -> Gt(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs) - | LtEq(l,enforce,n1,n2)::cs -> LtEq(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs) - | Lt(l,enforce,n1,n2)::cs -> Lt(l,enforce,n_subst t_env n1, n_subst t_env n2)::(cs_subst t_env cs) - | In(l,s,ns)::cs -> - let nexp = n_subst t_env (mk_nv s) in - (match nexp.nexp with - | Nuvar urec -> urec.nin <- true - | _ -> ()); - InS(l,nexp,ns)::(cs_subst t_env cs) - | InS(l,n,ns)::cs -> InS(l,n_subst t_env n,ns)::(cs_subst t_env cs) - | Predicate(l, cp,cn)::cs -> - Predicate(l, List.hd(cs_subst t_env [cp]), List.hd(cs_subst t_env [cn]))::(cs_subst t_env cs) - | CondCons(l,kind,_,cs_p,cs_e)::cs -> - CondCons(l,kind,None,cs_subst t_env cs_p,cs_subst t_env cs_e)::(cs_subst t_env cs) - | BranchCons(l,_,bs)::cs -> BranchCons(l,None,cs_subst t_env bs)::(cs_subst t_env cs) - -let subst_with_env env leave_imp t cs e = - (typ_subst env leave_imp t, cs_subst env cs, e_subst env e, env) - -let subst_n_with_env = n_subst - -let subst (k_env : (Envmap.k * kind) list) (leave_imp:bool) (use_var:bool) - (t : t) (cs : nexp_range list) (e : effect) : (t * nexp_range list * effect * t_arg emap) = - let subst_env = Envmap.from_list - (List.map (fun (id,k) -> (id, - match k.k with - | K_Typ -> TA_typ (if use_var then (new_tv id) else (new_t ())) - | K_Nat -> TA_nexp (if use_var then (new_nv id) else (new_n ())) - | K_Ord -> TA_ord (new_o ()) - | K_Efct -> TA_eft (new_e ()) - | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown - "substitution given an environment with a non-base-kind kind"))) k_env) - in - subst_with_env subst_env leave_imp t cs e - -let rec typ_param_eq l spec_param fun_param = - match (spec_param,fun_param) with - | ([],[]) -> [] - | (_,[]) -> - raise (Reporting_basic.err_typ l "Specification type variables and function definition variables must match") - | ([],_) -> - raise - (Reporting_basic.err_typ l "Function definition declares more type variables than specification variables") - | ((ids,tas)::spec_param,(idf,taf)::fun_param) -> - if ids=idf - then match (tas,taf) with - | (TA_typ tas_t,TA_typ taf_t) -> (equate_t tas_t taf_t); typ_param_eq l spec_param fun_param - | (TA_nexp tas_n, TA_nexp taf_n) -> Eq((Specc l),tas_n,taf_n)::typ_param_eq l spec_param fun_param - | (TA_ord tas_o,TA_ord taf_o) -> (equate_o tas_o taf_o); typ_param_eq l spec_param fun_param - | (TA_eft tas_e,TA_eft taf_e) -> (equate_e tas_e taf_e); typ_param_eq l spec_param fun_param - | _ -> - raise (Reporting_basic.err_typ l - ("Specification and function definition have different kinds for variable " ^ ids)) - else raise (Reporting_basic.err_typ l - ("Specification type variables must match in order and number the function definition type variables, stopped matching at " ^ ids ^ " and " ^ idf)) - -let type_param_consistent l spec_param fun_param = - let specs = Envmap.to_list spec_param in - let funs = Envmap.to_list fun_param in - match specs,funs with - | [],[] | _,[] -> [] - | _ -> typ_param_eq l specs funs - -let rec t_remove_unifications s_env t = - match t.t with - | Tvar _ | Tid _-> s_env - | Tuvar tu -> - (match tu.subst with - | None -> - (match fresh_tvar s_env t with - | Some ks -> Envmap.insert s_env ks - | None -> s_env) - | _ -> ignore(resolve_tsubst t); s_env) - | Tfn(t1,t2,_,e) -> e_remove_unifications (t_remove_unifications (t_remove_unifications s_env t1) t2) e - | Ttup(ts) -> List.fold_right (fun t s_env -> t_remove_unifications s_env t) ts s_env - | Tapp(i,args) -> List.fold_left (fun s_env t -> ta_remove_unifications s_env t) s_env args - | Tabbrev(ti,ta) -> (t_remove_unifications (t_remove_unifications s_env ti) ta) - | Toptions(t1,t2) -> assert false (*This should really be removed by this point*) -and ta_remove_unifications s_env ta = - match ta with - | TA_typ t -> (t_remove_unifications s_env t) - | TA_nexp n -> (n_remove_unifications s_env n) - | TA_eft e -> (e_remove_unifications s_env e) - | TA_ord o -> (o_remove_unifications s_env o) -and n_remove_unifications s_env n = - (*let _ = Printf.eprintf "n_remove_unifications %s\n" (n_to_string n) in*) - match n.nexp with - | Nvar _ | Nid _ | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> s_env - | Nuvar _ -> - let _ = collapse_nuvar_chain (get_outer_most n) in - (*let _ = Printf.eprintf "nuvar is before turning into var %s\n" (n_to_string n) in*) - (match fresh_nvar s_env n with - | Some ks -> Envmap.insert s_env ks - | None -> s_env) - | N2n(n1,_) | Npow(n1,_) | Nneg n1 -> (n_remove_unifications s_env n1) - | Nadd(n1,n2) | Nsub(n1,n2) | Nmult(n1,n2) -> (n_remove_unifications (n_remove_unifications s_env n1) n2) -and o_remove_unifications s_env o = - match o.order with - | Ouvar _ -> (match fresh_ovar s_env o with - | Some ks -> Envmap.insert s_env ks - | None -> s_env) - | _ -> s_env -and e_remove_unifications s_env e = - match e.effect with - | Euvar _ -> (match fresh_evar s_env e with - | Some ks -> Envmap.insert s_env ks - | None -> s_env) - | _ -> s_env - - -let remove_internal_unifications s_env = - let rec rem remove s_env u_list = match u_list with - | [] -> s_env - | i::u_list -> rem remove (remove s_env i) u_list - in - (rem e_remove_unifications - (rem o_remove_unifications - (rem n_remove_unifications - (rem t_remove_unifications s_env !tuvars) - !nuvars) - !ouvars) - !euvars) - -let rec t_to_typ t = - match t.t with - | Tid i -> Typ_aux(Typ_id (Id_aux((Id i), Parse_ast.Unknown)),Parse_ast.Unknown) - | Tvar i -> Typ_aux(Typ_var (Kid_aux((Var i),Parse_ast.Unknown)),Parse_ast.Unknown) - | Tfn(t1,t2,_,e) -> Typ_aux(Typ_fn (t_to_typ t1, t_to_typ t2, e_to_ef e),Parse_ast.Unknown) - | Ttup ts -> Typ_aux(Typ_tup(List.map t_to_typ ts),Parse_ast.Unknown) - | Tapp(i,args) -> - Typ_aux(Typ_app(Id_aux((Id i), Parse_ast.Unknown),List.map targ_to_typ_arg args),Parse_ast.Unknown) - | Tabbrev(t,_) -> t_to_typ t - | Tuvar _ | Toptions _ -> Typ_aux(Typ_var (Kid_aux((Var "fresh"),Parse_ast.Unknown)),Parse_ast.Unknown) -and targ_to_typ_arg targ = - Typ_arg_aux( - (match targ with - | TA_nexp n -> Typ_arg_nexp (n_to_nexp n) - | TA_typ t -> Typ_arg_typ (t_to_typ t) - | TA_ord o -> Typ_arg_order (o_to_order o) - | TA_eft e -> Typ_arg_effect (e_to_ef e)), Parse_ast.Unknown) -and n_to_nexp n = - Nexp_aux( - (match n.nexp with - | Nid(i,_) -> Nexp_id (Id_aux ((Id i),Parse_ast.Unknown)) - | Nvar i -> Nexp_var (Kid_aux((Var i),Parse_ast.Unknown)) - | Nconst i -> Nexp_constant (int_of_big_int i) (*TODO: Push more bigint around*) - | Npos_inf -> Nexp_constant max_int (*TODO: Not right*) - | Nneg_inf -> Nexp_constant min_int (* see above *) - | Ninexact -> Nexp_constant min_int (*and above*) - | Nmult(n1,n2) -> Nexp_times(n_to_nexp n1,n_to_nexp n2) - | Nadd(n1,n2) -> Nexp_sum(n_to_nexp n1,n_to_nexp n2) - | Nsub(n1,n2) -> Nexp_minus(n_to_nexp n1,n_to_nexp n2) - | N2n(n,_) -> Nexp_exp (n_to_nexp n) - | Npow(n,1) -> let Nexp_aux(n',_) = n_to_nexp n in n' - | Npow(n,i) -> Nexp_times(n_to_nexp n,n_to_nexp( mk_pow n (i-1))) - | Nneg n -> Nexp_neg (n_to_nexp n) - | Nuvar _ -> Nexp_var (Kid_aux((Var "fresh"),Parse_ast.Unknown))), Parse_ast.Unknown) -and e_to_ef ef = - Effect_aux( - (match ef.effect with - | Evar i -> Effect_var (Kid_aux((Var i),Parse_ast.Unknown)) - | Eset effects -> Effect_set effects - | Euvar _ -> assert false), Parse_ast.Unknown) -and o_to_order o = - Ord_aux( - (match o.order with - | Ovar i -> Ord_var (Kid_aux((Var i),Parse_ast.Unknown)) - | Oinc -> Ord_inc - | Odec -> Ord_dec - | Ouvar _ -> Ord_var (Kid_aux((Var "fresh"),Parse_ast.Unknown))), Parse_ast.Unknown) - -let rec get_abbrev d_env t = - match t.t with - | Tid i -> - (match Envmap.apply d_env.abbrevs i with - | Some(Base((params,ta),tag,cs,efct,_,_)) -> - let ta,cs,_,_ = subst params false false ta cs efct in - let ta,cs' = get_abbrev d_env ta in - (match ta.t with - | Tabbrev(t',ta) -> ({t=Tabbrev({t=Tabbrev(t,t')},ta)},cs@cs') - | _ -> ({t = Tabbrev(t,ta)},cs)) - | _ -> t,[]) - | Tapp(i,args) -> - (match Envmap.apply d_env.abbrevs i with - | Some(Base((params,ta),tag,cs,efct,_,_)) -> - let env = Envmap.from_list2 (List.map fst params) args in - let ta,cs' = get_abbrev d_env (typ_subst env false ta) in - (match ta.t with - | Tabbrev(t',ta) -> ({t=Tabbrev({t=Tabbrev(t,t')},ta)},cs_subst env (cs@cs')) - | _ -> ({t = Tabbrev(t,ta)},cs_subst env cs)) - | _ -> t,[]) - | _ -> t,[] - -let is_enum_typ d_env t = - let t,_ = get_abbrev d_env t in - let t_actual = match t.t with | Tabbrev(_,ta) -> ta | _ -> t in - match t_actual.t with - | Tid i -> (match Envmap.apply d_env.enum_env i with - | Some(ns) -> Some(List.length ns) - | _ -> None) - | _ -> None - -let eq_error l msg = raise (Reporting_basic.err_typ l msg) -let multi_constraint_error l1 l2 msg = raise (Reporting_basic.err_typ_dual (get_c_loc l1) (get_c_loc l2) msg) - -let compare_effect (BE_aux(e1,_)) (BE_aux(e2,_)) = - match e1,e2 with - | (BE_rreg,BE_rreg) -> 0 - | (BE_rreg,_) -> -1 - | (_,BE_rreg) -> 1 - | (BE_wreg,BE_wreg) -> 0 - | (BE_wreg,_) -> -1 - | (_,BE_wreg) -> 1 - | (BE_rmem,BE_rmem) -> 0 - | (BE_rmem,_) -> -1 - | (_,BE_rmem) -> 1 - | (BE_rmemt,BE_rmemt) -> 0 - | (BE_rmemt,_) -> -1 - | (_,BE_rmemt) -> 1 - | (BE_wmem,BE_wmem) -> 0 - | (BE_wmem,_) -> -1 - | (_,BE_wmem) -> 1 - | (BE_wmv,BE_wmv) -> 0 - | (BE_wmv, _ ) -> -1 - | (_,BE_wmv) -> 1 - | (BE_wmvt,BE_wmvt) -> 0 - | (BE_wmvt, _ ) -> -1 - | (_,BE_wmvt) -> 1 - | (BE_eamem,BE_eamem) -> 0 - | (BE_eamem,_) -> -1 - | (_,BE_eamem) -> 1 - | (BE_exmem,BE_exmem) -> 0 - | (BE_exmem,_) -> -1 - | (_,BE_exmem) -> 1 - | (BE_barr,BE_barr) -> 0 - | (BE_barr,_) -> 1 - | (_,BE_barr) -> -1 - | (BE_undef,BE_undef) -> 0 - | (BE_undef,_) -> -1 - | (_,BE_undef) -> 1 - | (BE_unspec,BE_unspec) -> 0 - | (BE_unspec,_) -> -1 - | (_,BE_unspec) -> 1 - | (BE_nondet,BE_nondet) -> 0 - | (BE_nondet,_) -> -1 - | (_,BE_nondet) -> 1 - | (BE_depend,BE_depend) -> 0 - | (BE_depend,_) -> -1 - | (_,BE_depend) -> 1 - | (BE_lset,BE_lset) -> 0 - | (BE_lset,_) -> -1 - | (_,BE_lset) -> 1 - | (BE_lret,BE_lret) -> 0 - | (BE_lret,_) -> -1 - | (_, BE_lret) -> 1 - | (BE_escape,BE_escape) -> 0 - -let effect_sort = List.sort compare_effect - -let eq_be_effect (BE_aux (e1,_)) (BE_aux(e2,_)) = e1 = e2 - -(* Check that o1 is or can be eqaul to o2. - In the event that one is polymorphic, inc or dec can be used polymorphically but 'a cannot be used as inc or dec *) -let order_eq co o1 o2 = - let l = get_c_loc co in - match (o1.order,o2.order) with - | (Oinc,Oinc) | (Odec,Odec) | (Oinc,Ovar _) | (Odec,Ovar _) -> o2 - | (Ouvar i,_) -> equate_o o1 o2; o2 - | (_,Ouvar i) -> equate_o o2 o1; o2 - | (Ovar v1,Ovar v2) -> if v1=v2 then o2 - else eq_error l ("Order variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified") - | (Oinc,Odec) | (Odec,Oinc) -> eq_error l "Order mismatch of inc and dec" - | (Ovar v1,Oinc) -> eq_error l ("Polymorphic order " ^ v1 ^ " cannot be used where inc is expected") - | (Ovar v1,Odec) -> eq_error l ("Polymorhpic order " ^ v1 ^ " cannot be used where dec is expected") - -let rec remove_internal_effects = function - | [] -> [] - | (BE_aux((BE_lset | BE_lret),_))::effects -> remove_internal_effects effects - | b::effects -> b::(remove_internal_effects effects) - -let has_effect searched_for eff = - match eff.effect with - | Eset es -> - List.exists (eq_be_effect searched_for) es - | _ -> false - -let has_rreg_effect = has_effect (BE_aux(BE_rreg, Parse_ast.Unknown)) -let has_wreg_effect = has_effect (BE_aux(BE_wreg, Parse_ast.Unknown)) -let has_rmem_effect = has_effect (BE_aux(BE_rmem, Parse_ast.Unknown)) -let has_rmemt_effect = has_effect (BE_aux(BE_rmemt, Parse_ast.Unknown)) -let has_wmem_effect = has_effect (BE_aux(BE_wmem, Parse_ast.Unknown)) -let has_eamem_effect = has_effect (BE_aux(BE_eamem, Parse_ast.Unknown)) -let has_exmem_effect = has_effect (BE_aux(BE_exmem, Parse_ast.Unknown)) -let has_memv_effect = has_effect (BE_aux(BE_wmv, Parse_ast.Unknown)) -let has_memvt_effect = has_effect (BE_aux(BE_wmvt, Parse_ast.Unknown)) -let has_lret_effect = has_effect (BE_aux(BE_lret, Parse_ast.Unknown)) - -(*Similarly to above.*) -let effects_eq co e1 e2 = - let l = get_c_loc co in - match e1.effect,e2.effect with - | Eset _ , Evar _ -> e2 - | Euvar i,_ -> equate_e e1 e2; e2 - | _,Euvar i -> equate_e e2 e1; e2 - | Eset es1,Eset es2 -> - let es1, es2 = remove_internal_effects es1, remove_internal_effects es2 in - if (List.length es1) = (List.length es2) && (List.for_all2 eq_be_effect (effect_sort es1) (effect_sort es2) ) - then e2 - else eq_error l ("Effects must be the same, given " ^ e_to_string e1 ^ " and " ^ e_to_string e2) - | Evar v1, Evar v2 -> if v1 = v2 then e2 - else eq_error l ("Effect variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified") - | Evar v1, Eset _ -> - eq_error l ("Effect variable " ^ v1 ^ " cannot be used where a concrete set of effects is specified") - - -let build_variable_range d_env v typ = - let t,_ = get_abbrev d_env typ in - let t_actual = match t.t with | Tabbrev(_,t) -> t | _ -> t in - match t_actual.t with - | Tapp("atom", [TA_nexp n]) -> Some(VR_eq(v,n)) - | Tapp("range", [TA_nexp base;TA_nexp top]) -> - Some(VR_range(v,[LtEq((Patt Parse_ast.Unknown),Require,base,top)])) - | Tapp("vector", [TA_nexp start; TA_nexp rise; _; _]) -> Some(VR_vec_eq(v,rise)) - | Tuvar _ -> Some(VR_recheck(v,t_actual)) - | _ -> None - -let get_vr_var = - function | VR_eq (v,_) | VR_range(v,_) | VR_vec_eq(v,_) | VR_vec_r(v,_) | VR_recheck(v,_) -> v - -let compare_variable_range v1 v2 = compare (get_vr_var v1) (get_vr_var v2) - -let extract_bounds d_env v typ = - match build_variable_range d_env v typ with - | None -> No_bounds - | Some vb -> Bounds([vb], None) - -let find_bounds v bounds = match bounds with - | No_bounds -> None - | Bounds(bs,maps) -> - let rec find_rec bs = match bs with - | [] -> None - | b::bs -> if (get_vr_var b) = v then Some(b) else find_rec bs in - find_rec bs - -let add_map_to_bounds m bounds = match bounds with - | No_bounds -> Bounds([],Some m) - | Bounds(bs,None) -> Bounds(bs,Some m) - | Bounds(bs,Some m') -> Bounds(bs,Some (Nexpmap.union m m')) - -let rec add_map_tannot m tannot = match tannot with - | NoTyp -> NoTyp - | Base(params,tag,cs,efl,efr,bounds) -> Base(params,tag,cs,efl,efr,add_map_to_bounds m bounds) - | Overload(t,r,ts) -> Overload(add_map_tannot m t,r,ts) - -let get_map_bounds = function - | No_bounds -> None - | Bounds(_,m) -> m - -let get_map_tannot = function - | NoTyp -> None - | Base(_,_,_,_,_,bounds) -> get_map_bounds bounds - | Overload _ -> None - -let rec expand_nexp n = match n.nexp with - | Nvar _ | Nconst _ | Nuvar _ | Npos_inf | Nneg_inf | Ninexact -> [n] - | Nadd (n1,n2) | Nsub (n1,n2) | Nmult (n1,n2) -> n::((expand_nexp n1)@(expand_nexp n2)) - | N2n (n1,_) | Npow (n1,_) | Nneg n1 | Nid(_,n1) -> n::(expand_nexp n1) - -let is_nconst n = match n.nexp with | Nconst _ -> true | _ -> false - -let find_var_from_nexp n bounds = - (*let _ = Printf.eprintf "finding %s in bounds\n" (n_to_string n) in*) - if is_nconst n then None - else match bounds with - | No_bounds -> None - | Bounds(bs,map) -> - let rec find_rec bs n = match bs with - | [] -> None - | b::bs -> (match b with - | VR_eq(ev,n1) -> - (*let _ = Printf.eprintf "checking if %s is eq to %s, to bind to %s, eq? %b\n" - (n_to_string n) (n_to_string n1) ev (nexp_eq_check n1 n) in*) - if nexp_eq_check n1 n then Some (None,ev) else find_rec bs n - | VR_vec_eq (ev,n1)-> - (*let _ = Printf.eprintf "checking if %s is eq to %s, to bind to %s, eq? %b\n" - (n_to_string n) (n_to_string n1) ev (nexp_eq_check n1 n) in*) - if nexp_eq_check n1 n then Some (Some "length",ev) else find_rec bs n - | _ -> find_rec bs n) in - match find_rec bs n,map with - | None, None -> None - | None, Some map -> - (match Nexpmap.apply map n with - | None -> None - | Some n' -> find_rec bs n') - | s,_ -> s - -let merge_bounds b1 b2 = - match b1,b2 with - | No_bounds,b | b,No_bounds -> b - | Bounds(b1s,map1),Bounds(b2s,map2) -> - let merged_map = match map1,map2 with - | None, None -> None - | None, m | m, None -> m - | Some m1, Some m2 -> Some (Nexpmap.union m1 m2) in - let b1s = List.sort compare_variable_range b1s in - let b2s = List.sort compare_variable_range b2s in - let rec merge b1s b2s = match (b1s,b2s) with - | [],b | b,[] -> b - | b1::b1s,b2::b2s -> - match compare_variable_range b1 b2 with - | -1 -> b1::(merge b1s (b2::b2s)) - | 1 -> b2::(merge (b1::b1s) b2s) - | _ -> (match b1,b2 with - | VR_eq(v,n1),VR_eq(_,n2) -> - if nexp_eq n1 n2 then b1 else VR_range(v,[Eq((Patt Parse_ast.Unknown),n1,n2)]) - | VR_eq(v,n),VR_range(_,ranges) | - VR_range(v,ranges),VR_eq(_,n) -> VR_range(v,(Eq((Patt Parse_ast.Unknown),n,n))::ranges) - | VR_range(v,ranges1),VR_range(_,ranges2) -> VR_range(v, List.rev_append (List.rev ranges1) ranges2) - | VR_vec_eq(v,n1),VR_vec_eq(_,n2) -> - if nexp_eq n1 n2 then b1 else VR_vec_r(v,[Eq((Patt Parse_ast.Unknown),n1,n2)]) - | VR_vec_eq(v,n),VR_vec_r(_,ranges) | - VR_vec_r(v,ranges),VR_vec_eq(_,n) -> VR_vec_r(v,(Eq((Patt Parse_ast.Unknown),n,n)::ranges)) - | _ -> b1 - )::(merge b1s b2s) in - Bounds ((merge b1s b2s),merged_map) - -let rec conforms_to_t d_env loosely within_coercion spec actual = - (*let _ = Printf.eprintf "conforms_to_t called, evaluated loosely? %b & within_coercion? %b, with spec %s and actual %s\n" - within_coercion loosely (t_to_string spec) (t_to_string actual) in*) - let spec,_ = get_abbrev d_env spec in - let actual,_ = get_abbrev d_env actual in - match (spec.t,actual.t,loosely) with - | (Tuvar _,_,true) -> true - | (Ttup ss, Ttup acs,_) -> - (List.length ss = List.length acs) && List.for_all2 (conforms_to_t d_env loosely within_coercion) ss acs - | (Tid is, Tid ia,_) -> is = ia - | (Tapp(is,tas), Tapp("register",[TA_typ t]),true) -> - if is = "register" && (List.length tas) = 1 - then List.for_all2 (conforms_to_ta d_env loosely within_coercion) tas [TA_typ t] - else conforms_to_t d_env loosely within_coercion spec t - | (Tapp("vector",[TA_nexp bs;TA_nexp rs;TA_ord os;TA_typ ts]), - Tapp("vector",[TA_nexp ba;TA_nexp ra;TA_ord oa;TA_typ ta]),_) -> - conforms_to_t d_env loosely within_coercion ts ta - && conforms_to_o loosely os oa - && conforms_to_n false within_coercion eq_big_int rs ra - | (Tapp("range",[TA_nexp bs;TA_nexp rs]),Tapp("range",[TA_nexp ba;TA_nexp ra]),_) -> true (* - conforms_to_n true within_coercion le_big_int bs ba && conforms_to_n true within_coercion ge_big_int rs ra *) - | (Tapp("atom",[TA_nexp n]),Tapp("range",[TA_nexp ba;TA_nexp ra]),_) -> true (* - conforms_to_n true within_coercion le_big_int ba n && conforms_to_n true within_coercion ge_big_int n ra *) - | (Tapp("range",[TA_nexp bs;TA_nexp rs]),Tapp("atom",[TA_nexp n]),_) -> true (* - conforms_to_n true within_coercion le_big_int bs n && conforms_to_n true within_coercion ge_big_int rs n && - conforms_to_n true within_coercion ge_big_int bs n *) - | (Tapp(is,tas), Tapp(ia, taa),_) -> -(* let _ = Printf.eprintf "conforms to given two apps: %b, %b\n" - (is = ia) (List.length tas = List.length taa) in*) - (is = ia) && (List.length tas = List.length taa) && - (List.for_all2 (conforms_to_ta d_env loosely within_coercion) tas taa) - | (Tid "bit", Tapp("vector",[_;_;_;TA_typ ti]), _) -> - within_coercion && - conforms_to_t d_env loosely within_coercion spec ti - | (Tabbrev(_,s),a,_) -> conforms_to_t d_env loosely within_coercion s actual - | (s,Tabbrev(_,a),_) -> conforms_to_t d_env loosely within_coercion spec a - | (_,_,_) -> false -and conforms_to_ta d_env loosely within_coercion spec actual = -(*let _ = Printf.eprintf "conforms_to_ta called, evaluated loosely? %b, with %s and %s\n" - loosely (targ_to_string spec) (targ_to_string actual) in*) - match spec,actual with - | TA_typ s, TA_typ a -> conforms_to_t d_env loosely within_coercion s a - | TA_nexp s, TA_nexp a -> conforms_to_n loosely within_coercion eq_big_int s a - | TA_ord s, TA_ord a -> conforms_to_o loosely s a - | TA_eft s, TA_eft a -> conforms_to_e loosely s a - | _ -> false -and conforms_to_n loosely within_coercion op spec actual = -(* let _ = Printf.eprintf "conforms_to_n called, evaluated loosely? %b, with coercion? %b with %s and %s\n" - loosely within_coercion (n_to_string spec) (n_to_string actual) in*) - match (spec.nexp,actual.nexp,loosely,within_coercion) with - | (Nconst si,Nconst ai,_,_) -> op si ai - | (Nconst _,Nuvar _,false,false) -> false - | _ -> true -and conforms_to_o loosely spec actual = - match (spec.order,actual.order,loosely) with - | (Ouvar _,_,true) | (Oinc,Oinc,_) | (Odec,Odec,_) | (_, Ouvar _,_) -> true - | _ -> false -and conforms_to_e loosely spec actual = - match (spec.effect,actual.effect,loosely) with - | (Euvar _,_,true) -> true - | (_,Euvar _,true) -> false - | _ -> - try begin ignore (effects_eq (Specc Parse_ast.Unknown) spec actual); true end with - | _ -> false - -(*Is checking for structural equality amongst the types, building constraints for kind Nat. - When considering two range type applications, will check for consistency instead of equality - When considering two atom type applications, will expand into a range encompasing both when widen is true -*) -let rec type_consistent_internal co d_env enforce widen t1 cs1 t2 cs2 = - let l = get_c_loc co in - let t1,cs1' = get_abbrev d_env t1 in - let t2,cs2' = get_abbrev d_env t2 in - let cs1,cs2 = cs1@cs1',cs2@cs2' in - let csp = cs1@cs2 in - let t1_actual = match t1.t with | Tabbrev(_,t1) -> t1 | _ -> t1 in - let t2_actual = match t2.t with | Tabbrev(_,t2) -> t2 | _ -> t2 in -(* let _ = Printf.eprintf "type_consistent_internal called with, widen? %b, %s with actual %s and %s with actual %s\n" - widen (t_to_string t1) (t_to_string t1_actual) (t_to_string t2) (t_to_string t2_actual) in*) - match t1_actual.t,t2_actual.t with - | Tvar v1,Tvar v2 -> - if v1 = v2 then (t2,csp) - else eq_error l ("Type variables " ^ v1 ^ " and " ^ v2 ^ " do not match and cannot be unified") - | Tid v1,Tid v2 -> - if v1 = v2 then (t2,csp) - else eq_error l ("Types " ^ v1 ^ " and " ^ v2 ^ " do not match") - | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tapp("range",[TA_nexp b2;TA_nexp r2;]) -> - if (nexp_eq b1 b2)&&(nexp_eq r1 r2) - then (t2,csp) - else (t1, csp@[GtEq(co,enforce,b1,b2);LtEq(co,enforce,r1,r2)]) - | Tapp("atom",[TA_nexp a]),Tapp("range",[TA_nexp b1; TA_nexp r1]) -> - (t1, csp@[GtEq(co,enforce,a,b1);LtEq(co,enforce,a,r1)]) - | Tapp("range",[TA_nexp b1; TA_nexp r1]),Tapp("atom",[TA_nexp a]) -> - (t2, csp@[LtEq(co,Guarantee,b1,a);GtEq(co,Guarantee,r1,a)]) - | Tapp("atom",[TA_nexp a1]),Tapp("atom",[TA_nexp a2]) -> - if nexp_eq a1 a2 - then (t2,csp) - else if not(widen) - then (t1, csp@[Eq(co,a1,a2)]) - else (match a1.nexp,a2.nexp with - | Nconst i1, Nconst i2 -> - if lt_big_int i1 i2 - then ({t= Tapp("range",[TA_nexp a1;TA_nexp a2])},csp) - else ({t=Tapp ("range",[TA_nexp a2;TA_nexp a1])},csp) - (*| Nconst _, Nuvar _ | Nuvar _, Nconst _-> - (t1, csp@[Eq(co,a1,a2)])*) (*TODO This is the correct constraint. - However, without the proper support for In checks actually working, - this will cause specs to not build*) - | _ -> (*let nu1,nu2 = new_n (),new_n () in - ({t=Tapp("range",[TA_nexp nu1;TA_nexp nu2])}, - csp@[LtEq(co,enforce,nu1,a1);LtEq(co,enforce,nu1,a2);LtEq(co,enforce,a1,nu2);LtEq(co,enforce,a2,nu2)])*) - (t1, csp@[LtEq(co,enforce,a1,a2);(GtEq(co,enforce,a1,a2))])) - (*EQ is the right thing to do, but see above. Introducing new free vars here is bad*) - | Tapp("vector",[TA_nexp b1; TA_nexp l1; ord; ty1]),Tapp("vector",[TA_nexp b2; TA_nexp l2; ord2; ty2]) -> - let cs = if widen then [Eq(co,l1,l2)] else [Eq(co,l1,l2);Eq(co,b1,b2)] in - (t2, cs@(type_arg_eq co d_env enforce widen ord ord2)@(type_arg_eq co d_env enforce widen ty1 ty2)) - | Tapp(id1,args1), Tapp(id2,args2) -> - (*let _ = Printf.eprintf "checking consistency of %s and %s\n" id1 id2 in*) - let la1,la2 = List.length args1, List.length args2 in - if id1=id2 && la1 = la2 - then (t2,csp@(List.flatten (List.map2 (type_arg_eq co d_env enforce widen) args1 args2))) - else eq_error l ("Type application of " ^ (t_to_string t1) ^ " and " ^ (t_to_string t2) ^ " must match") - | Tfn(tin1,tout1,_,effect1),Tfn(tin2,tout2,_,effect2) -> - let (tin,cin) = type_consistent co d_env Require widen tin1 tin2 in - let (tout,cout) = type_consistent co d_env Guarantee widen tout1 tout2 in - let _ = effects_eq co effect1 effect2 in - (t2,csp@cin@cout) - | Ttup t1s, Ttup t2s -> - (t2,csp@(List.flatten (List.map snd (List.map2 (type_consistent co d_env enforce widen) t1s t2s)))) - | Tuvar _, t -> equate_t t1 t2; (t1,csp) - (*| Tapp("range",[TA_nexp b;TA_nexp r]),Tuvar _ -> - let b2,r2 = new_n (), new_n () in - let t2' = {t=Tapp("range",[TA_nexp b2;TA_nexp r2])} in - equate_t t2 t2'; - (t2,csp@[GtEq(co,enforce,b,b2);LtEq(co,enforce,r,r2)])*) - | Tapp("atom",[TA_nexp a]),Tuvar _ -> - if widen - then - let b,r = new_n (), new_n () in - let t2' = {t=Tapp("range",[TA_nexp b;TA_nexp r])} in - begin equate_t t2 t2'; - (t2,csp@[GtEq(co,enforce,a,b);LtEq(co,enforce,a,r)]) end - else begin equate_t t2 t1; (t2,csp) end - | t,Tuvar _ -> equate_t t2 t1; (t2,csp) - | _,_ -> eq_error l ("Type mismatch found " ^ (t_to_string t1) ^ " but expected a " ^ (t_to_string t2)) - -and type_arg_eq co d_env enforce widen ta1 ta2 = - match ta1,ta2 with - | TA_typ t1,TA_typ t2 -> snd (type_consistent co d_env enforce widen t1 t2) - | TA_nexp n1,TA_nexp n2 -> if nexp_eq n1 n2 then [] else [Eq(co,n1,n2)] - | TA_eft e1,TA_eft e2 -> (ignore(effects_eq co e1 e2); []) - | TA_ord o1,TA_ord o2 -> (ignore(order_eq co o1 o2);[]) - | _,_ -> eq_error (get_c_loc co) "Type arguments must be of the same kind" - -and type_consistent co d_env enforce widen t1 t2 = - type_consistent_internal co d_env enforce widen t1 [] t2 [] - -let rec type_coerce_internal co d_env enforce is_explicit widen bounds t1 cs1 e t2 cs2 = - let l = get_c_loc co in - let t1,cs1' = get_abbrev d_env t1 in - let t2,cs2' = get_abbrev d_env t2 in - let t1_actual = match t1.t with | Tabbrev(_,t1) -> t1 | _ -> t1 in - let t2_actual = match t2.t with | Tabbrev(_,t2) -> t2 | _ -> t2 in - let cs1,cs2 = cs1@cs1',cs2@cs2' in - let csp = cs1@cs2 in - (*let _ = Printf.eprintf "called type_coerce_internal is_explicit %b, widen %b, turning %s with actual %s into %s with actual %s\n" - is_explicit widen (t_to_string t1) (t_to_string t1_actual) (t_to_string t2) (t_to_string t2_actual) in*) - match t1_actual.t,t2_actual.t with - - (* Toptions is an internal constructor representing the type we're - going to be casting to and the natural type. source-language type - annotations might be demanding a coercion, so this checks - conformance and adds a coercion if needed *) - - | Toptions(to1,Some to2),_ -> - if (conforms_to_t d_env false true to1 t2_actual || conforms_to_t d_env false true to2 t2_actual) - then begin t1_actual.t <- t2_actual.t; (t2,csp,pure_e,e) end - else eq_error l ("Neither " ^ (t_to_string to1) ^ - " nor " ^ (t_to_string to2) ^ " can match expected type " ^ (t_to_string t2)) - | Toptions(to1,None),_ -> - if is_explicit - then type_coerce_internal co d_env enforce is_explicit widen bounds to1 cs1 e t2 cs2 - else (t2,csp,pure_e,e) - | _,Toptions(to1,Some to2) -> - if (conforms_to_t d_env false true to1 t1_actual || conforms_to_t d_env false true to2 t1_actual) - then begin t2_actual.t <- t1_actual.t; (t1,csp,pure_e,e) end - else eq_error l ((t_to_string t1) ^ " can match neither expected type " ^ - (t_to_string to1) ^ " nor " ^ (t_to_string to2)) - | _,Toptions(to1,None) -> - if is_explicit - then type_coerce_internal co d_env enforce is_explicit widen bounds t1_actual cs1 e to1 cs2 - else (t1,csp,pure_e,e) - - (* recursive coercions to components of tuples. They may be - complex expressions, not top-level tuples, so we sometimes - need to add a pattern match. At present we do that almost - always, unnecessarily often. The any_coerced is wrong *) - | Ttup t1s, Ttup t2s -> - let tl1,tl2 = List.length t1s,List.length t2s in - if tl1=tl2 then - let ids = List.map (fun _ -> Id_aux(Id (new_id ()),l)) t1s in - let vars = List.map2 (fun i t -> E_aux(E_id(i),(l,Base(([],t),Emp_local,[],pure_e,pure_e,nob)))) ids t1s in - let (coerced_ts,cs,efs,coerced_vars,any_coerced) = - List.fold_right2 (fun v (t1,t2) (ts,cs,efs,es,coerced) -> - let (t',c',ef,e') = type_coerce co d_env enforce is_explicit widen bounds t1 v t2 in - ((t'::ts),c'@cs,union_effects ef efs,(e'::es), coerced || (v == e'))) - vars (List.combine t1s t2s) ([],[],pure_e,[],false) in - if (not any_coerced) then (t2,cs,pure_e,e) - else let e' = E_aux(E_case(e, - [(Pat_aux(Pat_exp - (P_aux(P_tup - (List.map2 - (fun i t -> - P_aux(P_id i, - (l, - (*TODO should probably link i and t in bindings*) - (Base(([],t),Emp_local,[],pure_e,pure_e,nob))))) - ids t1s),(l,Base(([],t1),Emp_local,[],pure_e,pure_e,nob))), - E_aux(E_tuple coerced_vars, - (l,Base(([],t2),Emp_local,cs,pure_e,pure_e,nob)))), - (l,Base(([],t2),Emp_local,[],pure_e,pure_e,nob))))]), - (l,(Base(([],t2),Emp_local,[],pure_e,pure_e,nob)))) in - (t2,csp@cs,efs,e') - else eq_error l ("Found a tuple of length " ^ (string_of_int tl1) ^ - " but expected a tuple of length " ^ (string_of_int tl2)) - - - (* all the Tapp cases *) - | Tapp(id1,args1),Tapp(id2,args2) -> - if id1=id2 && (id1 <> "vector") - (* no coercion needed, so fall back to consistency *) - then let t',cs' = type_consistent co d_env enforce widen t1 t2 in (t',cs',pure_e,e) - else (match id1,id2,is_explicit with - - (* can coerce between two vectors just to change the start index *) - | "vector","vector",_ -> - (match args1,args2 with - | [TA_nexp b1;TA_nexp r1;TA_ord o1;TA_typ t1i], - [TA_nexp b2;TA_nexp r2;TA_ord o2;TA_typ t2i] -> - (match o1.order,o2.order with - | Oinc,Oinc | Odec,Odec -> () - | Oinc,Ouvar _ | Odec,Ouvar _ -> equate_o o2 o1; - | Ouvar _,Oinc | Ouvar _, Odec -> equate_o o1 o2; - | _,_ -> equate_o o1 o2); - let cs = csp@[Eq(co,r1,r2)]@(if widen then [] else [Eq(co,b1,b2)]) in - let t',cs' = type_consistent co d_env enforce widen t1i t2i in - let tannot = Base(([],t2),Emp_local,cs@cs',pure_e,(get_cummulative_effects (get_eannot e)),nob) in - let e' = E_aux(E_internal_cast ((l,(Base(([],t2),Emp_local,[],pure_e,pure_e,nob))),e),(l,tannot)) in - (t2,cs@cs',pure_e,e') - | _ -> raise (Reporting_basic.err_unreachable l "vector is not properly kinded")) - - (* coercion from a bit vector into a number *) - | "vector","range",_ -> - (match args1,args2 with - | [TA_nexp b1;TA_nexp r1;TA_ord _;TA_typ {t=Tid "bit"}], - [TA_nexp b2;TA_nexp r2;] -> - let cs = [Eq(co,b2,n_zero);LtEq(co,Guarantee,mk_sub (mk_2n(r1)) n_one,r2)] in - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "unsigned",l)),[e]), - (l, - cons_tag_annot_efr t2 (External (Some "unsigned")) - cs (get_cummulative_effects (get_eannot e))))) - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ -> - eq_error l "Cannot convert a vector to a range without an order" - | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ -> - eq_error l "Cannot convert non-bit vector into an range" - | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded")) - - (* similar to vector/range case *) - | "vector","atom",_ -> - (match args1,args2 with - | [TA_nexp b1;TA_nexp r1;TA_ord _;TA_typ {t=Tid "bit"}], - [TA_nexp b2] -> - let cs = [GtEq(co,Guarantee,b2,n_zero);LtEq(co,Guarantee,b2,mk_sub (mk_2n(r1)) n_one)] in - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "unsigned",l)),[e]), - (l, - cons_tag_annot_efr t2 (External (Some "unsigned")) - cs (get_cummulative_effects (get_eannot e))))) - | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ -> - eq_error l "Cannot convert non-bit vector into an range" - | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded")) - - (* coercion from number into bit vector, if there's an explicit type annotation in the source (the "true") *) - (* this can be lossy, if it doesn't fit into that vector, so we want to require the user to specify the vector size. It was desired by some users, but maybe should be turned back into an error and an explicit truncate function be used *) - | "range","vector",true -> - (match args2,args1 with - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Oinc};TA_typ {t=Tid "bit"}], - [TA_nexp b2;TA_nexp r2;] -> - let cs = [] (*[LtEq(co,Guarantee,r2,mk_sub {nexp=N2n(r1,None)} n_one)] - (*This constraint failing should be a warning, but truncation is ok*)*) in - let tannot = (l, Base(([],t2), External (Some "to_vec_inc"), cs, - pure_e, (get_cummulative_effects (get_eannot e)), bounds)) in - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_inc",l)), - [(E_aux(E_internal_exp(tannot), tannot));e]),tannot)) - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Odec};TA_typ {t=Tid "bit"}], - [TA_nexp b2;TA_nexp r2;] -> - let cs = [] (* See above [LtEq(co,Guarantee,r2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in - let tannot = (l, Base(([],t2),External (Some "to_vec_dec"), - cs, pure_e, (get_cummulative_effects (get_eannot e)),bounds)) in - (*let _ = Printf.eprintf "Generating to_vec_dec call: bounds are %s\n" (bounds_to_string bounds) in*) - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_dec",l)), - [(E_aux(E_internal_exp(tannot), tannot)); e]),tannot)) - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ -> - eq_error l "Cannot convert a range to a vector without an order" - | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ -> - eq_error l "Cannot convert a range into a non-bit vector" - | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded")) - - (* similar to number to bit vector case *) - | "atom","vector",true -> - (match args2,args1 with - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Oinc};TA_typ {t=Tid "bit"}], - [TA_nexp b2] -> - let cs = [](*[LtEq(co,Guarantee,b2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in - let tannot = (l, Base(([],t2), External(Some "to_vec_inc"), cs, pure_e, - (get_cummulative_effects (get_eannot e)), bounds)) in - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_inc",l)), - [(E_aux(E_internal_exp(tannot), tannot));e]),tannot)) - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Odec};TA_typ {t=Tid "bit"}], - [TA_nexp b2] -> - let cs = [](*[LtEq(co,Guarantee,b2,mk_sub {nexp=N2n(r1,None)} n_one)]*) in - let tannot = (l, Base(([],t2), External (Some "to_vec_dec"), cs, pure_e, - (get_cummulative_effects (get_eannot e)), bounds)) in - (*let _ = Printf.eprintf "Generating to_vec_dec call: bounds are %s\n" (bounds_to_string bounds) in*) - (t2,cs,pure_e,E_aux(E_app((Id_aux(Id "to_vec_dec",l)), - [(E_aux(E_internal_exp(tannot), tannot)); e]),tannot)) - | [TA_nexp b1;TA_nexp r1;TA_ord {order = Ovar o};TA_typ {t=Tid "bit"}],_ -> - eq_error l "Cannot convert a range to a vector without an order" - | [TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ t],_ -> - eq_error l "Cannot convert a range into a non-bit vector" - | _,_ -> raise (Reporting_basic.err_unreachable l "vector or range is not properly kinded")) - - (* implicit dereference of a register, from register<t> to t, and then perhaps also from t to the expected type *) - | "register",_,_ -> - (match args1 with - | [TA_typ t] -> - (*TODO Should this be an internal cast? - Probably, make sure it doesn't interfere with the other internal cast and get removed *) - (*let _ = Printf.eprintf "Adding cast to remove register read: t %s ; t2 %s\n" - (t_to_string t) (t_to_string t2) in*) - let efc = (BE_aux (BE_rreg, l)) in - let ef = add_effect efc pure_e in - let new_e = E_aux(E_cast(t_to_typ unit_t,e), - (l,Base(([],t),External None,[], - ef,add_effect efc (get_cummulative_effects (get_eannot e)),nob))) in - let (t',cs,ef',e) = type_coerce co d_env Guarantee is_explicit widen bounds t new_e t2 in - (t',cs,union_effects ef ef',e) - | _ -> raise (Reporting_basic.err_unreachable l "register is not properly kinded")) - - (* otherwise in Tapp case, fall back on type_consistent *) - | _,_,_ -> - let t',cs' = type_consistent co d_env enforce widen t1 t2 in (t',cs',pure_e,e)) - - (* bit vector of length 1 to bit *) - | Tapp("vector",[TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ {t=Tid "bit"}]),Tid("bit") -> - let cs = [Eq(co,r1,n_one)] in - (t2,cs,pure_e,E_aux((E_app ((Id_aux (Id "most_significant", l)), [e])), - (l, cons_tag_annot_efr t2 (External (Some "most_significant")) - cs (get_cummulative_effects (get_eannot e))))) - - (* bit to a bitvector of length 1 *) - | Tid("bit"),Tapp("vector",[TA_nexp b1;TA_nexp r1;TA_ord o;TA_typ {t=Tid "bit"}]) -> - let cs = [Eq(co,r1,n_one)] in - (t2,cs,pure_e,E_aux(E_vector [e], (l, constrained_annot_efr t2 cs (get_cummulative_effects (get_eannot e))))) - - (* bit to a number range (including 0..1) *) - | Tid("bit"),Tapp("range",[TA_nexp b1;TA_nexp r1]) -> - let t',cs'= type_consistent co d_env enforce false {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} t2 in - (t2,cs',pure_e, - E_aux(E_case (e,[Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_zero,l)),(l,simple_annot t1)), - E_aux(E_lit(L_aux(L_num 0,l)),(l,simple_annot t2))), - (l,simple_annot t2)); - Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_one,l)),(l,simple_annot t1)), - E_aux(E_lit(L_aux(L_num 1,l)),(l,simple_annot t2))), - (l,simple_annot t2));]), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - - - (* similar to above, bit to a singleton number range *) - | Tid("bit"),Tapp("atom",[TA_nexp b1]) -> - let t',cs'= type_consistent co d_env enforce false t2 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in - (t2,cs',pure_e, - E_aux(E_case (e,[Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_zero,l)),(l,simple_annot t1)), - E_aux(E_lit(L_aux(L_num 0,l)),(l,simple_annot t2))), - (l,simple_annot t2)); - Pat_aux(Pat_exp(P_aux(P_lit(L_aux(L_one,l)),(l,simple_annot t1)), - E_aux(E_lit(L_aux(L_num 1,l)),(l,simple_annot t2))), - (l,simple_annot t2));]), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - - - (* number range to a bit *) - | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tid("bit") -> - let t',cs'= type_consistent co d_env enforce false t1 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in - let efr = get_cummulative_effects (get_eannot e) - in (t2,cs',pure_e,E_aux(E_if(E_aux(E_app(Id_aux(Id "is_one",l),[e]), - (l, tag_annot_efr bit_t (External (Some "is_one")) efr)), - E_aux(E_lit(L_aux(L_one,l)),(l,simple_annot bit_t)), - E_aux(E_lit(L_aux(L_zero,l)),(l,simple_annot bit_t))), - (l,simple_annot_efr bit_t efr))) - - (* similar to above *) - | Tapp("atom",[TA_nexp b1]),Tid("bit") -> - let t',cs'= type_consistent co d_env enforce false t1 {t=Tapp("range",[TA_nexp n_zero;TA_nexp n_one])} in - let efr = get_cummulative_effects (get_eannot e) - in (t2,cs',pure_e,E_aux(E_if(E_aux(E_app(Id_aux(Id "is_one",l),[e]),(l, tag_annot_efr bit_t (External None) efr)), - E_aux(E_lit(L_aux(L_one,l)),(l,simple_annot bit_t)), - E_aux(E_lit(L_aux(L_zero,l)),(l,simple_annot bit_t))), - (l,simple_annot_efr bit_t efr))) - - (* number range to an enumeration type *) - | Tapp("range",[TA_nexp b1;TA_nexp r1;]),Tid(i) -> - (match Envmap.apply d_env.enum_env i with - | Some(enums) -> - let num_enums = List.length enums in - (t2,[GtEq(co,Require,b1,n_zero);LtEq(co,Require,r1,mk_c(big_int_of_int num_enums))],pure_e, - E_aux(E_case(e, - List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)), (l,simple_annot t1)), - E_aux(E_id(Id_aux(Id a,l)), - (l, tag_annot t2 (Enum num_enums)))), - (l,simple_annot t2))) enums), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2))) - - (* similar to above *) - | Tapp("atom",[TA_nexp b1]),Tid(i) -> - (match Envmap.apply d_env.enum_env i with - | Some(enums) -> - let num_enums = List.length enums in - (t2,[GtEq(co,Require,b1,n_zero); - LtEq(co,Require,b1,mk_c(big_int_of_int num_enums))],pure_e, - E_aux(E_case(e, - List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)),(l, simple_annot t1)), - E_aux(E_id(Id_aux(Id a,l)), - (l, tag_annot t2 (Enum num_enums)))), - (l,simple_annot t2))) enums), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2))) - - (* bit vector to an enumeration type *) - | Tapp("vector", [TA_nexp _; TA_nexp size; _; TA_typ {t= Tid "bit"}]), Tid(i) -> - (match Envmap.apply d_env.enum_env i with - | Some(enums) -> - let num_enums = List.length enums in - (t2,[LtEq(co,Require,mk_sub (mk_2n size) n_one, mk_c_int num_enums)], pure_e, - E_aux(E_case (E_aux(E_app((Id_aux(Id "unsigned",l)),[e]), - (l, - tag_annot_efr (mk_range n_zero (mk_sub (mk_2n size) n_one)) (External (Some "unsigned")) - (get_cummulative_effects (get_eannot e)))), - List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_lit(L_aux((L_num i),l)), (l,simple_annot t1)), - E_aux(E_id(Id_aux(Id a,l)), - (l, tag_annot t2 (Enum num_enums)))), - (l,simple_annot t2))) enums), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - | None -> eq_error l ("Type mismatch: found a " ^ (t_to_string t1) ^ " but expected " ^ (t_to_string t2))) - - (* enumeration type to number range *) - | Tid(i),Tapp("range",[TA_nexp b1;TA_nexp r1;]) -> - (match Envmap.apply d_env.enum_env i with - | Some(enums) -> - (t2,[Eq(co,b1,n_zero);GtEq(co,Guarantee,r1,mk_c(big_int_of_int (List.length enums)))],pure_e, - E_aux(E_case(e, - List.mapi (fun i a -> Pat_aux(Pat_exp(P_aux(P_id(Id_aux(Id a,l)), (l,simple_annot t1)), - E_aux(E_lit(L_aux((L_num i),l)),(l,simple_annot t2))), - (l,simple_annot t2))) enums), - (l,simple_annot_efr t2 (get_cummulative_effects (get_eannot e))))) - | None -> eq_error l ("Type mismatch: " ^ (t_to_string t1) ^ " , " ^ (t_to_string t2))) - - - (* probably there's a missing enumeration type to singleton number range *) - - (* fall through to type_consistent *) - | _,_ -> let t',cs = type_consistent co d_env enforce widen t1 t2 in (t',cs,pure_e,e) - -and type_coerce co d_env enforce is_explicit widen bounds t1 e t2 = - type_coerce_internal co d_env enforce is_explicit widen bounds t1 [] e t2 [];; - -let rec select_overload_variant d_env params_check get_all variants actual_type = - match variants with - | [] -> [] - | NoTyp::variants | Overload _::variants -> - select_overload_variant d_env params_check get_all variants actual_type - | Base((parms,t_orig),tag,cs,ef,_,bindings)::variants -> - (*let _ = Printf.eprintf "About to check a variant %s\n" (t_to_string t_orig) in*) - let t,cs,ef,_ = if parms=[] then t_orig,cs,ef,Envmap.empty else subst parms false false t_orig cs ef in - (*let _ = Printf.eprintf "And after substitution %s\n" (t_to_string t) in*) - let t,cs' = get_abbrev d_env t in - let recur _ = select_overload_variant d_env params_check get_all variants actual_type in - (match t.t with - | Tfn(a,r,_,e) -> - let is_matching = - if params_check then conforms_to_t d_env true false a actual_type - else match actual_type.t with - | Toptions(at1,Some at2) -> - (conforms_to_t d_env false true at1 r || conforms_to_t d_env false true at2 r) - | Toptions(at1,None) -> conforms_to_t d_env false true at1 r - | _ -> conforms_to_t d_env true true actual_type r in - (*let _ = Printf.eprintf "Checked a variant, matching? %b\n" is_matching in*) - if is_matching - then (Base(([],t),tag,cs@cs',ef,pure_e,bindings))::(if get_all then (recur ()) else []) - else recur () - | _ -> recur () ) - -let rec split_conditional_constraints = function - | [] -> [],[],[] - | Predicate(co,cp,cn)::cs -> - let (csa,csp,csn) = split_conditional_constraints cs in - (csa,cp::csp, cn::csn) - | c::cs -> - let (csa,csp,csn) = split_conditional_constraints cs in - (c::csa,csp, csn) - -let rec in_constraint_env = function - | [] -> [] - | InS(co,nexp,vals)::cs -> - (nexp,(List.map (fun c -> mk_c(big_int_of_int c)) vals))::(in_constraint_env cs) - | In(co,i,vals)::cs -> - (mk_nv i,(List.map (fun c -> mk_c(big_int_of_int c)) vals))::(in_constraint_env cs) - | _::cs -> in_constraint_env cs - -let rec contains_var nu n = - match n.nexp with - | Nvar _ | Nuvar _ -> nexp_eq_check nu n - | Nconst _ | Npos_inf | Nneg_inf | Ninexact -> false - | Nadd(n1,n2) | Nsub(n1,n2) | Nmult(n1,n2) -> contains_var nu n1 || contains_var nu n2 - | Nneg n | N2n(n,_) | Npow(n,_) | Nid(_,n) -> contains_var nu n - -let rec contains_in_vars in_env n = - match in_env with - | [] -> None - | (ne,vals)::in_env -> - (match contains_in_vars in_env n with - | None -> if contains_var ne n then Some [ne,vals] else None - | Some(e_env) -> if contains_var ne n then Some((ne,vals)::e_env) else Some(e_env)) - -let rec get_nuvars n = - match n.nexp with - | Nconst _ | Nvar _ | Nid _ | Npos_inf | Nneg_inf | Ninexact-> [] - | Nuvar _ -> [n] - | Nmult(n1,n2) | Nadd(n1,n2) | Nsub(n1,n2) -> (get_nuvars n1)@(get_nuvars n2) - | Nneg n | N2n(n,_) | Npow(n,_) -> get_nuvars n - -let rec get_all_nuvars_cs cs = match cs with - | [] -> Var_set.empty - | (Eq(_,n1,n2) | GtEq(_,_,n1,n2) | LtEq(_,_,n1,n2) | Gt(_,_,n1,n2) | Lt(_,_,n1,n2))::cs -> - let s = get_all_nuvars_cs cs in - let n1s = get_nuvars n1 in - let n2s = get_nuvars n2 in - List.fold_right (fun n s -> Var_set.add n s) (n1s@n2s) s - | Predicate(_,cp,cn)::cs -> - Var_set.union (get_all_nuvars_cs [cp;cn]) (get_all_nuvars_cs cs) - | CondCons(_,_,_,pats,exps)::cs -> - let s = get_all_nuvars_cs cs in - let ps = get_all_nuvars_cs pats in - let es = get_all_nuvars_cs exps in - Var_set.union s (Var_set.union ps es) - | BranchCons(_,_,c)::cs -> - Var_set.union (get_all_nuvars_cs c) (get_all_nuvars_cs cs) - | _::cs -> get_all_nuvars_cs cs - -let rec subst_nuvars nus n = - let is_imp_param = n.imp_param in - let new_n = - match n.nexp with - | Nconst _ | Nvar _ | Nid _ | Npos_inf | Nneg_inf | Ninexact -> n - | Nuvar _ -> - (match Nexpmap.apply nus n with - | None -> n - | Some nc -> nc) - | Nmult(n1,n2) -> mk_mult (subst_nuvars nus n1) (subst_nuvars nus n2) - | Nadd(n1,n2) -> mk_add (subst_nuvars nus n1) (subst_nuvars nus n2) - | Nsub(n1,n2) -> mk_sub (subst_nuvars nus n1) (subst_nuvars nus n2) - | Nneg n -> mk_neg (subst_nuvars nus n) - | N2n(n,None) -> mk_2n (subst_nuvars nus n) - | N2n(n,Some(i)) -> mk_2nc (subst_nuvars nus n) i - | Npow(n,i) -> mk_pow (subst_nuvars nus n) i in - (if is_imp_param then set_imp_param new_n); - new_n - -let rec subst_nuvars_cs nus cs = - match cs with - | [] -> [] - | Eq(l,n1,n2)::cs -> Eq(l,subst_nuvars nus n1,subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | NtEq(l,n1,n2)::cs -> NtEq(l, subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | GtEq(l,enforce,n1,n2)::cs -> GtEq(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | Gt(l,enforce,n1,n2)::cs -> Gt(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | LtEq(l,enforce,n1,n2)::cs -> LtEq(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | Lt(l,enforce,n1,n2)::cs -> Lt(l,enforce,subst_nuvars nus n1, subst_nuvars nus n2)::(subst_nuvars_cs nus cs) - | In(l,s,ns)::cs -> In(l,s,ns)::(subst_nuvars_cs nus cs) - | InS(l,n,ns)::cs -> InS(l,subst_nuvars nus n,ns)::(subst_nuvars_cs nus cs) - | Predicate(l, cp,cn)::cs -> - Predicate(l, List.hd(subst_nuvars_cs nus [cp]), List.hd(subst_nuvars_cs nus [cn]))::(subst_nuvars_cs nus cs) - | CondCons(l,kind,my_substs,cs_p,cs_e)::cs -> - CondCons(l,kind,my_substs,subst_nuvars_cs nus cs_p,subst_nuvars_cs nus cs_e)::(subst_nuvars_cs nus cs) - | BranchCons(l,possible_invars,bs)::cs -> - BranchCons(l,possible_invars,subst_nuvars_cs nus bs)::(subst_nuvars_cs nus cs) - -let rec constraint_size = function - | [] -> 0 - | c::cs -> - (match c with - | CondCons(_,_,_,ps,es) -> constraint_size ps + constraint_size es - | BranchCons(_,_,bs) -> constraint_size bs - | _ -> 1) + constraint_size cs - -let freshen_constraints cs = - let nuvars = - Var_set.fold (fun n map -> - let ne = new_n() in - (*let _ = Printf.eprintf "mapping %s to %s\n%!" (n_to_string n) (n_to_string ne) in*) - Nexpmap.insert map (n,ne)) (get_all_nuvars_cs cs) Nexpmap.empty in - (subst_nuvars_cs nuvars cs,nuvars) - -let rec prepare_constraints = function - | [] -> [] - | CondCons(l,(Positive|Negative|Switch as kind),None,cs_p,cs_e)::cs -> - let (new_pred_cs,my_substs) = freshen_constraints cs_p in - let new_expr_cs = subst_nuvars_cs my_substs cs_e in - CondCons(l,kind,Some(my_substs),new_pred_cs,(prepare_constraints new_expr_cs))::(prepare_constraints cs) - | CondCons(l,Solo,None,cs_p,cs_e)::cs -> - CondCons(l,Solo,None,cs_p,(prepare_constraints cs_e))::(prepare_constraints cs) - | BranchCons(l,_,bs)::cs -> BranchCons(l,None, prepare_constraints bs)::(prepare_constraints cs) - | c::cs -> c::(prepare_constraints cs) - -let nexpmap_to_string nmap = - Nexpmap.fold (fun acc k v -> - match v with - | One n -> "(" ^ n_to_string k ^ " |-> " ^ n_to_string n ^ ") " ^ acc - | Two(n1,n2) -> "(" ^ n_to_string k ^ " |-> (" ^ n_to_string n1 ^ ", or " ^ n_to_string n2 ^ ")) " ^ acc - | Many ns -> "(" ^ n_to_string k ^ " |-> (" ^ string_of_list ", " n_to_string ns ^ ") : " ^ (string_of_list ", " (fun n -> if is_all_nuvar n then "true" else "false") ns) ^ ") " ^ acc) "" nmap - -let rec make_merged_constraints acc = function - | [] -> acc - | c::cs -> - (* let _ = Printf.eprintf "merging constraints acc thus far is %s\n%!" (nexpmap_to_string acc) in*) - make_merged_constraints - (Nexpmap.fold - (fun acc k v -> -(* let _ = Printf.eprintf "folding over c: we have %s |-> %s for acc of %s\n%!" - (n_to_string k) (n_to_string v) (nexpmap_to_string acc) in*) - match Nexpmap.apply acc k with - | None -> Nexpmap.insert acc (k, One v) - | Some(One v') -> Nexpmap.insert (Nexpmap.remove acc k) (k, Two(v,v')) - | Some(Two(v',v'')) -> Nexpmap.insert (Nexpmap.remove acc k) (k,Many [v;v';v'']) - | Some(Many vs) -> Nexpmap.insert (Nexpmap.remove acc k) (k,Many (v::vs))) acc c) - cs - -let merge_branch_constraints merge_nuvars constraint_sets = - (*let _ = Printf.eprintf "merge_branch_constraints called\n%!" in*) - (*Separate variables into only occurs in one set, or occurs in multiple sets*) - (*assumes k and n outermost and all nuvar*) - let conditionally_set k n = - not(merge_nuvars) || ((occurs_in_nexp k n) || (occurs_in_nexp n k) || equate_n k n || equate_n n k) in - (*This function assumes n outermost and k all nuvar; - inserts a new nuvar at bottom, and an eq to k for non-nuvar*) - let conditionally_lift_to_nuvars_on_merge k n = - if not(merge_nuvars) || (is_all_nuvar n && conditionally_set k n) - then [],None - else - let new_nuvar = new_n () in - let new_temp = new_n () in - match first_non_nu n with - | Some n' -> - new_temp.nexp <- n'.nexp; (*Save equation*) - n'.nexp <- new_nuvar.nexp; (*Put a nuvar in place*) - [Eq(Patt(Parse_ast.Unknown),k,new_temp)], Some(Nexpmap.from_list [k,new_temp]) - | None -> [],None - in - let merged_constraints = make_merged_constraints Nexpmap.empty constraint_sets in - let merge_walker (sc,new_cs,new_map) k v = match v with - | One n -> - (*let _ = Printf.eprintf "Variables in one path: merge_nuvars %b, key %s, one %s\n%!" - merge_nuvars (n_to_string k) (n_to_string n) in*) - let k,n = get_outer_most k, get_outer_most n in - if (is_all_nuvar k || is_all_nuvar n) && conditionally_set k n - then (sc,new_cs,new_map) - else (sc, (Eq(Patt(Parse_ast.Unknown),k,n))::new_cs,new_map) - | Two(n1,n2) -> - (*let _ = Printf.eprintf "Variables in two paths: merge_nuvars %b, key %s, n1 %s, n2 %s\n%!" - merge_nuvars (n_to_string k) (n_to_string n1) (n_to_string n2) in*) - let k,n1,n2 = get_outer_most k, get_outer_most n1, get_outer_most n2 in - let all_nk, all_nn1, all_nn2 = is_all_nuvar k, is_all_nuvar n1, is_all_nuvar n2 in - if all_nk && all_nn1 && all_nn2 - then - let set1,set2 = conditionally_set k n1, conditionally_set k n2 in - if set1 && set2 then sc,new_cs,new_map - else (Nexpmap.insert sc (k,v),new_cs,new_map) - else (if all_nk - then - let ncs1,nm1 = conditionally_lift_to_nuvars_on_merge k n1 in - let ncs2,nm2 = conditionally_lift_to_nuvars_on_merge k n2 in - let set1,set2 = conditionally_set k n1, conditionally_set k n2 in - if set1 && set2 - then sc,ncs1@ncs2@new_cs,merge_option_maps new_map (merge_option_maps nm1 nm2) - else (Nexpmap.insert sc (k,v),new_cs,merge_option_maps new_map (merge_option_maps nm1 nm2)) - else (Nexpmap.insert sc (k,v),new_cs,new_map)) - | Many ns -> - (*(if merge_nuvars then - let _ = Printf.eprintf "Variables in many paths: merge_nuvars %b, key %s, [" - merge_nuvars (n_to_string k) in - let _ = List.iter (fun n -> Printf.eprintf "%s ;" (n_to_string n)) ns in - let _ = Printf.eprintf "]\n%!" in - let _ = Printf.eprintf "Is all nuvar? %b\n%!" - (List.for_all is_all_nuvar (List.map get_outer_most ns)) in ());*) - let k, ns = get_outer_most k, List.map get_outer_most ns in - let is_all_nuvars = List.for_all is_all_nuvar ns in - if not(merge_nuvars) - then Nexpmap.insert sc (k,v),new_cs,new_map - else if is_all_nuvars - then if List.for_all (fun i -> i) (List.map (conditionally_set k) ns) - then (sc,new_cs,new_map) - else (Nexpmap.insert sc (k,v),new_cs,new_map) - else - let rec all_eq = function - | [] | [_] -> true - | n1::n2::ns -> - (nexp_eq n1 n2) && all_eq (n2::ns) - in - if (all_eq ns) && not(ns=[]) - then if List.for_all (fun i -> i) (List.map (conditionally_set k) ns) - then (sc,new_cs,new_map) - else (Nexpmap.insert sc (k,v),new_cs,new_map) - else - let sets = List.map (conditionally_lift_to_nuvars_on_merge k) ns in - let css = (List.flatten (List.map fst sets))@ new_cs in - let map = List.fold_right merge_option_maps (List.map snd sets) new_map in - (Nexpmap.insert sc (k,v),css, map) in - let shared_path_distinct_constraints = Nexpmap.fold merge_walker (Nexpmap.empty,[],None) merged_constraints in - (*let _ = if merge_nuvars then - Printf.eprintf "merge branch constraints: shared var mappings after merge %s\n%!" - (nexpmap_to_string merged_constraints) in*) - if merge_nuvars then Nexpmap.fold merge_walker (Nexpmap.empty,[],None) merged_constraints - else - shared_path_distinct_constraints - -let rec extract_path_substs = function - | [] -> [],[] - | CondCons(l,k,Some(substs),ps,es)::cs -> - let set v n = match n.nexp with - | Nuvar _ -> ignore(equate_n n v) - | _ -> if nexp_eq n v then () else assert false (*Get a location to here*) - in - let updated_substs = - Nexpmap.fold (fun substs key newvar -> - (*let _ = Printf.eprintf "building substs sets: %s |-> %s\n" (n_to_string key) (n_to_string newvar) in*) - match key.nexp with - | Nuvar _ -> Nexpmap.insert substs (key,newvar) - | _ -> begin set key newvar; substs end) Nexpmap.empty substs in - let (substs, cs_rest) = extract_path_substs cs in - (updated_substs::substs, CondCons(l,k,Some(updated_substs),ps,es)::cs_rest) - | c::cs -> - let (substs,cs_rest) = extract_path_substs cs in - (substs,c::cs_rest) - -let rec merge_paths merge_nuvars = function - | [] -> [],None - | (BranchCons(co,_,branches) as b)::cs -> - (*let _ = Printf.eprintf "merge_paths BranchCons case branch is %s\n\n" (constraints_to_string [b]) in*) - let branches_merged,new_map = merge_paths merge_nuvars branches in - let path_substs,branches_up = extract_path_substs branches_merged in - let (shared_vars,new_cs,nm) = merge_branch_constraints merge_nuvars path_substs in - let (rest_cs,rest_map) = merge_paths merge_nuvars cs in - let out_map = merge_option_maps (merge_option_maps new_map nm) rest_map in - (BranchCons(co,Some(shared_vars),branches_up)::(new_cs@rest_cs), out_map) - | CondCons(co,k,substs,ps,es)::cs -> - (*let _ = Printf.eprintf "merge_paths CondCons case: ps %s \n es %s\n\n" (constraints_to_string ps) (constraints_to_string es) in*) - let (new_es,nm) = merge_paths merge_nuvars es in - let (rest_cs,rest_map) = merge_paths merge_nuvars cs in - let map = merge_option_maps nm rest_map in - (CondCons(co,k,substs,ps,new_es)::rest_cs, map) - | con::cs -> - let (rest_cs, rest_map) = merge_paths merge_nuvars cs in - (con::rest_cs, rest_map) - -let rec equate_nuvars in_env cs = - (*let _ = Printf.eprintf "equate_nuvars\n" in*) - let equate = equate_nuvars in_env in - match cs with - | [] -> [] - | (Eq(co,n1,n2) as c)::cs -> - (match (n1.nexp,n2.nexp) with - | Nuvar u1, Nuvar u2 -> - (*let _ = Printf.eprintf "setting two nuvars, %s and %s in equate\n" (n_to_string n1) (n_to_string n2) in*) - let occurs = (occurs_in_nexp n1 n2) || (occurs_in_nexp n2 n1) in - (*let _ = Printf.eprintf "did they occur? %b\n" occurs in*) - if not(occurs) - then if (equate_n n1 n2) then equate cs else c::equate cs - else c::equate cs - | _ -> c::equate cs) - | CondCons(co,kind,substs,pats,exps):: cs -> - let pats' = equate pats in - let exps' = equate exps in - (match pats',exps' with - | [],[] -> equate cs - | _ -> CondCons(co,kind,substs,pats',exps')::(equate cs)) - | BranchCons(co,sv,branches)::cs -> - let b' = equate branches in - if [] = b' - then equate cs - else BranchCons(co,sv,b')::(equate cs) - | c::cs -> c::(equate cs) - - -let rec flatten_constraints = function - | [] -> [] - | c::cs -> - (match c with - | CondCons(_,_,_,ps,es) -> flatten_constraints ps @ flatten_constraints es - | BranchCons(_,_,bs) -> flatten_constraints bs - | _ -> [c]) @ flatten_constraints cs - -let rec simple_constraint_check in_env cs = - let check = simple_constraint_check in_env in - (*let _ = Printf.eprintf "simple_constraint_check of %i constraints\n%!" (constraint_size cs) in*) - match cs with - | [] -> [] - | Eq(co,n1,n2)::cs -> - let eq_to_zero ok_to_set n1 n2 = - (*let _ = Printf.eprintf "eq_to_zero called with n1 %s and n2%s\n" (n_to_string n1) (n_to_string n2) in*) - let new_n = normalize_nexp (mk_sub n1 n2) in - (match new_n.nexp with - | Nconst i -> - if eq_big_int i zero - then None - else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires " - ^ n_to_string new_n ^ " to equal 0, not " ^ string_of_big_int i) - | Nuvar u1 -> - if ok_to_set - then if (equate_n new_n n_zero) then None else Some(Eq(co,new_n,n_zero)) - else Some(Eq(co,new_n,n_zero)) - | Nadd(new_n1,new_n2) -> - (match new_n1.nexp, new_n2.nexp with - | _ -> Some(Eq(co,n1,n2))) - | _ -> Some(Eq(co,n1,n2))) in - let check_eq ok_to_set n1 n2 = - (*let _ = Printf.eprintf "eq check, about to normalize_nexp of %s, %s arising from %s \n" - (n_to_string n1) (n_to_string n2) (co_to_string co) in*) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *) - (match n1'.nexp,n2'.nexp,n1.nexp,n2.nexp with - | Ninexact,nok,_,_ | nok,Ninexact,_,_ -> - eq_error (get_c_loc co) - ("Type constraint arising from here requires " ^ n_to_string {nexp = nok; imp_param = false} - ^ " to be equal to +inf + -inf") - | Npos_inf,Npos_inf,_,_ | Nneg_inf, Nneg_inf,_,_ -> None - | Nconst i1, Nconst i2,_,_ | Nconst i1,N2n(_,Some(i2)),_,_ | N2n(_,Some(i1)),Nconst(i2),_,_ -> - if eq_big_int i1 i2 then None - else eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ - " to equal " ^ n_to_string n2 ) - | Nuvar u1, Nuvar u2, _, _ -> - (*let _ = Printf.eprintf "setting two nuvars, %s and %s, it is ok_to_set %b\n" - (n_to_string n1) (n_to_string n2) ok_to_set in*) - if nexp_eq_check n1 n2 - then None - else - let occurs = (occurs_in_nexp n1' n2') || (occurs_in_nexp n2' n1') in - if ok_to_set && not(occurs) - then if (equate_n n1' n2') then None else Some(Eq(co,n1',n2')) - else if occurs then eq_to_zero ok_to_set n1' n2' - else Some(Eq(co,n1',n2')) - | _, Nuvar u, _, Nuvar _ -> - (*let _ = Printf.eprintf "setting right nuvar\n" in*) - let occurs = occurs_in_nexp n1' n2 in - let leave = leave_nu_as_var (get_outer_most n2') in - (*let _ = Printf.eprintf "occurs? %b, leave? %b n1' %s in n2' %s\n" - occurs leave (n_to_string n1') (n_to_string n2') in*) - if (*not(u.nin) &&*) ok_to_set && not(occurs) && not(leave) - then if (equate_n n2 n1) then None else (Some (Eq(co,n1',n2'))) - else if occurs - then eq_to_zero ok_to_set n1' n2' - else Some (Eq(co,n1',n2')) - | Nuvar u, _,Nuvar _, _ -> - (*let _ = Printf.eprintf "setting left nuvar\n" in*) - let occurs = occurs_in_nexp n2' n1 in - let leave = leave_nu_as_var (get_outer_most n1') in - (*let _ = Printf.eprintf "occurs? %b, leave? %b n2' %s in n1' %s\n" - occurs leave (n_to_string n2') (n_to_string n1') in*) - if (*not(u.nin) &&*) ok_to_set && not(occurs) && not(leave) - then if equate_n n1 n2 then None else (Some (Eq(co,n1,n2))) - else if occurs - then eq_to_zero ok_to_set n1' n2' - else Some (Eq(co,n1',n2')) - | _,_,_,_ -> - if nexp_eq_check n1' n2' - then None - else eq_to_zero ok_to_set n1' n2') - in - (match check_eq true n1 n2 with - | None -> (check cs) - | Some(c) -> c::(check cs)) - | NtEq(co,n1,n2)::cs -> - let nt_eq_to_zero n1 n2 = - (*let _ = Printf.eprintf "nt_eq_to_zero called with n1 %s and n2%s\n" (n_to_string n1) (n_to_string n2) in*) - let new_n = normalize_nexp (mk_sub n1 n2) in - (match new_n.nexp with - | Nconst i -> - if eq_big_int i zero - then eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires " - ^ n_to_string new_n ^ " to not equal 0") - else None - | _ -> Some(NtEq(co,n1,n2))) in - let check_not_eq n1 n2 = - (*let _ = Printf.eprintf "not eq check, about to normalize_nexp of %s, %s arising from %s \n" - (n_to_string n1) (n_to_string n2) (co_to_string co) in*) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *) - (match n1'.nexp,n2'.nexp with - | Ninexact,nok | nok,Ninexact -> - eq_error (get_c_loc co) - ("Type constraint arising from here requires " ^ n_to_string {nexp = nok; imp_param = false} ^ - " to be compared to +inf + -inf") - | Npos_inf,Npos_inf | Nneg_inf, Nneg_inf -> - eq_error (get_c_loc co) - ("Type constraint arising from here requires " ^ n_to_string n1' ^ " to be not = to " ^ n_to_string n2') - | Nconst i1, Nconst i2 | Nconst i1,N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst(i2) -> - if eq_big_int i1 i2 - then eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ - " to not equal " ^ n_to_string n2 ) - else None - | _,_ -> - if nexp_eq_check n1' n2' - then eq_error (get_c_loc co) - ("Type constraing mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to not equal " ^ - n_to_string n2) - else nt_eq_to_zero n1' n2') - in - (match check_not_eq n1 n2 with - | None -> (check cs) - | Some(c) -> c::(check cs)) - | GtEq(co,enforce,n1,n2)::cs -> - (*let _ = Printf.eprintf ">= check, about to normalize_nexp of %s, %s\n" - (n_to_string n1) (n_to_string n2) in *) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in*) - (match n1'.nexp,n2'.nexp with - | Nconst i1, Nconst i2 | Nconst i1,N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 -> - if ge_big_int i1 i2 - then check cs - else eq_error (get_c_loc co) - ("Type constraint mismatch: constraint of " ^ n_to_string n1 ^ " >= " ^ n_to_string n2 ^ - " arising from here requires " - ^ string_of_big_int i1 ^ " to be greater than or equal to " ^ string_of_big_int i2) - | Npos_inf, _ | _, Nneg_inf -> check cs - | Nconst _ ,Npos_inf -> - eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires " - ^ (n_to_string n1') ^ " to be greater than or equal to infinity") -(* | Nneg_inf,Nuvar _ -> - if equate_n n2' n1' then check cs else (GtEq(co,enforce,n1',n2')::check cs) - | Nneg_inf, _ -> - eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires negative infinity to be >= to " - ^ (n_to_string n2')) *) - | Nuvar _, _ | _, Nuvar _ -> GtEq(co,enforce, n1, n2)::(check cs) - | _,_ -> - (match nexp_ge n1' n2' with - | Yes -> check cs - | No -> eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to be >= to " ^ - (n_to_string n2)) - | Maybe -> - let new_n = normalize_nexp (mk_sub n1' n2') in - (match new_n.nexp with - | Nconst i -> - if ge_big_int i zero - then (check cs) - else eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " - ^ n_to_string new_n ^ " to be greater than or equal to 0, not " ^ string_of_big_int i) - | _ -> GtEq(co,enforce,n1',n2')::(check cs)))) - | Gt(co,enforce,n1,n2)::cs -> - (*let _ = Printf.eprintf "> check, about to normalize_nexp of %s, %s\n" - (n_to_string n1) (n_to_string n2) in *) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in*) - (match nexp_gt n1' n2' with - | Yes -> check cs - | No -> eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ " to be > to " ^ - (n_to_string n2)) - | Maybe -> - let new_n = normalize_nexp (mk_sub n1' n2') in - (match new_n.nexp with - | Nconst i -> - if gt_big_int i zero - then (check cs) - else eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " - ^ n_to_string new_n ^ " to be greater than or equal to 0, not " ^ string_of_big_int i) - | _ -> Gt(co,enforce,n1',n2')::(check cs))) - | LtEq(co,enforce,n1,n2)::cs -> - (*let _ = Printf.eprintf "<= check, about to normalize_nexp of %s, %s\n" - (n_to_string n1) (n_to_string n2) in *) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *) - (match n1'.nexp,n2'.nexp with - | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 -> - if le_big_int i1 i2 - then check cs - else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires " - ^ string_of_big_int i1 ^ " to be less than or equal to " ^ string_of_big_int i2) - | _, Npos_inf | Nneg_inf, _ -> check cs - | Nuvar _, _ | _, Nuvar _ -> LtEq(co,enforce, n1, n2)::(check cs) - | _,_ -> - (match nexp_ge n2' n1' with - | Yes -> check cs - | No -> eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ - " to be less than or equal to " ^ (n_to_string n2)) - | Maybe -> LtEq(co,enforce,n1',n2')::(check cs))) - | Lt(co,enforce,n1,n2)::cs -> - (*let _ = Printf.eprintf "< check, about to normalize_nexp of %s, %s\n" - (n_to_string n1) (n_to_string n2) in *) - let n1',n2' = normalize_nexp n1,normalize_nexp n2 in - (*let _ = Printf.eprintf "finished evaled to %s, %s\n" (n_to_string n1') (n_to_string n2') in *) - (match n1'.nexp,n2'.nexp with - | Nconst i1, Nconst i2 | Nconst i1, N2n(_,Some(i2)) | N2n(_,Some(i1)),Nconst i2 -> - if lt_big_int i1 i2 - then check cs - else eq_error (get_c_loc co) ("Type constraint mismatch: constraint arising from here requires " - ^ string_of_big_int i1 ^ " to be less than " ^ string_of_big_int i2) - | _, Npos_inf | Nneg_inf, _ -> check cs - | _,_ -> - (match nexp_gt n2' n1' with - | Yes -> check cs - | No -> eq_error (get_c_loc co) - ("Type constraint mismatch: constraint arising from here requires " ^ n_to_string n1 ^ - " to be less than " ^ (n_to_string n2)) - | Maybe -> Lt(co,enforce,n1',n2')::(check cs))) - | CondCons(co,kind,substs,pats,exps):: cs -> - (*let _ = Printf.eprintf "Condcons check length pats %i, length exps %i\n" - (constraint_size pats) (constraint_size exps) in*) - let pats' = check pats in - let exps' = check exps in - (*let _ = Printf.eprintf "Condcons after check length pats' %i, length exps' %i\n" - (constraint_size pats') (constraint_size exps') in*) - (match pats',exps',substs with - | [],[],None -> check cs - | _ -> CondCons(co,kind,substs,pats',exps')::(check cs)) - | BranchCons(co,sv,branches)::cs -> - (*let _ = Printf.eprintf "BranchCons pre_check with %i branches and %i for after\n" (constraint_size branches) (constraint_size cs) in*) - let b = check branches in - (*let _ = Printf.eprintf "Branchcons check length branches before %i and after %i with %i remaining after\n" - (constraint_size branches) (constraint_size b) (constraint_size cs) in*) - if [] = b - then check cs - else BranchCons(co,sv,b)::(check cs) - | Predicate _::cs -> check cs - | x::cs -> - (*let _ = Printf.eprintf "In default case with %s\n%!" (constraints_to_string [x]) in*) - x::(check cs) - -let rec resolve_in_constraints cs = cs - -let tri_to_bl c = - match c with - | Yes | Maybe -> true - | _ -> false - -type var_side = Left | Right | Neither - -let reform_nexps nv lft rght = - let contains_left, contains_right = contains_nuvar_nexp nv lft, contains_nuvar_nexp nv rght in - if contains_left && contains_right - then - match isolate_nexp nv lft, isolate_nexp nv rght with - | (Some varl, Some factorl, lft_rst), (Some varr, Some factorr, rght_rst) -> - if nexp_eq factorl factorr && nexp_eq varl varr - then None, normalize_nexp (mk_sub rght_rst lft_rst), Neither - else None, normalize_nexp (mk_sub rght lft), Neither (*Hard cases, let's punt for now*) - | (Some varl, Some factor, lft_rst), (Some varr, None, rght_rst) -> - if nexp_eq varl varr - then Some (normalize_nexp (mk_mult (mk_sub factor n_one) varl)), - normalize_nexp (mk_sub rght_rst (mk_mult factor lft_rst)), Left - else None, normalize_nexp (mk_sub rght lft), Neither (*More hard cases*) - | (Some varl, None, lft_rst), (Some varr, Some factor, rght_rst) -> - if nexp_eq varl varr - then Some (normalize_nexp (mk_mult (mk_add factor n_one) varl)), - normalize_nexp (mk_sub (mk_mult factor rght_rst) lft_rst), Left - else None, normalize_nexp (mk_sub rght lft), Neither (*More hard cases*) - | (Some varl, None, lft_rst), (Some varr, None, rght_rst) -> - if nexp_eq varl varr - then None, normalize_nexp (mk_sub rght_rst lft_rst), Neither - else None, normalize_nexp (mk_sub rght lft), Neither - | (None,_,_),(_,_,_) | (_,_,_),(None,_,_) -> assert false - else if contains_left - then - match isolate_nexp nv lft with - | (Some var, Some factor, lft_rst) -> - if divisible_by rght factor - then Some var, normalize_nexp (mk_sub (divide_by rght factor) lft_rst),Left - else Some (mk_mult var factor), normalize_nexp (mk_sub rght (mk_mult factor lft_rst)),Left - | Some var, None, lft_rst -> Some var, normalize_nexp (mk_sub rght lft_rst),Left - | None, _, lft -> None,normalize_nexp (mk_sub rght lft),Neither - else if contains_right - then match isolate_nexp nv rght with - | (Some var, Some factor, rgt_rst) -> - if divisible_by lft factor - then Some var, normalize_nexp (mk_sub (divide_by lft factor) rgt_rst),Right - else Some (mk_mult var factor), normalize_nexp (mk_sub lft (mk_mult factor rgt_rst)),Right - | Some var, None, rgt_rst -> Some var, normalize_nexp (mk_sub lft rgt_rst),Right - | None, _, rght -> None,normalize_nexp (mk_sub rght lft),Neither - else None, normalize_nexp (mk_sub rght lft), Neither - -let iso_builder nuv builder co enforce lft rgt = - match reform_nexps nuv lft rgt with - | Some v, nexp_term, Left -> - builder co enforce v nexp_term - | Some v, nexp_term, Right -> - builder co enforce nexp_term v - | None,nexp_term,Neither -> - builder co enforce n_zero nexp_term - | _ -> assert false (*Should be unreachable*) - -let rec isolate_constraint nuv constraints = match constraints with - | [] -> [] - | c::cs -> - (match c with - | LtEq(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> LtEq(c,e,l,r)) co enforce lft rgt - | Lt(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> Lt(c,e,l,r)) co enforce lft rgt - | GtEq(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> GtEq(c,e,l,r)) co enforce lft rgt - | Gt(co,enforce,lft,rgt) -> iso_builder nuv (fun c e l r -> Gt(c,e,l,r)) co enforce lft rgt - | _ -> c)::isolate_constraint nuv cs - -let check_range_consistent require_lt require_gt guarantee_lt guarantee_gt = - match require_lt,require_gt,guarantee_lt,guarantee_gt with - | None,None,None,None - | Some _, None, None, None | None, Some _ , None, None | None, None, Some _ , None | None, None, None, Some _ - | Some _, Some _,None,None | None,None,Some _,Some _ (*earlier check should ensure these*) - -> () - | Some(crlt,rlt), Some(crgt,rgt), Some(cglt,glt), Some(cggt,ggt) -> - if tri_to_bl (nexp_ge rlt glt) (*Can we guarantee the up is less than the required up*) - then if tri_to_bl (nexp_ge rlt ggt) (*Can we guarantee the lw is less than the required up*) - then if tri_to_bl (nexp_ge glt rgt) (*Can we guarantee the up is greater than the required lw*) - then if tri_to_bl (nexp_ge ggt rgt) (*Can we guarantee that the lw is greater than the required lw*) - then () - else multi_constraint_error cggt crgt ("Constraints arising from these locations requires greater than " - ^ (n_to_string rgt) ^ " but best guarantee is " ^ (n_to_string ggt)) - else multi_constraint_error cglt crgt ("Constraints arising from these locations guarantees a number no greather than " ^ (n_to_string glt) ^ " but requires a number greater than " ^ (n_to_string rgt)) - else multi_constraint_error crlt cggt ("Constraints arising from these locations guarantees a number that is less than " ^ (n_to_string rlt) ^ " but best guarantee is " ^ (n_to_string ggt)) - else multi_constraint_error crlt cglt ("Constraints arising from these locations require no more than " ^ (n_to_string rlt) ^ " but guarantee indicates it may be above " ^ (n_to_string glt)) - | _ -> - (*let _ = Printf.eprintf "check_range_consistent is in the partial case\n" in*) - () - -let check_ranges cs = - (*let _ = Printf.eprintf "In check_ranges with %i constraints\n%!" (constraint_size cs) in*) - let nuvars = get_all_nuvars_cs cs in - (*let _ = Printf.eprintf "Have %i nuvars\n" (List.length (Var_set.elements nuvars)) in*) - let nus_with_cs = List.map (fun n -> (n,contains_nuvar n cs)) (Var_set.elements nuvars) in - let nus_with_iso_cs = List.map (fun (n,ncs) -> (n,isolate_constraint n ncs)) nus_with_cs in - let refined_cs = List.concat (List.map (fun (n,ncs) -> - let guarantees,max_guarantee_lt,min_guarantee_gt = - refine_guarantees false None None n (flatten_constraints ncs) in - let require_cs,min_require_lt,max_require_gt = refine_requires false None None n guarantees in - check_range_consistent min_require_lt max_require_gt max_guarantee_lt min_guarantee_gt; - require_cs) - nus_with_iso_cs) - in - refined_cs - -let do_resolve_constraints = ref true - -let resolve_constraints cs = - (*let _ = Printf.eprintf "called resolve constraints with %i constraints\n" (constraint_size cs) in*) - if not !do_resolve_constraints - then (cs,None) - else - let rec fix checker len cs = - (*let _ = Printf.eprintf "Calling fix check thunk, fix check point is %i\n%!" len in *) - let cs' = checker (in_constraint_env cs) cs in - let len' = constraint_size cs' in - if len > len' then fix checker len' cs' - else cs' in - (*let _ = Printf.eprintf "Original constraints are %s\n%!" (constraints_to_string cs) in*) - let branch_freshened = prepare_constraints cs in - (*let _ = Printf.eprintf "Constraints after prepare constraints are %s\n" - (constraints_to_string branch_freshened) in*) - let nuvar_equated = fix equate_nuvars (constraint_size branch_freshened) branch_freshened in - (*let _ = Printf.eprintf "Constraints after nuvar equated are %s\n%!" (constraints_to_string nuvar_equated) in*) - let complex_constraints = - fix (fun in_env cs -> let (ncs,_) = merge_paths false (simple_constraint_check in_env cs) in ncs) - (constraint_size nuvar_equated) nuvar_equated in - (*let _ = Printf.eprintf "Now considering %i constraints \n%!" (constraint_size complex_constraints) in*) - let (complex_constraints,map) = merge_paths true complex_constraints in - let complex_constraints = check_ranges complex_constraints in - (*let _ = Printf.eprintf "Resolved as many constraints as possible, leaving %i\n" - (constraint_size complex_constraints) in - let _ = Printf.eprintf "%s\n" (constraints_to_string complex_constraints) in*) - (complex_constraints,map) - - -let check_tannot l annot imp_param constraints efs = - match annot with - | Base((params,t),tag,cs,ef,_,bindings) -> - let efs = remove_local_effects efs in - ignore(effects_eq (Specc l) efs ef); - let s_env = (t_remove_unifications Envmap.empty t) in - let params = Envmap.to_list s_env in - ignore (remove_internal_unifications s_env); - let t' = match (t.t,imp_param) with - | Tfn(p,r,_,e),Some x -> {t = Tfn(p,r,IP_user x,e) } - | _ -> t in - Base((params,t'),tag,cs,ef,pure_e,bindings) - | NoTyp -> raise (Reporting_basic.err_unreachable l "check_tannot given the place holder annotation") - | Overload _ -> raise (Reporting_basic.err_unreachable l "check_tannot given overload") - -let tannot_merge co denv widen t_older t_newer = - (*let _ = Printf.eprintf "tannot_merge called\n" in*) - match t_older,t_newer with - | NoTyp,NoTyp -> NoTyp - | NoTyp,_ -> t_newer - | _,NoTyp -> t_older - | Base((ps_o,t_o),tag_o,cs_o,efl_o,_,bounds_o),Base((ps_n,t_n),tag_n,cs_n,efl_n,_,bounds_n) -> - (match tag_o,tag_n with - | Default,tag -> - (match t_n.t with - | Tuvar _ -> let t_o,cs_o,ef_o,_ = subst ps_o false false t_o cs_o efl_o in - let t,_ = type_consistent co denv Guarantee false t_n t_o in - Base(([],t),tag_n,cs_o,ef_o,pure_e,bounds_o) - | _ -> t_newer) - | Emp_local, Emp_local -> - (*let _ = Printf.eprintf "local-local case\n" in*) - if conforms_to_t denv true false t_n t_o - then - let t,cs_b = type_consistent co denv Guarantee widen t_n t_o in - (*let _ = Printf.eprintf "types consistent\n" in*) - Base(([],t),Emp_local,cs_o@cs_n@cs_b,union_effects efl_o efl_n,pure_e, merge_bounds bounds_o bounds_n) - else Base(([],t_n),Emp_local,cs_n,efl_n,pure_e,bounds_n) - | _,_ -> t_newer) - | _ -> t_newer diff --git a/src/type_internal.mli b/src/type_internal.mli deleted file mode 100644 index ee2e3988..00000000 --- a/src/type_internal.mli +++ /dev/null @@ -1,390 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* *) -(* 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 Big_int - -module Envmap : Finite_map.Fmap with type k = string -module Nameset : sig - include Set.S with type elt = string - val pp : Format.formatter -> t -> unit -end - -val zero : big_int -val one : big_int -val two : big_int - -(*Trinary replacement for boolean, as sometimes we do want to distinguish we just don't know from a certain yes or no*) -type triple = Yes | No | Maybe -val triple_negate : triple -> triple - -type kind = { mutable k : k_aux } -and k_aux = - | K_Typ - | K_Nat - | K_Ord - | K_Efct - | K_Val - | K_Lam of kind list * kind - | K_infer - -type t_uvar -type n_uvar -type e_uvar -type o_uvar -type t = { mutable t : t_aux } -(*No recursive t will ever be Tfn *) -and t_aux = - | Tvar of string (* concrete *) - | Tid of string (* concrete *) - | Tfn of t * t * implicit_parm * effect (* concrete *) - | Ttup of t list (* concrete *) - | Tapp of string * t_arg list (* concrete *) - | Tabbrev of t * t (* first t is the type from the source; second is the actual ground type, never abbrev *) - | Toptions of t * t option (* used in overloads or cast; first is always concrete. Removed in type checking *) - | Tuvar of t_uvar (* Unification variable *) -(*Implicit nexp parameters for library and special function calls*) -and implicit_parm = - | IP_none (*Standard function*) - | IP_length of nexp (*Library function to take length of a vector as first parameter*) - | IP_start of nexp (*Library functions to take start of a vector as first parameter*) - | IP_user of nexp (*Special user functions, must be declared with val, will pass stated parameter to function from return type*) -and nexp = { mutable nexp : nexp_aux ; mutable imp_param : bool} -and nexp_aux = - | Nvar of string - | Nid of string * nexp - | Nconst of big_int - | Npos_inf (* Used to define nat and int types, does not arise from source otherwise *) - | Nneg_inf (* Used to define int type, does not arise from source otherwise *) - | Nadd of nexp * nexp - | Nsub of nexp * nexp - | Nmult of nexp * nexp - | N2n of nexp * big_int option (* Optionally contains the 2^n result for const n, for different constraint equations *) - | Npow of nexp * int (* Does not appear in source *) - | Nneg of nexp (* Does not appear in source *) - | Ninexact (*Does not appear in source*) - | Nuvar of n_uvar (* Unification variable *) -and effect = { mutable effect : effect_aux } -and effect_aux = - | Evar of string - | Eset of Ast.base_effect list - | Euvar of e_uvar (* Unificiation variable *) -and order = { mutable order : order_aux } -and order_aux = - | Ovar of string - | Oinc - | Odec - | Ouvar of o_uvar (* Unification variable *) -and t_arg = - | TA_typ of t - | TA_nexp of nexp - | TA_eft of effect - | TA_ord of order - -module Nexpmap : Finite_map.Fmap with type k = nexp -type nexp_map = nexp Nexpmap.t - -type alias_inf = - | Alias_field of string * string - | Alias_extract of string * int * int - | Alias_pair of string * string - -type tag = - | Emp_local (* Standard value, variable, expression *) - | Emp_global (* Variable from global instead of local scope *) - | Emp_intro (* Local mutable variable, and this is its introduction *) - | Emp_set (* Local mutable expression being set *) - | Tuple_assign of tag list (* Tuple of assignments, should not be External, Default, Construct, etc*) - | External of string option (* External function or register name *) - | Default (* Variable has default type, has not been bound *) - | Constructor of int (* Variable is a data constructor, int says how many variants are in this family *) - | Enum of int (* Variable came from an enumeration, int tells me the highest possible numeric value *) - | Alias of alias_inf (* Variable came from a register alias *) - | Spec (* Variable came from a val specification *) - -type constraint_origin = - | Patt of Parse_ast.l - | Expr of Parse_ast.l - | Fun of Parse_ast.l - | Specc of Parse_ast.l - -type range_enforcement = Require | Guarantee -type cond_kind = Positive | Negative | Solo | Switch -type 'a many = One of 'a | Two of 'a * 'a | Many of 'a list - -(* Constraints for nexps, plus the location which added the constraint *) -type nexp_range = - | LtEq of constraint_origin * range_enforcement * nexp * nexp - | Lt of constraint_origin * range_enforcement * nexp * nexp - | Eq of constraint_origin * nexp * nexp - | NtEq of constraint_origin * nexp * nexp - | GtEq of constraint_origin * range_enforcement * nexp * nexp - | Gt of constraint_origin * range_enforcement * nexp * nexp - | In of constraint_origin * string * int list - (* InS holds the nuvar after a substitution *) - | InS of constraint_origin * nexp * int list - (* Predicate treats the first constraint as holding in positive condcons, the second in negative: - must be one of LtEq, Eq, or GtEq, never In, Predicate, Cond, or Branch *) - | Predicate of constraint_origin * nexp_range * nexp_range - (* Constraints from one path from a conditional (pattern or if) and the constraints from that conditional *) - | CondCons of constraint_origin * cond_kind * (nexp Nexpmap.t) option * nexp_range list * nexp_range list - (* CondCons constraints from all branches of a conditional; list should be all CondCons *) - | BranchCons of constraint_origin * ((nexp many) Nexpmap.t) option * nexp_range list - -val get_c_loc : constraint_origin -> Parse_ast.l - -val n_zero : nexp -val n_one : nexp -val n_two : nexp -val mk_nv : string -> nexp -val mk_nid : string -> nexp -> nexp -val mk_add : nexp -> nexp -> nexp -val mk_sub : nexp -> nexp -> nexp -val mk_mult : nexp -> nexp -> nexp -val mk_c : big_int -> nexp -val mk_c_int : int -> nexp -val mk_neg : nexp -> nexp -val mk_2n : nexp -> nexp -val mk_2nc : nexp -> big_int -> nexp -val mk_pow : nexp -> int -> nexp -val mk_p_inf : unit -> nexp -val mk_n_inf : unit -> nexp -val mk_inexact : unit -> nexp -val set_imp_param : nexp -> unit - -val mk_atom : nexp -> t -val mk_tup : t list -> t -val mk_vector : t -> order -> nexp -> nexp -> t - -type variable_range = - | VR_eq of string * nexp - | VR_range of string * nexp_range list - | VR_vec_eq of string * nexp - | VR_vec_r of string * nexp_range list - | VR_recheck of string * t (*For cases where inference hasn't yet determined the type of v*) - -type bounds_env = - | No_bounds - | Bounds of variable_range list * nexp_map option - -type t_params = (string * kind) list -type tannot = - | NoTyp - (*A type of a function, variable, expression, etc, that is not overloaded: - the first effect is for local effects to the current expression or variable - the second effect is the cummulative effects of any contained subexpressions where applicable, pure otherwise *) - | Base of (t_params * t) * tag * nexp_range list * effect * effect * bounds_env - (* First tannot is the most polymorphic version; the list includes all variants. All t to be Tfn *) - | Overload of tannot * bool * tannot list - -type 'a emap = 'a Envmap.t - -type rec_kind = Record | Register -type rec_env = (string * rec_kind * tannot * ((string * t) list)) -type alias_kind = OneReg of string * tannot | TwoReg of string * string * tannot | MultiReg of (string list) * tannot -type def_envs = { - k_env: kind emap; - abbrevs: tannot emap; - nabbrevs: nexp emap; - namesch : tannot emap; - enum_env : (string list) emap; - rec_env : rec_env list; - alias_env : alias_kind emap; - default_o : order; - } - -type exp = tannot Ast.exp - -type minmax = (constraint_origin * nexp) option -type constraints = nexp_range list - - -val lookup_record_typ : string -> rec_env list -> rec_env option -val lookup_record_fields : string list -> rec_env list -> rec_env option -val lookup_possible_records : string list -> rec_env list -> rec_env list -val lookup_field_type : string -> rec_env -> t option - -val add_effect : Ast.base_effect -> effect -> effect -val union_effects : effect -> effect -> effect -val e_to_string : effect -> string -val has_rreg_effect : effect -> bool -val has_wreg_effect : effect -> bool -val has_rmem_effect : effect -> bool -val has_rmemt_effect : effect -> bool -val has_wmem_effect : effect -> bool -val has_eamem_effect : effect -> bool -val has_exmem_effect : effect -> bool -val has_memv_effect : effect -> bool -val has_memvt_effect : effect -> bool -val has_lret_effect : effect -> bool - -val initial_kind_env : kind Envmap.t -val initial_abbrev_env : tannot Envmap.t -val initial_typ_env : tannot Envmap.t -val nat_t : t -val unit_t : t -val int64_t : t -val bool_t : t -val bit_t : t -val string_t : t -val pure_e : effect -val nob : bounds_env - -val simple_annot : t -> tannot -val simple_annot_efr : t -> effect -> tannot -val global_annot : t -> tannot -val tag_annot : t -> tag -> tannot -val tag_annot_efr : t -> tag -> effect -> tannot -val constrained_annot : t -> constraints -> tannot -val constrained_annot_efr : t -> constraints -> effect -> tannot -val bounds_annot : t -> bounds_env -> tannot -val bounds_annot_efr : t -> bounds_env -> effect -> tannot -val cons_tag_annot : t -> tag -> constraints -> tannot -val cons_tag_annot_efr : t -> tag -> constraints -> effect -> tannot -val cons_efl_annot : t -> constraints -> effect -> tannot -val cons_efs_annot : t -> constraints -> effect -> effect -> tannot -val efs_annot : t -> effect -> effect -> tannot -val tag_efs_annot: t -> tag -> effect -> effect -> tannot -val cons_bs_annot : t -> constraints -> bounds_env -> tannot -val cons_bs_annot_efr : t -> constraints -> bounds_env -> effect -> tannot - -val kind_to_string : kind -> string -val t_to_string : t -> string -val n_to_string : nexp -> string -val constraints_to_string : constraints -> string -val bounds_to_string : bounds_env -> string -val tannot_to_string : tannot -> string -val t_to_typ : t -> Ast.typ - -val int_to_nexp : int -> nexp - -val reset_fresh : unit -> unit -val new_t : unit -> t -val new_n : unit -> nexp -val new_o : unit -> order -val new_e : unit -> effect -val equate_t : t -> t -> unit - -val typ_subst : t_arg emap -> bool -> t -> t -val subst : (Envmap.k * kind) list -> bool -> bool -> t -> constraints -> effect -> t * constraints * effect * t_arg emap -val subst_with_env : t_arg emap -> bool -> t -> nexp_range list -> effect -> t * constraints * effect * t_arg emap -val subst_n_with_env : t_arg emap -> nexp -> nexp -val type_param_consistent : Parse_ast.l -> t_arg emap -> t_arg emap -> nexp_range list - -val get_abbrev : def_envs -> t -> (t * nexp_range list) - -val is_enum_typ : def_envs -> t -> int option -val is_bit_vector : t -> bool - -val extract_bounds : def_envs -> string -> t -> bounds_env -val merge_bounds : bounds_env -> bounds_env -> bounds_env -val find_var_from_nexp : nexp -> bounds_env -> (string option * string) option -val add_map_to_bounds : nexp_map -> bounds_env -> bounds_env -val add_map_tannot : nexp_map -> tannot -> tannot -val get_map_tannot : tannot -> nexp_map option -val merge_option_maps : nexp_map option -> nexp_map option -> nexp_map option - -val expand_nexp : nexp -> nexp list -val normalize_nexp : nexp -> nexp -val get_index : nexp -> int (*expose nindex through this for debugging purposes*) -val get_all_nvar : nexp -> string list (*Pull out all of the contained nvar and nuvars in nexp*) - -val select_overload_variant : def_envs -> bool -> bool -> tannot list -> t -> tannot list - -(*splits constraints into always, positive, negative constraints; where positive and negative happen for predicates *) -val split_conditional_constraints : constraints -> (constraints * constraints * constraints) - -(*May raise an exception if a contradiction is found*) -val resolve_constraints : constraints -> (constraints * nexp_map option) -(* whether to actually perform constraint resolution or not *) -val do_resolve_constraints : bool ref - -(*May raise an exception if effects do not match tannot effects, - will lift unification variables to fresh type variables *) -val check_tannot : Parse_ast.l -> tannot -> nexp option -> constraints -> effect -> tannot - -val nexp_eq_check : nexp -> nexp -> bool (*structural equality only*) -val nexp_eq : nexp -> nexp -> bool -val nexp_one_more_than : nexp -> nexp -> bool - -(*Selects the subset of given list where an nexp_range contains the given nexp, presumed to be an nvar*) -val contains_nvar : nexp -> constraints -> constraints -(*As above but with nuvars*) -val contains_nuvar : nexp -> constraints -> constraints -(*Removes first nexp from second nexp, when first nexp is a nuvar or nvar. - If it isn't possible to remove the first nexp fully and leave integral values on the resulting nexp - i.e. if we have isolate_nexp 'i (8*i) + 3), then we return the nexp and any non-removable factors - (this may include 2 ^^ 'x) -*) -val isolate_nexp : nexp -> nexp -> (nexp option * nexp option * nexp) -val refine_requires: bool -> minmax -> minmax -> Nexpmap.k -> constraints -> constraints * minmax * minmax -val refine_guarantees: bool -> minmax-> minmax -> Nexpmap.k -> constraints -> constraints * minmax * minmax - - -(*type relations*) - -val conforms_to_t : def_envs -> bool -> bool -> t -> t -> bool - -(* type_consistent is similar to a standard type equality, except in the case of [[consistent t1 t2]] where - t1 and t2 are both range types and t1 is contained within the range of t2: i.e. - range<2, 5> is consistent with range<0, 10>, but not vice versa. - Similar for atom. - When widen, two atoms are used to generate a range that contains them (or is defined by them for constants; and an atom and a range may widen the range. - type_consistent mutates uvars to perform unification and will raise an error if the [[t1]] and [[t2]] are inconsistent -*) -val type_consistent : constraint_origin -> def_envs -> range_enforcement -> bool -> t -> t -> t * constraints - -(* type_coerce mutates to unify variables, and will raise an exception if the first type cannot - be coerced into the second and is additionally inconsistent with the second; - bool specifices whether this has arisen from an implicit or explicit type coercion request - type_coerce origin envs enforce is_explicit (ie came from user) widen bounds t exp expect_t - *) -val type_coerce : constraint_origin -> def_envs -> range_enforcement -> bool -> bool -> bounds_env -> t -> exp -> t -> t * constraints * effect * exp - -(* Merge tannots when intersection or unioning two environments. In case of default types, defer to tannot on right - When merging atoms, use bool to control widening. -*) -val tannot_merge : constraint_origin -> def_envs -> bool -> tannot -> tannot -> tannot - -val initial_typ_env : tannot Envmap.t - -val initial_typ_env_list : (string * ((string * tannot) list)) list - diff --git a/src/util.ml b/src/util.ml index 2b6f81f8..d2d4eea7 100644 --- a/src/util.ml +++ b/src/util.ml @@ -144,7 +144,14 @@ let rec compare_list f l1 l2 = compare_list f l1 l2 else c - + +let rec split_on_char sep str = + try + let sep_pos = String.index str sep in + String.sub str 0 sep_pos :: split_on_char sep (String.sub str (sep_pos + 1) (String.length str - (sep_pos + 1))) + with + | Not_found -> [str] + let map_changed_default d f l = let rec g = function | [] -> ([],false) @@ -196,6 +203,12 @@ let option_bind f = function | None -> None | Some(o) -> f o +let rec option_binop f x y = match x, y with + | None, None -> None + | Some x, None -> Some x + | None, Some y -> Some y + | Some x, Some y -> Some (f x y) + let changed2 f g x h y = match (g x, h y) with | (None,None) -> None @@ -240,6 +253,12 @@ let split_after n l = | _ -> raise (Failure "index too large") in aux [] n l +let rec split3 = function + | (x, y, z) :: xs -> + let (xs, ys, zs) = split3 xs in + (x :: xs, y :: ys, z :: zs) + | [] -> ([], [], []) + let list_mapi (f : int -> 'a -> 'b) (l : 'a list) : 'b list = let rec aux f i l = match l with @@ -324,4 +343,3 @@ let rec string_of_list sep string_of = function | [] -> "" | [x] -> string_of x | x::ls -> (string_of x) ^ sep ^ (string_of_list sep string_of ls) - diff --git a/src/util.mli b/src/util.mli index c565cdce..cfd6a19e 100644 --- a/src/util.mli +++ b/src/util.mli @@ -77,6 +77,12 @@ val option_bind : ('a -> 'b option) -> 'a option -> 'b option whereas [option_default d (Some x)] returns [x]. *) val option_default : 'a -> 'a option -> 'a +(** [option_binop f None None] returns [None], while + [option_binop f (Some x) None] and [option_binop f None (Some x)] + return [Some x], and [option_binop f (Some x) (Some y)] returns + [Some (f x y)] *) +val option_binop : ('a -> 'a -> 'a) -> 'a option -> 'a option -> 'a option + (** [option_get_exn exn None] throws the exception [exn], whereas [option_get_exn exn (Some x)] returns [x]. *) val option_get_exn : exn -> 'a option -> 'a @@ -145,6 +151,9 @@ val undo_list_to_front : int -> 'a list -> 'a list [l1] and [l2], with [length l1 = n] and [l1 @ l2 = l]. Fails if n is too small or large. *) val split_after : int -> 'a list -> 'a list * 'a list +(** [split3 l] splits a list of triples into a triple of lists *) +val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int @@ -195,3 +204,5 @@ module ExtraSet : functor (S : Set.S) -> (*Formatting functions*) val string_of_list : string -> ('a -> string) -> 'a list -> string + +val split_on_char : char -> string -> string list |