diff options
Diffstat (limited to 'src')
72 files changed, 19075 insertions, 17329 deletions
diff --git a/src/Makefile b/src/Makefile index be1eb9e5..e0c1e45c 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?= @@ -49,15 +49,21 @@ all: sail lib doc full: sail lib power doc test -sail: - ocamlbuild sail.native sail_lib.cma sail_lib.cmxa +ast.ml: ../language/l2.ott + ott -sort false -generate_aux_rules true -o ast.ml -picky_multiple_parses true ../language/l2.ott + +lem_interp/interp_ast.lem: ../language/l2.ott + ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott + +sail: ast.ml + ocamlbuild sail.native sail.native: sail -sail.byte: +sail.byte: ocamlbuild -cflag -g sail.byte -interpreter: +interpreter: lem_interp/interp_ast.lem ocamlbuild lem_interp/extract.cmxa ocamlbuild lem_interp/extract.cma @@ -66,32 +72,34 @@ test: sail interpreter ./run_tests.native THIS_MAKEFILE := $(realpath $(lastword $(MAKEFILE_LIST))) +SAIL_DIR:=$(realpath $(dir $(THIS_MAKEFILE))..) BITBUCKET_ROOT=$(realpath $(dir $(THIS_MAKEFILE))../..) LEM = $(BITBUCKET_ROOT)/lem/lem LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib ELFDIR= $(BITBUCKET_ROOT)/linksem ZARITH_DIR=$(LEMLIBOCAML)/dependencies/zarith -ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa +ZARITH_LIB=$(ZARITH_DIR)/zarith.cma +# ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa -SAIL_DIR:=$(BITBUCKET_ROOT)/sail -MIPS_SAIL_DIR:=$(SAIL_DIR)/mips +SAIL_LIB_DIR:=$(SAIL_DIR)/lib +MIPS_SAIL_DIR:=$(SAIL_DIR)/mips_new_tc -MIPS_SAILS_PRE:=$(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(MIPS_SAIL_DIR)/mips_wrappers.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail +MIPS_SAILS_PRE:=$(SAIL_LIB_DIR)/prelude.sail $(SAIL_LIB_DIR)/prelude_wrappers.sail $(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(MIPS_SAIL_DIR)/mips_wrappers.sail $(MIPS_SAIL_DIR)/mips_ast_decl.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail MIPS_SAILS:=$(MIPS_SAILS_PRE) $(SAIL_DIR)/etc/regfp.sail $(MIPS_SAIL_DIR)/mips_regfp.sail -MIPS_NOTLB_SAILS_PRE:=$(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb_stub.sail $(MIPS_SAIL_DIR)/mips_wrappers.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail +MIPS_NOTLB_SAILS_PRE:=$(SAIL_LIB_DIR)/prelude.sail $(SAIL_LIB_DIR)/prelude_wrappers.sail $(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb_stub.sail $(MIPS_SAIL_DIR)/mips_wrappers.sail $(MIPS_SAIL_DIR)/mips_ast_decl.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail MIPS_NOTLB_SAILS:=$(MIPS_NOTLB_SAILS_PRE) $(SAIL_DIR)/etc/regfp.sail $(MIPS_SAIL_DIR)/mips_regfp.sail CHERI_SAIL_DIR:=$(SAIL_DIR)/cheri -CHERI_NOTLB_SAILS:=$(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb_stub.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_256.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail +CHERI_NOTLB_SAILS:=$(SAIL_LIB_DIR)/prelude.sail $(SAIL_LIB_DIR)/prelude_wrappers.sail $(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb_stub.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_256.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail -CHERI_SAILS:=$(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_256.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail +CHERI_SAILS:=$(SAIL_LIB_DIR)/prelude.sail $(SAIL_LIB_DIR)/prelude_wrappers.sail $(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_256.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail -CHERI128_SAILS:=$(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_128.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail +CHERI128_SAILS:=$(SAIL_LIB_DIR)/prelude.sail $(SAIL_LIB_DIR)/prelude_wrappers.sail $(MIPS_SAIL_DIR)/mips_prelude.sail $(MIPS_SAIL_DIR)/mips_tlb.sail $(CHERI_SAIL_DIR)/cheri_types.sail $(CHERI_SAIL_DIR)/cheri_prelude_128.sail $(CHERI_SAIL_DIR)/cheri_prelude_common.sail $(MIPS_SAIL_DIR)/mips_insts.sail $(CHERI_SAIL_DIR)/cheri_insts.sail $(MIPS_SAIL_DIR)/mips_ri.sail $(MIPS_SAIL_DIR)/mips_epilogue.sail elf: make -C $(ELFDIR) @@ -124,10 +132,14 @@ _build/mips.lem: $(MIPS_SAILS) ./sail.native cd _build ;\ ../sail.native -lem_ast -o mips $(MIPS_SAILS) -_build/mips_embed_types.lem: $(MIPS_SAILS) ./sail.native +_build/mips_embed_types.lem: $(MIPS_NOTLB_SAILS) ./sail.native mkdir -p _build cd _build ;\ - ../sail.native -lem_lib "Mips_extras_embed" -lem -o mips $(MIPS_NOTLB_SAILS) + ../sail.native -lem_lib "Mips_extras_embed" -lem -lem_mwords -o mips $(MIPS_NOTLB_SAILS) + +_build/Mips_embed.thy: _build/mips_embed_types.lem + cd _build ;\ + lem -isa -outdir . -lib ../lem_interp -lib ../gen_lib $(MIPS_SAIL_DIR)/mips_extras_embed.lem mips_embed_types.lem mips_embed.lem _build/mips_notlb.lem: $(MIPS_NOTLB_SAILS) ./sail.native mkdir -p _build @@ -169,14 +181,14 @@ _build/cheri_notlb.lem: $(CHERI_NOTLB_SAILS) ./sail.native cd _build ;\ ../sail.native -lem_ast -o cheri_notlb $(CHERI_NOTLB_SAILS) -_build/cheri_embed_types.lem: $(CHERI_SAILS) ./sail.native +_build/cheri_embed_types_sequential.lem: $(CHERI_SAILS) ./sail.native mkdir -p _build cd _build ;\ - ../sail.native -lem_lib "Mips_extras_embed" -lem -o cheri $(CHERI_SAILS) + ../sail.native -lem_lib "Mips_extras_embed" -lem -lem_sequential -lem_mwords -o cheri $(CHERI_SAILS) -_build/Cheri_embed_sequential.thy: _build/cheri_embed_types.lem +_build/Cheri_embed_sequential.thy: _build/cheri_embed_types_sequential.lem cd _build ;\ - lem -isa -outdir . ../lem_interp/sail_impl_base.lem ../gen_lib/state.lem ../../mips/mips_extras_embed_sequential.lem cheri_embed_types.lem cheri_embed_sequential.lem + lem -isa -outdir . -lib ../lem_interp -lib ../gen_lib $(MIPS_SAIL_DIR)/mips_extras_embed_sequential.lem cheri_embed_types_sequential.lem cheri_embed_sequential.lem _build/mips_all.sail: $(MIPS_SAILS) cat $(MIPS_SAILS) > $@ @@ -193,8 +205,11 @@ count: _build/cheri_trimmed.sail _build/mips_trimmed.sail %.ml: %.lem $(LEM) -only_changed_output -ocaml -lib lem_interp/ $< +#run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter +# env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter - env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + env OCAMLRUNPARAM=l=100M ocamlfind ocamlc $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cma $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cma $(ELFDIR)/src/linksem.cma _build/pprint/src/PPrintLib.cma _build/lem_interp/extract.cma _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native run_cheri.native: _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml interpreter env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml -o run_cheri.native @@ -233,6 +248,7 @@ clean: -rm -rf tex-doc -rm -rf lem lib -rm -rf sail.docdir + -rm -f ast.ml doc: ocamlbuild sail.docdir/index.html @@ -1,7 +1,7 @@ -true: -traverse, debug +true: -traverse, debug, use_menhir <**/*.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, use_str <pprint> or <pprint/src>: include # see http://caml.inria.fr/mantis/view.php?id=4943 diff --git a/src/ast.ml b/src/ast.ml deleted file mode 100644 index c923ae3f..00000000 --- a/src/ast.ml +++ /dev/null @@ -1,584 +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. *) -(**************************************************************************) - -(* generated by Ott 0.25 from: l2.ott *) - - -type text = string - -type l = Parse_ast.l - -type 'a annot = l * 'a - - -type x = text (* identifier *) -type ix = text (* infix identifier *) - -type -base_kind_aux = (* base kind *) - BK_type (* kind of types *) - | BK_nat (* kind of natural number size expressions *) - | BK_order (* kind of vector order specifications *) - | BK_effect (* kind of effect sets *) - - -type -base_kind = - BK_aux of base_kind_aux * l - - -type -id_aux = (* Identifier *) - Id of x - | DeIid of x (* remove infix status *) - - -type -kid_aux = (* variables with kind, ticked to differntiate from program variables *) - Var of x - - -type -kind_aux = (* kinds *) - K_kind of (base_kind) list - - -type -id = - Id_aux of id_aux * l - - -type -kid = - Kid_aux of kid_aux * l - - -type -kind = - K_aux of kind_aux * l - - -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 *) - | Nexp_constant of int (* constant *) - | Nexp_times of nexp * nexp (* product *) - | Nexp_sum of nexp * nexp (* sum *) - | Nexp_minus of nexp * nexp (* subtraction *) - | Nexp_exp of nexp (* exponential *) - | Nexp_neg of nexp (* For internal use *) - -and nexp = - Nexp_aux of nexp_aux * l - - -type -base_effect_aux = (* effect *) - BE_rreg (* read register *) - | BE_wreg (* write register *) - | BE_rmem (* read memory *) - | BE_rmemt (* read memory tagged *) - | BE_wmem (* write memory *) - | BE_eamem (* signal effective address for writing memory *) - | BE_exmem (* determine if a store-exclusive (ARM) is going to succeed *) - | BE_wmv (* write memory, sending only value *) - | BE_wmvt (* write memory, sending only value and tag *) - | BE_barr (* memory barrier *) - | BE_depend (* dynamic footprint *) - | BE_undef (* undefined-instruction exception *) - | BE_unspec (* unspecified values *) - | BE_nondet (* nondeterminism from intra-instruction parallelism *) - | BE_escape (* Tracking of expressions and functions that might call exit *) - | BE_lset (* Local mutation happend; not user-writable *) - | BE_lret (* Local return happened; not user-writable *) - - -type -base_effect = - BE_aux of base_effect_aux * l - - -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 -effect_aux = (* effect set, of kind Effects *) - Effect_var of kid - | Effect_set of (base_effect) list (* effect set *) - - -type -order = - Ord_aux of order_aux * l - - -type -effect = - Effect_aux of effect_aux * l - - -type -kinded_id_aux = (* optionally kind-annotated identifier *) - KOpt_none of kid (* identifier *) - | KOpt_kind of kind * kid (* kind-annotated variable *) - - -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_nat_set_bounded of kid * (int) list - - -type -kinded_id = - KOpt_aux of kinded_id_aux * l - - -type -n_constraint = - NC_aux of n_constraint_aux * l - - -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 = - QI_aux of quant_item_aux * l - - -type -typquant_aux = (* type quantifiers and constraints *) - TypQ_tq of (quant_item) list - | TypQ_no_forall (* sugar, omitting quantifier and constraints *) - - -type -lit_aux = (* Literal constant *) - L_unit (* $() : _$ *) - | L_zero (* $_ : _$ *) - | L_one (* $_ : _$ *) - | L_true (* $_ : _$ *) - | L_false (* $_ : _$ *) - | L_num of int (* natural number constant *) - | L_hex of string (* bit vector constant, C-style *) - | L_bin of string (* bit vector constant, C-style *) - | L_undef (* constant representing undefined values *) - | L_string of string (* string constant *) - - -type -typquant = - TypQ_aux of typquant_aux * l - - -type -typ_aux = (* Type expressions, of kind $_$ *) - Typ_wild (* Unspecified type *) - | Typ_id of id (* Defined type *) - | Typ_var of kid (* Type variable *) - | Typ_fn of typ * typ * effect (* Function type (first-order only in user code) *) - | Typ_tup of (typ) list (* Tuple type *) - | Typ_app of id * (typ_arg) list (* type constructor application *) - -and typ = - Typ_aux of typ_aux * l - -and typ_arg_aux = (* Type constructor arguments of all kinds *) - Typ_arg_nexp of nexp - | Typ_arg_typ of typ - | Typ_arg_order of order - | Typ_arg_effect of effect - -and typ_arg = - Typ_arg_aux of typ_arg_aux * l - - -type -lit = - L_aux of lit_aux * l - - -type -typschm_aux = (* type scheme *) - TypSchm_ts of typquant * typ - - -type -'a pat_aux = (* Pattern *) - P_lit of lit (* literal constant pattern *) - | P_wild (* wildcard *) - | P_as of 'a pat * id (* named pattern *) - | P_typ of typ * 'a pat (* typed pattern *) - | P_id of id (* identifier *) - | P_app of id * ('a pat) list (* union constructor pattern *) - | P_record of ('a fpat) list * bool (* struct pattern *) - | P_vector of ('a pat) list (* vector pattern *) - | P_vector_indexed of ((int * 'a pat)) list (* vector pattern (with explicit indices) *) - | 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 *) - -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 = - FP_aux of 'a fpat_aux * 'a annot - - -type -typschm = - TypSchm_aux of typschm_aux * l - - -type -'a reg_id_aux = - RI_id of id - - -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 *) - | E_id of id (* identifier *) - | E_lit of lit (* literal constant *) - | E_cast of typ * 'a exp (* cast *) - | E_app of id * ('a exp) list (* function application *) - | E_app_infix of 'a exp * id * 'a exp (* infix function application *) - | E_tuple of ('a exp) list (* tuple *) - | E_if of 'a exp * 'a exp * 'a exp (* conditional *) - | E_for of id * 'a exp * 'a exp * 'a exp * order * 'a exp (* loop *) - | E_vector of ('a exp) list (* vector (indexed from 0) *) - | E_vector_indexed of ((int * 'a exp)) list * 'a opt_default (* vector (indexed consecutively) *) - | E_vector_access of 'a exp * 'a exp (* vector access *) - | E_vector_subrange of 'a exp * 'a exp * 'a exp (* subvector extraction *) - | E_vector_update of 'a exp * 'a exp * 'a exp (* vector functional update *) - | E_vector_update_subrange of 'a exp * 'a exp * 'a exp * 'a exp (* vector subrange update (with vector) *) - | E_vector_append of 'a exp * 'a exp (* vector concatenation *) - | E_list of ('a exp) list (* list *) - | E_cons of 'a exp * 'a exp (* cons *) - | E_record of 'a fexps (* struct *) - | E_record_update of 'a exp * 'a fexps (* functional update of struct *) - | E_field of 'a exp * id (* field projection from struct *) - | E_case of 'a exp * ('a pexp) list (* pattern matching *) - | 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_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 *) - | E_internal_cast of 'a annot * 'a exp (* This is an internal cast, generated during type checking that will resolve into a syntactic cast after *) - | E_internal_exp of 'a annot (* This is an internal use for passing nexp information to library functions, postponed for constraint solving *) - | E_sizeof_internal of 'a annot (* For sizeof during type checking, to replace nexp with internal n *) - | E_internal_exp_user of 'a annot * 'a annot (* This is like the above but the user has specified an implicit parameter for the current function *) - | E_comment of string (* For generated unstructured comments *) - | E_comment_struc of 'a exp (* For generated structured comments *) - | E_internal_let of 'a lexp * 'a exp * 'a exp (* This is an internal node for compilation that demonstrates the scope of a local mutable variable *) - | 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 = - E_aux of 'a exp_aux * 'a annot - -and 'a lexp_aux = (* lvalue expression *) - LEXP_id of id (* identifier *) - | LEXP_memory of id * ('a exp) list (* memory write via function call *) - | LEXP_cast of typ * id - | LEXP_tup of ('a lexp) list (* set multiple at a time, a check will ensure it's not memory *) - | LEXP_vector of 'a lexp * 'a exp (* vector element *) - | LEXP_vector_range of 'a lexp * 'a exp * 'a exp (* subvector *) - | LEXP_field of 'a lexp * id (* struct field *) - -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 = - 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 = - 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 = - Def_val_aux of 'a opt_default_aux * 'a annot - -and 'a pexp_aux = (* Pattern match *) - Pat_exp of 'a pat * 'a exp - -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 = - LB_aux of 'a letbind_aux * 'a annot - - -type -'a reg_id = - RI_aux of 'a reg_id_aux * 'a annot - - -type -type_union_aux = (* Type union constructors *) - Tu_id of id - | Tu_ty_id of typ * id - - -type -name_scm_opt_aux = (* Optional variable-naming-scheme specification for variables of defined type *) - Name_sect_none - | Name_sect_some of string - - -type -effect_opt_aux = (* Optional effect annotation for functions *) - Effect_opt_pure (* sugar for empty effect set *) - | Effect_opt_effect of effect - - -type -'a funcl_aux = (* Function clause *) - FCL_Funcl of id * 'a pat * 'a exp - - -type -rec_opt_aux = (* Optional recursive annotation for functions *) - Rec_nonrec (* non-recursive *) - | Rec_rec (* recursive *) - - -type -tannot_opt_aux = (* Optional type annotation for functions *) - Typ_annot_opt_some of typquant * typ - - -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 - | AL_slice of 'a reg_id * 'a exp * 'a exp - | AL_concat of 'a reg_id * 'a reg_id - - -type -type_union = - Tu_aux of type_union_aux * l - - -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 = - BF_aux of index_range_aux * l - - -type -name_scm_opt = - Name_sect_aux of name_scm_opt_aux * l - - -type -effect_opt = - Effect_opt_aux of effect_opt_aux * l - - -type -'a funcl = - FCL_aux of 'a funcl_aux * 'a annot - - -type -rec_opt = - Rec_aux of rec_opt_aux * l - - -type -tannot_opt = - Typ_annot_opt_aux of tannot_opt_aux * l - - -type -'a alias_spec = - AL_aux of 'a alias_spec_aux * 'a annot - - -type -'a 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 *) - 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 *) - | TD_enum of id * name_scm_opt * (id) list * bool (* enumeration type definition *) - | TD_register of id * nexp * nexp * ((index_range * id)) list (* register mutable bitfield type definition *) - - -type -'a 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 *) - - -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 *) - | KD_record of kind * id * name_scm_opt * typquant * ((typ * id)) list * bool (* struct type definition *) - | KD_variant of kind * id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) - | KD_enum of kind * id * name_scm_opt * (id) list * bool (* enumeration type definition *) - | KD_register of kind * id * nexp * nexp * ((index_range * id)) list (* register mutable bitfield type definition *) - - -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 *) - | SD_scattered_funcl of 'a funcl (* scattered function definition clause *) - | SD_scattered_variant of id * name_scm_opt * typquant (* scattered union definition header *) - | SD_scattered_unioncl of id * type_union (* scattered union definition member *) - | SD_scattered_end of id (* scattered definition end *) - - -type -'a fundef_aux = (* Function definition *) - FD_function of rec_opt * tannot_opt * effect_opt * ('a funcl) list - - -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 type_def = - TD_aux of 'a type_def_aux * 'a annot - - -type -'a val_spec = - VS_aux of 'a val_spec_aux * 'a annot - - -type -'a kind_def = - KD_aux of 'a kind_def_aux * 'a annot - - -type -'a scattered_def = - SD_aux of 'a scattered_def_aux * 'a annot - - -type -'a fundef = - FD_aux of 'a fundef_aux * 'a annot - - -type -'a dec_spec = - DEC_aux of 'a dec_spec_aux * 'a annot - - -type -'a dec_comm = (* Top-level generated comments *) - DC_comm of string (* generated unstructured comment *) - | DC_comm_struct of 'a def (* generated structured comment *) - -and 'a def = (* Top-level definition *) - DEF_kind of 'a kind_def (* definition of named kind identifiers *) - | DEF_type of 'a type_def (* type 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_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 -'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..d2712133 --- /dev/null +++ b/src/ast_util.ml @@ -0,0 +1,840 @@ +(**************************************************************************) +(* 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 no_annot = (Parse_ast.Unknown, ()) + +let gen_loc l = Parse_ast.Generated l + +let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown) +let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown) + +let mk_id str = Id_aux (Id str, Parse_ast.Unknown) + +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 mk_exp exp_aux = E_aux (exp_aux, no_annot) +let unaux_exp (E_aux (exp_aux, _)) = exp_aux + +let mk_pat pat_aux = P_aux (pat_aux, no_annot) +let unaux_pat (P_aux (pat_aux, _)) = pat_aux + +let mk_lexp lexp_aux = LEXP_aux (lexp_aux, no_annot) + +let mk_lit lit_aux = L_aux (lit_aux, Parse_ast.Unknown) + +let mk_lit_exp lit_aux = mk_exp (E_lit (mk_lit lit_aux)) + +let mk_funcl id pat body = FCL_aux (FCL_Funcl (id, pat, body), no_annot) + +let mk_qi_nc nc = QI_aux (QI_const nc, Parse_ast.Unknown) + +let mk_qi_id bk kid = + let kopt = + KOpt_aux (KOpt_kind (K_aux (K_kind [BK_aux (bk, Parse_ast.Unknown)], Parse_ast.Unknown), kid), Parse_ast.Unknown) + in + QI_aux (QI_id kopt, Parse_ast.Unknown) + +let mk_fundef funcls = + let tannot_opt = Typ_annot_opt_aux (Typ_annot_opt_none, Parse_ast.Unknown) in + let effect_opt = Effect_opt_aux (Effect_opt_pure, Parse_ast.Unknown) in + let rec_opt = Rec_aux (Rec_nonrec, Parse_ast.Unknown) in + DEF_fundef + (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), no_annot)) + +let mk_letbind pat exp = LB_aux (LB_val (pat, exp), no_annot) + +let mk_val_spec vs_aux = + DEF_spec (VS_aux (vs_aux, no_annot)) + +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 + +let string_of_kid = function + | Kid_aux (Var v, _) -> v + +module Kid = struct + type t = kid + let compare kid1 kid2 = String.compare (string_of_kid kid1) (string_of_kid kid2) +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 Nexp = struct + type t = nexp + let rec compare (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) = + let lex_ord (c1, c2) = if c1 = 0 then c2 else c1 in + match nexp1, nexp2 with + | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 + | Nexp_var kid1, Nexp_var kid2 -> Kid.compare kid1 kid2 + | Nexp_constant c1, Nexp_constant c2 -> compare_big_int c1 c2 + | Nexp_times (n1a, n1b), Nexp_times (n2a, n2b) + | Nexp_sum (n1a, n1b), Nexp_sum (n2a, n2b) + | Nexp_minus (n1a, n1b), Nexp_minus (n2a, n2b) -> + lex_ord (compare n1a n2a, compare n1b n2b) + | Nexp_exp n1, Nexp_exp n2 -> compare n1 n2 + | Nexp_neg n1, Nexp_neg n2 -> compare n1 n2 + | Nexp_constant _, _ -> -1 | _, Nexp_constant _ -> 1 + | Nexp_id _, _ -> -1 | _, Nexp_id _ -> 1 + | Nexp_var _, _ -> -1 | _, Nexp_var _ -> 1 + | Nexp_neg _, _ -> -1 | _, Nexp_neg _ -> 1 + | Nexp_exp _, _ -> -1 | _, Nexp_exp _ -> 1 + | Nexp_minus _, _ -> -1 | _, Nexp_minus _ -> 1 + | Nexp_sum _, _ -> -1 | _, Nexp_sum _ -> 1 + | Nexp_times _, _ -> -1 | _, Nexp_times _ -> 1 +end + +module Bindings = Map.Make(Id) +module IdSet = Set.Make(Id) +module KBindings = Map.Make(Kid) +module KidSet = Set.Make(Kid) +module NexpSet = Set.Make(Nexp) + +let rec nexp_identical nexp1 nexp2 = (Nexp.compare nexp1 nexp2 = 0) + +let rec is_nexp_constant (Nexp_aux (nexp, _)) = match nexp with + | Nexp_id _ | Nexp_var _ -> false + | Nexp_constant _ -> true + | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) -> + is_nexp_constant n1 && is_nexp_constant n2 + | Nexp_exp n | Nexp_neg n -> is_nexp_constant n + +let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l) +and nexp_simp_aux = function + | Nexp_minus (Nexp_aux (Nexp_sum (Nexp_aux (n1, _), nexp2), _), nexp3) + when nexp_identical nexp2 nexp3 -> + nexp_simp_aux n1 + | Nexp_sum (Nexp_aux (Nexp_minus (Nexp_aux (n1, _), nexp2), _), nexp3) + when nexp_identical nexp2 nexp3 -> + nexp_simp_aux n1 + | 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 (add_big_int 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 c, _ when eq_big_int c unit_big_int -> n2_simp + | _, Nexp_constant c when eq_big_int c unit_big_int -> n1_simp + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (mult_big_int 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 + match n1_simp, n2_simp with + | Nexp_constant c1, Nexp_constant c2 -> Nexp_constant (sub_big_int c1 c2) + (* A vector range x['n-1 .. 0] can result in the size "('n-1) - -1" *) + | Nexp_minus (Nexp_aux (n,_), Nexp_aux (Nexp_constant c1,_)), Nexp_constant c2 + when eq_big_int c1 (minus_big_int c2) -> n + | _, _ -> Nexp_minus (n1, n2) + end + | nexp -> nexp + +let mk_typ typ = Typ_aux (typ, Parse_ast.Unknown) +let mk_typ_arg arg = Typ_arg_aux (arg, Parse_ast.Unknown) +let mk_kid str = Kid_aux (Var ("'" ^ 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 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_simp nexp))])) +let range_typ nexp1 nexp2 = + mk_typ (Typ_app (mk_id "range", [mk_typ_arg (Typ_arg_nexp (nexp_simp nexp1)); + mk_typ_arg (Typ_arg_nexp (nexp_simp 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 tuple_typ typs = mk_typ (Typ_tup typs) +let function_typ typ1 typ2 eff = mk_typ (Typ_fn (typ1, typ2, eff)) + +let vector_typ n m ord typ = + mk_typ (Typ_app (mk_id "vector", + [mk_typ_arg (Typ_arg_nexp (nexp_simp n)); + mk_typ_arg (Typ_arg_nexp (nexp_simp m)); + mk_typ_arg (Typ_arg_order ord); + mk_typ_arg (Typ_arg_typ typ)])) + +let exc_typ = mk_id_typ (mk_id "exception") + +let nconstant c = Nexp_aux (Nexp_constant c, Parse_ast.Unknown) +let nint i = nconstant (big_int_of_int i) +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 nid id = Nexp_aux (Nexp_id id, Parse_ast.Unknown) + +let nc_set kid nums = mk_nc (NC_set (kid, nums)) +let nc_int_set kid ints = mk_nc (NC_set (kid, List.map big_int_of_int ints)) +let nc_eq n1 n2 = mk_nc (NC_equal (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 (nint 1)) +let nc_gt n1 n2 = nc_gteq n1 (nsum n2 (nint 1)) +let nc_and nc1 nc2 = mk_nc (NC_and (nc1, nc2)) +let nc_or nc1 nc2 = mk_nc (NC_or (nc1, nc2)) +let nc_true = mk_nc NC_true +let nc_false = mk_nc NC_false + +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_equal (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_false -> mk_nc NC_true + | NC_true -> mk_nc NC_false + | NC_set (kid, []) -> nc_false + | NC_set (kid, [int]) -> nc_neq (nvar kid) (nconstant int) + | NC_set (kid, int :: ints) -> + mk_nc (NC_and (nc_neq (nvar kid) (nconstant int), nc_negate (mk_nc (NC_set (kid, ints))))) + +let mk_typschm typq typ = TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown) + +let mk_typquant qis = TypQ_aux (TypQ_tq qis, Parse_ast.Unknown) + +let mk_fexp id exp = FE_aux (FE_Fexp (id, exp), no_annot) +let mk_fexps fexps = FES_aux (FES_Fexps (fexps, false), no_annot) + +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 [] + +let quant_items : typquant -> quant_item list = function + | TypQ_aux (TypQ_tq qis, _) -> qis + | TypQ_aux (TypQ_no_forall, _) -> [] + +let quant_kopts typq = + let qi_kopt = function + | QI_aux (QI_id kopt, _) -> [kopt] + | QI_aux _ -> [] + in + quant_items typq |> List.map qi_kopt |> List.concat + +let quant_split typq = + let qi_kopt = function + | QI_aux (QI_id kopt, _) -> [kopt] + | _ -> [] + in + let qi_nc = function + | QI_aux (QI_const nc, _) -> [nc] + | _ -> [] + in + let qis = quant_items typq in + List.concat (List.map qi_kopt qis), List.concat (List.map qi_nc qis) + +let unaux_nexp (Nexp_aux (nexp, _)) = nexp +let unaux_order (Ord_aux (ord, _)) = ord +let unaux_typ (Typ_aux (typ, _)) = typ + +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_loop (loop_type, e1, e2) -> E_loop (loop_type, map_exp_annot f e1, map_exp_annot f e2) + | E_vector exps -> E_vector (List.map (map_exp_annot f) exps) + | 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_try (exp, cases) -> E_try (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_throw exp -> E_throw (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_var (pat, kid) -> P_var (map_pat_annot f pat, kid) + | 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 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 (pat, exp) -> LB_val (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 def_loc = function + | DEF_kind (KD_aux (_, (l, _))) + | DEF_type (TD_aux (_, (l, _))) + | DEF_fundef (FD_aux (_, (l, _))) + | DEF_val (LB_aux (_, (l, _))) + | DEF_spec (VS_aux (_, (l, _))) + | DEF_default (DT_aux (_, l)) + | DEF_scattered (SD_aux (_, (l, _))) + | DEF_reg_dec (DEC_aux (_, (l, _))) + | DEF_fixity (_, _, Id_aux (_, l)) + | DEF_overload (Id_aux (_, l), _) -> + l + | DEF_internal_mutrec _ + | DEF_comm _ -> + Parse_ast.Unknown + +let string_of_id = function + | Id_aux (Id v, _) -> v + | Id_aux (DeIid v, _) -> "(deinfix " ^ v ^ ")" + +let id_of_kid = function + | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) + +let kid_of_id = function + | Id_aux (Id v, l) -> Kid_aux (Var ("'" ^ v), l) + | Id_aux (DeIid v, _) -> assert false + +let prepend_id str = function + | Id_aux (Id v, l) -> Id_aux (Id (str ^ v), l) + | Id_aux (DeIid v, l) -> Id_aux (DeIid (str ^ v), l) + +let prepend_kid str = function + | Kid_aux (Var v, l) -> Kid_aux (Var ("'" ^ str ^ String.sub v 1 (String.length v - 1)), l) + +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" + +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_big_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_app (id, nexps) -> string_of_id id ^ "(" ^ string_of_list ", " string_of_nexp nexps ^ ")" + | 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_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 + | Typ_exist (kids, nc, typ) -> + "exist " ^ string_of_list " " string_of_kid kids ^ ", " ^ string_of_n_constraint nc ^ ". " ^ string_of_typ typ +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 +and string_of_n_constraint = function + | NC_aux (NC_equal (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_set (kid, ns), _) -> + string_of_kid kid ^ " IN {" ^ string_of_list ", " string_of_big_int ns ^ "}" + | NC_aux (NC_true, _) -> "true" + | NC_aux (NC_false, _) -> "false" + +let string_of_annot = function + | Some (_, typ, eff) -> + "Some (_, " ^ string_of_typ typ ^ ", " ^ string_of_effect eff ^ ")" + | None -> "None" + +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_big_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_try (exp, cases) -> + "try " ^ string_of_exp exp ^ " catch { 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_update (v, n, exp) -> "[" ^ string_of_exp v ^ " with " ^ string_of_exp n ^ " = " ^ string_of_exp exp ^ "]" + | E_vector_update_subrange (v, n, m, exp) -> "[" ^ string_of_exp v ^ " with " ^ string_of_exp n ^ " .. " ^ string_of_exp m ^ " = " ^ string_of_exp exp ^ "]" + | 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_loop (While, cond, body) -> "while " ^ string_of_exp cond ^ " do " ^ string_of_exp body + | E_loop (Until, cond, body) -> "repeat " ^ string_of_exp body ^ " until " ^ string_of_exp cond + | E_assert (test, msg) -> "assert(" ^ string_of_exp test ^ ", " ^ string_of_exp msg ^ ")" + | E_exit exp -> "exit " ^ string_of_exp exp + | E_throw exp -> "throw " ^ string_of_exp exp + | E_cons (x, xs) -> string_of_exp x ^ " :: " ^ string_of_exp xs + | E_list xs -> "[||" ^ string_of_list ", " string_of_exp xs ^ "||]" + | E_record_update (exp, FES_aux (FES_Fexps (fexps, _), _)) -> + "{ " ^ string_of_exp exp ^ " with " ^ string_of_list "; " string_of_fexp fexps ^ " }" + | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> + "{ " ^ string_of_list "; " string_of_fexp fexps ^ " }" + | E_internal_cast _ -> "INTERNAL CAST" + | E_internal_exp _ -> "INTERNAL EXP" + | E_sizeof_internal _ -> "INTERNAL SIZEOF" + | E_internal_exp_user _ -> "INTERNAL EXP USER" + | E_comment _ -> "INTERNAL COMMENT" + | E_comment_struc _ -> "INTERNAL COMMENT STRUC" + | E_internal_let _ -> "INTERNAL LET" + | E_internal_return _ -> "INTERNAL RETURN" + | E_internal_plet _ -> "INTERNAL PLET" + | _ -> "INTERNAL" +and string_of_fexp (FE_aux (FE_Fexp (field, exp), _)) = + string_of_id field ^ " = " ^ string_of_exp exp +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_var (pat, kid) -> string_of_pat pat ^ " as " ^ string_of_kid kid + | 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 ^ "||]" + | P_vector_concat pats -> string_of_list " : " string_of_pat pats + | P_vector pats -> "[" ^ string_of_list ", " string_of_pat pats ^ "]" + | P_as (pat, id) -> string_of_pat pat ^ " as " ^ string_of_id id + | _ -> "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_vector_range (lexp, exp1, exp2) -> + string_of_lexp lexp ^ "[" ^ string_of_exp exp1 ^ ".." ^ string_of_exp exp2 ^ "]" + | 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 (pat, exp) -> 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_big_int n + | BF_range (n, m) -> string_of_big_int n ^ " .. " ^ string_of_big_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 BE = struct + type t = base_effect + let compare be1 be2 = String.compare (string_of_base_effect be1) (string_of_base_effect be2) +end + +module BESet = Set.Make(BE) + +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 lexp_to_exp (LEXP_aux (lexp_aux, annot) as le) = + let rewrap e_aux = E_aux (e_aux, annot) in + match lexp_aux with + | LEXP_id id | LEXP_cast (_, id) -> rewrap (E_id id) + | LEXP_tup les -> + let get_id (LEXP_aux(lexp,((l,_) as annot)) as le) = match lexp with + | LEXP_id id | LEXP_cast (_, id) -> E_aux (E_id id, annot) + | _ -> + raise (Reporting_basic.err_unreachable l + ("Unsupported sub-lexp " ^ string_of_lexp le ^ " in tuple")) in + rewrap (E_tuple (List.map get_id les)) + | LEXP_vector (lexp, e) -> rewrap (E_vector_access (lexp_to_exp lexp, e)) + | LEXP_vector_range (lexp, e1, e2) -> rewrap (E_vector_subrange (lexp_to_exp lexp, e1, e2)) + | LEXP_field (lexp, id) -> rewrap (E_field (lexp_to_exp lexp, id)) + | LEXP_memory (id, exps) -> rewrap (E_app (id, exps)) + +let rec is_number (Typ_aux (t,_)) = + match t with + | Typ_id (Id_aux (Id "int", _)) + | Typ_id (Id_aux (Id "nat", _)) + | Typ_app (Id_aux (Id "range", _),_) + | Typ_app (Id_aux (Id "implicit", _),_) + | Typ_app (Id_aux (Id "atom", _),_) -> true + | _ -> false + +let is_reftyp (Typ_aux (typ_aux, _)) = match typ_aux with + | Typ_app (id, _) -> string_of_id id = "register" || string_of_id id = "reg" + | _ -> 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) as typ -> + raise (Reporting_basic.err_typ l + ("typ_app_args_of called on non-app type " ^ string_of_typ typ)) + +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], _) -> + (nexp_simp start, nexp_simp 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 " ^ string_of_typ typ)) + +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") + +let effect_set (Effect_aux (eff,_)) = match eff with + | Effect_set effs -> BESet.of_list effs + +(* Utilities for constructing effect sets *) + +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 *) + +let rec tyvars_of_nexp (Nexp_aux (nexp,_)) = + match nexp with + | Nexp_id _ + | Nexp_constant _ -> KidSet.empty + | Nexp_var kid -> KidSet.singleton kid + | Nexp_times (n1,n2) + | Nexp_sum (n1,n2) + | Nexp_minus (n1,n2) -> KidSet.union (tyvars_of_nexp n1) (tyvars_of_nexp n2) + | Nexp_exp n + | Nexp_neg n -> tyvars_of_nexp n + +let rec tyvars_of_typ (Typ_aux (t,_)) = + match t with + | Typ_id _ -> KidSet.empty + | Typ_var kid -> KidSet.singleton kid + | Typ_fn (t1,t2,_) -> KidSet.union (tyvars_of_typ t1) (tyvars_of_typ t2) + | Typ_tup ts -> + List.fold_left (fun s t -> KidSet.union s (tyvars_of_typ t)) + KidSet.empty ts + | Typ_app (_,tas) -> + List.fold_left (fun s ta -> KidSet.union s (tyvars_of_typ_arg ta)) + KidSet.empty tas + | Typ_exist (kids,_,t) -> + let s = tyvars_of_typ t in + List.fold_left (fun s k -> KidSet.remove k s) s kids +and tyvars_of_typ_arg (Typ_arg_aux (ta,_)) = + match ta with + | Typ_arg_nexp nexp -> tyvars_of_nexp nexp + | Typ_arg_typ typ -> tyvars_of_typ typ + | Typ_arg_order _ -> KidSet.empty + +let rec undefined_of_typ mwords l annot (Typ_aux (typ_aux, _) as typ) = + let wrap e_aux typ = E_aux (e_aux, (l, annot typ)) in + match typ_aux with + | Typ_id id -> + wrap (E_app (prepend_id "undefined_" id, [wrap (E_lit (mk_lit L_unit)) unit_typ])) typ + | Typ_app (_,[start;size;_;_]) when mwords && is_bitvector_typ typ -> + wrap (E_app (mk_id "undefined_bitvector", + undefined_of_typ_args mwords l annot start @ + undefined_of_typ_args mwords l annot size)) typ + | Typ_app (id, args) -> + wrap (E_app (prepend_id "undefined_" id, + List.concat (List.map (undefined_of_typ_args mwords l annot) args))) typ + | Typ_var kid -> + (* Undefined monomorphism restriction in the type checker should + guarantee that the typ_(kid) parameter was always one created + in an undefined_(type) function created in + initial_check.ml. i.e. the rewriter should only encounter this + case when re-writing those functions. *) + wrap (E_id (prepend_id "typ_" (id_of_kid kid))) typ + | Typ_fn _ -> assert false +and undefined_of_typ_args mwords l annot (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = + match typ_arg_aux with + | Typ_arg_nexp n -> [E_aux (E_sizeof n, (l, annot (atom_typ n)))] + | Typ_arg_typ typ -> [undefined_of_typ mwords l annot typ] + | Typ_arg_order _ -> [] diff --git a/src/ast_util.mli b/src/ast_util.mli new file mode 100644 index 00000000..8206637c --- /dev/null +++ b/src/ast_util.mli @@ -0,0 +1,266 @@ +(**************************************************************************) +(* 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 Big_int + +val no_annot : unit annot +val gen_loc : Parse_ast.l -> Parse_ast.l + +val mk_id : string -> id +val mk_kid : string -> kid +val mk_ord : order_aux -> order +val mk_nc : n_constraint_aux -> n_constraint +val mk_nexp : nexp_aux -> nexp +val mk_exp : unit exp_aux -> unit exp +val mk_pat : unit pat_aux -> unit pat +val mk_lexp : unit lexp_aux -> unit lexp +val mk_lit : lit_aux -> lit +val mk_lit_exp : lit_aux -> unit exp +val mk_funcl : id -> unit pat -> unit exp -> unit funcl +val mk_fundef : (unit funcl) list -> unit def +val mk_val_spec : val_spec_aux -> unit def +val mk_typschm : typquant -> typ -> typschm +val mk_typquant : quant_item list -> typquant +val mk_qi_id : base_kind_aux -> kid -> quant_item +val mk_qi_nc : n_constraint -> quant_item +val mk_fexp : id -> unit exp -> unit fexp +val mk_fexps : (unit fexp) list -> unit fexps +val mk_letbind : unit pat -> unit exp -> unit letbind + +val unaux_exp : 'a exp -> 'a exp_aux +val unaux_pat : 'a pat -> 'a pat_aux +val unaux_nexp : nexp -> nexp_aux +val unaux_order : order -> order_aux +val unaux_typ : typ -> typ_aux + +val inc_ord : order +val dec_ord : order + +(* Utilites for working with kinded_ids *) +val kopt_kid : kinded_id -> kid +val is_nat_kopt : kinded_id -> bool +val is_order_kopt : kinded_id -> bool +val is_typ_kopt : kinded_id -> bool + +(* 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_typ : id -> typ + +(* 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 app_typ : id -> typ_arg list -> 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 exc_typ : typ +val tuple_typ : typ list -> typ +val function_typ : typ -> typ -> effect -> typ + +val no_effect : effect +val mk_effect : base_effect_aux list -> effect + +val nexp_simp : nexp -> nexp + +(* Utilities for building n-expressions *) +val nconstant : big_int -> nexp +val nint : 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 +val nid : id -> nexp (* NOTE: Nexp_id's don't do anything currently *) + +(* Numeric constraint builders *) +val nc_eq : nexp -> nexp -> n_constraint +val nc_neq : nexp -> nexp -> n_constraint +val nc_lteq : nexp -> nexp -> n_constraint +val nc_gteq : nexp -> nexp -> n_constraint +val nc_lt : nexp -> nexp -> n_constraint +val nc_gt : nexp -> nexp -> n_constraint +val nc_and : n_constraint -> n_constraint -> n_constraint +val nc_or : n_constraint -> n_constraint -> n_constraint +val nc_true : n_constraint +val nc_false : n_constraint +val nc_set : kid -> big_int list -> n_constraint +val nc_int_set : kid -> int list -> n_constraint + +(* Negate a n_constraint. Note that there's no NC_not constructor, so + this flips all the inequalites a the n_constraint leaves and uses + de-morgans to switch and to or and vice versa. *) +val nc_negate : n_constraint -> n_constraint + +val quant_items : typquant -> quant_item list +val quant_kopts : typquant -> kinded_id list +val quant_split : typquant -> kinded_id list * n_constraint list + +(* 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 + +val def_loc : 'a def -> Parse_ast.l + +(* For debugging and error messages only: Not guaranteed to produce + parseable SAIL, or even print all language constructs! *) +(* 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_annot : ('a * typ * effect) option -> 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 + +val id_of_kid : kid -> id +val kid_of_id : id -> kid + +val prepend_id : string -> id -> id +val prepend_kid : string -> kid -> kid + +module Id : sig + type t = id + val compare : id -> id -> int +end + +module Kid : sig + type t = kid + val compare : kid -> kid -> int +end + +module Nexp : sig + type t = nexp + val compare : nexp -> nexp -> int +end + +module BE : sig + type t = base_effect + val compare : base_effect -> base_effect -> int +end + +module IdSet : sig + include Set.S with type elt = id +end + +module NexpSet : sig + include Set.S with type elt = nexp +end + +module BESet : sig + include Set.S with type elt = base_effect +end + +module KidSet : sig + include Set.S with type elt = kid +end + +module KBindings : sig + include Map.S with type key = kid +end + +module Bindings : sig + include Map.S with type key = id +end + +val nexp_frees : nexp -> KidSet.t +val nexp_identical : nexp -> nexp -> bool +val is_nexp_constant : nexp -> bool + +val lexp_to_exp : 'a lexp -> 'a exp + +val is_number : typ -> bool +val is_reftyp : 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 + +val effect_set : effect -> BESet.t + +val equal_effects : effect -> effect -> bool +val union_effects : effect -> effect -> effect + +val tyvars_of_nexp : nexp -> KidSet.t +val tyvars_of_typ : typ -> KidSet.t + +val undefined_of_typ : bool -> Ast.l -> (typ -> 'annot) -> typ -> 'annot exp diff --git a/src/constraint.ml b/src/constraint.ml new file mode 100644 index 00000000..37073ff2 --- /dev/null +++ b/src/constraint.ml @@ -0,0 +1,258 @@ +open Big_int +open Util + +(* ===== Integer Constraints ===== *) + +type nexp_op = string + +type nexp = + | NFun of (nexp_op * nexp list) + | N2n of nexp + | NConstant of big_int + | NVar of int + +let big_int_op : nexp_op -> (big_int -> big_int -> big_int) option = function + | "+" -> Some add_big_int + | "-" -> Some sub_big_int + | "*" -> Some mult_big_int + | _ -> None + +let rec arith constr = + let constr' = match constr with + | NFun (op, [x; y]) -> NFun (op, [arith x; arith y]) + | N2n c -> N2n (arith c) + | c -> c + in + match constr' with + | NFun (op, [NConstant x; NConstant y]) as c -> + begin + match big_int_op op with + | Some op -> NConstant (op x y) + | None -> c + end + | 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) + | Forall of (int list * 'a constraint_bool) + | 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 + +(* Get a set of variables from a constraint *) +module IntSet = Set.Make( + struct + let compare = Pervasives.compare + type t = int + end) + +let rec nexp_vars : nexp -> IntSet.t = function + | NConstant _ -> IntSet.empty + | NVar v -> IntSet.singleton v + | NFun (_, xs) -> List.fold_left IntSet.union IntSet.empty (List.map nexp_vars xs) + | N2n x -> nexp_vars x + +let rec constraint_vars : nexp constraint_bool -> IntSet.t = function + | BFun (_, x, y) -> IntSet.union (constraint_vars x) (constraint_vars y) + | Not x -> constraint_vars x + | CFun (_, x, y) -> IntSet.union (nexp_vars x) (nexp_vars y) + | Forall (vars, x) -> IntSet.diff (constraint_vars x) (IntSet.of_list vars) + | Boolean _ -> 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 rec sexpr_of_nexp = function + | NFun (op, xs) -> sfun op (List.map sexpr_of_nexp xs) + | 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_constraint = function + | BFun (And, x, y) -> sfun "and" [sexpr_of_constraint x; sexpr_of_constraint y] + | BFun (Or, x, y) -> sfun "or" [sexpr_of_constraint x; sexpr_of_constraint y] + | Not x -> sfun "not" [sexpr_of_constraint x] + | CFun (op, x, y) -> cop_sexpr op (sexpr_of_nexp (arith x)) (sexpr_of_nexp (arith y)) + | Forall (vars, x) -> + sfun "forall" [List (List.map (fun v -> List [Atom ("v" ^ string_of_int v); Atom "Int"]) vars); sexpr_of_constraint x] + | Boolean true -> Atom "true" + | Boolean false -> Atom "false" + +let smtlib_of_constraints 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 | Sat | Unsat + +module DigestMap = Map.Make(Digest) + +let known_problems = ref (DigestMap.empty) + +let load_digests_err () = + let in_chan = open_in_bin "z3_problems" in + let rec load () = + let digest = Digest.input in_chan in + let result = input_byte in_chan in + begin + match result with + | 0 -> known_problems := DigestMap.add digest Unknown !known_problems + | 1 -> known_problems := DigestMap.add digest Sat !known_problems + | 2 -> known_problems := DigestMap.add digest Unsat !known_problems + | _ -> assert false + end; + load () + in + try load () with + | End_of_file -> close_in in_chan + +let load_digests () = + try load_digests_err () with + | Sys_error _ -> () + +let save_digests () = + let out_chan = open_out_bin "z3_problems" in + let output digest result = + Digest.output out_chan digest; + match result with + | Unknown -> output_byte out_chan 0 + | Sat -> output_byte out_chan 1 + | Unsat -> output_byte out_chan 2 + in + DigestMap.iter output !known_problems; + close_out out_chan + +let rec call_z3 constraints : smt_result = + let problems = [constraints] in + let z3_file = smtlib_of_constraints constraints 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 + + let digest = Digest.string z3_file in + try + let result = DigestMap.find digest !known_problems in + result + with + | Not_found -> + 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 + known_problems := DigestMap.add digest Unsat !known_problems; + Unsat + with + | Not_found -> + let unsolved = List.filter (fun (_, result) -> result = "unknown") z3_output in + if unsolved == [] + then (known_problems := DigestMap.add digest Sat !known_problems; Sat) + else (known_problems := DigestMap.add digest Unknown !known_problems; Unknown) + end + +let string_of = smtlib_of_constraints + +(* ===== 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 forall (vars : int list) (x : t) : t = Forall (vars, x) + +let negate (x : t) : t = Not x + +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 ("+", [x; y]) + +let sub x y : nexp = NFun ("-", [x; y]) + +let mult x y : nexp = NFun ("*", [x; y]) + +let app f xs : nexp = NFun (f, xs) + +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..33881fcf --- /dev/null +++ b/src/constraint.mli @@ -0,0 +1,34 @@ +type nexp +type t + +type smt_result = Unknown | Sat | Unsat + +val load_digests : unit -> unit +val save_digests : unit -> unit + +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 literal : bool -> t +val forall : int list -> t -> 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 app : string -> nexp list -> 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..8ef9dd9b 100644 --- a/src/gen_lib/prompt.lem +++ b/src/gen_lib/prompt.lem @@ -2,10 +2,13 @@ open import Pervasives_extra open import Sail_impl_base open import Sail_values -val return : forall 'a. 'a -> outcome 'a +type MR 'a 'r = outcome_r 'a 'r +type M 'a = outcome 'a + +val return : forall 'a 'r. 'a -> MR 'a 'r let return a = Done a -val bind : forall 'a 'b. outcome 'a -> ('a -> outcome 'b) -> outcome 'b +val bind : forall 'a 'b 'r. MR 'a 'r -> ('a -> MR 'b 'r) -> MR 'b 'r let rec bind m f = match m with | Done a -> f a | Read_mem descr k -> Read_mem descr (fun v -> let (o,opt) = k v in (bind o f,opt)) @@ -19,25 +22,66 @@ let rec bind m f = match m with | Escape descr -> Escape descr | Fail descr -> Fail descr | Error descr -> Error descr + | Return a -> Return a | Internal descr o_s -> Internal descr (let (o,opt) = o_s in (bind o f ,opt)) end -type M 'a = outcome 'a - let inline (>>=) = bind -val (>>) : forall 'b. M unit -> M 'b -> M 'b +val (>>) : forall 'b 'r. MR unit 'r -> MR 'b 'r -> MR 'b 'r let inline (>>) m n = m >>= fun _ -> n val exit : forall 'a 'b. 'b -> M 'a let exit s = Fail Nothing -val read_mem : bool -> read_kind -> vector bitU -> integer -> M (vector bitU) +val assert_exp : bool -> string -> M unit +let assert_exp exp msg = if exp then Done () else Fail (Just msg) + +val early_return : forall 'r. 'r -> MR unit 'r +let early_return r = Return r + +val liftR : forall 'a 'r. M 'a -> MR 'a 'r +let rec liftR m = match m with + | Done a -> Done a + | Read_mem descr k -> Read_mem descr (fun v -> let (o,opt) = k v in (liftR o,opt)) + | Read_reg descr k -> Read_reg descr (fun v -> let (o,opt) = k v in (liftR o,opt)) + | Write_memv descr k -> Write_memv descr (fun v -> let (o,opt) = k v in (liftR o,opt)) + | Excl_res k -> Excl_res (fun v -> let (o,opt) = k v in (liftR o,opt)) + | Write_ea descr o_s -> Write_ea descr (let (o,opt) = o_s in (liftR o,opt)) + | Barrier descr o_s -> Barrier descr (let (o,opt) = o_s in (liftR o,opt)) + | Footprint o_s -> Footprint (let (o,opt) = o_s in (liftR o,opt)) + | Write_reg descr o_s -> Write_reg descr (let (o,opt) = o_s in (liftR o,opt)) + | Internal descr o_s -> Internal descr (let (o,opt) = o_s in (liftR o,opt)) + | Escape descr -> Escape descr + | Fail descr -> Fail descr + | Error descr -> Error descr + | Return _ -> Error "uncaught early return" +end + +val catch_early_return : forall 'a 'r. MR 'a 'a -> M 'a +let rec catch_early_return m = match m with + | Done a -> Done a + | Read_mem descr k -> Read_mem descr (fun v -> let (o,opt) = k v in (catch_early_return o,opt)) + | Read_reg descr k -> Read_reg descr (fun v -> let (o,opt) = k v in (catch_early_return o,opt)) + | Write_memv descr k -> Write_memv descr (fun v -> let (o,opt) = k v in (catch_early_return o,opt)) + | Excl_res k -> Excl_res (fun v -> let (o,opt) = k v in (catch_early_return o,opt)) + | Write_ea descr o_s -> Write_ea descr (let (o,opt) = o_s in (catch_early_return o,opt)) + | Barrier descr o_s -> Barrier descr (let (o,opt) = o_s in (catch_early_return o,opt)) + | Footprint o_s -> Footprint (let (o,opt) = o_s in (catch_early_return o,opt)) + | Write_reg descr o_s -> Write_reg descr (let (o,opt) = o_s in (catch_early_return o,opt)) + | Internal descr o_s -> Internal descr (let (o,opt) = o_s in (catch_early_return o,opt)) + | Escape descr -> Escape descr + | Fail descr -> Fail descr + | Error descr -> Error descr + | Return a -> Done a +end + +val read_mem : forall 'a 'b. Bitvector 'a, Bitvector 'b => bool -> read_kind -> 'a -> integer -> M 'b let read_mem dir rk addr sz = - let addr = address_lifted_of_bitv addr in + let addr = address_lifted_of_bitv (bits_of addr) in let sz = natFromInteger sz in let k memory_value = - let bitv = internal_mem_value dir memory_value in + let bitv = of_bits (internal_mem_value dir memory_value) in (Done bitv,Nothing) in Read_mem (rk,addr,sz) k @@ -46,22 +90,22 @@ let excl_result () = let k successful = (return successful,Nothing) in Excl_res k -val write_mem_ea : write_kind -> vector bitU -> integer -> M unit +val write_mem_ea : forall 'a. Bitvector 'a => write_kind -> 'a -> integer -> M unit let write_mem_ea wk addr sz = - let addr = address_lifted_of_bitv addr in + let addr = address_lifted_of_bitv (bits_of addr) in let sz = natFromInteger sz in Write_ea (wk,addr,sz) (Done (),Nothing) -val write_mem_val : vector bitU -> M bool +val write_mem_val : forall 'a. Bitvector 'a => 'a -> M bool let write_mem_val v = - let v = external_mem_value v in + let v = external_mem_value (bits_of v) in let k successful = (return successful,Nothing) in Write_memv v k -val read_reg_aux : reg_name -> M (vector bitU) +val read_reg_aux : forall 'a. Bitvector 'a => reg_name -> M 'a let read_reg_aux reg = let k reg_value = - let v = internal_reg_value reg_value in + let v = of_bits (internal_reg_value reg_value) in (Done v,Nothing) in Read_reg reg k @@ -71,32 +115,38 @@ 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) + read_reg_aux (external_reg_field_whole reg regfield.field_name) let read_reg_bitfield reg regfield = - read_reg_aux (external_reg_field_whole reg regfield) >>= fun v -> - return (extract_only_bit v) + read_reg_aux (external_reg_field_whole reg regfield.field_name) >>= fun v -> + return (extract_only_element v) + +let reg_deref = read_reg -val write_reg_aux : reg_name -> vector bitU -> M unit +val write_reg_aux : forall 'a. Bitvector 'a => reg_name -> 'a -> M unit let write_reg_aux reg_name v = - let regval = external_reg_value reg_name v in + let regval = external_reg_value reg_name (bits_of v) in Write_reg (reg_name,regval) (Done (), Nothing) let write_reg reg v = write_reg_aux (external_reg_whole reg) v let write_reg_range reg i j v = write_reg_aux (external_reg_slice reg (natFromInteger i,natFromInteger j)) v -let write_reg_bit reg i bit = +let write_reg_pos reg i v = let iN = natFromInteger i in - write_reg_aux (external_reg_slice reg (iN,iN)) (Vector [bit] i (is_inc_of_reg reg)) + write_reg_aux (external_reg_slice reg (iN,iN)) [v] +let write_reg_bit = write_reg_pos let write_reg_field reg regfield v = - write_reg_aux (external_reg_field_whole reg regfield) v -let write_reg_bitfield reg regfield bit = - write_reg_aux (external_reg_field_whole reg regfield) - (Vector [bit] 0 (is_inc_of_reg reg)) + write_reg_aux (external_reg_field_whole reg regfield.field_name) v +(*let write_reg_field_bit reg regfield bit = + write_reg_aux (external_reg_field_whole reg regfield.field_name) + (Vector [bit] 0 (is_inc_of_reg reg))*) let write_reg_field_range reg regfield i j v = - write_reg_aux (external_reg_field_slice reg regfield (natFromInteger i,natFromInteger j)) v + write_reg_aux (external_reg_field_slice reg regfield.field_name (natFromInteger i,natFromInteger j)) v +let write_reg_field_pos reg regfield i v = + write_reg_field_range reg regfield i i [v] +let write_reg_field_bit = write_reg_field_pos @@ -108,26 +158,76 @@ val footprint : M unit let footprint = Footprint (Done (),Nothing) -val foreachM_inc : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> M 'vars) -> M 'vars +val foreachM_inc : forall 'vars 'r. (integer * integer * integer) -> 'vars -> + (integer -> 'vars -> MR 'vars 'r) -> MR 'vars 'r let rec foreachM_inc (i,stop,by) vars body = - if i <= stop + if (by > 0 && i <= stop) || (by < 0 && stop <= i) then body i vars >>= fun vars -> foreachM_inc (i + by,stop,by) vars body else return vars -val foreachM_dec : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> M 'vars) -> M 'vars -let rec foreachM_dec (i,stop,by) vars body = - if i >= stop +val foreachM_dec : forall 'vars 'r. (integer * integer * integer) -> 'vars -> + (integer -> 'vars -> MR 'vars 'r) -> MR 'vars 'r +let rec foreachM_dec (stop,i,by) vars body = + if (by > 0 && i >= stop) || (by < 0 && stop >= i) then body i vars >>= fun vars -> - foreachM_dec (i - by,stop,by) vars body + foreachM_dec (stop,i - by,by) vars body + else return vars + +val while_PP : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars +let rec while_PP vars cond body = + if cond vars then while_PP (body vars) cond body else vars + +val while_PM : forall 'vars 'r. 'vars -> ('vars -> bool) -> + ('vars -> MR 'vars 'r) -> MR 'vars 'r +let rec while_PM vars cond body = + if cond vars then + body vars >>= fun vars -> while_PM vars cond body + else return vars + +val while_MP : forall 'vars 'r. 'vars -> ('vars -> MR bool 'r) -> + ('vars -> 'vars) -> MR 'vars 'r +let rec while_MP vars cond body = + cond vars >>= fun cond_val -> + if cond_val then while_MP (body vars) cond body else return vars + +val while_MM : forall 'vars 'r. 'vars -> ('vars -> MR bool 'r) -> + ('vars -> MR 'vars 'r) -> MR 'vars 'r +let rec while_MM vars cond body = + cond vars >>= fun cond_val -> + if cond_val then + body vars >>= fun vars -> while_MM vars cond body else return vars -let write_two_regs r1 r2 vec = +val until_PP : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars +let rec until_PP vars cond body = + let vars = body vars in + if (cond vars) then vars else until_PP (body vars) cond body + +val until_PM : forall 'vars 'r. 'vars -> ('vars -> bool) -> + ('vars -> MR 'vars 'r) -> MR 'vars 'r +let rec until_PM vars cond body = + body vars >>= fun vars -> + if (cond vars) then return vars else until_PM vars cond body + +val until_MP : forall 'vars 'r. 'vars -> ('vars -> MR bool 'r) -> + ('vars -> 'vars) -> MR 'vars 'r +let rec until_MP vars cond body = + let vars = body vars in + cond vars >>= fun cond_val -> + if cond_val then return vars else until_MP vars cond body + +val until_MM : forall 'vars 'r. 'vars -> ('vars -> MR bool 'r) -> + ('vars -> MR 'vars 'r) -> MR 'vars 'r +let rec until_MM vars cond body = + body vars >>= fun vars -> + cond vars >>= fun cond_val -> + if cond_val then return vars else until_MM vars cond body + +(*let write_two_regs r1 r2 vec = let is_inc = let is_inc_r1 = is_inc_of_reg r1 in let is_inc_r2 = is_inc_of_reg r2 in @@ -146,4 +246,4 @@ 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 + write_reg r1 r1_v >> write_reg r2 r2_v*) diff --git a/src/gen_lib/sail_operators.lem b/src/gen_lib/sail_operators.lem new file mode 100644 index 00000000..826ea98f --- /dev/null +++ b/src/gen_lib/sail_operators.lem @@ -0,0 +1,495 @@ +open import Pervasives_extra +open import Machine_word +open import Sail_impl_base +open import Sail_values + +(*** Bit vector operations *) + +let bitvector_length = length + +let set_bitvector_start = set_vector_start +let reset_bitvector_start = reset_vector_start + +let set_bitvector_start_to_length = set_vector_start_to_length + +let bitvector_concat = vector_concat +let inline (^^^) = bitvector_concat + +let bitvector_subrange_inc = vector_subrange_inc +let bitvector_subrange_dec = vector_subrange_dec + +let vector_subrange_bl (start, v, i, j) = + let v' = slice v i j in + get_elems v' +let vector_subrange_bl_dec = vector_subrange_bl + +let bitvector_access_inc = vector_access_inc +let bitvector_access_dec = vector_access_dec +let bitvector_update_pos_inc = vector_update_pos_inc +let bitvector_update_pos_dec = vector_update_pos_dec +let bitvector_update_subrange_inc = vector_update_subrange_inc +let bitvector_update_subrange_dec = vector_update_subrange_dec + +let extract_only_bit = extract_only_element + +let norm_dec = reset_vector_start +let adjust_start_index (start, v) = set_vector_start (start, v) + +let cast_vec_bool v = bitU_to_bool (extract_only_element v) +let cast_bit_vec_basic (start, len, b) = Vector (repeat [b] len) start false +let cast_boolvec_bitvec (Vector bs start inc) = + Vector (List.map bool_to_bitU bs) start inc +let cast_vec_bl (Vector bs start inc) = bs + +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 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_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 hardware_mod (a: integer) (b:integer) : integer = + if a < 0 && b < 0 + then (abs a) mod (abs b) + else if (a < 0 && b >= 0) + then (a mod b) - b + else a mod b + +(* There are different possible answers for integer divide regarding +rounding behaviour on negative operands. Positive operands always +round down so derive the one we want (trucation towards zero) from +that *) +let hardware_quot (a:integer) (b:integer) : integer = + let q = (abs a) / (abs b) in + if ((a<0) = (b<0)) then + q (* same sign -- result positive *) + else + ~q (* different sign -- result negative *) + +let quot_signed = hardware_quot + + +let signed_big = signed + +let to_num sign = if sign then signed else unsigned + +let max_64u = (integerPow 2 64) - 1 +let max_64 = (integerPow 2 63) - 1 +let min_64 = 0 - (integerPow 2 63) +let max_32u = (4294967295 : integer) +let max_32 = (2147483647 : integer) +let min_32 = (0 - 2147483648 : integer) +let max_8 = (127 : integer) +let min_8 = (0 - 128 : integer) +let max_5 = (31 : integer) +let min_5 = (0 - 32 : integer) + +let get_max_representable_in sign (n : integer) : integer = + if (n = 64) then match sign with | true -> max_64 | false -> max_64u end + else if (n=32) then match sign with | true -> max_32 | false -> max_32u end + else if (n=8) then max_8 + else if (n=5) then max_5 + else match sign with | true -> integerPow 2 ((natFromInteger n) -1) + | false -> integerPow 2 (natFromInteger n) + end + +let get_min_representable_in _ (n : integer) : integer = + if n = 64 then min_64 + else if n = 32 then min_32 + else if n = 8 then min_8 + else if n = 5 then min_5 + else 0 - (integerPow 2 (natFromInteger n)) + +let to_norm_vec is_inc ((len : integer),(n : integer)) = + let start = if is_inc then 0 else len - 1 in + Vector (bits_of_int (len, n)) start is_inc + +let to_vec_big = to_norm_vec + +let to_vec_inc (start, len, n) = set_vector_start (start, to_norm_vec true (len, n)) +let to_vec_norm_inc (len, n) = to_norm_vec true (len, n) +let to_vec_dec (start, len, n) = set_vector_start (start, to_norm_vec false (len, n)) +let to_vec_norm_dec (len, n) = to_norm_vec false (len, n) + +let cast_0_vec = to_vec_dec +let cast_1_vec = to_vec_dec +let cast_01_vec = to_vec_dec + +let to_vec_undef is_inc (len : integer) = + Vector (replicate (natFromInteger len) BU) (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 (start, len, vec) = set_vector_start (start, to_norm_vec (get_dir vec) (len,signed vec)) +let extz (start, len, vec) = set_vector_start (start, to_norm_vec (get_dir vec) (len,unsigned vec)) + +let exts_big (start, len, vec) = set_vector_start (start, to_vec_big (get_dir vec) (len, signed_big vec)) +let extz_big (start, len, vec) = set_vector_start (start, to_vec_big (get_dir vec) (len, unsigned_big vec)) + +(* TODO *) +let extz_bl (start, len, bits) = Vector bits start false +let exts_bl (start, len, bits) = Vector bits start false + + +let quot = hardware_quot +let modulo (l,r) = hardware_mod l r + +let arith_op_vec op sign (size : integer) (Vector _ _ is_inc as l) r = + let (l',r') = (to_num sign l, to_num sign r) in + let n = op l' r' in + to_norm_vec is_inc (size * (length l),n) + + +(* add_vec + * add_vec_signed + * minus_vec + * multiply_vec + * multiply_vec_signed + *) +let add_VVV = arith_op_vec integerAdd false 1 +let addS_VVV = arith_op_vec integerAdd true 1 +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 mult_vec (l, r) = mult_VVV l r +let mult_svec (l, r) = multS_VVV l r + +let add_vec (l, r) = add_VVV l r +let sub_vec (l, r) = minus_VVV l r + +let arith_op_vec_range op sign size (Vector _ _ is_inc as l) r = + arith_op_vec op sign size l (to_norm_vec is_inc (length l,r)) + +(* add_vec_range + * add_vec_range_signed + * minus_vec_range + * mult_vec_range + * mult_vec_range_signed + *) +let add_VIV = arith_op_vec_range integerAdd false 1 +let addS_VIV = arith_op_vec_range integerAdd true 1 +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 add_vec_int (l, r) = add_VIV l r +let sub_vec_int (l, r) = minus_VIV l r + +let arith_op_range_vec op sign size l (Vector _ _ is_inc as r) = + arith_op_vec op sign size (to_norm_vec is_inc (length r, l)) r + +(* add_range_vec + * add_range_vec_signed + * minus_range_vec + * mult_range_vec + * mult_range_vec_signed + *) +let add_IVV = arith_op_range_vec integerAdd false 1 +let addS_IVV = arith_op_range_vec integerAdd true 1 +let minus_IVV = arith_op_range_vec integerMinus false 1 +let mult_IVV = arith_op_range_vec integerMult false 2 +let multS_IVV = arith_op_range_vec integerMult true 2 + +let arith_op_range_vec_range op sign l r = op l (to_num sign r) + +(* add_range_vec_range + * add_range_vec_range_signed + * minus_range_vec_range + *) +let add_IVI = arith_op_range_vec_range integerAdd false +let addS_IVI = arith_op_range_vec_range integerAdd true +let minus_IVI = arith_op_range_vec_range integerMinus false + +let arith_op_vec_range_range op sign l r = op (to_num sign l) r + +(* add_vec_range_range + * add_vec_range_range_signed + * minus_vec_range_range + *) +let add_VII = arith_op_vec_range_range integerAdd false +let addS_VII = arith_op_vec_range_range integerAdd true +let minus_VII = arith_op_vec_range_range integerMinus false + + + +let arith_op_vec_vec_range op sign l r = + let (l',r') = (to_num sign l,to_num sign r) in + op l' r' + +(* add_vec_vec_range + * add_vec_vec_range_signed + *) +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 l' = to_num sign l in + let n = op l' (match r with | B1 -> (1 : integer) | _ -> 0 end) in + to_norm_vec is_inc (length l * size,n) + +(* add_vec_bit + * add_vec_bit_signed + * minus_vec_bit_signed + *) +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 + 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 + let n = op l_sign r_sign in + let n_unsign = op l_unsign r_unsign in + let correct_size_num = to_norm_vec is_inc (act_size,n) in + let one_more_size_u = to_norm_vec is_inc (act_size + 1,n_unsign) in + let overflow = + if n <= get_max_representable_in sign len && + n >= get_min_representable_in sign len + then B0 else B1 in + let c_out = most_significant one_more_size_u in + (correct_size_num,overflow,c_out) + +(* add_overflow_vec + * add_overflow_vec_signed + * minus_overflow_vec + * minus_overflow_vec_signed + * mult_overflow_vec + * mult_overflow_vec_signed + *) +let addO_VVV = arith_op_overflow_vec integerAdd false 1 +let addSO_VVV = arith_op_overflow_vec integerAdd true 1 +let minusO_VVV = arith_op_overflow_vec integerMinus false 1 +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 + +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 + let l' = to_num sign l in + let l_u = to_num false l in + let (n,nu,changed) = match r_bit with + | B1 -> (op l' 1, op l_u 1, true) + | B0 -> (l',l_u,false) + | BU -> failwith "arith_op_overflow_vec_bit applied to undefined bit" + end in +(* | _ -> assert false *) + let correct_size_num = to_norm_vec is_inc (act_size,n) in + let one_larger = to_norm_vec is_inc (act_size + 1,nu) in + let overflow = + if changed + then + if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size + then B0 else B1 + else B0 in + (correct_size_num,overflow,most_significant one_larger) + +(* add_overflow_vec_bit_signed + * minus_overflow_vec_bit + * minus_overflow_vec_bit_signed + *) +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 n = natFromInteger n in + match op with + | LL_shift (*"<<"*) -> + Vector (sublist bs (n,List.length bs -1) ++ List.replicate n B0) start is_inc + | RR_shift (*">>"*) -> + Vector (List.replicate n B0 ++ sublist bs (0,n-1)) start is_inc + | LLL_shift (*"<<<"*) -> + Vector (sublist bs (n,List.length bs - 1) ++ sublist bs (0,n-1)) start is_inc + end + +let bitwise_leftshift = shift_op_vec LL_shift (*"<<"*) +let bitwise_rightshift = shift_op_vec RR_shift (*">>"*) +let bitwise_rotate = shift_op_vec LLL_shift (*"<<<"*) + +let shiftl = bitwise_leftshift + +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 + let (l',r') = (to_num sign l,to_num sign r) in + let n = arith_op_no0 op l' r' in + let (representable,n') = + match n with + | Just n' -> + (n' <= get_max_representable_in sign act_size && + n' >= get_min_representable_in sign act_size, n') + | _ -> (false,0) + end in + if representable + then to_norm_vec is_inc (act_size,n') + else Vector (List.replicate (natFromInteger act_size) BU) start is_inc + +let mod_VVV = arith_op_vec_no0 hardware_mod false 1 +let quot_VVV = arith_op_vec_no0 hardware_quot false 1 +let quotS_VVV = arith_op_vec_no0 hardware_quot true 1 + +let arith_op_overflow_no0_vec op sign size ((Vector _ start is_inc) as l) r = + let rep_size = length r * size in + let act_size = length l * size in + let (l',r') = (to_num sign l,to_num sign r) in + let (l_u,r_u) = (to_num false l,to_num false r) in + let n = arith_op_no0 op l' r' in + let n_u = arith_op_no0 op l_u r_u in + let (representable,n',n_u') = + match (n, n_u) with + | (Just n',Just n_u') -> + ((n' <= get_max_representable_in sign rep_size && + n' >= (get_min_representable_in sign rep_size)), n', n_u') + | _ -> (true,0,0) + end in + let (correct_size_num,one_more) = + if representable then + (to_norm_vec is_inc (act_size,n'),to_norm_vec is_inc (act_size + 1,n_u')) + else + (Vector (List.replicate (natFromInteger act_size) BU) start is_inc, + Vector (List.replicate (natFromInteger (act_size + 1)) BU) start is_inc) in + let overflow = if representable then B0 else B1 in + (correct_size_num,overflow,most_significant one_more) + +let quotO_VVV = arith_op_overflow_no0_vec hardware_quot false 1 +let quotSO_VVV = arith_op_overflow_no0_vec hardware_quot true 1 + +let arith_op_vec_range_no0 op sign size (Vector _ _ is_inc as l) r = + arith_op_vec_no0 op sign size l (to_norm_vec is_inc (length l,r)) + +let mod_VIV = arith_op_vec_range_no0 hardware_mod false 1 + +(* Assumes decreasing bit vectors *) +let duplicate (bit, length) = + Vector (repeat [bit] length) (length - 1) false + +let replicate_bits (v, count) = + Vector (repeat (get_elems v) count) ((length v * count) - 1) false + +let compare_op op (l,r) = (op l r) + +let lt = compare_op (<) +let gt = compare_op (>) +let lteq = compare_op (<=) +let gteq = compare_op (>=) + +let compare_op_vec op sign (l,r) = + let (l',r') = (to_num sign l, to_num sign r) in + compare_op op (l',r') + +let lt_vec = compare_op_vec (<) true +let gt_vec = compare_op_vec (>) true +let lteq_vec = compare_op_vec (<=) true +let gteq_vec = compare_op_vec (>=) true + +let lt_vec_signed = compare_op_vec (<) true +let gt_vec_signed = compare_op_vec (>) true +let lteq_vec_signed = compare_op_vec (<=) true +let gteq_vec_signed = compare_op_vec (>=) true +let lt_vec_unsigned = compare_op_vec (<) false +let gt_vec_unsigned = compare_op_vec (>) false +let lteq_vec_unsigned = compare_op_vec (<=) false +let gteq_vec_unsigned = compare_op_vec (>=) false + +let lt_svec = lt_vec_signed + +let compare_op_vec_range op sign (l,r) = + compare_op op ((to_num sign l),r) + +let lt_vec_range = compare_op_vec_range (<) true +let gt_vec_range = compare_op_vec_range (>) true +let lteq_vec_range = compare_op_vec_range (<=) true +let gteq_vec_range = compare_op_vec_range (>=) true + +let compare_op_range_vec op sign (l,r) = + compare_op op (l, (to_num sign r)) + +let lt_range_vec = compare_op_range_vec (<) true +let gt_range_vec = compare_op_range_vec (>) true +let lteq_range_vec = compare_op_range_vec (<=) true +let gteq_range_vec = compare_op_range_vec (>=) true + +val eq : forall 'a. Eq 'a => 'a * 'a -> bool +let eq (l,r) = (l = r) +let eq_range (l,r) = (l = r) + +val eq_vec : forall 'a. vector 'a * vector 'a -> bool +let eq_vec (l,r) = (l = r) +let eq_bit (l,r) = (l = r) +let eq_vec_range (l,r) = eq (to_num false l,r) +let eq_range_vec (l,r) = eq (l, to_num false r) +let eq_vec_vec (l,r) = eq (to_num true l, to_num true r) + +let neq (l,r) = not (eq (l,r)) +let neq_bit (l,r) = not (eq_bit (l,r)) +let neq_range (l,r) = not (eq_range (l,r)) +let neq_vec (l,r) = not (eq_vec (l,r)) +let neq_vec_vec (l,r) = not (eq_vec_vec (l,r)) +let neq_vec_range (l,r) = not (eq_vec_range (l,r)) +let neq_range_vec (l,r) = not (eq_range_vec (l,r)) + + +val make_indexed_vector : forall 'a. list (integer * 'a) -> 'a -> integer -> integer -> bool -> vector 'a +let make_indexed_vector entries default start length dir = + let length = natFromInteger length in + Vector (List.foldl replace (replicate length default) entries) start dir + +(* +val make_bit_vector_undef : integer -> vector bitU +let make_bitvector_undef length = + Vector (replicate (natFromInteger length) BU) 0 true + *) + +(* let bitwise_not_range_bit n = bitwise_not (to_vec defaultDir n) *) + +let mask (start, n, Vector bits _ dir) = + let current_size = List.length bits in + Vector (drop (current_size - (natFromInteger n)) bits) start dir + + +(* Register operations *) + +(*let update_reg_range i j reg_val new_val = update reg_val i j new_val +let update_reg_pos i reg_val bit = update_pos reg_val i bit +let update_reg_field_range regfield i j reg_val new_val = + let current_field_value = regfield.get_field reg_val in + let new_field_value = update current_field_value i j new_val in + regfield.set_field reg_val new_field_value +(*let write_reg_field_pos regfield i reg_val bit = + let current_field_value = regfield.get_field reg_val in + let new_field_value = update_pos current_field_value i bit in + regfield.set_field reg_val new_field_value*)*) diff --git a/src/gen_lib/sail_operators_mwords.lem b/src/gen_lib/sail_operators_mwords.lem new file mode 100644 index 00000000..74d0acf7 --- /dev/null +++ b/src/gen_lib/sail_operators_mwords.lem @@ -0,0 +1,601 @@ +open import Pervasives_extra +open import Machine_word +open import Sail_impl_base +open import Sail_values + +(* Translating between a type level number (itself 'n) and an integer *) + +let size_itself_int x = integerFromNat (size_itself x) + +(* NB: the corresponding sail type is forall 'n. atom('n) -> itself('n), + the actual integer is ignored. *) + +val make_the_value : forall 'n. integer -> itself 'n +let inline make_the_value x = the_value + +(*** Bit vector operations *) + +let bitvector_length bs = integerFromNat (word_length bs) + +(*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 bitvector_concat (bs, bs') = word_concat bs bs' + +let inline (^^^) = bitvector_concat + +val bvslice : forall 'a 'b. Size 'a => bool -> integer -> bitvector 'a -> integer -> integer -> bitvector 'b +let bvslice is_inc start bs i j = + let iN = natFromInteger i in + let jN = natFromInteger j in + let startN = natFromInteger start in + let top = word_length bs - 1 in + let (hi,lo) = if is_inc then (top+startN-iN,top+startN-jN) else (top-startN+iN,top-startN+jN) in + word_extract lo hi bs + +let bitvector_subrange_inc (start, v, i, j) = bvslice true start v i j +let bitvector_subrange_dec (start, v, i, j) = bvslice false start v i j + +let vector_subrange_bl_dec (start, v, i, j) = + let v' = slice (bvec_to_vec false start v) i j in + get_elems v' + +(* 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 bs 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. Size 'a => bool -> integer -> bitvector 'a -> integer -> integer -> list bitU -> bitvector 'a +let bvupdate_aux is_inc start bs i j bs' = + let bits = update_aux is_inc start (List.map to_bitU (bitlistFromWord bs)) i j bs' in + wordFromBitlist (List.map of_bitU bits) + (*let iN = natFromInteger i in + let jN = natFromInteger j in + let startN = natFromInteger start in + let top = word_length bs - 1 in + let (hi,lo) = if is_inc then (top+startN-iN,top+startN-jN) else (top-startN+iN,top-startN+jN) in + word_update bs lo hi bs'*) + +val bvupdate : forall 'a 'b. Size 'a => bool -> integer -> bitvector 'a -> integer -> integer -> bitvector 'b -> bitvector 'a +let bvupdate is_inc start bs i j bs' = + bvupdate_aux is_inc start bs i j (List.map to_bitU (bitlistFromWord bs')) + +val bvaccess : forall 'a. Size 'a => bool -> integer -> bitvector 'a -> integer -> bitU +let bvaccess is_inc start bs n = bool_to_bitU ( + let top = integerFromNat (word_length bs) - 1 in + if is_inc then getBit bs (natFromInteger (top + start - n)) + else getBit bs (natFromInteger (top + n - start))) + +val bvupdate_pos : forall 'a. Size 'a => bool -> integer -> bitvector 'a -> integer -> bitU -> bitvector 'a +let bvupdate_pos is_inc start v n b = + bvupdate_aux is_inc start v n n [b] + +let bitvector_access_inc (start, v, i) = bvaccess true start v i +let bitvector_access_dec (start, v, i) = bvaccess false start v i +let bitvector_update_pos_dec (start, v, i, b) = bvupdate_pos false start v i b +let bitvector_update_subrange_dec (start, v, i, j, v') = bvupdate false start v i j v' + +val extract_only_bit : bitvector ty1 -> bitU +let extract_only_bit 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 norm_dec v = v (*reset_bitvector_start*) +let adjust_start_index (start, v) = v (*set_bitvector_start (start, v)*) + +let cast_vec_bool v = bitU_to_bool (extract_only_bit v) +let cast_bit_vec_basic (start, len, b) = vec_to_bvec (Vector [b] start false) +let cast_boolvec_bitvec (Vector bs start inc) = + vec_to_bvec (Vector (List.map bool_to_bitU bs) start inc) +let cast_vec_bl v = List.map bool_to_bitU (bitlistFromWord v) + +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 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 bs = lNot bs + +let bitwise_binop op (bsl, bsr) = (op bsl bsr) + +let bitwise_and x = bitwise_binop lAnd x +let bitwise_or x = bitwise_binop lOr x +let bitwise_xor x = bitwise_binop lXor x + +(*let unsigned bs : integer = unsignedIntegerFromWord bs*) +let unsigned_big = unsigned + +let signed v : integer = signedIntegerFromWord v + +let hardware_mod (a: integer) (b:integer) : integer = + if a < 0 && b < 0 + then (abs a) mod (abs b) + else if (a < 0 && b >= 0) + then (a mod b) - b + else a mod b + +(* There are different possible answers for integer divide regarding +rounding behaviour on negative operands. Positive operands always +round down so derive the one we want (trucation towards zero) from +that *) +let hardware_quot (a:integer) (b:integer) : integer = + let q = (abs a) / (abs b) in + if ((a<0) = (b<0)) then + q (* same sign -- result positive *) + else + ~q (* different sign -- result negative *) + +let quot_signed = hardware_quot + + +let signed_big = signed + +let to_num sign = if sign then signed else unsigned + +let max_64u = (integerPow 2 64) - 1 +let max_64 = (integerPow 2 63) - 1 +let min_64 = 0 - (integerPow 2 63) +let max_32u = (4294967295 : integer) +let max_32 = (2147483647 : integer) +let min_32 = (0 - 2147483648 : integer) +let max_8 = (127 : integer) +let min_8 = (0 - 128 : integer) +let max_5 = (31 : integer) +let min_5 = (0 - 32 : integer) + +let get_max_representable_in sign (n : integer) : integer = + if (n = 64) then match sign with | true -> max_64 | false -> max_64u end + else if (n=32) then match sign with | true -> max_32 | false -> max_32u end + else if (n=8) then max_8 + else if (n=5) then max_5 + else match sign with | true -> integerPow 2 ((natFromInteger n) -1) + | false -> integerPow 2 (natFromInteger n) + end + +let get_min_representable_in _ (n : integer) : integer = + if n = 64 then min_64 + else if n = 32 then min_32 + else if n = 8 then min_8 + else if n = 5 then min_5 + else 0 - (integerPow 2 (natFromInteger n)) + +val to_bin_aux : natural -> list bitU +let rec to_bin_aux x = + if x = 0 then [] + else (if x mod 2 = 1 then B1 else B0) :: to_bin_aux (x / 2) +let to_bin n = List.reverse (to_bin_aux n) + +val pad_zero : list bitU -> integer -> list bitU +let rec pad_zero bits n = + if n = 0 then bits else pad_zero (B0 :: bits) (n -1) + + +let rec add_one_bit_ignore_overflow_aux bits = match bits with + | [] -> [] + | B0 :: bits -> B1 :: bits + | B1 :: bits -> B0 :: add_one_bit_ignore_overflow_aux bits + | BU :: _ -> failwith "add_one_bit_ignore_overflow: undefined bit" +end + +let add_one_bit_ignore_overflow bits = + List.reverse (add_one_bit_ignore_overflow_aux (List.reverse bits)) + +val to_norm_vec : forall 'a. Size 'a => integer -> bitvector 'a +let to_norm_vec (n : integer) = wordFromInteger n +(* + (* Bitvector length is determined by return type *) + let bits = wordFromInteger n in + let len = integerFromNat (word_length bits) in + let start = if is_inc then 0 else len - 1 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_norm_vec + +let to_vec_inc (start, len, n) = to_norm_vec n +let to_vec_norm_inc (len, n) = to_norm_vec n +let to_vec_dec (start, len, n) = to_norm_vec n +let to_vec_norm_dec (len, n) = to_norm_vec n + +(* TODO: Think about undefined bit(vector)s *) +let to_vec_undef is_inc (len : integer) = + (* 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 (start, len, vec) = to_norm_vec (signed vec) +val extz : forall 'a 'b. Size 'a, Size 'b => (integer * integer * bitvector 'a) -> bitvector 'b +let extz (start, len, vec) = to_norm_vec (unsigned vec) + +let exts_big (start, len, vec) = to_vec_big (signed_big vec) +let extz_big (start, len, vec) = to_vec_big (unsigned_big vec) + +(* TODO *) +let extz_bl (start, len, bits) = vec_to_bvec (Vector bits (integerFromNat (List.length bits - 1)) false) +let exts_bl (start, len, bits) = vec_to_bvec (Vector bits (integerFromNat (List.length bits - 1)) false) + +let quot = hardware_quot +let modulo (l,r) = hardware_mod 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) l r = + let (l',r') = (to_num sign l, to_num sign r) in + let n = op l' r' in + to_norm_vec n + + +(* add_vec + * add_vec_signed + * minus_vec + * multiply_vec + * multiply_vec_signed + *) +let add_VVV = arith_op_vec integerAdd false 1 +let addS_VVV = arith_op_vec integerAdd true 1 +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 mult_vec (l, r) = mult_VVV l r +let mult_svec (l, r) = multS_VVV l r + +let add_vec (l, r) = add_VVV l r +let sub_vec (l, r) = minus_VVV 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 l r = + arith_op_vec op sign size l ((to_norm_vec r) : bitvector 'a) + +(* add_vec_range + * add_vec_range_signed + * minus_vec_range + * mult_vec_range + * mult_vec_range_signed + *) +let add_VIV = arith_op_vec_range integerAdd false 1 +let addS_VIV = arith_op_vec_range integerAdd true 1 +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 add_vec_int (l, r) = add_VIV l r +let sub_vec_int (l, r) = minus_VIV 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 r = + arith_op_vec op sign size ((to_norm_vec l) : bitvector 'a) r + +(* add_range_vec + * add_range_vec_signed + * minus_range_vec + * mult_range_vec + * mult_range_vec_signed + *) +let add_IVV = arith_op_range_vec integerAdd false 1 +let addS_IVV = arith_op_range_vec integerAdd true 1 +let minus_IVV = arith_op_range_vec integerMinus false 1 +let mult_IVV = arith_op_range_vec integerMult false 2 +let multS_IVV = arith_op_range_vec integerMult true 2 + +let arith_op_range_vec_range op sign l r = op l (to_num sign r) + +(* add_range_vec_range + * add_range_vec_range_signed + * minus_range_vec_range + *) +let add_IVI x = arith_op_range_vec_range integerAdd false x +let addS_IVI x = arith_op_range_vec_range integerAdd true x +let minus_IVI x = arith_op_range_vec_range integerMinus false x + +let arith_op_vec_range_range op sign l r = op (to_num sign l) r + +(* add_vec_range_range + * add_vec_range_range_signed + * minus_vec_range_range + *) +let add_VII x = arith_op_vec_range_range integerAdd false x +let addS_VII x = arith_op_vec_range_range integerAdd true x +let minus_VII x = arith_op_vec_range_range integerMinus false x + + + +let arith_op_vec_vec_range op sign l r = + let (l',r') = (to_num sign l,to_num sign r) in + op l' r' + +(* add_vec_vec_range + * add_vec_vec_range_signed + *) +let add_VVI x = arith_op_vec_vec_range integerAdd false x +let addS_VVI x = arith_op_vec_vec_range integerAdd true x + +let arith_op_vec_bit op sign (size : integer) l r = + let l' = to_num sign l in + let n = op l' (match r with | B1 -> (1 : integer) | _ -> 0 end) in + to_norm_vec n + +(* add_vec_bit + * add_vec_bit_signed + * minus_vec_bit_signed + *) +let add_VBV x = arith_op_vec_bit integerAdd false 1 x +let addS_VBV x = arith_op_vec_bit integerAdd true 1 x +let minus_VBV x = arith_op_vec_bit integerMinus true 1 x + +(* 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 + let n = op l_sign r_sign in + let n_unsign = op l_unsign r_unsign in + let correct_size_num = to_vec_ord is_inc (act_size,n) in + let one_more_size_u = to_vec_ord is_inc (act_size + 1,n_unsign) in + let overflow = + if n <= get_max_representable_in sign len && + n >= get_min_representable_in sign len + then B0 else B1 in + let c_out = most_significant one_more_size_u in + (correct_size_num,overflow,c_out) + +(* add_overflow_vec + * add_overflow_vec_signed + * minus_overflow_vec + * minus_overflow_vec_signed + * mult_overflow_vec + * mult_overflow_vec_signed + *) +let addO_VVV = arith_op_overflow_vec integerAdd false 1 +let addSO_VVV = arith_op_overflow_vec integerAdd true 1 +let minusO_VVV = arith_op_overflow_vec integerMinus false 1 +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) + (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 + | B1 -> (op l' 1, op l_u 1, true) + | B0 -> (l',l_u,false) + | BU -> failwith "arith_op_overflow_vec_bit applied to undefined bit" + end in +(* | _ -> assert false *) + let correct_size_num = to_vec_ord is_inc (act_size,n) in + let one_larger = to_vec_ord is_inc (act_size + 1,nu) in + let overflow = + if changed + then + if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size + then B0 else B1 + else B0 in + (correct_size_num,overflow,most_significant one_larger) + +(* add_overflow_vec_bit_signed + * minus_overflow_vec_bit + * minus_overflow_vec_bit_signed + *) +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 (bs, (n : integer)) = + let n = natFromInteger n in + match op with + | LL_shift (*"<<"*) -> + shiftLeft bs n + | RR_shift (*">>"*) -> + shiftRight bs n + | LLL_shift (*"<<<"*) -> + rotateLeft n bs + end + +let bitwise_leftshift x = shift_op_vec LL_shift x (*"<<"*) +let bitwise_rightshift x = shift_op_vec RR_shift x (*">>"*) +let bitwise_rotate x = shift_op_vec LLL_shift x (*"<<<"*) + +let shiftl = bitwise_leftshift + +let rec arith_op_no0 (op : integer -> integer -> integer) l r = + if r = 0 + then Nothing + else Just (op l r) +(* 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') = + match n with + | Just n' -> + (n' <= get_max_representable_in sign act_size && + n' >= get_min_representable_in sign act_size, n') + | _ -> (false,0) + end in + if representable + then to_vec_ord is_inc (act_size,n') + else Vector (List.replicate (natFromInteger act_size) BU) start is_inc + +let mod_VVV = arith_op_vec_no0 hardware_mod false 1 +let quot_VVV = arith_op_vec_no0 hardware_quot false 1 +let quotS_VVV = arith_op_vec_no0 hardware_quot true 1 + +let arith_op_overflow_no0_vec op sign size ((Vector _ start is_inc) as l) r = + let rep_size = length r * size in + let act_size = length l * size in + let (l',r') = (to_num sign l,to_num sign r) in + let (l_u,r_u) = (to_num false l,to_num false r) in + let n = arith_op_no0 op l' r' in + let n_u = arith_op_no0 op l_u r_u in + let (representable,n',n_u') = + match (n, n_u) with + | (Just n',Just n_u') -> + ((n' <= get_max_representable_in sign rep_size && + n' >= (get_min_representable_in sign rep_size)), n', n_u') + | _ -> (true,0,0) + end in + let (correct_size_num,one_more) = + if representable then + (to_vec_ord is_inc (act_size,n'),to_vec_ord is_inc (act_size + 1,n_u')) + else + (Vector (List.replicate (natFromInteger act_size) BU) start is_inc, + Vector (List.replicate (natFromInteger (act_size + 1)) BU) start is_inc) in + let overflow = if representable then B0 else B1 in + (correct_size_num,overflow,most_significant one_more) + +let quotO_VVV = arith_op_overflow_no0_vec hardware_quot false 1 +let quotSO_VVV = arith_op_overflow_no0_vec hardware_quot true 1 + +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_ord is_inc (length l,r)) + +let mod_VIV = arith_op_vec_range_no0 hardware_mod false 1 +*) + +let duplicate (bit, length) = + vec_to_bvec (Vector (repeat [bit] length) (length - 1) false) + +(* TODO: replace with better native versions *) +let replicate_bits (v, count) = + let v = bvec_to_vec true 0 v in + vec_to_bvec (Vector (repeat (get_elems v) count) ((length v * count) - 1) false) + +let compare_op op (l,r) = (op l r) + +let lt = compare_op (<) +let gt = compare_op (>) +let lteq = compare_op (<=) +let gteq = compare_op (>=) + +let compare_op_vec op sign (l,r) = + let (l',r') = (to_num sign l, to_num sign r) in + compare_op op (l',r') + +let lt_vec x = compare_op_vec (<) true x +let gt_vec x = compare_op_vec (>) true x +let lteq_vec x = compare_op_vec (<=) true x +let gteq_vec x = compare_op_vec (>=) true x + +let lt_vec_signed x = compare_op_vec (<) true x +let gt_vec_signed x = compare_op_vec (>) true x +let lteq_vec_signed x = compare_op_vec (<=) true x +let gteq_vec_signed x = compare_op_vec (>=) true x +let lt_vec_unsigned x = compare_op_vec (<) false x +let gt_vec_unsigned x = compare_op_vec (>) false x +let lteq_vec_unsigned x = compare_op_vec (<=) false x +let gteq_vec_unsigned x = compare_op_vec (>=) false x + +let lt_svec = lt_vec_signed + +let compare_op_vec_range op sign (l,r) = + compare_op op ((to_num sign l),r) + +let lt_vec_range x = compare_op_vec_range (<) true x +let gt_vec_range x = compare_op_vec_range (>) true x +let lteq_vec_range x = compare_op_vec_range (<=) true x +let gteq_vec_range x = compare_op_vec_range (>=) true x + +let compare_op_range_vec op sign (l,r) = + compare_op op (l, (to_num sign r)) + +let lt_range_vec x = compare_op_range_vec (<) true x +let gt_range_vec x = compare_op_range_vec (>) true x +let lteq_range_vec x = compare_op_range_vec (<=) true x +let gteq_range_vec x = compare_op_range_vec (>=) true x + +val eq : forall 'a. Eq 'a => 'a * 'a -> bool +let eq (l,r) = (l = r) +let eq_range (l,r) = (l = r) + +val eq_vec : forall 'a. Size 'a => bitvector 'a * bitvector 'a -> bool +let eq_vec (l,r) = eq (to_num false l, to_num false r) +let eq_bit (l,r) = eq (l, r) +let eq_vec_range (l,r) = eq (to_num false l,r) +let eq_range_vec (l,r) = eq (l, to_num false r) +(*let eq_vec_vec (l,r) = eq (to_num true l, to_num true r)*) + +let neq (l,r) = not (eq (l,r)) +let neq_bit (l,r) = not (eq_bit (l,r)) +let neq_range (l,r) = not (eq_range (l,r)) +let neq_vec (l,r) = not (eq_vec (l,r)) +(*let neq_vec_vec (l,r) = not (eq_vec_vec (l,r))*) +let neq_vec_range (l,r) = not (eq_vec_range (l,r)) +let neq_range_vec (l,r) = not (eq_range_vec (l,r)) + + +val make_indexed_vector : forall 'a. list (integer * 'a) -> 'a -> integer -> integer -> bool -> vector 'a +let make_indexed_vector entries default start length dir = + let length = natFromInteger length in + Vector (List.foldl replace (replicate length default) entries) start dir + +(* +val make_bit_vector_undef : integer -> vector bitU +let make_bitvector_undef length = + Vector (replicate (natFromInteger length) BU) 0 true + *) + +(* let bitwise_not_range_bit n = bitwise_not (to_vec_ord defaultDir n) *) + +(* TODO *) +val mask : forall 'a 'b. Size 'b => (integer * integer * bitvector 'a) -> bitvector 'b +let mask (start, _, w) = (zeroExtend w) + +(* Register operations *) + +(*let update_reg_range reg i j reg_val new_val = bvupdate (reg.reg_is_inc) (reg.reg_start) reg_val i j new_val +let update_reg_pos reg i reg_val bit = bvupdate_pos (reg.reg_is_inc) (reg.reg_start) reg_val i bit +let update_reg_field_range regfield i j reg_val new_val = + let current_field_value = regfield.get_field reg_val in + let new_field_value = bvupdate (regfield.field_is_inc) (regfield.field_start) current_field_value i j new_val in + regfield.set_field reg_val new_field_value +(*let write_reg_field_pos regfield i reg_val bit = + let current_field_value = regfield.get_field reg_val in + let new_field_value = bvupdate_pos (regfield.field_is_inc) (regfield.field_start) current_field_value i bit in + regfield.set_field reg_val new_field_value*)*) diff --git a/src/gen_lib/sail_values.lem b/src/gen_lib/sail_values.lem index 121f6cc8..bd18cf81 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 @@ -8,6 +11,44 @@ type nn = natural val pow : integer -> integer -> integer let pow m n = m ** (natFromInteger n) +let pow2 n = pow 2 n + +let add_int (l,r) = integerAdd l r +let add_signed (l,r) = integerAdd l r +let sub_int (l,r) = integerMinus l r +let mult_int (l,r) = integerMult l r +let quotient_int (l,r) = integerDiv l r +let quotient_nat (l,r) = natDiv l r +let power_int_nat (l,r) = integerPow l r +let power_int_int (l, r) = integerPow l (natFromInteger r) +let negate_int i = integerNegate i +let min_int (l, r) = integerMin l r +let max_int (l, r) = integerMax l r + +let add_real (l, r) = realAdd l r +let sub_real (l, r) = realMinus l r +let mult_real (l, r) = realMult l r +let div_real (l, r) = realDiv l r +let negate_real r = realNegate r +let abs_real r = realAbs r +let power_real (b, e) = realPowInteger b e + +let or_bool (l, r) = (l || r) +let and_bool (l, r) = (l && r) +let xor_bool (l, r) = xor l r + +let list_append (l, r) = l ++ r +let list_length xs = integerFromNat (List.length xs) +let list_take (n, xs) = List.take (natFromInteger n) xs +let list_drop (n, xs) = List.drop (natFromInteger n) xs + +val repeat : forall 'a. list 'a -> integer -> list 'a +let rec repeat xs n = + if n <= 0 then [] + else xs ++ repeat xs (n-1) + +let duplicate_to_list (bit, length) = repeat [bit] length + let rec replace bs ((n : integer),b') = match bs with | [] -> [] | b :: bs -> @@ -15,6 +56,7 @@ let rec replace bs ((n : integer),b') = match bs with else b :: replace bs (n - 1,b') end +let upper n = n (*** Bits *) type bitU = B0 | B1 | BU @@ -29,6 +71,15 @@ instance (Show bitU) let show = showBitU end +class (BitU 'a) + val to_bitU : 'a -> bitU + val of_bitU : bitU -> 'a +end + +instance (BitU bitU) + let to_bitU b = b + let of_bitU b = b +end let bitU_to_bool = function | B0 -> false @@ -36,6 +87,15 @@ let bitU_to_bool = function | BU -> failwith "to_bool applied to BU" end +let bool_to_bitU b = if b then B1 else B0 + +instance (BitU bool) + let to_bitU = bool_to_bitU + let of_bitU = bitU_to_bool +end + +let cast_bit_bool = bitU_to_bool + let bit_lifted_of_bitU = function | B0 -> Bitl_zero | B1 -> Bitl_one @@ -66,14 +126,12 @@ let bitwise_not_bit = function | BU -> BU end -let inline (~) = bitwise_not_bit +(* let inline (~) = bitwise_not_bit *) val is_one : integer -> bitU let is_one i = if i = 1 then B1 else B0 -let bool_to_bitU b = if b then B1 else B0 - let bitwise_binop_bit op = function | (BU,_) -> BU (*Do we want to do this or to respect | of I and & of B0 rules?*) | (_,BU) -> BU (*Do we want to do this or to respect | of I and & of B0 rules?*) @@ -98,6 +156,56 @@ let inline (|.) x y = bitwise_or_bit (x,y) val (+.) : bitU -> bitU -> bitU let inline (+.) x y = bitwise_xor_bit (x,y) +val to_bin_aux : natural -> list bitU +let rec to_bin_aux x = + if x = 0 then [] + else (if x mod 2 = 1 then B1 else B0) :: to_bin_aux (x / 2) +let to_bin n = List.reverse (to_bin_aux n) + +val of_bin : list bitU -> natural +let of_bin bits = + let (sum,_) = + List.foldr + (fun b (acc,exp) -> + match b with + | B1 -> (acc + naturalPow 2 exp, exp + 1) + | B0 -> (acc, exp + 1) + | BU -> failwith "of_bin: bitvector has undefined bits" + end) + (0,0) bits in + sum + +val bitlist_to_integer : list bitU -> integer +let bitlist_to_integer bs = integerFromNatural (of_bin bs) + +val pad_zero : list bitU -> integer -> list bitU +let rec pad_zero bits n = + if n <= 0 then bits else pad_zero (B0 :: bits) (n -1) + +let bitwise_not_bitlist = List.map bitwise_not_bit + +let rec add_one_bit_ignore_overflow_aux bits = match bits with + | [] -> [] + | B0 :: bits -> B1 :: bits + | B1 :: bits -> B0 :: add_one_bit_ignore_overflow_aux bits + | BU :: _ -> failwith "add_one_bit_ignore_overflow: undefined bit" +end + +let add_one_bit_ignore_overflow bits = + List.reverse (add_one_bit_ignore_overflow_aux (List.reverse bits)) + +let bits_of_nat ((len : integer),(n : natural)) = + let bits = to_bin n in + let len_bits = integerFromNat (List.length bits) in + let longer = len - len_bits in + if longer < 0 then drop (natFromInteger (abs (longer))) bits + else pad_zero bits longer + +let bits_of_int ((len : integer),(n : integer)) = + let bits = bits_of_nat (len, naturalFromInteger (abs n)) in + if n > (0 : integer) + then bits + else (add_one_bit_ignore_overflow (bitwise_not_bitlist bits)) (*** Vectors *) @@ -112,6 +220,7 @@ let get_dir (Vector _ _ ord) = ord let get_start (Vector _ s _) = s let get_elems (Vector elems _ _) = elems let length (Vector bs _ _) = integerFromNat (length bs) +let vector_length = length instance forall 'a. Show 'a => (Show (vector 'a)) let show = showVector @@ -125,17 +234,17 @@ let bool_of_dir = function (*** Vector operations *) -val set_vector_start : forall 'a. integer -> vector 'a -> vector 'a -let set_vector_start new_start (Vector bs _ is_inc) = +val set_vector_start : forall 'a. (integer * vector 'a) -> vector 'a +let set_vector_start (new_start, Vector bs _ is_inc) = Vector bs new_start is_inc let reset_vector_start v = - set_vector_start (if (get_dir v) then 0 else (length v - 1)) v + set_vector_start (if (get_dir v) then 0 else (length v - 1), v) let set_vector_start_to_length v = - set_vector_start (length v - 1) v + set_vector_start (length v - 1, v) -let vector_concat (Vector bs start is_inc) (Vector bs' _ _) = +let vector_concat (Vector bs start is_inc, Vector bs' _ _) = Vector (bs ++ bs') start is_inc let inline (^^) = vector_concat @@ -152,14 +261,19 @@ let update_sublist xs (i,j) xs' = let (prefix,_fromItoJ) = List.splitAt i toJ in prefix ++ xs' ++ suffix -val slice : forall 'a. vector 'a -> integer -> integer -> vector 'a -let slice (Vector bs start is_inc) i j = +val slice_aux : forall 'a. bool -> integer -> list 'a -> integer -> integer -> list 'a +let slice_aux is_inc start bs i j = let iN = natFromInteger i in let jN = natFromInteger j in let startN = natFromInteger start in - let subvector_bits = - sublist bs (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) in - Vector subvector_bits i is_inc + sublist bs (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) + +val slice : forall 'a. vector 'a -> integer -> integer -> vector 'a +let slice (Vector bs start is_inc) i j = + Vector (slice_aux is_inc start bs i j) i is_inc + +let vector_subrange_inc (start, v, i, j) = slice v i j +let vector_subrange_dec (start, v, i, j) = slice v i j (* 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 @@ -174,503 +288,115 @@ let slice_raw (Vector bs start is_inc) i j = Vector bits (if is_inc then 0 else len - 1) is_inc -val update_aux : forall 'a. vector 'a -> integer -> integer -> list 'a -> vector 'a -let update_aux (Vector bs start is_inc) i j bs' = +val update_aux : forall 'a. bool -> integer -> list 'a -> integer -> integer -> list 'a -> list 'a +let update_aux is_inc start bs i j bs' = let iN = natFromInteger i in let jN = natFromInteger j in let startN = natFromInteger start in - let bits = - (update_sublist bs) - (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) bs' in - Vector bits start is_inc + update_sublist bs + (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) bs' val update : forall 'a. vector 'a -> integer -> integer -> vector 'a -> vector 'a -let update v i j (Vector bs' _ _) = - update_aux v i j bs' +let update (Vector bs start is_inc) i j (Vector bs' _ _) = + Vector (update_aux is_inc start bs i j bs') start is_inc + +let vector_update_subrange_inc (start, v, i, j, v') = update v i j v' +let vector_update_subrange_dec (start, v, i, j, v') = update v i j v' + +val access_aux : forall 'a. bool -> integer -> list 'a -> integer -> 'a +let access_aux is_inc start xs n = + if is_inc then List_extra.nth xs (natFromInteger (n - start)) + else List_extra.nth xs (natFromInteger (start - n)) val access : forall 'a. vector 'a -> integer -> 'a -let access (Vector bs start is_inc) n = - if is_inc then List_extra.nth bs (natFromInteger (n - start)) - else List_extra.nth bs (natFromInteger (start - n)) +let access (Vector bs start is_inc) n = access_aux is_inc start bs n + +let vector_access_inc (start, v, i) = access v i +let vector_access_dec (start, v, i) = access v i val update_pos : forall 'a. vector 'a -> integer -> 'a -> vector 'a let update_pos v n b = - update_aux v n n [b] - + update v n n (Vector [b] 0 false) -(*** Bit vector operations *) +let vector_update_pos_inc (start, v, i, x) = update_pos v i x +let vector_update_pos_dec (start, v, i, x) = update_pos v i x -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 -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 bitwise_not_bitlist = List.map bitwise_not_bit - -let bitwise_not (Vector bs start is_inc) = - Vector (bitwise_not_bitlist bs) start is_inc +(*** Bitvectors *) -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 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 hardware_mod (a: integer) (b:integer) : integer = - if a < 0 && b < 0 - then (abs a) mod (abs b) - else if (a < 0 && b >= 0) - then (a mod b) - b - else a mod b - -(* There are different possible answers for integer divide regarding -rounding behaviour on negative operands. Positive operands always -round down so derive the one we want (trucation towards zero) from -that *) -let hardware_quot (a:integer) (b:integer) : integer = - let q = (abs a) / (abs b) in - if ((a<0) = (b<0)) then - q (* same sign -- result positive *) - else - integerNegate q (* different sign -- result negative *) - -let quot_signed = hardware_quot - - -let signed_big = signed - -let to_num sign = if sign then signed else unsigned - -let max_64u = (integerPow 2 64) - 1 -let max_64 = (integerPow 2 63) - 1 -let min_64 = 0 - (integerPow 2 63) -let max_32u = (4294967295 : integer) -let max_32 = (2147483647 : integer) -let min_32 = (0 - 2147483648 : integer) -let max_8 = (127 : integer) -let min_8 = (0 - 128 : integer) -let max_5 = (31 : integer) -let min_5 = (0 - 32 : integer) - -let get_max_representable_in sign (n : integer) : integer = - if (n = 64) then match sign with | true -> max_64 | false -> max_64u end - else if (n=32) then match sign with | true -> max_32 | false -> max_32u end - else if (n=8) then max_8 - else if (n=5) then max_5 - else match sign with | true -> integerPow 2 ((natFromInteger n) -1) - | false -> integerPow 2 (natFromInteger n) - end - -let get_min_representable_in _ (n : integer) : integer = - if n = 64 then min_64 - else if n = 32 then min_32 - else if n = 8 then min_8 - else if n = 5 then min_5 - else 0 - (integerPow 2 (natFromInteger n)) - -val to_bin_aux : natural -> list bitU -let rec to_bin_aux x = - if x = 0 then [] - else (if x mod 2 = 1 then B1 else B0) :: to_bin_aux (x / 2) -let to_bin n = List.reverse (to_bin_aux n) - -val pad_zero : list bitU -> integer -> list bitU -let rec pad_zero bits n = - if n = 0 then bits else pad_zero (B0 :: bits) (n -1) - - -let rec add_one_bit_ignore_overflow_aux bits = match bits with - | [] -> [] - | B0 :: bits -> B1 :: bits - | B1 :: bits -> B0 :: add_one_bit_ignore_overflow_aux bits - | BU :: _ -> failwith "add_one_bit_ignore_overflow: undefined bit" +(* element list * start * has increasing direction *) +type bitvector 'a = mword 'a (* Bitvector of mword 'a * integer * bool *) +declare isabelle target_sorts bitvector = `len` + +class (Bitvector 'a) + val bits_of : 'a -> list bitU + val of_bits : list bitU -> 'a + val unsigned : 'a -> integer + (* The first two parameters of the following specify indexing: + indexing order and start index *) + val get_bit : bool -> integer -> 'a -> integer -> bitU + val set_bit : bool -> integer -> 'a -> integer -> bitU -> 'a + val get_bits : bool -> integer -> 'a -> integer -> integer -> list bitU + val set_bits : bool -> integer -> 'a -> integer -> integer -> list bitU -> 'a 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 to_vec_big = to_vec - -let to_vec_inc = to_vec true -let to_vec_dec = to_vec false - -let to_vec_undef is_inc (len : integer) = - Vector (replicate (natFromInteger len) BU) (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_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 add = integerAdd -let add_signed = integerAdd -let minus = integerMinus -let multiply = integerMult -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 = - 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) - - -(* add_vec - * add_vec_signed - * minus_vec - * multiply_vec - * multiply_vec_signed - *) -let add_VVV = arith_op_vec integerAdd false 1 -let addS_VVV = arith_op_vec integerAdd true 1 -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)) - -(* add_vec_range - * add_vec_range_signed - * minus_vec_range - * mult_vec_range - * mult_vec_range_signed - *) -let add_VIV = arith_op_vec_range integerAdd false 1 -let addS_VIV = arith_op_vec_range integerAdd true 1 -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 - -(* add_range_vec - * add_range_vec_signed - * minus_range_vec - * mult_range_vec - * mult_range_vec_signed - *) -let add_IVV = arith_op_range_vec integerAdd false 1 -let addS_IVV = arith_op_range_vec integerAdd true 1 -let minus_IVV = arith_op_range_vec integerMinus false 1 -let mult_IVV = arith_op_range_vec integerMult false 2 -let multS_IVV = arith_op_range_vec integerMult true 2 - -let arith_op_range_vec_range op sign l r = op l (to_num sign r) - -(* add_range_vec_range - * add_range_vec_range_signed - * minus_range_vec_range - *) -let add_IVI = arith_op_range_vec_range integerAdd false -let addS_IVI = arith_op_range_vec_range integerAdd true -let minus_IVI = arith_op_range_vec_range integerMinus false - -let arith_op_vec_range_range op sign l r = op (to_num sign l) r - -(* add_vec_range_range - * add_vec_range_range_signed - * minus_vec_range_range - *) -let add_VII = arith_op_vec_range_range integerAdd false -let addS_VII = arith_op_vec_range_range integerAdd true -let minus_VII = arith_op_vec_range_range integerMinus false - - - -let arith_op_vec_vec_range op sign l r = - let (l',r') = (to_num sign l,to_num sign r) in - op l' r' - -(* add_vec_vec_range - * add_vec_vec_range_signed - *) -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 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) - -(* add_vec_bit - * add_vec_bit_signed - * minus_vec_bit_signed - *) -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 - 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 - let n = op l_sign r_sign in - let n_unsign = op l_unsign r_unsign in - let correct_size_num = to_vec is_inc (act_size,n) in - let one_more_size_u = to_vec is_inc (act_size + 1,n_unsign) in - let overflow = - if n <= get_max_representable_in sign len && - n >= get_min_representable_in sign len - then B0 else B1 in - let c_out = most_significant one_more_size_u in - (correct_size_num,overflow,c_out) - -(* add_overflow_vec - * add_overflow_vec_signed - * minus_overflow_vec - * minus_overflow_vec_signed - * mult_overflow_vec - * mult_overflow_vec_signed - *) -let addO_VVV = arith_op_overflow_vec integerAdd false 1 -let addSO_VVV = arith_op_overflow_vec integerAdd true 1 -let minusO_VVV = arith_op_overflow_vec integerMinus false 1 -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 - -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 - let l' = to_num sign l in - let l_u = to_num false l in - let (n,nu,changed) = match r_bit with - | B1 -> (op l' 1, op l_u 1, true) - | B0 -> (l',l_u,false) - | BU -> failwith "arith_op_overflow_vec_bit applied to undefined bit" - end in -(* | _ -> assert false *) - let correct_size_num = to_vec is_inc (act_size,n) in - let one_larger = to_vec is_inc (act_size + 1,nu) in - let overflow = - if changed - then - if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size - then B0 else B1 - else B0 in - (correct_size_num,overflow,most_significant one_larger) - -(* add_overflow_vec_bit_signed - * minus_overflow_vec_bit - * minus_overflow_vec_bit_signed - *) -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 n = natFromInteger n in - match op with - | LL_shift (*"<<"*) -> - Vector (sublist bs (n,List.length bs -1) ++ List.replicate n B0) start is_inc - | RR_shift (*">>"*) -> - Vector (List.replicate n B0 ++ sublist bs (0,n-1)) start is_inc - | LLL_shift (*"<<<"*) -> - Vector (sublist bs (n,List.length bs - 1) ++ sublist bs (0,n-1)) start is_inc - end - -let bitwise_leftshift = shift_op_vec LL_shift (*"<<"*) -let bitwise_rightshift = shift_op_vec RR_shift (*">>"*) -let bitwise_rotate = shift_op_vec LLL_shift (*"<<<"*) - -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 - let (l',r') = (to_num sign l,to_num sign r) in - let n = arith_op_no0 op l' r' in - let (representable,n') = - match n with - | Just n' -> - (n' <= get_max_representable_in sign act_size && - n' >= get_min_representable_in sign act_size, n') - | _ -> (false,0) - end in - if representable - then to_vec is_inc (act_size,n') - else Vector (List.replicate (natFromInteger act_size) BU) start is_inc - -let mod_VVV = arith_op_vec_no0 hardware_mod false 1 -let quot_VVV = arith_op_vec_no0 hardware_quot false 1 -let quotS_VVV = arith_op_vec_no0 hardware_quot true 1 - -let arith_op_overflow_no0_vec op sign size ((Vector _ start is_inc) as l) r = - let rep_size = length r * size in - let act_size = length l * size in - let (l',r') = (to_num sign l,to_num sign r) in - let (l_u,r_u) = (to_num false l,to_num false r) in - let n = arith_op_no0 op l' r' in - let n_u = arith_op_no0 op l_u r_u in - let (representable,n',n_u') = - match (n, n_u) with - | (Just n',Just n_u') -> - ((n' <= get_max_representable_in sign rep_size && - n' >= (get_min_representable_in sign rep_size)), n', n_u') - | _ -> (true,0,0) - end in - let (correct_size_num,one_more) = - if representable then - (to_vec is_inc (act_size,n'),to_vec is_inc (act_size + 1,n_u')) - else - (Vector (List.replicate (natFromInteger act_size) BU) start is_inc, - Vector (List.replicate (natFromInteger (act_size + 1)) BU) start is_inc) in - let overflow = if representable then B0 else B1 in - (correct_size_num,overflow,most_significant one_more) - -let quotO_VVV = arith_op_overflow_no0_vec hardware_quot false 1 -let quotSO_VVV = arith_op_overflow_no0_vec hardware_quot true 1 - -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 [] - else xs ++ repeat xs (n-1) - -(* -let duplicate bit length = - Vector (repeat [bit] length) (if dir then 0 else length - 1) dir - *) - -let compare_op op (l,r) = bool_to_bitU (op l r) - -let lt = compare_op (<) -let gt = compare_op (>) -let lteq = compare_op (<=) -let gteq = compare_op (>=) - - -let compare_op_vec op sign (l,r) = - let (l',r') = (to_num sign l, to_num sign r) in - compare_op op (l',r') - -let lt_vec = compare_op_vec (<) true -let gt_vec = compare_op_vec (>) true -let lteq_vec = compare_op_vec (<=) true -let gteq_vec = compare_op_vec (>=) true - -let lt_vec_signed = compare_op_vec (<) true -let gt_vec_signed = compare_op_vec (>) true -let lteq_vec_signed = compare_op_vec (<=) true -let gteq_vec_signed = compare_op_vec (>=) true -let lt_vec_unsigned = compare_op_vec (<) false -let gt_vec_unsigned = compare_op_vec (>) false -let lteq_vec_unsigned = compare_op_vec (<=) false -let gteq_vec_unsigned = compare_op_vec (>=) false - -let compare_op_vec_range op sign (l,r) = - compare_op op ((to_num sign l),r) - -let lt_vec_range = compare_op_vec_range (<) true -let gt_vec_range = compare_op_vec_range (>) true -let lteq_vec_range = compare_op_vec_range (<=) true -let gteq_vec_range = compare_op_vec_range (>=) true - -let compare_op_range_vec op sign (l,r) = - compare_op op (l, (to_num sign r)) +instance forall 'a. BitU 'a => (Bitvector (list 'a)) + let bits_of v = List.map to_bitU v + let of_bits v = List.map of_bitU v + let unsigned v = bitlist_to_integer (List.map to_bitU v) + let get_bit is_inc start v n = to_bitU (access_aux is_inc start v n) + let set_bit is_inc start v n b = update_aux is_inc start v n n [of_bitU b] + let get_bits is_inc start v i j = List.map to_bitU (slice_aux is_inc start v i j) + let set_bits is_inc start v i j v' = update_aux is_inc start v i j (List.map of_bitU v') +end -let lt_range_vec = compare_op_range_vec (<) true -let gt_range_vec = compare_op_range_vec (>) true -let lteq_range_vec = compare_op_range_vec (<=) true -let gteq_range_vec = compare_op_range_vec (>=) true +instance forall 'a. BitU 'a => (Bitvector (vector 'a)) + let bits_of v = List.map to_bitU (get_elems v) + let of_bits v = Vector (List.map of_bitU v) (integerFromNat (List.length v) - 1) false + let unsigned v = unsigned (get_elems v) + let get_bit is_inc start v n = to_bitU (access v n) + let set_bit is_inc start v n b = update_pos v n (of_bitU b) + let get_bits is_inc start v i j = List.map to_bitU (get_elems (slice v i j)) + let set_bits is_inc start v i j v' = update v i j (Vector (List.map of_bitU v') (integerFromNat (List.length v') - 1) false) +end -let eq (l,r) = bool_to_bitU (l = r) -let eq_range (l,r) = bool_to_bitU (l = r) -let eq_vec (l,r) = bool_to_bitU (l = r) -let eq_bit (l,r) = bool_to_bitU (l = r) -let eq_vec_range (l,r) = eq (to_num false l,r) -let eq_range_vec (l,r) = eq (l, to_num false r) -let eq_vec_vec (l,r) = eq (to_num true l, to_num true r) +instance forall 'a. Size 'a => (Bitvector (mword 'a)) + let bits_of v = List.map to_bitU (bitlistFromWord v) + let of_bits v = wordFromBitlist (List.map of_bitU v) + let unsigned v = unsignedIntegerFromWord v + let get_bit is_inc start v n = to_bitU (access_aux is_inc start (bitlistFromWord v) n) + let set_bit is_inc start v n b = wordFromBitlist (update_aux is_inc start (bitlistFromWord v) n n [of_bitU b]) + let get_bits is_inc start v i j = slice_aux is_inc start (List.map to_bitU (bitlistFromWord v)) i j + let set_bits is_inc start v i j v' = wordFromBitlist (update_aux is_inc start (bitlistFromWord v) i j (List.map of_bitU v')) +end -let neq (l,r) = bitwise_not_bit (eq (l,r)) -let neq_bit (l,r) = bitwise_not_bit (eq_bit (l,r)) -let neq_range (l,r) = bitwise_not_bit (eq_range (l,r)) -let neq_vec (l,r) = bitwise_not_bit (eq_vec_vec (l,r)) -let neq_vec_range (l,r) = bitwise_not_bit (eq_vec_range (l,r)) -let neq_range_vec (l,r) = bitwise_not_bit (eq_range_vec (l,r)) +(*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 -val make_indexed_vector : forall 'a. list (integer * 'a) -> 'a -> integer -> integer -> bool -> vector 'a -let make_indexed_vector entries default start length dir = - let length = natFromInteger length in - Vector (List.foldl replace (replicate length default) entries) start dir +instance forall 'a. (Show (bitvector 'a)) + let show = showBitvector +end*) -(* -val make_bit_vector_undef : integer -> vector bitU -let make_bitvector_undef length = - Vector (replicate (natFromInteger length) BU) 0 true - *) +let bvec_to_vec is_inc start bs = + let bits = List.map bool_to_bitU (bitlistFromWord bs) in + Vector bits start is_inc -(* let bitwise_not_range_bit n = bitwise_not (to_vec defaultDir n) *) +let vec_to_bvec (Vector elems start is_inc) = + (*let word =*) wordFromBitlist (List.map bitU_to_bool elems) (*in + Bitvector word start is_inc*) -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 +(*** Vector operations *) +(* Bytes and addresses *) val byte_chunks : forall 'a. nat -> list 'a -> list (list 'a) let rec byte_chunks n list = match (n,list) with @@ -679,37 +405,37 @@ let rec byte_chunks n list = match (n,list) with | _ -> failwith "byte_chunks not given enough bits" end -val bitv_of_byte_lifteds : bool -> list Sail_impl_base.byte_lifted -> vector bitU +val bitv_of_byte_lifteds : bool -> list Sail_impl_base.byte_lifted -> list bitU let bitv_of_byte_lifteds dir v = let bits = foldl (fun x (Byte_lifted y) -> x ++ (List.map bitU_of_bit_lifted y)) [] v in let len = integerFromNat (List.length bits) in - Vector bits (if dir then 0 else len - 1) dir + bits (*Vector bits (if dir then 0 else len - 1) dir*) -val bitv_of_bytes : bool -> list Sail_impl_base.byte -> vector bitU +val bitv_of_bytes : bool -> list Sail_impl_base.byte -> list bitU let bitv_of_bytes dir v = let bits = foldl (fun x (Byte y) -> x ++ (List.map bitU_of_bit y)) [] v in let len = integerFromNat (List.length bits) in - Vector bits (if dir then 0 else len - 1) dir + bits (*Vector bits (if dir then 0 else len - 1) dir*) -val byte_lifteds_of_bitv : vector bitU -> list byte_lifted -let byte_lifteds_of_bitv (Vector bits length is_inc) = +val byte_lifteds_of_bitv : list bitU -> list byte_lifted +let byte_lifteds_of_bitv bits = let bits = List.map bit_lifted_of_bitU bits in byte_lifteds_of_bit_lifteds bits -val bytes_of_bitv : vector bitU -> list byte -let bytes_of_bitv (Vector bits length is_inc) = +val bytes_of_bitv : list bitU -> list byte +let bytes_of_bitv bits = let bits = List.map bit_of_bitU bits in bytes_of_bits bits val bit_lifteds_of_bitUs : list bitU -> list bit_lifted let bit_lifteds_of_bitUs bits = List.map bit_lifted_of_bitU bits -val bit_lifteds_of_bitv : vector bitU -> list bit_lifted -let bit_lifteds_of_bitv v = bit_lifteds_of_bitUs (get_elems v) +val bit_lifteds_of_bitv : list bitU -> list bit_lifted +let bit_lifteds_of_bitv v = bit_lifteds_of_bitUs v -val address_lifted_of_bitv : vector bitU -> address_lifted +val address_lifted_of_bitv : list bitU -> address_lifted let address_lifted_of_bitv v = let byte_lifteds = byte_lifteds_of_bitv v in let maybe_address_integer = @@ -719,11 +445,17 @@ let address_lifted_of_bitv v = end in Address_lifted byte_lifteds maybe_address_integer -val address_of_bitv : vector bitU -> address +val address_of_bitv : list bitU -> address let address_of_bitv v = let bytes = bytes_of_bitv v in address_of_byte_list bytes +let rec reverse_endianness_bl bits = + if List.length bits <= 8 then bits else + list_append(reverse_endianness_bl(list_drop(8, bits)), list_take(8, bits)) + +val reverse_endianness : forall 'a. Bitvector 'a => 'a -> 'a +let reverse_endianness v = of_bits (reverse_endianness_bl (bits_of v)) (*** Registers *) @@ -740,6 +472,20 @@ type register = | UndefinedRegister of integer (* length *) | RegisterPair of register * register +type register_ref 'regstate 'a = + <| reg_name : string; + reg_start : integer; + reg_is_inc : bool; + read_from : 'regstate -> 'a; + write_to : 'regstate -> 'a -> 'regstate |> + +type field_ref 'regtype 'a = + <| field_name : string; + field_start : integer; + field_is_inc : bool; + get_field : 'regtype -> 'a; + set_field : 'regtype -> 'a -> 'regtype |> + let name_of_reg = function | Register name _ _ _ _ -> name | UndefinedRegister _ -> failwith "name_of_reg UndefinedRegister" @@ -815,11 +561,11 @@ let rec external_reg_value reg_name v = rv_start = external_start; rv_start_internal = internal_start |> -val internal_reg_value : register_value -> vector bitU +val internal_reg_value : register_value -> list bitU let internal_reg_value v = - Vector (List.map bitU_of_bit_lifted v.rv_bits) - (integerFromNat v.rv_start_internal) - (v.rv_dir = D_increasing) + List.map bitU_of_bit_lifted v.rv_bits + (*(integerFromNat v.rv_start_internal) + (v.rv_dir = D_increasing)*) let external_slice (d:direction) (start:nat) ((i,j):(nat*nat)) = @@ -866,17 +612,17 @@ let internal_mem_value direction bytes = val foreach_inc : forall 'vars. (integer * integer * integer) -> 'vars -> (integer -> 'vars -> 'vars) -> 'vars let rec foreach_inc (i,stop,by) vars body = - if i <= stop + if (by > 0 && i <= stop) || (by < 0 && stop <= i) then let vars = body i vars in foreach_inc (i + by,stop,by) vars body else vars val foreach_dec : forall 'vars. (integer * integer * integer) -> 'vars -> (integer -> 'vars -> 'vars) -> 'vars -let rec foreach_dec (i,stop,by) vars body = - if i >= stop +let rec foreach_dec (stop,i,by) vars body = + if (by > 0 && i >= stop) || (by < 0 && stop >= i) then let vars = body i vars in - foreach_dec (i - by,stop,by) vars body + foreach_dec (stop,i - by,by) vars body else vars let assert' b msg_opt = @@ -884,7 +630,7 @@ let assert' b msg_opt = | Just msg -> msg | Nothing -> "unspecified error" end in - if bitU_to_bool b then () else failwith msg + if b then () else failwith msg (* convert numbers unsafely to naturals *) @@ -902,8 +648,9 @@ let toNaturalFiveTup (n1,n2,n3,n4,n5) = toNatural n4, toNatural n5) - -type regfp = +(* Let the following types be generated by Sail per spec, using either bitlists + or machine words as bitvector representation *) +(*type regfp = | RFull of (string) | RSlice of (string * integer * integer) | RSliceBit of (string * integer) @@ -945,7 +692,7 @@ end let niafp_to_nia reginfo = function | NIAFP_successor -> NIA_successor - | NIAFP_concrete_address v -> NIA_concrete_address (address_of_bitv v) + | NIAFP_concrete_address v -> NIA_concrete_address (address_of_bitv (bits_of v)) | NIAFP_LR -> NIA_LR | NIAFP_CTR -> NIA_CTR | NIAFP_register r -> NIA_register (regfp_to_reg reginfo r) @@ -953,9 +700,7 @@ end let diafp_to_dia reginfo = function | DIAFP_none -> DIA_none - | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v) + | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv (bits_of v)) | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r) end - -let max = uncurry max -let min = uncurry min +*) diff --git a/src/gen_lib/sail_values_word.lem b/src/gen_lib/sail_values_word.lem deleted file mode 100644 index 048bf30a..00000000 --- a/src/gen_lib/sail_values_word.lem +++ /dev/null @@ -1,1030 +0,0 @@ -(* 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 - - -type ii = integer -type nn = natural - -val pow : integer -> integer -> integer -let pow m n = m ** (natFromInteger n) - -let rec replace bs ((n : integer),b') = match bs with - | [] -> [] - | b :: bs -> - if n = 0 then b' :: bs - else b :: replace bs (n - 1,b') - end - - -(*** Bits *) -type bitU = B0 | B1 | BU - -let showBitU = function - | B0 -> "O" - | B1 -> "I" - | BU -> "U" -end - -instance (Show bitU) - let show = showBitU -end - - -let bitU_to_bool = function - | B0 -> false - | B1 -> true - | BU -> failwith "to_bool applied to BU" - end - -let bit_lifted_of_bitU = function - | B0 -> Bitl_zero - | B1 -> Bitl_one - | BU -> Bitl_undef - end - -let bitU_of_bit = function - | Bitc_zero -> B0 - | Bitc_one -> B1 - end - -let bit_of_bitU = function - | B0 -> Bitc_zero - | B1 -> Bitc_one - | BU -> failwith "bit_of_bitU: BU" - end - -let bitU_of_bit_lifted = function - | Bitl_zero -> B0 - | Bitl_one -> B1 - | Bitl_undef -> BU - | Bitl_unknown -> failwith "bitU_of_bit_lifted Bitl_unknown" - end - -let bitwise_not_bit = function - | B1 -> B0 - | B0 -> B1 - | BU -> BU - end - -let inline (~) = bitwise_not_bit - -val is_one : integer -> bitU -let is_one i = - if i = 1 then B1 else B0 - -let bool_to_bitU b = if b then B1 else B0 - -let bitwise_binop_bit op = function - | (BU,_) -> BU (*Do we want to do this or to respect | of I and & of B0 rules?*) - | (_,BU) -> BU (*Do we want to do this or to respect | of I and & of B0 rules?*) - | (x,y) -> bool_to_bitU (op (bitU_to_bool x) (bitU_to_bool y)) - end - -val bitwise_and_bit : bitU * bitU -> bitU -let bitwise_and_bit = bitwise_binop_bit (&&) - -val bitwise_or_bit : bitU * bitU -> bitU -let bitwise_or_bit = bitwise_binop_bit (||) - -val bitwise_xor_bit : bitU * bitU -> bitU -let bitwise_xor_bit = bitwise_binop_bit xor - -val (&.) : bitU -> bitU -> bitU -let inline (&.) x y = bitwise_and_bit (x,y) - -val (|.) : bitU -> bitU -> bitU -let inline (|.) x y = bitwise_or_bit (x,y) - -val (+.) : bitU -> bitU -> bitU -let inline (+.) x y = bitwise_xor_bit (x,y) - - - -(*** Vectors *) - -(* element list * start * has increasing direction *) -type vector 'a = Vector of list 'a * integer * bool - -let showVector (Vector elems start inc) = - "Vector " ^ show elems ^ " " ^ show start ^ " " ^ show inc - -let get_dir (Vector _ _ ord) = ord -let get_start (Vector _ s _) = s -let get_elems (Vector elems _ _) = elems -let length (Vector bs _ _) = integerFromNat (length bs) - -instance forall 'a. Show 'a => (Show (vector 'a)) - let show = showVector -end - -let dir is_inc = if is_inc then D_increasing else D_decreasing -let bool_of_dir = function - | D_increasing -> true - | D_decreasing -> false - end - -(*** Vector operations *) - -val set_vector_start : forall 'a. integer -> vector 'a -> vector 'a -let set_vector_start new_start (Vector bs _ is_inc) = - Vector bs new_start is_inc - -let reset_vector_start v = - set_vector_start (if (get_dir v) then 0 else (length v - 1)) v - -let set_vector_start_to_length v = - set_vector_start (length v - 1) v - -let vector_concat (Vector bs start is_inc) (Vector bs' _ _) = - Vector (bs ++ bs') start is_inc - -let inline (^^) = vector_concat - -val sublist : forall 'a. list 'a -> (nat * nat) -> list 'a -let sublist xs (i,j) = - let (toJ,_suffix) = List.splitAt (j+1) xs in - let (_prefix,fromItoJ) = List.splitAt i toJ in - fromItoJ - -val update_sublist : forall 'a. list 'a -> (nat * nat) -> list 'a -> list 'a -let update_sublist xs (i,j) xs' = - let (toJ,suffix) = List.splitAt (j+1) xs in - let (prefix,_fromItoJ) = List.splitAt i toJ in - prefix ++ xs' ++ suffix - -val slice : forall 'a. vector 'a -> integer -> integer -> vector 'a -let slice (Vector bs start is_inc) i j = - let iN = natFromInteger i in - let jN = natFromInteger j in - let startN = natFromInteger start in - let subvector_bits = - sublist bs (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) in - Vector 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 slice_raw : forall 'a. vector 'a -> integer -> integer -> vector 'a -let slice_raw (Vector bs start is_inc) i j = - let iN = natFromInteger i in - let jN = natFromInteger j in - let bits = sublist bs (iN,jN) in - let len = integerFromNat (List.length bits) in - Vector bits (if is_inc then 0 else len - 1) is_inc - - -val update_aux : forall 'a. vector 'a -> integer -> integer -> list 'a -> vector 'a -let update_aux (Vector bs start is_inc) i j bs' = - let iN = natFromInteger i in - let jN = natFromInteger j in - let startN = natFromInteger start in - let bits = - (update_sublist bs) - (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) bs' in - Vector bits start is_inc - -val update : forall 'a. vector 'a -> integer -> integer -> vector 'a -> vector 'a -let update v i j (Vector bs' _ _) = - update_aux v i j bs' - -val access : forall 'a. vector 'a -> integer -> 'a -let access (Vector bs start is_inc) n = - if is_inc then List_extra.nth bs (natFromInteger (n - start)) - else List_extra.nth bs (natFromInteger (start - n)) - -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 - -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 'a => (Show (bitvector 'a)) - let show = showBitvector -end - -(*** 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. bitvector 'a -> integer -> integer -> bitvector 'a -> 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 -> bool -let bvaccess (Bitvector bs start is_inc) n = - 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 -> bool -> bitvector 'a -let bvupdate_pos v n b = - bvupdate_aux v n n (wordFromNatural (if b then 1 else 0)) - -(*** Bit vector operations *) - -let extract_only_bit (Bitvector elems _ _) = - let l = word_length elems in - if l = 1 then - 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 (Bitvector v _ _) = - if word_length v = 0 then - failwith "most_significant applied to empty vector" - else - msb v - -let bitwise_not_bitlist = List.map bitwise_not_bit - -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 (Bitvector v _ _) : integer = signedIntegerFromWord v - -let hardware_mod (a: integer) (b:integer) : integer = - if a < 0 && b < 0 - then (abs a) mod (abs b) - else if (a < 0 && b >= 0) - then (a mod b) - b - else a mod b - -(* There are different possible answers for integer divide regarding -rounding behaviour on negative operands. Positive operands always -round down so derive the one we want (trucation towards zero) from -that *) -let hardware_quot (a:integer) (b:integer) : integer = - let q = (abs a) / (abs b) in - if ((a<0) = (b<0)) then - q (* same sign -- result positive *) - else - ~q (* different sign -- result negative *) - -let quot_signed = hardware_quot - - -let signed_big = signed - -let to_num sign = if sign then signed else unsigned - -let max_64u = (integerPow 2 64) - 1 -let max_64 = (integerPow 2 63) - 1 -let min_64 = 0 - (integerPow 2 63) -let max_32u = (4294967295 : integer) -let max_32 = (2147483647 : integer) -let min_32 = (0 - 2147483648 : integer) -let max_8 = (127 : integer) -let min_8 = (0 - 128 : integer) -let max_5 = (31 : integer) -let min_5 = (0 - 32 : integer) - -let get_max_representable_in sign (n : integer) : integer = - if (n = 64) then match sign with | true -> max_64 | false -> max_64u end - else if (n=32) then match sign with | true -> max_32 | false -> max_32u end - else if (n=8) then max_8 - else if (n=5) then max_5 - else match sign with | true -> integerPow 2 ((natFromInteger n) -1) - | false -> integerPow 2 (natFromInteger n) - end - -let get_min_representable_in _ (n : integer) : integer = - if n = 64 then min_64 - else if n = 32 then min_32 - else if n = 8 then min_8 - else if n = 5 then min_5 - else 0 - (integerPow 2 (natFromInteger n)) - -val to_bin_aux : natural -> list bitU -let rec to_bin_aux x = - if x = 0 then [] - else (if x mod 2 = 1 then B1 else B0) :: to_bin_aux (x / 2) -let to_bin n = List.reverse (to_bin_aux n) - -val pad_zero : list bitU -> integer -> list bitU -let rec pad_zero bits n = - if n = 0 then bits else pad_zero (B0 :: bits) (n -1) - - -let rec add_one_bit_ignore_overflow_aux bits = match bits with - | [] -> [] - | B0 :: bits -> B1 :: bits - | B1 :: bits -> B0 :: add_one_bit_ignore_overflow_aux bits - | BU :: _ -> failwith "add_one_bit_ignore_overflow: undefined bit" -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 = 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?? -let to_vec_undef is_inc (len : integer) = - Vector (replicate (natFromInteger len) BU) (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 (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 (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 -let minus = integerMinus -let multiply = integerMult -let modulo = hardware_mod -let quot = hardware_quot -let power = integerPow - -(* TODO: this, and the definitions that use it, currently requires Size for - to_vec, which I'd rather avoid *) -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 * (bvlength l),n) - - -(* add_vec - * add_vec_signed - * minus_vec - * multiply_vec - * multiply_vec_signed - *) -let add_VVV = arith_op_vec integerAdd false 1 -let addS_VVV = arith_op_vec integerAdd true 1 -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 - -val arith_op_vec_range : forall 'a. Size 'a => (integer -> integer -> integer) -> bool -> integer -> bitvector 'a -> integer -> bitvector 'a -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)) - -(* add_vec_range - * add_vec_range_signed - * minus_vec_range - * mult_vec_range - * mult_vec_range_signed - *) -let add_VIV = arith_op_vec_range integerAdd false 1 -let addS_VIV = arith_op_vec_range integerAdd true 1 -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 - -val arith_op_range_vec : forall 'a. Size 'a => (integer -> integer -> integer) -> bool -> integer -> integer -> bitvector 'a -> bitvector 'a -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)) r - -(* add_range_vec - * add_range_vec_signed - * minus_range_vec - * mult_range_vec - * mult_range_vec_signed - *) -let add_IVV = arith_op_range_vec integerAdd false 1 -let addS_IVV = arith_op_range_vec integerAdd true 1 -let minus_IVV = arith_op_range_vec integerMinus false 1 -let mult_IVV = arith_op_range_vec integerMult false 2 -let multS_IVV = arith_op_range_vec integerMult true 2 - -let arith_op_range_vec_range op sign l r = op l (to_num sign r) - -(* add_range_vec_range - * add_range_vec_range_signed - * minus_range_vec_range - *) -let add_IVI = arith_op_range_vec_range integerAdd false -let addS_IVI = arith_op_range_vec_range integerAdd true -let minus_IVI = arith_op_range_vec_range integerMinus false - -let arith_op_vec_range_range op sign l r = op (to_num sign l) r - -(* add_vec_range_range - * add_vec_range_range_signed - * minus_vec_range_range - *) -let add_VII = arith_op_vec_range_range integerAdd false -let addS_VII = arith_op_vec_range_range integerAdd true -let minus_VII = arith_op_vec_range_range integerMinus false - - - -let arith_op_vec_vec_range op sign l r = - let (l',r') = (to_num sign l,to_num sign r) in - op l' r' - -(* add_vec_vec_range - * add_vec_vec_range_signed - *) -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) (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 (bvlength l * size,n) - -(* add_vec_bit - * add_vec_bit_signed - * minus_vec_bit_signed - *) -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 - -val arith_op_overflow_vec : forall 'a. Size 'a => (integer -> integer -> integer) -> bool -> integer -> bitvector 'a -> bitvector 'a -> bitvector 'a * 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 - let n = op l_sign r_sign in - let n_unsign = op l_unsign r_unsign in - let correct_size_num = to_vec is_inc (act_size,n) in - let one_more_size_u = to_vec is_inc (act_size + 1,n_unsign) in - let overflow = - if n <= get_max_representable_in sign len && - n >= get_min_representable_in sign len - then B0 else B1 in - let c_out = most_significant one_more_size_u in - (correct_size_num,overflow,c_out) - -(* add_overflow_vec - * add_overflow_vec_signed - * minus_overflow_vec - * minus_overflow_vec_signed - * mult_overflow_vec - * mult_overflow_vec_signed - *) -let addO_VVV = arith_op_overflow_vec integerAdd false 1 -let addSO_VVV = arith_op_overflow_vec integerAdd true 1 -let minusO_VVV = arith_op_overflow_vec integerMinus false 1 -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. Size 'a => (integer -> integer -> integer) -> bool -> integer -> - bitvector 'a -> bitU -> bitvector 'a * bitU * bool -let rec arith_op_overflow_vec_bit (op : integer -> integer -> integer) sign (size : integer) - (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 - | B1 -> (op l' 1, op l_u 1, true) - | B0 -> (l',l_u,false) - | BU -> failwith "arith_op_overflow_vec_bit applied to undefined bit" - end in -(* | _ -> assert false *) - let correct_size_num = to_vec is_inc (act_size,n) in - let one_larger = to_vec is_inc (act_size + 1,nu) in - let overflow = - if changed - then - if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size - then B0 else B1 - else B0 in - (correct_size_num,overflow,most_significant one_larger) - -(* add_overflow_vec_bit_signed - * minus_overflow_vec_bit - * minus_overflow_vec_bit_signed - *) -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 (Bitvector bs start is_inc,(n : integer)) = - let n = natFromInteger n in - match op with - | LL_shift (*"<<"*) -> - Bitvector (shiftLeft bs (naturalFromNat n)) start is_inc - | RR_shift (*">>"*) -> - Bitvector (shiftRight bs (naturalFromNat n)) start is_inc - | LLL_shift (*"<<<"*) -> - Bitvector (rotateLeft (naturalFromNat n) bs) start is_inc - end - -let bitwise_leftshift = shift_op_vec LL_shift (*"<<"*) -let bitwise_rightshift = shift_op_vec RR_shift (*">>"*) -let bitwise_rotate = shift_op_vec LLL_shift (*"<<<"*) - -let rec arith_op_no0 (op : integer -> integer -> integer) l r = - if r = 0 - then Nothing - else Just (op l r) -(* 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') = - match n with - | Just n' -> - (n' <= get_max_representable_in sign act_size && - n' >= get_min_representable_in sign act_size, n') - | _ -> (false,0) - end in - if representable - then to_vec is_inc (act_size,n') - else Vector (List.replicate (natFromInteger act_size) BU) start is_inc - -let mod_VVV = arith_op_vec_no0 hardware_mod false 1 -let quot_VVV = arith_op_vec_no0 hardware_quot false 1 -let quotS_VVV = arith_op_vec_no0 hardware_quot true 1 - -let arith_op_overflow_no0_vec op sign size ((Vector _ start is_inc) as l) r = - let rep_size = length r * size in - let act_size = length l * size in - let (l',r') = (to_num sign l,to_num sign r) in - let (l_u,r_u) = (to_num false l,to_num false r) in - let n = arith_op_no0 op l' r' in - let n_u = arith_op_no0 op l_u r_u in - let (representable,n',n_u') = - match (n, n_u) with - | (Just n',Just n_u') -> - ((n' <= get_max_representable_in sign rep_size && - n' >= (get_min_representable_in sign rep_size)), n', n_u') - | _ -> (true,0,0) - end in - let (correct_size_num,one_more) = - if representable then - (to_vec is_inc (act_size,n'),to_vec is_inc (act_size + 1,n_u')) - else - (Vector (List.replicate (natFromInteger act_size) BU) start is_inc, - Vector (List.replicate (natFromInteger (act_size + 1)) BU) start is_inc) in - let overflow = if representable then B0 else B1 in - (correct_size_num,overflow,most_significant one_more) - -let quotO_VVV = arith_op_overflow_no0_vec hardware_quot false 1 -let quotSO_VVV = arith_op_overflow_no0_vec hardware_quot true 1 - -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 [] - else xs ++ repeat xs (n-1) - -(* -let duplicate bit length = - Vector (repeat [bit] length) (if dir then 0 else length - 1) dir - *) - -let compare_op op (l,r) = bool_to_bitU (op l r) - -let lt = compare_op (<) -let gt = compare_op (>) -let lteq = compare_op (<=) -let gteq = compare_op (>=) - - -let compare_op_vec op sign (l,r) = - let (l',r') = (to_num sign l, to_num sign r) in - compare_op op (l',r') - -let lt_vec = compare_op_vec (<) true -let gt_vec = compare_op_vec (>) true -let lteq_vec = compare_op_vec (<=) true -let gteq_vec = compare_op_vec (>=) true - -let lt_vec_signed = compare_op_vec (<) true -let gt_vec_signed = compare_op_vec (>) true -let lteq_vec_signed = compare_op_vec (<=) true -let gteq_vec_signed = compare_op_vec (>=) true -let lt_vec_unsigned = compare_op_vec (<) false -let gt_vec_unsigned = compare_op_vec (>) false -let lteq_vec_unsigned = compare_op_vec (<=) false -let gteq_vec_unsigned = compare_op_vec (>=) false - -let compare_op_vec_range op sign (l,r) = - compare_op op ((to_num sign l),r) - -let lt_vec_range = compare_op_vec_range (<) true -let gt_vec_range = compare_op_vec_range (>) true -let lteq_vec_range = compare_op_vec_range (<=) true -let gteq_vec_range = compare_op_vec_range (>=) true - -let compare_op_range_vec op sign (l,r) = - compare_op op (l, (to_num sign r)) - -let lt_range_vec = compare_op_range_vec (<) true -let gt_range_vec = compare_op_range_vec (>) true -let lteq_range_vec = compare_op_range_vec (<=) true -let gteq_range_vec = compare_op_range_vec (>=) true - -let eq (l,r) = bool_to_bitU (l = r) -let eq_range (l,r) = bool_to_bitU (l = r) -let eq_vec (l,r) = bool_to_bitU (l = r) -let eq_bit (l,r) = bool_to_bitU (l = r) -let eq_vec_range (l,r) = eq (to_num false l,r) -let eq_range_vec (l,r) = eq (l, to_num false r) -let eq_vec_vec (l,r) = eq (to_num true l, to_num true r) - -let neq (l,r) = bitwise_not_bit (eq (l,r)) -let neq_bit (l,r) = bitwise_not_bit (eq_bit (l,r)) -let neq_range (l,r) = bitwise_not_bit (eq_range (l,r)) -let neq_vec (l,r) = bitwise_not_bit (eq_vec_vec (l,r)) -let neq_vec_range (l,r) = bitwise_not_bit (eq_vec_range (l,r)) -let neq_range_vec (l,r) = bitwise_not_bit (eq_range_vec (l,r)) - - -val make_indexed_vector : forall 'a. list (integer * 'a) -> 'a -> integer -> integer -> bool -> vector 'a -let make_indexed_vector entries default start length dir = - let length = natFromInteger length in - Vector (List.foldl replace (replicate length default) entries) start dir - -(* -val make_bit_vector_undef : integer -> vector bitU -let make_bitvector_undef length = - Vector (replicate (natFromInteger length) BU) 0 true - *) - -(* 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 - - -val byte_chunks : forall 'a. nat -> list 'a -> list (list 'a) -let rec byte_chunks n list = match (n,list) with - | (0,_) -> [] - | (n+1, a::b::c::d::e::f::g::h::rest) -> [a;b;c;d;e;f;g;h] :: byte_chunks n rest - | _ -> failwith "byte_chunks not given enough bits" -end - -val bitv_of_byte_lifteds : bool -> list Sail_impl_base.byte_lifted -> vector bitU -let bitv_of_byte_lifteds dir v = - let bits = foldl (fun x (Byte_lifted y) -> x ++ (List.map bitU_of_bit_lifted y)) [] v in - let len = integerFromNat (List.length bits) in - Vector bits (if dir then 0 else len - 1) dir - -val bitv_of_bytes : bool -> list Sail_impl_base.byte -> vector bitU -let bitv_of_bytes dir v = - let bits = foldl (fun x (Byte y) -> x ++ (List.map bitU_of_bit y)) [] v in - let len = integerFromNat (List.length bits) in - Vector bits (if dir then 0 else len - 1) dir - - -val byte_lifteds_of_bitv : vector bitU -> list byte_lifted -let byte_lifteds_of_bitv (Vector bits length is_inc) = - let bits = List.map bit_lifted_of_bitU bits in - byte_lifteds_of_bit_lifteds bits - -val bytes_of_bitv : vector bitU -> list byte -let bytes_of_bitv (Vector bits length is_inc) = - let bits = List.map bit_of_bitU bits in - bytes_of_bits bits - -val bit_lifteds_of_bitUs : list bitU -> list bit_lifted -let bit_lifteds_of_bitUs bits = List.map bit_lifted_of_bitU bits - -val bit_lifteds_of_bitv : vector bitU -> list bit_lifted -let bit_lifteds_of_bitv v = bit_lifteds_of_bitUs (get_elems v) - - -val address_lifted_of_bitv : vector bitU -> address_lifted -let address_lifted_of_bitv v = - let byte_lifteds = byte_lifteds_of_bitv v in - let maybe_address_integer = - match (maybe_all (List.map byte_of_byte_lifted byte_lifteds)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing - end in - Address_lifted byte_lifteds maybe_address_integer - -val address_of_bitv : vector bitU -> address -let address_of_bitv v = - let bytes = bytes_of_bitv v in - address_of_byte_list bytes - - - -(*** Registers *) - -type register_field = string -type register_field_index = string * (integer * integer) (* name, start and end *) - -type register = - | Register of string * (* name *) - integer * (* length *) - integer * (* start index *) - bool * (* is increasing *) - list register_field_index - | UndefinedRegister of integer (* length *) - | RegisterPair of register * register - -let name_of_reg = function - | Register name _ _ _ _ -> name - | UndefinedRegister _ -> failwith "name_of_reg UndefinedRegister" - | RegisterPair _ _ -> failwith "name_of_reg RegisterPair" -end - -let size_of_reg = function - | Register _ size _ _ _ -> size - | UndefinedRegister size -> size - | RegisterPair _ _ -> failwith "size_of_reg RegisterPair" -end - -let start_of_reg = function - | Register _ _ start _ _ -> start - | UndefinedRegister _ -> failwith "start_of_reg UndefinedRegister" - | RegisterPair _ _ -> failwith "start_of_reg RegisterPair" -end - -let is_inc_of_reg = function - | Register _ _ _ is_inc _ -> is_inc - | UndefinedRegister _ -> failwith "is_inc_of_reg UndefinedRegister" - | RegisterPair _ _ -> failwith "in_inc_of_reg RegisterPair" -end - -let dir_of_reg = function - | Register _ _ _ is_inc _ -> dir is_inc - | UndefinedRegister _ -> failwith "dir_of_reg UndefinedRegister" - | RegisterPair _ _ -> failwith "dir_of_reg RegisterPair" -end - -let size_of_reg_nat reg = natFromInteger (size_of_reg reg) -let start_of_reg_nat reg = natFromInteger (start_of_reg reg) - -val register_field_indices_aux : register -> register_field -> maybe (integer * integer) -let rec register_field_indices_aux register rfield = - match register with - | Register _ _ _ _ rfields -> List.lookup rfield rfields - | RegisterPair r1 r2 -> - let m_indices = register_field_indices_aux r1 rfield in - if isJust m_indices then m_indices else register_field_indices_aux r2 rfield - | UndefinedRegister _ -> Nothing - end - -val register_field_indices : register -> register_field -> integer * integer -let register_field_indices register rfield = - match register_field_indices_aux register rfield with - | Just indices -> indices - | Nothing -> failwith "Invalid register/register-field combination" - end - -let register_field_indices_nat reg regfield= - let (i,j) = register_field_indices reg regfield in - (natFromInteger i,natFromInteger j) - -let rec external_reg_value reg_name v = - let (internal_start, external_start, direction) = - match reg_name with - | Reg _ start size dir -> - (start, (if dir = D_increasing then start else (start - (size +1))), dir) - | Reg_slice _ reg_start dir (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) - | Reg_field _ reg_start dir _ (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) - | Reg_f_slice _ reg_start dir _ _ (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) - end in - let bits = bit_lifteds_of_bitv v in - <| rv_bits = bits; - rv_dir = direction; - rv_start = external_start; - rv_start_internal = internal_start |> - -val internal_reg_value : register_value -> vector bitU -let internal_reg_value v = - Vector (List.map bitU_of_bit_lifted v.rv_bits) - (integerFromNat v.rv_start_internal) - (v.rv_dir = D_increasing) - - -let external_slice (d:direction) (start:nat) ((i,j):(nat*nat)) = - match d with - (*This is the case the thread/concurrecny model expects, so no change needed*) - | D_increasing -> (i,j) - | D_decreasing -> let slice_i = start - i in - let slice_j = (i - j) + slice_i in - (slice_i,slice_j) - end - -let external_reg_whole reg = - Reg (name_of_reg reg) (start_of_reg_nat reg) (size_of_reg_nat reg) (dir_of_reg reg) - -let external_reg_slice reg (i,j) = - let start = start_of_reg_nat reg in - let dir = dir_of_reg reg in - Reg_slice (name_of_reg reg) start dir (external_slice dir start (i,j)) - -let external_reg_field_whole reg rfield = - let (m,n) = register_field_indices_nat reg rfield in - let start = start_of_reg_nat reg in - let dir = dir_of_reg reg in - Reg_field (name_of_reg reg) start dir rfield (external_slice dir start (m,n)) - -let external_reg_field_slice reg rfield (i,j) = - let (m,n) = register_field_indices_nat reg rfield in - let start = start_of_reg_nat reg in - let dir = dir_of_reg reg in - Reg_f_slice (name_of_reg reg) start dir rfield - (external_slice dir start (m,n)) - (external_slice dir start (i,j)) - -let external_mem_value v = - byte_lifteds_of_bitv v $> List.reverse - -let internal_mem_value direction bytes = - List.reverse bytes $> bitv_of_byte_lifteds direction - - - - - -val foreach_inc : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> 'vars) -> 'vars -let rec foreach_inc (i,stop,by) vars body = - if i <= stop - then let vars = body i vars in - foreach_inc (i + by,stop,by) vars body - else vars - -val foreach_dec : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> 'vars) -> 'vars -let rec foreach_dec (i,stop,by) vars body = - if i >= stop - then let vars = body i vars in - foreach_dec (i - by,stop,by) vars body - else vars - -let assert' b msg_opt = - let msg = match msg_opt with - | Just msg -> msg - | Nothing -> "unspecified error" - end in - if bitU_to_bool b then () else failwith msg - -(* convert numbers unsafely to naturals *) - -class (ToNatural 'a) val toNatural : 'a -> natural end -(* eta-expanded for Isabelle output, otherwise it breaks *) -instance (ToNatural integer) let toNatural = (fun n -> naturalFromInteger n) end -instance (ToNatural int) let toNatural = (fun n -> naturalFromInt n) end -instance (ToNatural nat) let toNatural = (fun n -> naturalFromNat n) end -instance (ToNatural natural) let toNatural = (fun n -> n) end - -let toNaturalFiveTup (n1,n2,n3,n4,n5) = - (toNatural n1, - toNatural n2, - toNatural n3, - toNatural n4, - toNatural n5) - - -type regfp = - | RFull of (string) - | RSlice of (string * integer * integer) - | RSliceBit of (string * integer) - | RField of (string * string) - -type niafp = - | NIAFP_successor - | NIAFP_concrete_address of vector bitU - | NIAFP_LR - | NIAFP_CTR - | NIAFP_register of regfp - -(* only for MIPS *) -type diafp = - | DIAFP_none - | DIAFP_concrete of vector bitU - | DIAFP_reg of regfp - -let regfp_to_reg (reg_info : string -> maybe string -> (nat * nat * direction * (nat * nat))) = function - | RFull name -> - let (start,length,direction,_) = reg_info name Nothing in - Reg name start length direction - | RSlice (name,i,j) -> - let i = natFromInteger i in - let j = natFromInteger j in - let (start,length,direction,_) = reg_info name Nothing in - let slice = external_slice direction start (i,j) in - Reg_slice name start direction slice - | RSliceBit (name,i) -> - let i = natFromInteger i in - let (start,length,direction,_) = reg_info name Nothing in - let slice = external_slice direction start (i,i) in - Reg_slice name start direction slice - | RField (name,field_name) -> - let (start,length,direction,span) = reg_info name (Just field_name) in - let slice = external_slice direction start span in - Reg_field name start direction field_name slice -end - -let niafp_to_nia reginfo = function - | NIAFP_successor -> NIA_successor - | NIAFP_concrete_address v -> NIA_concrete_address (address_of_bitv v) - | NIAFP_LR -> NIA_LR - | NIAFP_CTR -> NIA_CTR - | NIAFP_register r -> NIA_register (regfp_to_reg reginfo r) -end - -let diafp_to_dia reginfo = function - | DIAFP_none -> DIA_none - | 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 88e29522..2fff7344 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -6,45 +6,77 @@ open import Sail_values type memstate = map integer memory_byte type tagstate = map integer bitU -type regstate = map string (vector bitU) - -type sequential_state = <| regstate : regstate; - memstate : memstate; - tagstate : tagstate; - write_ea : maybe (write_kind * integer * integer); - last_exclusive_operation_was_load : bool|> - -type M 'a = sequential_state -> list ((either 'a string) * sequential_state) - -val return : forall 'a. 'a -> M 'a +(* type regstate = map string (vector bitU) *) + +type sequential_state 'regs = + <| regstate : 'regs; + memstate : memstate; + tagstate : tagstate; + write_ea : maybe (write_kind * integer * integer); + last_exclusive_operation_was_load : bool|> + +(* State, nondeterminism and exception monad with result type 'a + and exception type 'e. *) +type ME 'regs 'a 'e = sequential_state 'regs -> list ((either 'a 'e) * sequential_state 'regs) + +(* By default, we use strings to distinguish between different types of exceptions *) +type M 'regs 'a = ME 'regs 'a string + +(* For early return, we abuse exceptions by throwing and catching + the return value. The exception type is "either 'r string", where "Right e" + represents a proper exception and "Left r" an early return of value "r". *) +type MR 'regs 'a 'r = ME 'regs 'a (either 'r string) + +val liftR : forall 'a 'r 'regs. M 'regs 'a -> MR 'regs 'a 'r +let liftR m s = List.map (function + | (Left a, s') -> (Left a, s') + | (Right e, s') -> (Right (Right e), s') + end) (m s) + +val return : forall 'regs 'a 'e. 'a -> ME 'regs 'a 'e let return a s = [(Left a,s)] -val bind : forall 'a 'b. M 'a -> ('a -> M 'b) -> M 'b -let bind m f (s : sequential_state) = +val bind : forall 'regs 'a 'b 'e. ME 'regs 'a 'e -> ('a -> ME 'regs 'b 'e) -> ME 'regs 'b 'e +let bind m f (s : sequential_state 'regs) = List.concatMap (function | (Left a, s') -> f a s' | (Right e, s') -> [(Right e, s')] end) (m s) let inline (>>=) = bind -val (>>): forall 'b. M unit -> M 'b -> M 'b +val (>>): forall 'regs 'b 'e. ME 'regs unit 'e -> ME 'regs 'b 'e -> ME 'regs 'b 'e let inline (>>) m n = m >>= fun _ -> n -val exit : forall 'e 'a. 'e -> M 'a -let exit _ s = [(Right "exit",s)] +val exit : forall 'regs 'e 'a. 'e -> M 'regs 'a +let exit _ s = [(Right "exit", s)] +val assert_exp : forall 'regs. bool -> string -> M 'regs unit +let assert_exp exp msg s = if exp then [(Left (), s)] else [(Right msg, s)] + +val early_return : forall 'regs 'a 'r. 'r -> MR 'regs 'a 'r +let early_return r s = [(Right (Left r), s)] + +val catch_early_return : forall 'regs 'a. MR 'regs 'a 'a -> M 'regs 'a +let catch_early_return m s = + List.map + (function + | (Right (Left a), s') -> (Left a, s') + | (Right (Right e), s') -> (Right e, s') + | (Left a, s') -> (Left a, s') + end) (m s) val range : integer -> integer -> list integer -let rec range i j = - if i = j then [i] +let rec range i j = + if j < i then [] + else if i = j then [i] else i :: range (i+1) j -val get_reg : sequential_state -> string -> vector bitU -let get_reg state reg = Map_extra.find reg state.regstate +val get_reg : forall 'regs 'a. sequential_state 'regs -> register_ref 'regs 'a -> 'a +let get_reg state reg = reg.read_from state.regstate -val set_reg : sequential_state -> string -> vector bitU -> sequential_state -let set_reg state reg bitv = - <| state with regstate = Map.insert reg bitv state.regstate |> +val set_reg : forall 'regs 'a. sequential_state 'regs -> register_ref 'regs 'a -> 'a -> sequential_state 'regs +let set_reg state reg v = + <| state with regstate = reg.write_to state.regstate v |> let is_exclusive = function @@ -65,10 +97,18 @@ end val read_mem : bool -> read_kind -> vector bitU -> integer -> M (vector bitU) 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 = of_bits (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 + | Sail_impl_base.Read_acquire -> false + | Sail_impl_base.Read_exclusive -> true + | Sail_impl_base.Read_exclusive_acquire -> true + | Sail_impl_base.Read_stream -> false + end in if is_exclusive read_kind then [(Left value, <| state with last_exclusive_operation_was_load = true |>)] @@ -77,42 +117,50 @@ 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 'regs 'a. Bitvector 'a => bool -> read_kind -> 'a -> M 'regs 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 end in + let is_exclusive = match read_kind with + | Sail_impl_base.Read_plain -> false + | Sail_impl_base.Read_reserve -> true + | Sail_impl_base.Read_acquire -> false + | Sail_impl_base.Read_exclusive -> true + | Sail_impl_base.Read_exclusive_acquire -> true + | Sail_impl_base.Read_stream -> false + end in + (* TODO Should reading a tag set the exclusive flag? *) if is_exclusive read_kind then [(Left tag, <| state with last_exclusive_operation_was_load = true |>)] else [(Left tag, state)] -val excl_result : unit -> M bool +val excl_result : forall 'regs. unit -> M 'regs bool let excl_result () state = let success = (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 'regs 'a. Bitvector 'a => write_kind -> 'a -> integer -> M 'regs unit let write_mem_ea write_kind addr sz state = - let addr = integer_of_address (address_of_bitv addr) in - [(Left (), <| state with write_ea = Just (write_kind,addr,sz) |>)] + [(Left (), <| state with write_ea = Just (write_kind,unsigned addr,sz) |>)] -val write_mem_val : vector bitU -> M bool +val write_mem_val : forall 'a 'regs 'b. Bitvector 'a => 'a -> M 'regs 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 (bits_of 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 [(Left true, <| state with memstate = memstate |>)] -val write_tag : bitU -> M bool +val write_tag : forall 'regs. bitU -> M 'regs bool let write_tag t state = let (write_kind,addr,sz) = match state.write_ea with | Nothing -> failwith "write ea has not been announced yet" @@ -121,24 +169,26 @@ 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 'regs 'a. register_ref 'regs 'a -> M 'regs 'a let read_reg reg state = - let v = Map_extra.find (name_of_reg reg) state.regstate in + let v = reg.read_from state.regstate in + [(Left 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 let read_reg_bitfield reg regfield = let (i,_) = register_field_indices reg regfield in - read_reg_bit reg i + read_reg_bit reg i *) -val write_reg : register -> vector bitU -> M unit +let reg_deref = read_reg + +val write_reg : forall 'regs 'a. register_ref 'regs 'a -> 'a -> M 'regs 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 = @@ -158,34 +208,120 @@ let write_reg_field_range reg regfield i j v = let new_field_value = update current_field_value i j v in write_reg_field reg regfield new_field_value +val update_reg : forall 'regs 'a 'b. register_ref 'regs 'a -> ('a -> 'b -> 'a) -> 'b -> M 'regs unit +let update_reg reg f v state = + let current_value = get_reg state reg in + let new_value = f current_value v in + [(Left (), set_reg state reg new_value)] + +let write_reg_field reg regfield = update_reg reg regfield.set_field -val barrier : barrier_kind -> M unit +val update_reg_range : forall 'regs 'a 'b. Bitvector 'a, Bitvector 'b => register_ref 'regs 'a -> integer -> integer -> 'a -> 'b -> 'a +let update_reg_range reg i j reg_val new_val = set_bits (reg.reg_is_inc) (reg.reg_start) reg_val i j (bits_of new_val) +let write_reg_range reg i j = update_reg reg (update_reg_range reg i j) + +let update_reg_pos reg i reg_val x = update_pos reg_val i x +let write_reg_pos reg i = update_reg reg (update_reg_pos reg i) + +let update_reg_bit reg i reg_val bit = set_bit (reg.reg_is_inc) (reg.reg_start) reg_val i (to_bitU bit) +let write_reg_bit reg i = update_reg reg (update_reg_bit reg i) + +let update_reg_field_range regfield i j reg_val new_val = + let current_field_value = regfield.get_field reg_val in + let new_field_value = set_bits (regfield.field_is_inc) (regfield.field_start) current_field_value i j (bits_of new_val) in + regfield.set_field reg_val new_field_value +let write_reg_field_range reg regfield i j = update_reg reg (update_reg_field_range regfield i j) + +let update_reg_field_pos regfield i reg_val x = + let current_field_value = regfield.get_field reg_val in + let new_field_value = update_pos current_field_value i x in + regfield.set_field reg_val new_field_value +let write_reg_field_pos reg regfield i = update_reg reg (update_reg_field_pos regfield i) + +let update_reg_field_bit regfield i reg_val bit = + let current_field_value = regfield.get_field reg_val in + let new_field_value = set_bit (regfield.field_is_inc) (regfield.field_start) current_field_value i (to_bitU bit) in + regfield.set_field reg_val new_field_value +let write_reg_field_bit reg regfield i = update_reg reg (update_reg_field_bit regfield i) + +val barrier : forall 'regs. barrier_kind -> M 'regs unit let barrier _ = return () -val footprint : M unit -let footprint = return () +val footprint : forall 'regs. M 'regs unit +let footprint s = return () s -val foreachM_inc : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> M 'vars) -> M 'vars +val foreachM_inc : forall 'regs 'vars 'e. (integer * integer * integer) -> 'vars -> + (integer -> 'vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e let rec foreachM_inc (i,stop,by) vars body = - if i <= stop + if (by > 0 && i <= stop) || (by < 0 && stop <= i) then body i vars >>= fun vars -> foreachM_inc (i + by,stop,by) vars body else return vars -val foreachM_dec : forall 'vars. (integer * integer * integer) -> 'vars -> - (integer -> 'vars -> M 'vars) -> M 'vars -let rec foreachM_dec (i,stop,by) vars body = - if i >= stop +val foreachM_dec : forall 'regs 'vars 'e. (integer * integer * integer) -> 'vars -> + (integer -> 'vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e +let rec foreachM_dec (stop,i,by) vars body = + if (by > 0 && i >= stop) || (by < 0 && stop >= i) then body i vars >>= fun vars -> - foreachM_dec (i - by,stop,by) vars body + foreachM_dec (stop,i - by,by) vars body + else return vars + +val while_PP : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars +let rec while_PP vars cond body = + if cond vars then while_PP (body vars) cond body else vars + +val while_PM : forall 'regs 'vars 'e. 'vars -> ('vars -> bool) -> + ('vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e +let rec while_PM vars cond body = + if cond vars then + body vars >>= fun vars -> while_PM vars cond body + else return vars + +val while_MP : forall 'regs 'vars 'e. 'vars -> ('vars -> ME 'regs bool 'e) -> + ('vars -> 'vars) -> ME 'regs 'vars 'e +let rec while_MP vars cond body = + cond vars >>= fun cond_val -> + if cond_val then while_MP (body vars) cond body else return vars + +val while_MM : forall 'regs 'vars 'e. 'vars -> ('vars -> ME 'regs bool 'e) -> + ('vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e +let rec while_MM vars cond body = + cond vars >>= fun cond_val -> + if cond_val then + body vars >>= fun vars -> while_MM vars cond body else return vars -let write_two_regs r1 r2 vec = +val until_PP : forall 'vars. 'vars -> ('vars -> bool) -> ('vars -> 'vars) -> 'vars +let rec until_PP vars cond body = + let vars = body vars in + if (cond vars) then vars else until_PP (body vars) cond body + +val until_PM : forall 'regs 'vars 'e. 'vars -> ('vars -> bool) -> + ('vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e +let rec until_PM vars cond body = + body vars >>= fun vars -> + if (cond vars) then return vars else until_PM vars cond body + +val until_MP : forall 'regs 'vars 'e. 'vars -> ('vars -> ME 'regs bool 'e) -> + ('vars -> 'vars) -> ME 'regs 'vars 'e +let rec until_MP vars cond body = + let vars = body vars in + cond vars >>= fun cond_val -> + if cond_val then return vars else until_MP vars cond body + +val until_MM : forall 'regs 'vars 'e. 'vars -> ('vars -> ME 'regs bool 'e) -> + ('vars -> ME 'regs 'vars 'e) -> ME 'regs 'vars 'e +let rec until_MM vars cond body = + body vars >>= fun vars -> + cond vars >>= fun cond_val -> + if cond_val then return vars else until_MM vars cond body + +(*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 @@ -204,4 +340,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..2764c30b 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -40,14 +40,45 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal open Ast +open Util +open Ast_util +open Big_int -type kind = Type_internal.kind -type typ = Type_internal.t +let opt_undefined_gen = ref false +let opt_magic_hash = ref false + +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 +type envs = Nameset.t * kind Envmap.t * order type 'a envs_out = 'a * envs let id_to_string (Id_aux(id,l)) = @@ -86,11 +117,22 @@ let typ_error l msg opt_id opt_var opt_kind = | None,Some(v),None -> ": " ^ (var_to_string v) | None,None,Some(kind) -> " " ^ (kind_to_string kind) | _ -> ""))) - -let to_ast_id (Parse_ast.Id_aux(id,l)) = - Id_aux( (match id with - | Parse_ast.Id(x) -> Id(x) - | Parse_ast.DeIid(x) -> DeIid(x)) , l) + +let string_of_parse_id_aux = function + | Parse_ast.Id v -> v + | Parse_ast.DeIid v -> v + +let string_contains str char = + try (String.index str char; true) with + | Not_found -> false + +let to_ast_id (Parse_ast.Id_aux(id, l)) = + if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) + then typ_error l "Identifier contains hash character" None None None + else Id_aux ((match id with + | Parse_ast.Id(x) -> Id(x) + | Parse_ast.DeIid(x) -> DeIid(x)), + l) let to_ast_var (Parse_ast.Kid_aux(Parse_ast.Var v,l)) = Kid_aux(Var v,l) @@ -99,7 +141,6 @@ let to_ast_base_kind (Parse_ast.BK_aux(k,l')) = | Parse_ast.BK_type -> BK_aux(BK_type,l'), { k = K_Typ} | Parse_ast.BK_nat -> BK_aux(BK_nat,l'), { k = K_Nat } | Parse_ast.BK_order -> BK_aux(BK_order,l'), { k = K_Ord } - | Parse_ast.BK_effect -> BK_aux(BK_effect,l'), { k = K_Efct } let to_ast_kind (k_env : kind Envmap.t) (Parse_ast.K_aux(Parse_ast.K_kind(klst),l)) : (Ast.kind * kind) = match klst with @@ -118,16 +159,8 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) match t with | Parse_ast.ATyp_aux(t,l) -> Typ_aux( (match t with - | Parse_ast.ATyp_id(id) -> - let id = to_ast_id id in - 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) - | Parse_ast.ATyp_var(v) -> + | Parse_ast.ATyp_id(id) -> Typ_id (to_ast_id id) + | Parse_ast.ATyp_var(v) -> let v = to_ast_var v in let mk = Envmap.apply k_env (var_to_string v) in (match mk with @@ -144,12 +177,12 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) let make_r bot top = match bot,top with | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant b,_),Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,l) -> - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant ((t-b)+1),l) + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (add_big_int (sub_big_int t b) unit_big_int),l) | bot,(Parse_ast.ATyp_aux(_,l) as top) -> Parse_ast.ATyp_aux((Parse_ast.ATyp_sum ((Parse_ast.ATyp_aux (Parse_ast.ATyp_sum (top, - Parse_ast.ATyp_aux(Parse_ast.ATyp_constant 1,Parse_ast.Unknown)), + Parse_ast.ATyp_aux(Parse_ast.ATyp_constant unit_big_int,Parse_ast.Unknown)), Parse_ast.Unknown)), (Parse_ast.ATyp_aux ((Parse_ast.ATyp_neg bot),Parse_ast.Unknown)))), l) in let base = to_ast_nexp k_env b in @@ -165,9 +198,9 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) | Parse_ast.ATyp_app(Parse_ast.Id_aux(Parse_ast.Id "vector_sugar_r",il), [b;r;ord;ti]) -> let make_sub_one t = match t with - | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (t-1),l) + | Parse_ast.ATyp_aux(Parse_ast.ATyp_constant t,_) -> Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (sub_big_int t unit_big_int),l) | t -> (Parse_ast.ATyp_aux - (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (-1),Parse_ast.Unknown)), + (Parse_ast.ATyp_sum (t, Parse_ast.ATyp_aux(Parse_ast.ATyp_constant (minus_big_int unit_big_int),Parse_ast.Unknown)), Parse_ast.Unknown)) in let (base,rise) = match def_ord with | Ord_aux(Ord_inc,dl) -> (to_ast_nexp k_env b), (to_ast_nexp k_env r) @@ -189,53 +222,40 @@ let rec to_ast_typ (k_env : kind Envmap.t) (def_ord : order) (t: Parse_ast.atyp) 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) + | Parse_ast.ATyp_exist (kids, nc, atyp) -> + let kids = List.map to_ast_var kids in + let k_env = List.fold_left Envmap.insert k_env (List.map (fun kid -> (var_to_string kid, {k=K_Nat})) kids) in + let exist_typ = to_ast_typ k_env def_ord atyp in + Typ_exist (kids, to_ast_nexp_constraint k_env nc, exist_typ) | _ -> typ_error l "Required an item of kind Type, encountered an illegal form for this kind" None None None ), l) and to_ast_nexp (k_env : kind Envmap.t) (n: Parse_ast.atyp) : Ast.nexp = - (*let _ = Printf.eprintf "to_ast_nexp\n" in*) match n with | Parse_ast.ATyp_aux(t,l) -> (match t with - | Parse_ast.ATyp_id(i) -> - let i = to_ast_id i in - let v = id_to_string i in - let mk = Envmap.apply k_env v 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 an identifier with kind Nat, encountered " (Some i) None (Some k)),l) - | None -> typ_error l "Encountered an unbound variable" (Some i) None None) - | Parse_ast.ATyp_var(v) -> - let v = to_ast_var v in - let mk = Envmap.apply k_env (var_to_string v) in - (*let _ = - Envmap.iter (fun v' k -> Printf.eprintf "%s -> %s, %s =? %b\n" - v' (kind_to_string k) (var_to_string v) ((var_to_string v) = v') ) k_env 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) - | Parse_ast.ATyp_constant(i) -> Nexp_aux(Nexp_constant(i),l) - | Parse_ast.ATyp_sum(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux(Nexp_sum(n1,n2),l) - | Parse_ast.ATyp_exp(t1) -> Nexp_aux(Nexp_exp(to_ast_nexp k_env t1),l) - | Parse_ast.ATyp_neg(t1) -> Nexp_aux(Nexp_neg(to_ast_nexp k_env t1),l) - | Parse_ast.ATyp_times(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux(Nexp_times(n1,n2),l) - | Parse_ast.ATyp_minus(t1,t2) -> - let n1 = to_ast_nexp k_env t1 in - let n2 = to_ast_nexp k_env t2 in - Nexp_aux(Nexp_minus(n1,n2),l) - | _ -> typ_error l "Requred an item of kind Nat, encountered an illegal form for this kind" None None None) - + | Parse_ast.ATyp_id i -> Nexp_aux (Nexp_id (to_ast_id i), l) + | Parse_ast.ATyp_var v -> Nexp_aux (Nexp_var (to_ast_var v), l) + | Parse_ast.ATyp_constant i -> Nexp_aux (Nexp_constant i, l) + | Parse_ast.ATyp_sum (t1, t2) -> + let n1 = to_ast_nexp k_env t1 in + let n2 = to_ast_nexp k_env t2 in + Nexp_aux (Nexp_sum (n1, n2), l) + | Parse_ast.ATyp_exp t1 -> Nexp_aux(Nexp_exp(to_ast_nexp k_env t1),l) + | Parse_ast.ATyp_neg t1 -> Nexp_aux(Nexp_neg(to_ast_nexp k_env t1),l) + | Parse_ast.ATyp_times (t1, t2) -> + let n1 = to_ast_nexp k_env t1 in + let n2 = to_ast_nexp k_env t2 in + Nexp_aux (Nexp_times (n1, n2), l) + | Parse_ast.ATyp_minus (t1, t2) -> + let n1 = to_ast_nexp k_env t1 in + let n2 = to_ast_nexp k_env t2 in + Nexp_aux (Nexp_minus (n1, n2), l) + | Parse_ast.ATyp_app (id, ts) -> + let nexps = List.map (to_ast_nexp k_env) ts in + Nexp_aux (Nexp_app (to_ast_id id, nexps), l) + | _ -> typ_error l "Required an item of kind Nat, encountered an illegal form for this kind" None None None) + and to_ast_order (k_env : kind Envmap.t) (def_ord : order) (o: Parse_ast.atyp) : Ast.order = match o with | Parse_ast.ATyp_aux(t,l) -> @@ -299,18 +319,21 @@ and to_ast_typ_arg (k_env : kind Envmap.t) (def_ord : order) (kind : kind) (arg | K_Typ -> Typ_arg_typ (to_ast_typ k_env def_ord arg) | K_Nat -> Typ_arg_nexp (to_ast_nexp k_env arg) | K_Ord -> Typ_arg_order (to_ast_order k_env def_ord arg) - | K_Efct -> Typ_arg_effect (to_ast_effects k_env arg) - | _ -> raise (Reporting_basic.err_unreachable l "To_ast_typ_arg received Lam kind or infer kind")), + | _ -> raise (Reporting_basic.err_unreachable l ("To_ast_typ_arg received Lam kind or infer kind: " ^ kind_to_string kind))), l) -let to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) : n_constraint = - match c with +and 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) -> + | Parse_ast.NC_equal(t1,t2) -> let n1 = to_ast_nexp k_env t1 in let n2 = to_ast_nexp k_env t2 in - NC_fixed(n1,n2) + NC_equal(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 @@ -319,9 +342,15 @@ let to_ast_nexp_constraint (k_env : kind Envmap.t) (c : Parse_ast.n_constraint) let n1 = to_ast_nexp k_env t1 in 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) + | Parse_ast.NC_set(id,bounds) -> + NC_set(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) + | Parse_ast.NC_true -> NC_true + | Parse_ast.NC_false -> NC_false + ), 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 +421,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) @@ -403,6 +433,7 @@ let rec to_ast_pat (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.P_aux(pa | Parse_ast.P_as(pat,id) -> P_as(to_ast_pat k_env def_ord pat,to_ast_id id) | Parse_ast.P_typ(typ,pat) -> P_typ(to_ast_typ k_env def_ord typ,to_ast_pat k_env def_ord pat) | Parse_ast.P_id(id) -> P_id(to_ast_id id) + | Parse_ast.P_var (pat, kid) -> P_var (to_ast_pat k_env def_ord pat, to_ast_var kid) | Parse_ast.P_app(id,pats) -> if pats = [] then P_id (to_ast_id id) @@ -410,27 +441,24 @@ 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) -> - let typsch, k_env, _ = to_ast_typschm k_env def_ord typschm in - 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)) - -and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) : Parse_ast.exp) : tannot exp = + | Parse_ast.LB_val(pat,exp) -> + LB_val(to_ast_pat k_env def_ord pat, to_ast_exp k_env def_ord exp) + ), (l,())) + +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) -> @@ -452,20 +480,10 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_if(e1,e2,e3) -> E_if(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2, to_ast_exp k_env def_ord e3) | Parse_ast.E_for(id,e1,e2,e3,atyp,e4) -> E_for(to_ast_id id,to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2, - to_ast_exp k_env def_ord e3,to_ast_order k_env def_ord atyp, to_ast_exp k_env def_ord e4) - | Parse_ast.E_vector(exps) -> - (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))) - | 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))) - | _ -> raise (Reporting_basic.err_unreachable l "to_ast_iexps didn't throw error")) + to_ast_exp k_env def_ord e3,to_ast_order k_env def_ord atyp, to_ast_exp k_env def_ord e4) + | Parse_ast.E_loop (Parse_ast.While, e1, e2) -> E_loop (While, to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) + | Parse_ast.E_loop (Parse_ast.Until, e1, e2) -> E_loop (Until, to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) + | Parse_ast.E_vector(exps) -> E_vector(List.map (to_ast_exp k_env def_ord) exps) | 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) -> E_vector_subrange(to_ast_exp k_env def_ord vex, to_ast_exp k_env def_ord exp1, to_ast_exp k_env def_ord exp2) @@ -477,22 +495,28 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_vector_append(e1,e2) -> E_vector_append(to_ast_exp k_env def_ord e1,to_ast_exp k_env def_ord e2) | Parse_ast.E_list(exps) -> E_list(List.map (to_ast_exp k_env def_ord) exps) | Parse_ast.E_cons(e1,e2) -> E_cons(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_record _ -> raise (Reporting_basic.err_unreachable l "parser generated an E_record") + | Parse_ast.E_record fexps -> + (match to_ast_fexps true k_env def_ord fexps with + | Some fexps -> E_record fexps + | None -> raise (Reporting_basic.err_unreachable l "to_ast_fexps with true returned none")) | Parse_ast.E_record_update(exp,fexps) -> (match to_ast_fexps true k_env def_ord fexps with | Some(fexps) -> E_record_update(to_ast_exp k_env def_ord exp, fexps) | _ -> raise (Reporting_basic.err_unreachable l "to_ast_fexps with true returned none")) | Parse_ast.E_field(exp,id) -> E_field(to_ast_exp k_env def_ord exp, to_ast_id id) | Parse_ast.E_case(exp,pexps) -> E_case(to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) + | Parse_ast.E_try (exp, pexps) -> E_try (to_ast_exp k_env def_ord exp, List.map (to_ast_case k_env def_ord) pexps) | 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_throw exp -> E_throw (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 +544,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 +567,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,32 +582,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 = - match exps with - | [] -> Some([]) - | iexp::exps -> (match to_iexp_try k_env def_ord iexp with - | Some(iexp),None -> - (match to_ast_iexps fail_on_error k_env def_ord exps with - | Some(iexps) -> Some(iexp::iexps) - | _ -> None) - | None,Some(l,msg) -> - if fail_on_error - 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) = - match exp with - | Parse_ast.E_app_infix(left,op,r) -> - (match left,op with - | Parse_ast.E_aux(Parse_ast.E_lit(Parse_ast.L_aux (Parse_ast.L_num i,ll)),cl), Parse_ast.Id_aux(Parse_ast.Id("="),leq) -> - Some(i,to_ast_exp k_env def_ord r),None - | Parse_ast.E_aux(_,li), Parse_ast.Id_aux (Parse_ast.Id("="),leq) -> - None,(Some(li,"Expected a constant number to begin this indexed vector assignemnt")) - | Parse_ast.E_aux(_,cl), Parse_ast.Id_aux(_,leq) -> - 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) : default_spec envs_out = match default with | Parse_ast.DT_aux(df,l) -> (match df with @@ -604,21 +605,13 @@ 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) - | Parse_ast.VS_extern_spec(ts,id,s) -> + | Parse_ast.VS_val_spec(ts,id,ext,is_cast) -> 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) - | 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_val_spec(typsch,to_ast_id id,ext,is_cast),(l,())),(names,k_env,default_order)) let to_ast_namescm (Parse_ast.Name_sect_aux(ns,l)) = Name_sect_aux( @@ -645,7 +638,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 +646,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 +659,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 +669,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 +679,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 +688,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 @@ -706,67 +699,17 @@ let to_ast_kdef (names,k_env,def_ord) (td:Parse_ast.kind_def) : (tannot kind_def let key = id_to_string id in let (kind,k) = to_ast_kind k_env kind in (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 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) | K_Nat -> let kd_nabrv = (match typschm with | 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 - ) - | Parse_ast.KD_record(kind,id,name_scm_opt,typq,fields,_) -> - let id = to_ast_id id in - let key = id_to_string id in - 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 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) - | Parse_ast.KD_variant(kind,id,name_scm_opt,typq,arms,_) -> - let id = to_ast_id id in - let key = id_to_string id in - 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 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) - | Parse_ast.KD_enum(kind,id,name_scm_opt,enums,_) -> - let id = to_ast_id id in - let key = id_to_string id in - 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 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) -> - let id = to_ast_id id in - let key = id_to_string id in - let kind,k = to_ast_kind k_env kind in - 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)) - + )) let to_ast_rec (Parse_ast.Rec_aux(r,l): Parse_ast.rec_opt) : rec_opt = Rec_aux((match r with @@ -776,7 +719,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 +730,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 +762,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 +783,20 @@ 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_prec = function + | Parse_ast.Infix -> Infix + | Parse_ast.InfixL -> InfixL + | Parse_ast.InfixR -> InfixR + 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_fixity (prec, n, op) -> + ((Finished(DEF_fixity (to_ast_prec prec, n, to_ast_id op)),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 +822,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 +854,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) -> @@ -948,7 +901,15 @@ let rec to_ast_defs_helper envs partial_defs = function then (fst !d) :: defs, envs, partial_defs else typ_error l "Scattered type definition never ended" (Some id) None None)) +let rec remove_mutrec = function + | [] -> [] + | Parse_ast.DEF_internal_mutrec fundefs :: defs -> + List.map (fun fdef -> Parse_ast.DEF_fundef fdef) fundefs @ remove_mutrec defs + | def :: defs -> + def :: remove_mutrec defs + let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : order) (Parse_ast.Defs(defs)) = + let defs = remove_mutrec defs in let defs,(_,k_env,def_ord),partial_defs = to_ast_defs_helper (default_names,kind_env,def_ord) [] defs in List.iter (fun (id,(d,k)) -> @@ -957,3 +918,154 @@ 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})} ); + ("itself", {k = K_Lam( [ {k=K_Nat} ], {k=K_Typ})}); + ] + +let typschm_of_string order str = + let typschm = Parser2.typschm_eof Lexer2.token (Lexing.from_string str) in + let (typschm, _, _) = to_ast_typschm initial_kind_env order typschm in + typschm + +let val_spec_of_string order id str = mk_val_spec (VS_val_spec (typschm_of_string order str, id, (fun _ -> Some (string_of_id id)), false)) + +let val_spec_ids (Defs defs) = + let val_spec_id (VS_aux (vs_aux, _)) = + match vs_aux with + | VS_val_spec (_, id, _, _) -> id + in + let rec vs_ids = function + | DEF_spec vs :: defs -> val_spec_id vs :: vs_ids defs + | def :: defs -> vs_ids defs + | [] -> [] + in + IdSet.of_list (vs_ids defs) + +let quant_item_param = function + | QI_aux (QI_id kopt, _) when is_nat_kopt kopt -> [prepend_id "atom_" (id_of_kid (kopt_kid kopt))] + | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [prepend_id "typ_" (id_of_kid (kopt_kid kopt))] + | _ -> [] +let quant_item_typ = function + | QI_aux (QI_id kopt, _) when is_nat_kopt kopt -> [atom_typ (nvar (kopt_kid kopt))] + | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [mk_typ (Typ_var (kopt_kid kopt))] + | _ -> [] +let quant_item_arg = function + | QI_aux (QI_id kopt, _) when is_nat_kopt kopt -> [mk_typ_arg (Typ_arg_nexp (nvar (kopt_kid kopt)))] + | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [mk_typ_arg (Typ_arg_typ (mk_typ (Typ_var (kopt_kid kopt))))] + | _ -> [] +let undefined_typschm id typq = + let qis = quant_items typq in + if qis = [] then + mk_typschm typq (mk_typ (Typ_fn (unit_typ, mk_typ (Typ_id id), mk_effect [BE_undef]))) + else + let arg_typ = mk_typ (Typ_tup (List.concat (List.map quant_item_typ qis))) in + let ret_typ = app_typ id (List.concat (List.map quant_item_arg qis)) in + mk_typschm typq (mk_typ (Typ_fn (arg_typ, ret_typ, mk_effect [BE_undef]))) + +let generate_undefineds vs_ids (Defs defs) = + let gen_vs id str = + if (IdSet.mem id vs_ids) then [] else [val_spec_of_string dec_ord id str] + in + let undefined_builtins = List.concat + [gen_vs (mk_id "internal_pick") "forall ('a:Type). list('a) -> 'a effect {undef}"; + gen_vs (mk_id "undefined_bool") "unit -> bool effect {undef}"; + gen_vs (mk_id "undefined_bit") "unit -> bit effect {undef}"; + gen_vs (mk_id "undefined_int") "unit -> int effect {undef}"; + gen_vs (mk_id "undefined_nat") "unit -> nat effect {undef}"; + gen_vs (mk_id "undefined_real") "unit -> real effect {undef}"; + gen_vs (mk_id "undefined_string") "unit -> string effect {undef}"; + gen_vs (mk_id "undefined_list") "forall ('a:Type). 'a -> list('a) effect {undef}"; + gen_vs (mk_id "undefined_range") "forall 'n 'm. (atom('n), atom('m)) -> range('n,'m) effect {undef}"; + (* FIXME: How to handle inc/dec order correctly? *) + gen_vs (mk_id "undefined_vector") "forall 'n 'm ('a:Type). (atom('n), atom('m), 'a) -> vector('n, 'm, dec,'a) effect {undef}"; + (* Only used with lem_mwords *) + gen_vs (mk_id "undefined_bitvector") "forall 'n 'm. (atom('n), atom('m)) -> vector('n, 'm, dec,bit) effect {undef}"; + gen_vs (mk_id "undefined_unit") "unit -> unit effect {undef}"] + in + let undefined_tu = function + | Tu_aux (Tu_id id, _) -> mk_exp (E_id id) + | Tu_aux (Tu_ty_id (typ, id), _) -> mk_exp (E_app (id, [mk_lit_exp L_undef])) + in + let undefined_td = function + | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + let typschm = typschm_of_string dec_ord ("unit -> " ^ string_of_id id ^ " effect {undef}") in + [mk_val_spec (VS_val_spec (typschm, prepend_id "undefined_" id, (fun _ -> None), false)); + mk_fundef [mk_funcl (prepend_id "undefined_" id) + (mk_pat (P_lit (mk_lit L_unit))) + (mk_exp (E_app (mk_id "internal_pick", + [mk_exp (E_list (List.map (fun id -> mk_exp (E_id id)) ids))])))]] + | TD_record (id, _, typq, fields, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + let pat = mk_pat (P_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id)))) in + [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false)); + mk_fundef [mk_funcl (prepend_id "undefined_" id) + pat + (mk_exp (E_record (mk_fexps (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields))))]] + | TD_variant (id, _, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) -> + let pat = mk_pat (P_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id)))) in + [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false)); + mk_fundef [mk_funcl (prepend_id "undefined_" id) + pat + (mk_exp (E_app (mk_id "internal_pick", + [mk_exp (E_list (List.map undefined_tu tus))])))]] + | _ -> [] + in + let rec undefined_defs = function + | DEF_type (TD_aux (td_aux, _)) as def :: defs -> + def :: undefined_td td_aux @ undefined_defs defs + | def :: defs -> + def :: undefined_defs defs + | [] -> [] + in + Defs (undefined_builtins @ undefined_defs defs) + +let rec get_registers = function + | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), _)) :: defs -> (typ, id) :: get_registers defs + | def :: defs -> get_registers defs + | [] -> [] + +let generate_initialize_registers vs_ids (Defs defs) = + let regs = get_registers defs in + let initialize_registers = + if IdSet.mem (mk_id "initialize_registers") vs_ids || regs = [] then [] + else + [val_spec_of_string dec_ord (mk_id "initialize_registers") "unit -> unit effect {undef, wreg}"; + mk_fundef [mk_funcl (mk_id "initialize_registers") + (mk_pat (P_lit (mk_lit L_unit))) + (mk_exp (E_block (List.map (fun (typ, id) -> mk_exp (E_assign (mk_lexp (LEXP_cast (typ, id)), mk_lit_exp L_undef))) regs)))]] + in + Defs (defs @ initialize_registers) + +let incremental_k_env = ref initial_kind_env + +let process_ast order defs = + let ast, k_env, _= to_ast Nameset.empty !incremental_k_env order defs in + incremental_k_env := k_env; + if not !opt_undefined_gen + then ast + else + begin + let vs_ids = val_spec_ids ast in + let ast = generate_undefineds vs_ids ast in + generate_initialize_registers vs_ids ast + end diff --git a/src/initial_check.mli b/src/initial_check.mli index 5e4b7e77..cfbea3e1 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -41,13 +41,11 @@ (**************************************************************************) open Ast -open Type_internal -type kind = Type_internal.kind -type typ = Type_internal.t +open Ast_util -(*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 opt_undefined_gen : bool ref +val opt_magic_hash : bool ref -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 +val process_ast : order -> Parse_ast.defs -> unit defs + +val val_spec_ids : 'a defs -> IdSet.t 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/lem_interp/instruction_extractor.lem b/src/lem_interp/instruction_extractor.lem index e603bb58..056f0100 100644 --- a/src/lem_interp/instruction_extractor.lem +++ b/src/lem_interp/instruction_extractor.lem @@ -44,20 +44,21 @@ open import Interp_ast open import Interp_utilities open import Pervasives -type instr_param_typ = +type instr_param_typ = | IBit | IBitvector of maybe nat | IRange of maybe nat | IEnum of string * nat | IOther -type instruction_form = +type instruction_form = | Instr_form of string * list (string * instr_param_typ) * list base_effect -| Skipped +| Skipped val extract_instructions : string -> defs tannot -> list instruction_form let rec extract_ityp t tag = match (t,tag) with +(* AA: Hack | (T_abbrev _ t,_) -> extract_ityp t tag | (T_id "bit",_) -> IBit | (T_id "bool",_) -> IBit @@ -74,6 +75,7 @@ let rec extract_ityp t tag = match (t,tag) with IEnum i (natFromInteger max) | (T_id i,Tag_enum max) -> IEnum i (natFromInteger max) +*) | _ -> IOther end @@ -125,7 +127,10 @@ let rec extract_patt_parm (P_aux p (_,tannot)) = let rec extract_from_execute fcls = match fcls with | [] -> [] | FCL_aux (FCL_Funcl _ (P_aux (P_app (Id_aux (Id i) _) parms) _) _) (_,Just(_,_,_,Effect_aux(Effect_set efs) _,_))::fcls -> - (Instr_form i (List.map extract_patt_parm parms) efs)::extract_from_execute fcls + (Instr_form i (List.map extract_patt_parm parms) efs)::extract_from_execute fcls + | _ :: fcls -> + (* AA: Find out what breaks this *) + extract_from_execute fcls end let rec extract_effects instrs execute = diff --git a/src/lem_interp/interp.lem b/src/lem_interp/interp.lem index f00458b7..cc10b758 100644 --- a/src/lem_interp/interp.lem +++ b/src/lem_interp/interp.lem @@ -98,7 +98,7 @@ end let rec {ocaml} string_of_value v = match v with | V_boxref nat t -> "$#" ^ (show nat) ^ "$" - | V_lit (L_aux lit _) -> + | V_lit (L_aux lit _) -> (match lit with | L_unit -> "()" | L_zero -> "0" @@ -112,9 +112,9 @@ let rec {ocaml} string_of_value v = match v with | L_string str-> "\"" ^ str ^ "\"" end) | V_tuple vals -> "(" ^ (list_to_string string_of_value "," vals) ^ ")" | V_list vals -> "[||" ^ (list_to_string string_of_value "," vals) ^ "||]" - | V_vector i inc vals -> + | V_vector i inc vals -> let default_format _ = "[" ^ (list_to_string string_of_value "," vals) ^ "]" in - let to_bin () = (*"("^show i ^") "^ *)"0b" ^ + let to_bin () = (*"("^show i ^") "^ *)"0b" ^ (List.foldr (fun v rst -> (match v with @@ -126,16 +126,16 @@ let rec {ocaml} string_of_value v = match v with match vals with | [] -> default_format () | v::vs -> - match v with + match v with | V_lit (L_aux L_zero _) -> to_bin() | V_lit (L_aux L_one _) -> to_bin() | _ -> default_format() end end - | V_vector_sparse start stop inc vals default -> + | V_vector_sparse start stop inc vals default -> "[" ^ (list_to_string (fun (i,v) -> (show i) ^ " = " ^ (string_of_value v)) "," vals) ^ "]:" ^ show start ^ "-" ^show stop ^ "(default of " ^ (string_of_value default) ^ ")" | V_record t vals -> "{" ^ (list_to_string (fun (id,v) -> (get_id id) ^ "=" ^ (string_of_value v)) ";" vals) ^ "}" - | V_ctor id t _ value -> (get_id id) ^ " " ^ string_of_value value + | V_ctor id t _ value -> (get_id id) ^ " " ^ string_of_value value | V_unknown -> "Unknown" | V_register r -> string_of_reg_form r | V_register_alias _ _ -> "register_as_alias" @@ -152,7 +152,7 @@ end val debug_print_value : value -> string let rec debug_print_value v = match v with | V_boxref n t -> "V_boxref " ^ (show n) ^ " t" - | V_lit (L_aux lit _) -> + | V_lit (L_aux lit _) -> "V_lit " ^ (match lit with | L_unit -> "L_unit" @@ -206,7 +206,7 @@ and value_eq strict left right = | (V_list l, V_list l') -> listEqualBy (value_eq strict) l l' | (V_vector n b l, V_vector m b' l') -> b = b' && listEqualBy (value_eq strict) l l' | (V_vector_sparse n o b l v, V_vector_sparse m p b' l' v') -> - n=m && o=p && b=b' && + n=m && o=p && b=b' && listEqualBy (fun (i,v) (i',v') -> i=i' && (value_eq strict v v')) l l' && value_eq strict v v' | (V_record t l, V_record t' l') -> t = t' && @@ -217,8 +217,8 @@ and value_eq strict left right = | (V_unknown,V_unknown) -> true | (V_unknown,_) -> if strict then false else true | (_,V_unknown) -> if strict then false else true - | (V_track v1 ts1, V_track v2 ts2) -> - if strict + | (V_track v1 ts1, V_track v2 ts2) -> + if strict then value_eq strict v1 v2 && ts1 = ts2 else value_eq strict v1 v2 | (V_track v _, v2) -> if strict then false else value_eq strict v v2 @@ -236,62 +236,52 @@ instance (Eq value) let (<>) = value_ineq end -let reg_start_pos reg = +let reg_start_pos reg = match reg with - | Form_Reg _ (Just(typ,_,_,_,_)) _ -> + | Form_Reg _ (Just(typ,_,_,_,_)) _ -> let start_from_vec targs = match targs with - | T_args [T_arg_nexp (Ne_const s);_;_;_] -> natFromInteger s - | T_args [T_arg_nexp _; T_arg_nexp (Ne_const s); T_arg_order Odec; _] -> (natFromInteger s) - 1 - | T_args [_; _; T_arg_order Oinc; _] -> 0 + | [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _;_;_;_] -> natFromInteger s + | [Typ_arg_aux (Typ_arg_nexp _) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _; Typ_arg_aux (Typ_arg_order Odec) _; _] -> (natFromInteger s) - 1 + | [_; _; Typ_arg_aux (Typ_arg_order Oinc) _; _] -> 0 | _ -> Assert_extra.failwith "vector type not well formed" end in let start_from_reg targs = match targs with - | T_args [T_arg_typ (T_app "vector" targs)] -> start_from_vec targs - | T_args [T_arg_typ (T_abbrev _ (T_app "vector" targs))] -> start_from_vec targs + | [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) targs) _)) _] -> start_from_vec targs | _ -> Assert_extra.failwith "register not of type vector" end in - let start_from_abbrev t = match t with - | T_app "vector" targs -> start_from_vec targs - | T_app "register" targs -> start_from_reg targs + match typ with + | Typ_aux (Typ_app id targs) _ -> + if get_id id = "vector" then start_from_vec targs + else if get_id id = "register" then start_from_reg targs + else Assert_extra.failwith "register abbrev not register or vector" | _ -> Assert_extra.failwith "register abbrev not register or vector" - end in - match typ with - | T_app "vector" targs -> start_from_vec targs - | T_app "register" targs -> start_from_reg targs - | T_abbrev _ t -> start_from_abbrev t - | _ -> Assert_extra.failwith "register type not vector, register, or abbrev" - end + end | _ -> Assert_extra.failwith "reg_start_pos found unexpected sub reg, or reg without a type" -end +end -let reg_size reg = +let reg_size reg = match reg with - | Form_Reg _ (Just(typ,_,_,_,_)) _ -> + | Form_Reg _ (Just(typ,_,_,_,_)) _ -> let end_from_vec targs = match targs with - | T_args [_;T_arg_nexp (Ne_const s);_;_] -> natFromInteger s + | [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _;_;_] -> natFromInteger s | _ -> Assert_extra.failwith "register vector type not well formed" end in let end_from_reg targs = match targs with - | T_args [T_arg_typ (T_app "vector" targs)] -> end_from_vec targs - | T_args [T_arg_typ (T_abbrev _ (T_app "vector" targs))] -> end_from_vec targs - | _ -> Assert_extra.failwith "register does not contain vector" + | [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) targs) _)) _] -> end_from_vec targs + | _ -> Assert_extra.failwith "register does not contain vector" end in - let end_from_abbrev t = match t with - | T_app "vector" targs -> end_from_vec targs - | T_app "register" targs -> end_from_reg targs - | _ -> Assert_extra.failwith "register abbrev is neither vector nor register" - end in - match typ with - | T_app "vector" targs -> end_from_vec targs - | T_app "register" targs -> end_from_reg targs - | T_abbrev _ t -> end_from_abbrev t - | _ -> Assert_extra.failwith "register type is none of vector, register, or abbrev" - end + match typ with + | Typ_aux (Typ_app id targs) _ -> + if get_id id = "vector" then end_from_vec targs + else if get_id id = "register" then end_from_reg targs + else Assert_extra.failwith "register type is none of vector, register, or abbrev" + | _ -> Assert_extra.failwith "register type is none of vector, register, or abbrev" + end | _ -> Assert_extra.failwith "reg_size given unexpected sub reg or reg without a type" -end +end (*Constant unit value, for use in interpreter *) -let unit_ty = T_id "unit" +let unit_ty = Typ_aux (Typ_id (Id_aux (Id "unit") Unknown)) Unknown let unitv = V_lit (L_aux L_unit Unknown) let unit_e = E_aux (E_lit (L_aux L_unit Unknown)) (Unknown, val_annot unit_ty) @@ -331,26 +321,26 @@ end type sub_reg_map = map string index_range -(*top_level is a tuple of +(*top_level is a tuple of (function definitions environment, all extracted instructions (where possible), default direction - letbound and enum values, - register values, - Typedef union constructors, + letbound and enum values, + register values, + Typedef union constructors, sub register mappings, and register aliases) *) -type top_level = +type top_level = | Env of map string (list (funcl tannot)) (*function definitions environment*) * list instruction_form (* extracted instructions (where extractable) *) * i_direction (*default direction*) * env (*letbound and enum values*) - * env (*register values*) + * env (*register values*) * map string typ (*typedef union constructors *) * map string sub_reg_map (*sub register mappings*) * map string (alias_spec tannot) (*register aliases*) * bool (* debug? *) -type action = +type action = | Read_reg of reg_form * maybe (nat * nat) | Write_reg of reg_form * maybe (nat * nat) * value | Read_mem of id * value * maybe (nat * nat) @@ -367,13 +357,13 @@ type action = | Return of value | Exit of (exp tannot) (* For the error case of a failed assert, carries up an optional error message*) - | Fail of value + | Fail of value (* For stepper, no action needed. String is function called, value is parameter where applicable *) - | Step of l * maybe string * maybe value + | Step of l * maybe string * maybe value (* Inverted call stack, where the frame with a Top stack waits for an action to resolve and all other frames for their inner stack *) -type stack = +type stack = | Top | Hole_frame of id * exp tannot * top_level * lenv * lmem * stack (* Stack frame waiting for a value *) | Thunk_frame of exp tannot * top_level * lenv * lmem * stack (* Paused stack frame *) @@ -383,7 +373,7 @@ type stack = type outcome = | Value of value | Action of action * stack - | Error of l * string + | Error of l * string let string_of_id id' = (match id' with @@ -501,7 +491,6 @@ let rec string_of_exp e' = | E_if cond thn els -> "(E_if " ^ (string_of_exp cond) ^ " ? " ^ (string_of_exp thn) ^ " : " ^ (string_of_exp els) ^ ")" | E_for id from to_ by order exp -> "(E_for " ^ string_of_id id ^ " " ^ string_of_exp from ^ " " ^ string_of_exp to_ ^ " " ^ string_of_exp by ^ " " ^ string_of_order order ^ " " ^ string_of_exp exp ^ ")" | E_vector exps -> "(E_vector [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_vector_indexed _ _ -> "(E_vector_indexed)" | E_vector_access exp1 exp2 -> "(E_vector_access " ^ string_of_exp exp1 ^ " " ^ string_of_exp exp2 ^ ")" | E_vector_subrange exp1 exp2 exp3 -> "(E_vector_subrange " ^ string_of_exp exp1 ^ " " ^ string_of_exp exp2 ^ " " ^ string_of_exp exp3 ^ ")" | E_vector_update _ _ _ -> "(E_vector_update)" @@ -585,7 +574,6 @@ let rec string_of_pat (P_aux pat _) = | P_app id pats -> "(P_app " ^ show id ^ " [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" | P_record _ _ -> "(P_record _ _)" | P_vector pats -> "(P_vector [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - | P_vector_indexed _ -> "(P_vector_indexed _)" | P_vector_concat pats -> "(P_vector_concat [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" | P_tup pats -> "(P_tup [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" | P_list pats -> "(P_list [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" @@ -597,8 +585,7 @@ end let string_of_letbind (LB_aux lb _) = (match lb with - | LB_val_explicit ts pat exp -> "(LB_val_explicit " ^ (show ts) ^ " " ^ (show pat) ^ " " ^ (show exp) ^ ")" - | LB_val_implicit pat exp -> "(LB_val_implicit " ^ (show pat) ^ " " ^ (show exp) ^ ")" + | LB_val pat exp -> "(LB_val " ^ (show pat) ^ " " ^ (show exp) ^ ")" end) instance forall 'a. (Show letbind 'a) @@ -649,36 +636,36 @@ let rec to_fdefs (Defs defs) = | _ -> to_fdefs (Defs defs) end end val to_register_fields : defs tannot -> map string (map string index_range) -let rec to_register_fields (Defs defs) = +let rec to_register_fields (Defs defs) = match defs with | [ ] -> Map.empty - | def::defs -> - match def with + | def::defs -> + match def with | DEF_type (TD_aux (TD_register id n1 n2 indexes) l') -> - Map.insert (get_id id) + Map.insert (get_id id) (List.foldr (fun (a,b) imap -> Map.insert (get_id b) a imap) Map.empty indexes) (to_register_fields (Defs defs)) | _ -> to_register_fields (Defs defs) - end + end end val to_registers : i_direction -> defs tannot -> env -let rec to_registers dd (Defs defs) = +let rec to_registers dd (Defs defs) = match defs with | [ ] -> Map.empty - | def::defs -> - match def with - | DEF_reg_dec (DEC_aux (DEC_reg typ id) (l,tannot)) -> + | def::defs -> + match def with + | DEF_reg_dec (DEC_aux (DEC_reg typ id) (l,tannot)) -> let dir = match tannot with | Nothing -> dd | Just(t, _, _, _,_) -> dd (*TODO, lets pull the direction out properly*) end in Map.insert (get_id id) (V_register(Form_Reg id tannot dir)) (to_registers dd (Defs defs)) - | DEF_reg_dec (DEC_aux (DEC_alias id aspec) (l,tannot)) -> + | DEF_reg_dec (DEC_aux (DEC_alias id aspec) (l,tannot)) -> Map.insert (get_id id) (V_register_alias aspec tannot) (to_registers dd (Defs defs)) | _ -> to_registers dd (Defs defs) - end - end + end + end val to_aliases : defs tannot -> map string (alias_spec tannot) let rec to_aliases (Defs defs) = @@ -686,12 +673,12 @@ let rec to_aliases (Defs defs) = | [] -> Map.empty | def::defs -> match def with - | DEF_reg_dec (DEC_aux (DEC_alias id aspec) _) -> + | DEF_reg_dec (DEC_aux (DEC_alias id aspec) _) -> Map.insert (get_id id) aspec (to_aliases (Defs defs)) - | DEF_reg_dec (DEC_aux (DEC_typ_alias typ id aspec) _) -> + | DEF_reg_dec (DEC_aux (DEC_typ_alias typ id aspec) _) -> Map.insert (get_id id) aspec (to_aliases (Defs defs)) | _ -> to_aliases (Defs defs) - end + end end val to_data_constructors : defs tannot -> map string typ @@ -699,14 +686,14 @@ let rec to_data_constructors (Defs defs) = match defs with | [] -> (*Prime environment with built-in constructors*) - Map.insert "Some" (Typ_aux (Typ_var (Kid_aux (Var "a") Unknown)) Unknown) + Map.insert "Some" (Typ_aux (Typ_var (Kid_aux (Var "a") Unknown)) Unknown) (Map.insert "None" unit_t Map.empty) | def :: defs -> match def with | DEF_type (TD_aux t _)-> - match t with + match t with | TD_variant id _ tq tid_list _ -> - (List.foldr + (List.foldr (fun (Tu_aux t _) map -> match t with | (Tu_ty_id x y) -> Map.insert (get_id y) x map @@ -727,12 +714,12 @@ val in_lenv : lenv -> id -> value let in_lenv (LEnv _ env) id = match in_env env (get_id id) with | Nothing -> V_unknown - | Just v -> v + | Just v -> v end (*Prefer entries in the first when in conflict*) val union_env : lenv -> lenv -> lenv -let union_env (LEnv i1 env1) (LEnv i2 env2) = +let union_env (LEnv i1 env1) (LEnv i2 env2) = let l = if i1 < i2 then i2 else i1 in LEnv l (Map.(union) env2 env1) @@ -745,7 +732,7 @@ val add_to_env : (id * value) -> lenv -> lenv let add_to_env (id, entry) (LEnv i env) = (LEnv i (Map.insert (get_id id) entry env)) val in_mem : lmem -> nat -> value -let in_mem (LMem _ _ m _) n = +let in_mem (LMem _ _ m _) n = Map_extra.find n m (* Map.lookup n m *) @@ -762,9 +749,9 @@ let clear_updates (LMem owner c m _) = LMem owner c m Set.empty (*Value helper functions*) val is_lit_vector : lit -> bool -let is_lit_vector (L_aux l _) = +let is_lit_vector (L_aux l _) = match l with - | L_bin _ -> true + | L_bin _ -> true | L_hex _ -> true | _ -> false end @@ -774,9 +761,9 @@ let litV_to_vec (L_aux lit l) (dir: i_direction) = match lit with | L_hex s -> let to_v b = V_lit (L_aux b l) in - let hexes = List.map to_v - (List.concat - (List.map + let hexes = List.map to_v + (List.concat + (List.map (fun s -> match s with | #'0' -> [L_zero;L_zero;L_zero;L_zero] | #'1' -> [L_zero;L_zero;L_zero;L_one ] @@ -803,12 +790,12 @@ let litV_to_vec (L_aux lit l) (dir: i_direction) = | _ -> Assert_extra.failwith "Lexer did not restrict to valid hex" end) (String.toCharList s))) in V_vector (if is_inc(dir) then 0 else ((List.length hexes) - 1)) dir hexes - | L_bin s -> - let bits = List.map - (fun s -> match s with - | #'0' -> (V_lit (L_aux L_zero l)) + | L_bin s -> + let bits = List.map + (fun s -> match s with + | #'0' -> (V_lit (L_aux L_zero l)) | #'1' -> (V_lit (L_aux L_one l)) - | _ -> Assert_extra.failwith "Lexer did not restrict to valid bin" + | _ -> Assert_extra.failwith "Lexer did not restrict to valid bin" end) (String.toCharList s) in V_vector (if is_inc(dir) then 0 else ((List.length bits) -1)) dir bits | _ -> Assert_extra.failwith "litV predicate did not restrict to literal vectors" @@ -821,10 +808,10 @@ val list_length : forall 'a . list 'a -> integer let list_length l = integerFromNat (List.length l) val taint: value -> set reg_form -> value -let rec taint value regs = +let rec taint value regs = if Set.null regs then value - else match value with + else match value with | V_track value rs -> taint value (regs union rs) | V_tuple vals -> V_tuple (List.map (fun v -> taint v regs) vals) | _ -> V_track value regs @@ -832,13 +819,13 @@ end val retaint: value -> value -> value let retaint orig updated = - match orig with + match orig with | V_track _ rs -> taint updated rs | _ -> updated end -val detaint: value -> value -let rec detaint value = +val detaint: value -> value +let rec detaint value = match value with | V_track value _ -> detaint value | v -> v @@ -851,24 +838,24 @@ let rec binary_taint thunk = fun vall valr -> | (V_track vl rl,vr) -> taint (binary_taint thunk vl vr) rl | (vl,V_track vr rr) -> taint (binary_taint thunk vl vr) rr | (vl,vr) -> thunk vl vr -end +end -let rec merge_values v1 v2 = - if value_eq true v1 v2 - then v1 +let rec merge_values v1 v2 = + if value_eq true v1 v2 + then v1 else match (v1,v2) with | (V_lit l, V_lit l') -> if lit_eq l l' then v1 else V_unknown - | (V_boxref n t, V_boxref m t') -> + | (V_boxref n t, V_boxref m t') -> (*Changes to memory handled by merge_mem*) if n = m then v1 else V_unknown - | (V_tuple l, V_tuple l') -> - V_tuple (map2 merge_values l l') - | (V_list l, V_list l') -> - if (List.length l = List.length l') + | (V_tuple l, V_tuple l') -> + V_tuple (map2 merge_values l l') + | (V_list l, V_list l') -> + if (List.length l = List.length l') then V_list (map2 merge_values l l') else V_unknown - | (V_vector n b l, V_vector m b' l') -> - if b = b' && (List.length l = List.length l') + | (V_vector n b l, V_vector m b' l') -> + if b = b' && (List.length l = List.length l') then V_vector n b (map2 merge_values l l') else V_unknown | (V_vector_sparse n o b l v, V_vector_sparse m p b' l' v') -> @@ -877,45 +864,45 @@ let rec merge_values v1 v2 = else V_unknown | (V_record t l, V_record t' l') -> (*assumes canonical order for fields in a record*) - if t = t' && List.length l = length l' + if t = t' && List.length l = length l' then V_record t (map2 (fun (i,v1) (_,v2) -> (i, merge_values v1 v2)) l l') else V_unknown - | (V_ctor i t (C_Enum j) v, V_ctor i' t' (C_Enum j') v') -> + | (V_ctor i t (C_Enum j) v, V_ctor i' t' (C_Enum j') v') -> if i = i' then v1 else V_unknown | (V_ctor _ _ (C_Enum i) _,V_lit (L_aux (L_num j) _)) -> if i = (natFromInteger j) then v1 else V_unknown | (V_lit (L_aux (L_num j) _), V_ctor _ _ (C_Enum i) _) -> if i = (natFromInteger j) then v2 else V_unknown | (V_ctor i t ckind v, V_ctor i' t' _ v') -> - if t = t' && i = i' + if t = t' && i = i' then (V_ctor i t ckind (merge_values v v')) else V_unknown | (V_unknown,V_unknown) -> V_unknown - | (V_track v1 ts1, V_track v2 ts2) -> + | (V_track v1 ts1, V_track v2 ts2) -> taint (merge_values v1 v2) (ts1 union ts2) | (V_track v1 ts, v2) -> taint (merge_values v1 v2) ts | (v1,V_track v2 ts) -> taint (merge_values v1 v2) ts | (_, _) -> V_unknown -end +end val merge_lmems : lmem -> lmem -> lmem -let merge_lmems ((LMem owner1 c1 mem1 set1) as lmem1) ((LMem owner2 c2 mem2 set2) as lmem2) = +let merge_lmems ((LMem owner1 c1 mem1 set1) as lmem1) ((LMem owner2 c2 mem2 set2) as lmem2) = let diff1 = Set_extra.toList (set1 \ set2) in let diff2 = Set_extra.toList (set2 \ set1) in let inters = Set_extra.toList (set1 inter set2) in let c = max c1 c2 in let mem = LMem owner1 c (if c1 >= c2 then mem1 else mem2) Set.empty in - let diff_mem1 = - List.foldr - (fun i mem -> update_mem false mem i + let diff_mem1 = + List.foldr + (fun i mem -> update_mem false mem i (match Map.lookup i mem2 with | Nothing -> V_unknown | Just v -> merge_values (in_mem lmem1 i) v end)) mem diff1 in - let diff_mem2 = - List.foldr - (fun i mem -> update_mem false mem i + let diff_mem2 = + List.foldr + (fun i mem -> update_mem false mem i (match Map.lookup i mem1 with | Nothing -> V_unknown | Just v -> merge_values (in_mem lmem2 i) v end)) diff_mem1 diff2 in - List.foldr + List.foldr (fun i mem -> update_mem false mem i (merge_values (in_mem lmem1 i) (in_mem lmem2 i))) diff_mem2 inters @@ -929,7 +916,7 @@ end val access_vector : value -> nat -> value let access_vector v n = retaint v (match (detaint v) with - | V_unknown -> V_unknown + | V_unknown -> V_unknown | V_lit (L_aux L_undef _) -> v | V_lit (L_aux L_zero _) -> v | V_lit (L_aux L_one _ ) -> v @@ -938,7 +925,7 @@ let access_vector v n = | V_vector_sparse _ _ _ vs d -> match (List.lookup n vs) with | Nothing -> d - | Just v -> v end + | Just v -> v end | _ -> Assert_extra.failwith ("access_vector given unexpected " ^ string_of_value v) end ) @@ -946,16 +933,16 @@ val from_n_to_n :forall 'a. nat -> nat -> list 'a -> list 'a let from_n_to_n from to_ ls = take (to_ - from + 1) (drop from ls) val slice_sparse_list : (nat -> nat -> bool) -> (nat -> nat) -> list (nat * value) -> nat -> nat -> ((list (nat * value)) * bool) -let rec slice_sparse_list compare update_n vals n1 n2 = +let rec slice_sparse_list compare update_n vals n1 n2 = let sl = slice_sparse_list compare update_n in - if (n1 = n2) && (vals = []) + if (n1 = n2) && (vals = []) then ([],true) else if (n1=n2) then ([],false) else match vals with | [] -> ([],true) - | (i,v)::vals -> - if n1 = i + | (i,v)::vals -> + if n1 = i then let (rest,still_sparse) = (sl vals (update_n n1) n2) in ((i,v)::rest,still_sparse) else if (compare n1 i) then (sl vals (update_n n1) n2) @@ -966,12 +953,12 @@ val slice_vector : value -> nat -> nat -> value let slice_vector v n1 n2 = retaint v (match detaint v with | V_vector m dir vs -> - if is_inc(dir) + if is_inc(dir) then V_vector n1 dir (from_n_to_n (n1 - m) (n2 - m) vs) - else V_vector n1 dir (from_n_to_n (m - n1) (m - n2) vs) - | V_vector_sparse m n dir vs d -> - let (slice, still_sparse) = - if is_inc(dir) + else V_vector n1 dir (from_n_to_n (m - n1) (m - n2) vs) + | V_vector_sparse m n dir vs d -> + let (slice, still_sparse) = + if is_inc(dir) then slice_sparse_list (>) (fun i -> i + 1) vs n1 n2 else slice_sparse_list (<) (fun i -> i - 1) vs n1 n2 in if still_sparse && is_inc(dir) @@ -992,7 +979,7 @@ let rec update_field_list base updates = end val fupdate_record : value -> value -> value -let fupdate_record base updates = +let fupdate_record base updates = let fupdate_record_helper base updates = (match (base,updates) with | (V_record t bs,V_record _ us) -> V_record t (update_field_list bs (env_from_list us)) @@ -1017,7 +1004,7 @@ let fupdate_vec v n vexp = let tainted = binary_taint (fun v _ -> v) v vexp in retaint tainted (match detaint v with - | V_vector m dir vals -> + | V_vector m dir vals -> V_vector m dir (List.update vals (if is_inc(dir) then (n-m) else (m-n)) vexp) | V_vector_sparse m o dir vals d -> V_vector_sparse m o dir (fupdate_sparse (if is_inc(dir) then (>) else (<)) vals n vexp) d @@ -1029,7 +1016,7 @@ let rec replace_is ls vs base start stop = match (ls,vs) with | ([],_) -> [] | (ls,[]) -> ls - | (l::ls,v::vs) -> + | (l::ls,v::vs) -> if base >= start then if start >= stop then v::ls else v::(replace_is ls vs (base + 1) (start + 1) stop) @@ -1043,30 +1030,30 @@ let rec replace_sparse compare vals reps = | (vs,[]) -> vs | ((i1,v)::vs,(i2,r)::rs) -> if i1 = i2 then (i2,r)::(replace_sparse compare vs rs) - else if (compare i1 i2) + else if (compare i1 i2) then (i1,v)::(replace_sparse compare vs ((i2,r)::rs)) else (i2,r)::(replace_sparse compare ((i1,v)::vs) rs) end val fupdate_vector_slice : value -> value -> nat -> nat -> value let fupdate_vector_slice vec replace start stop = - let fupdate_vec_help vec replace = + let fupdate_vec_help vec replace = (match (vec,replace) with | (V_vector m dir vals,V_vector r_m dir' reps) -> - V_vector m dir - (replace_is vals + V_vector m dir + (replace_is vals (if dir=dir' then reps else (List.reverse reps)) 0 (if is_inc(dir) then (start-m) else (m-start)) (if is_inc(dir) then (stop-m) else (m-stop))) | (V_vector m dir vals, V_unknown) -> V_vector m dir - (replace_is vals + (replace_is vals (List.replicate (if is_inc(dir) then (stop-start) else (start-stop)) V_unknown) 0 (if is_inc(dir) then (start-m) else (m-start)) (if is_inc(dir) then (stop-m) else (m-stop))) | (V_vector_sparse m n dir vals d,V_vector _ _ reps) -> let (_,repsi) = List.foldl (fun (i,rs) r -> ((if is_inc(dir) then i+1 else i-1), (i,r)::rs)) (start,[]) reps in (V_vector_sparse m n dir (replace_sparse (if is_inc(dir) then (<) else (>)) vals (List.reverse repsi)) d) | (V_vector_sparse m n dir vals d, V_unknown) -> - let (_,repsi) = List.foldl (fun (i,rs) r -> ((if is_inc(dir) then i+1 else i-1), (i,r)::rs)) (start,[]) + let (_,repsi) = List.foldl (fun (i,rs) r -> ((if is_inc(dir) then i+1 else i-1), (i,r)::rs)) (start,[]) (List.replicate (if is_inc(dir) then (stop-start) else (start-stop)) V_unknown) in (V_vector_sparse m n dir (replace_sparse (if is_inc(dir) then (<) else (>)) vals (List.reverse repsi)) d) | (V_unknown,_) -> V_unknown @@ -1076,28 +1063,28 @@ let fupdate_vector_slice vec replace start stop = binary_taint fupdate_vec_help vec replace val update_vector_slice : bool -> value -> value -> nat -> nat -> lmem -> lmem -let update_vector_slice track vector value start stop mem = +let update_vector_slice track vector value start stop mem = match (detaint vector,detaint value) with | ((V_boxref n t), v) -> - update_mem track mem n (fupdate_vector_slice (in_mem mem n) (retaint value v) start stop) + update_mem track mem n (fupdate_vector_slice (in_mem mem n) (retaint value v) start stop) | ((V_vector m _ vs),(V_vector n _ vals)) -> let (V_vector m' _ vs') = slice_vector vector start stop in foldr2 (fun vbox v mem -> match vbox with | V_boxref n t -> update_mem track mem n v end) mem vs' vals - | ((V_vector m dir vs),(V_vector_sparse n o _ vals d)) -> + | ((V_vector m dir vs),(V_vector_sparse n o _ vals d)) -> let (m',vs') = match slice_vector vector start stop with | (V_vector m' _ vs') -> (m',vs') | _ -> Assert_extra.failwith "slice_vector did not return vector" end in let (_,mem) = foldr (fun vbox (i,mem) -> match vbox with - | V_boxref n t -> + | V_boxref n t -> (if is_inc(dir) then i+1 else i-1, update_mem track mem n (match List.lookup i vals with | Nothing -> d | Just v -> v end)) | _ -> Assert_extra.failwith "Internal error: update_vector_slice not of boxes" - end) (m,mem) vs' in + end) (m,mem) vs' in mem | ((V_vector m _ vs),v) -> let (m',vs') = match slice_vector vector start stop with @@ -1117,7 +1104,7 @@ let update_vector_start default_dir new_start expected_size v = | V_lit (L_aux L_zero _) -> V_vector new_start default_dir [v] | V_lit (L_aux L_one _) -> V_vector new_start default_dir [v] | V_vector m inc vs -> V_vector new_start inc vs (*Note, may need to shrink and check if still sparse *) - | V_vector_sparse m n dir vals d -> V_vector_sparse new_start n dir vals d + | V_vector_sparse m n dir vals d -> V_vector_sparse new_start n dir vals d | V_unknown -> V_vector new_start default_dir (List.replicate expected_size V_unknown) | V_lit (L_aux L_undef _) -> V_vector new_start default_dir (List.replicate expected_size v) | _ -> Assert_extra.failwith ("update_vector_start given unexpected " ^ string_of_value v) @@ -1135,9 +1122,9 @@ end let add_to_top_frame e_builder stack = match stack with | Top -> Top - | Hole_frame id e t_level env mem stack -> + | Hole_frame id e t_level env mem stack -> let (e',env') = (e_builder e env) in Hole_frame id e' t_level env' mem stack - | Thunk_frame e t_level env mem stack -> + | Thunk_frame e t_level env mem stack -> let (e',env') = (e_builder e env) in Thunk_frame e' t_level env' mem stack end @@ -1149,14 +1136,14 @@ let top_hole stack : bool = end let redex_id = id_of_string "0" -let mk_hole l annot t_level l_env l_mem = +let mk_hole l annot t_level l_env l_mem = Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem Top let mk_thunk l annot t_level l_env l_mem = Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,(intern_annot annot))) t_level l_env l_mem Top (*Converts a Hole_frame into a Thunk_frame, pushing to the top of the stack to insert the value at the innermost context *) val add_answer_to_stack : stack -> value -> stack -let rec add_answer_to_stack stack v = +let rec add_answer_to_stack stack v = match stack with | Top -> Top | Hole_frame id e t_level env mem Top -> Thunk_frame e t_level (add_to_env (id,v) env) mem Top @@ -1176,7 +1163,7 @@ let rec set_in_context stack e = | Thunk_frame _ _ _ _ s -> set_in_context s e end -let get_stack_state stack = +let get_stack_state stack = match stack with | Top -> Assert_extra.failwith "Top reached in extracting stack state" | Hole_frame id exp top_level lenv lmem stack -> (lenv,lmem) @@ -1186,7 +1173,7 @@ end let rec update_stack_state stack ((LMem name c mem _) as lmem) = match stack with | Top -> Top - | Hole_frame id oe t_level env (LMem _ _ _ s) Top -> + | Hole_frame id oe t_level env (LMem _ _ _ s) Top -> (match Map.lookup (0 : nat) mem with | Nothing -> Thunk_frame oe t_level (add_to_env (id,V_unknown) env) (LMem name c mem s) Top | Just v -> Thunk_frame oe t_level (add_to_env (id, v) env) (LMem name c (Map.delete (0 : nat) mem) s) Top end) @@ -1216,106 +1203,115 @@ end (*functions for converting in progress evaluation back into expression for building current continuation*) let rec combine_typs ts = match ts with - | [] -> T_var "fresh" + | [] -> mk_typ_var "fresh" | [t] -> t | t::ts -> let t' = combine_typs ts in - match (t,t') with - | (_,T_var _) -> t - | ((T_app "range" (T_args [T_arg_nexp (Ne_const bot1); T_arg_nexp (Ne_const top1)])), - (T_app "range" (T_args [T_arg_nexp (Ne_const bot2); T_arg_nexp (Ne_const top2)]))) -> + match (t,t') with + | (_,Typ_aux (Typ_var _) _) -> t + | ((Typ_aux (Typ_app (Id_aux (Id "range") _) + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot1) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top1) _)) _]) _), + (Typ_aux (Typ_app (Id_aux (Id "range") _) + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot2) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top2) _)) _]) _)) -> let (smallest,largest) = if bot1 <= bot2 then if top1 <= top2 then (bot1, top2) else (bot1, top1) else if top1 <= top2 then (bot2, top2) else (bot2, top1) in - T_app "range" (T_args [T_arg_nexp (Ne_const smallest); T_arg_nexp (Ne_const largest)]) - | ((T_app "atom" (T_args [T_arg_nexp (Ne_const a1);])), (T_app "atom" (T_args [T_arg_nexp (Ne_const a2);]))) -> + mk_typ_app "range" [Typ_arg_nexp (nconstant smallest); Typ_arg_nexp (nconstant largest)] + | ((Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a1) _)) _]) _), + (Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a2) _)) _]) _)) -> if a1 = a2 then t else let (smaller,larger) = if a1 < a2 then (a1,a2) else (a2,a1) in - T_app "range" (T_args [T_arg_nexp (Ne_const smaller); T_arg_nexp (Ne_const larger)]) - | (T_app "range" (T_args [T_arg_nexp (Ne_const bot); T_arg_nexp (Ne_const top)]), - T_app "atom" (T_args [T_arg_nexp (Ne_const a)])) -> + mk_typ_app "range" [Typ_arg_nexp (nconstant smaller); Typ_arg_nexp (nconstant larger)] + | (Typ_aux (Typ_app (Id_aux (Id "range") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top) _)) _]) _, + Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a) _)) _]) _) -> if bot <= a && a <= top then t else if bot <= a && top <= a - then T_app "range" (T_args [T_arg_nexp (Ne_const bot); T_arg_nexp (Ne_const a)]) - else T_app "range" (T_args [T_arg_nexp (Ne_const a); T_arg_nexp (Ne_const top)]) - | (T_app "atom" (T_args [T_arg_nexp (Ne_const a)]), - T_app "range" (T_args [T_arg_nexp (Ne_const bot); T_arg_nexp (Ne_const top)])) -> + then mk_typ_app "range" [Typ_arg_nexp (nconstant bot); Typ_arg_nexp (nconstant a)] + else mk_typ_app "range" [Typ_arg_nexp (nconstant a); Typ_arg_nexp (nconstant top)] + | (Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a) _)) _]) _, + Typ_aux (Typ_app (Id_aux (Id "range") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top) _)) _]) _) -> if bot <= a && a <= top then t else if bot <= a && top <= a - then T_app "range" (T_args [T_arg_nexp (Ne_const bot); T_arg_nexp (Ne_const a)]) - else T_app "range" (T_args [T_arg_nexp (Ne_const a); T_arg_nexp (Ne_const top)]) - | ((T_app "vector" (T_args [T_arg_nexp (Ne_const b1); T_arg_nexp (Ne_const r1); - T_arg_order (Ord_aux o1 _); T_arg_typ t1])), - (T_app "vector" (T_args [T_arg_nexp (Ne_const b2); T_arg_nexp (Ne_const r2); - T_arg_order (Ord_aux o2 _); T_arg_typ t2]))) -> - let t = combine_typs [t1;t2] in + then mk_typ_app "range" [Typ_arg_nexp (nconstant bot); Typ_arg_nexp (nconstant a)] + else mk_typ_app "range" [Typ_arg_nexp (nconstant a); Typ_arg_nexp (nconstant top)] + | (Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b1) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r1) _)) _; + Typ_arg_aux (Typ_arg_order (Ord_aux o1 _)) _; + Typ_arg_aux (Typ_arg_typ t1) _]) _, + Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b2) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r2) _)) _; + Typ_arg_aux (Typ_arg_order (Ord_aux o2 _)) _; + Typ_arg_aux (Typ_arg_typ t2) _]) _) -> + let t = combine_typs [t1;t2] in match (o1,o2) with | (Ord_inc,Ord_inc) -> let larger_start = if b1 < b2 then b2 else b1 in let smaller_rise = if r1 < r2 then r1 else r2 in - (T_app "vector" (T_args [T_arg_nexp (Ne_const larger_start); T_arg_nexp (Ne_const smaller_rise); - (T_arg_order (Ord_aux o1 Unknown)); T_arg_typ t])) + mk_typ_app "vector" [Typ_arg_nexp (nconstant larger_start); Typ_arg_nexp (nconstant smaller_rise); + Typ_arg_order (Ord_aux o1 Unknown); Typ_arg_typ t] | (Ord_dec,Ord_dec) -> let smaller_start = if b1 < b2 then b1 else b2 in let smaller_fall = if r1 < r2 then r2 else r2 in - (T_app "vector" (T_args [T_arg_nexp (Ne_const smaller_start); T_arg_nexp (Ne_const smaller_fall); - (T_arg_order (Ord_aux o1 Unknown)); T_arg_typ t])) - | _ -> T_var "fresh" - end + mk_typ_app "vector" [Typ_arg_nexp (nconstant smaller_start); Typ_arg_nexp (nconstant smaller_fall); + Typ_arg_order (Ord_aux o1 Unknown); Typ_arg_typ t] + | _ -> mk_typ_var "fresh" + end | _ -> t' - end + end end let reg_to_t r = match r with | Form_Reg _ (Just (t,_,_,_,_)) _ -> t - | _ -> T_var "fresh" + | _ -> mk_typ_var "fresh" end let rec val_typ v = match v with - | V_boxref n t -> T_app "reg" (T_args [T_arg_typ t]) + | V_boxref n t -> mk_typ_app "reg" [Typ_arg_typ t] | V_lit (L_aux lit _) -> match lit with - | L_unit -> T_id "unit" - | L_true -> T_id "bit" - | L_false -> T_id "bit" - | L_one -> T_id "bit" - | L_zero -> T_id "bit" - | L_string _ -> T_id "string" - | L_num n -> T_app "atom" (T_args [T_arg_nexp (Ne_const n);]) - | L_undef -> T_var "fresh" + | L_unit -> mk_typ_id "unit" + | L_true -> mk_typ_id "bit" + | L_false -> mk_typ_id "bit" + | L_one -> mk_typ_id "bit" + | L_zero -> mk_typ_id "bit" + | L_string _ -> mk_typ_id "string" + | L_num n -> mk_typ_app "atom" [Typ_arg_nexp (nconstant n)] + | L_undef -> mk_typ_var "fresh" | L_hex _ -> Assert_extra.failwith "literal hex not removed" | L_bin _ -> Assert_extra.failwith "literal bin not removed" - end - | V_tuple vals -> T_tup (List.map val_typ vals) - | V_vector n dir vals -> + end + | V_tuple vals -> mk_typ_tup (List.map val_typ vals) + | V_vector n dir vals -> let ts = List.map val_typ vals in let t = combine_typs ts in - T_app "vector" (T_args [T_arg_nexp (Ne_const (integerFromNat n)); T_arg_nexp (Ne_const (list_length vals)); - T_arg_order (Ord_aux (if is_inc(dir) then Ord_inc else Ord_dec) Unknown); - T_arg_typ t]) + mk_typ_app "vector" [Typ_arg_nexp (nconstant (integerFromNat n)); Typ_arg_nexp (nconstant (list_length vals)); + Typ_arg_order (Ord_aux (if is_inc dir then Ord_inc else Ord_dec) Unknown); + Typ_arg_typ t] | V_vector_sparse n m dir vals d -> let ts = List.map val_typ (d::(List.map snd vals)) in let t = combine_typs ts in - T_app "vector" (T_args [T_arg_nexp (Ne_const (integerFromNat n)); T_arg_nexp (Ne_const (integerFromNat m)); - T_arg_order (Ord_aux (if is_inc(dir) then Ord_inc else Ord_dec) Unknown); - T_arg_typ t]) + mk_typ_app "vector" [Typ_arg_nexp (nconstant (integerFromNat n)); Typ_arg_nexp (nconstant (integerFromNat m)); + Typ_arg_order (Ord_aux (if is_inc dir then Ord_inc else Ord_dec) Unknown); + Typ_arg_typ t] | V_record t ivals -> t - | V_list vals -> + | V_list vals -> let ts = List.map val_typ vals in let t = combine_typs ts in - T_app "list" (T_args [T_arg_typ t]) + mk_typ_app "list" [Typ_arg_typ t] | V_ctor id t _ vals -> t | V_register reg -> reg_to_t reg | V_track v _ -> val_typ v - | V_unknown -> T_var "fresh" (*consider carrying the type along*) - | V_register_alias _ _ -> T_var "fresh_alias" + | V_unknown -> mk_typ_var "fresh" + | V_register_alias _ _ -> mk_typ_var "fresh" end let rec to_exp mode env v : (exp tannot * lenv) = @@ -1324,37 +1320,36 @@ let rec to_exp mode env v : (exp tannot * lenv) = val env_to_let : interp_mode -> lenv -> (exp tannot) -> lenv -> ((exp tannot) * lenv) let rec env_to_let_help mode env taint_env = match env with | [] -> ([],taint_env) - | (i,v)::env -> + | (i,v)::env -> let t = (val_typ v) in let tan = (val_annot t) in let (e,taint_env) = to_exp mode taint_env v in let (rest,taint_env) = env_to_let_help mode env taint_env in ((((P_aux (P_id (id_of_string i)) (Unknown,tan)),e),t)::rest, taint_env) -end +end -let env_to_let mode (LEnv _ env) (E_aux e annot) taint_env = +let env_to_let mode (LEnv _ env) (E_aux e annot) taint_env = match env_to_let_help mode (Set_extra.toList (Map.toSet env)) taint_env with | ([],taint_env) -> (E_aux e annot,taint_env) | ([((p,e),t)],tain_env) -> - (E_aux (E_let (LB_aux (LB_val_implicit p e) (Unknown,(val_annot t))) e) annot,taint_env) + (E_aux (E_let (LB_aux (LB_val p e) (Unknown,(val_annot t))) e) annot,taint_env) | (pts,taint_env) -> let ts = List.map snd pts in let pes = List.map fst pts in let ps = List.map fst pes in let es = List.map snd pes in - let t = T_tup ts in + let t = mk_typ_tup ts in let tan = val_annot t in - (E_aux (E_let (LB_aux (LB_val_implicit (P_aux (P_tup ps) (Unknown,tan)) + (E_aux (E_let (LB_aux (LB_val (P_aux (P_tup ps) (Unknown,tan)) (E_aux (E_tuple es) (Unknown,tan))) (Unknown,tan)) (E_aux e annot)) annot, taint_env) -end +end -let fix_up_nondet typ branches annot = +let fix_up_nondet typ branches annot = match typ with - | T_id "unit" -> (branches, Nothing) - | T_abbrev _ (T_id "unit") -> (branches, Nothing) - | _ -> ((List.map + | Typ_aux (Typ_id (Id_aux (Id "unit") _)) _ -> (branches, Nothing) + | _ -> ((List.map (fun e -> E_aux (E_assign (LEXP_aux (LEXP_id redex_id) annot) e) annot) branches), Just "0") end @@ -1364,25 +1359,25 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in let (t,tag,cs) = match annot with | Just(t,tag,cs,e,_) -> (t,tag,cs) - | Nothing -> (T_var "fresh",Tag_empty,[]) end in + | Nothing -> (mk_typ_var "fresh",Tag_empty,[]) end in let value = detaint value_whole in let taint_pat v = binary_taint (fun v _ -> v) v value_whole in - match p with + match p with | P_lit(lit) -> if is_lit_vector lit then let (n, inc, bits) = match litV_to_vec lit default_dir with | V_vector n inc bits -> (n, inc, bits) - | _ -> Assert_extra.failwith "litV_to_vec failed" end in + | _ -> Assert_extra.failwith "litV_to_vec failed" end in match value with - | V_lit litv -> - if is_lit_vector litv then + | V_lit litv -> + if is_lit_vector litv then let (n', inc', bits') = match litV_to_vec litv default_dir with | V_vector n' inc' bits' -> (n', inc', bits') - | _ -> Assert_extra.failwith "litV_to_vec failed" end in + | _ -> Assert_extra.failwith "litV_to_vec failed" end in if n=n' && inc = inc' then (foldr2 (fun l r rest -> (l = r) && rest) true bits bits',false, eenv) else (false,false,eenv) else (false,false,eenv) - | V_vector n' inc' bits' -> + | V_vector n' inc' bits' -> (foldr2 (fun l r rest -> (l=r) && rest) true bits bits',false,eenv) | V_unknown -> (true,true,eenv) | _ -> (false,false,eenv) end @@ -1394,16 +1389,16 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = | _ -> (false,false,eenv) end | P_wild -> (true,false,eenv) - | P_as pat id -> + | P_as pat id -> let (matched_p,used_unknown,bounds) = match_pattern t_level pat value in if matched_p then (matched_p,used_unknown,(add_to_env (id,value_whole) bounds)) else (false,false,eenv) - | P_typ typ pat -> match_pattern t_level pat value_whole + | P_typ typ pat -> match_pattern t_level pat value_whole | P_id id -> (true, false, (LEnv 0 (Map.fromList [((get_id id),value_whole)]))) - | P_app (Id_aux id _) pats -> + | P_app (Id_aux id _) pats -> match value with - | V_ctor (Id_aux cid _) t ckind (V_tuple vals) -> + | V_ctor (Id_aux cid _) t ckind (V_tuple vals) -> if (id = cid && ((List.length pats) = (List.length vals))) then foldr2 (fun pat value (matched_p,used_unknown,bounds) -> @@ -1412,7 +1407,7 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = (matched_p, (used_unknown || used_unknown'), (union_env new_bounds bounds)) else (false,false,eenv)) (true,false,eenv) pats vals else (false,false,eenv) - | V_ctor (Id_aux cid _) t ckind (V_track (V_tuple vals) r) -> + | V_ctor (Id_aux cid _) t ckind (V_track (V_tuple vals) r) -> if (id = cid && ((List.length pats) = (List.length vals))) then foldr2 (fun pat value (matched_p,used_unknown,bounds) -> @@ -1430,10 +1425,10 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = | _ -> (false,false,eenv) end) else (false,false,eenv) | V_lit (L_aux (L_num i) _) -> - match tag with - | Tag_enum _ -> + match tag with + | Tag_enum _ -> match Map.lookup (get_id (Id_aux id Unknown)) lets with - | Just(V_ctor _ t (C_Enum j) _) -> + | Just(V_ctor _ t (C_Enum j) _) -> if i = (integerFromNat j) then (true,false,eenv) else (false,false,eenv) | _ -> (false,false,eenv) end @@ -1454,13 +1449,13 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = else (false,false,eenv)) (true,false,eenv) fpats | V_unknown -> (true,true,eenv) | _ -> (false,false,eenv) - end + end | P_vector pats -> match value with | V_vector n dir vals -> if ((List.length vals) = (List.length pats)) then foldr2 - (fun pat value (matched_p,used_unknown,bounds) -> + (fun pat value (matched_p,used_unknown,bounds) -> if matched_p then let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat value) in (matched_p, (used_unknown||used_unknown'), (union_env new_bounds bounds)) @@ -1472,8 +1467,8 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = then let (_,matched_p,used_unknown,bounds) = foldr (fun pat (i,matched_p,used_unknown,bounds) -> - if matched_p - then let (matched_p,used_unknown',new_bounds) = + if matched_p + then let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (match List.lookup i vals with | Nothing -> d | Just v -> (taint_pat v) end) in @@ -1485,49 +1480,23 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = | V_unknown -> (true,true,eenv) | _ -> (false,false,eenv) end - | P_vector_indexed ipats -> - match value with - | V_vector n dir vals -> - let v_len = if is_inc(dir) then List.length vals + n else n - List.length vals in - List.foldr - (fun (i,pat) (matched_p,used_unknown,bounds) -> - let i = natFromInteger i in - if matched_p && i < v_len then - let (matched_p,used_unknown',new_bounds) = - match_pattern t_level pat (taint_pat (list_nth vals (if is_inc(dir) then i+n else i-n))) in - (matched_p,used_unknown||used_unknown',(union_env new_bounds bounds)) - else (false,false,eenv)) - (true,false,eenv) ipats - | V_vector_sparse n m dir vals d -> - List.foldr - (fun (i,pat) (matched_p,used_unknown,bounds) -> - let i = natFromInteger i in - if matched_p && i < m then - let (matched_p,used_unknown',new_bounds) = - match_pattern t_level pat (match List.lookup i vals with | Nothing -> d | Just v -> (taint_pat v) end) in - (matched_p,used_unknown||used_unknown',(union_env new_bounds bounds)) - else (false,false,eenv)) - (true,false,eenv) ipats - | V_unknown -> (true,true,eenv) - | _ -> (false,false, eenv) - end | P_vector_concat pats -> match value with | V_vector n dir vals -> let (matched_p,used_unknown,bounds,remaining_vals) = vec_concat_match_top t_level pats vals dir in - (*List.foldl + (*List.foldl (fun (matched_p,used_unknown,bounds,r_vals) (P_aux pat (l,Just(t,_,_,_))) -> let (matched_p,used_unknown',bounds',matcheds,r_vals) = vec_concat_match_plev t_level pat r_vals inc l t in (matched_p,(used_unknown || used_unknown'),(union_env bounds' bounds),r_vals)) (true,false,eenv,vals) pats in*) - if matched_p && ([] = remaining_vals) then (matched_p,used_unknown,bounds) else (false,false,eenv) + if matched_p && ([] = remaining_vals) then (matched_p,used_unknown,bounds) else (false,false,eenv) | V_unknown -> (true,true,eenv) - | _ -> (false,false, eenv) + | _ -> (false,false, eenv) end | P_tup(pats) -> - match value with + match value with | V_tuple(vals) -> if ((List.length pats)= (List.length vals)) - then foldr2 + then foldr2 (fun pat v (matched_p,used_unknown,bounds) -> if matched_p then let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat v) in (matched_p,used_unknown ||used_unknown', (union_env new_bounds bounds)) @@ -1536,12 +1505,12 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = else (false,false,eenv) | V_unknown -> (true,true,eenv) | _ -> (false,false,eenv) - end + end | P_list(pats) -> - match value with + match value with | V_list(vals) -> if ((List.length pats)= (List.length vals)) - then foldr2 + then foldr2 (fun pat v (matched_p,used_unknown,bounds) -> if matched_p then let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat v) in (matched_p,used_unknown|| used_unknown', (union_env new_bounds bounds)) @@ -1550,12 +1519,12 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = else (false,false,eenv) | V_unknown -> (true,true,eenv) | _ -> (false,false,eenv) end - end + end and vec_concat_match_top t_level pats r_vals dir : ((*matched_p*) bool * (*used_unknown*) bool * lenv * (list value)) = match pats with | [] -> (true,false,eenv,r_vals) - | [(P_aux p (l,Just(t,_,_,_,_)))] -> + | [(P_aux p (l,Just(t,_,_,_,_)))] -> let (matched_p,used_unknown,bounds,_,r_vals) = vec_concat_match_plev t_level p r_vals dir l true t in (matched_p,used_unknown,bounds,r_vals) | (P_aux p (l,Just(t,_,_,_,_)))::pats -> @@ -1571,8 +1540,8 @@ and vec_concat_match_plev t_level pat r_vals dir l last_pat t = match pat with | P_lit (L_aux (L_bin bin_string) l') -> let bin_chars = toCharList bin_string in - let binpats = List.map - (fun b -> P_aux (match b with + let binpats = List.map + (fun b -> P_aux (match b with | #'0' -> P_lit (L_aux L_zero l') | #'1' -> P_lit (L_aux L_one l') | _ -> Assert_extra.failwith "bin not 0 or 1" end) (l',Nothing)) bin_chars in @@ -1580,62 +1549,53 @@ and vec_concat_match_plev t_level pat r_vals dir l last_pat t = | P_vector pats -> vec_concat_match t_level pats r_vals | P_id id -> (match t with - | T_app "vector" (T_args [T_arg_nexp _;T_arg_nexp (Ne_const i);_;_]) -> + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant i) _)) _;_;_]) _ -> let wilds = List.genlist (fun _ -> P_aux P_wild (l,Nothing)) (natFromInteger i) in let (matched_p,used_unknown,bounds,matcheds,r_vals) = vec_concat_match t_level wilds r_vals in - if matched_p - then (matched_p, used_unknown, + if matched_p + then (matched_p, used_unknown, (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length matcheds) - 1)) dir matcheds)) bounds), matcheds,r_vals) else (false,false,eenv,[],[]) - | T_abbrev _ (T_app "vector" (T_args [T_arg_nexp _;T_arg_nexp (Ne_const i);_;_])) -> - let wilds = List.genlist (fun _ -> P_aux P_wild (l,Nothing)) (natFromInteger i) in - let (matched_p,used_unknown,bounds,matcheds,r_vals) = vec_concat_match t_level wilds r_vals in - if matched_p - then (matched_p, used_unknown, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length matcheds) - 1)) dir matcheds)) - bounds), - matcheds,r_vals) - else (false,false,eenv,[],[]) - | T_app "vector" (T_args [T_arg_nexp _;T_arg_nexp nc;_;_]) -> - if last_pat - then - (true,false, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) - 1)) dir r_vals)) eenv), - r_vals,[]) - else (false,false,eenv,[],[]) (*TODO use some constraint bounds here*) - | _ -> - if last_pat - then - (true,false, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) -1 )) dir r_vals)) eenv), - r_vals,[]) - else (false,false,eenv,[],[]) end) + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp nc) _;_;_]) _ -> + if last_pat + then + (true,false, + (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) - 1)) dir r_vals)) eenv), + r_vals,[]) + else (false,false,eenv,[],[]) (*TODO use some constraint bounds here*) + | _ -> + if last_pat + then + (true,false, + (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) -1 )) dir r_vals)) eenv), + r_vals,[]) + else (false,false,eenv,[],[]) end) | P_wild -> (match t with - | T_app "vector" (T_args [T_arg_nexp _;T_arg_nexp (Ne_const i);_;_]) -> + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant i) _)) _;_;_]) _ -> let wilds = List.genlist (fun _ -> P_aux P_wild (l,Nothing)) (natFromInteger i) in - vec_concat_match t_level wilds r_vals - | T_app "vector" (T_args [T_arg_nexp _;T_arg_nexp nc;_;_]) -> + vec_concat_match t_level wilds r_vals + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp nc) _;_;_]) _ -> if last_pat - then + then (true,false,eenv,r_vals,[]) else (false,false,eenv,[],[]) (*TODO use some constraint bounds here*) - | _ -> + | _ -> if last_pat - then + then (true,false,eenv,r_vals,[]) else (false,false,eenv,[],[]) end) - | P_as (P_aux pat (l',Just(t',_,_,_,_))) id -> + | P_as (P_aux pat (l',Just(t',_,_,_,_))) id -> let (matched_p, used_unknown, bounds,matcheds,r_vals) = vec_concat_match_plev t_level pat r_vals dir l last_pat t' in - if matched_p + if matched_p then (matched_p, used_unknown, (add_to_env (id,V_vector (if is_inc(dir) then 0 else (List.length matcheds)) dir matcheds) bounds), matcheds,r_vals) - else (false,false,eenv,[],[]) + else (false,false,eenv,[],[]) | P_typ _ (P_aux p (l',Just(t',_,_,_,_))) -> vec_concat_match_plev t_level p r_vals dir l last_pat t - | _ -> (false,false,eenv,[],[]) end + | _ -> (false,false,eenv,[],[]) end (*TODO Need to support indexed here, skipping intermediate numbers but consumming r_vals, and as *) and vec_concat_match t_level pats r_vals = @@ -1645,7 +1605,7 @@ and vec_concat_match t_level pats r_vals = | [] -> (false,false,eenv,[],[]) | r::r_vals -> let (matched_p,used_unknown,new_bounds) = match_pattern t_level pat r in - if matched_p then + if matched_p then let (matched_p,used_unknown',bounds,matcheds,r_vals) = vec_concat_match t_level pats r_vals in (matched_p, used_unknown||used_unknown',(union_env new_bounds bounds),r :: matcheds,r_vals) else (false,false,eenv,[],[]) end @@ -1670,7 +1630,7 @@ val find_case : top_level -> list (pexp tannot) -> value -> list (lenv * bool * let rec find_case t_level pexps value = match pexps with | [] -> [] - | (Pat_aux (Pat_exp p e) _)::pexps -> + | (Pat_aux (Pat_exp p e) _)::pexps -> let (is_matching,used_unknown,env) = match_pattern t_level p value in if (is_matching && used_unknown) then (env,used_unknown,e)::find_case t_level pexps value @@ -1731,10 +1691,10 @@ let update_stack o fn = match o with | _ -> o end -let debug_out fn value e tl lm le = +let debug_out fn value e tl lm le = (Action (Step (get_exp_l e) fn value) (Thunk_frame e tl le lm Top),lm,le) -let to_exps mode env vals = +let to_exps mode env vals = List.foldr (fun v (es,env) -> let (e,env') = to_exp mode env v in (e::es, union_env env' env)) ([],env) vals let get_num v = match v with @@ -1745,12 +1705,12 @@ let get_num v = match v with let rec __exp_list mode t_level build_e build_v l_env l_mem vals exps = match exps with | [ ] -> (Value (build_v vals), l_mem, l_env) - | e::exps -> + | e::exps -> resolve_outcome (interp_main mode t_level l_env l_mem e) (fun value lm le -> exp_list mode t_level build_e build_v l_env lm (vals++[value]) exps) - (fun a -> update_stack a (add_to_top_frame - (fun e env -> - let (es,env') = to_exps mode env vals in + (fun a -> update_stack a (add_to_top_frame + (fun e env -> + let (es,env') = to_exps mode env vals in let (e,env'') = build_e (es++(e::exps)) env' in (e,env'')))) end @@ -1763,62 +1723,62 @@ and exp_list mode t_level build_e build_v l_env l_mem vals exps = and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let (typ,tag,ncs,effect,reffect) = match annot with + let (typ,tag,ncs,effect,reffect) = match annot with | Nothing -> - (T_var "fresh_v", Tag_empty,[],(Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) + (mk_typ_var "fresh_v", Tag_empty,[],(Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) | Just(t, tag, ncs, ef,efr) -> (t,tag,ncs,ef,efr) end in match exp with | E_internal_value v -> (Value v, l_mem, l_env) - | E_lit lit -> - if is_lit_vector lit - then let is_inc = (match typ with - | T_app "vector" (T_args [_;_;T_arg_order (Ord_aux Ord_inc _);_]) -> IInc | _ -> IDec end) in - (Value (litV_to_vec lit is_inc),l_mem,l_env) + | E_lit lit -> + if is_lit_vector lit + then let is_inc = (match typ with + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;_;Typ_arg_aux (Typ_arg_order (Ord_aux Ord_inc _)) _;_]) _ -> IInc | _ -> IDec end) in + (Value (litV_to_vec lit is_inc),l_mem,l_env) else (Value (V_lit (match lit with | L_aux L_false loc -> L_aux L_zero loc | L_aux L_true loc -> L_aux L_one loc | _ -> lit end)), l_mem,l_env) | E_comment _ -> (Value unitv, l_mem,l_env) - | E_comment_struc _ -> (Value unitv, l_mem, l_env) - | E_cast ((Typ_aux typ _) as ctyp) exp -> + | E_comment_struc _ -> (Value unitv, l_mem, l_env) + | E_cast ((Typ_aux typ _) as ctyp) exp -> (*Cast is either a no-op, a signal to read a register, or a signal to change the start of a vector *) - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> + (fun v lm le -> (* Potentially use cast to change vector start position *) let conditional_update_vstart () = match typ with | Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp(Nexp_aux (Nexp_constant i) _)) _;_;_;_] -> let i = natFromInteger i in - match (detaint v) with + match (detaint v) with | V_vector start dir vs -> if start = i then (Value v,lm,le) else (Value (update_vector_start dir i 1 v),lm,le) | _ -> (Value v,lm,le) end | (Typ_var (Kid_aux (Var "length") _))-> - match (detaint v) with + match (detaint v) with | V_vector start dir vs -> let i = (List.length vs) - 1 in if start = i then (Value v,lm,le) else (Value (update_vector_start dir i 1 v),lm,le) | _ -> (Value v,lm,le) end | _ -> (Value v,lm,le) end in - (match (tag,detaint v) with + (match (tag,detaint v) with (*Cast is telling us to read a register*) | (Tag_extern _, V_register regform) -> (Action (Read_reg regform Nothing) (mk_hole l (val_annot (reg_to_t regform)) t_level le lm), lm,le) (*Cast is changing vector start position, potentially*) | (_,v) -> conditional_update_vstart () end)) (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_cast ctyp e) (l,annot), env)))) - | E_id id -> + | E_id id -> let name = get_id id in match tag with - | Tag_empty -> + | Tag_empty -> match in_lenv l_env id with | V_boxref n t -> (Value (in_mem l_mem n),l_mem,l_env) | value -> (Value value,l_mem,l_env) end | Tag_global -> match in_env lets name with | Just(value) -> (Value value, l_mem,l_env) - | Nothing -> + | Nothing -> (match in_env regs name with | Just(value) -> (Value value, l_mem,l_env) | Nothing -> (Error l ("Internal error: " ^ name ^ " unbound on Tag_global"),l_mem,l_env) end) end @@ -1826,28 +1786,28 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = match in_env lets name with | Just(value) -> (Value value,l_mem,l_env) | Nothing -> (Error l ("Internal error: " ^ name ^ " unbound on Tag_enum "), l_mem,l_env) - end + end | Tag_extern _ -> (* update with id here when it's never just "register" *) let regf = match in_lenv l_env id with (* Check for local treatment of a register as a value *) | V_register regform -> regform - | _ -> + | _ -> match in_env regs name with (* Register isn't a local value, so pull from global environment *) | Just(V_register regform) -> regform | _ -> Form_Reg id annot default_dir end end in (Action (Read_reg regf Nothing) (mk_hole l annot t_level l_env l_mem), l_mem, l_env) - | Tag_alias -> + | Tag_alias -> match in_env aliases name with | Just aspec -> interp_alias_read mode t_level l_env l_mem aspec | _ -> (Error l ("Internal error: alias not found"), l_mem,l_env) end - | _ -> - (Error l + | _ -> + (Error l ("Internal error: tag " ^ (string_of_tag tag) ^ " expected empty,enum,alias,or extern for " ^ name), l_mem,l_env) end | E_if cond thn els -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem cond) - (fun value_whole lm le -> + (fun value_whole lm le -> let value = detaint value_whole in match (value,mode.eager_eval) with (*TODO remove booleans here when fully removed elsewhere *) @@ -1855,36 +1815,36 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = | (V_lit(L_aux L_one _),false) -> debug_out Nothing Nothing thn t_level lm l_env | (V_vector _ _ [(V_lit(L_aux L_one _))],true) -> interp_main mode t_level l_env lm thn | (V_vector _ _ [(V_lit(L_aux L_one _))],false) -> debug_out Nothing Nothing thn t_level lm l_env - | (V_unknown,_) -> + | (V_unknown,_) -> let (branches,maybe_id) = fix_up_nondet typ [thn;els] (l,annot) in interp_main mode t_level l_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)) - | (_,true) -> interp_main mode t_level l_env lm els + | (_,true) -> interp_main mode t_level l_env lm els | (_,false) -> debug_out Nothing Nothing els t_level lm l_env end) (fun a -> update_stack a (add_to_top_frame (fun c env -> (E_aux (E_if c thn els) (l,annot), env)))) | E_for id from to_ by ((Ord_aux o _) as order) exp -> let is_inc = match o with | Ord_inc -> true | _ -> false end in - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem from) (fun from_val_whole lm le -> let from_val = detaint from_val_whole in let (from_e,env) = to_exp mode le from_val_whole in match from_val with - | V_lit(L_aux(L_num from_num) fl) -> - resolve_outcome + | V_lit(L_aux(L_num from_num) fl) -> + resolve_outcome (interp_main mode t_level env lm to_) (fun to_val_whole lm le -> let to_val = detaint to_val_whole in let (to_e,env) = to_exp mode le to_val_whole in match to_val with | V_lit(L_aux (L_num to_num) tl) -> - resolve_outcome + resolve_outcome (interp_main mode t_level env lm by) (fun by_val_whole lm le -> let by_val = detaint by_val_whole in let (by_e,env) = to_exp mode le by_val_whole in - match by_val with + match by_val with | V_lit (L_aux (L_num by_num) bl) -> - if ((is_inc && (from_num > to_num)) || (not(is_inc) && (from_num < to_num))) + if ((is_inc && (from_num > to_num)) || (not(is_inc) && (from_num < to_num))) then (Value(V_lit (L_aux L_unit l)),lm,le) else let (ftyp,ttyp,btyp) = (val_typ from_val,val_typ to_val,val_typ by_val) in @@ -1894,95 +1854,95 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = | (V_lit _, V_lit _) -> ((E_aux (E_lit diff) augment_annot), env) | (V_track _ rs, V_lit _) -> to_exp mode env (taint (V_lit diff) rs) | (V_lit _, V_track _ rs) -> to_exp mode env (taint (V_lit diff) rs) - | (V_track _ r1, V_track _ r2) -> + | (V_track _ r1, V_track _ r2) -> (to_exp mode env (taint (V_lit diff) (r1 union r2))) | _ -> Assert_extra.failwith "For loop from and by values not range" end in - let e = + let e = (E_aux - (E_block - [(E_aux - (E_let - (LB_aux (LB_val_implicit (P_aux (P_id id) (fl,val_annot ftyp)) from_e) + (E_block + [(E_aux + (E_let + (LB_aux (LB_val (P_aux (P_id id) (fl,val_annot ftyp)) from_e) (Unknown,val_annot ftyp)) exp) (l,annot)); (E_aux (E_for id augment_e to_e by_e order exp) (l,annot))]) (l,annot)) in if mode.eager_eval - then interp_main mode t_level env lm e + then interp_main mode t_level env lm e else debug_out Nothing Nothing e t_level lm env - | V_unknown -> - let e = + | V_unknown -> + let e = (E_aux - (E_let - (LB_aux - (LB_val_implicit (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) + (E_let + (LB_aux + (LB_val (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) (fl, val_annot (val_typ from_val))) exp) (l,annot)) in interp_main mode t_level env lm e | _ -> (Error l "internal error: by must be a number",lm,le) end) - (fun a -> update_stack a + (fun a -> update_stack a (add_to_top_frame (fun b env -> (E_aux (E_for id from_e to_e b order exp) (l,annot), env)))) - | V_unknown -> + | V_unknown -> let e = (E_aux (E_let (LB_aux - (LB_val_implicit (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) + (LB_val (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) (fl, val_annot (val_typ from_val))) exp) (l,annot)) in interp_main mode t_level env lm e | _ -> (Error l "internal error: to must be a number",lm,env) end) - (fun a -> update_stack a - (add_to_top_frame (fun t env -> + (fun a -> update_stack a + (add_to_top_frame (fun t env -> (E_aux (E_for id from_e t by order exp) (l,annot), env)))) | V_unknown -> let e = (E_aux - (E_let (LB_aux (LB_val_implicit (P_aux (P_id id) (Unknown, val_annot (val_typ from_val))) from_e) + (E_let (LB_aux (LB_val (P_aux (P_id id) (Unknown, val_annot (val_typ from_val))) from_e) (Unknown, val_annot (val_typ from_val))) exp) (l,annot)) in interp_main mode t_level env lm e | _ -> (Error l "internal error: from must be a number",lm,le) end) (fun a -> update_stack a (add_to_top_frame (fun f env -> (E_aux (E_for id f to_ by order exp) (l,annot), env)))) | E_case exp pats -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem exp) (fun v lm le -> match find_case t_level pats v with | [] -> (Error l ("No matching patterns in case for value " ^ (string_of_value v)),lm,le) - | [(env,_,exp)] -> + | [(env,_,exp)] -> if mode.eager_eval then interp_main mode t_level (union_env env l_env) lm exp else debug_out Nothing Nothing exp t_level lm (union_env env l_env) | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> + let (lets,taint_env) = + List.foldr (fun (env,_,exp) (rst,taint_env) -> let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in interp_main mode t_level taint_env lm (E_aux (E_nondet branches) (l,(non_det_annot annot maybe_id))) end) (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_case e pats) (l,annot), env)))) - | E_record(FES_aux (FES_Fexps fexps _) fes_annot) -> + | E_record(FES_aux (FES_Fexps fexps _) fes_annot) -> let (fields,exps) = List.unzip (List.map (fun (FE_aux (FE_Fexp id exp) _) -> (id,exp)) fexps) in - exp_list mode t_level - (fun es env' -> - ((E_aux - (E_record - (FES_aux (FES_Fexps + exp_list mode t_level + (fun es env' -> + ((E_aux + (E_record + (FES_aux (FES_Fexps (map2 (fun id exp -> (FE_aux (FE_Fexp id exp) (Unknown,Nothing))) fields es) false) fes_annot)) (l,annot)), env')) (fun vs -> (V_record typ (List.zip fields vs))) l_env l_mem [] exps | E_record_update exp (FES_aux (FES_Fexps fexps _) fes_annot) -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem exp) (fun rv lm le -> match rv with | V_record t fvs -> let (fields,exps) = List.unzip (List.map (fun (FE_aux (FE_Fexp id exp) _) -> (id,exp)) fexps) in - resolve_outcome - (exp_list mode t_level - (fun es env'-> + resolve_outcome + (exp_list mode t_level + (fun es env'-> let (e,env'') = (to_exp mode env' rv) in - ((E_aux (E_record_update e - (FES_aux (FES_Fexps + ((E_aux (E_record_update e + (FES_aux (FES_Fexps (map2 (fun id exp -> (FE_aux (FE_Fexp id exp) (Unknown,Nothing))) fields es) false) fes_annot)) (l,annot)), env'')) @@ -1991,38 +1951,37 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = (fun a -> a) (*Due to exp_list this won't happen, but we want to functionaly update on Value *) | V_unknown -> (Value V_unknown, lm, le) | _ -> (Error l "internal error: record update requires record",lm,le) end) - (fun a -> update_stack a - (add_to_top_frame + (fun a -> update_stack a + (add_to_top_frame (fun e env -> (E_aux(E_record_update e (FES_aux(FES_Fexps fexps false) fes_annot)) (l,annot), env)))) | E_list(exps) -> exp_list mode t_level (fun exps env' -> (E_aux (E_list exps) (l,annot),env')) V_list l_env l_mem [] exps | E_cons hd tl -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem hd) - (fun hdv lm le -> + (fun hdv lm le -> resolve_outcome (interp_main mode t_level l_env lm tl) - (fun tlv lm le -> match detaint tlv with + (fun tlv lm le -> match detaint tlv with | V_list t -> (Value (retaint tlv (V_list (hdv::t))),lm,le) | V_unknown -> (Value (retaint tlv V_unknown),lm,le) | _ -> (Error l ("Internal error '::' of non-list value " ^ (string_of_value tlv)),lm,le) end) - (fun a -> update_stack a - (add_to_top_frame + (fun a -> update_stack a + (add_to_top_frame (fun t env -> let (hde,env') = to_exp mode env hdv in (E_aux (E_cons hde t) (l,annot),env'))))) (fun a -> update_stack a (add_to_top_frame (fun h env -> (E_aux (E_cons h tl) (l,annot), env)))) - | E_field exp id -> - resolve_outcome + | E_field exp id -> + resolve_outcome (interp_main mode t_level l_env l_mem exp) - (fun value_whole lm le -> - match detaint value_whole with - | V_record t fexps -> + (fun value_whole lm le -> + match detaint value_whole with + | V_record t fexps -> (match in_env (env_from_list fexps) (get_id id) with | Just v -> (Value (retaint value_whole v),lm,l_env) | Nothing -> (Error l "Internal_error: Field not found in record",lm,le) end) | V_register ((Form_Reg _ annot _) as reg_form) -> let id' = match annot with - | Just((T_id id'),_,_,_,_) -> id' - | Just((T_abbrev (T_id id') _),_,_,_,_) -> id' + | Just((Typ_aux (Typ_id (Id_aux (Id id') _)) _),_,_,_,_) -> id' | _ -> Assert_extra.failwith "annotation not well formed for field access" end in (match in_env subregs id' with @@ -2035,32 +1994,22 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = | _ -> (Error l "Internal error: unrecognized read, no id",lm,le) end) | Nothing -> (Error l "Internal error: subregs indexes not found", lm, le) end) | V_unknown -> (Value (retaint value_whole V_unknown),lm,l_env) - | _ -> - (Error l ("Internal error: neither register nor record at field access " + | _ -> + (Error l ("Internal error: neither register nor record at field access " ^ (string_of_value value_whole)),lm,le) end) - (fun a -> + (fun a -> match (exp,a) with | (E_aux _ (l,Just(_,Tag_extern _,_,_,_)), - (Action (Read_reg ((Form_Reg _ (Just((T_id id'),_,_,_,_)) _) as regf) Nothing) s)) -> + (Action (Read_reg ((Form_Reg _ (Just((Typ_aux (Typ_id (Id_aux (Id id') _)) _),_,_,_,_)) _) as regf) Nothing) s)) -> match in_env subregs id' with | Just(indexes) -> (match in_env indexes (get_id id) with - | Just ir -> - (Action (Read_reg (Form_SubReg id regf ir) Nothing) s) - | _ -> Error l "Internal error, unrecognized read, no id" - end) - | Nothing -> Error l "Internal error, unrecognized read, no reg" end - | (E_aux _ (l,Just(_,Tag_extern _,_,_,_)), - (Action (Read_reg ((Form_Reg _ (Just((T_abbrev (T_id id') _),_,_,_,_)) _) as regf) Nothing) s))-> - match in_env subregs id' with - | Just(indexes) -> - match in_env indexes (get_id id) with - | Just ir -> + | Just ir -> (Action (Read_reg (Form_SubReg id regf ir) Nothing) s) | _ -> Error l "Internal error, unrecognized read, no id" - end + end) | Nothing -> Error l "Internal error, unrecognized read, no reg" end - | _ -> update_stack a (add_to_top_frame (fun e env -> (E_aux(E_field e id) (l,annot),env))) end) + | _ -> update_stack a (add_to_top_frame (fun e env -> (E_aux(E_field e id) (l,annot),env))) end) | E_vector_access vec i -> resolve_outcome (interp_main mode t_level l_env l_mem vec) @@ -2261,130 +2210,95 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = (E_aux (E_vector_append e1_e e2') (l,annot), env'))))) (fun a -> update_stack a (add_to_top_frame (fun e1' env -> (E_aux (E_vector_append e1' e2) (l,annot), env)))) - | E_tuple(exps) -> + | E_tuple(exps) -> exp_list mode t_level (fun exps env' -> (E_aux (E_tuple exps) (l,annot), env')) V_tuple l_env l_mem [] exps | E_vector(exps) -> let (is_inc,dir) = (match typ with - | T_app "vector" (T_args [ _; _; T_arg_order (Ord_aux Ord_inc _); _]) -> (true,IInc) + | Typ_aux (Typ_app (Id_aux (Id "vector") _) [ _; _; Typ_arg_aux (Typ_arg_order (Ord_aux Ord_inc _)) _; _]) _ -> (true,IInc) | _ -> (false,IDec) end) in let base = (if is_inc then 0 else (List.length exps) - 1) in - exp_list mode t_level - (fun exps env' -> (E_aux (E_vector exps) (l,annot),env')) + exp_list mode t_level + (fun exps env' -> (E_aux (E_vector exps) (l,annot),env')) (fun vals -> V_vector base dir vals) l_env l_mem [] exps - | E_vector_indexed iexps (Def_val_aux default dannot) -> - let (indexes,exps) = List.unzip iexps in - let (dir,base,len) = (match typ with - | T_app "vector" (T_args [T_arg_nexp base;T_arg_nexp len; T_arg_order (Ord_aux Ord_inc _); _]) -> - (IInc,base,len) - | T_app "vector" (T_args [T_arg_nexp base;T_arg_nexp len; T_arg_order (Ord_aux _ _); _]) -> - (IDec,base,len) - | _ -> Assert_extra.failwith "Vector type not as expected for indexed vector" end) in - (match default with - | Def_val_empty -> - exp_list mode t_level - (fun es env' -> (E_aux (E_vector_indexed (map2 (fun i e -> (i,e)) indexes es) - (Def_val_aux default dannot)) (l,annot), env')) - (fun vals -> V_vector (if indexes=[] then 0 else (natFromInteger (List_extra.head indexes))) dir vals) - l_env l_mem [] exps - | Def_val_dec default_exp -> - let (b,len) = match (base,len) with - | (Ne_const b,Ne_const l) -> (natFromInteger b, natFromInteger l) - | _ -> Assert_extra.failwith "Vector start and end unset in vector with default value" end in - resolve_outcome - (interp_main mode t_level l_env l_mem default_exp) - (fun v lm le -> - exp_list mode t_level - (fun es env' -> - let (ev,env'') = to_exp mode env' v in - (E_aux (E_vector_indexed (map2 (fun i e -> (i,e)) indexes es) - (Def_val_aux (Def_val_dec ev) dannot)) - (l,annot), env'')) - (fun vs -> - (V_vector_sparse b len dir - (map2 (fun i v -> ((natFromInteger i),v)) indexes vs) v)) l_env l_mem [] exps) - (fun a -> - update_stack a - (add_to_top_frame (fun e env -> - (E_aux (E_vector_indexed iexps (Def_val_aux (Def_val_dec e) dannot)) (l,annot), env)))) end) | E_block exps -> interp_block mode t_level l_env l_env l_mem l annot exps | E_nondet exps -> - (Action (Nondet exps tag) + (Action (Nondet exps tag) (match tag with - | Tag_unknown (Just id) -> mk_hole l annot t_level l_env l_mem + | Tag_unknown (Just id) -> mk_hole l annot t_level l_env l_mem | _ -> mk_thunk l annot t_level l_env l_mem end), l_mem, l_env) | E_app f args -> - (match (exp_list mode t_level + (match (exp_list mode t_level (fun es env -> (E_aux (E_app f es) (l,annot),env)) - (fun vs -> match vs with | [] -> V_lit (L_aux L_unit l) | [v] -> v | vs -> V_tuple vs end) + (fun vs -> match vs with | [] -> V_lit (L_aux L_unit l) | [v] -> v | vs -> V_tuple vs end) l_env l_mem [] args) with - | (Value v,lm,le) -> - let name = get_id f in + | (Value v,lm,le) -> + let name = get_id f in (match tag with | Tag_global -> (match Map.lookup name fdefs with - | Just(funcls) -> + | Just(funcls) -> (match find_funcl t_level funcls v with - | [] -> + | [] -> (Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value v)),l_mem,l_env) | [(env,_,exp)] -> - resolve_outcome - (if mode.eager_eval + resolve_outcome + (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just v) exp t_level (emem name) env)) + else (debug_out (Just name) (Just v) exp t_level (emem name) env)) (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a + (fun a -> update_stack a (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> + let (lets,taint_env) = + List.foldr (fun (env,_,exp) (rst,taint_env) -> let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in let exp = E_aux (E_nondet branches) (l,(non_det_annot annot maybe_id)) in interp_main mode t_level taint_env lm exp end) - | Nothing -> + | Nothing -> (Error l ("Internal error: function with tag global unfound " ^ name),lm,le) end) - | Tag_empty -> + | Tag_empty -> (match Map.lookup name fdefs with - | Just(funcls) -> + | Just(funcls) -> (match find_funcl t_level funcls v with - | [] -> + | [] -> (Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value v)),l_mem,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval + | [(env,used_unknown,exp)] -> + resolve_outcome + (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just v) exp t_level (emem name) env)) + else (debug_out (Just name) (Just v) exp t_level (emem name) env)) (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a + (fun a -> update_stack a (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) | _ -> (Error l ("Internal error: multiple pattern matches found for " ^ name), l_mem, l_env) end) - | Nothing -> + | Nothing -> (Error l ("Internal error: function with local tag unfound " ^ name),lm,le) end) - | Tag_spec -> + | Tag_spec -> (match Map.lookup name fdefs with - | Just(funcls) -> + | Just(funcls) -> (match find_funcl t_level funcls v with - | [] -> + | [] -> (Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value v)),l_mem,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval + | [(env,used_unknown,exp)] -> + resolve_outcome + (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) else (debug_out (Just name) (Just v) exp t_level (emem name) env)) (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> - (Hole_frame redex_id + (fun a -> update_stack a + (fun stack -> + (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name), l_mem, l_env) end) - | Nothing -> + | Nothing -> (Error l (String.stringAppend "Specified function must be defined before executing " name),lm,le) end) | Tag_ctor -> (match Map.lookup name ctors with @@ -2396,10 +2310,10 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = let name_ext = match opt_name with | Just s -> s | Nothing -> name end in let mk_hole_frame act = (Action act (mk_hole l annot t_level le lm), lm, le) in let mk_thunk_frame act = (Action act (mk_thunk l annot t_level le lm), lm, le) in - if has_rmem_effect effects - then mk_hole_frame (Read_mem (id_of_string name_ext) v Nothing) - else if has_rmemt_effect effects - then mk_hole_frame (Read_mem_tagged (id_of_string name_ext) v Nothing) + if has_rmem_effect effects + then mk_hole_frame (Read_mem (id_of_string name_ext) v Nothing) + else if has_rmemt_effect effects + then mk_hole_frame (Read_mem_tagged (id_of_string name_ext) v Nothing) else if has_barr_effect effects then mk_thunk_frame (Barrier (id_of_string name_ext) v) else if has_depend_effect effects @@ -2407,11 +2321,11 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = else if has_wmem_effect effects then let (wv,v) = match v with - | V_tuple [p;v] -> (v,p) + | V_tuple [p;v] -> (v,p) | V_tuple params_list -> let reved = List.reverse params_list in (List_extra.head reved,V_tuple (List.reverse (List_extra.tail reved))) - | _ -> Assert_extra.failwith ("Expected tuple found " ^ (string_of_value v)) end in + | _ -> Assert_extra.failwith ("Expected tuple found " ^ (string_of_value v)) end in mk_hole_frame (Write_mem (id_of_string name_ext) v Nothing wv) else if has_eamem_effect effects then mk_thunk_frame (Write_ea (id_of_string name_ext) v) @@ -2428,57 +2342,57 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = mk_hole_frame (Write_memv (id_of_string name_ext) v wv) else if has_wmvt_effect effects then match v with - | V_tuple [addr; size; tag; data] -> + | V_tuple [addr; size; tag; data] -> mk_hole_frame (Write_memv_tagged (id_of_string name_ext) (V_tuple([addr; size])) tag data) | _ -> Assert_extra.failwith("wmvt: expected tuple of four elements") end - else mk_hole_frame (Call_extern name_ext v) + else mk_hole_frame (Call_extern name_ext v) | _ -> (Error l (String.stringAppend "Tag not empty, spec, ctor, or extern on function call " name),lm,le) end) | out -> out end) - | E_app_infix lft op r -> + | E_app_infix lft op r -> let op = match op with | Id_aux (Id x) il -> Id_aux (DeIid x) il | _ -> op end in let name = get_id op in - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem lft) - (fun lv lm le -> - resolve_outcome + (fun lv lm le -> + resolve_outcome (interp_main mode t_level l_env lm r) - (fun rv lm le -> + (fun rv lm le -> match tag with | Tag_global -> (match Map.lookup name fdefs with | Nothing -> (Error l ("Internal error: no function def for " ^ name),lm,le) | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with + (match find_funcl t_level funcls (V_tuple [lv;rv]) with | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) | [(env,used_unknown,exp)] -> - resolve_outcome + resolve_outcome (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) + else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> + (fun a -> update_stack a + (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name),lm,le) end)end) - | Tag_empty -> + | Tag_empty -> (match Map.lookup name fdefs with | Nothing -> (Error l ("Internal error: no function def for " ^ name),lm,le) | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with + (match find_funcl t_level funcls (V_tuple [lv;rv]) with | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) | [(env,used_unknown,exp)] -> - resolve_outcome + resolve_outcome (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) + else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a + (fun a -> update_stack a (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,annot)) t_level l_env l_mem stack))) | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name),lm,le) @@ -2487,15 +2401,15 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = (match Map.lookup name fdefs with | Nothing -> (Error l ("Internal error: No function definition found for " ^ name),lm,le) | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with + (match find_funcl t_level funcls (V_tuple [lv;rv]) with | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval + resolve_outcome + (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a + (fun a -> update_stack a (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) @@ -2503,12 +2417,12 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = end)end) | Tag_extern ext_name -> let ext_name = match ext_name with Just s -> s | Nothing -> name end in - (Action (Call_extern ext_name (V_tuple [lv;rv])) - (Hole_frame redex_id + (Action (Call_extern ext_name (V_tuple [lv;rv])) + (Hole_frame redex_id (E_aux (E_id redex_id) (l,intern_annot annot)) t_level le lm Top),lm,le) | _ -> (Error l "Internal error: unexpected tag for app_infix", l_mem, l_env) end) - (fun a -> update_stack a - (add_to_top_frame + (fun a -> update_stack a + (add_to_top_frame (fun r env -> let (el,env') = to_exp mode env lv in (E_aux (E_app_infix el op r) (l,annot), env'))))) (fun a -> update_stack a (add_to_top_frame (fun lft env -> (E_aux (E_app_infix lft op r) (l,annot), env)))) | E_exit exp -> @@ -2517,9 +2431,9 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = resolve_outcome (interp_main mode t_level l_env l_mem exp) (fun v lm le -> (Action (Return v) Top, l_mem, l_env)) - (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_return e) (l,annot), env)))) + (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_return e) (l,annot), env)))) | E_assert cond msg -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem msg) (fun v lm le -> resolve_outcome @@ -2530,43 +2444,43 @@ and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = | V_lit (L_aux L_true _) -> (Value unitv,lm,l_env) | V_lit (L_aux L_zero _) -> (Action (Fail v) (mk_thunk l annot t_level l_env l_mem), lm,le) | V_lit (L_aux L_false _) -> (Action (Fail v) (mk_thunk l annot t_level l_env l_mem), lm,le) - | V_unknown -> + | V_unknown -> let (branches,maybe_id) = fix_up_nondet typ [unit_e; E_aux (E_assert (E_aux (E_lit (L_aux L_zero l)) - (l,val_annot (T_id "bit"))) msg) (l,annot)] + (l,val_annot (mk_typ_id "bit"))) msg) (l,annot)] (l,annot) in interp_main mode t_level l_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)) | _ -> (Error l ("assert given unexpected " ^ (string_of_value c)),l_mem,l_env) end)) (fun a -> update_stack a (add_to_top_frame (fun c env -> (E_aux (E_assert c msg) (l,annot), env))))) (fun a -> update_stack a (add_to_top_frame (fun m env -> (E_aux (E_assert cond m) (l,annot), env)))) - | E_let (lbind : letbind tannot) exp -> + | E_let (lbind : letbind tannot) exp -> match (interp_letbind mode t_level l_env l_mem lbind) with | ((Value v,lm,le),_) -> if mode.eager_eval then interp_main mode t_level le lm exp - else debug_out Nothing Nothing exp t_level lm le - | (((Action a s as o),lm,le),Just lbuild) -> + else debug_out Nothing Nothing exp t_level lm le + | (((Action a s as o),lm,le),Just lbuild) -> ((update_stack o (add_to_top_frame (fun e env -> (E_aux (E_let (lbuild e) exp) (l,annot), env)))),lm,le) | (e,_) -> e end | E_assign lexp exp -> - resolve_outcome + resolve_outcome (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> + (fun v lm le -> (match create_write_message_or_update mode t_level v l_env lm true lexp with | (outcome,Nothing,_) -> outcome | (outcome,Just lexp_builder,Nothing) -> resolve_outcome outcome (fun v lm le -> (Value v,lm,le)) - (fun a -> + (fun a -> (match a with | (Action (Write_reg regf range value) stack) -> a | (Action (Write_mem id a_ range value) stack) -> a | (Action (Write_memv _ _ _) stack) -> a | (Action (Write_memv_tagged _ _ _ _) stack) -> a - | _ -> update_stack a (add_to_top_frame - (fun e env -> + | _ -> update_stack a (add_to_top_frame + (fun e env -> let (ev,env') = (to_exp mode env v) in let (lexp,env') = (lexp_builder e env') in (E_aux (E_assign lexp ev) (l,annot),env'))) end)) @@ -2593,17 +2507,17 @@ and interp_main mode t_level l_env l_mem exp = and __interp_block mode t_level init_env local_env local_mem l tannot exps = match exps with | [] -> (Value (V_lit (L_aux (L_unit) Unknown)), local_mem, init_env) - | [exp] -> + | [exp] -> if mode.eager_eval then interp_main mode t_level local_env local_mem exp else debug_out Nothing Nothing exp t_level local_mem local_env | exp:: exps -> resolve_outcome (interp_main mode t_level local_env local_mem exp) - (fun _ lm le -> + (fun _ lm le -> if mode.eager_eval then interp_block mode t_level init_env le lm l tannot exps else debug_out Nothing Nothing (E_aux (E_block exps) (l,tannot)) t_level lm le) - (fun a -> update_stack a + (fun a -> update_stack a (add_to_top_frame (fun e env-> (E_aux (E_block(e::exps)) (l,tannot), env)))) end @@ -2614,22 +2528,20 @@ and interp_block mode t_level init_env local_env local_mem l tannot exps = retval and __create_write_message_or_update mode t_level value l_env l_mem is_top_level - ((LEXP_aux lexp (l,annot)):lexp tannot) + ((LEXP_aux lexp (l,annot)):lexp tannot) : ((outcome * lmem * lenv) * maybe ((exp tannot) -> lenv -> ((lexp tannot) * lenv)) * maybe value) = let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let (typ,tag,ncs,ef,efr) = match annot with - | Nothing -> (T_var "fresh_v", Tag_empty, [], + let (typ,tag,ncs,ef,efr) = match annot with + | Nothing -> (mk_typ_var "fresh_v", Tag_empty, [], (Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) | Just(t, tag, ncs, ef,efr) -> (t,tag,ncs,ef,efr) end in - let recenter_val typ value = match typ with - | T_app "reg" (T_args [T_arg_typ - (T_app "vector" (T_args [T_arg_nexp (Ne_const start); T_arg_nexp (Ne_const size); _; _ ]))]) -> - update_vector_start default_dir (natFromInteger start) (natFromInteger size) value - | T_abbrev _ (T_app "vector" (T_args [T_arg_nexp (Ne_const start); T_arg_nexp (Ne_const size); _; _ ])) -> - update_vector_start default_dir (natFromInteger start) (natFromInteger size) value - | _ -> value end in + let recenter_val (Typ_aux typ _) value = match typ with + | Typ_app (Id_aux (Id "reg") _) [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant start) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant size) _)) _;_;_]) _)) _] -> + update_vector_start default_dir (natFromInteger start) (natFromInteger size) value + | _ -> value end in match lexp with - | LEXP_id id -> + | LEXP_id id -> let name = get_id id in match tag with | Tag_intro -> @@ -2638,16 +2550,16 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level if is_top_level then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else + else let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level - then + | v -> + if is_top_level + then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing,Nothing) else @@ -2655,143 +2567,129 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level Nothing, Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) end - | Tag_set -> + | Tag_set -> match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), + | ((V_boxref n t) as v) -> + if is_top_level + then ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing, Nothing) else ((Value v, l_mem, l_env),Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) | V_unknown -> if is_top_level then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else + else let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing, Nothing) - | v -> - if is_top_level - then + | v -> + if is_top_level + then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) else ((Error l ("Writes must be to reg values given " ^ (string_of_value v)),l_mem,l_env), Nothing, Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - end - | Tag_empty -> + end + | Tag_empty -> match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), + | ((V_boxref n t) as v) -> + if is_top_level + then ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing, Nothing) else ((Value v, l_mem, l_env),Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) | V_unknown -> if is_top_level then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else + else let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level - then + | v -> + if is_top_level + then if name = "0" then ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) else ((Error l ("Writes must be to reg values given " ^ (string_of_value v)),l_mem,l_env), Nothing, Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - end - | Tag_global -> + end + | Tag_global -> (match in_env lets name with - | Just v -> + | Just v -> if is_top_level then ((Error l "Writes must be to reg or registers",l_mem,l_env),Nothing,Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) | Nothing -> - let regf = + let regf = match in_env regs name with (*pull the regform with the most specific type annotation from env *) | Just(V_register regform) -> regform | _ -> Assert_extra.failwith "Register not known in regenv" end in let start_pos = reg_start_pos regf in - let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing + let reg_size = reg_size regf in + let request = + (Action (Write_reg regf Nothing (if is_top_level then (update_vector_start default_dir start_pos reg_size value) else value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env) in - if is_top_level then (request,Nothing,Nothing) + if is_top_level then (request,Nothing,Nothing) else (request,Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) end) | Tag_extern _ -> - let regf = + let regf = match in_env regs name with (*pull the regform with the most specific type annotation from env *) | Just(V_register regform) -> regform | _ -> Assert_extra.failwith "Register not known in regenv" end in let start_pos = reg_start_pos regf in let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing + let request = + (Action (Write_reg regf Nothing (if is_top_level then (update_vector_start default_dir start_pos reg_size value) else value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env) in - if is_top_level then (request,Nothing,Nothing) + if is_top_level then (request,Nothing,Nothing) else (request,Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)),Nothing) - | Tag_alias -> - let request = + | Tag_alias -> + let request = (match in_env aliases name with - | Just (AL_aux aspec (l,_)) -> + | Just (AL_aux aspec (l,_)) -> (match aspec with - | AL_subreg (RI_aux (RI_id reg) (li, ((Just((T_id id),_,_,_,_)) as annot'))) subreg -> + | AL_subreg (RI_aux (RI_id reg) (li, ((Just((Typ_aux (Typ_id (Id_aux (Id id) _)) _),_,_,_,_)) as annot'))) subreg -> (match in_env subregs id with - | Just indexes -> + | Just indexes -> (match in_env indexes (get_id subreg) with - | Just ir -> - (Action - (Write_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing + | Just ir -> + (Action + (Write_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing (update_vector_start default_dir (get_first_index_range ir) (get_index_range_size ir) value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) t_level l_env l_mem Top), l_mem, l_env) | _ -> (Error l "Internal error, alias spec has unknown field", l_mem, l_env) end) - | _ -> + | _ -> (Error l ("Internal error: alias spec has unknown register type " ^ id), l_mem, l_env) end) - | AL_subreg (RI_aux (RI_id reg) (li, ((Just((T_abbrev (T_id id) _),_,_,_,_)) as annot'))) subreg -> - (match in_env subregs id with - | Just indexes -> - (match in_env indexes (get_id subreg) with - | Just ir -> - (Action - (Write_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing - (update_vector_start default_dir (get_first_index_range ir) - (get_index_range_size ir) value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) - t_level l_env l_mem Top), l_mem, l_env) - | _ -> (Error l "Internal error, alias spec has unknown field", l_mem, l_env) end) - | _ -> - (Error l ("Internal error: alias spec has unknown register type "^id), l_mem, l_env) end) | AL_bit (RI_aux (RI_id reg) (_,annot')) e -> - resolve_outcome (interp_main mode t_level l_env l_mem e) - (fun v le lm -> match v with - | V_lit (L_aux (L_num i) _) -> + resolve_outcome (interp_main mode t_level l_env l_mem e) + (fun v le lm -> match v with + | V_lit (L_aux (L_num i) _) -> let i = natFromInteger i in - (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (i,i)) - (update_vector_start default_dir i 1 value)) + (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (i,i)) + (update_vector_start default_dir i 1 value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) t_level l_env l_mem Top), l_mem, l_env) | _ -> (Error l "Internal error: alias bit has non number", l_mem, l_env) end) (fun a -> a) - | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> + | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> resolve_outcome (interp_main mode t_level l_env l_mem start) - (fun v lm le -> - match detaint v with + (fun v lm le -> + match detaint v with | V_lit (L_aux (L_num start) _) -> (resolve_outcome (interp_main mode t_level l_env lm stop) (fun v le lm -> @@ -2799,7 +2697,7 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | V_lit (L_aux (L_num stop) _) -> let (start,stop) = (natFromInteger start,natFromInteger stop) in let size = if start < stop then stop - start +1 else start -stop +1 in - (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (start,stop)) + (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (start,stop)) (update_vector_start default_dir start size value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) t_level l_env l_mem Top), @@ -2808,23 +2706,24 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level (fun a -> a)) | _ -> (Error l "Alias slice has non number",l_mem,l_env) end) (fun a -> a) - | AL_concat (RI_aux (RI_id reg1) (l1,annot1)) (RI_aux (RI_id reg2) annot2) -> - let val_typ t = match t with - | T_app "register" (T_args [T_arg_typ t]) -> t - | T_abbrev _ (T_app "register" (T_args [T_arg_typ t])) -> t + | AL_concat (RI_aux (RI_id reg1) (l1,annot1)) (RI_aux (RI_id reg2) annot2) -> + let val_typ (Typ_aux t _) = match t with + | Typ_app (Id_aux (Id "register") _) [Typ_arg_aux (Typ_arg_typ t) _] -> t | _ -> Assert_extra.failwith "alias type ill formed" end in let (t1,t2) = match (annot1,annot2) with | (Just (t1,_,_,_,_), (_,(Just (t2,_,_,_,_)))) -> (val_typ t1,val_typ t2) | _ -> Assert_extra.failwith "type annotations ill formed" end in (match (t1,t2) with - | (T_app "vector" (T_args [T_arg_nexp (Ne_const b1); T_arg_nexp (Ne_const r1); _;_]), - T_app "vector" (T_args [T_arg_nexp (Ne_const b2); T_arg_nexp (Ne_const r2); _;_])) -> - (Action - (Write_reg (Form_Reg reg1 annot1 default_dir) Nothing + | (Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b1) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r1) _)) _; _;_]) _, + Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b2) _)) _; + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r2) _)) _; _;_]) _) -> + (Action + (Write_reg (Form_Reg reg1 annot1 default_dir) Nothing (slice_vector value (natFromInteger b1) (natFromInteger r1))) (Thunk_frame (E_aux (E_assign (LEXP_aux (LEXP_id reg2) annot2) - (fst (to_exp <| mode with track_values =false|> eenv + (fst (to_exp <| mode with track_values =false|> eenv (slice_vector value (natFromInteger (r1+1)) (natFromInteger r2))))) annot2) t_level l_env l_mem Top), l_mem,l_env) @@ -2832,182 +2731,182 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | _ -> (Error l "Internal error: alias spec ill formed", l_mem, l_env) end) | _ -> (Error l ("Internal error: alias not found for id " ^(get_id id)),l_mem,l_env) end) in (request,Nothing,Nothing) - | _ -> + | _ -> ((Error l ("Internal error: writing to id with tag other than extern, empty, or alias " ^ (get_id id)), l_mem,l_env),Nothing,Nothing) - end - | LEXP_memory id exps -> - match (exp_list mode t_level (fun exps env -> (E_aux (E_tuple exps) (Unknown,Nothing),env)) + end + | LEXP_memory id exps -> + match (exp_list mode t_level (fun exps env -> (E_aux (E_tuple exps) (Unknown,Nothing),env)) (fun vs -> match vs with | [] -> V_lit (L_aux L_unit Unknown) | [v] -> v | vs -> V_tuple vs end) l_env l_mem [] exps) with | (Value v,lm,le) -> (match tag with | Tag_extern _ -> - let request = + let request = let effects = (match ef with | Effect_aux(Effect_set es) _ -> es | _ -> [] end) in - let act = if has_wmem_effect effects then (Write_mem id v Nothing value) + let act = if has_wmem_effect effects then (Write_mem id v Nothing value) else if has_wmv_effect effects then (Write_memv id v value) else Assert_extra.failwith "LEXP_memory with neither wmem or wmv event" in - (Action act + (Action act (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env lm Top), lm,l_env) in - if is_top_level then (request,Nothing,Nothing) - else + if is_top_level then (request,Nothing,Nothing) + else (request, Just (fun e env-> let (parms,env) = (to_exps mode env (match v with | V_tuple vs -> vs | v -> [v] end)) in (LEXP_aux (LEXP_memory id parms) (l,annot), env)), Nothing) | Tag_global -> - let name = get_id id in + let name = get_id id in (match Map.lookup name fdefs with - | Just(funcls) -> - let new_vals = match v with + | Just(funcls) -> + let new_vals = match v with | V_tuple vs -> V_tuple (vs ++ [value]) | V_lit (L_aux L_unit _) -> V_tuple [v;value] (*hmmm may be wrong in some code*) | v -> V_tuple [v;value] end in (match find_funcl t_level funcls new_vals with | [] -> ((Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value new_vals)),l_mem,l_env),Nothing, Nothing) - | [(env,used_unknown,exp)] -> - (match (if mode.eager_eval + | [(env,used_unknown,exp)] -> + (match (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) else (debug_out (Just name) (Just new_vals) exp t_level (emem name) env)) with | (Value ret, _,_) -> ((Value ret, l_mem,l_env),Nothing, Nothing) | (Action action stack,lm,le) -> - (((update_stack (Action action stack) + (((update_stack (Action action stack) (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))), l_mem,l_env), Nothing, Nothing) | (e,lm,le) -> ((e,lm,le),Nothing,Nothing) end) | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> + let (lets,taint_env) = + List.foldr (fun (env,_,exp) (rst,taint_env) -> let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in (interp_main mode t_level taint_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)), Nothing, Nothing) end) - | Nothing -> + | Nothing -> ((Error l ("Internal error: function unfound " ^ name),lm,le),Nothing,Nothing) end) | Tag_spec -> - let name = get_id id in + let name = get_id id in (match Map.lookup name fdefs with - | Just(funcls) -> - let new_vals = match v with + | Just(funcls) -> + let new_vals = match v with | V_tuple vs -> V_tuple (vs ++ [value]) | V_lit (L_aux L_unit _) -> V_tuple [v;value] (*hmmm may be wrong in some code*) | v -> V_tuple [v;value] end in (match find_funcl t_level funcls new_vals with | [] -> ((Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value new_vals)),l_mem,l_env),Nothing,Nothing) - | [(env,used_unknown,exp)] -> - (match (if mode.eager_eval + | [(env,used_unknown,exp)] -> + (match (if mode.eager_eval then (interp_main mode t_level env (emem name) exp) else (debug_out (Just name) (Just new_vals) exp t_level (emem name) env)) with | (Value ret, _,_) -> ((Value ret, l_mem,l_env),Nothing,Nothing) | (Action action stack,lm,le) -> - (((update_stack (Action action stack) + (((update_stack (Action action stack) (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))), l_mem,l_env), Nothing, Nothing) | (e,lm,le) -> ((e,lm,le),Nothing,Nothing) end) | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> + let (lets,taint_env) = + List.foldr (fun (env,_,exp) (rst,taint_env) -> let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in (interp_main mode t_level taint_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)), Nothing,Nothing) end) - | Nothing -> + | Nothing -> ((Error l ("Internal error: function unfound " ^ name),lm,le),Nothing,Nothing) end) - | _ -> ((Error l "Internal error: unexpected tag for memory or register write", lm,le),Nothing,Nothing) + | _ -> ((Error l "Internal error: unexpected tag for memory or register write", lm,le),Nothing,Nothing) end) - | (Action a s,lm, le) -> + | (Action a s,lm, le) -> ((Action a s,lm,le), Just (fun (E_aux e _) env -> (match e with | E_tuple es -> (LEXP_aux (LEXP_memory id es) (l,annot), env) | _ -> Assert_extra.failwith "Lexp builder not well formed" end)), Nothing) | e -> (e,Nothing,Nothing) end - | LEXP_cast typc id -> + | LEXP_cast typc id -> let name = get_id id in match tag with | Tag_intro -> match detaint (in_lenv l_env id) with - | V_unknown -> - if is_top_level + | V_unknown -> + if is_top_level then begin let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) end else ((Error l ("LEXP:cast1: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing, Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing, Nothing) + | v -> + if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing, Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)), Nothing) end | Tag_set -> match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), + | ((V_boxref n t) as v) -> + if is_top_level + then ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing,Nothing) else ((Value v, l_mem, l_env), Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level + | V_unknown -> + if is_top_level then begin let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) end else ((Error l ("LEXP:cast2: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) + | v -> + if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) else ((Value v,l_mem,l_env), Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)),Nothing) - end + end | Tag_empty -> match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), + | ((V_boxref n t) as v) -> + if is_top_level + then ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing,Nothing) else ((Value v, l_mem, l_env), Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level + | V_unknown -> + if is_top_level then begin let (LMem owner c m s) = l_mem in let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, + ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) end else ((Error l ("LEXP:cast3: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) + | v -> + if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)),Nothing) - end + end | Tag_extern _ -> - let regf = + let regf = match in_env regs name with (*pull the regform with the most specific type annotation from env *) | Just(V_register regform) -> regform | _ -> Assert_extra.failwith "Register not known in regenv" end in let start_pos = reg_start_pos regf in let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing - (if is_top_level - then (update_vector_start default_dir start_pos reg_size value) - else value)) + let request = + (Action (Write_reg regf Nothing + (if is_top_level + then (update_vector_start default_dir start_pos reg_size value) + else value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env) in if is_top_level then (request,Nothing,Nothing) else (request,Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)),Nothing) - | _ -> + | _ -> ((Error l ("Internal error: writing to id not extern or empty " ^(get_id id)),l_mem,l_env), Nothing,Nothing) end @@ -3037,15 +2936,15 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | _ -> ((Error l "Internal error: Unexpected pattern match failure in LEXP_tup",l_mem,l_env),Nothing,Nothing) end) - end - | LEXP_vector lexp exp -> + end + | LEXP_vector lexp exp -> match (interp_main mode t_level l_env l_mem exp) with | (Value i,lm,le) -> - (match detaint i with + (match detaint i with | V_unknown -> ((Value i,lm,le),Nothing,Nothing) - | V_lit (L_aux (L_num n) ln) -> - let next_builder le_builder = - (fun e env -> + | V_lit (L_aux (L_num n) ln) -> + let next_builder le_builder = + (fun e env -> let (lexp,env) = le_builder e env in let (ie,env) = to_exp mode env i in (LEXP_aux (LEXP_vector lexp ie) (l,annot), env)) in @@ -3054,29 +2953,29 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | ((Value v_whole,lm,le),maybe_builder,maybe_value) -> let v = detaint v_whole in let nth _ = detaint (access_vector v n) in - (match v with + (match v with | V_unknown -> ((Value v_whole,lm,le),Nothing,Nothing) - | V_boxref i _ -> + | V_boxref i _ -> (match (in_mem lm i,is_top_level,maybe_builder) with | ((V_vector _ _ _ as vec),true,_) -> let new_vec = fupdate_vector_slice vec (V_vector 1 default_dir [value]) n n in - ((Value (V_lit (L_aux L_unit Unknown)), + ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm i new_vec, l_env), Nothing,Nothing) | ((V_track (V_vector _ _ _ as vec) r), true,_) -> let new_vec = fupdate_vector_slice vec (V_vector 1 default_dir [value]) n n in - ((Value (V_lit (L_aux L_unit Unknown)), + ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm i (taint new_vec r),l_env),Nothing,Nothing) | ((V_vector _ _ _ as vec),false, Just lexp_builder) -> ((Value (access_vector vec n), lm, l_env), Just (next_builder lexp_builder),Nothing) - | (v,_,_) -> + | (v,_,_) -> Assert_extra.failwith("no vector findable in set bit, found " ^ (string_of_value v)) end ) - | V_vector inc m vs -> + | V_vector inc m vs -> (match (nth(),is_top_level,maybe_builder) with | (V_register regform,true,_) -> let start_pos = reg_start_pos regform in let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) + ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env), @@ -3084,75 +2983,75 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | (V_register regform,false,Just lexp_builder) -> let start_pos = reg_start_pos regform in let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) + ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env), Just (next_builder lexp_builder),maybe_value) - | (V_boxref n t,true,_) -> + | (V_boxref n t,true,_) -> ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm n value, l_env), Nothing,Nothing) | (V_unknown,true,_) -> ((Value (V_lit (L_aux L_unit Unknown)), lm, l_env),Nothing,Nothing) - | (v,true,_) -> + | (v,true,_) -> ((Error l "Vector does not contain reg or register values",lm,l_env),Nothing,Nothing) - | ((V_boxref n t),false, Just lexp_builder) -> + | ((V_boxref n t),false, Just lexp_builder) -> ((Value (in_mem lm n),lm, l_env),Just (next_builder lexp_builder),Nothing) - | (v,false, Just lexp_builder) -> + | (v,false, Just lexp_builder) -> ((Value v,lm,le), Just (next_builder lexp_builder),Nothing) - | _ -> Assert_extra.failwith "Vector assignment logic incomplete" + | _ -> Assert_extra.failwith "Vector assignment logic incomplete" end) | V_vector_sparse n m inc vs d -> (match (nth(),is_top_level,maybe_builder) with | (V_register regform,true,_) -> - let start_pos = reg_start_pos regform in + let start_pos = reg_start_pos regform in let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) + ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env),Nothing,Nothing) | (V_register regform,false,Just lexp_builder) -> let start_pos = reg_start_pos regform in let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) + ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), l_mem,l_env), Just (next_builder lexp_builder),Nothing) - | (V_boxref n t,true,_) -> + | (V_boxref n t,true,_) -> ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm n value, l_env), Nothing,Nothing) - | (v,true,_) -> + | (v,true,_) -> ((Error l ("Vector does not contain reg or register values " ^ (string_of_value v)), lm,l_env), Nothing,Nothing) - | ((V_boxref n t),false, Just lexp_builder) -> + | ((V_boxref n t),false, Just lexp_builder) -> ((Value (in_mem lm n),lm, l_env),Just (next_builder lexp_builder),Nothing) - | (v,false, Just lexp_builder) -> + | (v,false, Just lexp_builder) -> ((Value v,lm,le), Just (next_builder lexp_builder), Nothing) | _ -> Assert_extra.failwith "Vector assignment logic incomplete" end) - | v -> + | v -> ((Error l ("Vector access to write of non-vector" ^ (string_of_value v)),lm,l_env),Nothing,Nothing) end) | ((Action a s,lm,le),Just lexp_builder,maybe_value) -> (match (a,is_top_level) with - | ((Write_reg regf Nothing value),true) -> - ((Action (Write_reg regf (Just (n,n)) - (if (vector_length value) = 1 + | ((Write_reg regf Nothing value),true) -> + ((Action (Write_reg regf (Just (n,n)) + (if (vector_length value) = 1 then (update_vector_start default_dir n 1 value) else (access_vector value n))) s, lm,le), Nothing, Nothing) - | ((Write_reg regf Nothing value),false) -> - ((Action (Write_reg regf (Just (n,n)) - (if (vector_length value) = 1 + | ((Write_reg regf Nothing value),false) -> + ((Action (Write_reg regf (Just (n,n)) + (if (vector_length value) = 1 then (update_vector_start default_dir n 1 value) else (access_vector value n))) s,lm,le), Just (next_builder lexp_builder), Nothing) - | ((Write_mem id a Nothing value),true) -> + | ((Write_mem id a Nothing value),true) -> ((Action (Write_mem id a (Just (n,n)) value) s,lm,le), Nothing, Nothing) - | ((Write_mem id a Nothing value),false) -> + | ((Write_mem id a Nothing value),false) -> ((Action (Write_mem id a (Just (n,n)) value) s,lm,le), Just (next_builder lexp_builder), Nothing) | _ -> ((Action a s,lm,le), Just (next_builder lexp_builder), Nothing) end) | e -> e end) - | v -> + | v -> ((Error l ("Vector access must be a number given " ^ (string_of_value v)),lm,le),Nothing,Nothing) end) - | (Action a s,lm,le) -> + | (Action a s,lm,le) -> ((Action a s,lm,le), Just (fun e env -> (LEXP_aux (LEXP_vector lexp e) (l,annot), env)), Nothing) | e -> (e,Nothing,Nothing) end | LEXP_vector_range lexp exp1 exp2 -> @@ -3166,8 +3065,8 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level (match detaint i2 with | V_unknown -> ((Value i2,lm,le),Nothing,Nothing) | V_lit (L_aux (L_num n2) ln2) -> - let next_builder le_builder = - (fun e env -> + let next_builder le_builder = + (fun e env -> let (e1,env) = to_exp mode env i1 in let (e2,env) = to_exp mode env i2 in let (lexp,env) = le_builder e env in @@ -3176,33 +3075,33 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level (match (create_write_message_or_update mode t_level value l_env lm false lexp) with | ((Value v,lm,le), Just lexp_builder,_) -> (match (detaint v,is_top_level) with - | (V_vector m inc vs,true) -> - ((Value (V_lit (L_aux L_unit Unknown)), + | (V_vector m inc vs,true) -> + ((Value (V_lit (L_aux L_unit Unknown)), update_vector_slice mode.track_lmem v value n1 n2 lm, l_env), Nothing, Nothing) - | (V_boxref _ _, true) -> - ((Value (V_lit (L_aux L_unit Unknown)), + | (V_boxref _ _, true) -> + ((Value (V_lit (L_aux L_unit Unknown)), update_vector_slice mode.track_lmem v value n1 n2 lm, l_env), Nothing, Nothing) | (V_vector m inc vs,false) -> ((Value (slice_vector v n1 n2),lm,l_env), Just (next_builder lexp_builder), Nothing) | (V_register regform,true) -> let start_pos = reg_start_pos regform in let reg_size = reg_size regform in - ((Action (Write_reg regform (Just (n1,n2)) (update_vector_start default_dir start_pos reg_size v)) + ((Action (Write_reg regform (Just (n1,n2)) (update_vector_start default_dir start_pos reg_size v)) (mk_thunk l annot t_level l_env l_mem), l_mem,l_env), Just (next_builder lexp_builder), Nothing) - | (V_unknown,_) -> + | (V_unknown,_) -> let inc = n1 < n2 in let start = if inc then n1 else (n2-1) in - let size = if inc then n2-n1 +1 else n1 -n2 +1 in + let size = if inc then n2-n1 +1 else n1 -n2 +1 in ((Value (V_vector start (if inc then IInc else IDec) (List.replicate size V_unknown)), lm,l_env),Nothing,Nothing) | _ -> ((Error l "Vector required",lm,le),Nothing,Nothing) end) | ((Action (Write_reg regf Nothing value) s, lm,le), Just lexp_builder,_) -> let len = (if n1 < n2 then n2 -n1 else n1 - n2) +1 in - ((Action - (Write_reg regf (Just (n1,n2)) - (if (vector_length value) <= len + ((Action + (Write_reg regf (Just (n1,n2)) + (if (vector_length value) <= len then (update_vector_start default_dir n1 len value) else (slice_vector value n1 n2))) s,lm,le), Just (next_builder lexp_builder), Nothing) @@ -3213,8 +3112,8 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | e -> e end) | _ -> ((Error l "Vector slice requires a number", lm, le),Nothing,Nothing) end) | (Action a s,lm,le) -> - ((Action a s,lm, le), - Just (fun e env -> + ((Action a s,lm, le), + Just (fun e env -> let (e1,env) = to_exp mode env i1 in (LEXP_aux (LEXP_vector_range lexp e1 e) (l,annot), env)), Nothing) | e -> (e,Nothing,Nothing) end) @@ -3225,53 +3124,39 @@ and __create_write_message_or_update mode t_level value l_env l_mem is_top_level | LEXP_field lexp id -> (match (create_write_message_or_update mode t_level value l_env l_mem false lexp) with | ((Value (V_record t fexps),lm,le),Just lexp_builder,_) -> - let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in + let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in (LEXP_aux (LEXP_field lexp id) (l,annot), env)) in match (in_env (env_from_list fexps) (get_id id),is_top_level) with - | (Just (V_boxref n t),true) -> + | (Just (V_boxref n t),true) -> ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem lm n value, l_env),Nothing,Nothing) | (Just (V_boxref n t),false) -> ((Value (in_mem lm n),lm,l_env),next_builder,Nothing) | (Just v, true) -> ((Error l "Mutating a field access requires a reg type",lm,le),Nothing,Nothing) | (Just v,false) -> ((Value v,lm,l_env),next_builder,Nothing) | (Nothing,_) -> ((Error l "Field not found in specified record",lm,le),Nothing,Nothing) end - | ((Action a s,lm,le), Just lexp_builder,_) -> - let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in + | ((Action a s,lm,le), Just lexp_builder,_) -> + let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in (LEXP_aux (LEXP_field lexp id) (l,annot), env)) in match a with | Read_reg _ _ -> ((Action a s,lm,le), next_builder, Nothing) | Read_mem _ _ _ -> ((Action a s,lm,le), next_builder, Nothing) | Read_mem_tagged _ _ _ -> ((Action a s,lm,le), next_builder, Nothing) | Call_extern _ _ -> ((Action a s,lm,le), next_builder, Nothing) - | Write_reg ((Form_Reg _ (Just(T_id id',_,_,_,_)) _) as regf) Nothing value -> - match in_env subregs id' with - | Just(indexes) -> - match in_env indexes (get_id id) with - | Just ir -> - ((Action - (Write_reg (Form_SubReg id regf ir) Nothing - (update_vector_start default_dir (get_first_index_range ir) - (get_index_range_size ir) value)) s, - lm,le), - (if is_top_level then Nothing else next_builder), Nothing) - | _ -> ((Error l "Internal error, unrecognized write, no field",lm,le),Nothing,Nothing) - end - | Nothing -> ((Error l "Internal error, unrecognized write, no subreges",lm,le),Nothing,Nothing) end - | Write_reg ((Form_Reg _ (Just((T_abbrev(T_id id') _),_,_,_,_)) _) as regf) Nothing value -> + | Write_reg ((Form_Reg _ (Just(Typ_aux (Typ_id (Id_aux (Id id') _)) _,_,_,_,_)) _) as regf) Nothing value -> match in_env subregs id' with | Just(indexes) -> match in_env indexes (get_id id) with - | Just ir -> - ((Action - (Write_reg (Form_SubReg id regf ir) Nothing + | Just ir -> + ((Action + (Write_reg (Form_SubReg id regf ir) Nothing (update_vector_start default_dir (get_first_index_range ir) (get_index_range_size ir) value)) s, - lm,le), + lm,le), (if is_top_level then Nothing else next_builder), Nothing) | _ -> ((Error l "Internal error, unrecognized write, no field",lm,le),Nothing,Nothing) - end + end | Nothing -> ((Error l "Internal error, unrecognized write, no subreges",lm,le),Nothing,Nothing) end | _ -> ((Error l "Internal error, unrecognized write, no matching action",lm,le),Nothing,Nothing) - end + end | e -> e end) end @@ -3283,21 +3168,13 @@ and create_write_message_or_update mode t_level value l_env l_mem is_top_level l and __interp_letbind mode t_level l_env l_mem (LB_aux lbind (l,annot)) = match lbind with - | LB_val_explicit t pat exp -> + | LB_val pat exp -> match (interp_main mode t_level l_env l_mem exp) with | (Value v,lm,le) -> (match match_pattern t_level pat v with | (true,used_unknown,env) -> ((Value (V_lit (L_aux L_unit l)), lm, (union_env env l_env)),Nothing) | _ -> ((Error l "Pattern in letbind did not match value",lm,le),Nothing) end) - | (Action a s,lm,le) -> ((Action a s,lm,le),(Just (fun e ->(LB_aux (LB_val_explicit t pat e) (l,annot))))) - | e -> (e,Nothing) end - | LB_val_implicit pat exp -> - match (interp_main mode t_level l_env l_mem exp) with - | (Value v,lm,le) -> - (match match_pattern t_level pat v with - | (true,used_unknown,env) -> ((Value (V_lit (L_aux L_unit l)), lm, (union_env env l_env)),Nothing) - | _ -> ((Error l "Pattern in letbind did not match value",lm,le),Nothing) end) - | (Action a s,lm,le) -> ((Action a s,lm,le),(Just (fun e -> (LB_aux (LB_val_implicit pat e) (l,annot))))) + | (Action a s,lm,le) -> ((Action a s,lm,le),(Just (fun e -> (LB_aux (LB_val pat e) (l,annot))))) | e -> (e,Nothing) end end @@ -3312,15 +3189,14 @@ and __interp_alias_read mode t_level l_env l_mem (AL_aux alspec (l,annot)) = let stack = Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem Top in let get_reg_typ_name typ = match typ with - | T_id i -> i - | T_abbrev (T_id i) _ -> i + | Typ_aux (Typ_id (Id_aux (Id i) _)) _ -> i | _ -> Assert_extra.failwith "Alias reg typ not well formed" end in match alspec with | AL_subreg (RI_aux (RI_id reg) (li,((Just (t,_,_,_,_)) as annot'))) subreg -> let reg_ti = get_reg_typ_name t in (match in_env subregs reg_ti with - | Just indexes -> + | Just indexes -> (match in_env indexes (get_id subreg) with | Just ir -> (Action (Read_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing) stack, l_mem, l_env) @@ -3328,19 +3204,19 @@ and __interp_alias_read mode t_level l_env l_mem (AL_aux alspec (l,annot)) = | _ -> (Error l (String.stringAppend "Internal error: alias spec has unknown register type " reg_ti), l_mem, l_env) end) | AL_bit (RI_aux (RI_id reg) (_,annot')) e -> - resolve_outcome (interp_main mode t_level l_env l_mem e) - (fun v le lm -> match v with - | V_lit (L_aux (L_num i) _) -> + resolve_outcome (interp_main mode t_level l_env l_mem e) + (fun v le lm -> match v with + | V_lit (L_aux (L_num i) _) -> let i = natFromInteger i in (Action (Read_reg (Form_Reg reg annot' default_dir) (Just (i,i))) stack, l_mem, l_env) | _ -> Assert_extra.failwith "alias bit did not reduce to number" end) (fun a -> a) (*Should not currently happen as type system enforces constants*) - | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> + | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> resolve_outcome (interp_main mode t_level l_env l_mem start) - (fun v lm le -> - match v with + (fun v lm le -> + match v with | V_lit (L_aux (L_num start) _) -> - (resolve_outcome + (resolve_outcome (interp_main mode t_level l_env lm stop) (fun v le lm -> (match v with @@ -3350,14 +3226,14 @@ and __interp_alias_read mode t_level l_env l_mem (AL_aux alspec (l,annot)) = | _ -> Assert_extra.failwith ("Alias slice evaluted non-lit " ^ (string_of_value v)) end)) (fun a -> a)) - | _ -> Assert_extra.failwith ("Alias slice evaluated non-lit "^ string_of_value v) + | _ -> Assert_extra.failwith ("Alias slice evaluated non-lit "^ string_of_value v) end) (fun a -> a) (*Neither action function should occur, due to above*) - | AL_concat (RI_aux (RI_id reg1) (l1, annot1)) (RI_aux (RI_id reg2) annot2) -> + | AL_concat (RI_aux (RI_id reg1) (l1, annot1)) (RI_aux (RI_id reg2) annot2) -> (Action (Read_reg (Form_Reg reg1 annot1 default_dir) Nothing) (Hole_frame redex_id (E_aux (E_vector_append (E_aux (E_id redex_id) (l1, (intern_annot annot1))) - (E_aux (E_id reg2) annot2)) + (E_aux (E_id reg2) annot2)) (l,(intern_annot annot))) t_level l_env l_mem Top), l_mem,l_env) | _ -> Assert_extra.failwith "alias spec not well formed" end @@ -3368,10 +3244,10 @@ and interp_alias_read mode t_level l_env l_mem al = let _ = debug_fun_exit mode "interp_alias_read" retval in retval -let rec eval_toplevel_let handle_action tlevel env mem lbind = +let rec eval_toplevel_let handle_action tlevel env mem lbind = match interp_letbind <| eager_eval=true; track_values=false; track_lmem=false; debug=false; debug_indent="" |> tlevel env mem lbind with | ((Value v, lm, (LEnv _ le)),_) -> Just le - | ((Action a s,lm,le), Just le_builder) -> + | ((Action a s,lm,le), Just le_builder) -> (match handle_action (Action a s) with | Just value -> (match s with @@ -3389,30 +3265,30 @@ let rec to_global_letbinds handle_action (Defs defs) t_level = match def with | DEF_val lbind -> match eval_toplevel_let handle_action t_level eenv (emem "global_letbinds") lbind with - | Just le -> + | Just le -> to_global_letbinds handle_action - (Defs defs) + (Defs defs) (Env fdefs instrs default_dir (Map.(union) lets le) regs ctors subregs aliases debug) - | Nothing -> - to_global_letbinds handle_action (Defs defs) + | Nothing -> + to_global_letbinds handle_action (Defs defs) (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) end | DEF_type (TD_aux tdef _) -> match tdef with - | TD_enum id ns ids _ -> - let typ = T_id (get_id id) in - let enum_vals = - Map.fromList - (snd + | TD_enum id ns ids _ -> + let typ = mk_typ_id (get_id id) in + let enum_vals = + Map.fromList + (snd (List.foldl (fun (c,rst) eid -> (1+c,(get_id eid,V_ctor eid typ (C_Enum c) unitv)::rst)) (0,[]) ids)) in - to_global_letbinds - handle_action (Defs defs) + to_global_letbinds + handle_action (Defs defs) (Env fdefs instrs default_dir (Map.(union) lets enum_vals) regs ctors subregs aliases debug) | _ -> to_global_letbinds handle_action (Defs defs) t_level end | _ -> to_global_letbinds handle_action (Defs defs) t_level end end -let rec extract_default_direction (Defs defs) = match defs with +let rec extract_default_direction (Defs defs) = match defs with | [] -> IInc (*When lack of a declared default, go for inc*) | def::defs -> match def with @@ -3423,11 +3299,11 @@ let rec extract_default_direction (Defs defs) = match defs with (*TODO Contemplate making execute environment variable instead of constant*) let to_top_env debug external_functions defs = let direction = (extract_default_direction defs) in - let t_level = Env (to_fdefs defs) - (extract_instructions "execute" defs) + let t_level = Env (to_fdefs defs) + (extract_instructions "execute" defs) direction - Map.empty (* empty letbind and enum values, call below will fill in any *) - (to_registers direction defs) + Map.empty (* empty letbind and enum values, call below will fill in any *) + (to_registers direction defs) (to_data_constructors defs) (to_register_fields defs) (to_aliases defs) debug in let (o,t_level) = to_global_letbinds (external_functions direction) defs t_level in match o with @@ -3437,9 +3313,9 @@ let to_top_env debug external_functions defs = let __interp mode external_functions defs exp = match (to_top_env mode.debug external_functions defs) with - | (Nothing,t_level) -> + | (Nothing,t_level) -> interp_main mode t_level eenv (emem "top level") exp - | (Just o,_) -> (o,(emem "top level error"),eenv) + | (Just o,_) -> (o,(emem "top level error"),eenv) end let interp mode external_functions defs exp = @@ -3451,15 +3327,15 @@ let interp mode external_functions defs exp = let rec __resume_with_env mode stack value = match (stack,value) with | (Top,_) -> (Error Unknown "Top hit without expression to evaluate in resume_with_env",eenv) - | (Hole_frame id exp t_level env mem Top,Just value) -> - match interp_main mode t_level (add_to_env (id,value) env) mem exp with | (o,_,e) -> (o,e) end + | (Hole_frame id exp t_level env mem Top,Just value) -> + match interp_main mode t_level (add_to_env (id,value) env) mem exp with | (o,_,e) -> (o,e) end | (Hole_frame id exp t_level env mem stack,Just value) -> match resume_with_env mode stack (Just value) with - | (Value v,e) -> - match interp_main mode t_level (add_to_env (id,v) env) mem exp with | (o,_,e) -> (o,e) end + | (Value v,e) -> + match interp_main mode t_level (add_to_env (id,v) env) mem exp with | (o,_,e) -> (o,e) end | (Action action stack,e) -> (Action action (Hole_frame id exp t_level env mem stack),e) | (Error l s,e) -> (Error l s,e) - end + end | (Hole_frame id exp t_level env mem stack, Nothing) -> match resume_with_env mode stack Nothing with | (Value v,e) -> @@ -3471,8 +3347,8 @@ let rec __resume_with_env mode stack value = match interp_main mode t_level env mem exp with | (o,_,e) -> (o,e) end | (Thunk_frame exp t_level env mem stack,value) -> match resume_with_env mode stack value with - | (Value v,e) -> - match interp_main mode t_level env mem exp with | (o,_,e) -> (o,e) end + | (Value v,e) -> + match interp_main mode t_level env mem exp with | (o,_,e) -> (o,e) end | (Action action stack,e) -> (Action action (Thunk_frame exp t_level env mem stack),e) | (Error l s,e) -> (Error l s,e) end @@ -3488,32 +3364,32 @@ and resume_with_env mode stack value = let rec __resume mode stack value = match (stack,value) with | (Top,_) -> (Error Unknown "Top hit without expression to evaluate in resume",(emem "top level error"),eenv) - | (Hole_frame id exp t_level env mem Top,Just value) -> + | (Hole_frame id exp t_level env mem Top,Just value) -> interp_main mode t_level (add_to_env (id,value) env) mem exp | (Hole_frame id exp t_level env mem Top,Nothing) -> (Error Unknown "Top hole frame hit wihtout a value in resume", mem, env) | (Hole_frame id exp t_level env mem stack,Just value) -> match resume mode stack (Just value) with - | (Value v,_,_) -> - interp_main mode t_level (add_to_env (id,v) env) mem exp + | (Value v,_,_) -> + interp_main mode t_level (add_to_env (id,v) env) mem exp | (Action action stack,lm,le) -> (Action action (Hole_frame id exp t_level env mem stack),lm,le) | (Error l s,lm,le) -> (Error l s,lm,le) - end + end | (Hole_frame id exp t_level env mem stack, Nothing) -> match resume mode stack Nothing with | (Value v,_,_) -> - interp_main mode t_level (add_to_env (id,v) env) mem exp + interp_main mode t_level (add_to_env (id,v) env) mem exp | (Action action stack,lm,le) -> (Action action (Hole_frame id exp t_level env mem stack),lm,le) | (Error l s,lm,le) -> (Error l s,lm,le) end | (Thunk_frame exp t_level env mem Top,_) -> - interp_main mode t_level env mem exp + interp_main mode t_level env mem exp | (Thunk_frame exp t_level env mem stack,value) -> match resume mode stack value with | (Value v,_,_) -> interp_main mode t_level env mem exp | (Action action stack,lm,le) -> (Action action (Thunk_frame exp t_level env mem stack), lm, le) | (Error l s,lm,le) -> (Error l s,lm,le) - end + end end and resume mode stack value = diff --git a/src/lem_interp/interp_ast.lem b/src/lem_interp/interp_ast.lem deleted file mode 100644 index 733d1a36..00000000 --- a/src/lem_interp/interp_ast.lem +++ /dev/null @@ -1,747 +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. *) -(*========================================================================*) - -(* generated by Ott 0.25 from: l2.ott *) -open import Pervasives - -open import Pervasives -open import Pervasives_extra -open import Map -open import Maybe -open import Set_extra - -type l = - | Unknown - | Int of string * maybe l (*internal types, functions*) - | Range of string * nat * nat * nat * nat - | Generated of l (*location for a generated node, where l is the location of the closest original source*) - -type annot 'a = l * 'a - -val duplicates : forall 'a. list 'a -> list 'a - -val set_from_list : forall 'a. list 'a -> set 'a - -val subst : forall 'a. list 'a -> list 'a -> bool - - -type x = string (* identifier *) -type ix = string (* infix identifier *) - -type base_kind_aux = (* base kind *) - | BK_type (* kind of types *) - | BK_nat (* kind of natural number size expressions *) - | BK_order (* kind of vector order specifications *) - | BK_effect (* kind of effect sets *) - - -type kid_aux = (* kinded IDs: $Type$, $Nat$, $Order$, and $Effect$ variables *) - | Var of x - - -type id_aux = (* identifier *) - | Id of x - | DeIid of x (* remove infix status *) - - -type base_kind = - | BK_aux of base_kind_aux * l - - -type kid = - | Kid_aux of kid_aux * l - - -type id = - | Id_aux of id_aux * l - - -type kind_aux = (* kinds *) - | K_kind of list base_kind - - -type nexp_aux = (* numeric expression, of kind $Nat$ *) - | Nexp_id of id (* abbreviation identifier *) - | Nexp_var of kid (* variable *) - | Nexp_constant of integer (* constant *) - | Nexp_times of nexp * nexp (* product *) - | Nexp_sum of nexp * nexp (* sum *) - | Nexp_minus of nexp * nexp (* subtraction *) - | Nexp_exp of nexp (* exponential *) - | Nexp_neg of nexp (* for internal use only *) - -and nexp = - | Nexp_aux of nexp_aux * l - - -type kind = - | K_aux of kind_aux * l - - -type base_effect_aux = (* effect *) - | BE_rreg (* read register *) - | BE_wreg (* write register *) - | BE_rmem (* read memory *) - | BE_rmemt (* read memory and tag *) - | BE_wmem (* write memory *) - | BE_eamem (* signal effective address for writing memory *) - | BE_exmem (* determine if a store-exclusive (ARM) is going to succeed *) - | BE_wmv (* write memory, sending only value *) - | BE_wmvt (* write memory, sending only value and tag *) - | BE_barr (* memory barrier *) - | BE_depend (* dynamic footprint *) - | BE_undef (* undefined-instruction exception *) - | BE_unspec (* unspecified values *) - | BE_nondet (* nondeterminism, from $nondet$ *) - | BE_escape (* potential call of $exit$ *) - | BE_lset (* local mutation; not user-writable *) - | BE_lret (* local return; not user-writable *) - - -type base_effect = - | BE_aux of base_effect_aux * l - - -type order_aux = (* vector order specifications, of kind $Order$ *) - | Ord_var of kid (* variable *) - | Ord_inc (* increasing *) - | Ord_dec (* decreasing *) - - -type effect_aux = (* effect set, of kind $Effect$ *) - | Effect_var of kid - | Effect_set of list base_effect (* effect set *) - - -type order = - | Ord_aux of order_aux * l - - -type effect = - | Effect_aux of effect_aux * l - -let effect_union e1 e2 = - match (e1,e2) with - | ((Effect_aux (Effect_set els) _),(Effect_aux (Effect_set els2) l)) -> Effect_aux (Effect_set (els++els2)) l - end - - -type n_constraint_aux = (* constraint over kind $Nat$ *) - | NC_fixed of nexp * nexp - | NC_bounded_ge of nexp * nexp - | NC_bounded_le of nexp * nexp - | NC_nat_set_bounded of kid * list integer - - -type kinded_id_aux = (* optionally kind-annotated identifier *) - | KOpt_none of kid (* identifier *) - | KOpt_kind of kind * kid (* kind-annotated variable *) - - -type n_constraint = - | NC_aux of n_constraint_aux * l - - -type kinded_id = - | KOpt_aux of kinded_id_aux * l - - -type quant_item_aux = (* kinded identifier or $Nat$ constraint *) - | QI_id of kinded_id (* optionally kinded identifier *) - | QI_const of n_constraint (* $Nat$ constraint *) - - -type quant_item = - | QI_aux of quant_item_aux * l - - -type typquant_aux = (* type quantifiers and constraints *) - | TypQ_tq of list quant_item - | TypQ_no_forall (* empty *) - - -type typquant = - | TypQ_aux of typquant_aux * l - - -type typ_aux = (* type expressions, of kind $Type$ *) - | Typ_wild (* unspecified type *) - | Typ_id of id (* defined type *) - | Typ_var of kid (* type variable *) - | Typ_fn of typ * typ * effect (* Function (first-order only in user code) *) - | Typ_tup of list typ (* Tuple *) - | Typ_app of id * list typ_arg (* type constructor application *) - -and typ = - | Typ_aux of typ_aux * l - -and typ_arg_aux = (* type constructor arguments of all kinds *) - | Typ_arg_nexp of nexp - | Typ_arg_typ of typ - | Typ_arg_order of order - | Typ_arg_effect of effect - -and typ_arg = - | Typ_arg_aux of typ_arg_aux * l - - -type lit_aux = (* literal constant *) - | L_unit (* $() : unit$ *) - | L_zero (* $bitzero : bit$ *) - | L_one (* $bitone : bit$ *) - | L_true (* $true : bool$ *) - | L_false (* $false : bool$ *) - | L_num of integer (* natural number constant *) - | L_hex of string (* bit vector constant, C-style *) - | L_bin of string (* bit vector constant, C-style *) - | L_string of string (* string constant *) - | L_undef (* undefined-value constant *) - - -type index_range_aux = (* index specification, for bitfields in register types *) - | BF_single of integer (* single index *) - | BF_range of integer * integer (* index range *) - | BF_concat of index_range * index_range (* concatenation of index ranges *) - -and index_range = - | BF_aux of index_range_aux * l - - -type typschm_aux = (* type scheme *) - | TypSchm_ts of typquant * typ - - -type lit = - | L_aux of lit_aux * l - - -type typschm = - | TypSchm_aux of typschm_aux * l - - -type pat_aux 'a = (* pattern *) - | P_lit of lit (* literal constant pattern *) - | P_wild (* wildcard *) - | P_as of (pat 'a) * id (* named pattern *) - | P_typ of typ * (pat 'a) (* typed pattern *) - | P_id of id (* identifier *) - | P_app of id * list (pat 'a) (* union constructor pattern *) - | P_record of list (fpat 'a) * bool (* struct pattern *) - | P_vector of list (pat 'a) (* vector pattern *) - | P_vector_indexed of list (integer * (pat 'a)) (* vector pattern (with explicit indices) *) - | P_vector_concat of list (pat 'a) (* concatenated vector pattern *) - | P_tup of list (pat 'a) (* tuple pattern *) - | P_list of list (pat 'a) (* list pattern *) - -and pat 'a = - | P_aux of (pat_aux 'a) * annot 'a - -and fpat_aux 'a = (* field pattern *) - | FP_Fpat of id * (pat 'a) - -and fpat 'a = - | FP_aux of (fpat_aux 'a) * annot 'a - - -type name_scm_opt_aux = (* optional variable naming-scheme constraint *) - | Name_sect_none - | Name_sect_some of string - - -type type_union_aux = (* type union constructors *) - | Tu_id of id - | Tu_ty_id of typ * id - - -type name_scm_opt = - | Name_sect_aux of name_scm_opt_aux * l - - -type type_union = - | Tu_aux of type_union_aux * l - - -type kind_def_aux 'a = (* Definition body for elements of kind *) - | KD_nabbrev of kind * id * name_scm_opt * nexp (* $Nat$-expression abbreviation *) - | KD_abbrev of kind * id * name_scm_opt * typschm (* type abbreviation *) - | KD_record of kind * id * name_scm_opt * typquant * list (typ * id) * bool (* struct type definition *) - | KD_variant of kind * id * name_scm_opt * typquant * list type_union * bool (* union type definition *) - | KD_enum of kind * id * name_scm_opt * list id * bool (* enumeration type definition *) - | KD_register of kind * id * nexp * nexp * list (index_range * id) (* register mutable bitfield type definition *) - - -type type_def_aux 'a = (* type definition body *) - | TD_abbrev of id * name_scm_opt * typschm (* type abbreviation *) - | TD_record of id * name_scm_opt * typquant * list (typ * id) * bool (* struct type definition *) - | TD_variant of id * name_scm_opt * typquant * list type_union * bool (* tagged union type definition *) - | TD_enum of id * name_scm_opt * list id * bool (* enumeration type definition *) - | TD_register of id * nexp * nexp * list (index_range * id) (* register mutable bitfield type definition *) - - -type kind_def 'a = - | KD_aux of (kind_def_aux 'a) * annot 'a - - -type type_def 'a = - | TD_aux of (type_def_aux 'a) * annot 'a - - -let rec remove_one i l = - match l with - | [] -> [] - | i2::l2 -> if i2 = i then l2 else i2::(remove_one i l2) -end - -let rec remove_from l l2 = - match l2 with - | [] -> l - | i::l2' -> remove_from (remove_one i l) l2' -end - -let disjoint s1 s2 = Set.null (s1 inter s2) - -let rec disjoint_all sets = - match sets with - | [] -> true - | s1::[] -> true - | s1::s2::sets -> (disjoint s1 s2) && (disjoint_all (s2::sets)) -end - - -type ne = (* internal numeric expressions *) - | Ne_id of x - | Ne_var of x - | Ne_const of integer - | Ne_inf - | Ne_mult of ne * ne - | Ne_add of list ne - | Ne_minus of ne * ne - | Ne_exp of ne - | Ne_unary of ne - - -type t = (* Internal types *) - | T_id of x - | T_var of x - | T_fn of t * t * effect - | T_tup of list t - | T_app of x * t_args - | T_abbrev of t * t - -and t_arg = (* Argument to type constructors *) - | T_arg_typ of t - | T_arg_nexp of ne - | T_arg_effect of effect - | T_arg_order of order - -and t_args = (* Arguments to type constructors *) - | T_args of list t_arg - - -type k = (* Internal kinds *) - | Ki_typ - | Ki_nat - | Ki_ord - | Ki_efct - | Ki_ctor of list k * k - | Ki_infer (* Representing an unknown kind, inferred by context *) - - -type tid = (* A type identifier or type variable *) - | Tid_id of id - | Tid_var of kid - - -type kinf = (* Whether a kind is default or from a local binding *) - | Kinf_k of k - | Kinf_def of k - - -type nec = (* Numeric expression constraints *) - | Nec_lteq of ne * ne - | Nec_eq of ne * ne - | Nec_gteq of ne * ne - | Nec_in of x * list integer - | Nec_cond of list nec * list nec - | Nec_branch of list nec - - -type tag = (* Data indicating where the identifier arises and thus information necessary in compilation *) - | Tag_empty - | Tag_intro (* Denotes an assignment and lexp that introduces a binding *) - | Tag_set (* Denotes an expression that mutates a local variable *) - | Tag_tuple_assign (* Denotes an assignment with a tuple lexp *) - | Tag_global (* Globally let-bound or enumeration based value/variable *) - | Tag_ctor (* Data constructor from a type union *) - | Tag_extern of maybe string (* External function, specied only with a val statement *) - | Tag_default (* Type has come from default declaration, identifier may not be bound locally *) - | Tag_spec - | Tag_enum of integer - | Tag_alias - | Tag_unknown of maybe string (* Tag to distinguish an unknown path from a non-analysis non deterministic path *) - - -type tinf = (* Type variables, type, and constraints, bound to an identifier *) - | Tinf_typ of t - | Tinf_quant_typ of (map tid kinf) * list nec * tag * t - - -type conformsto = (* how much conformance does overloading need *) - | Conformsto_full - | Conformsto_parm - - -type widennum = - | Widennum_widen - | Widennum_dont - | Widennum_dontcare - - -type widenvec = - | Widenvec_widen - | Widenvec_dont - | Widenvec_dontcare - - -type widening = (* Should we widen vector start locations, should we widen atoms and ranges *) - | Widening_w of widennum * widenvec - - -type tinflist = (* In place so that a list of tinfs can be referred to without the dot form *) - | Tinfs_empty - | Tinfs_ls of list tinf - - type definition_env = - | DenvEmp - | Denv of (map tid kinf) * (map (list (id*t)) tinf) * (map t (list (nat*id))) - - -let blength (bit) = Ne_const 8 -let hlength (bit) = Ne_const 8 - - type env = - | EnvEmp - | Env of (map id tinf) * definition_env - - type inf = - | Iemp - | Inf of (list nec) * effect - - val denv_union : definition_env -> definition_env -> definition_env - let denv_union de1 de2 = - match (de1,de2) with - | (DenvEmp,de2) -> de2 - | (de1,DenvEmp) -> de1 - | ((Denv ke1 re1 ee1),(Denv ke2 re2 ee2)) -> - Denv (ke1 union ke2) (re1 union re2) (ee1 union ee2) - end - - val env_union : env -> env -> env - let env_union e1 e2 = - match (e1,e2) with - | (EnvEmp,e2) -> e2 - | (e1,EnvEmp) -> e1 - | ((Env te1 de1),(Env te2 de2)) -> - Env (te1 union te2) (denv_union de1 de2) - end - -let inf_union i1 i2 = - match (i1,i2) with - | (Iemp,i2) -> i2 - | (i1,Iemp) -> i1 - | (Inf n1 e1,Inf n2 e2) -> (Inf (n1++n2) (effect_union e1 e2)) - end - -let fresh_kid denv = Var "x" (*TODO When strings can be manipulated, this should actually build a fresh string*) - - - -type I = inf - - -type E = env - - -type tannot = maybe (t * tag * list nec * effect * effect) - - - -type i_direction = - | IInc - | IDec - - -type reg_id_aux 'a = - | RI_id of id - - -type reg_form = - | Form_Reg of id * tannot * i_direction - | Form_SubReg of id * reg_form * index_range - - -type ctor_kind = - | C_Enum of nat - | C_Union - - -type reg_id 'a = - | RI_aux of (reg_id_aux 'a) * annot 'a - - -type exp_aux 'a = (* expression *) - | E_block of list (exp 'a) (* sequential block *) - | E_nondet of list (exp 'a) (* nondeterministic block *) - | E_id of id (* identifier *) - | E_lit of lit (* literal constant *) - | E_cast of typ * (exp 'a) (* cast *) - | E_app of id * list (exp 'a) (* function application *) - | E_app_infix of (exp 'a) * id * (exp 'a) (* infix function application *) - | E_tuple of list (exp 'a) (* tuple *) - | E_if of (exp 'a) * (exp 'a) * (exp 'a) (* conditional *) - | E_for of id * (exp 'a) * (exp 'a) * (exp 'a) * order * (exp 'a) (* loop *) - | E_vector of list (exp 'a) (* vector (indexed from 0) *) - | E_vector_indexed of list (integer * (exp 'a)) * (opt_default 'a) (* vector (indexed consecutively) *) - | E_vector_access of (exp 'a) * (exp 'a) (* vector access *) - | E_vector_subrange of (exp 'a) * (exp 'a) * (exp 'a) (* subvector extraction *) - | E_vector_update of (exp 'a) * (exp 'a) * (exp 'a) (* vector functional update *) - | E_vector_update_subrange of (exp 'a) * (exp 'a) * (exp 'a) * (exp 'a) (* vector subrange update, with vector *) - | E_vector_append of (exp 'a) * (exp 'a) (* vector concatenation *) - | E_list of list (exp 'a) (* list *) - | E_cons of (exp 'a) * (exp 'a) (* cons *) - | E_record of (fexps 'a) (* struct *) - | E_record_update of (exp 'a) * (fexps 'a) (* functional update of struct *) - | E_field of (exp 'a) * id (* field projection from struct *) - | E_case of (exp 'a) * list (pexp 'a) (* pattern matching *) - | E_let of (letbind 'a) * (exp 'a) (* let expression *) - | E_assign of (lexp 'a) * (exp 'a) (* imperative assignment *) - | E_sizeof of nexp (* the value of nexp at run time *) - | E_return of (exp 'a) (* return (exp 'a) from current function *) - | E_exit of (exp 'a) (* halt all current execution *) - | E_assert of (exp 'a) * (exp 'a) (* halt with error (exp 'a) when not (exp 'a) *) - | E_internal_cast of annot 'a * (exp 'a) (* This is an internal cast, generated during type checking that will resolve into a syntactic cast after *) - | E_internal_exp of annot 'a (* This is an internal use for passing nexp information to library functions, postponed for constraint solving *) - | E_sizeof_internal of annot 'a (* For sizeof during type checking, to replace nexp with internal n *) - | E_internal_exp_user of annot 'a * annot 'a (* This is like the above but the user has specified an implicit parameter for the current function *) - | E_comment of string (* For generated unstructured comments *) - | E_comment_struc of (exp 'a) (* For generated structured comments *) - | E_internal_let of (lexp 'a) * (exp 'a) * (exp 'a) (* This is an internal node for compilation that demonstrates the scope of a local mutable variable *) - | E_internal_plet of (pat 'a) * (exp 'a) * (exp 'a) (* This is an internal node, used to distinguised some introduced lets during processing from original ones *) - | E_internal_return of (exp 'a) (* For internal use to embed into monad definition *) - | E_internal_value of value (* For internal use in interpreter to wrap pre-evaluated values when returning an action *) - -and exp 'a = - | E_aux of (exp_aux 'a) * annot 'a - -and value = (* interpreter evaluated value *) - | V_boxref of nat * t - | V_lit of lit - | V_tuple of list value - | V_list of list value - | V_vector of nat * i_direction * list value - | V_vector_sparse of nat * nat * i_direction * list (nat * value) * value - | V_record of t * list (id * value) - | V_ctor of id * t * ctor_kind * value - | V_unknown - | V_register of reg_form - | V_register_alias of alias_spec tannot * tannot - | V_track of value * set reg_form - -and lexp_aux 'a = (* lvalue expression *) - | LEXP_id of id (* identifier *) - | LEXP_memory of id * list (exp 'a) (* memory or register write via function call *) - | LEXP_cast of typ * id (* cast *) - | LEXP_tup of list (lexp 'a) (* multiple (non-memory) assignment *) - | LEXP_vector of (lexp 'a) * (exp 'a) (* vector element *) - | LEXP_vector_range of (lexp 'a) * (exp 'a) * (exp 'a) (* subvector *) - | LEXP_field of (lexp 'a) * id (* struct field *) - -and lexp 'a = - | LEXP_aux of (lexp_aux 'a) * annot 'a - -and fexp_aux 'a = (* field expression *) - | FE_Fexp of id * (exp 'a) - -and fexp 'a = - | FE_aux of (fexp_aux 'a) * annot 'a - -and fexps_aux 'a = (* field expression list *) - | FES_Fexps of list (fexp 'a) * bool - -and fexps 'a = - | FES_aux of (fexps_aux 'a) * annot 'a - -and opt_default_aux 'a = (* optional default value for indexed vector expressions *) - | Def_val_empty - | Def_val_dec of (exp 'a) - -and opt_default 'a = - | Def_val_aux of (opt_default_aux 'a) * annot 'a - -and pexp_aux 'a = (* pattern match *) - | Pat_exp of (pat 'a) * (exp 'a) - -and pexp 'a = - | Pat_aux of (pexp_aux 'a) * annot 'a - -and letbind_aux 'a = (* let binding *) - | LB_val_explicit of typschm * (pat 'a) * (exp 'a) (* let, explicit type ((pat 'a) must be total) *) - | LB_val_implicit of (pat 'a) * (exp 'a) (* let, implicit type ((pat 'a) must be total) *) - -and letbind 'a = - | LB_aux of (letbind_aux 'a) * annot 'a - -and alias_spec_aux 'a = (* register alias expression forms *) - | AL_subreg of (reg_id 'a) * id - | AL_bit of (reg_id 'a) * (exp 'a) - | AL_slice of (reg_id 'a) * (exp 'a) * (exp 'a) - | AL_concat of (reg_id 'a) * (reg_id 'a) - -and alias_spec 'a = - | AL_aux of (alias_spec_aux 'a) * annot 'a - - -type funcl_aux 'a = (* function clause *) - | FCL_Funcl of id * (pat 'a) * (exp 'a) - - -type rec_opt_aux = (* optional recursive annotation for functions *) - | Rec_nonrec (* non-recursive *) - | Rec_rec (* recursive *) - - -type tannot_opt_aux = (* optional type annotation for functions *) - | Typ_annot_opt_some of typquant * typ - - -type effect_opt_aux = (* optional effect annotation for functions *) - | Effect_opt_pure (* sugar for empty effect set *) - | Effect_opt_effect of effect - - -type funcl 'a = - | FCL_aux of (funcl_aux 'a) * annot 'a - - -type rec_opt = - | Rec_aux of rec_opt_aux * l - - -type tannot_opt = - | Typ_annot_opt_aux of tannot_opt_aux * l - - -type effect_opt = - | Effect_opt_aux of effect_opt_aux * l - - -type val_spec_aux 'a = (* value type specification *) - | VS_val_spec of typschm * id (* specify the type of an upcoming definition *) - | VS_extern_no_rename of typschm * id (* specify the type of an external function *) - | VS_extern_spec of typschm * id * string (* specify the type of a function from Lem *) - - -type fundef_aux 'a = (* function definition *) - | FD_function of rec_opt * tannot_opt * effect_opt * list (funcl 'a) - - -type scattered_def_aux 'a = (* scattered function and union type definitions *) - | SD_scattered_function of rec_opt * tannot_opt * effect_opt * id (* scattered function definition header *) - | SD_scattered_funcl of (funcl 'a) (* scattered function definition clause *) - | SD_scattered_variant of id * name_scm_opt * typquant (* scattered union definition header *) - | SD_scattered_unioncl of id * type_union (* scattered union definition member *) - | SD_scattered_end of id (* scattered definition end *) - - -type default_spec_aux 'a = (* default kinding or typing assumption *) - | DT_order of order - | DT_kind of base_kind * kid - | DT_typ of typschm * id - - -type dec_spec_aux 'a = (* register declarations *) - | DEC_reg of typ * id - | DEC_alias of id * (alias_spec 'a) - | DEC_typ_alias of typ * id * (alias_spec 'a) - - -type val_spec 'a = - | VS_aux of (val_spec_aux 'a) * annot 'a - - -type fundef 'a = - | FD_aux of (fundef_aux 'a) * annot 'a - - -type scattered_def 'a = - | SD_aux of (scattered_def_aux 'a) * annot 'a - - -type default_spec 'a = - | DT_aux of (default_spec_aux 'a) * l - - -type dec_spec 'a = - | DEC_aux of (dec_spec_aux 'a) * annot 'a - - -type dec_comm 'a = (* top-level generated comments *) - | DC_comm of string (* generated unstructured comment *) - | DC_comm_struct of (def 'a) (* generated structured comment *) - -and def 'a = (* top-level definition *) - | DEF_kind of (kind_def 'a) (* definition of named kind identifiers *) - | DEF_type of (type_def 'a) (* type definition *) - | DEF_fundef of (fundef 'a) (* function definition *) - | DEF_val of (letbind 'a) (* value definition *) - | DEF_spec of (val_spec 'a) (* top-level type constraint *) - | DEF_default of (default_spec 'a) (* default kind and type assumptions *) - | DEF_scattered of (scattered_def 'a) (* scattered function and type definition *) - | DEF_reg_dec of (dec_spec 'a) (* register declaration *) - | DEF_comm of (dec_comm 'a) (* generated comments *) - - -type defs 'a = (* definition sequence *) - | Defs of list (def 'a) - - - diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 8199f271..c982a30a 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -48,6 +48,7 @@ import Set_extra open import Pervasives open import Assert_extra open import Interp_ast +open import Interp_utilities open import Sail_impl_base open import Interp_interface @@ -439,7 +440,8 @@ let rec interp_to_value_helper debug arg ivh_mode err_str instr direction regist (Ivh_error (Interp_interface.Internal_error ("Write memory value request in a " ^ errk_str)), events_out) | (Interp.Action (Interp.Write_memv_tagged _ _ _ _) _,_,_) -> (Ivh_error (Interp_interface.Internal_error ("Write memory value tagged request in a " ^ errk_str)), events_out) - | _ -> (Ivh_error (Interp_interface.Internal_error ("Non expected action in a " ^ errk_str)), events_out) + | (outcome, _, _) -> + (Ivh_error (Interp_interface.Internal_error ("Non expected action in a " ^ errk_str ^ " " ^ Interp.string_of_outcome outcome)), events_out) end let call_external_functions direction outcome = @@ -501,7 +503,7 @@ let value_of_instruction_param direction (name,typ,v) = end in v let intern_instruction direction (name,parms) = - Interp_ast.V_ctor (Interp.id_of_string name) (T_id "ast") Interp_ast.C_Union + Interp_ast.V_ctor (Interp.id_of_string name) (mk_typ_id "ast") Interp_ast.C_Union (Interp_ast.V_tuple (List.map (value_of_instruction_param direction) parms)) let instruction_analysis top_level end_flag thunk_name regn_to_reg_details registers (instruction : Interp_ast.value) = @@ -765,7 +767,7 @@ let instr_external_to_interp_value top_level instr = end in (*This type shouldn't be hard-coded*) Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id name) Interp_ast.Unknown) - (T_id "ast") Interp_ast.C_Union parmsV + (mk_typ_id "ast") Interp_ast.C_Union parmsV val instruction_to_istate : context -> Interp_ast.value -> instruction_state let instruction_to_istate (top_level:context) (instr:Interp_ast.value) : instruction_state = diff --git a/src/lem_interp/interp_utilities.lem b/src/lem_interp/interp_utilities.lem index 4e8c1111..1878066f 100644 --- a/src/lem_interp/interp_utilities.lem +++ b/src/lem_interp/interp_utilities.lem @@ -52,15 +52,20 @@ let rec power (a: integer) (b: integer) : integer = let foldr2 f x l l' = List.foldr (Tuple.uncurry f) x (List.zip l l') let map2 f l l' = List.map (Tuple.uncurry f) (List.zip l l') -(*As in the type system, the first effect is local to the expression and the second is cummulative*) -type tannot = maybe (t * tag * list nec * effect * effect) - let get_exp_l (E_aux e (l,annot)) = l val pure : effect let pure = Effect_aux(Effect_set []) Unknown let unit_t = Typ_aux(Typ_app (Id_aux (Id "unit") Unknown) []) Unknown +let mk_typ_app str args = Typ_aux (Typ_app (Id_aux (Id str) Unknown) (List.map (fun aux -> Typ_arg_aux aux Unknown) args)) Unknown +let mk_typ_id str = Typ_aux (Typ_id (Id_aux (Id str) Unknown)) Unknown + +let mk_typ_var str = Typ_aux (Typ_var (Kid_aux (Var ("'" ^ str)) Unknown)) Unknown +let mk_typ_tup typs = Typ_aux (Typ_tup typs) Unknown + +let nconstant n = Nexp_aux (Nexp_constant n) Unknown + (* Workaround Lem's inability to scrap my (type classes) boilerplate. * Implementing only Eq, and only for literals - hopefully this will * be enough, but we should in principle implement ordering for everything in diff --git a/src/lem_interp/pretty_interp.ml b/src/lem_interp/pretty_interp.ml index 9f1ea3e3..950e1ac5 100644 --- a/src/lem_interp/pretty_interp.ml +++ b/src/lem_interp/pretty_interp.ml @@ -150,8 +150,7 @@ let doc_bkind (BK_aux(k,_)) = string (match k with | BK_type -> "Type" | BK_nat -> "Nat" - | BK_order -> "Order" - | BK_effect -> "Effect") + | BK_order -> "Order") let doc_op symb a b = infix 2 1 symb a b let doc_unop symb a = prefix 2 1 symb a @@ -233,7 +232,6 @@ let doc_typ, doc_atomic_typ, doc_nexp = and atomic_typ ((Typ_aux (t, _)) as ty) = match t with | Typ_id id -> doc_id id | Typ_var v -> doc_var v - | Typ_wild -> underscore | Typ_app _ | Typ_tup _ | Typ_fn _ -> (* exhaustiveness matters here to avoid infinite loops * if we add a new Typ constructor *) @@ -245,7 +243,6 @@ let doc_typ, doc_atomic_typ, doc_nexp = | Typ_arg_typ t -> app_typ t | Typ_arg_nexp n -> nexp n | Typ_arg_order o -> doc_ord o - | Typ_arg_effect e -> doc_effects e (* same trick to handle precedence of nexp *) and nexp ne = sum_typ ne @@ -277,10 +274,10 @@ let doc_typ, doc_atomic_typ, doc_nexp = in typ, atomic_typ, nexp let doc_nexp_constraint (NC_aux(nc,_)) = match nc with - | NC_fixed(n1,n2) -> doc_op equals (doc_nexp n1) (doc_nexp n2) + | NC_equal(n1,n2) -> doc_op equals (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) -> + | NC_set(v,bounds) -> doc_op (string "IN") (doc_var v) (braces (separate_map comma_sp doc_int bounds)) @@ -337,7 +334,6 @@ let doc_pat, doc_atomic_pat = | P_app(id,[]) -> doc_id id | P_record(fpats,_) -> braces (separate_map semi_sp fpat fpats) | P_vector pats -> brackets (separate_map comma_sp atomic_pat pats) - | 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_app(_, _ :: _) | P_vector_concat _ -> @@ -493,13 +489,6 @@ let doc_exp, doc_let = | _ -> failwith "bit vector not just bit values") | _ -> failwith "bit vector not all lits") exps "")) else default_print ()) - | E_vector_indexed (iexps, (Def_val_aux(default,_))) -> - let default_string = - (match default with - | Def_val_empty -> string "" - | Def_val_dec e -> concat [semi; space; string "default"; equals; (exp env mem add_red show_hole_contents e)]) in - let iexp (i,e) = doc_op equals (doc_int i) (exp env mem add_red show_hole_contents e) in - brackets (concat [(separate_map comma iexp iexps);default_string]) | E_vector_update(v,e1,e2) -> brackets (doc_op (string "with") (exp env mem add_red show_hole_contents v) @@ -556,11 +545,7 @@ let doc_exp, doc_let = | _-> failwith "internal expression escaped" and let_exp env mem add_red show_hole_contents (LB_aux(lb,_)) = match lb with - | LB_val_explicit(ts,pat,e) -> - prefix 2 1 - (separate space [string "let"; doc_typscm_atomic ts; doc_atomic_pat pat; equals]) - (exp env mem add_red show_hole_contents e) - | LB_val_implicit(pat,e) -> + | LB_val(pat,e) -> prefix 2 1 (separate space [string "let"; doc_atomic_pat pat; equals]) (exp env mem add_red show_hole_contents e) @@ -603,13 +588,8 @@ let doc_default (DT_aux(df,_)) = match df with | DT_order o -> separate space [string "default"; string "Order"; doc_ord o] let doc_spec (VS_aux(v,_)) = match v with - | VS_val_spec(ts,id) -> + | VS_val_spec(ts,id, _, _) -> separate space [string "val"; doc_typscm ts; doc_id id] - | VS_extern_no_rename(ts,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))] let doc_namescm (Name_sect_aux(ns,_)) = match ns with | Name_sect_none -> empty diff --git a/src/lem_interp/run_interp_model.ml b/src/lem_interp/run_interp_model.ml index 6978aeb9..81f0a5fd 100644 --- a/src/lem_interp/run_interp_model.ml +++ b/src/lem_interp/run_interp_model.ml @@ -433,7 +433,7 @@ let run (List.combine nondets (List.map (fun _ -> Random.bits ()) nondets)) in show "nondeterministic evaluation begun" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in show "nondeterministic evaluation ended" "" "" ""; (step next,env',next) @@ -445,7 +445,7 @@ let run else begin show "undefined triggered a non_det" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in (step i_state,env',i_state) end | Escape0(Some e,_) -> @@ -462,11 +462,11 @@ let run | Write_memv1 _ -> assert false) (*| _ -> assert false*) in - loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies false) next) in + loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies true) next) in let mode = match mode with | None -> if eager_eval then Run else Step | Some m -> m in - let imode = make_mode eager_eval !track_dependencies false in + let imode = make_mode eager_eval !track_dependencies true in let (IState(instr_state,context)) = istate in let (top_exp,(top_env,top_mem)) = top_frame_exp_state instr_state in interactf "%s: %s %s\n" (grey name) (blue "evaluate") diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index c0ec8548..59e86ece 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -106,6 +106,8 @@ type register_value = <| type byte_lifted = Byte_lifted of list bit_lifted (* of length 8 *) (*MSB first everywhere*) +type instruction_field_value = list bit + type byte = Byte of list bit (* of length 8 *) (*MSB first everywhere*) type address_lifted = Address_lifted of list byte_lifted (* of length 8 for 64bit machines*) * maybe integer @@ -131,22 +133,66 @@ type address = Address of list byte (* of length 8 *) * integer type opcode = Opcode of list byte (* of length 4 *) (** typeclass instantiations *) - -instance (EnumerationType bit) - let toNat = function - | Bitc_zero -> 0 - | Bitc_one -> 1 +let ~{ocaml} bitCompare (b1:bit) (b2:bit) = + match (b1,b2) with + | (Bitc_zero, Bitc_zero) -> EQ + | (Bitc_one, Bitc_one) -> EQ + | (Bitc_zero, _) -> LT + | (_,_) -> GT end +let inline {ocaml} bitCompare = defaultCompare + +let ~{ocaml} bitLess b1 b2 = bitCompare b1 b2 = LT +let ~{ocaml} bitLessEq b1 b2 = bitCompare b1 b2 <> GT +let ~{ocaml} bitGreater b1 b2 = bitCompare b1 b2 = GT +let ~{ocaml} bitGreaterEq b1 b2 = bitCompare b1 b2 <> LT + +let inline {ocaml} bitLess = defaultLess +let inline {ocaml} bitLessEq = defaultLessEq +let inline {ocaml} bitGreater = defaultGreater +let inline {ocaml} bitGreaterEq = defaultGreaterEq + +instance (Ord bit) + let compare = bitCompare + let (<) = bitLess + let (<=) = bitLessEq + let (>) = bitGreater + let (>=) = bitGreaterEq end -instance (EnumerationType bit_lifted) - let toNat = function - | Bitl_zero -> 0 - | Bitl_one -> 1 - | Bitl_undef -> 2 - | Bitl_unknown -> 3 +let ~{ocaml} bit_liftedCompare (bl1:bit_lifted) (bl2:bit_lifted) = + match (bl1,bl2) with + | (Bitl_zero, Bitl_zero) -> EQ + | (Bitl_zero,_) -> LT + | (Bitl_one, Bitl_zero) -> GT + | (Bitl_one, Bitl_one) -> EQ + | (Bitl_one, _) -> LT + | (Bitl_undef,Bitl_zero) -> GT + | (Bitl_undef,Bitl_one) -> GT + | (Bitl_undef,Bitl_undef) -> EQ + | (Bitl_undef,_) -> LT + | (Bitl_unknown,Bitl_unknown) -> EQ + | (Bitl_unknown,_) -> GT end +let inline {ocaml} bit_liftedCompare = defaultCompare + +let ~{ocaml} bit_liftedLess b1 b2 = bit_liftedCompare b1 b2 = LT +let ~{ocaml} bit_liftedLessEq b1 b2 = bit_liftedCompare b1 b2 <> GT +let ~{ocaml} bit_liftedGreater b1 b2 = bit_liftedCompare b1 b2 = GT +let ~{ocaml} bit_liftedGreaterEq b1 b2 = bit_liftedCompare b1 b2 <> LT + +let inline {ocaml} bit_liftedLess = defaultLess +let inline {ocaml} bit_liftedLessEq = defaultLessEq +let inline {ocaml} bit_liftedGreater = defaultGreater +let inline {ocaml} bit_liftedGreaterEq = defaultGreaterEq + +instance (Ord bit_lifted) + let compare = bit_liftedCompare + let (<) = bit_liftedLess + let (<=) = bit_liftedLessEq + let (>) = bit_liftedGreater + let (>=) = bit_liftedGreaterEq end let ~{ocaml} byte_liftedCompare (Byte_lifted b1) (Byte_lifted b2) = compare b1 b2 @@ -191,10 +237,6 @@ instance (Ord byte) let (>=) = byteGreaterEq end - - - - let ~{ocaml} opcodeCompare (Opcode o1) (Opcode o2) = compare o1 o2 let {ocaml} opcodeCompare = defaultCompare @@ -216,10 +258,6 @@ instance (Ord opcode) let (>) = opcodeGreater let (>=) = opcodeGreaterEq end - - - - let addressCompare (Address b1 i1) (Address b2 i2) = compare i1 i2 (* this cannot be defaultCompare for OCaml because addresses contain big ints *) @@ -562,55 +600,137 @@ type instruction_kind = instance (Show instruction_kind) let show = function | IK_barrier barrier_kind -> "IK_barrier " ^ (show barrier_kind) - | IK_mem_read read_kind -> "IK_mem_read " ^ (show read_kind) + | IK_mem_read read_kind -> "IK_mem_read " ^ (show read_kind) | IK_mem_write write_kind -> "IK_mem_write " ^ (show write_kind) - | IK_mem_rmw (r, w) -> "IK_mem_rmw " ^ (show r) ^ " " ^ (show w) - | IK_cond_branch -> "IK_cond_branch" - | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) - | IK_simple -> "IK_simple" + | IK_cond_branch -> "IK_cond_branch" + | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) + | IK_simple -> "IK_simple" end end -instance (EnumerationType read_kind) - let toNat = function - | Read_plain -> 0 - | Read_reserve -> 1 - | Read_acquire -> 2 - | Read_exclusive -> 3 - | Read_exclusive_acquire -> 4 - | Read_stream -> 5 - | Read_RISCV_acquire -> 6 - | Read_RISCV_strong_acquire -> 7 - | Read_RISCV_reserved -> 8 - | Read_RISCV_reserved_acquire -> 9 - | Read_RISCV_reserved_strong_acquire -> 10 - | Read_X86_locked -> 11 - end +let ~{ocaml} read_kindCompare rk1 rk2 = + match (rk1, rk2) with + | (Read_plain, Read_plain) -> EQ + | (Read_plain, Read_reserve) -> LT + | (Read_plain, Read_acquire) -> LT + | (Read_plain, Read_exclusive) -> LT + | (Read_plain, Read_exclusive_acquire) -> LT + | (Read_plain, Read_stream) -> LT + + | (Read_reserve, Read_plain) -> GT + | (Read_reserve, Read_reserve) -> EQ + | (Read_reserve, Read_acquire) -> LT + | (Read_reserve, Read_exclusive) -> LT + | (Read_reserve, Read_exclusive_acquire) -> LT + | (Read_reserve, Read_stream) -> LT + + | (Read_acquire, Read_plain) -> GT + | (Read_acquire, Read_reserve) -> GT + | (Read_acquire, Read_acquire) -> EQ + | (Read_acquire, Read_exclusive) -> LT + | (Read_acquire, Read_exclusive_acquire) -> LT + | (Read_acquire, Read_stream) -> LT + + | (Read_exclusive, Read_plain) -> GT + | (Read_exclusive, Read_reserve) -> GT + | (Read_exclusive, Read_acquire) -> GT + | (Read_exclusive, Read_exclusive) -> EQ + | (Read_exclusive, Read_exclusive_acquire) -> LT + | (Read_exclusive, Read_stream) -> LT + + | (Read_exclusive_acquire, Read_plain) -> GT + | (Read_exclusive_acquire, Read_reserve) -> GT + | (Read_exclusive_acquire, Read_acquire) -> GT + | (Read_exclusive_acquire, Read_exclusive) -> GT + | (Read_exclusive_acquire, Read_exclusive_acquire) -> EQ + | (Read_exclusive_acquire, Read_stream) -> GT + + | (Read_stream, Read_plain) -> GT + | (Read_stream, Read_reserve) -> GT + | (Read_stream, Read_acquire) -> GT + | (Read_stream, Read_exclusive) -> GT + | (Read_stream, Read_exclusive_acquire) -> GT + | (Read_stream, Read_stream) -> EQ +end +let inline {ocaml} read_kindCompare = defaultCompare + +let ~{ocaml} read_kindLess b1 b2 = read_kindCompare b1 b2 = LT +let ~{ocaml} read_kindLessEq b1 b2 = read_kindCompare b1 b2 <> GT +let ~{ocaml} read_kindGreater b1 b2 = read_kindCompare b1 b2 = GT +let ~{ocaml} read_kindGreaterEq b1 b2 = read_kindCompare b1 b2 <> LT + +let inline {ocaml} read_kindLess = defaultLess +let inline {ocaml} read_kindLessEq = defaultLessEq +let inline {ocaml} read_kindGreater = defaultGreater +let inline {ocaml} read_kindGreaterEq = defaultGreaterEq + +instance (Ord read_kind) + let compare = read_kindCompare + let (<) = read_kindLess + let (<=) = read_kindLessEq + let (>) = read_kindGreater + let (>=) = read_kindGreaterEq end -instance (EnumerationType write_kind) - let toNat = function - | Write_plain -> 0 - | Write_conditional -> 1 - | Write_release -> 2 - | Write_exclusive -> 3 - | Write_exclusive_release -> 4 - | Write_RISCV_release -> 5 - | Write_RISCV_strong_release -> 6 - | Write_RISCV_conditional -> 7 - | Write_RISCV_conditional_release -> 8 - | Write_RISCV_conditional_strong_release -> 9 - | Write_X86_locked -> 10 - end +let ~{ocaml} write_kindCompare wk1 wk2 = + match (wk1, wk2) with + | (Write_plain, Write_plain) -> EQ + | (Write_plain, Write_conditional) -> LT + | (Write_plain, Write_release) -> LT + | (Write_plain, Write_exclusive) -> LT + | (Write_plain, Write_exclusive_release) -> LT + + | (Write_conditional, Write_plain) -> GT + | (Write_conditional, Write_conditional) -> EQ + | (Write_conditional, Write_release) -> LT + | (Write_conditional, Write_exclusive) -> LT + | (Write_conditional, Write_exclusive_release) -> LT + + | (Write_release, Write_plain) -> GT + | (Write_release, Write_conditional) -> GT + | (Write_release, Write_release) -> EQ + | (Write_release, Write_exclusive) -> LT + | (Write_release, Write_exclusive_release) -> LT + + | (Write_exclusive, Write_plain) -> GT + | (Write_exclusive, Write_conditional) -> GT + | (Write_exclusive, Write_release) -> GT + | (Write_exclusive, Write_exclusive) -> EQ + | (Write_exclusive, Write_exclusive_release) -> LT + + | (Write_exclusive_release, Write_plain) -> GT + | (Write_exclusive_release, Write_conditional) -> GT + | (Write_exclusive_release, Write_release) -> GT + | (Write_exclusive_release, Write_exclusive) -> GT + | (Write_exclusive_release, Write_exclusive_release) -> EQ +end +let inline {ocaml} write_kindCompare = defaultCompare + +let ~{ocaml} write_kindLess b1 b2 = write_kindCompare b1 b2 = LT +let ~{ocaml} write_kindLessEq b1 b2 = write_kindCompare b1 b2 <> GT +let ~{ocaml} write_kindGreater b1 b2 = write_kindCompare b1 b2 = GT +let ~{ocaml} write_kindGreaterEq b1 b2 = write_kindCompare b1 b2 <> LT + +let inline {ocaml} write_kindLess = defaultLess +let inline {ocaml} write_kindLessEq = defaultLessEq +let inline {ocaml} write_kindGreater = defaultGreater +let inline {ocaml} write_kindGreaterEq = defaultGreaterEq + +instance (Ord write_kind) + let compare = write_kindCompare + let (<) = write_kindLess + let (<=) = write_kindLessEq + let (>) = write_kindGreater + let (>=) = write_kindGreaterEq end -instance (EnumerationType barrier_kind) - let toNat = function - | Barrier_Sync -> 0 +(* Barrier comparison that uses less memory in Isabelle/HOL +let ~{ocaml} barrier_number = function + | Barrier_Sync -> (0 : natural) | Barrier_LwSync -> 1 - | Barrier_Eieio ->2 + | Barrier_Eieio -> 2 | Barrier_Isync -> 3 | Barrier_DMB -> 4 | Barrier_DMB_ST -> 5 @@ -629,6 +749,88 @@ instance (EnumerationType barrier_kind) | Barrier_RISCV_i -> 18 | Barrier_x86_MFENCE -> 19 end + + let ~{ocaml} barrier_kindCompare bk1 bk2 = + let n1 = barrier_number bk1 in + let n2 = barrier_number bk2 in + if n1 < n2 then LT + else if n1 = n2 then EQ + else GT +*) + +let ~{ocaml} barrier_kindCompare bk1 bk2 = + match (bk1, bk2) with + | (Barrier_Sync, Barrier_Sync) -> EQ + | (Barrier_Sync, _) -> LT + | (_, Barrier_Sync) -> GT + + | (Barrier_LwSync, Barrier_LwSync) -> EQ + | (Barrier_LwSync, _) -> LT + | (_, Barrier_LwSync) -> GT + + | (Barrier_Eieio, Barrier_Eieio) -> EQ + | (Barrier_Eieio, _) -> LT + | (_, Barrier_Eieio) -> GT + + | (Barrier_Isync, Barrier_Isync) -> EQ + | (Barrier_Isync, _) -> LT + | (_, Barrier_Isync) -> GT + + | (Barrier_DMB, Barrier_DMB) -> EQ + | (Barrier_DMB, _) -> LT + | (_, Barrier_DMB) -> GT + + | (Barrier_DMB_ST, Barrier_DMB_ST) -> EQ + | (Barrier_DMB_ST, _) -> LT + | (_, Barrier_DMB_ST) -> GT + + | (Barrier_DMB_LD, Barrier_DMB_LD) -> EQ + | (Barrier_DMB_LD, _) -> LT + | (_, Barrier_DMB_LD) -> GT + + | (Barrier_DSB, Barrier_DSB) -> EQ + | (Barrier_DSB, _) -> LT + | (_, Barrier_DSB) -> GT + + | (Barrier_DSB_ST, Barrier_DSB_ST) -> EQ + | (Barrier_DSB_ST, _) -> LT + | (_, Barrier_DSB_ST) -> GT + + | (Barrier_DSB_LD, Barrier_DSB_LD) -> EQ + | (Barrier_DSB_LD, _) -> LT + | (_, Barrier_DSB_LD) -> GT + + | (Barrier_ISB, Barrier_ISB) -> EQ + | (Barrier_ISB, _) -> LT + | (_, Barrier_ISB) -> GT + + | (Barrier_TM_COMMIT, Barrier_TM_COMMIT) -> EQ + | (Barrier_TM_COMMIT, _) -> LT + | (_, Barrier_TM_COMMIT) -> GT + + | (Barrier_MIPS_SYNC, Barrier_MIPS_SYNC) -> EQ + (* | (Barrier_MIPS_SYNC, _) -> LT + | (_, Barrier_MIPS_SYNC) -> GT *) + + end +let inline {ocaml} barrier_kindCompare = defaultCompare + +let ~{ocaml} barrier_kindLess b1 b2 = barrier_kindCompare b1 b2 = LT +let ~{ocaml} barrier_kindLessEq b1 b2 = barrier_kindCompare b1 b2 <> GT +let ~{ocaml} barrier_kindGreater b1 b2 = barrier_kindCompare b1 b2 = GT +let ~{ocaml} barrier_kindGreaterEq b1 b2 = barrier_kindCompare b1 b2 <> LT + +let inline {ocaml} barrier_kindLess = defaultLess +let inline {ocaml} barrier_kindLessEq = defaultLessEq +let inline {ocaml} barrier_kindGreater = defaultGreater +let inline {ocaml} barrier_kindGreaterEq = defaultGreaterEq + +instance (Ord barrier_kind) + let compare = barrier_kindCompare + let (<) = barrier_kindLess + let (<=) = barrier_kindLessEq + let (>) = barrier_kindGreater + let (>=) = barrier_kindGreaterEq end type event = @@ -696,32 +898,35 @@ end (* the address_lifted types should go away here and be replaced by address *) type with_aux 'o = 'o * maybe ((unit -> (string * string)) * ((list (reg_name * register_value)) -> list event)) -type outcome 'a = +type outcome_r 'a 'r = (* Request to read memory, value is location to read, integer is size to read, followed by registers that were used in computing that size *) - | Read_mem of (read_kind * address_lifted * nat) * (memory_value -> with_aux (outcome 'a)) + | Read_mem of (read_kind * address_lifted * nat) * (memory_value -> with_aux (outcome_r 'a 'r)) (* Tell the system a write is imminent, at address lifted, of size nat *) - | Write_ea of (write_kind * address_lifted * nat) * (with_aux (outcome 'a)) + | Write_ea of (write_kind * address_lifted * nat) * (with_aux (outcome_r 'a 'r)) (* Request the result of store-exclusive *) - | Excl_res of (bool -> with_aux (outcome 'a)) + | Excl_res of (bool -> with_aux (outcome_r 'a 'r)) (* Request to write memory at last signalled address. Memory value should be 8 times the size given in ea signal *) - | Write_memv of memory_value * (bool -> with_aux (outcome 'a)) + | Write_memv of memory_value * (bool -> with_aux (outcome_r 'a 'r)) (* Request a memory barrier *) - | Barrier of barrier_kind * with_aux (outcome 'a) + | Barrier of barrier_kind * with_aux (outcome_r 'a 'r) (* Tell the system to dynamically recalculate dependency footprint *) - | Footprint of with_aux (outcome 'a) + | Footprint of with_aux (outcome_r 'a 'r) (* Request to read register, will track dependency when mode.track_values *) - | Read_reg of reg_name * (register_value -> with_aux (outcome 'a)) + | Read_reg of reg_name * (register_value -> with_aux (outcome_r 'a 'r)) (* Request to write register *) - | Write_reg of (reg_name * register_value) * with_aux (outcome 'a) + | Write_reg of (reg_name * register_value) * with_aux (outcome_r 'a 'r) | Escape of maybe string (*Result of a failed assert with possible error message to report*) | Fail of maybe string - | Internal of (maybe string * maybe (unit -> string)) * with_aux (outcome 'a) + (* Early return with value of type 'r *) + | Return of 'r + | Internal of (maybe string * maybe (unit -> string)) * with_aux (outcome_r 'a 'r) | Done of 'a | Error of string +type outcome 'a = outcome_r 'a unit type outcome_s 'a = with_aux (outcome 'a) (* first string : output of instruction_stack_to_string second string: output of local_variables_to_string *) diff --git a/src/lem_interp/type_check.lem b/src/lem_interp/type_check.lem deleted file mode 100644 index 6c6cda1a..00000000 --- a/src/lem_interp/type_check.lem +++ /dev/null @@ -1,862 +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 import Pervasives -import Map -import Map_extra (* For 'find' instead of using lookup and maybe types, as we know it cannot fail *) -import Set_extra (* For 'to_list' because map only goes to set *) -import List_extra (* For 'nth' and 'head' where we know that they cannot fail *) -open import Show_extra (* for 'show' to convert nat to string) *) -open import String_extra (* for chr *) -import Assert_extra (*For failwith when partiality is known to be unreachable*) - -open import Sail_impl_base -open import Interp_ast -open import Interp_utilities -open import Instruction_extractor - -type tannot = Interp_ast.tannot - -(*Env of t counter, nexp counter, order counter, type env, order env, nexp env, nec env*) -type envs = | Env of nat * nat * nat * map string (t * nec) * map string order * map string ne * map string nec - -let union_envs (orig_envs : envs) (branch_envs : list envs) : envs = orig_envs - -let t_fresh envs = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - (T_var ("fresh_" ^ show t_count),(Env (t_count + 1) ne_count o_count t_env o_env ne_env nec_env)) -let nexp_fresh envs = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - (Ne_var ("fresh_" ^ show ne_count),(Env t_count (ne_count + 1) o_count t_env o_env ne_env nec_env)) -let ord_fresh envs = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - (Ord_aux (Ord_var (Kid_aux (Var ("fresh" ^ show o_count)) Unknown)) Unknown, - (Env t_count ne_count (o_count + 1) t_env o_env ne_env nec_env)) - -let get_nexp envs n = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Map.lookup n ne_env -let update_nexp envs n ne = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Env t_count ne_count o_count t_env o_env (Map.insert n ne ne_env) nec_env - -let get_typ envs t = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Map.lookup t t_env -let update_t envs t ty nec = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Env t_count ne_count o_count (Map.insert t (ty, nec) t_env) o_env ne_env nec_env - -let get_ord (envs : envs) (o :string) = - let (Env t_count ne_count o_count t_env (o_env : map string order) ne_env nec_env) = envs in - Map.lookup o o_env -let update_ord envs o ord = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Env t_count ne_count o_count t_env (Map.insert o ord o_env) ne_env nec_env - -let get_nec envs n = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Map.lookup nec_env n -let update_nec envs n nc = - let (Env t_count ne_count o_count t_env o_env ne_env nec_env) = envs in - Env t_count ne_count o_count t_env o_env ne_env (Map.insert n nc nec_env) - -let rec typ_to_t envs (Typ_aux typ _) = match typ with - | Typ_wild -> T_var "fresh" - | Typ_id id -> T_id (get_id id) - | Typ_var (Kid_aux (Var kid) _) -> T_var kid - | Typ_fn ptyp rtyp effect -> T_fn (typ_to_t envs ptyp) (typ_to_t envs rtyp) effect - | Typ_tup typs -> T_tup (List.map (typ_to_t envs) typs) - | Typ_app id typ_args -> T_app (get_id id) (T_args []) -end - -let rec pow_i (i:integer) (n:integer) : integer = - match (natFromInteger n) with - | 0 -> 1 - | n -> i * (pow_i i (integerFromNat (n-1))) -end -let two_pow = pow_i 2 - -let n_zero = Ne_const 0 -let n_one = Ne_const 1 -let n_two = Ne_const 2 - -val debug_print : string -> unit -declare ocaml target_rep function debug_print s = `Printf.eprintf` "%s" s - -type triple = Yes | No | Maybe -let triple_negate = function - | Yes -> No - | No -> Yes - | Maybe -> Maybe -end - - -(*Hand translated from Ocaml version*) - -let rec compare_nexps n1 n2 = - match (n1,n2) with - | (Ne_unary Ne_inf, Ne_unary Ne_inf) -> EQ - | (Ne_unary Ne_inf, _ ) -> LT - | (_ , Ne_unary Ne_inf) -> GT - | (Ne_const n1, Ne_const n2) -> compare n1 n2 - | (Ne_const _ , _ ) -> LT - | (_ , Ne_const _ ) -> GT - | (Ne_var i1 , Ne_var i2) -> compare i1 i2 - | (Ne_var _ , _ ) -> LT - | (_ , Ne_var _ ) -> GT - | (Ne_mult n0 n1, Ne_mult n2 n3) -> - (match compare_nexps n0 n2 with - | EQ -> compare_nexps n1 n3 - | a -> a end) - | (Ne_mult _ _ , _ ) -> LT - | (_ , Ne_mult _ _) -> GT - | (Ne_add[n1;n12],Ne_add [n2;n22]) -> - (match compare_nexps n1 n2 with - | EQ -> compare_nexps n12 n22 - | a -> a end) - | (Ne_add _ , _ ) -> LT - | (_ , Ne_add _ ) -> GT - | (Ne_minus n1 n12, Ne_minus n2 n22) -> - (match compare_nexps n1 n2 with - | EQ -> compare_nexps n12 n22 - | a -> a end) - | (Ne_minus _ _ , _ ) -> LT - | (_ , Ne_minus _ _ ) -> GT - | (Ne_exp n1, Ne_exp n2) -> compare_nexps n1 n2 - | (Ne_exp _ , _ ) -> LT - | (_ , Ne_exp _ ) -> GT - | (Ne_unary n1, Ne_unary n2) -> compare_nexps n1 n2 - | (Ne_unary _ , _ ) -> LT - | (_ , Ne_unary _ ) -> GT - | (Ne_inf, Ne_inf) -> EQ - | (Ne_inf, _ ) -> LT - | (_ , Ne_inf) -> GT -end - -let ~{ocaml} neLess b1 b2 = compare_nexps b1 b2 = LT -let ~{ocaml} neLessEq b1 b2 = compare_nexps b1 b2 <> GT -let ~{ocaml} neGreater b1 b2 = compare_nexps b1 b2 = GT -let ~{ocaml} neGreaterEq b1 b2 = compare_nexps b1 b2 <> LT - -let inline {ocaml} neLess = defaultLess -let inline {ocaml} neLessEq = defaultLessEq -let inline {ocaml} neGreater = defaultGreater -let inline {ocaml} neGreaterEq = defaultGreaterEq - -instance (Ord ne) - let compare = compare_nexps - let (<) = neLess - let (<=) = neLessEq - let (>) = neGreater - let (>=) = neGreaterEq -end - -let rec get_var n = match n with - | Ne_var _ -> Just n - | Ne_exp _ -> Just n - | Ne_unary n -> get_var n - | Ne_mult _ n1 -> get_var n1 - | _ -> Nothing -end - -let rec nexp_negative n = - match n with - | Ne_const i -> if i < 0 then Yes else No - | Ne_unary Ne_inf -> Yes - | Ne_inf -> No - | Ne_exp _ -> No - | Ne_var _ -> No - | Ne_mult n1 n2 -> (match (nexp_negative n1, nexp_negative n2) with - | (Yes,Yes) -> No - | (No, No) -> No - | (No, Yes) -> Yes - | (Yes, No) -> Yes - | _ -> Maybe end) - | Ne_add [n1;n2] -> (match (nexp_negative n1, nexp_negative n2) with - | (Yes,Yes) -> Yes - | (No, No) -> No - | _ -> Maybe end) - | _ -> Maybe -end - -let negate = function - | Ne_const i -> Ne_const ((0-1) * i) - | n -> Ne_mult (Ne_const (0-1)) n -end - -let increment_factor n i = - match n with - | Ne_var _ -> - (match i with - | Ne_const i -> - let ni = i + 1 in - if ni = 0 then n_zero else Ne_mult (Ne_const ni) n - | _ -> Ne_mult (Ne_add [i; n_one]) n end) - | Ne_exp _-> - (match i with - | Ne_const i -> - let ni = i + 1 in - if ni = 0 then n_zero else Ne_mult (Ne_const ni) n - | _ -> Ne_mult (Ne_add [i; n_one]) n end) - | Ne_mult n1 n2 -> - (match (n1,i) with - | (Ne_const i2,Ne_const i) -> - let ni = i + i2 in - if ni = 0 then n_zero else Ne_mult (Ne_const(i + i2)) n2 - | _ -> Ne_mult (Ne_add [n1; i]) n2 end) - | _ -> n - end - -let get_factor = function - | Ne_var _ -> n_one - | Ne_mult n1 _ -> n1 - | _ -> Assert_extra.failwith "get_factor argument not normalized" -end - -let rec normalize_n_rec recur_ok n = - match n with - | Ne_const _ -> n - | Ne_var _ -> n - | Ne_inf -> n - | Ne_unary n -> - let (n',to_recur,add_neg) = - (match n with - | Ne_const i -> (negate n,false,false) - | Ne_add [n1;n2] -> (Ne_add [negate n1; negate n2],true,false) - | Ne_minus n1 n2 -> (Ne_minus n2 n1,true,false) - | Ne_unary n -> (n,true,false) - | _ -> (n,true,true) end) in - if to_recur - then (let n' = normalize_n_rec true n' in - if add_neg - then negate n' - else n') - else n' - | Ne_exp n -> - let n' = normalize_n_rec true n in - (match n' with - | Ne_const i -> Ne_const (two_pow i) - | _ -> Ne_exp n' end) - | Ne_add [n1;n2] -> - let (n1',n2') = (normalize_n_rec true n1, normalize_n_rec true n2) in - (match (n1',n2', recur_ok) with - | (Ne_unary Ne_inf, Ne_inf,_) -> Assert_extra.failwith "Type inference should have failed" - | (Ne_inf, Ne_unary Ne_inf,_) -> Assert_extra.failwith "Type inference should have failed" - | (Ne_inf, _,_) -> Ne_inf - | (_, Ne_inf, _) -> Ne_inf - | (Ne_unary Ne_inf, _,_) -> Ne_unary Ne_inf - | (_, Ne_unary Ne_inf, _) -> Ne_unary Ne_inf - | (Ne_const i1, Ne_const i2,_) -> Ne_const (i1 + i2) - | (Ne_add [n11;n12], Ne_const i, true) -> - if (i = 0) - then n1' - else normalize_n_rec false (Ne_add [n11; (normalize_n_rec false (Ne_add [n12; n2']))]) - | (Ne_add [n11;n12], Ne_const i, false) -> - if i = 0 then n1' - else Ne_add [n11; (normalize_n_rec false (Ne_add [n12; n2']))] - | (Ne_const i, Ne_add[n21;n22], true) -> - if i = 0 then n2' - else normalize_n_rec false (Ne_add [n21; (normalize_n_rec false (Ne_add [n22; n1']))]) - | (Ne_const i, Ne_add [n21;n22], false) -> - if (i = 0) then n2' - else Ne_add [n21; (normalize_n_rec false (Ne_add [n22; n1']))] - | (Ne_const i, _,_) -> if i = 0 then n2' else Ne_add [n2'; n1'] - | (_, Ne_const i,_) -> if i = 0 then n1' else Ne_add [n1'; n2'] - | (Ne_add [n11;n12], Ne_add[n21;n22], true) -> - (match compare_nexps n11 n21 with - | GT -> normalize_n_rec false (Ne_add [n21; (normalize_n_rec false (Ne_add [n22; n1']))]) - | EQ -> - (match compare_nexps n12 n22 with - | GT -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_add [n12; n22])]) - | EQ -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_mult n_two n12)]) - | _ -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_add [n22; n12])]) end) - | _ -> normalize_n_rec false (Ne_add [n11; (normalize_n_rec false (Ne_add [n12; n2']))])end) - | (Ne_add[n11;n12], Ne_add[n21;n22], false) -> - (match compare_nexps n11 n21 with - | GT -> Ne_add [n21; (normalize_n_rec false (Ne_add [n22; n1']))] - | EQ -> - (match compare_nexps n12 n22 with - | GT -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_add [n12; n22])]) - | EQ -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_mult n_two n12)]) - | _ -> normalize_n_rec true (Ne_add [(Ne_mult n_two n11); (Ne_add [n22; n12])]) end) - | _ -> Ne_add [n11; (normalize_n_rec false (Ne_add [n12; n2']))] end) - | (Ne_exp n11, Ne_exp n21,_) -> - (match compare_nexps n11 n21 with - | GT -> Ne_add [n1'; n2'] - | EQ -> Ne_exp (normalize_n_rec true (Ne_add [n11; n_one])) - | _ -> Ne_add [ n2'; n1'] end) - | (Ne_exp n11,Ne_add[n21;n22],_) -> - (match n21 with - | Ne_exp n211 -> - (match compare_nexps n11 n211 with - | GT -> Ne_add [n21; (normalize_n_rec true (Ne_add [n11; n22]))] - | EQ -> Ne_add [(Ne_exp (normalize_n_rec true (Ne_add [n11; n_one]))); n22] - | _ -> Ne_add [n1'; n2'] end) - | _ -> Ne_add [n1'; n2'] end) - | (Ne_add [n11;n12],Ne_exp n21,_) -> - (match n11 with - | Ne_exp n111 -> - (match compare_nexps n111 n21 with - | GT -> Ne_add [n2'; n1'] - | EQ -> Ne_add [(Ne_exp (normalize_n_rec true (Ne_add [n111; n_one]))); n12] - | _ -> Ne_add [n11; (normalize_n_rec true (Ne_add [n2'; n12]))] end) - | _ -> Ne_add [n2'; n1'] end) - | _ -> - (match (get_var n1', get_var n2') with - | (Just nv1,Just nv2) -> - (match compare_nexps nv1 nv2 with - | GT -> Ne_add [n1'; n2'] - | EQ -> increment_factor n1' (get_factor n2') - | _ -> Ne_add [n2'; n1'] end) - | (Just (nv1),Nothing) -> Ne_add [n2'; n1'] - | (Nothing,Just(nv2)) -> Ne_add [n1'; n2'] - | _ -> (match (n1',n2') with - | (Ne_add[n11';n12'], _) -> - (match compare_nexps n11' n2' with - | GT -> Ne_add [n11'; (normalize_n_rec true (Ne_add [n12'; n2']))] - | EQ -> Assert_extra.failwith "Neither term has var but are the same?" - | _ -> Ne_add [n2';n1'] end) - | (_, Ne_add[n21';n22']) -> - (match compare_nexps n1' n21' with - | GT -> Ne_add [n1'; n2'] - | EQ -> Assert_extra.failwith "Unexpected equality" - | _ -> Ne_add [n21'; (normalize_n_rec true (Ne_add [n1'; n22']))] end) - | _ -> - (match compare_nexps n1' n2' with - | GT -> Ne_add [n1'; n2'] - | EQ -> normalize_n_rec true (Ne_mult n_two n1') - | _ -> Ne_add [n2'; n1'] end) end) end) end) - | Ne_minus n1 n2 -> - let (n1',n2') = (normalize_n_rec true n1, normalize_n_rec true n2) in - (match (n1',n2') with - | (Ne_unary Ne_inf, Ne_inf) -> Assert_extra.failwith "Type checker should have caught" - | (Ne_inf, Ne_unary Ne_inf) -> Assert_extra.failwith "Type checker should have caught" - | (Ne_inf, _) -> Ne_inf - | (_,Ne_unary Ne_inf) -> Ne_inf - | (Ne_unary Ne_inf, _) -> Ne_unary Ne_inf - | (_,Ne_inf) -> Ne_unary Ne_inf - | (Ne_const i1, Ne_const i2) -> Ne_const (i1 - i2) - | (Ne_const i, _) -> - if (i = 0) - then normalize_n_rec true (negate n2') - else normalize_n_rec true (Ne_add [(negate n2'); n1']) - | (_, Ne_const i) -> - if (i = 0) - then n1' - else normalize_n_rec true (Ne_add [n1'; (Ne_const ((0 - 1) * i))]) - | (_,_) -> - (match compare_nexps n1 n2 with - | EQ -> n_zero - | GT -> Ne_add [n1'; (negate n2')] - | _ -> Ne_add [(negate n2'); n1'] end) end) - | Ne_mult n1 n2 -> - let (n1',n2') = (normalize_n_rec true n1, normalize_n_rec true n2) in - (match (n1',n2') with - | (Ne_unary Ne_inf,Ne_unary Ne_inf) -> Ne_inf - | (Ne_inf, Ne_const i) -> if i = 0 then Ne_const 0 else Ne_inf - | (Ne_const i, Ne_inf) -> if i = 0 then Ne_const 0 else Ne_inf - | (Ne_unary Ne_inf, Ne_const i) -> - if i = 0 then Ne_const 0 - else if i < 0 then Ne_inf - else Ne_unary Ne_inf - | (Ne_const i, Ne_unary Ne_inf) -> - if i = 0 then Ne_const 0 - else if i < 0 then Ne_inf - else Ne_unary Ne_inf - | (Ne_unary Ne_inf, _) -> - (match nexp_negative n2 with - | Yes -> Ne_inf - | _ -> Ne_unary Ne_inf end) - | (_, Ne_unary Ne_inf) -> - (match nexp_negative n1 with - | Yes -> Ne_inf - | _ -> Ne_unary Ne_inf end) - | (Ne_inf, _) -> - (match nexp_negative n2 with - | Yes -> Ne_unary Ne_inf - | _ -> Ne_inf end) - | (_, Ne_inf) -> - (match nexp_negative n1 with - | Yes -> Ne_unary Ne_inf - | _ -> Ne_inf end) - | (Ne_const i1, Ne_const i2) -> Ne_const (i1 * i2) - | (Ne_const i1, Ne_exp n) -> - if i1 = 2 - then Ne_exp (normalize_n_rec true (Ne_add [n;n_one])) - else Ne_mult n1' n2' - | (Ne_exp n, Ne_const i1) -> - if i1 = 2 - then Ne_exp (normalize_n_rec true (Ne_add [n; n_one])) - else Ne_mult n2' n1' - | (Ne_mult _ _, Ne_var _) -> Ne_mult n1' n2' - | (Ne_exp n1, Ne_exp n2) -> Ne_exp (normalize_n_rec true (Ne_add [n1; n2])) - | (Ne_exp _, Ne_var _) -> Ne_mult n2' n1' - | (Ne_exp _, Ne_mult _ _) -> Ne_mult n2' n1' - | (Ne_var _, Ne_var _) -> - (match compare n1' n2' with - | EQ -> Ne_mult n1' n2' - | GT -> Ne_mult n1' n2' - | _ -> Ne_mult n2' n1' end) - | (Ne_const _, Ne_add [n21;n22]) -> - normalize_n_rec true (Ne_add [(Ne_mult n1' n21); (Ne_mult n1' n21)]) - | (Ne_var _,Ne_add [n21;n22]) -> - normalize_n_rec true (Ne_add [(Ne_mult n1' n21); (Ne_mult n1' n21)]) - | (Ne_exp _, Ne_add[n21;n22]) -> - normalize_n_rec true (Ne_add [(Ne_mult n1' n21); (Ne_mult n1' n21)]) - | (Ne_mult _ _, Ne_add[n21;n22]) -> - normalize_n_rec true (Ne_add [(Ne_mult n1' n21); (Ne_mult n1' n21)]) - | (Ne_add[n11;n12],Ne_const _) -> - normalize_n_rec true (Ne_add [(Ne_mult n11 n2'); (Ne_mult n12 n2')]) - | (Ne_add [n11;n12],Ne_var _) -> - normalize_n_rec true (Ne_add [(Ne_mult n11 n2'); (Ne_mult n12 n2')]) - | (Ne_add([n11;n12]), Ne_exp _) -> - normalize_n_rec true (Ne_add [(Ne_mult n11 n2'); (Ne_mult n12 n2')]) - | (Ne_add [n11;n12], Ne_mult _ _) -> - normalize_n_rec true (Ne_add [(Ne_mult n11 n2'); (Ne_mult n12 n2')]) - | (Ne_mult n11 n12 , Ne_const _) -> - normalize_n_rec false (Ne_mult (Ne_mult n11 n2') (Ne_mult n12 n2')) - | (Ne_const i1, _) -> - if (i1 = 0) then n1' - else if (i1 = 1) then n2' - else Ne_mult n1' n2' - | (_, Ne_const i1) -> - if (i1 = 0) then n2' - else if (i1 = 1) then n1' - else Ne_mult n2' n1' - | (Ne_add [n11;n12],Ne_add [n21;n22]) -> - normalize_n_rec true (Ne_add [(Ne_mult n11 n21); - (Ne_add [(Ne_mult n11 n22); - (Ne_add [(Ne_mult n12 n21); (Ne_mult n12 n22)])])]) - | (Ne_mult _ _, Ne_exp _) -> Ne_mult n1' n2' - | (Ne_var _, Ne_mult n1 n2) -> - (match (get_var n1, get_var n2) with - | (Just(nv1),Just(nv2)) -> - (match compare_nexps nv1 nv2 with - | EQ -> Ne_mult n1 (Ne_mult nv1 nv1) - | GT -> Ne_mult (normalize_n_rec true (Ne_mult n1 n1')) n2 - | _ -> Ne_mult n2' n1' end) - | _ -> Ne_mult (normalize_n_rec true (Ne_mult n1 n1')) n2 end) - | (Ne_var _, Ne_exp _) -> Ne_mult n2' n1' - | (Ne_mult _ _,Ne_mult n21 n22) -> Ne_mult (Ne_mult n21 n1') (Ne_mult n22 n1') - | _ -> Assert_extra.failwith "Normalize hit a case that should have been removed" end) -end - -let normalize_nexp = normalize_n_rec true - -let rec range_in_range envs (recur1,recur2,recur3,recur4) act_bot act_top exp_bot exp_top = - let (act_bot,act_top,exp_bot,exp_top) = - if recur1 && recur2 && recur3 && recur4 - then (normalize_nexp act_bot, normalize_nexp act_top, normalize_nexp exp_bot, normalize_nexp exp_top) - else (act_bot,act_top,exp_bot,exp_top) - in - match (act_bot,recur1,act_top,recur2,exp_bot,recur3,exp_top,recur4) with - | (Ne_var i, true, _,_, _,_, _,_) -> - (match get_nexp envs i with - | Just n -> range_in_range envs (false, recur2,recur3,recur4) n act_top exp_bot exp_top - | Nothing -> range_in_range envs (false,recur2,recur3,recur4) act_bot act_top exp_bot exp_top end) - | (_, _, Ne_var i, true, _, _, _, _) -> - (match get_nexp envs i with - | Just n -> range_in_range envs (recur1,false,recur3,recur4) act_bot n exp_bot exp_top - | Nothing -> range_in_range envs (recur1,false,recur3,recur4) act_bot act_top exp_bot exp_top end) - | (_,_,_,_,Ne_var i,true,_,_) -> - (match get_nexp envs i with - | Just n -> range_in_range envs (recur1,recur2,false,recur4) act_bot act_top n exp_top - | Nothing -> range_in_range envs (recur1,recur2,false,recur4) act_bot act_top exp_bot exp_top end) - | (_,_,_,_,_,_,Ne_var i,true) -> - (match get_nexp envs i with - | Just n -> range_in_range envs (recur1,recur2,recur3,false) act_bot act_top exp_bot n - | Nothing -> range_in_range envs (recur1,recur2,recur3,false) act_bot act_top exp_bot exp_top end) - | (Ne_const abi,_, Ne_const ati,_, Ne_const ebi,_, Ne_const ebt,_) -> - ebi <= abi && abi <= ebt && ati <= ebt - | (Ne_const abi,_, Ne_const ati,_, Ne_unary Ne_inf,_, Ne_inf,_) -> true - | (Ne_const abi,_, Ne_const ati,_, Ne_const ebi,_, Ne_inf,_) -> - ebi <= abi - | (Ne_const abi,_, Ne_const ati,_, Ne_unary Ne_inf,_, Ne_const ebt,_) -> - abi <= ebt && ati <= ebt - | (Ne_unary Ne_inf,_, Ne_inf,_, Ne_unary Ne_inf,_, Ne_inf,_) -> true -end - -let rec single_in_range envs act exp_bot exp_top = - let (act,exp_bot,exp_top) = (normalize_nexp act, normalize_nexp exp_bot, normalize_nexp exp_top) in - match (act,exp_bot,exp_top) with - | (Ne_const ai, Ne_const ebi, Ne_const eti) -> - ebi <= ai && ai <= eti - | (Ne_const _, Ne_unary Ne_inf, Ne_inf) -> true - | (Ne_const ai, Ne_const ebi, Ne_inf) -> ebi <= ai - | (Ne_const ai, Ne_unary Ne_inf, Ne_const eti) -> ai <= eti - end - -let make_new_range envs start length (Ord_aux order _) = - let is_inc = match order with - | Ord_inc -> true - | Ord_dec -> false - | Ord_var (Kid_aux (Var id) _) -> - (match get_ord envs id with - | Just (Ord_aux Ord_inc _) -> true - | Just (Ord_aux Ord_dec _) -> false - | _ -> true (* Default direction is inc *) end) end in - let length_n = match (normalize_nexp length) with - | Ne_var i -> (match get_nexp envs i with - | Just n -> n - | Nothing -> Assert_extra.failwith "Vector type has no length" end) - | n -> n end in - let start_n = match (normalize_nexp start) with - | Ne_var i -> (match get_nexp envs i with - | Just n -> n - | Nothing -> if is_inc then Ne_const 0 else (Ne_minus length_n n_one) end) - | n -> n end in - if is_inc - then T_app "range" (T_args [T_arg_nexp start;T_arg_nexp (Ne_minus (Ne_add [start;length]) n_one)]) - else T_app "range" (T_args [T_arg_nexp (Ne_add [(Ne_minus start_n length_n);n_one]); T_arg_nexp start]) - -let consistent_eff eff1 eff2 = true - -let rec consistent_typ envs (typ_actual :t) (typ_allowed : t) = - match (typ_actual,typ_allowed) with - | (T_abbrev ta _, T_abbrev tb _) -> consistent_typ envs ta tb - | (T_abbrev ta _, t) -> consistent_typ envs ta t - | (t, T_abbrev tb _) -> consistent_typ envs t tb - | (T_id x, T_id y) -> (x=y, envs) - | (T_fn act_parms act_ret act_eff, T_fn all_parms all_ret all_eff) -> - let (consistent,envs) = consistent_typ envs act_parms all_parms in - if consistent - then let (consistent,envs) = consistent_typ envs act_ret all_ret in - if consistent - then (consistent_eff act_eff all_eff, envs) - else (false,envs) - else (false,envs) - | (T_tup act_tups, T_tup all_tups) -> - if List.length act_tups = List.length all_tups - then consistent_typ_list envs act_tups all_tups - else (false,envs) - | (T_app "range" (T_args [T_arg_nexp low;T_arg_nexp high]), - T_app "range" (T_args [T_arg_nexp all_low;T_arg_nexp all_high])) -> - (range_in_range envs (true,true,true,true) low high all_low all_high,envs) - | (T_app "range" (T_args [T_arg_nexp low;T_arg_nexp high]), - T_app "atom" (T_args [T_arg_nexp all])) -> - (false,envs) - | (T_app "atom" (T_args [T_arg_nexp act]), T_app "range" (T_args [T_arg_nexp low; T_arg_nexp high])) -> - (single_in_range envs act low high,envs) - | (T_app "atom" (T_args [T_arg_nexp act]), T_app "atom" (T_args [T_arg_nexp all])) -> - (false,envs) - | (T_app "vector" (T_args [T_arg_nexp start; T_arg_nexp size; T_arg_order dir; T_arg_typ t]), - T_app "vector" (T_args [T_arg_nexp sta; T_arg_nexp sia ; T_arg_order da ; T_arg_typ ta])) -> - let (consistent,envs) = consistent_nexp envs start sta in - if consistent then - let (consistent,envs) = consistent_nexp envs size sia in - if consistent then - if dir = da - then consistent_typ envs t ta - else (false,envs) - else (false,envs) - else (false,envs) - | (T_app x (T_args args_act), T_app y (T_args args_all)) -> - if x = y && List.length args_act = List.length args_all - then consistent_typ_arg_list envs args_act args_all - else (false, envs) - | (T_var x, T_var y) -> (x = y,envs) - | _ -> (false,envs) -end - -and - consistent_nexp envs n_acc n_all = - let (n_acc,n_all) = (normalize_nexp n_acc,normalize_nexp n_all) in - match (n_acc,n_all) with - | (Ne_const iac, Ne_const ial) -> (iac = ial, envs) - | (Ne_exp nac, Ne_exp nal) -> consistent_nexp envs nac nal - | (_, Ne_inf) -> (true,envs) - | (Ne_var i, _) -> (true,envs) - | (_, Ne_var i) -> (true,envs) - | _ -> (true,envs) -end - -and consistent_typ_list envs t_accs t_alls = - match (t_accs,t_alls) with - | ([],[]) -> (true,envs) - | (t_acc::t_accs,t_all::t_alls) -> - let (consistent,envs) = consistent_typ envs t_acc t_all in - if consistent - then consistent_typ_list envs t_accs t_alls - else (false,envs) - | _ -> (false,envs) -end - -and consistent_typ_arg_list envs t_accs t_alls = - let arg_check t_acc t_all = - match (t_acc,t_all) with - | (T_arg_typ tacc,T_arg_typ tall) -> consistent_typ envs tacc tall - | (T_arg_nexp nacc,T_arg_nexp nall) -> consistent_nexp envs nacc nall - | (T_arg_order oacc, T_arg_order oall) -> (oacc=oall,envs) - | (T_arg_effect eacc, T_arg_effect eall) -> (consistent_eff eacc eall, envs) - end in - match (t_accs,t_alls) with - | ([],[]) -> (true,envs) - | (ta::tas,t::ts) -> - let (consistent,envs) = arg_check ta t in - if consistent - then consistent_typ_arg_list envs tas ts - else (false,envs) - | _ -> (false,envs) -end - -let mk_atom n = T_app "atom" (T_args [T_arg_nexp (Ne_const n)]) - -let check_lit envs typ (L_aux lit loc) = - match lit with - | L_num n -> consistent_typ envs (mk_atom n) typ - | L_zero -> consistent_typ envs (T_id "bit") typ - | L_one -> consistent_typ envs (T_id "bit") typ - | L_string _ -> consistent_typ envs (T_id "string") typ - | L_undef -> (true,envs) - | _ -> (false,envs) -end - -let rec check_exp envs ret_typ exp_typ (E_aux exp (l,annot)) = - let (typ,tag,ncs,effect,reffect) = match annot with - | Nothing -> - (T_var "fresh_v", Tag_empty,[],(Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) - | Just(t, tag, ncs, ef,efr) -> (t,tag,ncs,ef,efr) end in - match exp with - | E_block exps -> check_block envs envs true ret_typ exp_typ exps - | E_nondet exps -> check_block envs envs false ret_typ exp_typ exps - | E_id id -> - (match get_typ envs (get_id id) with - | Just (t,necs) -> let (consistent,envs) = consistent_typ envs typ t in - if consistent - then consistent_typ envs typ exp_typ - else (false,envs) - | Nothing -> (false,envs) end) - | E_lit lit -> - let (consistent,envs) = check_lit envs exp_typ lit in - if consistent - then consistent_typ envs typ exp_typ - else (false,envs) - | E_cast typ exp -> - let t = typ_to_t envs typ in - let (consistent,envs) = check_exp envs ret_typ t exp in - if consistent - then consistent_typ envs t exp_typ - else (false,envs) - | E_app id exps -> (*Need to connect constraints for the function to new type variables in the parms and ret*) - (match get_typ envs (get_id id) with - | Just ((T_fn parms ret effects),necs) -> - (match (parms,exps) with - | (T_tup (_::_ as typs), (_::_ as exps)) -> - if List.length typs = List.length exps - then let (consistent,envs) = List.foldr (fun (exp,typ) (consistent,envs) -> - if consistent - then check_exp envs ret_typ typ exp - else (false,envs)) (true,envs) (List.zip exps typs) in - if consistent - then consistent_typ envs ret exp_typ - else (false,envs) - else (false,envs) - | (T_id "unit", []) -> - consistent_typ envs ret exp_typ - | (T_id "unit", [E_aux (E_lit (L_aux L_unit _)) _]) -> - consistent_typ envs ret exp_typ - | _ -> (false,envs) end) - | _ -> (false, envs) end) - | E_app_infix lexp id rexp -> - (match get_typ envs (get_id id) with - | Just ((T_fn parms ret effects),necs) -> - (match parms with - | T_tup [ltyp;rtyp] -> - let (consistent,envs) = check_exp envs ret_typ ltyp lexp in - if consistent then - let (consistent,envs) = check_exp envs ret_typ rtyp rexp in - if consistent - then consistent_typ envs ret exp_typ - else (false,envs) - else (false,envs) - | _ -> (false,envs) end) - | _ -> (false, envs) end) - | E_tuple exps -> - (match (typ,exp_typ) with - | (T_tup typs, T_tup e_typs) -> - if List.length typs = List.length e_typs && List.length exps = List.length typs - then - let typ_list = List.zip typs e_typs in - let exp_typs_list = List.zip exps typ_list in - List.foldr (fun (exp, (typ,e_typ)) (consistent,envs) -> - if consistent - then let (consistent,envs) = check_exp envs ret_typ e_typ exp in - consistent_typ envs typ e_typ - else (false,envs)) (true,envs) exp_typs_list - else (false,envs) - | _ -> (false,envs) end) - | E_if cond t_branch e_branch -> - let (consistent,envs) = check_exp envs ret_typ (T_id "bit") cond in - if consistent - then let (consistent,envs_t) = check_exp envs ret_typ exp_typ t_branch in - if consistent - then let (consistent,envs_e) = check_exp envs ret_typ exp_typ e_branch in - if consistent - then consistent_typ (union_envs envs [envs_t; envs_e]) typ exp_typ - else (false,envs) - else (false,envs) - else (false,envs) - | E_for id from to_ by ((Ord_aux o _) as order) exp -> (false,envs) - | E_vector exps -> - (match (typ,exp_typ) with - | (T_app "vector" (T_args [T_arg_nexp start; T_arg_nexp length; T_arg_order ord; T_arg_typ typ]), - T_app "vector" (T_args [T_arg_nexp strte; T_arg_nexp lenge; T_arg_order orde; T_arg_typ typ_e])) -> - let (consistent, envs) = consistent_nexp envs start strte in - if consistent then - let (consistent, envs) = consistent_nexp envs length lenge in - if consistent then - let (consistent,envs) = consistent_nexp envs (Ne_const (integerFromNat (List.length exps))) length in - if consistent then - List.foldr (fun exp (consistent,envs) -> - if consistent - then check_exp envs ret_typ exp_typ exp - else (false,envs)) (true,envs) exps - else (false,envs) - else (false,envs) - else (false,envs) - | _ -> (false,envs) end) - | E_vector_indexed iexps default -> (false,envs) - | E_vector_access vexp aexp -> - let (fresh_start,envs) = nexp_fresh envs in - let (fresh_length, envs) = nexp_fresh envs in - let (fresh_order, envs) = ord_fresh envs in - let (consistent,envs) = - check_exp envs ret_typ (T_app "vector" (T_args [T_arg_nexp fresh_start; T_arg_nexp fresh_length; - T_arg_order fresh_order; T_arg_typ typ])) vexp in - if consistent - then check_exp envs ret_typ (make_new_range envs fresh_start fresh_length fresh_order) aexp - else (false,envs) - | E_vector_subrange vexp sexp eexp -> - let (fresh_start,envs) = nexp_fresh envs in - let (fresh_length,envs) = nexp_fresh envs in - let (fresh_order, envs) = ord_fresh envs in - (match (typ,exp_typ) with - | (T_app "vector" (T_args [T_arg_nexp sstart; T_arg_nexp sleng; T_arg_order ord; T_arg_typ typ]), - T_app "vector" (T_args [T_arg_nexp sse; T_arg_nexp sle; T_arg_order oe; T_arg_typ exp_typ])) -> - let (consistent,envs) = - check_exp envs ret_typ (T_app "vector" (T_args [T_arg_nexp fresh_start; T_arg_nexp fresh_length; - T_arg_order fresh_order; T_arg_typ exp_typ])) vexp in - if consistent - then let range = make_new_range envs fresh_start fresh_length fresh_order in - let (consistent,envs) = check_exp envs ret_typ range sexp in - if consistent - then check_exp envs ret_typ range eexp (*TODO, make sure that the sub piece is build by the s and e terms*) - else (false,envs) - else (false,envs) - | _ -> (false,envs) end) - | E_vector_update vexp aexp nexp -> (false,envs) - | E_vector_update_subrange vexp sexp eexp nexp -> (false,envs) - | E_vector_append lexp rexp -> - (match (typ,exp_typ) with - | (T_app "vector" (T_args[T_arg_nexp start;T_arg_nexp length;T_arg_order dir;T_arg_typ t]), - T_app "vector" (T_args[T_arg_nexp ste; T_arg_nexp lee; T_arg_order dre; T_arg_typ te])) -> - let (startl,envs) = nexp_fresh envs in - let (lenl,envs) = nexp_fresh envs in - let (startr,envs) = nexp_fresh envs in - let (lenr,envs) = nexp_fresh envs in - let (consistent,envs) = - check_exp envs ret_typ (T_app "vector" (T_args [T_arg_nexp startl;T_arg_nexp lenl; - T_arg_order dir; T_arg_typ te])) lexp in - if consistent then - let (consistent,envs) = - check_exp envs ret_typ (T_app "vector" (T_args [T_arg_nexp startr;T_arg_nexp lenr; - T_arg_order dir; T_arg_typ te])) rexp in - if consistent then - let (consistent,envs) = consistent_typ envs typ exp_typ in - if consistent - then consistent_nexp envs (Ne_add [lenl; lenr]) lee - else (false,envs) - else (false,envs) - else (false,envs) - | _ -> (false,envs) end) - | E_list exps -> - (match (typ,exp_typ) with - | (T_app "list" (T_args [T_arg_typ t]),T_app "list" (T_args [T_arg_typ te])) -> - let (consistent,envs) = List.foldr (fun exp (consistent,envs) -> - if consistent - then check_exp envs ret_typ te exp - else (false,envs)) (true,envs) exps in - if consistent - then consistent_typ envs t te - else (false,envs) - | _ -> (false,envs) end) - | E_cons hexp texp -> - (match (typ,exp_typ) with - | (T_app "list" (T_args [T_arg_typ t]),T_app "list" (T_args [T_arg_typ te])) -> - let (consistent,envs) = check_exp envs ret_typ te hexp in - if consistent - then let (consistent,envs) = check_exp envs ret_typ exp_typ texp in - if consistent - then consistent_typ envs t te - else (false,envs) - else (false,envs) - | _ -> (false,envs) end) - | E_record fexps -> (false,envs) - | E_record_update rexp fexps -> (false,envs) - | E_field exp id -> (false,envs) - | E_case exp pexps -> (false,envs) - | E_let lbind exp -> (false,envs) - | E_assign lexp exp -> (false,envs) - | E_sizeof nexp -> (false,envs) - | E_exit exp -> let (fresh_t,envs) = t_fresh envs in check_exp envs ret_typ fresh_t exp - | E_return exp -> check_exp envs ret_typ ret_typ exp - | E_assert cond mesg -> - let (consistent,envs) = check_exp envs ret_typ (T_id "bit") cond in - if consistent then - let (consistent,envs) = check_exp envs ret_typ (T_app "option" (T_args[T_arg_typ (T_id "string")])) mesg in - if consistent - then consistent_typ envs (T_id "unit") exp_typ - else (false,envs) - else (false,envs) - | E_internal_cast tannot exp -> (false,envs) - | E_internal_exp tannot -> (false,envs) - | E_sizeof_internal tannot -> (false,envs) - | E_internal_exp_user tannot tannot2 -> (false,envs) - | E_comment msg -> (true,envs) - | E_comment_struc exp -> (true,envs) - | E_internal_let lexp exp inexp -> (false,envs) - | E_internal_plet pat exp inexp -> (false,envs) - | E_internal_return exp -> (false,envs) -end - -and check_block orig_envs envs carry_variables_forward ret_typ exp_typ exps = (false,orig_envs) diff --git a/src/lexer.mll b/src/lexer.mll index 7f11355f..3b1a1583 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -42,6 +42,7 @@ { open Parser +open Big_int module M = Map.Make(String) exception LexError of string * Lexing.position @@ -76,10 +77,16 @@ let kw_table = ("else", (fun _ -> Else)); ("exit", (fun _ -> Exit)); ("extern", (fun _ -> Extern)); + ("cast", (fun _ -> Cast)); ("false", (fun _ -> False)); + ("try", (fun _ -> Try)); + ("catch", (fun _ -> Catch)); + ("throw", (fun _ -> Throw)); ("forall", (fun _ -> Forall)); + ("exist", (fun _ -> Exist)); ("foreach", (fun _ -> Foreach)); ("function", (fun x -> Function_)); + ("overload", (fun _ -> Overload)); ("if", (fun x -> If_)); ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); @@ -87,6 +94,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 +102,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 +112,11 @@ let kw_table = ("undefined", (fun x -> Undefined)); ("union", (fun x -> Union)); ("with", (fun x -> With)); + ("when", (fun x -> When)); + ("repeat", (fun x -> Repeat)); + ("until", (fun x -> Until)); + ("while", (fun x -> While)); + ("do", (fun x -> Do)); ("val", (fun x -> Val)); ("div", (fun x -> Div_)); @@ -130,7 +144,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 +320,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(big_int_of_string i)) } + | "-" digit+ as i { (Num(big_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/lexer2.mll b/src/lexer2.mll new file mode 100644 index 00000000..a8dbaaf3 --- /dev/null +++ b/src/lexer2.mll @@ -0,0 +1,286 @@ +(**************************************************************************) +(* 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 Parser2 +open Big_int +open Parse_ast +module M = Map.Make(String) +exception LexError of string * Lexing.position + +let r = fun s -> s (* Ulib.Text.of_latin1 *) +(* Available as Scanf.unescaped since OCaml 4.0 but 3.12 is still common *) +let unescaped s = Scanf.sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) + +let mk_operator prec n op = + match prec, n with + | Infix, 0 -> Op0 op + | Infix, 1 -> Op1 op + | Infix, 2 -> Op2 op + | Infix, 3 -> Op3 op + | Infix, 4 -> Op4 op + | Infix, 5 -> Op5 op + | Infix, 6 -> Op6 op + | Infix, 7 -> Op7 op + | Infix, 8 -> Op8 op + | Infix, 9 -> Op9 op + | InfixL, 0 -> Op0l op + | InfixL, 1 -> Op1l op + | InfixL, 2 -> Op2l op + | InfixL, 3 -> Op3l op + | InfixL, 4 -> Op4l op + | InfixL, 5 -> Op5l op + | InfixL, 6 -> Op6l op + | InfixL, 7 -> Op7l op + | InfixL, 8 -> Op8l op + | InfixL, 9 -> Op9l op + | InfixR, 0 -> Op0r op + | InfixR, 1 -> Op1r op + | InfixR, 2 -> Op2r op + | InfixR, 3 -> Op3r op + | InfixR, 4 -> Op4r op + | InfixR, 5 -> Op5r op + | InfixR, 6 -> Op6r op + | InfixR, 7 -> Op7r op + | InfixR, 8 -> Op8r op + | InfixR, 9 -> Op9r op + | _, _ -> assert false + +let operators = ref M.empty + +let kw_table = + List.fold_left + (fun r (x,y) -> M.add x y r) + M.empty + [ + ("and", (fun _ -> And)); + ("as", (fun _ -> As)); + ("assert", (fun _ -> Assert)); + ("bitzero", (fun _ -> Bitzero)); + ("bitone", (fun _ -> Bitone)); + ("by", (fun _ -> By)); + ("match", (fun _ -> Match)); + ("clause", (fun _ -> Clause)); + ("dec", (fun _ -> Dec)); + ("operator", (fun _ -> Op)); + ("default", (fun _ -> Default)); + ("effect", (fun _ -> Effect)); + ("end", (fun _ -> End)); + ("enum", (fun _ -> Enum)); + ("else", (fun _ -> Else)); + ("exit", (fun _ -> Exit)); + ("cast", (fun _ -> Cast)); + ("false", (fun _ -> False)); + ("forall", (fun _ -> Forall)); + ("foreach", (fun _ -> Foreach)); + ("function", (fun x -> Function_)); + ("overload", (fun _ -> Overload)); + ("throw", (fun _ -> Throw)); + ("try", (fun _ -> Try)); + ("catch", (fun _ -> Catch)); + ("if", (fun x -> If_)); + ("in", (fun x -> In)); + ("inc", (fun _ -> Inc)); + ("let", (fun x -> Let_)); + ("record", (fun _ -> Record)); + ("Int", (fun x -> Int)); + ("Order", (fun x -> Order)); + ("pure", (fun x -> Pure)); + ("register", (fun x -> Register)); + ("return", (fun x -> Return)); + ("scattered", (fun x -> Scattered)); + ("sizeof", (fun x -> Sizeof)); + ("constraint", (fun x -> Constraint)); + ("struct", (fun x -> Struct)); + ("then", (fun x -> Then)); + ("true", (fun x -> True)); + ("Type", (fun x -> TYPE)); + ("type", (fun x -> Typedef)); + ("undefined", (fun x -> Undefined)); + ("union", (fun x -> Union)); + ("with", (fun x -> With)); + ("val", (fun x -> Val)); + ("repeat", (fun _ -> Repeat)); + ("until", (fun _ -> Until)); + ("while", (fun _ -> While)); + ("do", (fun _ -> Do)); + ("mutual", (fun _ -> Mutual)); + + ("barr", (fun x -> Barr)); + ("depend", (fun x -> Depend)); + ("rreg", (fun x -> Rreg)); + ("wreg", (fun x -> Wreg)); + ("rmem", (fun x -> Rmem)); + ("rmemt", (fun x -> Rmemt)); + ("wmem", (fun x -> Wmem)); + ("wmv", (fun x -> Wmv)); + ("wmvt", (fun x -> Wmvt)); + ("eamem", (fun x -> Eamem)); + ("exmem", (fun x -> Exmem)); + ("undef", (fun x -> Undef)); + ("unspec", (fun x -> Unspec)); + ("nondet", (fun x -> Nondet)); + ("escape", (fun x -> Escape)); + ] + +} + +let ws = [' ''\t']+ +let letter = ['a'-'z''A'-'Z''?'] +let digit = ['0'-'9'] +let binarydigit = ['0'-'1'] +let hexdigit = ['0'-'9''A'-'F''a'-'f'] +let alphanum = letter|digit +let startident = letter|'_' +let ident = alphanum|['_''\'''#'] +let tyvar_start = '\'' +let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] +let operator = (oper_char+ ('_' ident)?) +let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) + +rule token = parse + | ws + { token lexbuf } + | "\n" + { Lexing.new_line lexbuf; + token lexbuf } + | "&" { (Amp(r"&")) } + | "@" { (At "@") } + | "2" ws "^" { TwoCaret } + | "^" { (Caret(r"^")) } + | ":" { Colon(r ":") } + | "," { Comma } + | ".." { DotDot } + | "." { Dot } + | "==" as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } + | "=" { (Eq(r"=")) } + | ">" { (Gt(r">")) } + | "-" { Minus } + | "<" { (Lt(r"<")) } + | "+" { (Plus(r"+")) } + | ";" { Semi } + | "*" { (Star(r"*")) } + | "_" { Under } + | "[|" { LsquareBar } + | "|]" { RsquareBar } + | "{|" { LcurlyBar } + | "|}" { RcurlyBar } + | "|" { Bar } + | "{" { Lcurly } + | "}" { Rcurly } + | "()" { Unit(r"()") } + | "(" { Lparen } + | ")" { Rparen } + | "[" { Lsquare } + | "]" { Rsquare } + | "!=" { (ExclEq(r"!=")) } + | ">=" { (GtEq(r">=")) } + | "->" { MinusGt } + | "=>" { EqGt(r "=>") } + | "<=" { (LtEq(r"<=")) } + | "infix" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator Infix (int_of_string (Char.escaped p)) op) !operators; + Fixity (Infix, big_int_of_string (Char.escaped p), op) } + | "infixl" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixL (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixL, big_int_of_string (Char.escaped p), op) } + | "infixr" ws (digit as p) ws (operator as op) + { operators := M.add op (mk_operator InfixR (int_of_string (Char.escaped p)) op) !operators; + Fixity (InfixR, big_int_of_string (Char.escaped p), op) } + | operator as op + { try M.find op !operators + with Not_found -> raise (LexError ("Operator fixity undeclared " ^ op, Lexing.lexeme_start_p lexbuf)) } + | "(*" { comment (Lexing.lexeme_start_p lexbuf) 0 lexbuf; token lexbuf } + | "*)" { raise (LexError("Unbalanced comment", Lexing.lexeme_start_p lexbuf)) } + | tyvar_start startident ident* as i { TyVar(r i) } + | "~" { Id(r"~") } + | startident ident* as i { if M.mem i kw_table then + (M.find i kw_table) () + (* else if + List.mem i default_type_names || + List.mem i !custom_type_names then + TyId(r i) *) + else Id(r i) } + | (digit+ as i1) "." (digit+ as i2) { (Real (i1 ^ "." ^ i2)) } + | "-" (digit* as i1) "." (digit+ as i2) { (Real ("-" ^ i1 ^ "." ^ i2)) } + | digit+ as i { (Num(big_int_of_string i)) } + | "-" digit+ as i { (Num(big_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 + | "(*" { comment pos (depth+1) lexbuf } + | "*)" { if depth = 0 then () + else if depth > 0 then comment pos (depth-1) lexbuf + else assert false } + | "\n" { Lexing.new_line lexbuf; + comment pos depth lexbuf } + | '"' { ignore(string (Lexing.lexeme_start_p lexbuf) (Buffer.create 10) lexbuf); + comment pos depth lexbuf } + | _ { comment pos depth lexbuf } + | eof { raise (LexError("Unbalanced comment", pos)) } + +and string pos b = parse + | ([^'"''\n''\\']*'\n' as i) { Lexing.new_line lexbuf; + Buffer.add_string b i; + string pos b lexbuf } + | ([^'"''\n''\\']* as i) { Buffer.add_string b i; string pos b lexbuf } + | escape_sequence as i { Buffer.add_string b i; string pos b lexbuf } + | '\\' '\n' ws { Lexing.new_line lexbuf; string pos b lexbuf } + | '\\' { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + "illegal backslash escape in string"*) } + | '"' { let s = unescaped(Buffer.contents b) in + (*try Ulib.UTF8.validate s; s + with Ulib.UTF8.Malformed_code -> + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + "String literal is not valid utf8"))) *) s } + | eof { assert false (*raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, + "String literal not terminated")))*) } diff --git a/src/monomorphise.ml b/src/monomorphise.ml new file mode 100644 index 00000000..7774e110 --- /dev/null +++ b/src/monomorphise.ml @@ -0,0 +1,2370 @@ +open Parse_ast +open Ast +open Ast_util +open Big_int +open Type_check + +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 kbindings_from_list = List.fold_left (fun s (v,i) -> KBindings.add v i s) KBindings.empty +let bindings_from_list = List.fold_left (fun s (v,i) -> Bindings.add v i s) Bindings.empty +(* union was introduced in 4.03.0, a bit too recently *) +let bindings_union s1 s2 = + Bindings.merge (fun _ x y -> match x,y with + | _, (Some x) -> Some x + | (Some x), _ -> Some x + | _, _ -> None) s1 s2 + +let subst_nexp substs nexp = + let rec s_snexp substs (Nexp_aux (ne,l) as nexp) = + let re ne = Nexp_aux (ne,l) in + let s_snexp = s_snexp substs in + match ne with + | Nexp_var (Kid_aux (_,l) as kid) -> + (try KBindings.find kid substs + with Not_found -> nexp) + | Nexp_id _ + | Nexp_constant _ -> nexp + | Nexp_times (n1,n2) -> re (Nexp_times (s_snexp n1, s_snexp n2)) + | Nexp_sum (n1,n2) -> re (Nexp_sum (s_snexp n1, s_snexp n2)) + | Nexp_minus (n1,n2) -> re (Nexp_minus (s_snexp n1, s_snexp n2)) + | Nexp_exp ne -> re (Nexp_exp (s_snexp ne)) + | Nexp_neg ne -> re (Nexp_neg (s_snexp ne)) + | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args)) + in s_snexp substs nexp + +let rec subst_nc substs (NC_aux (nc,l) as n_constraint) = + let snexp nexp = subst_nexp substs nexp in + let snc nc = subst_nc substs nc in + let re nc = NC_aux (nc,l) in + match nc with + | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2)) + | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2)) + | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2)) + | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2)) + | NC_set (kid,is) -> + begin + match KBindings.find kid substs with + | Nexp_aux (Nexp_constant i,_) -> + if List.mem i is then re NC_true else re NC_false + | nexp -> + raise (Reporting_basic.err_general l + ("Unable to substitute " ^ string_of_nexp nexp ^ + " into set constraint " ^ string_of_n_constraint n_constraint)) + | exception Not_found -> n_constraint + end + | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2)) + | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2)) + | NC_true + | NC_false + -> n_constraint + + + +let subst_src_typ substs t = + let rec s_styp substs ((Typ_aux (t,l)) as ty) = + let re t = Typ_aux (t,l) in + match t with + | Typ_id _ + | Typ_var _ + -> ty + | Typ_fn (t1,t2,e) -> re (Typ_fn (s_styp substs t1, s_styp substs t2,e)) + | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts)) + | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas)) + | Typ_exist (kids,nc,t) -> + let substs = List.fold_left (fun sub v -> KBindings.remove v sub) substs kids in + re (Typ_exist (kids,nc,s_styp substs t)) + and s_starg substs (Typ_arg_aux (ta,l) as targ) = + match ta with + | Typ_arg_nexp ne -> Typ_arg_aux (Typ_arg_nexp (subst_nexp substs ne),l) + | Typ_arg_typ t -> Typ_arg_aux (Typ_arg_typ (s_styp substs t),l) + | Typ_arg_order _ -> targ + in s_styp substs t + +let make_vector_lit sz i = + let f j = if eq_big_int (mod_big_int (shift_right_big_int i (sz-j-1)) (big_int_of_int 2)) zero_big_int 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 eq_big_int n zero_big_int then acc' else aux acc' (sub_big_int n unit_big_int) + in if eq_big_int n zero_big_int then [] else aux [] (sub_big_int n unit_big_int) + +let make_vectors sz = + tabulate (make_vector_lit sz) (shift_left_big_int unit_big_int sz) + +let pat_id_is_variable env id = + match Env.lookup_id id env with + (* Unbound is returned for both variables and constructors which take + arguments, but the latter only don't appear in a P_id *) + | Unbound + (* Shadowing of immutable locals is allowed; mutable locals and registers + are rejected by the type checker, so don't matter *) + | Local _ + | Register _ + -> true + | Enum _ + | Union _ + -> false + +let rec is_value (E_aux (e,(l,annot))) = + let is_constructor 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,_,_) -> + Env.is_union_constructor id env || + (match Env.lookup_id id env with + | Enum _ | Union _ -> true + | Unbound | Local _ | Register _ -> false) + in + match e with + | E_id id -> is_constructor id + | E_lit _ -> true + | E_tuple es -> List.for_all is_value es + | E_app (id,es) -> is_constructor id && List.for_all is_value es +(* 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) + +let rec cross' = function + | [] -> [[]] + | (h::t) -> + let t' = cross' t in + List.concat (List.map (fun x -> List.map (fun l -> x::l) t') h) + +let rec cross'' = function + | [] -> [[]] + | (k,None)::t -> List.map (fun l -> (k,None)::l) (cross'' t) + | (k,Some h)::t -> + let t' = cross'' t in + List.concat (List.map (fun x -> List.map (fun l -> (k,Some x)::l) t') h) + +let kidset_bigunion = function + | [] -> KidSet.empty + | h::t -> List.fold_left KidSet.union h t + +(* TODO: deal with non-set constraints, intersections, etc somehow *) +let extract_set_nc var (NC_aux (_,l) as nc) = + let rec aux (NC_aux (nc,l)) = + let re nc = NC_aux (nc,l) in + match nc with + | NC_set (id,is) when Kid.compare id var = 0 -> Some (is,re NC_true) + | NC_and (nc1,nc2) -> + (match aux nc1, aux nc2 with + | None, None -> None + | None, Some (is,nc2') -> Some (is, re (NC_and (nc1,nc2'))) + | Some (is,nc1'), None -> Some (is, re (NC_and (nc1',nc2))) + | Some _, Some _ -> + raise (Reporting_basic.err_general l ("Multiple set constraints for " ^ string_of_kid var))) + | _ -> None + in match aux nc with + | Some is -> is + | None -> + raise (Reporting_basic.err_general l ("No set constraint for " ^ string_of_kid var)) + +let rec peel = function + | [], l -> ([], l) + | h1::t1, h2::t2 -> let (l1,l2) = peel (t1, t2) in ((h1,h2)::l1,l2) + | _,_ -> assert false + +let rec split_insts = function + | [] -> [],[] + | (k,None)::t -> let l1,l2 = split_insts t in l1,k::l2 + | (k,Some v)::t -> let l1,l2 = split_insts t in (k,v)::l1,l2 + +let apply_kid_insts kid_insts t = + let kid_insts, kids' = split_insts kid_insts in + let kid_insts = List.map (fun (v,i) -> (v,Nexp_aux (Nexp_constant i,Generated Unknown))) kid_insts in + let subst = kbindings_from_list kid_insts in + kids', subst_src_typ subst t + +let rec inst_src_type insts (Typ_aux (ty,l) as typ) = + match ty with + | Typ_id _ + | Typ_var _ + -> insts,typ + | Typ_fn _ -> + raise (Reporting_basic.err_general l "Function type in constructor") + | Typ_tup ts -> + let insts,ts = + List.fold_right + (fun typ (insts,ts) -> let insts,typ = inst_src_type insts typ in insts,typ::ts) + ts (insts,[]) + in insts, Typ_aux (Typ_tup ts,l) + | Typ_app (id,args) -> + let insts,ts = + List.fold_right + (fun arg (insts,args) -> let insts,arg = inst_src_typ_arg insts arg in insts,arg::args) + args (insts,[]) + in insts, Typ_aux (Typ_app (id,ts),l) + | Typ_exist (kids, nc, t) -> + let kid_insts, insts' = peel (kids,insts) in + let kids', t' = apply_kid_insts kid_insts t in + (* TODO: subst in nc *) + match kids' with + | [] -> insts', t' + | _ -> insts', Typ_aux (Typ_exist (kids', nc, t'), l) +and inst_src_typ_arg insts (Typ_arg_aux (ta,l) as tyarg) = + match ta with + | Typ_arg_nexp _ + | Typ_arg_order _ + -> insts, tyarg + | Typ_arg_typ typ -> + let insts', typ' = inst_src_type insts typ in + insts', Typ_arg_aux (Typ_arg_typ typ',l) + +let rec contains_exist (Typ_aux (ty,_)) = + match ty with + | Typ_id _ + | Typ_var _ + -> false + | Typ_fn (t1,t2,_) -> contains_exist t1 || contains_exist t2 + | Typ_tup ts -> List.exists contains_exist ts + | Typ_app (_,args) -> List.exists contains_exist_arg args + | Typ_exist _ -> true +and contains_exist_arg (Typ_arg_aux (arg,_)) = + match arg with + | Typ_arg_nexp _ + | Typ_arg_order _ + -> false + | Typ_arg_typ typ -> contains_exist typ + +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 + | Nexp_app (_,args) -> List.concat (List.map size_nvars_nexp args) + +(* 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 + (* This was originally written for the general case, but I cut it down to the + more manageable prenex-form below *) + let rec size_nvars_ty (Typ_aux (ty,l) as typ) = + match ty with + | Typ_id _ + | Typ_var _ + -> (KidSet.empty,[[],typ]) + | Typ_fn _ -> + raise (Reporting_basic.err_general l ("Function type in constructor " ^ i)) + | Typ_tup ts -> + let (vars,tys) = List.split (List.map size_nvars_ty ts) in + let insttys = List.map (fun x -> let (insts,tys) = List.split x in + List.concat insts, Typ_aux (Typ_tup tys,l)) (cross' tys) in + (kidset_bigunion vars, insttys) + | 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",_)),_)),_)]) -> + (KidSet.of_list (size_nvars_nexp sz), [[],typ]) + | Typ_app (_, tas) -> + (KidSet.empty,[[],typ]) (* We only support sizes for bitvectors mentioned explicitly, not any buried + inside another type *) + | Typ_exist (kids, nc, t) -> + let (vars,tys) = size_nvars_ty t in + let find_insts k (insts,nc) = + let inst,nc' = + if KidSet.mem k vars then + let is,nc' = extract_set_nc k nc in + Some is,nc' + else None,nc + in (k,inst)::insts,nc' + in + let (insts,nc') = List.fold_right find_insts kids ([],nc) in + let insts = cross'' insts in + let ty_and_inst (inst0,ty) inst = + let kids, ty = apply_kid_insts inst ty in + let ty = + (* Typ_exist is not allowed an empty list of kids *) + match kids with + | [] -> ty + | _ -> Typ_aux (Typ_exist (kids, nc', ty),l) + in inst@inst0, ty + in + let tys = List.concat (List.map (fun instty -> List.map (ty_and_inst instty) insts) tys) in + let free = List.fold_left (fun vars k -> KidSet.remove k vars) vars kids in + (free,tys) + in + (* Only single-variable prenex-form for now *) + let size_nvars_ty (Typ_aux (ty,l) as typ) = + match ty with + | Typ_exist (kids,_,t) -> + begin + match snd (size_nvars_ty typ) with + | [] -> [] + | tys -> + (* One level of tuple type is stripped off by the type checker, so + add another here *) + let tys = + List.map (fun (x,ty) -> + x, match ty with + | Typ_aux (Typ_tup _,_) -> Typ_aux (Typ_tup [ty],Unknown) + | _ -> ty) tys in + if contains_exist t then + raise (Reporting_basic.err_general l + "Only prenex types in unions are supported by monomorphisation") + else if List.length kids > 1 then + raise (Reporting_basic.err_general l + "Only single-variable existential types in unions are currently supported by monomorphisation") + else tys + end + | _ -> [] + in + (* TODO: reject universally quantification or monomorphise it *) + let variants = size_nvars_ty ty in + match variants with + | [] -> None + | sample::__ -> + let () = if List.length variants > size_set_limit then + raise (Reporting_basic.err_general ql + (string_of_int (List.length variants) ^ "variants for constructor " ^ i ^ + "bigger than limit " ^ string_of_int size_set_limit)) else () + 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_seg = function + | (_,None) -> "" + | (k,Some i) -> string_of_kid k ^ string_of_big_int i + in + let name l i = String.concat "_" (i::(List.map name_seg l)) in + Some (List.map (fun (l,ty) -> (l, wrap (name l),ty)) variants) + +let reduce_nexp subst ne = + let rec eval (Nexp_aux (ne,_) as nexp) = + match ne with + | Nexp_constant i -> i + | Nexp_sum (n1,n2) -> add_big_int (eval n1) (eval n2) + | Nexp_minus (n1,n2) -> sub_big_int (eval n1) (eval n2) + | Nexp_times (n1,n2) -> mult_big_int (eval n1) (eval n2) + | Nexp_exp n -> shift_left_big_int (eval n) 1 + | Nexp_neg n -> minus_big_int (eval n) + | _ -> + raise (Reporting_basic.err_general Unknown ("Couldn't turn nexp " ^ + string_of_nexp nexp ^ " into concrete value")) + in eval ne + + +let typ_of_args args = + match args with + | [E_aux (E_tuple args,(_,Some (_,Typ_aux (Typ_exist _,_),_)))] -> + let tys = List.map Type_check.typ_of args in + Typ_aux (Typ_tup tys,Unknown) + | [exp] -> + Type_check.typ_of exp + | _ -> + let tys = List.map Type_check.typ_of args in + Typ_aux (Typ_tup tys,Unknown) + +(* 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) *) + +let refine_constructor refinements l env id args = + match List.find (fun (id',_) -> Id.compare id id' = 0) refinements with + | (_,irefinements) -> begin + let (_,constr_ty) = Env.get_val_spec id env in + match constr_ty with + | Typ_aux (Typ_fn (constr_ty,_,_),_) -> begin + let arg_ty = typ_of_args args in + match Type_check.destruct_exist env constr_ty with + | None -> None + | Some (kids,nc,constr_ty) -> + let (bindings,_,_) = Type_check.unify l env constr_ty arg_ty in + let find_kid kid = try Some (KBindings.find kid bindings) with Not_found -> None in + let bindings = List.map find_kid kids in + let matches_refinement (mapping,_,_) = + List.for_all2 + (fun v (_,w) -> + match v,w with + | _,None -> true + | Some (U_nexp (Nexp_aux (Nexp_constant n, _))),Some m -> eq_big_int n m + | _,_ -> false) bindings mapping + in + match List.find matches_refinement irefinements with + | (_,new_id,_) -> Some (E_app (new_id,args)) + | exception Not_found -> + (Reporting_basic.print_err false true l "Monomorphisation" + ("Unable to refine constructor " ^ string_of_id id); + None) + end + | _ -> None + end + | exception Not_found -> None + + +(* Substitute found nexps for variables in an expression, and rename constructors to reflect + specialisation *) + +(* TODO: kid shadowing *) +let nexp_subst_fns substs = + + let s_t t = subst_src_typ substs t in +(* let s_typschm (TypSchm_aux (TypSchm_ts (q,t),l)) = TypSchm_aux (TypSchm_ts (q,s_t t),l) in + hopefully don't need this anyway *)(* + let s_typschm tsh = tsh in*) + let s_tannot = function + | None -> None + | Some (env,t,eff) -> Some (env,s_t t,eff) (* TODO: what about env? *) + in +(* let rec s_pat (P_aux (p,(l,annot))) = + let re p = P_aux (p,(l,(*s_tannot*) annot)) in + match p with + | P_lit _ | P_wild | P_id _ -> re p + | P_var kid -> 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)) + | P_cons (p1,p2) -> re (P_cons (s_pat p1, s_pat p2)) + and s_fpat (FP_aux (FP_Fpat (id, p), (l,annot))) = + FP_aux (FP_Fpat (id, s_pat p), (l,s_tannot annot)) + in*) + let rec s_exp (E_aux (e,(l,annot))) = + let re e = E_aux (e,(l,s_tannot annot)) in + match e with + | E_block es -> re (E_block (List.map s_exp es)) + | E_nondet es -> re (E_nondet (List.map s_exp es)) + | E_id _ + | E_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_constraint nc -> re (E_constraint (subst_nc substs nc)) + | 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) -> re (E_app (id, List.map s_exp es)) + | E_app_infix (e1,id,e2) -> re (E_app_infix (s_exp e1,id,s_exp e2)) + | E_tuple es -> re (E_tuple (List.map s_exp es)) + | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3)) + | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4)) + | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2)) + | E_vector es -> re (E_vector (List.map s_exp es)) + | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2)) + | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3)) + | E_vector_update (e1,e2,e3) -> re (E_vector_update (s_exp e1,s_exp e2,s_exp e3)) + | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (s_exp e1,s_exp e2,s_exp e3,s_exp e4)) + | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2)) + | E_list es -> re (E_list (List.map s_exp es)) + | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2)) + | E_record fes -> re (E_record (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)) + | E_throw e -> re (E_throw (s_exp e)) + | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases)) + and s_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 (p,e) -> LB_aux (LB_val ((*s_pat*) p,s_exp e), (l,s_tannot annot)) + and s_lexp (LEXP_aux (e,(l,annot))) = + let re e = LEXP_aux (e,(l,s_tannot annot)) in + match e with + | LEXP_id _ -> re e + | LEXP_cast (typ,id) -> re (LEXP_cast (s_t typ, id)) + | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map s_exp es)) + | LEXP_tup les -> re (LEXP_tup (List.map s_lexp les)) + | LEXP_vector (le,e) -> re (LEXP_vector (s_lexp le, s_exp e)) + | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (s_lexp le, s_exp e1, s_exp e2)) + | LEXP_field (le,id) -> re (LEXP_field (s_lexp le, id)) + in ((fun x -> x (*s_pat*)),s_exp) +let nexp_subst_pat substs = fst (nexp_subst_fns substs) +let nexp_subst_exp substs = snd (nexp_subst_fns substs) + +let bindings_from_pat p = + let rec aux_pat (P_aux (p,(l,annot))) = + let env = Type_check.env_of_annot (l, annot) in + match p with + | P_lit _ + | P_wild + -> [] + | P_as (p,id) -> id::(aux_pat p) + | P_typ (_,p) -> aux_pat p + | P_id id -> + if pat_id_is_variable env id then [id] else [] + | P_var (p,kid) -> aux_pat p + | P_vector ps + | P_vector_concat ps + | P_app (_,ps) + | P_tup ps + | P_list ps + -> List.concat (List.map aux_pat ps) + | P_record (fps,_) -> List.concat (List.map aux_fpat fps) + | P_cons (p1,p2) -> aux_pat p1 @ aux_pat p2 + and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p + in aux_pat p + +let remove_bound env pat = + let bound = bindings_from_pat pat in + List.fold_left (fun sub v -> Bindings.remove v sub) 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 + | L_num i1, L_num i2 -> eq_big_int i1 i2 + | l1,l2 -> l1 = l2 + +(* There's no undefined nexp, so replace undefined sizes with a plausible size. + 32 is used as a sensible default. *) +let fabricate_nexp l = function + | None -> nint 32 + | Some (env,typ,_) -> + match Type_check.destruct_exist env typ with + | None -> nint 32 + | Some (kids,nc,typ') -> + match kids,nc,Env.expand_synonyms env typ' with + | ([kid],NC_aux (NC_set (kid',i::_),_), + Typ_aux (Typ_app (Id_aux (Id "range",_), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_); + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 && + Kid.compare kid kid''' = 0 -> + Nexp_aux (Nexp_constant i,Unknown) + | ([kid],NC_aux (NC_true,_), + Typ_aux (Typ_app (Id_aux (Id "range",_), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_); + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_)) + when Kid.compare kid kid'' = 0 && + Kid.compare kid kid''' = 0 -> + nint 32 + | _ -> raise (Reporting_basic.err_general l + ("Undefined value at unsupported type " ^ string_of_typ typ)) + +(* Used for constant propagation in pattern matches *) +type 'a matchresult = + | DoesMatch of 'a + | DoesNotMatch + | GiveUp + +(* Remove top-level casts from an expression. Useful when we need to look at + subexpressions to reduce something, but could break type-checking if we used + it everywhere. *) +let rec drop_casts = function + | E_aux (E_cast (_,e),_) -> drop_casts e + | exp -> exp + +let int_of_str_lit = function + | L_hex hex -> big_int_of_string ("0x" ^ hex) + | L_bin bin -> big_int_of_string ("0b" ^ bin) + | _ -> assert false + +let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) = + match l1,l2 with + | (L_zero|L_false), (L_zero|L_false) + | (L_one |L_true ), (L_one |L_true) + -> Some true + | (L_hex _| L_bin _), (L_hex _|L_bin _) + -> Some (eq_big_int (int_of_str_lit l1) (int_of_str_lit l2)) + | L_undef, _ | _, L_undef -> None + | L_num i1, L_num i2 -> Some (eq_big_int i1 i2) + | _ -> Some (l1 = l2) + +let try_app (l,ann) (id,args) = + let new_l = Generated l in + let env = env_of_annot (l,ann) in + let get_overloads f = List.map string_of_id + (Env.get_overloads (Id_aux (Id f, Parse_ast.Unknown)) env @ + Env.get_overloads (Id_aux (DeIid f, Parse_ast.Unknown)) env) in + let is_id f = List.mem (string_of_id id) (f :: get_overloads f) in + if is_id "==" || is_id "!=" then + match args with + | [E_aux (E_lit l1,_); E_aux (E_lit l2,_)] -> + let lit b = if b then L_true else L_false in + let lit b = lit (if is_id "==" then b else not b) in + (match lit_eq l1 l2 with + | None -> None + | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)),(l,ann)))) + | _ -> None + else if is_id "cast_bit_bool" then + match args with + | [E_aux (E_lit L_aux (L_zero,_),_)] -> Some (E_aux (E_lit (L_aux (L_false,new_l)),(l,ann))) + | [E_aux (E_lit L_aux (L_one ,_),_)] -> Some (E_aux (E_lit (L_aux (L_true ,new_l)),(l,ann))) + | _ -> None + else if is_id "UInt" then + match args with + | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit,_), _)] -> + Some (E_aux (E_lit (L_aux (L_num (int_of_str_lit lit),new_l)),(l,ann))) + | _ -> None + else if is_id "shl_int" then + match args with + | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] -> + Some (E_aux (E_lit (L_aux (L_num (shift_left_big_int i (int_of_big_int j)),new_l)),(l,ann))) + | _ -> None + else if is_id "ex_int" then + match args with + | [E_aux (E_lit lit,(l,_))] -> Some (E_aux (E_lit lit,(l,ann))) + | _ -> None + else if is_id "vector_access" || is_id "bitvector_access" then + match args with + | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_); + E_aux (E_lit L_aux (L_num i,_),_)] -> + let v = int_of_str_lit lit in + let b = and_big_int (shift_right_big_int v (int_of_big_int i)) unit_big_int in + let lit' = if eq_big_int b unit_big_int then L_one else L_zero in + Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann))) + | _ -> None + else None + + +let construct_lit_vector args = + let rec aux l = function + | [] -> Some (L_aux (L_bin (String.concat "" (List.rev l)),Unknown)) + | E_aux (E_lit (L_aux ((L_zero | L_one) as lit,_)),_)::t -> + aux ((if lit = L_zero then "0" else "1")::l) t + | _ -> None + in aux [] args + +(* 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) list + | ConstrSplit of (tannot pat * nexp KBindings.t) list + +let threaded_map f state l = + let l',state' = + List.fold_left (fun (tl,state) element -> let (el',state') = f state element in (el'::tl,state')) + ([],state) l + in List.rev l',state' + +let isubst_minus subst subst' = + Bindings.merge (fun _ x y -> match x,y with (Some a), None -> Some a | _, _ -> None) subst subst' + +let isubst_minus_set subst set = + IdSet.fold Bindings.remove set subst + +let assigned_vars exp = + fst (Rewriter.fold_exp + { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with + Rewriter.lEXP_id = (fun id -> IdSet.singleton id, LEXP_id id); + Rewriter.lEXP_cast = (fun (ty,id) -> IdSet.singleton id, LEXP_cast (ty,id)) } + exp) + +let assigned_vars_in_fexps (FES_aux (FES_Fexps (fes,_), _)) = + List.fold_left + (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e)) + IdSet.empty + fes + +let assigned_vars_in_pexp (Pat_aux (p,_)) = + match p with + | Pat_exp (_,e) -> assigned_vars e + | Pat_when (p,e1,e2) -> IdSet.union (assigned_vars e1) (assigned_vars e2) + +let rec assigned_vars_in_lexp (LEXP_aux (le,_)) = + match le with + | LEXP_id id + | LEXP_cast (_,id) -> IdSet.singleton id + | LEXP_tup lexps -> List.fold_left (fun vs le -> IdSet.union vs (assigned_vars_in_lexp le)) IdSet.empty lexps + | LEXP_memory (_,es) -> List.fold_left (fun vs e -> IdSet.union vs (assigned_vars e)) IdSet.empty es + | LEXP_vector (le,e) -> IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) + | LEXP_vector_range (le,e1,e2) -> + IdSet.union (assigned_vars_in_lexp le) (IdSet.union (assigned_vars e1) (assigned_vars e2)) + | LEXP_field (le,_) -> assigned_vars_in_lexp le + +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', ty) -> Tu_aux (Tu_ty_id (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 + + (* Constant propogation. + Takes maps of immutable/mutable variables to subsitute. + Extremely conservative about evaluation order of assignments in + subexpressions, dropping assignments rather than committing to + any particular order *) + let rec const_prop_exp substs assigns ((E_aux (e,(l,annot))) as exp) = + (* Functions to treat lists and tuples of subexpressions as possibly + non-deterministic: that is, we stop making any assumptions about + variables that are assigned to in any of the subexpressions *) + let non_det_exp_list es = + let assigned_in = + List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) + IdSet.empty es in + let assigns = isubst_minus_set assigns assigned_in in + let es' = List.map (fun e -> fst (const_prop_exp substs assigns e)) es in + es',assigns + in + let non_det_exp_2 e1 e2 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigns = isubst_minus_set assigns assigned_in_e12 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + e1',e2',assigns + in + let non_det_exp_3 e1 e2 e3 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in + let assigns = isubst_minus_set assigns assigned_in_e123 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + let e3',_ = const_prop_exp substs assigns e3 in + e1',e2',e3',assigns + in + let non_det_exp_4 e1 e2 e3 e4 = + let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in + let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in + let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in + let assigns = isubst_minus_set assigns assigned_in_e1234 in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + let e3',_ = const_prop_exp substs assigns e3 in + let e4',_ = const_prop_exp substs assigns e4 in + e1',e2',e3',e4',assigns + in + let re e assigns = E_aux (e,(l,annot)),assigns in + match e with + (* TODO: are there more circumstances in which we should get rid of these? *) + | E_block [e] -> const_prop_exp substs assigns e + | E_block es -> + let es',assigns = threaded_map (const_prop_exp substs) assigns es in + re (E_block es') assigns + | E_nondet es -> + let es',assigns = non_det_exp_list es in + re (E_nondet es') assigns + | E_id id -> + let env = Type_check.env_of_annot (l, annot) in + (try + match Env.lookup_id id env with + | Local (Immutable,_) -> Bindings.find id substs + | Local (Mutable,_) -> Bindings.find id assigns + | _ -> exp + with Not_found -> exp),assigns + | E_lit _ + | E_sizeof _ + | E_internal_exp _ + | E_sizeof_internal _ + | E_internal_exp_user _ + | E_comment _ + | E_constraint _ + -> exp,assigns + | E_cast (t,e') -> + let e'',assigns = const_prop_exp substs assigns e' in + re (E_cast (t, e'')) assigns + | E_app (id,es) -> + let es',assigns = non_det_exp_list es in + let env = Type_check.env_of_annot (l, annot) in + (match try_app (l,annot) (id,es') with + | None -> + (match const_prop_try_fn l env (id,es') with + | None -> re (E_app (id,es')) assigns + | Some r -> r,assigns) + | Some r -> r,assigns) + | E_tuple es -> + let es',assigns = non_det_exp_list es in + re (E_tuple es') assigns + | E_if (e1,e2,e3) -> + let e1',assigns = const_prop_exp substs assigns e1 in + let e2',assigns2 = const_prop_exp substs assigns e2 in + let e3',assigns3 = const_prop_exp substs assigns e3 in + (match drop_casts e1' with + | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) -> + (match lit with L_true -> e2',assigns2 | _ -> e3',assigns3) + | _ -> + let assigns = isubst_minus_set assigns (assigned_vars e2) in + let assigns = isubst_minus_set assigns (assigned_vars e3) in + re (E_if (e1',e2',e3')) assigns) + | E_for (id,e1,e2,e3,ord,e4) -> + (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *) + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + let assigns = isubst_minus_set assigns (assigned_vars e4) in + let e4',_ = const_prop_exp (Bindings.remove id substs) assigns e4 in + re (E_for (id,e1',e2',e3',ord,e4')) assigns + | E_loop (loop,e1,e2) -> + let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in + let e1',_ = const_prop_exp substs assigns e1 in + let e2',_ = const_prop_exp substs assigns e2 in + re (E_loop (loop,e1',e2')) assigns + | E_vector es -> + let es',assigns = non_det_exp_list es in + begin + match construct_lit_vector es' with + | None -> re (E_vector es') assigns + | Some lit -> re (E_lit lit) assigns + end + | E_vector_access (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_vector_access (e1',e2')) assigns + | E_vector_subrange (e1,e2,e3) -> + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + re (E_vector_subrange (e1',e2',e3')) assigns + | E_vector_update (e1,e2,e3) -> + let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in + re (E_vector_update (e1',e2',e3')) assigns + | E_vector_update_subrange (e1,e2,e3,e4) -> + let e1',e2',e3',e4',assigns = non_det_exp_4 e1 e2 e3 e4 in + re (E_vector_update_subrange (e1',e2',e3',e4')) assigns + | E_vector_append (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_vector_append (e1',e2')) assigns + | E_list es -> + let es',assigns = non_det_exp_list es in + re (E_list es') assigns + | E_cons (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_cons (e1',e2')) assigns + | E_record fes -> + let assigned_in_fes = assigned_vars_in_fexps fes in + let assigns = isubst_minus_set assigns assigned_in_fes in + re (E_record (const_prop_fexps substs assigns fes)) assigns + | E_record_update (e,fes) -> + let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in + let assigns = isubst_minus_set assigns assigned_in in + let e',_ = const_prop_exp substs assigns e in + re (E_record_update (e', const_prop_fexps substs assigns fes)) assigns + | E_field (e,id) -> + let e',assigns = const_prop_exp substs assigns e in + re (E_field (e',id)) assigns + | E_case (e,cases) -> + let e',assigns = const_prop_exp substs assigns e in + (match can_match e' cases substs assigns with + | None -> + let assigned_in = + List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe)) + IdSet.empty cases + in + let assigns' = isubst_minus_set assigns assigned_in in + re (E_case (e', List.map (const_prop_pexp substs assigns) cases)) assigns' + | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) -> + let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in + let newbindings_env = bindings_from_list newbindings in + let substs' = bindings_union substs newbindings_env in + const_prop_exp substs' assigns exp) + | E_let (lb,e2) -> + begin + match lb with + | LB_aux (LB_val (p,e), annot) -> + let e',assigns = const_prop_exp substs assigns e in + let substs' = remove_bound substs p in + let plain () = + let e2',assigns = const_prop_exp substs' assigns e2 in + re (E_let (LB_aux (LB_val (p,e'), annot), + e2')) assigns in + if is_value e' && not (is_value e) then + match can_match e' [Pat_aux (Pat_exp (p,e2),(Unknown,None))] substs assigns with + | None -> plain () + | Some (e'',bindings,kbindings) -> + let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in + let bindings = bindings_from_list bindings in + let substs'' = bindings_union substs' bindings in + const_prop_exp substs'' assigns e'' + else plain () + end + (* TODO maybe - tuple assignments *) + | E_assign (le,e) -> + let env = Type_check.env_of_annot (l, annot) in + let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in + let assigns = isubst_minus_set assigns assigned_in in + let le',idopt = const_prop_lexp substs assigns le in + let e',_ = const_prop_exp substs assigns e in + let assigns = + match idopt with + | Some id -> + begin + match Env.lookup_id id env with + | Local (Mutable,_) | Unbound -> + if is_value e' + then Bindings.add id e' assigns + else Bindings.remove id assigns + | _ -> assigns + end + | None -> assigns + in + re (E_assign (le', e')) assigns + | E_exit e -> + let e',_ = const_prop_exp substs assigns e in + re (E_exit e') Bindings.empty + | E_throw e -> + let e',_ = const_prop_exp substs assigns e in + re (E_throw e') Bindings.empty + | E_try (e,cases) -> + (* TODO: try and preserve *any* assignment info *) + let e',_ = const_prop_exp substs assigns e in + re (E_case (e', List.map (const_prop_pexp substs Bindings.empty) cases)) Bindings.empty + | E_return e -> + let e',_ = const_prop_exp substs assigns e in + re (E_return e') Bindings.empty + | E_assert (e1,e2) -> + let e1',e2',assigns = non_det_exp_2 e1 e2 in + re (E_assert (e1',e2')) assigns + | E_internal_cast (ann,e) -> + let e',assigns = const_prop_exp substs assigns e in + re (E_internal_cast (ann,e')) assigns + (* TODO: should I substitute or anything here? Is it even used? *) + | E_comment_struc e -> re (E_comment_struc e) assigns + + | E_app_infix _ + | E_internal_let _ + | E_internal_plet _ + | E_internal_return _ + -> raise (Reporting_basic.err_unreachable l + ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) + and const_prop_fexps substs assigns (FES_aux (FES_Fexps (fes,flag), annot)) = + FES_aux (FES_Fexps (List.map (const_prop_fexp substs assigns) fes, flag), annot) + and const_prop_fexp substs assigns (FE_aux (FE_Fexp (id,e), annot)) = + FE_aux (FE_Fexp (id,fst (const_prop_exp substs assigns e)),annot) + and const_prop_pexp substs assigns = function + | (Pat_aux (Pat_exp (p,e),l)) -> + Pat_aux (Pat_exp (p,fst (const_prop_exp (remove_bound substs p) assigns e)),l) + | (Pat_aux (Pat_when (p,e1,e2),l)) -> + let substs' = remove_bound substs p in + let e1',assigns = const_prop_exp substs' assigns e1 in + Pat_aux (Pat_when (p, e1', fst (const_prop_exp substs' assigns e2)),l) + and const_prop_lexp substs assigns ((LEXP_aux (e,annot)) as le) = + let re e = LEXP_aux (e,annot), None in + match e with + | LEXP_id id (* shouldn't end up substituting here *) + | LEXP_cast (_,id) + -> le, Some id + | LEXP_memory (id,es) -> + re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp substs assigns e)) es)) (* or here *) + | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp substs assigns le)) les)) + | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp substs assigns le), fst (const_prop_exp substs assigns e))) + | LEXP_vector_range (le,e1,e2) -> + re (LEXP_vector_range (fst (const_prop_lexp substs assigns le), + fst (const_prop_exp substs assigns e1), + fst (const_prop_exp substs assigns e2))) + | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp substs assigns 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 l env (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,Generated l)),(Generated l,None)) + | [e] -> e + | _ -> E_aux (E_tuple args,(Generated l,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_with_env env arg cases Bindings.empty Bindings.empty with + | Some (exp,bindings,kbindings) -> + let substs = bindings_from_list bindings in + let result,_ = const_prop_exp substs Bindings.empty exp in + if is_value result then Some result else None + | None -> None + + and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases substs assigns = + let rec findpat_generic check_pat description assigns = 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 assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl) + | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx + when pat_id_is_variable env id' -> + Some (exp, [(id', exp0)], []) + | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl + when pat_id_is_variable env id' -> begin + let substs = Bindings.add id' exp0 substs in + let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in + match guard with + | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[]) + | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | _ -> None + end + | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin + match check_pat p with + | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesMatch (vsubst,ksubst) -> begin + let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in + let substs = bindings_union substs (bindings_from_list vsubst) in + let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in + match guard with + | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst) + | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl + | _ -> None + end + | GiveUp -> None + end + | (Pat_aux (Pat_exp (p,exp),_))::tl -> + match check_pat p with + | DoesNotMatch -> findpat_generic check_pat description assigns tl + | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst) + | GiveUp -> None + in + match e with + | E_id id -> + (match Env.lookup_id id env with + | Enum _ -> + let checkpat = function + | P_aux (P_id id',_) + | P_aux (P_app (id',[]),_) -> + if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch + | P_aux (_,(l',_)) -> + (Reporting_basic.print_err false true l' "Monomorphisation" + "Unexpected kind of pattern for enumeration"; GiveUp) + in findpat_generic checkpat (string_of_id id) assigns cases + | _ -> None) + | E_lit (L_aux (lit_e, lit_l)) -> + let checkpat = function + | P_aux (P_lit (L_aux (lit_p, _)),_) -> + if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch + | P_aux (P_var (P_aux (P_id id,p_id_annot), kid),_) -> + begin + match lit_e with + | L_num i -> + DoesMatch ([id, E_aux (e,(l,annot))], + [kid,Nexp_aux (Nexp_constant i,Unknown)]) + (* For undefined we fix the type-level size (because there's no good + way to construct an undefined size), but leave the term as undefined + to make the meaning clear. *) + | L_undef -> + let nexp = fabricate_nexp l annot in + let typ = subst_src_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in + DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,None))),(l,None))], + [kid,nexp]) + | _ -> + (Reporting_basic.print_err false true lit_l "Monomorphisation" + "Unexpected kind of literal for var match"; GiveUp) + end + | P_aux (_,(l',_)) -> + (Reporting_basic.print_err false true l' "Monomorphisation" + "Unexpected kind of pattern for literal"; GiveUp) + in findpat_generic checkpat "literal" assigns cases + | _ -> None + + and can_match exp = + let env = Type_check.env_of exp in + can_match_with_env env exp + in + + let subst_exp substs exp = + let substs = bindings_from_list substs in + fst (const_prop_exp substs Bindings.empty exp) + in + + (* Split a variable pattern into every possible value *) + + let split var l annot = + let v = string_of_id var in + let env = Type_check.env_of_annot (l, annot) in + let typ = Type_check.typ_of_annot (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_aux (Id "bool",_)) -> + [P_aux (P_lit (L_aux (L_true,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_true,new_l)),(new_l,annot))]; + P_aux (P_lit (L_aux (L_false,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_false,new_l)),(new_l,annot))]] + + | 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 int_of_big_int sz <= vector_split_limit then + let lits = make_vectors (int_of_big_int 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_big_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) -> + let matches = + List.filter (fun ((filename,line),_) -> + Filename.basename p.Lexing.pos_fname = filename && + p.Lexing.pos_lnum <= line && line <= q.Lexing.pos_lnum) ls + in List.map snd matches + in + + let split_pat vars p = + let id_matches = function + | Id_aux (Id x,_) -> List.mem x vars + | Id_aux (DeIid x,_) -> List.mem x vars + in + + let rec list f = function + | [] -> None + | h::t -> + let t' = + match list f t with + | None -> [t,[]] + | Some t' -> t' + in + let h' = + match f h with + | None -> [h,[]] + | Some ps -> ps + in + Some (List.concat (List.map (fun (h,hsubs) -> List.map (fun (t,tsubs) -> (h::t,hsubs@tsubs)) t') h')) + in + let rec spl (P_aux (p,(l,annot))) = + let relist f ctx ps = + optmap (list f ps) + (fun ps -> + List.map (fun (ps,sub) -> P_aux (ctx ps,(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 + match p with + | P_lit _ + | P_wild + | P_var _ + -> None + | P_as (p',id) when id_matches id -> + raise (Reporting_basic.err_general l + ("Cannot split " ^ string_of_id id ^ " 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_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 + | P_cons (p1,p2) -> + match spl p1, spl p2 with + | None, None -> None + | p1', p2' -> + let p1' = match p1' with None -> [p1,[]] | Some p1' -> p1' in + let p2' = match p2' with None -> [p2,[]] | Some p2' -> p2' in + let ps = List.map (fun (p1',subs1) -> List.map (fun (p2',subs2) -> + P_aux (P_cons (p1',p2'),(l,annot)),subs1@subs2) p2') p1' in + Some (List.concat ps) + in spl p + in + + let map_pat_by_loc (P_aux (p,(l,_)) as pat) = + match match_l l with + | [] -> None + | vars -> split_pat vars pat + 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) -> + begin + let kid,kid_annot = + match args with + | [P_aux (P_var (_,kid),ann)] -> kid,ann + | _ -> + raise (Reporting_basic.err_general l + "Pattern match not currently supported by monomorphisation") + in match List.find (fun (id',_) -> Id.compare id id' = 0) refinements with + | (_,variants) -> + let map_inst (insts,id',_) = + let insts = + match insts with [(v,Some i)] -> [(kid,Nexp_aux (Nexp_constant i, Generated l))] + | _ -> assert false + in +(* + let insts,_ = split_insts insts in + let insts = List.map (fun (v,i) -> + (??, + Nexp_aux (Nexp_constant i,Generated l))) + insts in + P_aux (P_app (id',args),(Generated l,tannot)), +*) + P_aux (P_app (id',[P_aux (P_id (id_of_kid kid),kid_annot)]),(Generated l,tannot)), + kbindings_from_list insts + in + ConstrSplit (List.map map_inst variants) + | exception Not_found -> NoSplit + end + | _ -> 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 _ + | E_constraint _ + -> ea + | E_cast (t,e') -> re (E_cast (t, map_exp e')) + | E_app (id,es) -> + let es' = List.map map_exp es in + let env = env_of_annot annot in + begin + match Env.is_union_constructor id env, refine_constructor refinements (fst annot) env id es' with + | true, Some exp -> re exp + | _,_ -> re (E_app (id,es')) + end + | 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_loop (loop,e1,e2) -> re (E_loop (loop,map_exp e1,map_exp e2)) + | E_vector es -> re (E_vector (List.map map_exp es)) + | 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_throw e -> re (E_throw e) + | E_try (e,cases) -> re (E_try (map_exp e, List.concat (List.map map_pexp cases))) + | 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',substs) -> + let exp' = subst_exp substs e in + Pat_aux (Pat_exp (pat', map_exp exp'),l)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + 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',substs) -> + let exp1' = subst_exp substs e1 in + let exp2' = subst_exp substs e2 in + Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + let pat' = nexp_subst_pat nsubst pat' in + let exp1' = nexp_subst_exp nsubst e1 in + let exp2' = nexp_subst_exp nsubst e2 in + 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 (p,e) -> LB_aux (LB_val (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',substs) -> + let exp' = subst_exp substs exp in + FCL_aux (FCL_Funcl (id, pat', map_exp exp'), annot)) + patsubsts + | ConstrSplit patnsubsts -> + List.map (fun (pat',nsubst) -> + 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 _ + | DEF_fixity _ + | DEF_internal_mutrec _ + -> [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' + + + +(* The next section of code turns atom('n) types into itself('n) types, which + survive into the Lem output, so can be used to parametrise functions over + internal bitvector lengths (such as datasize and regsize in ARM specs *) + +module AtomToItself = +struct + +let findi f = + let rec aux n = function + | [] -> None + | h::t -> match f h with Some x -> Some (n,x) | _ -> aux (n+1) t + in aux 0 + +let mapat f is xs = + let rec aux n = function + | _, [] -> [] + | (i,_)::is, h::t when i = n -> + let h' = f h in + let t' = aux (n+1) (is, t) in + h'::t' + | is, h::t -> + let t' = aux (n+1) (is, t) in + h::t' + in aux 0 (is, xs) + +let mapat_extra f is xs = + let rec aux n = function + | _, [] -> [], [] + | (i,v)::is, h::t when i = n -> + let h',x = f v h in + let t',xs = aux (n+1) (is, t) in + h'::t',x::xs + | is, h::t -> + let t',xs = aux (n+1) (is, t) in + h::t',xs + in aux 0 (is, xs) + +let tyvars_bound_in_pat pat = + let open Rewriter in + fst (fold_pat + { (compute_pat_alg KidSet.empty KidSet.union) with + p_var = (fun ((s,pat),kid) -> KidSet.add kid s, P_var (pat,kid)) } + pat) +let tyvars_bound_in_lb (LB_aux (LB_val (pat,_),_)) = tyvars_bound_in_pat pat + +let rec sizes_of_typ (Typ_aux (t,l)) = + match t with + | Typ_id _ + | Typ_var _ + -> KidSet.empty + | Typ_fn _ -> raise (Reporting_basic.err_general l + "Function type on expressinon") + | Typ_tup typs -> kidset_bigunion (List.map sizes_of_typ typs) + | Typ_exist (kids,_,typ) -> + List.fold_left (fun s k -> KidSet.remove k s) (sizes_of_typ typ) kids + | Typ_app (Id_aux (Id "vector",_), + [_;Typ_arg_aux (Typ_arg_nexp size,_); + _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) -> + KidSet.of_list (size_nvars_nexp size) + | Typ_app (_,tas) -> + kidset_bigunion (List.map sizes_of_typarg tas) +and sizes_of_typarg (Typ_arg_aux (ta,_)) = + match ta with + Typ_arg_nexp _ + | Typ_arg_order _ + -> KidSet.empty + | Typ_arg_typ typ -> sizes_of_typ typ + +let sizes_of_annot = function + | _,None -> KidSet.empty + | _,Some (env,typ,_) -> sizes_of_typ (Env.base_typ_of env typ) + +let change_parameter_pat kid = function + | P_aux (P_id var, (l,_)) + | P_aux (P_typ (_,P_aux (P_id var, (l,_))),_) + -> P_aux (P_id var, (l,None)), (var,kid) + | P_aux (_,(l,_)) -> raise (Reporting_basic.err_unreachable l + "Expected variable pattern") + +(* We add code to change the itself('n) parameter into the corresponding + integer. *) +let add_var_rebind exp (var,kid) = + let l = Generated Unknown in + let annot = (l,None) in + E_aux (E_let (LB_aux (LB_val (P_aux (P_id var,annot), + E_aux (E_app (mk_id "size_itself_int",[E_aux (E_id var,annot)]),annot)),annot),exp),annot) + +(* atom('n) arguments to function calls need to be rewritten *) +let replace_with_the_value (E_aux (_,(l,_)) as exp) = + let env = env_of exp in + let typ, wrap = match typ_of exp with + | Typ_aux (Typ_exist (kids,nc,typ),l) -> typ, fun t -> Typ_aux (Typ_exist (kids,nc,t),l) + | typ -> typ, fun x -> x + in + let typ = Env.expand_synonyms env typ in + let mk_exp nexp l l' = + E_aux (E_cast (wrap (Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), + [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated Unknown)), + E_aux (E_app (Id_aux (Id "make_the_value",Generated Unknown),[exp]),(Generated l,None))), + (Generated l,None)) + in + match typ with + | Typ_aux (Typ_app (Id_aux (Id "range",_), + [Typ_arg_aux (Typ_arg_nexp nexp,l');Typ_arg_aux (Typ_arg_nexp nexp',_)]),_) + when nexp_identical nexp nexp' -> + mk_exp nexp l l' + | Typ_aux (Typ_app (Id_aux (Id "atom",_), + [Typ_arg_aux (Typ_arg_nexp nexp,l')]),_) -> + mk_exp nexp l l' + | _ -> raise (Reporting_basic.err_unreachable l + "atom stopped being an atom?") + +let replace_type env typ = + let Typ_aux (t,l) = Env.expand_synonyms env typ in + match t with + | Typ_app (Id_aux (Id "range",_), + [Typ_arg_aux (Typ_arg_nexp nexp,l');Typ_arg_aux (Typ_arg_nexp _,_)]) -> + Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), + [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated l) + | Typ_app (Id_aux (Id "atom",_), + [Typ_arg_aux (Typ_arg_nexp nexp,l')]) -> + Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown), + [Typ_arg_aux (Typ_arg_nexp nexp,l')]),Generated l) + | _ -> raise (Reporting_basic.err_unreachable l + "atom stopped being an atom?") + + +let rewrite_size_parameters env (Defs defs) = + let open Rewriter in + let size_vars exp = + fst (fold_exp + { (compute_exp_alg KidSet.empty KidSet.union) with + e_aux = (fun ((s,e),annot) -> KidSet.union s (sizes_of_annot annot), E_aux (e,annot)); + e_let = (fun ((sl,lb),(s2,e2)) -> KidSet.union sl (KidSet.diff s2 (tyvars_bound_in_lb lb)), E_let (lb,e2)); + pat_exp = (fun ((sp,pat),(s,e)) -> KidSet.diff s (tyvars_bound_in_pat pat), Pat_exp (pat,e))} + exp) + in + let sizes_funcl fsizes (FCL_aux (FCL_Funcl (id,pat,exp),(l,_))) = + let sizes = size_vars exp in + (* TODO: what, if anything, should sequential be? *) + let visible_tyvars = + KidSet.union (Pretty_print_lem.lem_tyvars_of_typ false true (pat_typ_of pat)) + (Pretty_print_lem.lem_tyvars_of_typ false true (typ_of exp)) + in + let expose_tyvars = KidSet.diff sizes visible_tyvars in + let parameters = match pat with + | P_aux (P_tup ps,_) -> ps + | _ -> [pat] + in + let to_change = List.map + (fun kid -> + let check (P_aux (_,(_,Some (env,typ,_)))) = + match Env.expand_synonyms env typ with + Typ_aux (Typ_app(Id_aux (Id "range",_), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_); + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_) -> + if Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 then Some kid else None + | Typ_aux (Typ_app(Id_aux (Id "atom", _), + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid',_)),_)]), _) -> + if Kid.compare kid kid' = 0 then Some kid else None + | _ -> None + in match findi check parameters with + | None -> raise (Reporting_basic.err_general l + ("Unable to find an argument for " ^ string_of_kid kid)) + | Some i -> i) + (KidSet.elements expose_tyvars) + in + let ik_compare (i,k) (i',k') = + match compare (i : int) i' with + | 0 -> Kid.compare k k' + | x -> x + in + let to_change = List.sort ik_compare to_change in + match Bindings.find id fsizes with + | old -> if List.for_all2 (fun x y -> ik_compare x y = 0) old to_change then fsizes else + raise (Reporting_basic.err_general l + ("Different size type variables in different clauses of " ^ string_of_id id)) + | exception Not_found -> Bindings.add id to_change fsizes + in + let sizes_def fsizes = function + | DEF_fundef (FD_aux (FD_function (_,_,_,funcls),_)) -> + List.fold_left sizes_funcl fsizes funcls + | _ -> fsizes + in + let fn_sizes = List.fold_left sizes_def Bindings.empty defs in + + let rewrite_e_app (id,args) = + match Bindings.find id fn_sizes with + | [] -> E_app (id,args) + | to_change -> + let args' = mapat replace_with_the_value to_change args in + E_app (id,args') + | exception Not_found -> E_app (id,args) + in + let rewrite_funcl (FCL_aux (FCL_Funcl (id,pat,body),(l,annot))) = + let pat,body = + (* Update pattern and add itself -> nat wrapper to body *) + match Bindings.find id fn_sizes with + | [] -> pat,body + | to_change -> + let pat, vars = + match pat with + P_aux (P_tup pats,(l,_)) -> + let pats, vars = mapat_extra change_parameter_pat to_change pats in + P_aux (P_tup pats,(l,None)), vars + | P_aux (_,(l,_)) -> + begin + match to_change with + | [0,kid] -> + let pat, var = change_parameter_pat kid pat in + pat, [var] + | _ -> + raise (Reporting_basic.err_unreachable l + "Expected multiple parameters at single parameter") + end + in + let body = List.fold_left add_var_rebind body vars in + pat,body + | exception Not_found -> pat,body + in + (* Update function applications *) + let body = fold_exp { id_exp_alg with e_app = rewrite_e_app } body in + FCL_aux (FCL_Funcl (id,pat,body),(l,None)) + in + let rewrite_def = function + | DEF_fundef (FD_aux (FD_function (recopt,tannopt,effopt,funcls),(l,_))) -> + (* TODO rewrite tannopt? *) + DEF_fundef (FD_aux (FD_function (recopt,tannopt,effopt,List.map rewrite_funcl funcls),(l,None))) + | DEF_spec (VS_aux (VS_val_spec (typschm,id,extern,cast),(l,annot))) as spec -> + begin + match Bindings.find id fn_sizes with + | [] -> spec + | to_change -> + let typschm = match typschm with + | TypSchm_aux (TypSchm_ts (tq,typ),l) -> + let typ = match typ with + | Typ_aux (Typ_fn (Typ_aux (Typ_tup ts,l),t2,eff),l2) -> + Typ_aux (Typ_fn (Typ_aux (Typ_tup (mapat (replace_type env) to_change ts),l),t2,eff),l2) + | _ -> replace_type env typ + in TypSchm_aux (TypSchm_ts (tq,typ),l) + in + DEF_spec (VS_aux (VS_val_spec (typschm,id,extern,cast),(l,None))) + | exception Not_found -> spec + end + | def -> def + in +(* + Bindings.iter (fun id args -> + print_endline (string_of_id id ^ " needs " ^ + String.concat ", " (List.map string_of_int args))) fn_sizes +*) + Defs (List.map rewrite_def defs) + +end + + +module Analysis = +struct + +type loc = string * int (* filename, line *) + +let string_of_loc (s,l) = s ^ "." ^ string_of_int l + +let id_pair_compare (id,l) (id',l') = + match Id.compare id id' with + | 0 -> compare l l' + | x -> x + +(* Arguments that we might split on *) +module ArgSet = Set.Make (struct + type t = id * loc + let compare = id_pair_compare +end) + +(* Arguments that we should look at in callers *) +module CallerArgSet = Set.Make (struct + type t = id * int + let compare = id_pair_compare +end) + +(* Type variables that we should look at in callers *) +module CallerKidSet = Set.Make (struct + type t = id * kid + let compare (id,kid) (id',kid') = + match Id.compare id id' with + | 0 -> Kid.compare kid kid' + | x -> x +end) + +module FailureSet = Set.Make (struct + type t = Parse_ast.l * string + let compare = compare +end) + +type dependencies = + | Have of ArgSet.t * CallerArgSet.t * CallerKidSet.t + (* args to split inside fn * caller args to split * caller kids that are bitvector parameters *) + | Unknown of Parse_ast.l * string + +let string_of_argset s = + String.concat ", " (List.map (fun (id,l) -> string_of_id id ^ "." ^ string_of_loc l) + (ArgSet.elements s)) + +let string_of_callerset s = + String.concat ", " (List.map (fun (id,arg) -> string_of_id id ^ "." ^ string_of_int arg) + (CallerArgSet.elements s)) + +let string_of_callerkidset s = + String.concat ", " (List.map (fun (id,kid) -> string_of_id id ^ "." ^ string_of_kid kid) + (CallerKidSet.elements s)) + +let string_of_dep = function + | Have (argset,callset,kidset) -> + "Have (" ^ string_of_argset argset ^ "; " ^ string_of_callerset callset ^ "; " ^ + string_of_callerkidset kidset ^ ")" + | Unknown (l,msg) -> "Unknown " ^ msg ^ " at " ^ Reporting_basic.loc_to_string l + +(* Result of analysing the body of a function. The split field gives + the arguments to split based on the body alone, and the failures + field where we couldn't do anything. The other fields are used at + the end for the interprocedural phase. *) + +type result = { + split : ArgSet.t; + failures : FailureSet.t; + (* Dependencies for arguments and type variables of each fn called, so that + if the fn uses one for a bitvector size we can track it back *) + split_on_call : (dependencies list * dependencies KBindings.t) Bindings.t; (* (arguments, kids) per fn *) + split_in_caller : CallerArgSet.t; + kid_in_caller : CallerKidSet.t +} + +let empty = { + split = ArgSet.empty; + failures = FailureSet.empty; + split_on_call = Bindings.empty; + split_in_caller = CallerArgSet.empty; + kid_in_caller = CallerKidSet.empty +} + +let dmerge x y = + match x,y with + | Unknown (l,s), _ -> Unknown (l,s) + | _, Unknown (l,s) -> Unknown (l,s) + | Have (a,c,k), Have (a',c',k') -> + Have (ArgSet.union a a', CallerArgSet.union c c', CallerKidSet.union k k') + +let dempty = Have (ArgSet.empty, CallerArgSet.empty, CallerKidSet.empty) + +let dopt_merge k x y = + match x, y with + | None, _ -> y + | _, None -> x + | Some x, Some y -> Some (dmerge x y) + +let dep_bindings_merge a1 a2 = + Bindings.merge dopt_merge a1 a2 + +let dep_kbindings_merge a1 a2 = + KBindings.merge dopt_merge a1 a2 + +let call_kid_merge k x y = + match x, y with + | None, x -> x + | x, None -> x + | Some d, Some d' -> Some (dmerge d d') + +let call_arg_merge k args args' = + match args, args' with + | None, x -> x + | x, None -> x + | Some (args,kdep), Some (args',kdep') + -> Some (List.map2 dmerge args args', KBindings.merge call_kid_merge kdep kdep') + +let merge rs rs' = { + split = ArgSet.union rs.split rs'.split; + failures = FailureSet.union rs.failures rs'.failures; + split_on_call = Bindings.merge call_arg_merge rs.split_on_call rs'.split_on_call; + split_in_caller = CallerArgSet.union rs.split_in_caller rs'.split_in_caller; + kid_in_caller = CallerKidSet.union rs.kid_in_caller rs'.kid_in_caller +} + +type env = { + var_deps : dependencies Bindings.t; + kid_deps : dependencies KBindings.t; + control_deps : dependencies +} + +let rec split3 = function + | [] -> [],[],[] + | ((h1,h2,h3)::t) -> + let t1,t2,t3 = split3 t in + (h1::t1,h2::t2,h3::t3) + +let kids_bound_by_pat pat = + let open Rewriter in + fst (fold_pat ({ (compute_pat_alg KidSet.empty KidSet.union) + with p_var = (fun ((s,p),kid) -> (KidSet.add kid s, P_var (p,kid))) }) pat) + +let update_env env deps pat = + let bound = bindings_from_pat pat in + let var_deps = List.fold_left (fun ds v -> Bindings.add v deps ds) env.var_deps bound in + let kbound = kids_bound_by_pat pat in + let kid_deps = KidSet.fold (fun v ds -> KBindings.add v deps ds) kbound env.kid_deps in + { env with var_deps = var_deps; kid_deps = kid_deps } + +(* Functions to give dependencies for type variables in nexps, constraints, types and + unification variables. For function calls we also supply a list of dependencies for + arguments so that we can find dependencies for existentially bound sizes. *) + +let deps_of_tyvars kid_deps arg_deps kids = + let check kid deps = + match KBindings.find kid kid_deps with + | deps' -> dmerge deps deps' + | exception Not_found -> + match kid with + | Kid_aux (Var kidstr, l) -> + let unknown = Unknown (l, "Unknown type variable " ^ string_of_kid kid) in + (* Tyvars from existentials in arguments have a special format *) + if String.length kidstr > 5 && String.sub kidstr 0 4 = "'arg" then + try + let i = String.index kidstr '#' in + let n = String.sub kidstr 4 (i-4) in + let arg = int_of_string n in + List.nth arg_deps arg + with Not_found | Failure _ -> unknown + else unknown + in + KidSet.fold check kids dempty + +let deps_of_nexp kid_deps arg_deps nexp = + let kids = nexp_frees nexp in + deps_of_tyvars kid_deps arg_deps kids + +let rec deps_of_nc kid_deps (NC_aux (nc,l)) = + match nc with + | NC_equal (nexp1,nexp2) + | NC_bounded_ge (nexp1,nexp2) + | NC_bounded_le (nexp1,nexp2) + | NC_not_equal (nexp1,nexp2) + -> dmerge (deps_of_nexp kid_deps [] nexp1) (deps_of_nexp kid_deps [] nexp2) + | NC_set (kid,_) -> + (match KBindings.find kid kid_deps with + | deps -> deps + | exception Not_found -> Unknown (l, "Unknown type variable " ^ string_of_kid kid)) + | NC_or (nc1,nc2) + | NC_and (nc1,nc2) + -> dmerge (deps_of_nc kid_deps nc1) (deps_of_nc kid_deps nc2) + | NC_true + | NC_false + -> dempty + +let deps_of_typ kid_deps arg_deps typ = + deps_of_tyvars kid_deps arg_deps (tyvars_of_typ typ) + +let deps_of_uvar kid_deps arg_deps = function + | U_nexp nexp -> deps_of_nexp kid_deps arg_deps nexp + | U_order _ + | U_effect _ -> dempty + | U_typ typ -> deps_of_typ kid_deps arg_deps typ + +(* Takes an environment of dependencies on vars, type vars, and flow control, + and dependencies on mutable variables. The latter are quite conservative, + we currently drop variables assigned inside loops, for example. *) + +let rec analyse_exp fn_id env assigns (E_aux (e,(l,annot)) as exp) = + let remove_assigns es message = + let assigned = + List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp)) + IdSet.empty es in + IdSet.fold + (fun id asn -> + Bindings.add id (Unknown (l, string_of_id id ^ message)) asn) + assigned assigns + in + let non_det es = + let assigns = remove_assigns es " assigned in non-deterministic expressions" in + let deps, _, rs = split3 (List.map (analyse_exp fn_id env assigns) es) in + (deps, assigns, List.fold_left merge empty rs) + in + let merge_deps deps = + List.fold_left dmerge env.control_deps deps in + let deps, assigns, r = + match e with + | E_block es -> + let rec aux assigns = function + | [] -> (dempty, assigns, empty) + | [e] -> analyse_exp fn_id env assigns e + | e::es -> + let _, assigns, r' = analyse_exp fn_id env assigns e in + let d, assigns, r = aux assigns es in + d, assigns, merge r r' + in + aux assigns es + | E_nondet es -> + let _, assigns, r = non_det es in + (dempty, assigns, r) + | E_id id -> + begin + match Bindings.find id env.var_deps with + | args -> (dmerge env.control_deps args,assigns,empty) + | exception Not_found -> + match Bindings.find id assigns with + | args -> (dmerge env.control_deps args,assigns,empty) + | exception Not_found -> + match Env.lookup_id id (Type_check.env_of_annot (l,annot)) with + | Enum _ | Union _ -> env.control_deps,assigns,empty + | Register _ -> Unknown (l, string_of_id id ^ " is a register"),assigns,empty + | _ -> + Unknown (l, string_of_id id ^ " is not in the environment"),assigns,empty + end + | E_lit _ -> (env.control_deps,assigns,empty) + | E_cast (_,e) -> analyse_exp fn_id env assigns e + | E_app (id,args) -> + let deps, assigns, r = non_det args in + let kid_inst = instantiation_of exp in + (* Change kids in instantiation to the canonical ones from the type signature *) + let kid_inst = KBindings.fold (fun kid -> KBindings.add (orig_kid kid)) kid_inst KBindings.empty in + let kid_deps = KBindings.map (deps_of_uvar env.kid_deps deps) kid_inst in + let r' = + if Id.compare fn_id id == 0 then + let bad = Unknown (l,"Recursive call of " ^ string_of_id id) in + let deps = List.map (fun _ -> bad) deps in + let kid_deps = KBindings.map (fun _ -> bad) kid_deps in + { empty with split_on_call = Bindings.singleton id (deps, kid_deps) } + else + { empty with split_on_call = Bindings.singleton id (deps, kid_deps) } in + (merge_deps deps, assigns, merge r r') + | E_tuple es + | E_list es -> + let deps, assigns, r = non_det es in + (merge_deps deps, assigns, r) + | E_if (e1,e2,e3) -> + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let env' = { env with control_deps = dmerge env.control_deps d1 } in + let d2,a2,r2 = analyse_exp fn_id env' assigns e2 in + let d3,a3,r3 = analyse_exp fn_id env' assigns e3 in + (dmerge d2 d3, dep_bindings_merge a2 a3, merge r1 (merge r2 r3)) + | E_loop (_,e1,e2) -> + let assigns = remove_assigns [e1;e2] " assigned in a loop" in + let d1,a1,r1 = analyse_exp fn_id env assigns e1 in + let env' = { env with control_deps = dmerge env.control_deps d1 } in + let d2,a2,r2 = analyse_exp fn_id env' assigns e2 in + (dempty, assigns, merge r1 r2) + | E_for (var,efrom,eto,eby,ord,body) -> + let d1,assigns,r1 = non_det [efrom;eto;eby] in + let assigns = remove_assigns [body] " assigned in a loop" in + let d = dmerge env.control_deps (merge_deps d1) in + let loop_kid = mk_kid ("loop_" ^ string_of_id var) in + let env' = { env with + control_deps = d; + kid_deps = KBindings.add loop_kid d env.kid_deps} in + let d2,a2,r2 = analyse_exp fn_id env' assigns body in + (dempty, assigns, merge r1 r2) + | E_vector es -> + let ds, assigns, r = non_det es in + (merge_deps ds, assigns, r) + | E_vector_access (e1,e2) + | E_vector_append (e1,e2) + | E_cons (e1,e2) -> + let ds, assigns, r = non_det [e1;e2] in + (merge_deps ds, assigns, r) + | E_vector_subrange (e1,e2,e3) + | E_vector_update (e1,e2,e3) -> + let ds, assigns, r = non_det [e1;e2;e3] in + (merge_deps ds, assigns, r) + | E_vector_update_subrange (e1,e2,e3,e4) -> + let ds, assigns, r = non_det [e1;e2;e3;e4] in + (merge_deps ds, assigns, r) + | E_record (FES_aux (FES_Fexps (fexps,_),_)) -> + let es = List.map (function (FE_aux (FE_Fexp (_,e),_)) -> e) fexps in + let ds, assigns, r = non_det es in + (merge_deps ds, assigns, r) + | E_record_update (e,FES_aux (FES_Fexps (fexps,_),_)) -> + let es = List.map (function (FE_aux (FE_Fexp (_,e),_)) -> e) fexps in + let ds, assigns, r = non_det (e::es) in + (merge_deps ds, assigns, r) + | E_field (e,_) -> analyse_exp fn_id env assigns e + | E_case (e,cases) -> + let deps,assigns,r = analyse_exp fn_id env assigns e in + let analyse_case (Pat_aux (pexp,_)) = + match pexp with + | Pat_exp (pat,e1) -> + let env = update_env env deps pat in + analyse_exp fn_id env assigns e1 + | Pat_when (pat,e1,e2) -> + let env = update_env env deps pat in + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let d2,assigns,r2 = analyse_exp fn_id env assigns e2 in + (dmerge d1 d2, assigns, merge r1 r2) + in + let ds,assigns,rs = split3 (List.map analyse_case cases) in + (merge_deps (deps::ds), + List.fold_left dep_bindings_merge Bindings.empty assigns, + List.fold_left merge r rs) + | E_let (LB_aux (LB_val (pat,e1),_),e2) -> + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let env = update_env env d1 pat in + let d2,assigns,r2 = analyse_exp fn_id env assigns e2 in + (d2,assigns,merge r1 r2) + | E_assign (lexp,e1) -> + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let assigns,r2 = analyse_lexp fn_id env assigns d1 lexp in + (dempty, assigns, merge r1 r2) + | E_sizeof nexp -> + (deps_of_nexp env.kid_deps [] nexp, assigns, empty) + | E_return e + | E_exit e + | E_throw e -> + let _, _, r = analyse_exp fn_id env assigns e in + (Unknown (l,"non-local flow"), Bindings.empty, r) + | E_try (e,cases) -> + let deps,_,r = analyse_exp fn_id env assigns e in + let assigns = remove_assigns [e] " assigned in try expression" in + let analyse_handler (Pat_aux (pexp,_)) = + match pexp with + | Pat_exp (pat,e1) -> + let env = update_env env (Unknown (l,"Exception")) pat in + analyse_exp fn_id env assigns e1 + | Pat_when (pat,e1,e2) -> + let env = update_env env (Unknown (l,"Exception")) pat in + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let d2,assigns,r2 = analyse_exp fn_id env assigns e2 in + (dmerge d1 d2, assigns, merge r1 r2) + in + let ds,assigns,rs = split3 (List.map analyse_handler cases) in + (merge_deps (deps::ds), + List.fold_left dep_bindings_merge Bindings.empty assigns, + List.fold_left merge r rs) + | E_assert (e1,_) -> analyse_exp fn_id env assigns e1 + + | E_app_infix _ + | E_internal_cast _ + | E_internal_exp _ + | E_sizeof_internal _ + | E_internal_exp_user _ + | E_comment _ + | E_comment_struc _ + | E_internal_plet _ + | E_internal_return _ + -> raise (Reporting_basic.err_unreachable l + ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp)) + + | E_internal_let (lexp,e1,e2) -> + (* Really we ought to remove the assignment after e2 *) + let d1,assigns,r1 = analyse_exp fn_id env assigns e1 in + let assigns,r' = analyse_lexp fn_id env assigns d1 lexp in + let d2,assigns,r2 = analyse_exp fn_id env assigns e2 in + (dempty, assigns, merge r1 (merge r' r2)) + | E_constraint nc -> + (deps_of_nc env.kid_deps nc, assigns, empty) + in + let r = + (* Check for bitvector types with parametrised sizes *) + match annot with + | None -> r + | Some (tenv,typ,_) -> + (* TODO: existential wrappers *) + let typ = Env.expand_synonyms tenv typ in + if is_bitvector_typ typ then + let _,size,_,_ = vector_typ_args_of typ in + match deps_of_nexp env.kid_deps [] size with + | Have (args,caller,caller_kids) -> + { r with + split = ArgSet.union r.split args; + split_in_caller = CallerArgSet.union r.split_in_caller caller; + kid_in_caller = CallerKidSet.union r.kid_in_caller caller_kids + } + | Unknown (l,msg) -> + { r with + failures = + FailureSet.add (l,"Unable to monomorphise " ^ string_of_nexp size ^ ": " ^ msg) + r.failures } + else + r + in (deps, assigns, r) + + +and analyse_lexp fn_id env assigns deps (LEXP_aux (lexp,_)) = + (* TODO: maybe subexps and sublexps should be non-det (and in const_prop_lexp, too?) *) + match lexp with + | LEXP_id id + | LEXP_cast (_,id) -> + Bindings.add id deps assigns, empty + | LEXP_memory (id,es) -> + let _, assigns, r = analyse_exp fn_id env assigns (E_aux (E_tuple es,(Unknown,None))) in + assigns, r + | LEXP_tup lexps -> + List.fold_left (fun (assigns,r) lexp -> + let assigns,r' = analyse_lexp fn_id env assigns deps lexp + in assigns,merge r r') (assigns,empty) lexps + | LEXP_vector (lexp,e) -> + let _, assigns, r1 = analyse_exp fn_id env assigns e in + let assigns, r2 = analyse_lexp fn_id env assigns deps lexp in + assigns, merge r1 r2 + | LEXP_vector_range (lexp,e1,e2) -> + let _, assigns, r1 = analyse_exp fn_id env assigns e1 in + let _, assigns, r2 = analyse_exp fn_id env assigns e2 in + let assigns, r3 = analyse_lexp fn_id env assigns deps lexp in + assigns, merge r3 (merge r1 r2) + | LEXP_field (lexp,_) -> analyse_lexp fn_id env assigns deps lexp + + +let translate_id (Id_aux (_,l) as id) = + let rec aux l = + match l with + | Range (pos,_) -> id,(pos.Lexing.pos_fname,pos.Lexing.pos_lnum) + | Generated l -> aux l + | _ -> + raise (Reporting_basic.err_general l ("Unable to give location for " ^ string_of_id id)) + in aux l + +let initial_env fn_id (TypQ_aux (tq,_)) pat = + let pats = + match pat with + | P_aux (P_tup pats,_) -> pats + | _ -> [pat] + in + let arg i pat = + let rec aux (P_aux (p,(l,_))) = + let of_list pats = + let ss,vs,ks = split3 (List.map aux pats) in + let s = List.fold_left ArgSet.union ArgSet.empty ss in + let v = List.fold_left dep_bindings_merge Bindings.empty vs in + let k = List.fold_left dep_kbindings_merge KBindings.empty ks in + s,v,k + in + match p with + | P_lit _ + | P_wild + -> ArgSet.empty,Bindings.empty,KBindings.empty + | P_as (pat,id) -> + let s,v,k = aux pat in + let id' = translate_id id in + ArgSet.add id' s, Bindings.add id (Have (ArgSet.singleton id',CallerArgSet.empty,CallerKidSet.empty)) v,k + | P_typ (_,pat) -> aux pat + | P_id id -> + let id' = translate_id id in + let s = ArgSet.singleton id' in + s, Bindings.singleton id (Have (s,CallerArgSet.empty,CallerKidSet.empty)), KBindings.empty + | P_var (pat,kid) -> + let s,v,k = aux pat in + s,v,KBindings.add kid (Have (ArgSet.empty,CallerArgSet.singleton (fn_id,i),CallerKidSet.empty)) k + | P_app (_,pats) -> of_list pats + | P_record (fpats,_) -> of_list (List.map (fun (FP_aux (FP_Fpat (_,p),_)) -> p) fpats) + | P_vector pats + | P_vector_concat pats + | P_tup pats + | P_list pats + -> of_list pats + | P_cons (p1,p2) -> of_list [p1;p2] + in aux pat + in + let quant k = function + | QI_aux (QI_id (KOpt_aux ((KOpt_none kid | KOpt_kind (_,kid)),_)),_) -> + KBindings.add kid (Have (ArgSet.empty,CallerArgSet.empty,CallerKidSet.singleton (fn_id,kid))) k + | QI_aux (QI_const _,_) -> k + in + let kid_quant_deps = + match tq with + | TypQ_no_forall -> KBindings.empty + | TypQ_tq qs -> List.fold_left quant KBindings.empty qs + in + let _,var_deps,kid_deps = split3 (List.mapi arg pats) in + let var_deps = List.fold_left dep_bindings_merge Bindings.empty var_deps in + let kid_deps = List.fold_left dep_kbindings_merge kid_quant_deps kid_deps in + { var_deps = var_deps; kid_deps = kid_deps; control_deps = dempty } + +let print_result r = + let _ = print_endline (" splits: " ^ string_of_argset r.split) in + let print_kbinding kid dep = + let _ = print_endline (" " ^ string_of_kid kid ^ ": " ^ string_of_dep dep) in + () + in + let print_binding id (deps,kdep) = + let _ = print_endline (" " ^ string_of_id id ^ ":") in + let _ = List.iter (fun dep -> print_endline (" " ^ string_of_dep dep)) deps in + let _ = KBindings.iter print_kbinding kdep in + () + in + let _ = print_endline " split_on_call: " in + let _ = Bindings.iter print_binding r.split_on_call in + let _ = print_endline (" split_in_caller: " ^ string_of_callerset r.split_in_caller) in + let _ = print_endline (" kid_in_caller: " ^ string_of_callerkidset r.kid_in_caller) in + () + +let analyse_funcl debug tenv (FCL_aux (FCL_Funcl (id,pat,body),_)) = + let (tq,_) = Env.get_val_spec id tenv in + let aenv = initial_env id tq pat in + let _,_,r = analyse_exp id aenv Bindings.empty body in + let _ = + if debug > 2 then + (print_endline (string_of_id id); + print_result r) + else () + in r + +let analyse_def debug env = function + | DEF_fundef (FD_aux (FD_function (_,_,_,funcls),_)) -> + List.fold_left (fun r f -> merge r (analyse_funcl debug env f)) empty funcls + + | _ -> empty + +let analyse_defs debug env (Defs defs) = + let r = List.fold_left (fun r d -> merge r (analyse_def debug env d)) empty defs in + + (* Resolve the interprocedural dependencies *) + + let rec chase_deps = function + | Have (splits, caller_args, caller_kids) -> + let splits,fails = CallerArgSet.fold add_arg caller_args (splits,FailureSet.empty) in + let splits,fails = CallerKidSet.fold add_kid caller_kids (splits,fails) in + splits, fails + | Unknown (l,msg) -> + ArgSet.empty , FailureSet.singleton (l,("Unable to monomorphise dependency: " ^ msg)) + and chase_kid_caller (id,kid) = + match Bindings.find id r.split_on_call with + | (_,kid_deps) -> begin + match KBindings.find kid kid_deps with + | deps -> chase_deps deps + | exception Not_found -> ArgSet.empty,FailureSet.empty + end + | exception Not_found -> ArgSet.empty,FailureSet.empty + and chase_arg_caller (id,i) = + match Bindings.find id r.split_on_call with + | (arg_deps,_) -> chase_deps (List.nth arg_deps i) + | exception Not_found -> ArgSet.empty,FailureSet.empty + and add_arg arg (splits,fails) = + let splits',fails' = chase_arg_caller arg in + ArgSet.union splits splits', FailureSet.union fails fails' + and add_kid k (splits,fails) = + let splits',fails' = chase_kid_caller k in + ArgSet.union splits splits', FailureSet.union fails fails' + in + let _ = if debug > 1 then print_result r else () in + let splits,fails = CallerArgSet.fold add_arg r.split_in_caller (r.split,r.failures) in + let splits,fails = CallerKidSet.fold add_kid r.kid_in_caller (splits,fails) in + let _ = + if debug > 0 then + (print_endline "Final splits:"; + print_endline (string_of_argset splits)) + else () + in + let _ = + if FailureSet.is_empty fails then () else + begin + FailureSet.iter (fun (l,msg) -> Reporting_basic.print_err false false l "Monomorphisation" msg) + fails; + raise (Reporting_basic.err_general Unknown "Unable to monomorphise program") + end + in splits + +let argset_to_list splits = + let l = ArgSet.elements splits in + let argelt (id,(file,loc)) = ((file,loc),string_of_id id) in + List.map argelt l +end + + +let monomorphise mwords auto debug_analysis splits env defs = + let new_splits = + if auto + then Analysis.argset_to_list (Analysis.analyse_defs debug_analysis env defs) + else [] in + let defs = split_defs (new_splits@splits) defs in + (* TODO: currently doing this because constant propagation leaves numeric literals as + int, try to avoid this later; also use final env for DEF_spec case above, because the + type checker doesn't store the env at that point :( *) + if mwords then + let (defs,env) = Type_check.check (Type_check.Env.no_casts Type_check.initial_env) defs in + let defs = AtomToItself.rewrite_size_parameters env defs in + defs + else + defs diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index 765553d3..697ee9bd 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -101,5 +101,11 @@ dispatch begin function mv (basename (env "%.lem")) (dirname (env "%.lem")) ]); + rule "old parser" + ~insert:(`top) + ~prods: ["parser.ml"; "parser.mli"] + ~dep: "parser.mly" + (fun env builder -> Cmd(S[V"OCAMLYACC"; T(tags_of_pathname "parser.mly"++"ocaml"++"parser"++"ocamlyacc"); Px "parser.mly"])); + | _ -> () end ;; diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml new file mode 100644 index 00000000..333505e0 --- /dev/null +++ b/src/ocaml_backend.ml @@ -0,0 +1,588 @@ +open Ast +open Ast_util +open PPrint +open Type_check + +(* Option to turn tracing features on or off *) +let opt_trace_ocaml = ref false + +type ctx = + { register_inits : tannot exp list; + externs : id Bindings.t; + val_specs : typ Bindings.t + } + +let empty_ctx = + { register_inits = []; + externs = Bindings.empty; + val_specs = Bindings.empty + } + +let gensym_counter = ref 0 + +let gensym () = + let gs = "gs" ^ string_of_int !gensym_counter in + incr gensym_counter; + string gs + +let zchar c = + let zc c = "z" ^ String.make 1 c in + if Char.code c <= 41 then zc (Char.chr (Char.code c + 16)) + else if Char.code c <= 47 then zc (Char.chr (Char.code c + 23)) + else if Char.code c <= 57 then String.make 1 c + else if Char.code c <= 64 then zc (Char.chr (Char.code c + 13)) + else if Char.code c <= 90 then String.make 1 c + else if Char.code c <= 94 then zc (Char.chr (Char.code c - 13)) + else if Char.code c <= 95 then "_" + else if Char.code c <= 96 then zc (Char.chr (Char.code c - 13)) + else if Char.code c <= 121 then String.make 1 c + else if Char.code c <= 122 then "zz" + else if Char.code c <= 126 then zc (Char.chr (Char.code c - 39)) + else raise (Invalid_argument "zchar") + +let zencode_string str = "z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.map zchar (Util.string_to_list str)) + +let zencode_upper_string str = "Z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.map zchar (Util.string_to_list str)) + +let zencode ctx id = + try string (string_of_id (Bindings.find id ctx.externs)) with + | Not_found -> string (zencode_string (string_of_id id)) + +let zencode_upper ctx id = + try string (string_of_id (Bindings.find id ctx.externs)) with + | Not_found -> string (zencode_upper_string (string_of_id id)) + +let zencode_kid kid = string ("'" ^ zencode_string (string_of_id (id_of_kid kid))) + +let ocaml_string_of id = string ("string_of_" ^ zencode_string (string_of_id id)) + +let ocaml_string_parens inside = string "\"(\" ^ " ^^ inside ^^ string " ^ \")\"" + +let ocaml_string_comma = string " ^ \", \" ^ " + +let rec ocaml_string_typ (Typ_aux (typ_aux, _)) arg = + match typ_aux with + | Typ_id id -> ocaml_string_of id ^^ space ^^ arg + | Typ_app (id, []) -> ocaml_string_of id ^^ space ^^ arg + | Typ_app (id, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id eid, _)), _)]) + when string_of_id id = "list" && string_of_id eid = "bit" -> + string "string_of_bits" ^^ space ^^ arg + | Typ_app (id, [Typ_arg_aux (Typ_arg_typ typ, _)]) when string_of_id id = "list" -> + let farg = gensym () in + separate space [string "string_of_list \", \""; parens (separate space [string "fun"; farg; string "->"; ocaml_string_typ typ farg]); arg] + | Typ_app (_, _) -> string "\"APP\"" + | Typ_tup typs -> + let args = List.map (fun _ -> gensym ()) typs in + let body = + ocaml_string_parens (separate_map ocaml_string_comma (fun (typ, arg) -> ocaml_string_typ typ arg) (List.combine typs args)) + in + parens (separate space [string "fun"; parens (separate (comma ^^ space) args); string "->"; body]) + ^^ space ^^ arg + | Typ_fn (typ1, typ2, _) -> string "\"FN\"" + | Typ_var kid -> string "\"VAR\"" + | Typ_exist _ -> assert false + +let ocaml_typ_id ctx = function + | id when Id.compare id (mk_id "string") = 0 -> string "string" + | id when Id.compare id (mk_id "list") = 0 -> string "list" + | id when Id.compare id (mk_id "bit") = 0 -> string "bit" + | id when Id.compare id (mk_id "int") = 0 -> string "big_int" + | id when Id.compare id (mk_id "nat") = 0 -> string "big_int" + | id when Id.compare id (mk_id "bool") = 0 -> string "bool" + | id when Id.compare id (mk_id "unit") = 0 -> string "unit" + | id when Id.compare id (mk_id "real") = 0 -> string "Num.num" + | id when Id.compare id (mk_id "register") = 0 -> string "ref" + | id -> zencode ctx id + +let rec ocaml_typ ctx (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_id id -> ocaml_typ_id ctx id + | Typ_app (id, []) -> ocaml_typ_id ctx id + | Typ_app (id, typs) -> parens (separate_map (string " * ") (ocaml_typ_arg ctx) typs) ^^ space ^^ ocaml_typ_id ctx id + | Typ_tup typs -> parens (separate_map (string " * ") (ocaml_typ ctx) typs) + | Typ_fn (typ1, typ2, _) -> separate space [ocaml_typ ctx typ1; string "->"; ocaml_typ ctx typ2] + | Typ_var kid -> zencode_kid kid + | Typ_exist _ -> assert false +and ocaml_typ_arg ctx (Typ_arg_aux (typ_arg_aux, _) as typ_arg) = + match typ_arg_aux with + | Typ_arg_typ typ -> ocaml_typ ctx typ + | _ -> failwith ("OCaml: unexpected type argument " ^ string_of_typ_arg typ_arg) + +let ocaml_typquant typq = + let ocaml_qi = function + | QI_aux (QI_id kopt, _) -> zencode_kid (kopt_kid kopt) + | QI_aux (QI_const _, _) -> failwith "Ocaml type quantifiers should no longer contain constraints" + in + match quant_items typq with + | [] -> empty + | [qi] -> ocaml_qi qi + | qis -> parens (separate_map (string " * ") ocaml_qi qis) + +let string_lit str = dquotes (string (String.escaped str)) + +let ocaml_lit (L_aux (lit_aux, _)) = + match lit_aux with + | L_unit -> string "()" + | L_zero -> string "B0" + | L_one -> string "B1" + | L_true -> string "true" + | L_false -> string "false" + | L_num n -> parens (string "big_int_of_string" ^^ space ^^ string ("\"" ^ Big_int.string_of_big_int n ^ "\"")) + | L_undef -> failwith "undefined should have been re-written prior to ocaml backend" + | L_string str -> string_lit str + | L_real str -> parens (string "real_of_string" ^^ space ^^ dquotes (string (String.escaped str))) + | _ -> string "LIT" + +let rec ocaml_pat ctx (P_aux (pat_aux, _) as pat) = + match pat_aux with + | P_id id -> + begin + match Env.lookup_id id (pat_env_of pat) with + | Local (Immutable, _) | Unbound -> zencode ctx id + | Enum _ -> zencode_upper ctx id + | _ -> failwith "Ocaml: Cannot pattern match on mutable variable or register" + end + | P_lit lit -> ocaml_lit lit + | P_typ (_, pat) -> ocaml_pat ctx pat + | P_tup pats -> parens (separate_map (comma ^^ space) (ocaml_pat ctx) pats) + | P_list pats -> brackets (separate_map (semi ^^ space) (ocaml_pat ctx) pats) + | P_wild -> string "_" + | P_as (pat, id) -> separate space [ocaml_pat ctx pat; string "as"; zencode ctx id] + | _ -> string ("PAT<" ^ string_of_pat pat ^ ">") + +let begin_end doc = group (string "begin" ^^ nest 2 (break 1 ^^ doc) ^/^ string "end") + +(* Returns true if a type is a register being passed by name *) +let is_passed_by_name = function + | (Typ_aux (Typ_app (tid, _), _)) -> string_of_id tid = "register" + | _ -> false + +let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = + match exp_aux with + | E_app (f, [x]) when Env.is_union_constructor f (env_of exp) -> zencode_upper ctx f ^^ space ^^ ocaml_atomic_exp ctx x + | E_app (f, [x]) -> zencode ctx f ^^ space ^^ ocaml_atomic_exp ctx x + | E_app (f, xs) when Env.is_union_constructor f (env_of exp) -> + zencode_upper ctx f ^^ space ^^ parens (separate_map (comma ^^ space) (ocaml_atomic_exp ctx) xs) + (* Make sure we get the correct short circuiting semantics for and and or *) + | E_app (f, [x; y]) when string_of_id f = "and_bool" -> + separate space [ocaml_atomic_exp ctx x; string "&&"; ocaml_atomic_exp ctx y] + | E_app (f, [x; y]) when string_of_id f = "or_bool" -> + separate space [ocaml_atomic_exp ctx x; string "||"; ocaml_atomic_exp ctx y] + | E_app (f, xs) -> + zencode ctx f ^^ space ^^ parens (separate_map (comma ^^ space) (ocaml_atomic_exp ctx) xs) + | E_vector_subrange (exp1, exp2, exp3) -> string "subrange" ^^ space ^^ parens (separate_map (comma ^^ space) (ocaml_atomic_exp ctx) [exp1; exp2; exp3]) + | E_return exp -> separate space [string "r.return"; ocaml_atomic_exp ctx exp] + | E_assert (exp, _) -> separate space [string "assert"; ocaml_atomic_exp ctx exp] + | E_cast (_, exp) -> ocaml_exp ctx exp + | E_block [exp] -> ocaml_exp ctx exp + | E_block [] -> string "()" + | E_block exps -> begin_end (ocaml_block ctx exps) + | E_field (exp, id) -> ocaml_atomic_exp ctx exp ^^ dot ^^ zencode ctx id + | E_exit exp -> string "exit 0" + | E_case (exp, pexps) -> + begin_end (separate space [string "match"; ocaml_atomic_exp ctx exp; string "with"] + ^/^ ocaml_pexps ctx pexps) + | E_assign (lexp, exp) -> ocaml_assignment ctx lexp exp + | E_if (c, t, e) -> separate space [string "if"; ocaml_atomic_exp ctx c; + string "then"; ocaml_atomic_exp ctx t; + string "else"; ocaml_atomic_exp ctx e] + | E_record (FES_aux (FES_Fexps (fexps, _), _)) -> + enclose lbrace rbrace (group (separate_map (semi ^^ break 1) (ocaml_fexp ctx) fexps)) + | E_record_update (exp, FES_aux (FES_Fexps (fexps, _), _)) -> + enclose lbrace rbrace (separate space [ocaml_atomic_exp ctx exp; + string "with"; + separate_map (semi ^^ space) (ocaml_fexp ctx) fexps]) + | E_let (lb, exp) -> + separate space [string "let"; ocaml_letbind ctx lb; string "in"] + ^/^ ocaml_exp ctx exp + | E_internal_let (lexp, exp1, exp2) -> + separate space [string "let"; ocaml_atomic_lexp ctx lexp; + equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewrites.simple_typ (typ_of exp1))); string "in"] + ^/^ ocaml_exp ctx exp2 + | E_loop (Until, cond, body) -> + let loop_body = + (ocaml_atomic_exp ctx body ^^ semi) + ^/^ + separate space [string "if"; ocaml_atomic_exp ctx cond; + string "then loop ()"; + string "else ()"] + in + (string "let rec loop () =" ^//^ loop_body) + ^/^ string "in" + ^/^ string "loop ()" + | E_loop (While, cond, body) -> + let loop_body = + separate space [string "if"; ocaml_atomic_exp ctx cond; + string "then"; parens (ocaml_atomic_exp ctx body ^^ semi ^^ space ^^ string "loop ()"); + string "else ()"] + in + (string "let rec loop () =" ^//^ loop_body) + ^/^ string "in" + ^/^ string "loop ()" + | E_lit _ | E_list _ | E_id _ | E_tuple _ -> ocaml_atomic_exp ctx exp + | E_for (id, exp_from, exp_to, exp_step, ord, exp_body) -> + let loop_var = separate space [string "let"; zencode ctx id; equals; string "ref"; ocaml_atomic_exp ctx exp_from; string "in"] in + let loop_mod = + match ord with + | Ord_aux (Ord_inc, _) -> string "add_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step + | Ord_aux (Ord_dec, _) -> string "sub_big_int" ^^ space ^^ zencode ctx id ^^ space ^^ ocaml_atomic_exp ctx exp_step + in + let loop_compare = + match ord with + | Ord_aux (Ord_inc, _) -> string "le_big_int" + | Ord_aux (Ord_dec, _) -> string "gt_big_int" + in + let loop_body = + separate space [string "if"; loop_compare; zencode ctx id; ocaml_atomic_exp ctx exp_to] + ^/^ separate space [string "then"; + parens (ocaml_atomic_exp ctx exp_body ^^ semi ^^ space ^^ string "loop" ^^ space ^^ parens loop_mod)] + ^/^ string "else ()" + in + (string ("let rec loop " ^ zencode_string (string_of_id id) ^ " =") ^//^ loop_body) + ^/^ string "in" + ^/^ (string "loop" ^^ space ^^ ocaml_atomic_exp ctx exp_from) + | _ -> string ("EXP(" ^ string_of_exp exp ^ ")") +and ocaml_letbind ctx (LB_aux (lb_aux, _)) = + match lb_aux with + | LB_val (pat, exp) -> separate space [ocaml_pat ctx pat; equals; ocaml_atomic_exp ctx exp] +and ocaml_pexps ctx = function + | [pexp] -> ocaml_pexp ctx pexp + | pexp :: pexps -> ocaml_pexp ctx pexp ^/^ ocaml_pexps ctx pexps + | [] -> empty +and ocaml_pexp ctx = function + | Pat_aux (Pat_exp (pat, exp), _) -> + separate space [bar; ocaml_pat ctx pat; string "->"] + ^//^ group (ocaml_exp ctx exp) + | Pat_aux (Pat_when (pat, wh, exp), _) -> + separate space [bar; ocaml_pat ctx pat; string "when"; ocaml_atomic_exp ctx wh; string "->"] + ^//^ group (ocaml_exp ctx exp) +and ocaml_block ctx = function + | [exp] -> ocaml_exp ctx exp + | exp :: exps -> ocaml_exp ctx exp ^^ semi ^/^ ocaml_block ctx exps + | _ -> assert false +and ocaml_fexp ctx (FE_aux (FE_Fexp (id, exp), _)) = + separate space [zencode ctx id; equals; ocaml_exp ctx exp] +and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) = + match exp_aux with + | E_lit lit -> ocaml_lit lit + | E_id id -> + begin + match Env.lookup_id id (env_of exp) with + | Local (Immutable, _) | Unbound -> zencode ctx id + | Enum _ | Union _ -> zencode_upper ctx id + | Register _ when is_passed_by_name (typ_of exp) -> zencode ctx id + | Register typ -> + if !opt_trace_ocaml then + let var = gensym () in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in + parens (separate space [string "let"; var; equals; bang ^^ zencode ctx id; string "in"; + string "trace_read" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) + else bang ^^ zencode ctx id + | Local (Mutable, _) -> bang ^^ zencode ctx id + end + | E_list exps -> enclose lbracket rbracket (separate_map (semi ^^ space) (ocaml_exp ctx) exps) + | E_tuple exps -> parens (separate_map (comma ^^ space) (ocaml_exp ctx) exps) + | _ -> parens (ocaml_exp ctx exp) +and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = + match lexp_aux with + | LEXP_cast (_, id) | LEXP_id id -> + begin + match Env.lookup_id id (env_of exp) with + | Register typ -> + let var = gensym () in + let traced_exp = + if !opt_trace_ocaml then + let var = gensym () in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in + parens (separate space [string "let"; var; equals; ocaml_atomic_exp ctx exp; string "in"; + string "trace_write" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) + else ocaml_atomic_exp ctx exp + in + separate space [zencode ctx id; string ":="; traced_exp] + | _ -> separate space [zencode ctx id; string ":="; ocaml_exp ctx exp] + end + | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") +and ocaml_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = + match lexp_aux with + | LEXP_cast _ | LEXP_id _ -> ocaml_atomic_lexp ctx lexp + | _ -> string ("LEXP<" ^ string_of_lexp lexp ^ ">") +and ocaml_atomic_lexp ctx (LEXP_aux (lexp_aux, _) as lexp) = + match lexp_aux with + | LEXP_cast (_, id) -> zencode ctx id + | LEXP_id id -> zencode ctx id + | _ -> parens (ocaml_lexp ctx lexp) + +let rec get_initialize_registers = function + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _, E_aux (E_block inits, _)), _)]), _)) :: defs + when Id.compare id (mk_id "initialize_registers") = 0 -> + inits + | _ :: defs -> get_initialize_registers defs + | [] -> [] + +let initial_value_for id inits = + let find_reg = function + | E_aux (E_assign (LEXP_aux (LEXP_cast (_, reg_id), _), init), _) when Id.compare id reg_id = 0 -> Some init + | _ -> None + in + match Util.option_first find_reg inits with + | Some init -> init + | None -> failwith ("No assignment to register ^ " ^ string_of_id id ^ " in initialize_registers") + +let ocaml_dec_spec ctx (DEC_aux (reg, _)) = + match reg with + | DEC_reg (typ, id) -> + separate space [string "let"; zencode ctx id; colon; + parens (ocaml_typ ctx typ); string "ref"; equals; + string "ref"; parens (ocaml_exp ctx (initial_value_for id ctx.register_inits))] + | _ -> failwith "Unsupported register declaration" + +let first_function = ref true + +let function_header () = + if !first_function + then (first_function := false; string "let rec") + else string "and" + +let funcls_id = function + | [] -> failwith "Ocaml: empty function" + | FCL_aux (FCL_Funcl (id, pat, exp),_) :: _ -> id + +let ocaml_funcl_match ctx (FCL_aux (FCL_Funcl (id, pat, exp), _)) = + separate space [bar; ocaml_pat ctx pat; string "->"] + ^//^ ocaml_exp ctx exp + +let rec ocaml_funcl_matches ctx = function + | [] -> failwith "Ocaml: empty function" + | [clause] -> ocaml_funcl_match ctx clause + | (clause :: clauses) -> ocaml_funcl_match ctx clause ^/^ ocaml_funcl_matches ctx clauses + +let ocaml_funcls ctx = + (* Create functions string_of_arg and string_of_ret that print the argument and return types of the function respectively *) + let trace_info typ1 typ2 = + let arg_sym = gensym () in + let ret_sym = gensym () in + let string_of_arg = + separate space [function_header (); arg_sym; parens (string "arg" ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1); + colon; string "string"; equals; ocaml_string_typ typ1 (string "arg")] + in + let string_of_ret = + separate space [function_header (); ret_sym; parens (string "arg" ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ2); + colon; string "string"; equals; ocaml_string_typ typ2 (string "arg")] + in + (arg_sym, string_of_arg, ret_sym, string_of_ret) + in + let sail_call id arg_sym pat_sym ret_sym = + if !opt_trace_ocaml + then separate space [string "sail_trace_call"; string_lit (string_of_id id); parens (arg_sym ^^ space ^^ pat_sym); ret_sym] + else separate space [string "sail_call"] + in + let ocaml_funcl call string_of_arg string_of_ret = + if !opt_trace_ocaml + then (call ^^ twice hardline ^^ string_of_arg ^^ twice hardline ^^ string_of_ret) + else call + in + function + | [] -> failwith "Ocaml: empty function" + | [FCL_aux (FCL_Funcl (id, pat, exp),_)] -> + let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let pat_sym = gensym () in + let annot_pat = + let pat = parens (ocaml_pat ctx pat ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1) in + if !opt_trace_ocaml + then parens (separate space [pat; string "as"; pat_sym]) + else pat + in + let call_header = function_header () in + let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in + let call = + separate space [call_header; zencode ctx id; annot_pat; colon; ocaml_typ ctx typ2; equals; + sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] + ^//^ ocaml_exp ctx exp + ^^ rparen + in + ocaml_funcl call string_of_arg string_of_ret + | funcls -> + let id = funcls_id funcls in + let Typ_aux (Typ_fn (typ1, typ2, _), _) = Bindings.find id ctx.val_specs in + let pat_sym = gensym () in + let call_header = function_header () in + let arg_sym, string_of_arg, ret_sym, string_of_ret = trace_info typ1 typ2 in + let call = + separate space [call_header; zencode ctx id; parens (pat_sym ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx typ1); equals; + sail_call id arg_sym pat_sym ret_sym; string "(fun r ->"] + ^//^ (separate space [string "match"; pat_sym; string "with"] ^^ hardline ^^ ocaml_funcl_matches ctx funcls) + ^^ rparen + in + ocaml_funcl call string_of_arg string_of_ret + +let ocaml_fundef ctx (FD_aux (FD_function (_, _, _, funcls), _)) = + ocaml_funcls ctx funcls + +let rec ocaml_fields ctx = + let ocaml_field typ id = + separate space [zencode ctx id; colon; ocaml_typ ctx typ] + in + function + | [(typ, id)] -> ocaml_field typ id + | (typ, id) :: fields -> ocaml_field typ id ^^ semi ^/^ ocaml_fields ctx fields + | [] -> empty + +let rec ocaml_cases ctx = + let ocaml_case = function + | Tu_aux (Tu_id id, _) -> separate space [bar; zencode_upper ctx id] + | Tu_aux (Tu_ty_id (typ, id), _) -> separate space [bar; zencode_upper ctx id; string "of"; ocaml_typ ctx typ] + in + function + | [tu] -> ocaml_case tu + | tu :: tus -> ocaml_case tu ^/^ ocaml_cases ctx tus + | [] -> empty + +let rec ocaml_enum ctx = function + | [id] -> zencode_upper ctx id + | id :: ids -> zencode_upper ctx id ^/^ (bar ^^ space ^^ ocaml_enum ctx ids) + | [] -> empty + +(* We generate a string_of_X ocaml function for each type X, to be used for debugging purposes *) + +let ocaml_def_end = string ";;" ^^ twice hardline + +let ocaml_string_of_enum ctx id ids = + let ocaml_case id = + separate space [bar; zencode_upper ctx id; string "->"; string ("\"" ^ string_of_id id ^ "\"")] + in + separate space [string "let"; ocaml_string_of id; equals; string "function"] + ^//^ (separate_map hardline ocaml_case ids) + +let ocaml_string_of_struct ctx id typq fields = + let arg = gensym () in + let ocaml_field (typ, id) = + separate space [string (string_of_id id ^ " = \""); string "^"; ocaml_string_typ typ arg ^^ string "." ^^ zencode ctx id] + in + separate space [string "let"; ocaml_string_of id; parens (arg ^^ space ^^ colon ^^ space ^^ zencode ctx id); equals] + ^//^ (string "\"{" ^^ separate_map (hardline ^^ string "^ \", ") ocaml_field fields ^^ string " ^ \"}\"") + +let ocaml_string_of_abbrev ctx id typq typ = + let arg = gensym () in + separate space [string "let"; ocaml_string_of id; parens (arg ^^ space ^^ colon ^^ space ^^ zencode ctx id); equals] + ^//^ ocaml_string_typ typ arg + +let ocaml_typedef ctx (TD_aux (td_aux, _)) = + match td_aux with + | TD_record (id, _, typq, fields, _) -> + ((separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; lbrace] + ^//^ ocaml_fields ctx fields) + ^/^ rbrace) + ^^ ocaml_def_end + ^^ ocaml_string_of_struct ctx id typq fields + | TD_variant (id, _, typq, cases, _) -> + separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] + ^//^ ocaml_cases ctx cases + | TD_enum (id, _, ids, _) -> + (separate space [string "type"; zencode ctx id; equals] + ^//^ (bar ^^ space ^^ ocaml_enum ctx ids)) + ^^ ocaml_def_end + ^^ ocaml_string_of_enum ctx id ids + | TD_abbrev (id, _, TypSchm_aux (TypSchm_ts (typq, typ), _)) -> + separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; ocaml_typ ctx typ] + ^^ ocaml_def_end + ^^ ocaml_string_of_abbrev ctx id typq typ + | _ -> failwith "Unsupported typedef" + +let get_externs (Defs defs) = + let extern_id (VS_aux (VS_val_spec (typschm, id, ext, _), _)) = + match ext "ocaml" with + | None -> [] + | Some ext -> [(id, mk_id ext)] + in + let rec extern_ids = function + | DEF_spec vs :: defs -> extern_id vs :: extern_ids defs + | def :: defs -> extern_ids defs + | [] -> [] + in + List.fold_left (fun exts (id, name) -> Bindings.add id name exts) Bindings.empty (List.concat (extern_ids defs)) + +let nf_group doc = + first_function := true; + group doc + +let ocaml_def ctx def = match def with + | DEF_reg_dec ds -> nf_group (ocaml_dec_spec ctx ds) ^^ ocaml_def_end + | DEF_fundef fd -> group (ocaml_fundef ctx fd) ^^ twice hardline + | DEF_type td -> nf_group (ocaml_typedef ctx td) ^^ ocaml_def_end + | DEF_val lb -> nf_group (string "let" ^^ space ^^ ocaml_letbind ctx lb) ^^ ocaml_def_end + | _ -> empty + +let val_spec_typs (Defs defs) = + let typs = ref (Bindings.empty) in + let val_spec_typ (VS_aux (vs_aux, _)) = + match vs_aux with + | VS_val_spec (TypSchm_aux (TypSchm_ts (_, typ), _), id, _, _) -> typs := Bindings.add id typ !typs + in + let rec vs_typs = function + | DEF_spec vs :: defs -> val_spec_typ vs; vs_typs defs + | _ :: defs -> vs_typs defs + | [] -> [] + in + vs_typs defs; + !typs + +let ocaml_defs (Defs defs) = + let ctx = { register_inits = get_initialize_registers defs; + externs = get_externs (Defs defs); + val_specs = val_spec_typs (Defs defs) + } + in + let empty_reg_init = + if ctx.register_inits = [] + then + separate space [string "let"; string "initialize_registers"; string "()"; equals; string "()"] + ^^ ocaml_def_end + else empty + in + (string "open Sail_lib;;" ^^ hardline) + ^^ (string "open Big_int" ^^ ocaml_def_end) + ^^ concat (List.map (ocaml_def ctx) defs) + ^^ empty_reg_init + +let ocaml_main spec = + concat [separate space [string "open"; string (String.capitalize spec)] ^^ ocaml_def_end; + separate space [string "open"; string "Elf_loader"] ^^ ocaml_def_end; + separate space [string "let"; string "()"; equals] + ^//^ (string "Random.self_init ();" + ^/^ string "load_elf ();" + ^/^ string (if !opt_trace_ocaml then "Sail_lib.opt_trace := true;" else "Sail_lib.opt_trace := false;") + ^/^ string "initialize_registers ();" + ^/^ string "Printexc.record_backtrace true;" + ^/^ string "zmain ()") + ] + +let ocaml_pp_defs f defs = + ToChannel.pretty 1. 80 f (ocaml_defs defs) + +let ocaml_compile spec defs = + let sail_lib_dir = + try Sys.getenv "SAILLIBDIR" with + | Not_found -> failwith "Environment variable SAILLIBDIR needs to be set" + in + if Sys.file_exists "_sbuild" then () else Unix.mkdir "_sbuild" 0o775; + let cwd = Unix.getcwd () in + Unix.chdir "_sbuild"; + let _ = Unix.system ("cp -r " ^ sail_lib_dir ^ "/ocaml_rts/. .") in + let out_chan = open_out (spec ^ ".ml") in + ocaml_pp_defs out_chan defs; + close_out out_chan; + if IdSet.mem (mk_id "main") (Initial_check.val_spec_ids defs) + then + begin + print_endline "Generating main"; + let out_chan = open_out "main.ml" in + ToChannel.pretty 1. 80 out_chan (ocaml_main spec); + close_out out_chan; + let _ = Unix.system "ocamlbuild -pkg zarith -pkg uint main.native" in + let _ = Unix.system ("cp main.native " ^ cwd ^ "/" ^ spec) in + () + end + else + let _ = Unix.system ("ocamlbuild -pkg zarith -pkg uint " ^ spec ^ ".cmo") in + (); + Unix.chdir cwd diff --git a/src/parse_ast.ml b/src/parse_ast.ml index e069462a..aceba3b6 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -42,6 +42,7 @@ (* generated by Ott 0.25 from: l2_parse.ott *) +open Big_int type text = string @@ -64,7 +65,6 @@ base_kind_aux = (* base kind *) BK_type (* kind of types *) | BK_nat (* kind of natural number size expressions *) | BK_order (* kind of vector order specifications *) - | BK_effect (* kind of effect sets *) type @@ -131,7 +131,7 @@ type atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders, and effects after parsing *) ATyp_id of id (* identifier *) | ATyp_var of kid (* ticked variable *) - | ATyp_constant of int (* constant *) + | ATyp_constant of big_int (* constant *) | ATyp_times of atyp * atyp (* product *) | ATyp_sum of atyp * atyp (* sum *) | ATyp_minus of atyp * atyp (* subtraction *) @@ -144,36 +144,39 @@ atyp_aux = (* expressions of all kinds, to be translated to types, nats, orders | ATyp_fn of atyp * atyp * atyp (* Function type (first-order only in user code), last atyp is an effect *) | ATyp_tup of (atyp) list (* Tuple type *) | ATyp_app of id * (atyp) list (* type constructor application *) + | ATyp_exist of kid list * n_constraint * atyp and atyp = ATyp_aux of atyp_aux * l -type +and kinded_id_aux = (* optionally kind-annotated identifier *) KOpt_none of kid (* identifier *) | KOpt_kind of kind * kid (* kind-annotated variable *) -type +and n_constraint_aux = (* constraint over kind $_$ *) - NC_fixed of atyp * atyp + NC_equal of atyp * atyp | NC_bounded_ge of atyp * atyp | NC_bounded_le of atyp * atyp - | NC_nat_set_bounded of kid * (int) list - + | NC_not_equal of atyp * atyp + | NC_set of kid * (big_int) list + | NC_or of n_constraint * n_constraint + | NC_and of n_constraint * n_constraint + | NC_true + | NC_false + +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 *) @@ -202,12 +205,12 @@ lit_aux = (* Literal constant *) | L_one (* $_ : _$ *) | L_true (* $_ : _$ *) | L_false (* $_ : _$ *) - | L_num of int (* natural number constant *) + | L_num of big_int (* natural number constant *) | L_hex of string (* bit vector constant, C-style *) | 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 *) @@ -231,13 +234,14 @@ pat_aux = (* Pattern *) | P_as of pat * id (* named pattern *) | P_typ of atyp * pat (* typed pattern *) | P_id of id (* identifier *) + | P_var of pat * kid (* bind pat to type variable *) | P_app of id * (pat) list (* union constructor pattern *) | P_record of (fpat) list * bool (* struct pattern *) | P_vector of (pat) list (* vector pattern *) - | P_vector_indexed of ((int * pat)) list (* vector pattern (with explicit indices) *) | 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 @@ -248,6 +252,7 @@ and fpat_aux = (* Field pattern *) and fpat = FP_aux of fpat_aux * l +type loop = While | Until type exp_aux = (* Expression *) @@ -260,9 +265,9 @@ exp_aux = (* Expression *) | E_app_infix of exp * id * exp (* infix function application *) | E_tuple of (exp) list (* tuple *) | E_if of exp * exp * exp (* conditional *) + | E_loop of loop * exp * exp | E_for of id * exp * exp * exp * atyp * exp (* loop *) | E_vector of (exp) list (* vector (indexed from 0) *) - | E_vector_indexed of (exp) list * opt_default (* vector (indexed consecutively) *) | E_vector_access of exp * exp (* vector access *) | E_vector_subrange of exp * exp * exp (* subvector extraction *) | E_vector_update of exp * exp * exp (* vector functional update *) @@ -270,16 +275,20 @@ exp_aux = (* Expression *) | E_vector_append of exp * exp (* vector concatenation *) | E_list of (exp) list (* list *) | E_cons of exp * exp (* cons *) - | E_record of fexps (* struct *) + | E_record of exp list (* struct *) | E_record_update of exp * (exp) list (* functional update of struct *) | E_field of exp * id (* field projection from struct *) | E_case of exp * (pexp) list (* pattern matching *) | 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_throw of exp + | E_try of exp * pexp list | E_return of exp | E_assert of exp * exp + | E_internal_let of exp * exp * exp and exp = E_aux of exp_aux * l @@ -305,13 +314,13 @@ 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 and letbind_aux = (* Let binding *) - LB_val_explicit of typschm * pat * exp (* value binding, explicit type (pat must be total) *) - | LB_val_implicit of pat * exp (* value binding, implicit type (pat must be total) *) + LB_val of pat * exp (* value binding, implicit type (pat must be total) *) and letbind = LB_aux of letbind_aux * l @@ -379,8 +388,8 @@ type_union = 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_single of big_int (* single index *) + | BF_range of big_int * big_int (* index range *) | BF_concat of index_range * index_range (* concatenation of index ranges *) and index_range = @@ -415,19 +424,12 @@ type_def_aux = (* Type definition body *) 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 + VS_val_spec of typschm * id * (string -> string option) * bool type kind_def_aux = (* Definition body for elements of kind; many are shorthands for type\_defs *) KD_abbrev of kind * id * name_scm_opt * typschm (* type abbreviation *) - | KD_record of kind * id * name_scm_opt * typquant * ((atyp * id)) list * bool (* struct type definition *) - | KD_variant of kind * id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *) - | KD_enum of kind * id * name_scm_opt * (id) list * bool (* enumeration type definition *) - | KD_register of kind * id * atyp * atyp * ((index_range * id)) list (* register mutable bitfield type definition *) - type dec_spec_aux = (* Register declarations *) @@ -480,17 +482,23 @@ type scattered_def = SD_aux of scattered_def_aux * l +type prec = Infix | InfixL | InfixR -type +type fixity_token = (prec * big_int * string) + +type def = (* Top-level definition *) DEF_kind of kind_def (* definition of named kind identifiers *) | 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_fixity of prec * big_int * id (* fixity declaration *) | 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 *) | DEF_reg_dec of dec_spec (* register declaration *) + | DEF_internal_mutrec of fundef list type @@ -508,6 +516,3 @@ and lexp = type defs = (* Definition sequence *) Defs of (def) list - - - diff --git a/src/parser.mly b/src/parser.mly index bd68cfdc..2cfa8e80 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -44,13 +44,21 @@ let r = fun x -> x (* Ulib.Text.of_latin1 *) +open Big_int open Parse_ast let loc () = Range(Parsing.symbol_start_pos(),Parsing.symbol_end_pos()) let locn m n = Range(Parsing.rhs_start_pos m,Parsing.rhs_end_pos n) +let id_of_kid = function + | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) + let idl i = Id_aux(i, loc()) +let string_of_id = function + | Id_aux (Id str, _) -> str + | Id_aux (DeIid str, _) -> str + let efl e = BE_aux(e, loc()) let ploc p = P_aux(p,loc ()) @@ -92,16 +100,16 @@ let mk_namesectn _ = Name_sect_aux(Name_sect_none,Unknown) let make_range_sugar_bounded typ1 typ2 = ATyp_app(Id_aux(Id("range"),Unknown),[typ1; typ2;]) let make_range_sugar typ1 = - make_range_sugar_bounded (ATyp_aux(ATyp_constant(0), Unknown)) typ1 + make_range_sugar_bounded (ATyp_aux(ATyp_constant(zero_big_int), Unknown)) typ1 let make_atom_sugar typ1 = ATyp_app(Id_aux(Id("atom"),Unknown),[typ1]) let make_r bot top = match bot,top with | ATyp_aux(ATyp_constant b,_),ATyp_aux(ATyp_constant t,l) -> - ATyp_aux(ATyp_constant ((t-b)+1),l) + ATyp_aux(ATyp_constant (add_big_int (sub_big_int t b) unit_big_int),l) | bot,(ATyp_aux(_,l) as top) -> - ATyp_aux((ATyp_sum ((ATyp_aux (ATyp_sum (top, ATyp_aux(ATyp_constant 1,Unknown)), Unknown)), + ATyp_aux((ATyp_sum ((ATyp_aux (ATyp_sum (top, ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), (ATyp_aux ((ATyp_neg bot),Unknown)))), l) let make_vector_sugar_bounded order_set is_inc name typ typ1 typ2 = @@ -115,11 +123,11 @@ let make_vector_sugar_bounded order_set is_inc name typ typ1 typ2 = else (typ2, ATyp_default_ord,"vector_sugar_r") (* rise and base not calculated, rise only from specification *) in ATyp_app(Id_aux(Id(name),Unknown),[typ1;rise;ATyp_aux(ord,Unknown);typ]) let make_vector_sugar order_set is_inc typ typ1 = - let zero = (ATyp_aux(ATyp_constant 0,Unknown)) in + let zero = (ATyp_aux(ATyp_constant zero_big_int,Unknown)) in let (typ1,typ2) = match (order_set,is_inc,typ1) with - | (true,true,ATyp_aux(ATyp_constant t,l)) -> zero,ATyp_aux(ATyp_constant (t-1),l) + | (true,true,ATyp_aux(ATyp_constant t,l)) -> zero,ATyp_aux(ATyp_constant (sub_big_int t unit_big_int),l) | (true,true,ATyp_aux(_, l)) -> zero,ATyp_aux (ATyp_sum (typ1, - ATyp_aux(ATyp_neg(ATyp_aux(ATyp_constant 1,Unknown)), Unknown)), l) + ATyp_aux(ATyp_neg(ATyp_aux(ATyp_constant unit_big_int,Unknown)), Unknown)), l) | (true,false,_) -> typ1,zero | (false,_,_) -> zero,typ1 in make_vector_sugar_bounded order_set is_inc "vector_sugar_r" typ typ1 typ2 @@ -129,10 +137,11 @@ 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 Exist 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 Try Catch Throw %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape +%token While Do Repeat Until /* Avoid shift/reduce conflict - see right_atomic_exp rule */ @@ -149,8 +158,8 @@ let make_vector_sugar order_set is_inc typ typ1 = /*Terminals with content*/ %token <string> Id TyVar TyId -%token <int> Num -%token <string> String Bin Hex +%token <Big_int.big_int> Num +%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 +218,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 +239,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 +256,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 +272,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 @@ -278,15 +295,21 @@ tyvar: | TyVar { (Kid_aux((Var($1)),loc ())) } +tyvars: + | tyvar + { [$1] } + | tyvar tyvars + { $1 :: $2 } + atomic_kind: | TYPE { bkloc BK_type } | Nat { bkloc BK_nat } + | NatNum + { bkloc BK_nat } | Order { bkloc BK_order } - | EFFECT - { bkloc BK_effect } kind_help: | atomic_kind @@ -342,29 +365,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,76 +384,93 @@ 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) } + | Lcurly id Rcurly + { tloc (ATyp_id $2) } + | tyvar + { tloc (ATyp_var $1) } + | Lparen exist_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) } -typ: +exist_typ: + | Exist tyvars Comma nexp_constraint Dot tup_typ + { tloc (ATyp_exist ($2, $4, $6)) } + | Exist tyvars Dot tup_typ + { tloc (ATyp_exist ($2, NC_aux (NC_true, loc ()), $4)) } | tup_typ { $1 } - | tup_typ MinusGt typ Effect effect_typ + +typ: + | exist_typ + { $1 } + | tup_typ MinusGt exist_typ Effect effect_typ { tloc (ATyp_fn($1,$3,$5)) } lit: @@ -470,6 +488,8 @@ lit: { lloc (L_bin $1) } | Hex { lloc (L_hex $1) } + | Real + { lloc (L_real $1) } | Undefined { lloc L_undef } | Bitzero @@ -477,7 +497,6 @@ lit: | Bitone { lloc L_one } - atomic_pat: | lit { ploc (P_lit $1) } @@ -485,10 +504,12 @@ 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 exist_typ Rparen atomic_pat + { ploc (P_typ($2,$4)) } | id { ploc (P_app($1,[])) } + | tyvar + { ploc (P_var (ploc (P_id (id_of_kid $1)), $1)) } | Lcurly fpats Rcurly { ploc (P_record((fst $2, snd $2))) } | Lsquare comma_pats Rsquare @@ -497,16 +518,16 @@ atomic_pat: { ploc (P_vector([$2])) } | Lsquare Rsquare { ploc (P_vector []) } - | Lsquare npats Rsquare - { ploc (P_vector_indexed($2)) } | Lparen comma_pats Rparen { ploc (P_tup($2)) } | SquareBarBar BarBarSquare { ploc (P_list([])) } | SquareBarBar pat BarBarSquare { ploc (P_list([$2])) } - | SquareBarBar comma_pats BarBarSquare + | SquareBarBar semi_pats BarBarSquare { ploc (P_list($2)) } + | atomic_pat ColonColon pat + { ploc (P_cons ($1, $3)) } | Lparen pat Rparen { $2 } @@ -536,6 +557,12 @@ comma_pats: | atomic_pat Comma comma_pats { $1::$3 } +semi_pats: + | atomic_pat Semi atomic_pat + { [$1;$3] } + | atomic_pat Semi semi_pats + { $1::$3 } + fpat: | id Eq pat { fploc (FP_Fpat($1,$3)) } @@ -569,7 +596,7 @@ atomic_exp: { eloc (E_lit($1)) } | Lparen exp Rparen { $2 } - | Lparen typ Rparen atomic_exp + | Lparen exist_typ Rparen atomic_exp { eloc (E_cast($2,$4)) } | Lparen comma_exps Rparen { eloc (E_tuple($2)) } @@ -581,8 +608,6 @@ atomic_exp: { eloc (E_vector([$2])) } | Lsquare comma_exps Rsquare { eloc (E_vector($2)) } - | Lsquare comma_exps Semi Default Eq exp Rsquare - { eloc (E_vector_indexed($2,(Def_val_aux(Def_val_dec $6, locn 3 6)))) } | Lsquare exp With atomic_exp Eq exp Rsquare { eloc (E_vector_update($2,$4,$6)) } | Lsquare exp With atomic_exp Colon atomic_exp Eq exp Rsquare @@ -595,8 +620,14 @@ atomic_exp: { eloc (E_list($2)) } | Switch exp Lcurly case_exps Rcurly { eloc (E_case($2,$4)) } + | Try exp Catch Lcurly case_exps Rcurly + { eloc (E_try ($2, $5)) } | Sizeof atomic_typ { eloc (E_sizeof($2)) } + | Constraint Lparen nexp_constraint Rparen + { eloc (E_constraint $3) } + | Throw atomic_exp + { eloc (E_throw $2) } | Exit atomic_exp { eloc (E_exit $2) } | Return atomic_exp @@ -655,12 +686,14 @@ right_atomic_exp: raise (Parse_error_locn ((loc ()),"Missing \"from\" in foreach loop")); 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 step = eloc (E_lit(lloc (L_num unit_big_int))) in + let ord = if $6 = "to" then ATyp_aux(ATyp_inc,(locn 6 6)) else ATyp_aux(ATyp_dec,(locn 6 6)) in eloc (E_for($3,$5,$7,step,ord,$9)) } + | While exp Do exp + { eloc (E_loop (While, $2, $4)) } | letbind In exp { eloc (E_let($1,$3)) } @@ -970,15 +1003,12 @@ 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 - { lbloc (LB_val_implicit($2,$4)) } - | Let_ typquant atomic_typ atomic_pat Eq exp - { lbloc (LB_val_explicit((mk_typschm $2 $3 2 3),$4,$6)) } -/* This introduces one shift reduce conflict, that basically points out that an atomic_pat with a type declared is the Same as this - | Let_ Lparen typ Rparen atomic_pat Eq exp - { assert false (* lbloc (LB_val_explicit((mk_typschm (mk_typqn ()) $2 2 2),$3,$5)) *)} */ + { lbloc (LB_val($2,$4)) } funcl: | id atomic_pat Eq exp @@ -1020,17 +1050,29 @@ fun_def: val_spec: | Val typquant typ id - { vloc (VS_val_spec(mk_typschm $2 $3 2 3,$4)) } + { vloc (VS_val_spec(mk_typschm $2 $3 2 3,$4, (fun _ -> None), false)) } | Val typ id - { vloc (VS_val_spec(mk_typschm (mk_typqn ()) $2 2 2,$3)) } + { vloc (VS_val_spec(mk_typschm (mk_typqn ()) $2 2 2,$3, (fun _ -> None), false)) } + | Val Cast typquant typ id + { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> None), true)) } + | Val Cast typ id + { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> None), true)) } | Val Extern typquant typ id - { vloc (VS_extern_no_rename (mk_typschm $3 $4 3 4,$5)) } + { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some (string_of_id $5)), false)) } | Val Extern typ id - { vloc (VS_extern_no_rename (mk_typschm (mk_typqn ()) $3 3 3, $4)) } + { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3, $4, (fun _ -> Some (string_of_id $4)), false)) } | Val Extern typquant typ id Eq String - { vloc (VS_extern_spec (mk_typschm $3 $4 3 4,$5,$7)) } + { vloc (VS_val_spec (mk_typschm $3 $4 3 4,$5, (fun _ -> Some $7), false)) } | Val Extern typ id Eq String - { vloc (VS_extern_spec (mk_typschm (mk_typqn ()) $3 3 3,$4, $6)) } + { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $3 3 3,$4, (fun _ -> Some $6), false)) } + | Val Cast Extern typquant typ id + { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some (string_of_id $6)), true)) } + | Val Cast Extern typ id + { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4, $5, (fun _ -> Some (string_of_id $5)), true)) } + | Val Cast Extern typquant typ id Eq String + { vloc (VS_val_spec (mk_typschm $4 $5 4 5,$6, (fun _ -> Some $8), true)) } + | Val Cast Extern typ id Eq String + { vloc (VS_val_spec (mk_typschm (mk_typqn ()) $4 4 4,$5, (fun _ -> Some $7), true)) } kinded_id: | tyvar @@ -1051,14 +1093,36 @@ 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 () ) } + { NC_aux(NC_equal($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_set($1,$4), loc ()) } | tyvar IN Lcurly nums Rcurly - { NC_aux(NC_nat_set_bounded($1,$4), loc ()) } + { NC_aux(NC_set($1,$4), loc ()) } + | True + { NC_aux (NC_true, loc ()) } + | False + { NC_aux (NC_false, loc ()) } + | Lparen nexp_constraint Rparen + { $2 } id_constraint: | nexp_constraint @@ -1229,30 +1293,7 @@ ktype_def: { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) $5 5 5)) } | Def kind tid Eq Num { kdloc (KD_abbrev($2,$3,mk_namesectn (),mk_typschm (mk_typqn ()) (tlocl (ATyp_constant $5) 5 5) 5 5)) } - | Def kind tid name_sect Eq Const Struct typquant Lcurly c_def_body Rcurly - { kdloc (KD_record($2,$3,$4,$8,fst $10, snd $10)) } - | Def kind tid name_sect Eq Const Struct Lcurly c_def_body Rcurly - { kdloc (KD_record($2,$3,$4,(mk_typqn ()), fst $9, snd $9)) } - | Def kind tid Eq Const Struct typquant Lcurly c_def_body Rcurly - { kdloc (KD_record($2,$3,mk_namesectn (), $7, fst $9, snd $9)) } - | Def kind tid Eq Const Struct Lcurly c_def_body Rcurly - { kdloc (KD_record($2,$3, mk_namesectn (), mk_typqn (), fst $8, snd $8)) } - | Def kind tid name_sect Eq Const Union typquant Lcurly union_body Rcurly - { kdloc (KD_variant($2,$3,$4, $8, fst $10, snd $10)) } - | Def kind tid Eq Const Union typquant Lcurly union_body Rcurly - { kdloc (KD_variant($2,$3,mk_namesectn (), $7, fst $9, snd $9)) } - | Def kind tid name_sect Eq Const Union Lcurly union_body Rcurly - { kdloc (KD_variant($2, $3,$4, mk_typqn (), fst $9, snd $9)) } - | Def kind tid Eq Const Union Lcurly union_body Rcurly - { kdloc (KD_variant($2,$3, mk_namesectn (), mk_typqn (), fst $8, snd $8)) } - | Def kind tid Eq Enumerate Lcurly enum_body Rcurly - { kdloc (KD_enum($2,$3, mk_namesectn (), $7,false)) } - | Def kind tid name_sect Eq Enumerate Lcurly enum_body Rcurly - { kdloc (KD_enum($2,$3,$4,$8,false)) } - | Def kind tid Eq Register Bits Lsquare nexp_typ Colon nexp_typ Rsquare Lcurly r_def_body Rcurly - { kdloc (KD_register($2,$3, $8, $10, $13)) } - - + def: | type_def { dloc (DEF_type($1)) } @@ -1266,6 +1307,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 @@ -1301,4 +1344,3 @@ file: nonempty_exp_list: | semi_exps_help Eof { $1 } - diff --git a/src/parser2.mly b/src/parser2.mly new file mode 100644 index 00000000..1444f6cd --- /dev/null +++ b/src/parser2.mly @@ -0,0 +1,1155 @@ +/**************************************************************************/ +/* 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. */ +/**************************************************************************/ + +%{ + +let r = fun x -> x (* Ulib.Text.of_latin1 *) + +open Big_int +open Parse_ast + +let loc n m = Range (n, m) + +let default_opt x = function + | None -> x + | Some y -> y + +let assoc_opt key assocs = + try Some (List.assoc key assocs) with + | Not_found -> None + +let string_of_id = function + | Id_aux (Id str, _) -> str + | Id_aux (DeIid str, _) -> str + +let mk_id i n m = Id_aux (i, loc n m) +let mk_kid str n m = Kid_aux (Var str, loc n m) + +let id_of_kid = function + | Kid_aux (Var v, l) -> Id_aux (Id (String.sub v 1 (String.length v - 1)), l) + +let deinfix (Id_aux (Id v, l)) = Id_aux (DeIid v, l) + +let mk_effect e n m = BE_aux (e, loc n m) +let mk_typ t n m = ATyp_aux (t, loc n m) +let mk_pat p n m = P_aux (p, loc n m) +let mk_pexp p n m = Pat_aux (p, loc n m) +let mk_exp e n m = E_aux (e, loc n m) +let mk_lit l n m = L_aux (l, loc n m) +let mk_lit_exp l n m = mk_exp (E_lit (mk_lit l n m)) n m +let mk_typschm tq t n m = TypSchm_aux (TypSchm_ts (tq, t), loc n m) +let mk_nc nc n m = NC_aux (nc, loc n m) +let mk_sd s n m = SD_aux (s, loc n m) + +let mk_funcl f n m = FCL_aux (f, loc n m) +let mk_fun fn n m = FD_aux (fn, loc n m) +let mk_td t n m = TD_aux (t, loc n m) +let mk_vs v n m = VS_aux (v, loc n m) +let mk_reg_dec d n m = DEC_aux (d, loc n m) +let mk_default d n m = DT_aux (d, loc n m) + +let qi_id_of_kopt (KOpt_aux (kopt_aux, l) as kopt) = QI_aux (QI_id kopt, l) + +let mk_recn = (Rec_aux((Rec_nonrec), Unknown)) +let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown)) +let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown) +let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown) +let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown) + +type lchain = + LC_lt +| LC_lteq +| LC_nexp of atyp + +let rec desugar_lchain chain s e = + match chain with + | [LC_nexp n1; LC_lteq; LC_nexp n2] -> + mk_nc (NC_bounded_le (n1, n2)) s e + | [LC_nexp n1; LC_lt; LC_nexp n2] -> + mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e + | (LC_nexp n1 :: LC_lteq :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | (LC_nexp n1 :: LC_lt :: LC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_le (mk_typ (ATyp_sum (n1, mk_typ (ATyp_constant unit_big_int) s e)) s e, n2)) s e in + mk_nc (NC_and (nc1, desugar_lchain (LC_nexp n2 :: chain) s e)) s e + | _ -> assert false + +type rchain = + RC_gt +| RC_gteq +| RC_nexp of atyp + +let rec desugar_rchain chain s e = + match chain with + | [RC_nexp n1; RC_gteq; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, n2)) s e + | [RC_nexp n1; RC_gt; RC_nexp n2] -> + mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e + | (RC_nexp n1 :: RC_gteq :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, n2)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | (RC_nexp n1 :: RC_gt :: RC_nexp n2 :: chain) -> + let nc1 = mk_nc (NC_bounded_ge (n1, mk_typ (ATyp_sum (n2, mk_typ (ATyp_constant unit_big_int) s e)) s e)) s e in + mk_nc (NC_and (nc1, desugar_rchain (RC_nexp n2 :: chain) s e)) s e + | _ -> assert false + +%} + +/*Terminals with no content*/ + +%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op +%token Enum Else False Forall Foreach Overload Function_ If_ In Inc Let_ Int Order Cast +%token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef +%token Undefined Union With Val Constraint Throw Try Catch Exit +%token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape +%token Repeat Until While Do Record Mutual + +%nonassoc Then +%nonassoc Else + +%token Bar Comma Dot Eof Minus Semi Under DotDot +%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar +%token MinusGt + +/*Terminals with content*/ + +%token <string> Id TyVar +%token <Big_int.big_int> Num +%token <string> String Bin Hex Real + +%token <string> Amp At Caret Eq Gt Lt Plus Star EqGt Unit +%token <string> Colon ExclEq +%token <string> GtEq +%token <string> LtEq + +%token <string> Op0 Op1 Op2 Op3 Op4 Op5 Op6 Op7 Op8 Op9 +%token <string> Op0l Op1l Op2l Op3l Op4l Op5l Op6l Op7l Op8l Op9l +%token <string> Op0r Op1r Op2r Op3r Op4r Op5r Op6r Op7r Op8r Op9r + +%token <Parse_ast.fixity_token> Fixity + +%start file +%start typschm_eof +%type <Parse_ast.typschm> typschm_eof +%type <Parse_ast.defs> file + +%% + +id: + | Id { mk_id (Id $1) $startpos $endpos } + + | Op Op0 { mk_id (DeIid $2) $startpos $endpos } + | Op Op1 { mk_id (DeIid $2) $startpos $endpos } + | Op Op2 { mk_id (DeIid $2) $startpos $endpos } + | Op Op3 { mk_id (DeIid $2) $startpos $endpos } + | Op Op4 { mk_id (DeIid $2) $startpos $endpos } + | Op Op5 { mk_id (DeIid $2) $startpos $endpos } + | Op Op6 { mk_id (DeIid $2) $startpos $endpos } + | Op Op7 { mk_id (DeIid $2) $startpos $endpos } + | Op Op8 { mk_id (DeIid $2) $startpos $endpos } + | Op Op9 { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0l { mk_id (DeIid $2) $startpos $endpos } + | Op Op1l { mk_id (DeIid $2) $startpos $endpos } + | Op Op2l { mk_id (DeIid $2) $startpos $endpos } + | Op Op3l { mk_id (DeIid $2) $startpos $endpos } + | Op Op4l { mk_id (DeIid $2) $startpos $endpos } + | Op Op5l { mk_id (DeIid $2) $startpos $endpos } + | Op Op6l { mk_id (DeIid $2) $startpos $endpos } + | Op Op7l { mk_id (DeIid $2) $startpos $endpos } + | Op Op8l { mk_id (DeIid $2) $startpos $endpos } + | Op Op9l { mk_id (DeIid $2) $startpos $endpos } + + | Op Op0r { mk_id (DeIid $2) $startpos $endpos } + | Op Op1r { mk_id (DeIid $2) $startpos $endpos } + | Op Op2r { mk_id (DeIid $2) $startpos $endpos } + | Op Op3r { mk_id (DeIid $2) $startpos $endpos } + | Op Op4r { mk_id (DeIid $2) $startpos $endpos } + | Op Op5r { mk_id (DeIid $2) $startpos $endpos } + | Op Op6r { mk_id (DeIid $2) $startpos $endpos } + | Op Op7r { mk_id (DeIid $2) $startpos $endpos } + | Op Op8r { mk_id (DeIid $2) $startpos $endpos } + | Op Op9r { mk_id (DeIid $2) $startpos $endpos } + + | Op Plus { mk_id (DeIid "+") $startpos $endpos } + | Op Minus { mk_id (DeIid "-") $startpos $endpos } + | Op Star { mk_id (DeIid "*") $startpos $endpos } + | Op ExclEq { mk_id (DeIid "!=") $startpos $endpos } + | Op Lt { mk_id (DeIid "<") $startpos $endpos } + | Op Gt { mk_id (DeIid ">") $startpos $endpos } + | Op LtEq { mk_id (DeIid "<=") $startpos $endpos } + | Op GtEq { mk_id (DeIid ">=") $startpos $endpos } + | Op Amp { mk_id (DeIid "&") $startpos $endpos } + | Op Bar { mk_id (DeIid "|") $startpos $endpos } + | Op Caret { mk_id (DeIid "^") $startpos $endpos } + +op0: Op0 { mk_id (Id $1) $startpos $endpos } +op1: Op1 { mk_id (Id $1) $startpos $endpos } +op2: Op2 { mk_id (Id $1) $startpos $endpos } +op3: Op3 { mk_id (Id $1) $startpos $endpos } +op4: Op4 { mk_id (Id $1) $startpos $endpos } +op5: Op5 { mk_id (Id $1) $startpos $endpos } +op6: Op6 { mk_id (Id $1) $startpos $endpos } +op7: Op7 { mk_id (Id $1) $startpos $endpos } +op8: Op8 { mk_id (Id $1) $startpos $endpos } +op9: Op9 { mk_id (Id $1) $startpos $endpos } + +op0l: Op0l { mk_id (Id $1) $startpos $endpos } +op1l: Op1l { mk_id (Id $1) $startpos $endpos } +op2l: Op2l { mk_id (Id $1) $startpos $endpos } +op3l: Op3l { mk_id (Id $1) $startpos $endpos } +op4l: Op4l { mk_id (Id $1) $startpos $endpos } +op5l: Op5l { mk_id (Id $1) $startpos $endpos } +op6l: Op6l { mk_id (Id $1) $startpos $endpos } +op7l: Op7l { mk_id (Id $1) $startpos $endpos } +op8l: Op8l { mk_id (Id $1) $startpos $endpos } +op9l: Op9l { mk_id (Id $1) $startpos $endpos } + +op0r: Op0r { mk_id (Id $1) $startpos $endpos } +op1r: Op1r { mk_id (Id $1) $startpos $endpos } +op2r: Op2r { mk_id (Id $1) $startpos $endpos } +op3r: Op3r { mk_id (Id $1) $startpos $endpos } +op4r: Op4r { mk_id (Id $1) $startpos $endpos } +op5r: Op5r { mk_id (Id $1) $startpos $endpos } +op6r: Op6r { mk_id (Id $1) $startpos $endpos } +op7r: Op7r { mk_id (Id $1) $startpos $endpos } +op8r: Op8r { mk_id (Id $1) $startpos $endpos } +op9r: Op9r { mk_id (Id $1) $startpos $endpos } + +id_list: + | id + { [$1] } + | id Comma id_list + { $1 :: $3 } + +kid: + | TyVar + { mk_kid $1 $startpos $endpos } + +kid_list: + | kid + { [$1] } + | kid kid_list + { $1 :: $2 } + +nc: + | nc Bar nc_and + { mk_nc (NC_or ($1, $3)) $startpos $endpos } + | nc_and + { $1 } + +nc_and: + | nc_and Amp atomic_nc + { mk_nc (NC_and ($1, $3)) $startpos $endpos } + | atomic_nc + { $1 } + +atomic_nc: + | True + { mk_nc NC_true $startpos $endpos } + | False + { mk_nc NC_false $startpos $endpos } + | typ Eq typ + { mk_nc (NC_equal ($1, $3)) $startpos $endpos } + | typ ExclEq typ + { mk_nc (NC_not_equal ($1, $3)) $startpos $endpos } + | nc_lchain + { desugar_lchain $1 $startpos $endpos } + | nc_rchain + { desugar_rchain $1 $startpos $endpos } + | Lparen nc Rparen + { $2 } + | kid In Lcurly num_list Rcurly + { mk_nc (NC_set ($1, $4)) $startpos $endpos } + +num_list: + | Num + { [$1] } + | Num Comma num_list + { $1 :: $3 } + +nc_lchain: + | typ LtEq typ + { [LC_nexp $1; LC_lteq; LC_nexp $3] } + | typ Lt typ + { [LC_nexp $1; LC_lt; LC_nexp $3] } + | typ LtEq nc_lchain + { LC_nexp $1 :: LC_lteq :: $3 } + | typ Lt nc_lchain + { LC_nexp $1 :: LC_lt :: $3 } + +nc_rchain: + | typ GtEq typ + { [RC_nexp $1; RC_gteq; RC_nexp $3] } + | typ Gt typ + { [RC_nexp $1; RC_gt; RC_nexp $3] } + | typ GtEq nc_rchain + { RC_nexp $1 :: RC_gteq :: $3 } + | typ Gt nc_rchain + { RC_nexp $1 :: RC_gt :: $3 } + +typ: + | typ0 + { $1 } + +/* The following implements all nine levels of user-defined precedence for +operators in types, with both left, right and non-associative operators */ + +typ0: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0l: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ0l op0l typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } +typ0r: + | typ1 op0 typ1 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 op0r typ0r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1 { $1 } + +typ1: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1l: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ1l op1l typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } +typ1r: + | typ2 op1 typ2 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 op1r typ1r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2 { $1 } + +typ2: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2l: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ2l op2l typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } +typ2r: + | typ3 op2 typ3 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 op2r typ2r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3 { $1 } + +typ3: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3l: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ3l op3l typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } +typ3r: + | typ4 op3 typ4 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 op3r typ3r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4 { $1 } + +typ4: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4l: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ4l op4l typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } +typ4r: + | typ5 op4 typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 op4r typ4r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5 { $1 } + +typ5: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5l: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ5l op5l typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } +typ5r: + | typ6 op5 typ6 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 op5r typ5 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6 { $1 } + +typ6: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6l: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l op6l typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ6l Plus typ7 { mk_typ (ATyp_sum ($1, $3)) $startpos $endpos } + | typ6l Minus typ7 { mk_typ (ATyp_minus ($1, $3)) $startpos $endpos } + | typ7 { $1 } +typ6r: + | typ7 op6 typ7 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 op6r typ6r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7 { $1 } + +typ7: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7l: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l op7l typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ7l Star typ8 { mk_typ (ATyp_times ($1, $3)) $startpos $endpos } + | typ8 { $1 } +typ7r: + | typ8 op7 typ8 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 op7r typ7r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8 { $1 } + +typ8: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8l: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ8l op8l typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } +typ8r: + | typ9 op8 typ9 { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9 op8r typ8r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | TwoCaret typ9 { mk_typ (ATyp_exp $2) $startpos $endpos } + | Minus typ9 { mk_typ (ATyp_neg $2) $startpos $endpos} + | typ9 { $1 } + +typ9: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9l: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | typ9l op9l atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } +typ9r: + | atomic_typ op9 atomic_typ { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ op9r typ9r { mk_typ (ATyp_app (deinfix $2, [$1; $3])) $startpos $endpos } + | atomic_typ { $1 } + +atomic_typ: + | id + { mk_typ (ATyp_id $1) $startpos $endpos } + | kid + { mk_typ (ATyp_var $1) $startpos $endpos } + | Num + { mk_typ (ATyp_constant $1) $startpos $endpos } + | Dec + { mk_typ ATyp_dec $startpos $endpos } + | Inc + { mk_typ ATyp_inc $startpos $endpos } + | id Lparen typ_list Rparen + { mk_typ (ATyp_app ($1, $3)) $startpos $endpos } + | Register Lparen typ Rparen + { let register_id = mk_id (Id "register") $startpos $endpos in + mk_typ (ATyp_app (register_id, [$3])) $startpos $endpos } + | Lparen typ Rparen + { $2 } + | Lparen typ Comma typ_list Rparen + { mk_typ (ATyp_tup ($2 :: $4)) $startpos $endpos } + | LcurlyBar num_list RcurlyBar + { let v = mk_kid "n" $startpos $endpos in + let atom_id = mk_id (Id "atom") $startpos $endpos in + let atom_of_v = mk_typ (ATyp_app (atom_id, [mk_typ (ATyp_var v) $startpos $endpos])) $startpos $endpos in + mk_typ (ATyp_exist ([v], NC_aux (NC_set (v, $2), loc $startpos($2) $endpos($2)), atom_of_v)) $startpos $endpos } + | Lcurly kid_list Dot typ Rcurly + { mk_typ (ATyp_exist ($2, NC_aux (NC_true, loc $startpos $endpos), $4)) $startpos $endpos } + | Lcurly kid_list Comma nc Dot typ Rcurly + { mk_typ (ATyp_exist ($2, $4, $6)) $startpos $endpos } + +typ_list: + | typ + { [$1] } + | typ Comma typ_list + { $1 :: $3 } + +base_kind: + | Int + { BK_aux (BK_nat, loc $startpos $endpos) } + | TYPE + { BK_aux (BK_type, loc $startpos $endpos) } + | Order + { BK_aux (BK_order, loc $startpos $endpos) } + +kind: + | base_kind + { K_aux (K_kind [$1], loc $startpos $endpos) } + +kopt: + | Lparen kid Colon kind Rparen + { KOpt_aux (KOpt_kind ($4, $2), loc $startpos $endpos) } + | kid + { KOpt_aux (KOpt_none $1, loc $startpos $endpos) } + +kopt_list: + | kopt + { [$1] } + | kopt kopt_list + { $1 :: $2 } + +typquant: + | kopt_list Comma nc + { let qi_nc = QI_aux (QI_const $3, loc $startpos($3) $endpos($3)) in + TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1 @ [qi_nc]), loc $startpos $endpos) } + | kopt_list + { TypQ_aux (TypQ_tq (List.map qi_id_of_kopt $1), loc $startpos $endpos) } + +effect: + | Barr + { mk_effect BE_barr $startpos $endpos } + | Depend + { mk_effect BE_depend $startpos $endpos } + | Rreg + { mk_effect BE_rreg $startpos $endpos } + | Wreg + { mk_effect BE_wreg $startpos $endpos } + | Rmem + { mk_effect BE_rmem $startpos $endpos } + | Rmemt + { mk_effect BE_rmemt $startpos $endpos } + | Wmem + { mk_effect BE_wmem $startpos $endpos } + | Wmv + { mk_effect BE_wmv $startpos $endpos } + | Wmvt + { mk_effect BE_wmvt $startpos $endpos } + | Eamem + { mk_effect BE_eamem $startpos $endpos } + | Exmem + { mk_effect BE_exmem $startpos $endpos } + | Undef + { mk_effect BE_undef $startpos $endpos } + | Unspec + { mk_effect BE_unspec $startpos $endpos } + | Nondet + { mk_effect BE_nondet $startpos $endpos } + | Escape + { mk_effect BE_escape $startpos $endpos } + +effect_list: + | effect + { [$1] } + | effect Comma effect_list + { $1::$3 } + +effect_set: + | Lcurly effect_list Rcurly + { mk_typ (ATyp_set $2) $startpos $endpos } + | Pure + { mk_typ (ATyp_set []) $startpos $endpos } + +typschm: + | typ MinusGt typ + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ MinusGt typ + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, mk_typ (ATyp_set []) s e)) s e) s e) $startpos $endpos } + | typ MinusGt typ Effect effect_set + { (fun s e -> mk_typschm mk_typqn (mk_typ (ATyp_fn ($1, $3, $5)) s e) s e) $startpos $endpos } + | Forall typquant Dot typ MinusGt typ Effect effect_set + { (fun s e -> mk_typschm $2 (mk_typ (ATyp_fn ($4, $6, $8)) s e) s e) $startpos $endpos } + +typschm_eof: + | typschm Eof + { $1 } + +pat1: + | atomic_pat + { $1 } + | atomic_pat At pat_concat + { mk_pat (P_vector_concat ($1 :: $3)) $startpos $endpos } + +pat_concat: + | atomic_pat + { [$1] } + | atomic_pat At pat_concat + { $1 :: $3 } + +pat: + | pat1 + { $1 } + | pat1 As id + { mk_pat (P_as ($1, $3)) $startpos $endpos } + | pat1 As kid + { mk_pat (P_var ($1, $3)) $startpos $endpos } + +pat_list: + | pat + { [$1] } + | pat Comma pat_list + { $1 :: $3 } + +atomic_pat: + | Under + { mk_pat (P_wild) $startpos $endpos } + | lit + { mk_pat (P_lit $1) $startpos $endpos } + | id + { mk_pat (P_id $1) $startpos $endpos } + | kid + { mk_pat (P_var (mk_pat (P_id (id_of_kid $1)) $startpos $endpos, $1)) $startpos $endpos } + | id Lparen pat_list Rparen + { mk_pat (P_app ($1, $3)) $startpos $endpos } + | atomic_pat Colon typ + { mk_pat (P_typ ($3, $1)) $startpos $endpos } + | Lparen pat Rparen + { $2 } + | Lparen pat Comma pat_list Rparen + { mk_pat (P_tup ($2 :: $4)) $startpos $endpos } + | Lsquare pat_list Rsquare + { mk_pat (P_vector $2) $startpos $endpos } + +lit: + | True + { mk_lit L_true $startpos $endpos } + | False + { mk_lit L_false $startpos $endpos } + | Unit + { mk_lit L_unit $startpos $endpos } + | Num + { mk_lit (L_num $1) $startpos $endpos } + | Undefined + { mk_lit L_undef $startpos $endpos } + | Bitzero + { mk_lit L_zero $startpos $endpos } + | Bitone + { mk_lit L_one $startpos $endpos } + | Bin + { mk_lit (L_bin $1) $startpos $endpos } + | Hex + { mk_lit (L_hex $1) $startpos $endpos } + | String + { mk_lit (L_string $1) $startpos $endpos } + | Real + { mk_lit (L_real $1) $startpos $endpos } + +exp: + | exp0 + { $1 } + | atomic_exp Eq exp + { mk_exp (E_assign ($1, $3)) $startpos $endpos } + | Let_ letbind In exp + { mk_exp (E_let ($2, $4)) $startpos $endpos } + | Lcurly block Rcurly + { mk_exp (E_block $2) $startpos $endpos } + | Return exp + { mk_exp (E_return $2) $startpos $endpos } + | Throw exp + { mk_exp (E_throw $2) $startpos $endpos } + | If_ exp Then exp Else exp + { mk_exp (E_if ($2, $4, $6)) $startpos $endpos } + | If_ exp Then exp + { mk_exp (E_if ($2, $4, mk_lit_exp L_unit $endpos($4) $endpos($4))) $startpos $endpos } + | Match exp Lcurly case_list Rcurly + { mk_exp (E_case ($2, $4)) $startpos $endpos } + | Try exp Catch Lcurly case_list Rcurly + { mk_exp (E_try ($2, $5)) $startpos $endpos } + | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp In typ Rparen exp + { if $4 <> "from" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); + if $6 <> "to" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" in foreach loop")); + mk_exp (E_for ($3, $5, $7, $9, $11, $13)) $startpos $endpos } + | Foreach Lparen id Id atomic_exp Id atomic_exp By atomic_exp Rparen exp + { if $4 <> "from" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); + if $6 <> "to" && $6 <> "downto" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); + let order = + if $6 = "to" + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, $9, order, $11)) $startpos $endpos } + | Foreach Lparen id Id atomic_exp Id atomic_exp Rparen exp + { if $4 <> "from" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"from\" in foreach loop")); + if $6 <> "to" && $6 <> "downto" then + raise (Parse_error_locn (loc $startpos $endpos,"Missing \"to\" or \"downto\" in foreach loop")); + let step = mk_lit_exp (L_num unit_big_int) $startpos $endpos in + let ord = + if $6 = "to" + then ATyp_aux(ATyp_inc,loc $startpos($6) $endpos($6)) + else ATyp_aux(ATyp_dec,loc $startpos($6) $endpos($6)) + in + mk_exp (E_for ($3, $5, $7, step, ord, $9)) $startpos $endpos } + | Repeat exp Until exp + { mk_exp (E_loop (Until, $4, $2)) $startpos $endpos } + | While exp Do exp + { mk_exp (E_loop (While, $2, $4)) $startpos $endpos } + +/* The following implements all nine levels of user-defined precedence for +operators in expressions, with both left, right and non-associative operators */ + +exp0: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0l: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp0l op0l exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } +exp0r: + | exp1 op0 exp1 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 op0r exp0r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1 { $1 } + +exp1: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1l: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp1l op1l exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } +exp1r: + | exp2 op1 exp2 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 op1r exp1r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2 { $1 } + +exp2: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } +exp2l: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp2l op2l exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 { $1 } +exp2r: + | exp3 op2 exp3 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 op2r exp2r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3 Bar exp2r { mk_exp (E_app_infix ($1, mk_id (Id "|") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp3 { $1 } + +exp3: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } +exp3l: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp3l op3l exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 { $1 } +exp3r: + | exp4 op3 exp4 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 op3r exp3r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4 Amp exp3r { mk_exp (E_app_infix ($1, mk_id (Id "&") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4 { $1 } + +exp4: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 Lt exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 Gt exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 LtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "<=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 GtEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id ">=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp5 ExclEq exp5 { mk_exp (E_app_infix ($1, mk_id (Id "!=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4l: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp4l op4l exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } +exp4r: + | exp5 op4 exp5 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 op4r exp4r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5 { $1 } + +exp5: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } +exp5l: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp5l op5l exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 { $1 } +exp5r: + | exp6 op5 exp6 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 op5r exp5r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6 At exp5r { mk_exp (E_vector_append ($1, $3)) $startpos $endpos } + | exp6 { $1 } + +exp6: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6l: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l op6l exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp6l Plus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "+") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp6l Minus exp7 { mk_exp (E_app_infix ($1, mk_id (Id "-") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp7 { $1 } +exp6r: + | exp7 op6 exp7 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 op6r exp6r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7 { $1 } + +exp7: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7l: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l op7l exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp7l Star exp8 { mk_exp (E_app_infix ($1, mk_id (Id "*") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | exp8 { $1 } +exp7r: + | exp8 op7 exp8 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 op7r exp7r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8 { $1 } + +exp8: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8l: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp8l op8l exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } +exp8r: + | exp9 op8 exp9 { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 op8r exp8r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9 Caret exp8r { mk_exp (E_app_infix ($1, mk_id (Id "^") $startpos($2) $endpos($2), $3)) $startpos $endpos } + | TwoCaret exp9 { mk_exp (E_app (mk_id (Id "pow2") $startpos($1) $endpos($1), [$2])) $startpos $endpos } + | exp9 { $1 } + +exp9: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9l: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | exp9l op9l atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } +exp9r: + | atomic_exp op9 atomic_exp { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp op9r exp9r { mk_exp (E_app_infix ($1, $2, $3)) $startpos $endpos } + | atomic_exp { $1 } + +case: + | pat EqGt exp + { mk_pexp (Pat_exp ($1, $3)) $startpos $endpos } + | pat If_ exp EqGt exp + { mk_pexp (Pat_when ($1, $3, $5)) $startpos $endpos } + +case_list: + | case + { [$1] } + | case Comma case_list + { $1 :: $3 } + +block: + | exp + { [$1] } + | Let_ letbind Semi block + { [mk_exp (E_let ($2, mk_exp (E_block $4) $startpos($4) $endpos)) $startpos $endpos] } + | exp Semi /* Allow trailing semicolon in block */ + { [$1] } + | exp Semi block + { $1 :: $3 } + +%inline letbind: + | pat Eq exp + { LB_aux (LB_val ($1, $3), loc $startpos $endpos) } + +atomic_exp: + | atomic_exp Colon atomic_typ + { mk_exp (E_cast ($3, $1)) $startpos $endpos } + | lit + { mk_exp (E_lit $1) $startpos $endpos } + | atomic_exp Dot id + { mk_exp (E_field ($1, $3)) $startpos $endpos } + | id + { mk_exp (E_id $1) $startpos $endpos } + | kid + { mk_exp (E_sizeof (mk_typ (ATyp_var $1) $startpos $endpos)) $startpos $endpos } + | id Unit + { mk_exp (E_app ($1, [mk_lit_exp L_unit $startpos($2) $endpos])) $startpos $endpos } + | id Lparen exp_list Rparen + { mk_exp (E_app ($1, $3)) $startpos $endpos } + | Exit Lparen exp Rparen + { mk_exp (E_exit $3) $startpos $endpos } + | Sizeof Lparen typ Rparen + { mk_exp (E_sizeof $3) $startpos $endpos } + | Constraint Lparen nc Rparen + { mk_exp (E_constraint $3) $startpos $endpos } + | Assert Lparen exp Rparen + { mk_exp (E_assert ($3, mk_lit_exp (L_string "") $startpos($4) $endpos($4))) $startpos $endpos } + | Assert Lparen exp Comma exp Rparen + { mk_exp (E_assert ($3, $5)) $startpos $endpos } + | atomic_exp Lsquare exp Rsquare + { mk_exp (E_vector_access ($1, $3)) $startpos $endpos } + | atomic_exp Lsquare exp DotDot exp Rsquare + { mk_exp (E_vector_subrange ($1, $3, $5)) $startpos $endpos } + | Record Lcurly fexp_exp_list Rcurly + { mk_exp (E_record $3) $startpos $endpos } + | Lcurly exp With fexp_exp_list Rcurly + { mk_exp (E_record_update ($2, $4)) $startpos $endpos } + | Lsquare exp_list Rsquare + { mk_exp (E_vector $2) $startpos $endpos } + | Lsquare exp With atomic_exp Eq exp Rsquare + { mk_exp (E_vector_update ($2, $4, $6)) $startpos $endpos } + | Lsquare exp With atomic_exp DotDot atomic_exp Eq exp Rsquare + { mk_exp (E_vector_update_subrange ($2, $4, $6, $8)) $startpos $endpos } + | LsquareBar exp_list RsquareBar + { mk_exp (E_list $2) $startpos $endpos } + | Lparen exp Rparen + { $2 } + | Lparen exp Comma exp_list Rparen + { mk_exp (E_tuple ($2 :: $4)) $startpos $endpos } + +fexp_exp: + | atomic_exp Eq exp + { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + +fexp_exp_list: + | fexp_exp + { [$1] } + | fexp_exp Comma fexp_exp_list + { $1 :: $3 } + +exp_list: + | exp + { [$1] } + | exp Comma exp_list + { $1 :: $3 } + +funcl: + | id pat Eq exp + { mk_funcl (FCL_Funcl ($1, $2, $4)) $startpos $endpos } + +funcls: + | id pat Eq exp + { [mk_funcl (FCL_Funcl ($1, $2, $4)) $startpos $endpos] } + | id pat Eq exp And funcls + { mk_funcl (FCL_Funcl ($1, $2, $4)) $startpos $endpos :: $6 } + +type_def: + | Typedef id typquant Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm $3 $5 $startpos($3) $endpos)) $startpos $endpos } + | Typedef id Eq typ + { mk_td (TD_abbrev ($2, mk_namesectn, mk_typschm mk_typqn $4 $startpos($4) $endpos)) $startpos $endpos } + | Struct id Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } + | Struct id typquant Eq Lcurly struct_fields Rcurly + { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + | Enum id Eq enum_bar + { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } + | Enum id Eq Lcurly enum Rcurly + { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } + | Union id typquant Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } + +enum_bar: + | id + { [$1] } + | id Bar enum_bar + { $1 :: $3 } + +enum: + | id + { [$1] } + | id Comma enum + { $1 :: $3 } + +struct_field: + | id Colon typ + { ($3, $1) } + +struct_fields: + | struct_field + { [$1] } + | struct_field Comma + { [$1] } + | struct_field Comma struct_fields + { $1 :: $3 } + +type_union: + | id Colon typ + { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } + | id + { Tu_aux (Tu_id $1, loc $startpos $endpos) } + +type_unions: + | type_union + { [$1] } + | type_union Comma + { [$1] } + | type_union Comma type_unions + { $1 :: $3 } + +fun_def: + | Function_ funcls + { mk_fun (FD_function (mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } + +fun_def_list: + | fun_def + { [$1] } + | fun_def fun_def_list + { $1 :: $2 } + +let_def: + | Let_ letbind + { $2 } + +externs: + | id Colon String + { [(string_of_id $1, $3)] } + | id Colon String Comma externs + { (string_of_id $1, $3) :: $5 } + +val_spec_def: + | Val id Colon typschm + { mk_vs (VS_val_spec ($4, $2, (fun _ -> None), false)) $startpos $endpos } + | Val Cast id Colon typschm + { mk_vs (VS_val_spec ($5, $3, (fun _ -> None), true)) $startpos $endpos } + | Val id Eq String Colon typschm + { mk_vs (VS_val_spec ($6, $2, (fun _ -> Some $4), false)) $startpos $endpos } + | Val Cast id Eq String Colon typschm + { mk_vs (VS_val_spec ($7, $3, (fun _ -> Some $5), true)) $startpos $endpos } + | Val String Colon typschm + { mk_vs (VS_val_spec ($4, mk_id (Id $2) $startpos($2) $endpos($2), (fun _ -> Some $2), false)) $startpos $endpos } + | Val Cast String Colon typschm + { mk_vs (VS_val_spec ($5, mk_id (Id $3) $startpos($3) $endpos($3), (fun _ -> Some $3), true)) $startpos $endpos } + | Val id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($8, $2, (fun backend -> (assoc_opt backend $5)), false)) $startpos $endpos } + | Val Cast id Eq Lcurly externs Rcurly Colon typschm + { mk_vs (VS_val_spec ($9, $3, (fun backend -> (assoc_opt backend $6)), true)) $startpos $endpos } + +register_def: + | Register id Colon typ + { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos } + +default_def: + | Default base_kind Inc + { mk_default (DT_order ($2, mk_typ ATyp_inc $startpos($3) $endpos)) $startpos $endpos } + | Default base_kind Dec + { mk_default (DT_order ($2, mk_typ ATyp_dec $startpos($3) $endpos)) $startpos $endpos } + +scattered_def: + | Union id typquant + { mk_sd (SD_scattered_variant($2, mk_namesectn, $3)) $startpos $endpos } + | Union id + { mk_sd (SD_scattered_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos } + | Function_ id + { mk_sd (SD_scattered_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } + +def: + | fun_def + { DEF_fundef $1 } + | Fixity + { let (prec, n, op) = $1 in DEF_fixity (prec, n, Id_aux (Id op, loc $startpos $endpos)) } + | val_spec_def + { DEF_spec $1 } + | type_def + { DEF_type $1 } + | let_def + { DEF_val $1 } + | register_def + { DEF_reg_dec $1 } + | Overload id Eq Lcurly id_list Rcurly + { DEF_overload ($2, $5) } + | Overload id Eq enum_bar + { DEF_overload ($2, $4) } + | Scattered scattered_def + { DEF_scattered $2 } + | Function_ Clause funcl + { DEF_scattered (mk_sd (SD_scattered_funcl $3) $startpos $endpos) } + | Union Clause id Eq type_union + { DEF_scattered (mk_sd (SD_scattered_unioncl ($3, $5)) $startpos $endpos) } + | End id + { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } + | default_def + { DEF_default $1 } + | Mutual Lcurly fun_def_list Rcurly + { DEF_internal_mutrec $3 } + +defs_list: + | def + { [$1] } + | def defs_list + { $1::$2 } + +defs: + | defs_list + { (Defs $1) } + +file: + | defs Eof + { $1 } diff --git a/src/pretty_print.ml b/src/pretty_print.ml index 442c368b..f778fe08 100644 --- a/src/pretty_print.ml +++ b/src/pretty_print.ml @@ -40,9 +40,6 @@ (* 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 034db664..b878d29e 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -41,18 +41,13 @@ (**************************************************************************) 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) -> (out_channel * string list) -> tannot defs -> string -> unit - - -val pp_format_annot_ascii : tannot -> string +val pp_defs_lem : bool -> bool -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 3699e1ac..315772a4 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -41,11 +41,13 @@ (**************************************************************************) open Ast +open Big_int open PPrint let pipe = string "|" let arrow = string "->" let dotdot = string ".." +let coloncolon = string "::" let coloneq = string ":=" let lsquarebar = string "[|" let rsquarebar = string "|]" @@ -66,7 +68,7 @@ let comma_sp = comma ^^ space let colon_sp = spaces colon let doc_var (Kid_aux(Var v,_)) = string v -let doc_int i = string (string_of_int i) +let doc_int i = string (string_of_big_int i) let doc_op symb a b = infix 2 1 symb a b let doc_unop symb a = prefix 2 1 symb a @@ -111,7 +113,7 @@ let doc_ord (Ord_aux(o,_)) = match o with | Ord_inc -> string "inc" | Ord_dec -> string "dec" -let doc_typ, doc_atomic_typ, doc_nexp = +let doc_typ, doc_atomic_typ, doc_nexp, doc_nexp_constraint = (* following the structure of parser for precedence *) let rec typ ty = fn_typ ty and fn_typ ((Typ_aux (t, _)) as ty) = match t with @@ -119,12 +121,15 @@ let doc_typ, doc_atomic_typ, doc_nexp = separate space [tup_typ arg; arrow; fn_typ ret; string "effect"; doc_effects efct] | _ -> tup_typ ty and tup_typ ((Typ_aux (t, _)) as ty) = match t with + | Typ_exist (kids, nc, ty) -> + separate space [string "exist"; separate_map space doc_var kids ^^ comma; nexp_constraint nc ^^ dot; typ ty] | Typ_tup typs -> parens (separate_map comma_sp app_typ typs) | _ -> app_typ ty and app_typ ((Typ_aux (t, _)) as ty) = match t with (*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,10 +164,11 @@ 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, _);]) -> - (squarebars (if n = 0 then nexp m else doc_op colon (doc_int n) (nexp m))) + (squarebars (if eq_big_int n zero_big_int then nexp m else doc_op colon (doc_int n) (nexp m))) | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> (squarecolons (nexp n)) | Typ_app(id,args) -> @@ -172,7 +178,6 @@ let doc_typ, doc_atomic_typ, doc_nexp = and atomic_typ ((Typ_aux (t, _)) as ty) = match t with | Typ_id id -> doc_id id | Typ_var v -> doc_var v - | Typ_wild -> underscore | Typ_app _ | Typ_tup _ | Typ_fn _ -> (* exhaustiveness matters here to avoid infinite loops * if we add a new Typ constructor *) @@ -184,7 +189,6 @@ let doc_typ, doc_atomic_typ, doc_nexp = | Typ_arg_typ t -> app_typ t | Typ_arg_nexp n -> nexp n | Typ_arg_order o -> doc_ord o - | Typ_arg_effect e -> doc_effects e (* same trick to handle precedence of nexp *) and nexp ne = sum_typ ne @@ -207,13 +211,28 @@ let doc_typ, doc_atomic_typ, doc_nexp = | _ -> atomic_nexp_typ ne and atomic_nexp_typ ((Nexp_aux(n,_)) as ne) = match n with | Nexp_var v -> doc_var v - | Nexp_id i -> doc_id i - | Nexp_constant i -> doc_int i + | Nexp_id i -> braces (doc_id i) + | Nexp_constant i -> if lt_big_int i zero_big_int then parens(doc_int i) else doc_int i | Nexp_neg _ | Nexp_exp _ | Nexp_times _ | Nexp_sum _ | Nexp_minus _-> group (parens (nexp ne)) - (* expose doc_typ, doc_atomic_typ and doc_nexp *) - in typ, atomic_typ, nexp + and nexp_constraint (NC_aux(nc,_)) = match nc with + | NC_equal(n1,n2) -> doc_op equals (nexp n1) (nexp n2) + | NC_not_equal (n1, n2) -> doc_op (string "!=") (nexp n1) (nexp n2) + | NC_bounded_ge(n1,n2) -> doc_op (string ">=") (nexp n1) (nexp n2) + | NC_bounded_le(n1,n2) -> doc_op (string "<=") (nexp n1) (nexp n2) + | NC_set(v,bounds) -> + doc_op (string "IN") (doc_var v) + (braces (separate_map comma_sp doc_int bounds)) + | NC_or (nc1, nc2) -> + parens (separate space [nexp_constraint nc1; string "|"; nexp_constraint nc2]) + | NC_and (nc1, nc2) -> + separate space [nexp_constraint nc1; string "&"; nexp_constraint nc2] + | NC_true -> string "true" + | NC_false -> string "false" + + (* expose doc_typ, doc_atomic_typ, doc_nexp and doc_nexp_constraint *) + in typ, atomic_typ, nexp, nexp_constraint let pp_format_id (Id_aux(i,_)) = match i with diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index cf8fda59..ef91c684 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 @@ -50,12 +53,16 @@ open Pretty_print_common * PPrint-based sail-to-lem pprinter ****************************************************************************) -let print_to_from_interp_value = ref true +let print_to_from_interp_value = ref false let langlebar = string "<|" let ranglebar = string "|>" let anglebars = enclose langlebar ranglebar -let fix_id name = match name with +let is_number_char c = + c = '0' || c = '1' || c = '2' || c = '3' || c = '4' || c = '5' || + c = '6' || c = '7' || c = '8' || c = '9' + +let rec fix_id remove_tick name = match name with | "assert" | "lsl" | "lsr" @@ -67,28 +74,28 @@ let fix_id name = match name with | "try" | "match" | "with" + | "check" | "field" | "LT" | "GT" | "EQ" | "integer" -> name ^ "'" - | _ -> name - -let is_number char = - char = '0' || char = '1' || char = '2' || char = '3' || char = '4' || char = '5' || - char = '6' || char = '7' || char = '8' || char = '9' + | _ -> + if String.contains name '#' then + fix_id remove_tick (String.concat "_" (Util.split_on_char '#' name)) + else if String.contains name '?' then + fix_id remove_tick (String.concat "_pat_" (Util.split_on_char '?' name)) + else if name.[0] = '\'' then + let var = String.sub name 1 (String.length name - 1) in + if remove_tick then var else (var ^ "'") + else if is_number_char(name.[0]) then + ("v" ^ name ^ "'") + else name let doc_id_lem (Id_aux(i,_)) = match i with - | Id i -> - (* this not the right place to do this, just a workaround *) - if i.[0] = '\'' then - string ((String.sub i 1 (String.length i - 1)) ^ "'") - else if is_number(i.[0]) then - string ("v" ^ i ^ "'") - else - string (fix_id i) + | Id i -> string (fix_id false i) | DeIid x -> (* add an extra space through empty to avoid a closing-comment * token in case of x ending with star. *) @@ -99,7 +106,7 @@ let doc_id_lem_type (Id_aux(i,_)) = | Id("int") -> string "ii" | Id("nat") -> string "ii" | Id("option") -> string "maybe" - | Id i -> string (fix_id i) + | Id i -> string (fix_id false i) | DeIid x -> (* add an extra space through empty to avoid a closing-comment * token in case of x ending with star. *) @@ -112,56 +119,161 @@ let doc_id_lem_ctor (Id_aux(i,_)) = | Id("nat") -> string "integer" | Id("Some") -> string "Just" | Id("None") -> string "Nothing" - | Id i -> string (fix_id (String.capitalize i)) + | Id i -> string (fix_id false (String.capitalize i)) | DeIid x -> (* add an extra space through empty to avoid a closing-comment * token in case of x ending with star. *) separate space [colon; string (String.capitalize x); empty] +let doc_var_lem kid = string (fix_id true (string_of_kid kid)) + +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 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 + | Effect_set effs -> effectful_set effs + +let is_regtyp (Typ_aux (typ, _)) env = match typ with + | Typ_app(id, _) when string_of_id id = "register" -> true + | Typ_id(id) when Env.is_regtyp id env -> true | _ -> false +let doc_nexp_lem nexp = + let (Nexp_aux (nexp, l) as full_nexp) = nexp_simp nexp in + match nexp with + | Nexp_constant i -> string ("ty" ^ string_of_big_int i) + | Nexp_var v -> string (string_of_kid (orig_kid v)) + | _ -> + let rec mangle_nexp (Nexp_aux (nexp, _)) = begin + match nexp with + | Nexp_id id -> string_of_id id + | Nexp_var kid -> string_of_id (id_of_kid (orig_kid kid)) + | Nexp_constant i -> Pretty_print_lem_ast.lemnum string_of_big_int i + | Nexp_times (n1, n2) -> mangle_nexp n1 ^ "_times_" ^ mangle_nexp n2 + | Nexp_sum (n1, n2) -> mangle_nexp n1 ^ "_plus_" ^ mangle_nexp n2 + | Nexp_minus (n1, n2) -> mangle_nexp n1 ^ "_minus_" ^ mangle_nexp n2 + | Nexp_exp n -> "exp_" ^ mangle_nexp n + | Nexp_neg n -> "neg_" ^ mangle_nexp n + end in + string ("'" ^ mangle_nexp full_nexp) + (* raise (Reporting_basic.err_unreachable l + ("cannot pretty-print non-atomic nexp \"" ^ string_of_nexp full_nexp ^ "\"")) *) + +(* Rewrite mangled names of type variables to the original names *) +let rec orig_nexp (Nexp_aux (nexp, l)) = + let rewrap nexp = Nexp_aux (nexp, l) in + match nexp with + | Nexp_var kid -> rewrap (Nexp_var (orig_kid kid)) + | Nexp_times (n1, n2) -> rewrap (Nexp_times (orig_nexp n1, orig_nexp n2)) + | Nexp_sum (n1, n2) -> rewrap (Nexp_sum (orig_nexp n1, orig_nexp n2)) + | Nexp_minus (n1, n2) -> rewrap (Nexp_minus (orig_nexp n1, orig_nexp n2)) + | Nexp_exp n -> rewrap (Nexp_exp (orig_nexp n)) + | Nexp_neg n -> rewrap (Nexp_neg (orig_nexp n)) + | _ -> rewrap nexp + +(* Returns the set of type variables that will appear in the Lem output, + which may be smaller than those in the Sail type. May need to be + updated with doc_typ_lem *) +let rec lem_nexps_of_typ sequential mwords (Typ_aux (t,_)) = + let trec = lem_nexps_of_typ sequential mwords in + match t with + | Typ_id _ -> NexpSet.empty + | Typ_var kid -> NexpSet.singleton (orig_nexp (nvar kid)) + | Typ_fn (t1,t2,_) -> NexpSet.union (trec t1) (trec t2) + | Typ_tup ts -> + List.fold_left (fun s t -> NexpSet.union s (trec t)) + NexpSet.empty ts + | 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 m = nexp_simp m in + if mwords && is_bit_typ elem_typ && not (is_nexp_constant m) then + NexpSet.singleton (orig_nexp m) + else trec elem_typ + (* NexpSet.union + (if mwords then tyvars_of_nexp (nexp_simp m) else NexpSet.empty) + (trec elem_typ) *) + | Typ_app(Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + if sequential then trec etyp else NexpSet.empty + | Typ_app(Id_aux (Id "range", _),_) + | Typ_app(Id_aux (Id "implicit", _),_) + | Typ_app(Id_aux (Id "atom", _), _) -> NexpSet.empty + | Typ_app (_,tas) -> + List.fold_left (fun s ta -> NexpSet.union s (lem_nexps_of_typ_arg sequential mwords ta)) + NexpSet.empty tas + | Typ_exist (kids,_,t) -> + let s = trec t in + List.fold_left (fun s k -> NexpSet.remove k s) s (List.map nvar kids) +and lem_nexps_of_typ_arg sequential mwords (Typ_arg_aux (ta,_)) = + match ta with + | Typ_arg_nexp nexp -> NexpSet.singleton (nexp_simp (orig_nexp nexp)) + | Typ_arg_typ typ -> lem_nexps_of_typ sequential mwords typ + | Typ_arg_order _ -> NexpSet.empty + +let lem_tyvars_of_typ sequential mwords typ = + NexpSet.fold (fun nexp ks -> KidSet.union ks (tyvars_of_nexp nexp)) + (lem_nexps_of_typ sequential mwords typ) KidSet.empty + +(* When making changes here, check whether they affect lem_tyvars_of_typ *) let doc_typ_lem, doc_atomic_typ_lem = (* following the structure of parser for precedence *) - let rec typ regtypes ty = fn_typ regtypes true ty - and typ' regtypes ty = fn_typ regtypes false ty - and fn_typ regtypes atyp_needed ((Typ_aux (t, _)) as ty) = match t with + let rec typ sequential mwords ty = fn_typ sequential mwords true ty + and typ' sequential mwords ty = fn_typ sequential mwords false ty + and fn_typ (sequential : bool) (mwords : bool) atyp_needed ((Typ_aux (t, _)) as ty) = match t with | Typ_fn(arg,ret,efct) -> (*let exc_typ = string "string" in*) let ret_typ = if effectful efct - then separate space [string "M";(*parens exc_typ;*) fn_typ regtypes true ret] - else separate space [fn_typ regtypes false ret] in - let tpp = separate space [tup_typ regtypes true arg; arrow;ret_typ] in + then separate space [string "_M";(*parens exc_typ;*) fn_typ sequential mwords true ret] + else separate space [fn_typ sequential mwords false ret] in + let tpp = separate space [tup_typ sequential mwords true arg; arrow;ret_typ] in (* once we have proper excetions we need to know what the exceptions type is *) if atyp_needed then parens tpp else tpp - | _ -> tup_typ regtypes atyp_needed ty - and tup_typ regtypes atyp_needed ((Typ_aux (t, _)) as ty) = match t with + | _ -> tup_typ sequential mwords atyp_needed ty + and tup_typ sequential mwords atyp_needed ((Typ_aux (t, _)) as ty) = match t with | Typ_tup typs -> - let tpp = separate_map (space ^^ star ^^ space) (app_typ regtypes false) typs in + let tpp = separate_map (space ^^ star ^^ space) (app_typ sequential mwords false) typs in + if atyp_needed then parens tpp else tpp + | _ -> app_typ sequential mwords atyp_needed ty + and app_typ sequential mwords atyp_needed ((Typ_aux (t, l)) as ty) = match t with + | 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",_)),_) when mwords -> + string "bitvector " ^^ doc_nexp_lem (nexp_simp m) + (* (match nexp_simp m with + | (Nexp_aux(Nexp_constant i,_)) -> string "bitvector ty" ^^ doc_int i + | (Nexp_aux(Nexp_var _, _)) -> separate space [string "bitvector"; doc_nexp m] + | _ -> raise (Reporting_basic.err_unreachable l + "cannot pretty-print bitvector type with non-constant length")) *) + | _ -> string "vector" ^^ space ^^ typ sequential mwords elem_typ in 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 "register", _), [Typ_arg_aux (Typ_arg_typ etyp, _)]) -> + (* TODO: Better distinguish register names and contents? *) + (* fn_typ regtypes atyp_needed etyp *) + let tpp = + if sequential + then string "register_ref regstate " ^^ typ sequential mwords etyp + else string "register" in if atyp_needed then parens tpp else tpp | Typ_app(Id_aux (Id "range", _),_) -> (string "integer") @@ -170,157 +282,327 @@ let doc_typ_lem, doc_atomic_typ_lem = | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> (string "integer") | Typ_app(id,args) -> - let tpp = (doc_id_lem_type id) ^^ space ^^ (separate_map space (doc_typ_arg_lem regtypes) args) in + let tpp = (doc_id_lem_type id) ^^ space ^^ (separate_map space (doc_typ_arg_lem sequential mwords) args) in if atyp_needed then parens tpp else tpp - | _ -> atomic_typ regtypes atyp_needed ty - and atomic_typ regtypes atyp_needed ((Typ_aux (t, _)) as ty) = match t with - | Typ_id (Id_aux (Id "bool",_)) -> string "bitU" - | Typ_id (Id_aux (Id "boolean",_)) -> string "bitU" + | _ -> atomic_typ sequential mwords atyp_needed ty + and atomic_typ sequential mwords atyp_needed ((Typ_aux (t, l)) as ty) = match t with + | Typ_id (Id_aux (Id "bool",_)) -> string "bool" | 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 + else*) doc_id_lem_type id | Typ_var v -> doc_var v - | Typ_wild -> underscore | Typ_app _ | Typ_tup _ | Typ_fn _ -> (* exhaustiveness matters here to avoid infinite loops * if we add a new Typ constructor *) - let tpp = typ regtypes ty in + let tpp = typ sequential mwords 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_nexp n -> empty + | Typ_exist (kids,_,ty) -> begin + let tpp = typ sequential mwords ty in + let visible_vars = lem_tyvars_of_typ sequential mwords ty in + match List.filter (fun kid -> KidSet.mem kid visible_vars) kids with + | [] -> if atyp_needed then parens tpp else tpp + | bad -> raise (Reporting_basic.err_general l + ("Existential type variable(s) " ^ + String.concat ", " (List.map string_of_kid bad) ^ + " escape into Lem")) + end + and doc_typ_arg_lem sequential mwords (Typ_arg_aux(t,_)) = match t with + | Typ_arg_typ t -> app_typ sequential mwords true t + | Typ_arg_nexp n -> doc_nexp_lem (nexp_simp n) | Typ_arg_order o -> empty - | Typ_arg_effect e -> empty in typ', atomic_typ +(* 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 mwords (Typ_aux (t,a) as typ) = match t with + | Typ_id _ -> false + | Typ_var _ -> true + | Typ_exist _ -> true + | Typ_fn (t1,t2,_) -> contains_t_pp_var mwords t1 || contains_t_pp_var mwords t2 + | Typ_tup ts -> List.exists (contains_t_pp_var mwords) ts + | Typ_app (c,targs) -> + if Ast_util.is_number typ then false + else if is_bitvector_typ typ then + let (_,length,_,_) = vector_typ_args_of typ in + let length = nexp_simp length in + not (is_nexp_constant length || + (mwords && match length with Nexp_aux (Nexp_var _,_) -> true | _ -> false)) + else List.exists (contains_t_arg_pp_var mwords) targs +and contains_t_arg_pp_var mwords (Typ_arg_aux (targ, _)) = match targ with + | Typ_arg_typ t -> contains_t_pp_var mwords t + | Typ_arg_nexp nexp -> not (is_nexp_constant (nexp_simp nexp)) + | _ -> false + +let doc_tannot_lem sequential mwords eff typ = + if contains_t_pp_var mwords typ then empty + else + let ta = doc_typ_lem sequential mwords 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 ? *) -let doc_lit_lem in_pat (L_aux(lit,l)) a = - utf8string (match lit with - | L_unit -> "()" - | L_zero -> "B0" - | L_one -> "B1" - | L_false -> "B0" - | L_true -> "B1" +let doc_lit_lem sequential mwords in_pat (L_aux(lit,l)) a = + match lit with + | L_unit -> utf8string "()" + | L_zero -> utf8string "B0" + | L_one -> utf8string "B1" + | L_false -> utf8string "false" + | L_true -> utf8string "true" | L_num i -> - let ipp = string_of_int i in - if in_pat then "("^ipp^":nn)" - else if i < 0 then "((0"^ipp^"):ii)" - else "("^ipp^":ii)" + let ipp = string_of_big_int i in + utf8string ( + if in_pat then "("^ipp^":nn)" + else if lt_big_int i zero_big_int then "((0"^ipp^"):ii)" + else "("^ipp^":ii)") | 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\")") - | L_string s -> "\"" ^ s ^ "\"") + (match a with + | Some (_, (Typ_aux (t,_) as typ), _) -> + (match t with + | Typ_id (Id_aux (Id "bit", _)) + | Typ_app (Id_aux (Id "register", _),_) -> utf8string "UndefinedRegister 0" + | Typ_id (Id_aux (Id "string", _)) -> utf8string "\"\"" + | _ -> + let ta = if contains_t_pp_var mwords typ then empty + else doc_tannot_lem sequential mwords false typ in + parens + ((utf8string "(failwith \"undefined value of unsupported type\")") ^^ ta)) + | _ -> utf8string "(failwith \"undefined value of unsupported type\")") + | L_string s -> utf8string ("\"" ^ s ^ "\"") + | L_real s -> + (* Lem does not support decimal syntax, so we translate a string + of the form "x.y" into the ratio (x * 10^len(y) + y) / 10^len(y). + The OCaml library has a conversion function from strings to floats, but + not from floats to ratios. ZArith's Q library does have the latter, but + using this would require adding a dependency on ZArith to Sail. *) + let parts = Util.split_on_char '.' s in + let (num, denom) = match parts with + | [i] -> (big_int_of_string i, unit_big_int) + | [i;f] -> + let denom = power_int_positive_int 10 (String.length f) in + (add_big_int (mult_big_int (big_int_of_string i) denom) (big_int_of_string f), denom) + | _ -> + raise (Reporting_basic.Fatal_error + (Reporting_basic.Err_syntax_locn (l, "could not parse real literal"))) in + separate space (List.map string ["realFromFrac"; string_of_big_int num; string_of_big_int denom]) (* typ_doc is the doc for the type being quantified *) - -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 doc_quant_item vars_included (QI_aux (qi, _)) = match qi with +| QI_id (KOpt_aux (KOpt_none kid, _)) +| QI_id (KOpt_aux (KOpt_kind (_, kid), _)) -> + (match vars_included with + None -> doc_var kid + | Some set -> (*when KidSet.mem kid set -> doc_var kid*) + let nexps = NexpSet.filter (fun nexp -> KidSet.mem (orig_kid kid) (nexp_frees nexp)) set in + separate_map space doc_nexp_lem (NexpSet.elements nexps) + | _ -> empty) +| _ -> empty + +let doc_typquant_items_lem vars_included (TypQ_aux(tq,_)) = match tq with +| TypQ_tq qs -> separate_map space (doc_quant_item vars_included) qs +| _ -> empty + +let doc_typquant_lem (TypQ_aux(tq,_)) vars_included typ = match tq with +| TypQ_tq ((_ :: _) as qs) -> + string "forall " ^^ separate_map space (doc_quant_item vars_included) qs ^^ string ". " ^^ typ +| _ -> typ + +(* Produce Size type constraints for bitvector sizes when using + machine words. Often these will be unnecessary, but this simple + approach will do for now. *) + +let rec typeclass_nexps (Typ_aux(t,_)) = match t with +| Typ_id _ +| Typ_var _ + -> NexpSet.empty +| Typ_fn (t1,t2,_) -> NexpSet.union (typeclass_nexps t1) (typeclass_nexps t2) +| Typ_tup ts -> List.fold_left NexpSet.union NexpSet.empty (List.map typeclass_nexps ts) +| Typ_app (Id_aux (Id "vector",_), + [_;Typ_arg_aux (Typ_arg_nexp size_nexp,_); + _;Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id (Id_aux (Id "bit",_)),_)),_)]) +| Typ_app (Id_aux (Id "itself",_), + [Typ_arg_aux (Typ_arg_nexp size_nexp,_)]) -> + let size_nexp = nexp_simp size_nexp in + if is_nexp_constant size_nexp then NexpSet.empty else + NexpSet.singleton (orig_nexp size_nexp) +| Typ_app _ -> NexpSet.empty +| Typ_exist (kids,_,t) -> NexpSet.empty (* todo *) + +let doc_typclasses_lem mwords t = + if mwords then + let nexps = typeclass_nexps t in + if NexpSet.is_empty nexps then (empty, NexpSet.empty) else + (separate_map comma_sp (fun nexp -> string "Size " ^^ doc_nexp_lem nexp) (NexpSet.elements nexps) ^^ string " => ", nexps) + else (empty, NexpSet.empty) + +let doc_typschm_lem sequential mwords quants (TypSchm_aux(TypSchm_ts(tq,t),_)) = + let pt = doc_typ_lem sequential mwords t in + if quants + then + let nexps_used = lem_nexps_of_typ sequential mwords t in + let ptyc, nexps_sizes = doc_typclasses_lem mwords t in + let nexps_to_include = NexpSet.union nexps_used nexps_sizes in + if NexpSet.is_empty nexps_to_include + then pt + else doc_typquant_lem tq (Some nexps_to_include) (ptyc ^^ pt) + else pt + +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 +let rec doc_pat_lem sequential mwords apat_needed (P_aux (p,(l,annot)) as pa) = match p with | P_app(id, ((_ :: _) as pats)) -> - (match annot with - | Base(_,(Constructor _ | Enum _),_,_,_,_) -> - 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 - | _ -> empty) - | P_lit lit -> doc_lit_lem true lit annot + let ppp = doc_unop (doc_id_lem_ctor id) + (parens (separate_map comma (doc_pat_lem sequential mwords true) pats)) in + if apat_needed then parens ppp else ppp + | P_app(id,[]) -> doc_id_lem_ctor id + | P_lit lit -> doc_lit_lem sequential mwords true lit annot | P_wild -> underscore | P_id id -> begin match id with | 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_var(p,kid) -> doc_pat_lem sequential mwords true p + | P_as(p,id) -> parens (separate space [doc_pat_lem sequential mwords true p; string "as"; doc_id_lem id]) + | P_typ(typ,p) -> + let doc_p = doc_pat_lem sequential mwords true p in + if contains_t_pp_var mwords typ then doc_p + else parens (doc_op colon doc_p (doc_typ_lem sequential mwords typ)) | P_vector pats -> let ppp = (separate space) - [string "Vector";brackets (separate_map semi (doc_pat_lem regtypes true) pats);underscore;underscore] in + [string "Vector";brackets (separate_map semi (doc_pat_lem sequential mwords true) pats);underscore;underscore] in if apat_needed then parens ppp else ppp | P_vector_concat pats -> - let ppp = - (separate space) - [string "Vector";parens (separate_map (string "::") (doc_pat_lem regtypes true) pats);underscore;underscore] in - if apat_needed then parens ppp else ppp + raise (Reporting_basic.err_unreachable l + "vector concatenation patterns should have been removed before pretty-printing") | P_tup pats -> (match pats with - | [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] -> doc_pat_lem sequential mwords apat_needed p + | _ -> parens (separate_map comma_sp (doc_pat_lem sequential mwords false) pats)) + | P_list pats -> brackets (separate_map semi (doc_pat_lem sequential mwords false) pats) (*Never seen but easy in lem*) + | P_cons (p,p') -> doc_op (string "::") (doc_pat_lem sequential mwords true p) (doc_pat_lem sequential mwords true p') + | P_record (_,_) -> empty (* TODO *) + +let rec typ_needs_printed (Typ_aux (t,_) as typ) = match t with + | Typ_tup ts -> List.exists typ_needs_printed ts + | Typ_app (Id_aux (Id "itself",_),_) -> true + | Typ_app (_, targs) -> is_bitvector_typ typ || List.exists typ_needs_printed_arg targs + | Typ_fn (t1,t2,_) -> typ_needs_printed t1 || typ_needs_printed t2 + | _ -> false +and typ_needs_printed_arg (Typ_arg_aux (targ, _)) = match targ with + | Typ_arg_typ t -> typ_needs_printed t + | _ -> false + +let contains_early_return exp = + fst (fold_exp + { (Rewriter.compute_exp_alg false (||)) + with e_return = (fun (_, r) -> (true, E_return r)) } exp) + +let typ_id_of (Typ_aux (typ, l)) = match typ with + | Typ_id id -> id + | Typ_app (register, [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id id, _)), _)]) + when string_of_id register = "register" -> id + | Typ_app (id, _) -> id + | _ -> raise (Reporting_basic.err_unreachable l "failed to get type id") 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 expY = top_exp regtypes true in - let expN = top_exp regtypes false in - let expV = top_exp regtypes in + let rec top_exp sequential mwords (early_ret : bool) (aexp_needed : bool) + (E_aux (e, (l,annot)) as full_exp) = + let expY = top_exp sequential mwords early_ret true in + let expN = top_exp sequential mwords early_ret false in + let expV = top_exp sequential mwords early_ret in + let liftR doc = + if early_ret && effectful (effect_of full_exp) + then separate space [string "liftR"; parens (doc)] + else doc 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 ((LEXP_aux (_, lannot) as le),id), fannot) -> + if is_bit_typ (typ_of_annot fannot) then raise (report l "indexing a register's (single bit) bitfield not supported") else - (prefix 2 1) + let field_ref = + doc_id_lem (typ_id_of (typ_of_annot lannot)) ^^ + underscore ^^ + doc_id_lem id in + liftR ((prefix 2 1) (string "write_reg_field_range") - (align (doc_lexp_deref_lem regtypes le ^^ space^^ - string_lit (doc_id_lem id) ^/^ expY e2 ^/^ expY e3 ^/^ expY e)) + (align (doc_lexp_deref_lem sequential mwords early_ret le ^/^ + field_ref ^/^ expY e2 ^/^ expY e3 ^/^ expY e))) | _ -> - (prefix 2 1) + let deref = doc_lexp_deref_lem sequential mwords early_ret le in + liftR ((prefix 2 1) (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"})),_ -> + (align (deref ^/^ expY e2 ^/^ expY e3) ^/^ expY e))) + | LEXP_vector (le,e2) -> (match le with - | LEXP_aux (LEXP_field (le,id), (_,((Base ((_,{t = t}),_,_,_,_,_))))) -> - if t = Tid "bit" then + | LEXP_aux (LEXP_field ((LEXP_aux (_, lannot) as le),id), fannot) -> + if is_bit_typ (typ_of_annot fannot) then raise (report l "indexing a register's (single bit) bitfield not supported") else - (prefix 2 1) - (string "write_reg_field_bit") - (align (doc_lexp_deref_lem regtypes le ^^ space ^^ doc_id_lem id ^/^ expY e2 ^/^ expY e)) - | _ -> - (prefix 2 1) - (string "write_reg_bit") - (doc_lexp_deref_lem regtypes le ^^ space ^^ expY e2 ^/^ expY e) + let field_ref = + doc_id_lem (typ_id_of (typ_of_annot lannot)) ^^ + underscore ^^ + doc_id_lem id in + let call = if is_bitvector_typ (Env.base_typ_of (env_of full_exp) (typ_of_annot fannot)) then "write_reg_field_bit" else "write_reg_field_pos" in + liftR ((prefix 2 1) + (string call) + (align (doc_lexp_deref_lem sequential mwords early_ret le ^/^ + field_ref ^/^ expY e2 ^/^ expY e))) + | LEXP_aux (_, lannot) -> + (match le with + | LEXP_aux (_, (_, Some (_, Typ_aux (Typ_app (vector, [_; _; _; Typ_arg_aux (Typ_arg_typ etyp, _)]), _), _))) + when is_reftyp etyp && string_of_id vector = "vector" -> + (* Special case vectors of register references *) + let deref = + parens (separate space [ + string "access"; + expY (lexp_to_exp le); + expY e2 + ]) in + liftR ((prefix 2 1) (string "write_reg") (deref ^/^ expY e)) + | _ -> + let deref = doc_lexp_deref_lem sequential mwords early_ret le in + let call = if is_bitvector_typ (Env.base_typ_of (env_of full_exp) (typ_of_annot lannot)) then "write_reg_bit" else "write_reg_pos" in + liftR ((prefix 2 1) (string call) + (deref ^/^ expY e2 ^/^ expY e))) ) - | LEXP_field (le,id), (Tid "bit"| Tabbrev (_,{t=Tid "bit"})), _ -> - (prefix 2 1) + (* | LEXP_field (le,id) when is_bit_typ t -> + liftR ((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), _, _ -> - (prefix 2 1) + (doc_lexp_deref_lem sequential mwords early_ret le ^^ space ^^ string_lit(doc_id_lem id) ^/^ expY e)) *) + | LEXP_field ((LEXP_aux (_, lannot) as le),id) -> + let field_ref = + doc_id_lem (typ_id_of (typ_of_annot lannot)) ^^ + underscore ^^ + doc_id_lem id (*^^ + dot ^^ + string "set_field"*) in + liftR ((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 -> + (doc_lexp_deref_lem sequential mwords early_ret le ^^ space ^^ + field_ref ^/^ expY e)) + (* | (LEXP_id id | LEXP_cast (_,id)), t, Alias alias_info -> (match alias_info with | Alias_field(reg,field) -> let f = match t with @@ -332,18 +614,27 @@ 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) -> + liftR ((prefix 2 1) (string "write_reg") (doc_lexp_deref_lem sequential mwords early_ret le ^/^ expY e))) + | E_vector_append(le,re) -> + raise (Reporting_basic.err_unreachable l + "E_vector_append should have been rewritten before pretty-printing") + (* 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 mwords t) + then ("bitvector_concat", doc_tannot_lem sequential mwords 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 - if aexp_needed then parens epp else epp - | E_cons(l,r) -> doc_op (group (colon^^colon)) (expY l) (expY r) + align (group (separate space [string call;expY le;expY re])) ^^ ta in + if aexp_needed then parens epp else epp *) + | 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 = - separate space [string "if";group (align (string "bitU_to_bool" ^//^ group (expY c)))] ^^ + separate space [string "if";group (expY c)] ^^ break 1 ^^ (prefix 2 1 (string "then") (expN t)) ^^ (break 1) ^^ (prefix 2 1 (string "else") (expN e)) in @@ -351,7 +642,7 @@ let doc_exp_lem, doc_let_lem = | E_for(id,exp1,exp2,exp3,(Ord_aux(order,_)),exp4) -> raise (report l "E_for should have been removed till now") | E_let(leb,e) -> - let epp = let_exp regtypes leb ^^ space ^^ string "in" ^^ hardline ^^ expN e in + let epp = let_exp sequential mwords early_ret leb ^^ space ^^ string "in" ^^ hardline ^^ expN e in if aexp_needed then parens epp else epp | E_app(f,args) -> begin match f with @@ -361,12 +652,12 @@ let doc_exp_lem, doc_let_lem = let [id;indices;body;e5] = args in let varspp = match e5 with | E_aux (E_tuple vars,_) -> - let vars = List.map (fun (E_aux (E_id (Id_aux (Id name,_)),_)) -> string name) vars in + let vars = List.map (fun (E_aux (E_id id,_)) -> doc_id_lem id) vars in begin match vars with | [v] -> v | _ -> parens (separate comma vars) end - | E_aux (E_id (Id_aux (Id name,_)),_) -> - string name + | E_aux (E_id id,_) -> + doc_id_lem id | E_aux (E_lit (L_aux (L_unit,_)),_) -> string "_" in parens ( @@ -376,86 +667,171 @@ let doc_exp_lem, doc_let_lem = (prefix 1 1 (separate space [string "fun";expY id;varspp;arrow]) (expN body)) ) ) - | Id_aux (Id "append",_) -> + | Id_aux ((Id (("while_PP" | "while_PM" | + "while_MP" | "while_MM" | + "until_PP" | "until_PM" | + "until_MP" | "until_MM") as loopf),_)) -> + let [cond;body;e5] = args in + let varspp = match e5 with + | E_aux (E_tuple vars,_) -> + let vars = List.map (fun (E_aux (E_id id,_)) -> doc_id_lem id) vars in + begin match vars with + | [v] -> v + | _ -> parens (separate comma vars) end + | E_aux (E_id id,_) -> + doc_id_lem id + | E_aux (E_lit (L_aux (L_unit,_)),_) -> + string "_" in + parens ( + (prefix 2 1) + ((separate space) [string loopf; expY e5]) + ((prefix 0 1) + (parens (prefix 1 1 (separate space [string "fun";varspp;arrow]) (expN cond))) + (parens (prefix 1 1 (separate space [string "fun";varspp;arrow]) (expN body)))) + ) + (* | Id_aux (Id "append",_) -> let [e1;e2] = args in let epp = align (expY e1 ^^ space ^^ string "++" ^//^ expY e2) in 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 typ_needs_printed t && not (contains_t_pp_var mwords t) + then (align epp ^^ (doc_tannot_lem sequential mwords (effectful eff) t), true) + else (epp, aexp_needed) in + if aexp_needed then parens (align taepp) else taepp*) + | Id_aux (Id "length",_) -> + (* Another temporary hack: The sizeof rewriting introduces calls to + "length", and the disambiguation between the length function on + bitvectors and vectors of other element types should be done by + the type checker, but type checking after rewriting steps is + currently broken. *) + let [arg] = args in + let targ = typ_of arg in + let call = if (*mwords &&*) is_bitvector_typ targ then "bitvector_length" else "vector_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 _,_,_,_,_) -> - 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 + | Some (env, _, _) when (is_ctor env f) -> let epp = match args with | [] -> doc_id_lem_ctor f - | [arg] -> doc_id_lem_ctor f ^^ space ^^ argpp true arg + | [arg] -> doc_id_lem_ctor f ^^ space ^^ expV true arg | _ -> doc_id_lem_ctor f ^^ space ^^ - parens (separate_map comma (argpp false) args) in + parens (separate_map comma (expV false) args) in if aexp_needed then parens (align epp) else epp | _ -> let call = match annot with - | Base(_,External (Some n),_,_,_,_) -> string n + | Some (env, _, _) when Env.is_extern f env "lem" -> + string (Env.get_extern f env "lem") | _ -> 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 argspp = match args with - | [arg] -> argpp true arg - | args -> parens (align (separate_map (comma ^^ break 0) (argpp false) args)) in + | [arg] -> expV true arg + | args -> parens (align (separate_map (comma ^^ break 0) (expV 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 typ_needs_printed (Env.base_typ_of (env_of full_exp) t) + then (align epp ^^ (doc_tannot_lem sequential mwords (effectful eff) t), true) + else (epp, aexp_needed) in + liftR (if aexp_needed then parens (align taepp) else taepp) end end | E_vector_access (v,e) -> - let (Base (_,_,_,_,eff,_)) = annot in + let vtyp = Env.base_typ_of (env_of v) (typ_of v) in + let (start, len, ord, etyp) = vector_typ_args_of vtyp in + let ord_suffix = if is_order_inc ord then "_inc" else "_dec" in + let bit_prefix = if is_bitvector_typ vtyp then "bit" else "" in + let call = bit_prefix ^ "vector_access" ^ ord_suffix in + let start_idx = match nexp_simp (start) with + | Nexp_aux (Nexp_constant i, _) -> expN (simple_num l i) + | _ -> + let nc = nc_eq start (nminus len (nint 1)) in + if prove (env_of full_exp) nc + then string (bit_prefix ^ "vector_length") ^^ space ^^ expY v + else raise (Reporting_basic.err_unreachable l + ("cannot pretty print expression " ^ (string_of_exp full_exp) ^ + " with non-constant start index")) in + let epp = string call ^^ space ^^ parens (separate comma_sp [start_idx;expY v;expY e]) in + if aexp_needed then parens (align epp) else epp + (* raise (Reporting_basic.err_unreachable l + "E_vector_access should have been rewritten before pretty-printing") *) + (* 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 - if aexp_needed then parens (align epp) else epp + 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 vtyp = Env.base_typ_of (env_of v) (typ_of v) in + let (start, len, ord, etyp) = vector_typ_args_of vtyp in + let ord_suffix = if is_order_inc ord then "_inc" else "_dec" in + let bit_prefix = if is_bitvector_typ vtyp then "bit" else "" in + let call = bit_prefix ^ "vector_subrange" ^ ord_suffix in + let start_idx = match nexp_simp (start) with + | Nexp_aux (Nexp_constant i, _) -> expN (simple_num l i) + | _ -> + let nc = nc_eq start (nminus len (nint 1)) in + if prove (env_of full_exp) nc + then string (bit_prefix ^ "vector_length") ^^ space ^^ expY v + else raise (Reporting_basic.err_unreachable l + ("cannot pretty print expression " ^ (string_of_exp full_exp) ^ + " with non-constant start index")) in + let epp = string call ^^ space ^^ parens (separate comma_sp [start_idx;expY v;expY e1;expY e2]) in + if aexp_needed then parens (align epp) else epp + (* raise (Reporting_basic.err_unreachable l + "E_vector_subrange should have been rewritten before pretty-printing") *) + (* 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 typ_needs_printed t && not (contains_t_pp_var mwords t) + then (epp ^^ doc_tannot_lem sequential mwords true t, true) + else (epp, aexp_needed) else - align (string "slice" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2) in - if aexp_needed then parens (align epp) else epp + if is_bitvector_typ t then + let bepp = string "bvslice" ^^ space ^^ expY v ^//^ expY e1 ^//^ expY e2 in + if not (contains_t_pp_var mwords t) + then (bepp ^^ doc_tannot_lem sequential mwords 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 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},_) -> + let ft = typ_of_annot (l,fannot) in + (match fannot with + | Some(env, (Typ_aux (Typ_id tid, _)), _) + | Some(env, (Typ_aux (Typ_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (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 eff = effect_of full_exp in + let field_f = doc_id_lem tid ^^ underscore ^^ doc_id_lem id ^^ dot ^^ string "get_field" in + let (ta,aexp_needed) = + if typ_needs_printed t + then (doc_tannot_lem sequential mwords (effectful eff) t, true) + else (empty, aexp_needed) in + let epp = field_f ^^ space ^^ (expY fexp) in + 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 +840,118 @@ 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 -> - (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] - else - doc_id_lem id - | Base(_,(Constructor i |Enum i),_,_,_,_) -> doc_id_lem_ctor id - | Base((_,t),Alias alias_info,_,eff,_,_) -> + let env = env_of full_exp in + let typ = typ_of full_exp in + let eff = effect_of full_exp in + let base_typ = Env.base_typ_of env typ in + if has_effect eff BE_rreg then + let epp = separate space [string "read_reg";doc_id_lem id] in + if is_bitvector_typ base_typ + then liftR (parens (epp ^^ doc_tannot_lem sequential mwords true base_typ)) + else liftR epp + else if is_ctor env id then doc_id_lem_ctor id + else doc_id_lem 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 typ_needs_printed t && not (contains_t_pp_var mwords t) + then doc_tannot_lem sequential mwords 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 typ_needs_printed t && not (contains_t_pp_var mwords t) + then doc_tannot_lem sequential mwords 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 - ) - | _ -> doc_id_lem id) - | E_lit lit -> doc_lit_lem false lit annot - | E_cast(Typ_aux (typ,_),e) -> + let epp = + if start = stop then + separate space [string "read_reg_bit";string reg;doc_int start] + else + let ta = + if typ_needs_printed t && not (contains_t_pp_var mwords t) + then doc_tannot_lem sequential mwords 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 + )*) + | E_lit lit -> doc_lit_lem sequential mwords false lit annot + | E_cast(typ,e) -> + 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 typ_needs_printed t && not (contains_t_pp_var mwords t) + then parens (epp ^^ doc_tannot_lem sequential mwords 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 - | _ -> raise (report l "cannot get record type") in + let recordtyp = match annot with + | Some (env, Typ_aux (Typ_id tid,_), _) + | Some (env, Typ_aux (Typ_app (tid, _), _), _) -> + (* when Env.is_record tid env -> *) + tid + | _ -> raise (report l ("cannot get record type from annot " ^ string_of_annot annot ^ " of exp " ^ string_of_exp full_exp)) in let epp = anglebars (space ^^ (align (separate_map (semi_sp ^^ break 1) - (doc_fexp regtypes recordtyp) fexps)) ^^ space) in + (doc_fexp sequential mwords early_ret 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 - | _ -> raise (report l "cannot get record type") in - anglebars (doc_op (string "with") (expY e) (separate_map semi_sp (doc_fexp regtypes recordtyp) fexps)) + (* let (E_aux (_, (_, eannot))) = e in *) + let recordtyp = match annot with + | Some (env, Typ_aux (Typ_id tid,_), _) + | Some (env, Typ_aux (Typ_app (tid, _), _), _) + when Env.is_record tid env -> + tid + | _ -> raise (report l ("cannot get record type from annot " ^ string_of_annot annot ^ " of exp " ^ string_of_exp full_exp)) in + anglebars (doc_op (string "with") (expY e) (separate_map semi_sp (doc_fexp sequential mwords early_ret 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 nexp_simp start with + | Nexp_aux (Nexp_constant i, _) -> string_of_big_int i | _ -> if dir then "0" else string_of_int (List.length exps) in let expspp = match exps with @@ -566,107 +967,92 @@ 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 && mwords then + let bepp = string "vec_to_bvec" ^^ space ^^ parens (align epp) in + (bepp ^^ doc_tannot_lem sequential mwords 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)) - | _ -> 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 default_string = - match default with - | Def_val_empty -> - if is_bit_vector 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 - match t with - | Tapp ("register", - [TA_typ ({t = rt})]) -> - - 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) - | _ -> - raise ((Reporting_basic.err_unreachable dl) - ("not the right type information available to construct "^ - "undefined register")) in - parens (string ("UndefinedRegister " ^ string_of_big_int n)) - | _ -> expY e in - let iexp (i,e) = parens (doc_int i ^^ comma ^^ expN e) in - let expspp = - match iexps with - | [] -> empty - | e :: es -> - let (expspp,_) = - List.fold_left - (fun (pp,count) e -> - (pp ^^ semi ^^ (if count = 5 then break 1 else empty) ^^ iexp e), - if count = 5 then 0 else count + 1) - (iexp e,0) es in - align (expspp) 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 + (* *) | E_vector_update(v,e1,e2) -> - let epp = separate space [string "update_pos";expY v;expY e1;expY e2] in + let t = typ_of v in + let (start, len, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of full_exp) t) in + let ord_suffix = if is_order_inc ord then "_inc" else "_dec" in + let bit_prefix = if is_bitvector_typ t then "bit" else "" in + let call = bit_prefix ^ "vector_update_pos" ^ ord_suffix in + let start_idx = match nexp_simp (start) with + | Nexp_aux (Nexp_constant i, _) -> expN (simple_num l i) + | _ -> + let nc = nc_eq start (nminus len (nint 1)) in + if prove (env_of full_exp) nc + then string (bit_prefix ^ "vector_length") ^^ space ^^ expY v + else raise (Reporting_basic.err_unreachable l + ("cannot pretty print expression " ^ (string_of_exp full_exp) ^ + " with non-constant start index")) in + let epp = string call ^^ space ^^ parens (separate comma_sp [start_idx;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" ^//^ - group (group (expY v) ^/^ group (expY e1) ^/^ group (expY e2)) ^/^ - group (expY e3)) in + let t = typ_of v in + let (start, len, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of full_exp) t) in + let ord_suffix = if is_order_inc ord then "_inc" else "_dec" in + let bit_prefix = if is_bitvector_typ t then "bit" else "" in + let call = bit_prefix ^ "vector_update_subrange" ^ ord_suffix in + let start_idx = match nexp_simp (start) with + | Nexp_aux (Nexp_constant i, _) -> expN (simple_num l i) + | _ -> + let nc = nc_eq start (nminus len (nint 1)) in + if prove (env_of full_exp) nc + then string (bit_prefix ^ "vector_length") ^^ space ^^ expY v + else raise (Reporting_basic.err_unreachable l + ("cannot pretty print expression " ^ (string_of_exp full_exp) ^ + " with non-constant start index")) in + let epp = + align (string call ^//^ + parens (separate comma_sp + [start_idx; 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 pattern-matching on integers *) let epp = group ((separate space [string "match"; only_integers e; string "with"]) ^/^ - (separate_map (break 1) (doc_case regtypes) pexps) ^/^ + (separate_map (break 1) (doc_case sequential mwords early_ret) pexps) ^/^ (string "end")) in if aexp_needed then parens (align epp) else align epp - | E_exit e -> separate space [string "exit"; expY e;] + | E_exit e -> liftR (separate space [string "exit"; expY e;]) | E_assert (e1,e2) -> - let epp = separate space [string "assert'"; expY e1; expY e2] in + let epp = liftR (separate space [string "assert_exp"; 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 +1120,15 @@ let doc_exp_lem, doc_let_lem = | _ -> string name ^//^ parens (expN e1 ^^ comma ^/^ expN e2)) in + let (epp,aexp_needed) = + if typ_needs_printed t && not (contains_t_pp_var mwords t) + then (parens epp ^^ doc_tannot_lem sequential mwords 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 @@ -757,45 +1147,69 @@ let doc_exp_lem, doc_let_lem = (separate space [expV b e1; string ">>"]) ^^ hardline ^^ expN e2 | _ -> (separate space [expV b e1; string ">>= fun"; - doc_pat_lem regtypes true pat;arrow]) ^^ hardline ^^ expN e2 in + doc_pat_lem sequential mwords true pat;arrow]) ^^ hardline ^^ expN e2 in if aexp_needed then parens (align epp) else epp | E_internal_return (e1) -> separate space [string "return"; expY e1;] - and let_exp regtypes (LB_aux(lb,_)) = match lb with - | LB_val_explicit(_,pat,e) - | LB_val_implicit(pat,e) -> + | E_sizeof nexp -> + (match nexp_simp nexp with + | Nexp_aux (Nexp_constant i, _) -> doc_lit_lem sequential mwords 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 r -> + let ret_monad = if sequential then " : MR regstate" else " : MR" in + let ta = + if contains_t_pp_var mwords (typ_of full_exp) || contains_t_pp_var mwords (typ_of r) + then empty + else separate space + [string ret_monad; + parens (doc_typ_lem sequential mwords (typ_of full_exp)); + parens (doc_typ_lem sequential mwords (typ_of r))] in + align (parens (string "early_return" ^//^ expV true r ^//^ ta)) + | E_constraint _ | 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 sequential mwords early_ret (LB_aux(lb,_)) = match lb with + | LB_val(pat,e) -> prefix 2 1 - (separate space [string "let"; doc_pat_lem regtypes true pat; equals]) - (top_exp regtypes false e) + (separate space [string "let"; doc_pat_lem sequential mwords true pat; equals]) + (top_exp sequential mwords early_ret false e) - and doc_fexp regtypes recordtyp (FE_aux(FE_Fexp(id,e),_)) = + and doc_fexp sequential mwords early_ret 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)) + group (doc_op equals fname (top_exp sequential mwords early_ret true e)) - and doc_case regtypes (Pat_aux(Pat_exp(pat,e),_)) = - group (prefix 3 1 (separate space [pipe; doc_pat_lem regtypes false pat;arrow]) - (group (top_exp regtypes false e))) + and doc_case sequential mwords early_ret = function + | Pat_aux(Pat_exp(pat,e),_) -> + group (prefix 3 1 (separate space [pipe; doc_pat_lem sequential mwords false pat;arrow]) + (group (top_exp sequential mwords early_ret false e))) + | Pat_aux(Pat_when(_,_,_),(l,_)) -> + raise (Reporting_basic.err_unreachable l + "guarded pattern expression should have been rewritten before pretty-printing") - and doc_lexp_deref_lem regtypes ((LEXP_aux(lexp,(l,annot))) as le) = match lexp with + and doc_lexp_deref_lem sequential mwords early_ret ((LEXP_aux(lexp,(l,annot))) as le) = match lexp with | LEXP_field (le,id) -> - parens (separate empty [doc_lexp_deref_lem regtypes le;dot;doc_id_lem id]) + parens (separate empty [doc_lexp_deref_lem sequential mwords early_ret le;dot;doc_id_lem id]) | LEXP_vector(le,e) -> - parens ((separate space) [string "access";doc_lexp_deref_lem regtypes le; - top_exp regtypes true e]) + parens ((separate space) [string "access";doc_lexp_deref_lem sequential mwords early_ret le; + top_exp sequential mwords early_ret true e]) | LEXP_id id -> doc_id_lem id | LEXP_cast (typ,id) -> doc_id_lem id + | LEXP_tup lexps -> parens (separate_map comma_sp (doc_lexp_deref_lem sequential mwords early_ret) lexps) | _ -> raise (Reporting_basic.err_unreachable l ("doc_lexp_deref_lem: Shouldn't happen")) (* expose doc_exp_lem and doc_let *) in top_exp, let_exp (*TODO Upcase and downcase type and constructors as needed*) -let doc_type_union_lem regtypes (Tu_aux(typ_u,_)) = match typ_u with +let doc_type_union_lem sequential mwords (Tu_aux(typ_u,_)) = match typ_u with | Tu_ty_id(typ,id) -> separate space [pipe; doc_id_lem_ctor id; string "of"; - parens (doc_typ_lem regtypes typ)] + parens (doc_typ_lem sequential mwords typ)] | Tu_id id -> separate space [pipe; doc_id_lem_ctor id] let rec doc_range_lem (BF_aux(r,_)) = match r with @@ -803,37 +1217,82 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2)) | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) -let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with - | TD_abbrev(id,nm,typschm) -> - (doc_op equals (concat [string "type"; space; doc_id_lem_type id]) - (doc_typschm_lem regtypes typschm),empty) +let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with + | TD_abbrev(id,nm,(TypSchm_aux (TypSchm_ts (typq, _), _) as typschm)) -> + doc_op equals + (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) + (doc_typschm_lem sequential mwords false typschm) | TD_record(id,nm,typq,fs,_) -> - let f_pp (typ,fid) = - let fname = if prefix_recordtype - then concat [doc_id_lem id;string "_";doc_id_lem_type fid;] - else doc_id_lem_type fid in - concat [fname;space;colon;space;doc_typ_lem regtypes typ; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - (doc_op equals - (concat [string "type"; space; doc_id_lem_type id;]) - (doc_typquant_lem typq (anglebars (space ^^ align fs_doc ^^ space))),empty) + let fname fid = if prefix_recordtype + then concat [doc_id_lem id;string "_";doc_id_lem_type fid;] + else doc_id_lem_type fid in + let f_pp (typ,fid) = + concat [fname fid;space;colon;space;doc_typ_lem sequential mwords typ; semi] in + let rectyp = match typq with + | TypQ_aux (TypQ_tq qs, _) -> + let quant_item = function + | QI_aux (QI_id (KOpt_aux (KOpt_none kid, _)), l) + | QI_aux (QI_id (KOpt_aux (KOpt_kind (_, kid), _)), l) -> + [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid, l)), l)] + | _ -> [] in + let targs = List.concat (List.map quant_item qs) in + mk_typ (Typ_app (id, targs)) + | TypQ_aux (TypQ_no_forall, _) -> mk_id_typ id in + let fs_doc = group (separate_map (break 1) f_pp fs) in + let doc_field (ftyp, fid) = + let reftyp = + mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), + [mk_typ_arg (Typ_arg_typ rectyp); + mk_typ_arg (Typ_arg_typ ftyp)])) in + let rfannot = doc_tannot_lem sequential mwords false reftyp in + let get, set = + string "rec_val" ^^ dot ^^ fname fid, + anglebars (space ^^ string "rec_val with " ^^ + (doc_op equals (fname fid) (string "v")) ^^ space) in + let base_ftyp = match annot with + | Some (env, _, _) -> Env.base_typ_of env ftyp + | _ -> ftyp in + let (start, is_inc) = + try + let (start, _, ord, _) = vector_typ_args_of base_ftyp in + match nexp_simp start with + | Nexp_aux (Nexp_constant i, _) -> (i, is_order_inc ord) + | _ -> + raise (Reporting_basic.err_unreachable Parse_ast.Unknown + ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) + with + | _ -> (zero_big_int, true) in + doc_op equals + (concat [string "let "; parens (concat [doc_id_lem id; underscore; doc_id_lem fid; rfannot])]) + (anglebars (concat [space; + doc_op equals (string "field_name") (string_lit (doc_id_lem fid)); semi_sp; + doc_op equals (string "field_start") (string (string_of_big_int start)); semi_sp; + doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp; + doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp; + doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in + doc_op equals + (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq]) + ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline ^^ + if sequential && string_of_id id = "regstate" then empty + else separate_map hardline doc_field fs | TD_variant(id,nm,typq,ar,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> (empty,empty) - | Id_aux ((Id "write_kind"),_) -> (empty,empty) - | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) - | Id_aux ((Id "trans_kind"),_) -> (empty,empty) - | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) - | Id_aux ((Id "regfp"),_) -> (empty,empty) - | Id_aux ((Id "niafp"),_) -> (empty,empty) - | Id_aux ((Id "diafp"),_) -> (empty,empty) + | Id_aux ((Id "read_kind"),_) -> empty + | Id_aux ((Id "write_kind"),_) -> empty + | Id_aux ((Id "barrier_kind"),_) -> empty + | Id_aux ((Id "trans_kind"),_) -> empty + | Id_aux ((Id "instruction_kind"),_) -> empty + (* | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty *) + | Id_aux ((Id "option"),_) -> empty | _ -> - let ar_doc = group (separate_map (break 1) (doc_type_union_lem regtypes) ar) in + let ar_doc = group (separate_map (break 1) (doc_type_union_lem sequential mwords) ar) in let typ_pp = (doc_op equals) - (concat [string "type"; space; doc_id_lem_type id;]) - (doc_typquant_lem typq ar_doc) in + (concat [string "type"; space; doc_id_lem_type id; space; doc_typquant_items_lem None typq]) + ((*doc_typquant_lem typq*) ar_doc) in let make_id pat id = separate space [string "Interp_ast.Id_aux"; parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); @@ -995,34 +1454,103 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with | TD_register(id,n1,n2,rs) -> match n1,n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> + let dir_b = i1 < i2 in + let dir = (if dir_b then "true" else "false") in + let dir_suffix = (if dir_b then "_inc" else "_dec") in + let ord = Ord_aux ((if dir_b then Ord_inc else Ord_dec), Parse_ast.Unknown) in + let size = if dir_b then add_big_int (sub_big_int i2 i1) unit_big_int else add_big_int (sub_big_int i1 i2) unit_big_int in + let vtyp = vector_typ (nconstant i1) (nconstant size) ord bit_typ in + let tannot = doc_tannot_lem sequential mwords false vtyp in let doc_rid (r,id) = parens (separate comma_sp [string_lit (doc_id_lem id); doc_range_lem r;]) in let doc_rids = group (separate_map (semi ^^ (break 1)) doc_rid rs) in - (*let doc_rfield (_,id) = - (doc_op equals) - (string "let" ^^ space ^^ doc_id_lem id) - (string "Register_field" ^^ space ^^ string_lit(doc_id_lem id)) in*) - let dir_b = i1 < i2 in - let dir = string (if dir_b then "true" else "false") in - let size = if dir_b then i2-i1 +1 else i1-i2 + 1 in - ((doc_op equals) - (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) - (string "Register" ^^ space ^^ - align (separate space [string "regname"; doc_int size; doc_int i1; dir; - break 0 ^^ brackets (align doc_rids)])),empty) - (*^^ hardline ^^ - separate_map hardline doc_rfield rs *) + let doc_field (fr, fid) = + let i, j = match fr with + | BF_aux (BF_single i, _) -> (i, i) + | BF_aux (BF_range (i, j), _) -> (i, j) + | _ -> raise (Reporting_basic.err_unreachable l "unsupported field type") in + let fsize = if dir_b then add_big_int (sub_big_int j i) unit_big_int else add_big_int (sub_big_int i j) unit_big_int in + let ftyp = vector_typ (nconstant i) (nconstant fsize) ord bit_typ in + let reftyp = + mk_typ (Typ_app (Id_aux (Id "field_ref", Parse_ast.Unknown), + [mk_typ_arg (Typ_arg_typ (mk_id_typ id)); + mk_typ_arg (Typ_arg_typ ftyp)])) in + let rfannot = doc_tannot_lem sequential mwords false reftyp in + let id_exp id = E_aux (E_id (mk_id id), simple_annot l vtyp) in + let get, set = + E_aux (E_vector_subrange (id_exp "reg", simple_num l i, simple_num l j), simple_annot l ftyp), + E_aux (E_vector_update_subrange (id_exp "reg", simple_num l i, simple_num l j, id_exp "v"), simple_annot l ftyp) in + (* "bitvector_subrange" ^ dir_suffix ^ " (" ^ string_of_int i1 ^ ", reg, " ^ string_of_int i ^ ", " ^ string_of_int j ^ ")", + "bitvector_update_subrange" ^ dir_suffix ^ " (" ^ string_of_int i1 ^ ", reg, " ^ string_of_int i ^ ", " ^ string_of_int j ^ ", v)" in *) + doc_op equals + (concat [string "let "; parens (concat [doc_id_lem id; underscore; doc_id_lem fid; rfannot])]) + (concat [ + space; langlebar; string " field_name = \"" ^^ doc_id_lem fid ^^ string "\";"; hardline; + space; space; space; string (" field_start = " ^ string_of_big_int i ^ ";"); hardline; + space; space; space; string (" field_is_inc = " ^ dir ^ ";"); hardline; + space; space; space; string " get_field = (fun reg -> " ^^ doc_exp_lem sequential mwords false false get ^^ string ");"; hardline; + space; space; space; string " set_field = (fun reg v -> " ^^ doc_exp_lem sequential mwords false false set ^^ string ") "; ranglebar]) + in + doc_op equals + (concat [string "type";space;doc_id_lem id]) + (doc_typ_lem sequential mwords vtyp) + ^^ hardline ^^ + doc_op equals + (concat [string "let";space;string "cast_";doc_id_lem id;space;string "reg"]) + (string "reg") + ^^ hardline ^^ + doc_op equals + (concat [string "let";space;string "cast_to_";doc_id_lem id;space;string "reg"]) + (string "reg") + ^^ hardline ^^ + (* if sequential then *) + (* string " = <|" (*; parens (string "reg" ^^ tannot) *)]) ^^ hardline ^^ + string (" get_field = (fun reg -> " ^ get ^ ");") ^^ hardline ^^ + string (" set_field = (fun reg v -> " ^ set ^") |>") *) + (* doc_op equals + (concat [string "let set_"; doc_id_lem id; underscore; doc_id_lem fid; + space; parens (separate comma_sp [parens (string "reg" ^^ tannot); string "v"])]) (string set) *) + (* in *) + (* doc_op equals + (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) + (string "Register" ^^ space ^^ + align (separate space [string "regname"; doc_int size; doc_int i1; dir; + break 0 ^^ brackets (align doc_rids)])) + ^^ hardline ^^ *) + separate_map hardline doc_field rs + ^^ hardline ^^ + (* else *) + (*let doc_rfield (_,id) = + (doc_op equals) + (string "let" ^^ space ^^ doc_id_lem id) + (string "Register_field" ^^ space ^^ string_lit(doc_id_lem id)) in*) + doc_op equals + (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) + (string "Register" ^^ space ^^ + align (separate space [string "regname"; doc_int size; doc_int i1; string dir; + break 0 ^^ brackets (align doc_rids)])) + (*^^ hardline ^^ + separate_map hardline doc_field rs*) + | _ -> raise (Reporting_basic.err_unreachable l "register with non-constant indices") + let doc_rec_lem (Rec_aux(r,_)) = match r with | Rec_nonrec -> space | Rec_rec -> space ^^ string "rec" ^^ space -let doc_tannot_opt_lem regtypes (Typ_annot_opt_aux(t,_)) = match t with - | Typ_annot_opt_some(tq,typ) -> doc_typquant_lem tq (doc_typ_lem regtypes typ) +let doc_tannot_opt_lem sequential mwords (Typ_annot_opt_aux(t,_)) = match t with + | Typ_annot_opt_some(tq,typ) -> (*doc_typquant_lem tq*) (doc_typ_lem sequential mwords typ) + +let doc_fun_body_lem sequential mwords exp = + let early_ret =contains_early_return exp in + let doc_exp = doc_exp_lem sequential mwords early_ret false exp in + if early_ret + then align (string "catch_early_return" ^//^ parens (doc_exp)) + else doc_exp -let doc_funcl_lem regtypes (FCL_aux(FCL_Funcl(id,pat,exp),_)) = - group (prefix 3 1 ((doc_pat_lem regtypes false pat) ^^ space ^^ arrow) - (doc_exp_lem regtypes false exp)) +let doc_funcl_lem sequential mwords (FCL_aux(FCL_Funcl(id,pat,exp),_)) = + group (prefix 3 1 ((doc_pat_lem sequential mwords false pat) ^^ space ^^ arrow) + (doc_fun_body_lem sequential mwords exp)) let get_id = function | [] -> failwith "FD_function with empty list" @@ -1030,141 +1558,162 @@ let get_id = function module StringSet = Set.Make(String) -let rec doc_fundef_lem regtypes (FD_aux(FD_function(r, typa, efa, fcls),fannot)) = - match fcls with +let doc_fundef_rhs_lem sequential mwords (FD_aux(FD_function(r, typa, efa, funcls),fannot) as fd) = + match funcls with | [] -> failwith "FD_function with empty function list" - | [FCL_aux (FCL_Funcl(id,pat,exp),_)] -> - (prefix 2 1) - ((separate space) - [(string "let") ^^ (doc_rec_lem r) ^^ (doc_id_lem id); - (doc_pat_lem regtypes true pat); - equals]) - (doc_exp_lem regtypes false exp) + | [FCL_aux(FCL_Funcl(id,pat,exp),_)] -> + (prefix 2 1) + ((separate space) + [doc_id_lem id; + (doc_pat_lem sequential mwords true pat); + equals]) + (doc_fun_body_lem sequential mwords exp) | _ -> - let id = get_id fcls in - (* let sep = hardline ^^ pipe ^^ space in *) - match id with - | Id_aux (Id fname,idl) - when fname = "execute" || fname = "initial_analysis" -> - let (_,auxiliary_functions,clauses) = - List.fold_left - (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 rec pick_name_not_clashing_with already_used candidate = - if StringSet.mem candidate already_used then - pick_name_not_clashing_with already_used (candidate ^ "'") - else candidate in - let aux_fname = pick_name_not_clashing_with already_used_fnames (fname ^ "_" ^ ctor) in - let already_used_fnames = StringSet.add aux_fname already_used_fnames in - let fcl = FCL_aux (FCL_Funcl (Id_aux (Id aux_fname,l), - P_aux (P_tup argspat,pannot),exp),annot) in - let auxiliary_functions = - auxiliary_functions ^^ hardline ^^ hardline ^^ - doc_fundef_lem regtypes (FD_aux (FD_function(r,typa,efa,[fcl]),fannot)) in - (* Bind complex patterns to names so that we can pass them to the - auxiliary function *) - let name_pat idx (P_aux (p,a)) = match p with - | P_as (pat,_) -> P_aux (p,a) (* already named *) - | P_lit _ -> P_aux (p,a) (* no need to name a literal *) - | P_id _ -> P_aux (p,a) (* no need to name an identifier *) - | _ -> P_aux (P_as (P_aux (p,a), Id_aux (Id ("arg" ^ string_of_int idx),l)),a) in - let named_argspat = List.mapi name_pat argspat in - let named_pat = P_aux (P_app (Id_aux (Id ctor,l),named_argspat),pannot) in - let doc_arg idx (P_aux (p,(l,a))) = match p with - | P_as (pat,id) -> doc_id_lem id - | P_lit lit -> doc_lit_lem false lit a - | P_id id -> doc_id_lem id - | _ -> string ("arg" ^ string_of_int idx) in - let clauses = - clauses ^^ (break 1) ^^ - (separate space - [pipe;doc_pat_lem regtypes false named_pat;arrow; - string aux_fname; - parens (separate comma (List.mapi doc_arg named_argspat))]) in - (already_used_fnames,auxiliary_functions,clauses) - ) (StringSet.empty,empty,empty) fcls in - - auxiliary_functions ^^ hardline ^^ hardline ^^ - (prefix 2 1) - ((separate space) [string "let" ^^ doc_rec_lem r ^^ doc_id_lem id;equals;string "function"]) - (clauses ^/^ string "end") - | _ -> - let clauses = - (separate_map (break 1)) - (fun fcl -> separate space [pipe;doc_funcl_lem regtypes fcl]) fcls in - (prefix 2 1) - ((separate space) [string "let" ^^ doc_rec_lem r ^^ doc_id_lem id;equals;string "function"]) - (clauses ^/^ string "end") - - - -let doc_dec_lem (DEC_aux (reg,(l,annot))) = + let clauses = + (separate_map (break 1)) + (fun fcl -> separate space [pipe;doc_funcl_lem sequential mwords fcl]) funcls in + (prefix 2 1) + ((separate space) [doc_id_lem (id_of_fundef fd);equals;string "function"]) + (clauses ^/^ string "end") + +let doc_mutrec_lem sequential mwords = function + | [] -> failwith "DEF_internal_mutrec with empty function list" + | fundefs -> + string "let rec " ^^ + separate_map (hardline ^^ string "and ") + (doc_fundef_rhs_lem sequential mwords) fundefs + +let rec doc_fundef_lem sequential mwords (FD_aux(FD_function(r, typa, efa, fcls),fannot) as fd) = + match fcls with + | [] -> failwith "FD_function with empty function list" + | FCL_aux (FCL_Funcl(id,_,exp),_) :: _ + when string_of_id id = "execute" (*|| string_of_id id = "initial_analysis"*) -> + let (_,auxiliary_functions,clauses) = + List.fold_left + (fun (already_used_fnames,auxiliary_functions,clauses) funcl -> + match funcl with + | FCL_aux (FCL_Funcl (Id_aux (Id _,l),pat,exp),annot) -> + 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 ^ "'") + else candidate in + let aux_fname = pick_name_not_clashing_with already_used_fnames (string_of_id id ^ "_" ^ ctor) in + let already_used_fnames = StringSet.add aux_fname already_used_fnames in + let fcl = FCL_aux (FCL_Funcl (Id_aux (Id aux_fname,l), + P_aux (P_tup argspat,pannot),exp),annot) in + let auxiliary_functions = + auxiliary_functions ^^ hardline ^^ hardline ^^ + doc_fundef_lem sequential mwords (FD_aux (FD_function(r,typa,efa,[fcl]),fannot)) in + (* Bind complex patterns to names so that we can pass them to the + auxiliary function *) + let name_pat idx (P_aux (p,a)) = match p with + | P_as (pat,_) -> P_aux (p,a) (* already named *) + | P_lit _ -> P_aux (p,a) (* no need to name a literal *) + | P_id _ -> P_aux (p,a) (* no need to name an identifier *) + | _ -> P_aux (P_as (P_aux (p,a), Id_aux (Id ("arg" ^ string_of_int idx),l)),a) in + let named_argspat = List.mapi name_pat argspat in + let named_pat = P_aux (P_app (Id_aux (Id ctor,l),named_argspat),pannot) in + let doc_arg idx (P_aux (p,(l,a))) = match p with + | P_as (pat,id) -> doc_id_lem id + | P_lit lit -> doc_lit_lem sequential mwords false lit a + | P_id id -> doc_id_lem id + | _ -> string ("arg" ^ string_of_int idx) in + let clauses = + clauses ^^ (break 1) ^^ + (separate space + [pipe;doc_pat_lem sequential mwords false named_pat;arrow; + string aux_fname; + parens (separate comma (List.mapi doc_arg named_argspat))]) in + (already_used_fnames,auxiliary_functions,clauses) + ) (StringSet.empty,empty,empty) fcls in + + auxiliary_functions ^^ hardline ^^ hardline ^^ + (prefix 2 1) + ((separate space) [string "let" ^^ doc_rec_lem r ^^ doc_id_lem id;equals;string "function"]) + (clauses ^/^ string "end") + | FCL_aux (FCL_Funcl(id,_,exp),_) :: _ + when not (Env.is_extern id (env_of exp) "lem") -> + string "let" ^^ (doc_rec_lem r) ^^ (doc_fundef_rhs_lem sequential mwords fd) + | _ -> empty + + + +let doc_dec_lem sequential (DEC_aux (reg, ((l, _) as 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 - (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); - 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) + if sequential then empty + else + let env = env_of_annot annot in + (match typ with + | Typ_aux (Typ_id idt, _) when Env.is_regtyp idt env -> + separate space [string "let";doc_id_lem id;equals; + string "build_" ^^ string (string_of_id idt);string_lit (doc_id_lem id)] ^/^ hardline + | _ -> + let rt = Env.base_typ_of env typ in + if is_vector_typ rt then + let (start, size, order, etyp) = vector_typ_args_of rt in + if is_bit_typ etyp && is_nexp_constant start && is_nexp_constant size then + 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_nexp (size); + doc_nexp (start); + string o; + string "[]"])) + ^/^ hardline + else raise (Reporting_basic.err_unreachable l + ("can't deal with register type " ^ string_of_typ typ)) + else raise (Reporting_basic.err_unreachable l + ("can't deal with register type " ^ string_of_typ typ))) | DEC_alias(id,alspec) -> empty | DEC_typ_alias(typ,id,alspec) -> empty -let doc_spec_lem regtypes (VS_aux (valspec,annot)) = +let doc_spec_lem sequential mwords (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 -(* 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),empty) - | DEF_type t_def -> - let (typdefs,fromtodefs) = doc_typdef_lem regtypes t_def in - ((group typdefs ^/^ hardline,fromtodefs),empty) - | DEF_reg_dec dec -> ((group (doc_dec_lem dec),empty),empty) - - | DEF_default df -> ((empty,empty),empty) - | DEF_fundef f_def -> ((empty,empty),group (doc_fundef_lem regtypes f_def) ^/^ hardline) - | DEF_val lbind -> ((empty,empty),group (doc_let_lem regtypes lbind) ^/^ hardline) + | VS_val_spec (typschm,id,ext,_) when ext "lem" = None -> + (* let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in + if contains_t_pp_var mwords typ then empty else *) + separate space [string "val"; doc_id_lem id; string ":";doc_typschm_lem sequential mwords true typschm] ^/^ hardline + (* | VS_val_spec (_,_,Some _,_) -> empty *) + | _ -> empty + +let rec doc_def_lem sequential mwords def = + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) + match def with + | DEF_spec v_spec -> (empty,doc_spec_lem sequential mwords v_spec) + | DEF_fixity _ -> (empty,empty) + | DEF_overload _ -> (empty,empty) + | DEF_type t_def -> (group (doc_typdef_lem sequential mwords t_def) ^/^ hardline,empty) + | DEF_reg_dec dec -> (group (doc_dec_lem sequential dec),empty) + + | DEF_default df -> (empty,empty) + | DEF_fundef f_def -> (empty,group (doc_fundef_lem sequential mwords f_def) ^/^ hardline) + | DEF_internal_mutrec fundefs -> + (empty, doc_mutrec_lem sequential mwords fundefs ^/^ hardline) + | DEF_val lbind -> (empty,group (doc_let_lem sequential mwords false lbind) ^/^ hardline) | DEF_scattered sdef -> failwith "doc_def_lem: shoulnd't have DEF_scattered at this point" - | DEF_kind _ -> ((empty,empty),empty) + | DEF_kind _ -> (empty,empty) - | DEF_comm (DC_comm s) -> ((empty,empty),comment (string s)) + | DEF_comm (DC_comm s) -> (empty,comment (string s)) | DEF_comm (DC_comm_struct d) -> - let ((typdefs,tofromdefs),vdefs) = doc_def_lem regtypes d in - ((empty,empty),comment (typdefs ^^ hardline ^^ tofromdefs ^^ hardline ^^ vdefs)) + let (typdefs,vdefs) = doc_def_lem sequential mwords d in + (empty,comment (typdefs ^^ hardline ^^ vdefs)) -let doc_defs_lem regtypes (Defs defs) = - let (typdefs,valdefs) = List.split (List.map (doc_def_lem regtypes) defs) in - let (typdefs,tofromdefs) = List.split typdefs in - (separate empty typdefs,separate empty tofromdefs, separate empty valdefs) +let doc_defs_lem sequential mwords (Defs defs) = + let (typdefs,valdefs) = List.split (List.map (doc_def_lem sequential mwords) defs) in + (separate empty typdefs,separate empty valdefs) let find_regtypes (Defs defs) = List.fold_left @@ -1174,37 +1723,147 @@ let find_regtypes (Defs defs) = | _ -> acc ) [] defs +let find_registers (Defs defs) = + List.fold_left + (fun acc def -> + match def with + | DEF_reg_dec (DEC_aux(DEC_reg (typ, id), annot)) -> + let env = match annot with + | (_, Some (env, _, _)) -> env + | _ -> Env.empty in + (typ, id, env) :: acc + | _ -> 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) - (tofrom_file,tofrom_modules) - d top_line = - let pp_aux file modules defs = - (print file) - (concat - [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) modules;hardline; - defs]); +let doc_regstate_lem mwords registers = + let l = Parse_ast.Unknown in + let annot = (l, None) in + let regstate = match registers with + | [] -> + TD_abbrev ( + Id_aux (Id "regstate", l), + Name_sect_aux (Name_sect_none, l), + TypSchm_aux (TypSchm_ts (TypQ_aux (TypQ_tq [], l), unit_typ), l)) + | _ -> + TD_record ( + Id_aux (Id "regstate", l), + Name_sect_aux (Name_sect_none, l), + TypQ_aux (TypQ_tq [], l), + List.map (fun (typ, id, env) -> (typ, id)) registers, + false) in - - - let regtypes = find_regtypes d in - let (typdefs,tofromdefs,valdefs) = doc_defs_lem regtypes d in - - pp_aux types_file types_modules typdefs; - pp_aux prompt_file prompt_modules valdefs; - pp_aux state_file state_modules valdefs; - - (print tofrom_file) + let initregstate = + if !Initial_check.opt_undefined_gen then + let exp = match registers with + | [] -> E_aux (E_lit (mk_lit L_unit), (l, Some (Env.empty, unit_typ, no_effect))) + | _ -> + let initreg (typ, id, env) = + let annot typ = Some (env, typ, no_effect) in + let initval = undefined_of_typ mwords l annot typ in + FE_aux (FE_Fexp (id, initval), (l, annot typ)) in + E_aux ( + E_record (FES_aux (FES_Fexps (List.map initreg registers, false), annot)), + (l, Some (Env.empty, mk_id_typ (mk_id "regstate"), no_effect))) + in + doc_op equals (string "let initial_regstate") (doc_exp_lem true mwords false false exp) + else empty + in + concat [ + doc_typdef_lem true mwords (TD_aux (regstate, annot)); hardline; + hardline; + string "type _M 'a = M regstate 'a" + ], + initregstate + +let doc_register_refs_lem registers = + let doc_register_ref (typ, id, env) = + let idd = doc_id_lem id in + let field = if prefix_recordtype then string "regstate_" ^^ idd else idd in + let base_typ = Env.base_typ_of env typ in + let (start, is_inc) = + try + let (start, _, ord, _) = vector_typ_args_of base_typ in + match nexp_simp start with + | Nexp_aux (Nexp_constant i, _) -> (i, is_order_inc ord) + | _ -> + raise (Reporting_basic.err_unreachable Parse_ast.Unknown + ("register " ^ string_of_id id ^ " has non-constant start index " ^ string_of_nexp start)) + with + | _ -> (zero_big_int, true) in + concat [string "let "; idd; string " = <|"; hardline; + string " reg_name = \""; idd; string "\";"; hardline; + string " reg_start = "; string (string_of_big_int start); string ";"; hardline; + string " reg_is_inc = "; string (if is_inc then "true" else "false"); string ";"; hardline; + string " read_from = (fun s -> s."; field; string ");"; hardline; + string " write_to = (fun s v -> (<| s with "; field; string " = v |>)) |>"] in + separate_map hardline doc_register_ref registers + +let pp_defs_lem sequential mwords (types_file,types_modules) (defs_file,defs_modules) d top_line = + (* let regtypes = find_regtypes d in *) + let (typdefs,valdefs) = doc_defs_lem sequential mwords d in + let regstate_def, initregstate_def = doc_regstate_lem mwords (find_registers d) in + let register_refs = doc_register_refs_lem (find_registers d) in + (print types_file) + (concat + [string "(*" ^^ (string top_line) ^^ string "*)";hardline; + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) types_modules;hardline; + if !print_to_from_interp_value + then + concat + [(separate_map hardline) + (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"]; + string "open import Deep_shallow_convert"; + hardline; + hardline; + string "module SI = Interp"; hardline; + string "module SIA = Interp_ast"; hardline; + hardline] + else empty; + typdefs; hardline; + hardline; + if sequential then + concat [regstate_def; hardline; + hardline; + register_refs] + else + concat [string "type _M 'a = M 'a"; hardline] + ]); + (* (print types_seq_file) + (concat + [string "(*" ^^ (string top_line) ^^ string "*)";hardline; + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) types_seq_modules;hardline; + if !print_to_from_interp_value + then + concat + [(separate_map hardline) + (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"]; + string "open import Deep_shallow_convert"; + hardline; + hardline; + string "module SI = Interp"; hardline; + string "module SIA = Interp_ast"; hardline; + hardline] + else empty; + typdefs_seq; hardline; + hardline; + regstate_def; hardline; + hardline; + register_refs]); *) + (print defs_file) + (concat + [string "(*" ^^ (string top_line) ^^ string "*)";hardline; + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) defs_modules;hardline; + hardline; + valdefs; + hardline; + initregstate_def]); + (* (print state_file) (concat [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) (fun lib -> separate space [string "open import";string lib]) tofrom_modules;hardline; - (separate_map hardline) (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"];hardline; - string "open import Deep_shallow_convert"; - hardline;tofromdefs]) + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) state_modules;hardline; + hardline; + valdefs_seq]); *) diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index ef7a8b95..65fa5d25 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 @@ -57,41 +57,24 @@ let rec list_pp i_format l_format = | [i] -> fprintf ppf "%a" l_format i | i::is -> fprintf ppf "%a%a" i_format i (list_pp i_format l_format) is +let pp_option_lem some_format = + fun ppf opt -> + match opt with + | Some a -> fprintf ppf "(Just %a)" some_format a + | None -> fprintf ppf "Nothing" + +let pp_bool_lem ppf b = fprintf ppf (if b then "true" else "false") + let kwd ppf s = fprintf ppf "%s" s let base ppf s = fprintf ppf "%s" s +let quot_string ppf s = fprintf ppf "\"%s\"" s -let lemnum default n = match n with - | 0 -> "zero" - | 1 -> "one" - | 2 -> "two" - | 3 -> "three" - | 4 -> "four" - | 5 -> "five" - | 6 -> "six" - | 7 -> "seven" - | 8 -> "eight" - | 15 -> "fifteen" - | 16 -> "sixteen" - | 20 -> "twenty" - | 23 -> "twentythree" - | 24 -> "twentyfour" - | 30 -> "thirty" - | 31 -> "thirtyone" - | 32 -> "thirtytwo" - | 35 -> "thirtyfive" - | 39 -> "thirtynine" - | 40 -> "forty" - | 47 -> "fortyseven" - | 48 -> "fortyeight" - | 55 -> "fiftyfive" - | 56 -> "fiftysix" - | 57 -> "fiftyseven" - | 61 -> "sixtyone" - | 63 -> "sixtythree" - | 64 -> "sixtyfour" - | 127 -> "onetwentyseven" - | 128 -> "onetwentyeight" - | _ -> if n >= 0 then default n else ("(zero - " ^ (default (abs n)) ^ ")") +let lemnum default n = + if le_big_int zero_big_int n && le_big_int n (big_int_of_int 128) then + "int" ^ string_of_big_int n + else if ge_big_int n zero_big_int then + default n + else ("(int0 - " ^ (default (abs_big_int n)) ^ ")") let pp_format_id (Id_aux(i,_)) = match i with @@ -133,8 +116,7 @@ let pp_format_bkind_lem (BK_aux(k,l)) = (match k with | BK_type -> "BK_type" | BK_nat -> "BK_nat" - | BK_order -> "BK_order" - | BK_effect -> "BK_effect") ^ " " ^ + | BK_order -> "BK_order") ^ " " ^ (pp_format_l_lem l) ^ ")" let pp_lem_bkind ppf bk = base ppf (pp_format_bkind_lem bk) @@ -154,14 +136,14 @@ let rec pp_format_typ_lem (Typ_aux(t,l)) = (pp_format_effects_lem efct) ^ ")" | Typ_tup(typs) -> "(Typ_tup [" ^ (list_format "; " pp_format_typ_lem typs) ^ "])" | Typ_app(id,args) -> "(Typ_app " ^ (pp_format_id_lem id) ^ " [" ^ (list_format "; " pp_format_typ_arg_lem args) ^ "])" - | Typ_wild -> "Typ_wild") ^ " " ^ + | Typ_exist(kids,nc,typ) -> "(Typ_exist [" ^ list_format ";" pp_format_var_lem kids ^ "] " ^ pp_format_nexp_constraint_lem nc ^ " " ^ pp_format_typ_lem typ ^ ")") ^ " " ^ (pp_format_l_lem l) ^ ")" and pp_format_nexp_lem (Nexp_aux(n,l)) = "(Nexp_aux " ^ (match n with | Nexp_id(i) -> "(Nexp_id " ^ pp_format_id_lem i ^ ")" | Nexp_var(v) -> "(Nexp_var " ^ pp_format_var_lem v ^ ")" - | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum string_of_int i) ^ ")" + | Nexp_constant(i) -> "(Nexp_constant " ^ (lemnum string_of_big_int i) ^ ")" | Nexp_sum(n1,n2) -> "(Nexp_sum " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_minus(n1,n2) -> "(Nexp_minus " ^ (pp_format_nexp_lem n1)^ " " ^ (pp_format_nexp_lem n2) ^ ")" | Nexp_times(n1,n2) -> "(Nexp_times " ^ (pp_format_nexp_lem n1) ^ " " ^ (pp_format_nexp_lem n2) ^ ")" @@ -207,31 +189,45 @@ and pp_format_effects_lem (Effect_aux(e,l)) = and pp_format_typ_arg_lem (Typ_arg_aux(t,l)) = "(Typ_arg_aux " ^ (match t with - | Typ_arg_typ(t) -> "(Typ_arg_typ " ^ pp_format_typ_lem t ^ ")" - | Typ_arg_nexp(n) -> "(Typ_arg_nexp " ^ pp_format_nexp_lem n ^ ")" - | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")" - | Typ_arg_effect(e) -> "(Typ_arg_effect " ^ pp_format_effects_lem e ^ ")") ^ " " ^ + | Typ_arg_typ(t) -> "(Typ_arg_typ " ^ pp_format_typ_lem t ^ ")" + | Typ_arg_nexp(n) -> "(Typ_arg_nexp " ^ pp_format_nexp_lem n ^ ")" + | Typ_arg_order(o) -> "(Typ_arg_order " ^ pp_format_ord_lem o ^ ")") ^ " " ^ (pp_format_l_lem l) ^ ")" - -let pp_lem_typ ppf t = base ppf (pp_format_typ_lem t) -let pp_lem_nexp ppf n = base ppf (pp_format_nexp_lem n) -let pp_lem_ord ppf o = base ppf (pp_format_ord_lem o) -let pp_lem_effects ppf e = base ppf (pp_format_effects_lem e) -let pp_lem_beffect ppf be = base ppf (pp_format_base_effect_lem be) - -let pp_format_nexp_constraint_lem (NC_aux(nc,l)) = +and pp_format_nexp_constraint_lem (NC_aux(nc,l)) = "(NC_aux " ^ (match nc with - | NC_fixed(n1,n2) -> "(NC_fixed " ^ pp_format_nexp_lem n1 ^ " " ^ pp_format_nexp_lem n2 ^ ")" + | NC_equal(n1,n2) -> "(NC_equal " ^ pp_format_nexp_lem n1 ^ " " ^ pp_format_nexp_lem n2 ^ ")" | NC_bounded_ge(n1,n2) -> "(NC_bounded_ge " ^ pp_format_nexp_lem n1 ^ " " ^ pp_format_nexp_lem n2 ^ ")" | NC_bounded_le(n1,n2) -> "(NC_bounded_le " ^ pp_format_nexp_lem n1 ^ " " ^ pp_format_nexp_lem n2 ^ ")" - | NC_nat_set_bounded(id,bounds) -> "(NC_nat_set_bounded " ^ + | NC_not_equal(n1,n2) -> "(NC_not_equal " ^ pp_format_nexp_lem n1 ^ " " ^ pp_format_nexp_lem n2 ^ ")" + | NC_or(nc1,nc2) -> "(NC_or " ^ pp_format_nexp_constraint_lem nc1 ^ " " ^ pp_format_nexp_constraint_lem nc2 ^ ")" + | NC_and(nc1,nc2) -> "(NC_and " ^ pp_format_nexp_constraint_lem nc1 ^ " " ^ pp_format_nexp_constraint_lem nc2 ^ ")" + | NC_true -> "NC_true" + | NC_false -> "NC_false" + | NC_set(id,bounds) -> "(NC_set " ^ pp_format_var_lem id ^ " [" ^ - list_format "; " string_of_int bounds ^ + list_format "; " string_of_big_int bounds ^ "])") ^ " " ^ (pp_format_l_lem l) ^ ")" +let pp_lem_typ ppf t = base ppf (pp_format_typ_lem t) +let pp_lem_nexp ppf n = base ppf (pp_format_nexp_lem n) +let pp_lem_ord ppf o = base ppf (pp_format_ord_lem o) +let pp_lem_effects ppf e = base ppf (pp_format_effects_lem e) +let pp_lem_beffect ppf be = base ppf (pp_format_base_effect_lem be) +let pp_lem_loop ppf l = + let l_str = match l with + | While -> "While" + | Until -> "Until" in + base ppf l_str +let pp_lem_prec ppf p = + let p_str = match p with + | Infix -> "Infix" + | InfixL -> "InfixL" + | InfixR -> "InfixR" in + base ppf p_str + let pp_lem_nexp_constraint ppf nc = base ppf (pp_format_nexp_constraint_lem nc) let pp_format_qi_lem (QI_aux(qi,lq)) = @@ -274,106 +270,39 @@ let pp_format_lit_lem (L_aux(lit,l)) = | L_one -> "L_one" | L_true -> "L_true" | L_false -> "L_false" - | L_num(i) -> "(L_num " ^ (lemnum string_of_int i) ^ ")" + | L_num(i) -> "(L_num " ^ (lemnum string_of_big_int i) ^ ")" | L_hex(n) -> "(L_hex \"" ^ n ^ "\")" | L_bin(n) -> "(L_bin \"" ^ n ^ "\")" | L_undef -> "L_undef" - | L_string(s) -> "(L_string \"" ^ s ^ "\")") ^ " " ^ + | L_string(s) -> "(L_string \"" ^ s ^ "\")" + | L_real(s) -> "(L_real \"" ^ s ^ "\")") ^ " " ^ (pp_format_l_lem 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 "; " - (fun ne -> match ne with - | LtEq(_,n1,n2) -> "(Nec_lteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | Eq(_,n1,n2) -> "(Nec_eq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | GtEq(_,n1,n2) -> "(Nec_gteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | In(_,i,ns) | InS(_,{nexp=Nvar i},ns) -> - "(Nec_in \"" ^ i ^ "\" [" ^ (list_format "; " string_of_int ns)^ "])" - | InS(_,_,ns) -> - "(Nec_in \"fresh\" [" ^ (list_format "; " string_of_int ns)^ "])" - | CondCons(_,nes_c,nes_t) -> - "(Nec_cond " ^ (pp_format_nes nes_c) ^ " " ^ (pp_format_nes nes_t) ^ ")" - | BranchCons(_,nes_b) -> - "(Nec_branch " ^ (pp_format_nes nes_b) ^ ")" - ) - nes) ^*) "]" - -let pp_format_annot = function - | 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" +let tag_id id env = + if Env.is_extern id env "lem_ast" then + "Tag_extern (Just \"" ^ Ast_util.string_of_id id ^ "\")" + else if Env.is_union_constructor id env then + "Tag_ctor" + else + "Tag_empty" + +let pp_format_annot ?tag:(t="Tag_empty") = function + | None -> "Nothing" + | Some (_, typ, eff) -> + "(Just (" + ^ pp_format_typ_lem typ ^ ", " + ^ t ^ ", " + ^ "[], " + ^ pp_format_effects_lem eff ^ ", " + ^ pp_format_effects_lem eff + ^ "))" let pp_annot ppf ant = base ppf (pp_format_annot ant) +let pp_annot_tag tag ppf ant = base ppf (pp_format_annot ~tag:tag ant) let rec pp_format_pat_lem (P_aux(p,(l,annot))) = "(P_aux " ^ @@ -381,6 +310,7 @@ let rec pp_format_pat_lem (P_aux(p,(l,annot))) = | P_lit(lit) -> "(P_lit " ^ pp_format_lit_lem lit ^ ")" | P_wild -> "P_wild" | P_id(id) -> "(P_id " ^ pp_format_id_lem id ^ ")" + | P_var(pat,kid) -> "(P_var " ^ pp_format_pat_lem pat ^ " " ^ pp_format_var_lem kid ^ ")" | P_as(pat,id) -> "(P_as " ^ pp_format_pat_lem pat ^ " " ^ pp_format_id_lem id ^ ")" | P_typ(typ,pat) -> "(P_typ " ^ pp_format_typ_lem typ ^ " " ^ pp_format_pat_lem pat ^ ")" | P_app(id,pats) -> "(P_app " ^ pp_format_id_lem id ^ " [" ^ @@ -390,11 +320,10 @@ let rec pp_format_pat_lem (P_aux(p,(l,annot))) = "(FP_Fpat " ^ pp_format_id_lem id ^ " " ^ pp_format_pat_lem fpat ^ ")") fpats ^ "])" | P_vector(pats) -> "(P_vector [" ^ list_format "; " pp_format_pat_lem pats ^ "])" - | P_vector_indexed(ipats) -> - "(P_vector_indexed [" ^ list_format "; " (fun (i,p) -> Printf.sprintf "(%d, %s)" i (pp_format_pat_lem p)) ipats ^ "])" | P_vector_concat(pats) -> "(P_vector_concat [" ^ list_format "; " pp_format_pat_lem pats ^ "])" | P_tup(pats) -> "(P_tup [" ^ (list_format "; " pp_format_pat_lem pats) ^ "])" - | P_list(pats) -> "(P_list [" ^ (list_format "; " pp_format_pat_lem pats) ^ "])") ^ + | P_list(pats) -> "(P_list [" ^ (list_format "; " pp_format_pat_lem pats) ^ "])" + | P_cons(pat,pat') -> "(P_cons " ^ pp_format_pat_lem pat ^ " " ^ pp_format_pat_lem pat' ^ ")") ^ " (" ^ pp_format_l_lem l ^ ", " ^ pp_format_annot annot ^ "))" let pp_lem_pat ppf p = base ppf (pp_format_pat_lem p) @@ -402,13 +331,12 @@ let pp_lem_pat ppf p = base ppf (pp_format_pat_lem p) let rec pp_lem_let ppf (LB_aux(lb,(l,annot))) = let print_lb ppf lb = match lb with - | LB_val_explicit(ts,pat,exp) -> - fprintf ppf "@[<0>(%a %a %a %a)@]" kwd "LB_val_explicit" pp_lem_typscm ts pp_lem_pat pat pp_lem_exp exp - | LB_val_implicit(pat,exp) -> - fprintf ppf "@[<0>(%a %a %a)@]" kwd "LB_val_implicit" pp_lem_pat pat pp_lem_exp exp in + | LB_val(pat,exp) -> + fprintf ppf "@[<0>(%a %a %a)@]" kwd "LB_val" pp_lem_pat pat pp_lem_exp exp in fprintf ppf "@[<0>(LB_aux %a (%a, %a))@]" print_lb lb pp_lem_l l pp_annot annot -and pp_lem_exp ppf (E_aux(e,(l,annot))) = +and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = + let env = env_of exp in let print_e ppf e = match e with | E_block(exps) -> fprintf ppf "@[<0>(E_aux %a [%a] %a (%a, %a))@]" @@ -419,13 +347,13 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = kwd "(E_nondet" (list_pp pp_semi_lem_exp pp_lem_exp) exps kwd ")" pp_lem_l l pp_annot annot - | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l pp_annot annot + | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l (pp_annot_tag (tag_id id env)) 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 + pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l (pp_annot_tag (tag_id f env)) annot | E_app_infix(l',op,r) -> fprintf ppf "@[<0>(E_aux (E_app_infix %a %a %a) (%a, %a))@]" pp_lem_exp l' pp_lem_id op pp_lem_exp r pp_lem_l l pp_annot annot | E_tuple(exps) -> fprintf ppf "@[<0>(E_aux (E_tuple [%a]) (%a, %a))@]" @@ -436,17 +364,11 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = fprintf ppf "@[<0>(E_aux (E_for %a %a %a %a %a @ @[<1> %a @]) (%a, %a))@]" pp_lem_id id pp_lem_exp exp1 pp_lem_exp exp2 pp_lem_exp exp3 pp_lem_ord order pp_lem_exp exp4 pp_lem_l l pp_annot annot + | E_loop(loop,cond,body) -> + fprintf ppf "@[<0>(E_aux (E_loop %a %a @ @[<1> %a @]) (%a, %a))@]" + pp_lem_loop loop pp_lem_exp cond pp_lem_exp body pp_lem_l l pp_annot annot | E_vector(exps) -> fprintf ppf "@[<0>(E_aux (%a [%a]) (%a, %a))@]" kwd "E_vector" (list_pp pp_semi_lem_exp pp_lem_exp) exps pp_lem_l l pp_annot annot - | E_vector_indexed(iexps,(Def_val_aux (default, (dl,dannot)))) -> - let iformat ppf (i,e) = fprintf ppf "@[<1>(%i %a %a) %a@]" i kwd ", " pp_lem_exp e kwd ";" in - let lformat ppf (i,e) = fprintf ppf "@[<1>(%i %a %a) @]" i kwd ", " pp_lem_exp e in - let default_string ppf _ = (match default with - | Def_val_empty -> fprintf ppf "(Def_val_aux Def_val_empty (%a,%a))" pp_lem_l dl pp_annot dannot - | Def_val_dec e -> fprintf ppf "(Def_val_aux (Def_val_dec %a) (%a,%a))" - pp_lem_exp e pp_lem_l dl pp_annot dannot) in - fprintf ppf "@[<0>(E_aux (%a [%a] %a) (%a, %a))@]" kwd "E_vector_indexed" - (list_pp iformat lformat) iexps default_string () pp_lem_l l pp_annot annot | E_vector_access(v,e) -> fprintf ppf "@[<0>(E_aux (%a %a %a) (%a, %a))@]" kwd "E_vector_access" pp_lem_exp v pp_lem_exp e pp_lem_l l pp_annot annot @@ -484,12 +406,15 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = pp_lem_lexp lexp pp_lem_exp exp pp_lem_l l pp_annot annot | E_sizeof nexp -> fprintf ppf "@[<0>(E_aux (E_sizeof %a) (%a, %a))@]" pp_lem_nexp nexp pp_lem_l l pp_annot annot + | E_constraint nc -> + fprintf ppf "@[<0>(E_aux (E_constraint %a) (%a, %a))@]" pp_lem_nexp_constraint nc pp_lem_l l pp_annot annot | E_exit exp -> fprintf ppf "@[<0>(E_aux (E_exit %a) (%a, %a))@]" pp_lem_exp exp pp_lem_l l pp_annot annot | E_return exp -> 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 +433,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 @@ -527,8 +458,11 @@ and pp_lem_fexp ppf (FE_aux(FE_Fexp(id,exp),(l,annot))) = fprintf ppf "@[<1>(FE_aux (FE_Fexp %a %a) (%a, %a))@]" pp_lem_id id pp_lem_exp exp pp_lem_l l pp_annot annot and pp_semi_lem_fexp ppf fexp = fprintf ppf "@[<1>%a %a@]" pp_lem_fexp fexp kwd ";" -and pp_lem_case ppf (Pat_aux(Pat_exp(pat,exp),(l,annot))) = +and pp_lem_case ppf = function +| Pat_aux(Pat_exp(pat,exp),(l,annot)) -> fprintf ppf "@[<1>(Pat_aux (Pat_exp %a@ %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp exp pp_lem_l l pp_annot annot +| Pat_aux(Pat_when(pat,guard,exp),(l,annot)) -> + fprintf ppf "@[<1>(Pat_aux (Pat_when %a@ %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp guard pp_lem_exp exp pp_lem_l l pp_annot annot and pp_semi_lem_case ppf case = fprintf ppf "@[<1>%a %a@]" pp_lem_case case kwd ";" and pp_lem_lexp ppf (LEXP_aux(lexp,(l,annot))) = @@ -547,6 +481,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 = @@ -557,15 +492,14 @@ let pp_lem_default ppf (DT_aux(df,l)) = in fprintf ppf "@[<0>(DT_aux %a %a)@]" print_de df pp_lem_l l +(* FIXME *) let pp_lem_spec ppf (VS_aux(v,(l,annot))) = let print_spec ppf v = match v with - | VS_val_spec(ts,id) -> - fprintf ppf "@[<0>(%a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id - | VS_extern_spec(ts,id,s) -> - 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_val_spec(ts,id,ext_opt,is_cast) -> + (* FIXME: None *) + fprintf ppf "@[<0>(%a %a %a %a %a)@]@\n" kwd "VS_val_spec" pp_lem_typscm ts pp_lem_id id (pp_option_lem quot_string) None pp_bool_lem is_cast + | _ -> failwith "Invalid valspec" in fprintf ppf "@[<0>(VS_aux %a (%a, %a))@]" print_spec v pp_lem_l l pp_annot annot @@ -576,8 +510,8 @@ let pp_lem_namescm ppf (Name_sect_aux(ns,l)) = let rec pp_lem_range ppf (BF_aux(r,l)) = match r with - | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" i pp_lem_l l - | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" i1 i2 pp_lem_l l + | BF_single(i) -> fprintf ppf "(BF_aux (BF_single %i) %a)" (int_of_big_int i) pp_lem_l l + | BF_range(i1,i2) -> fprintf ppf "(BF_aux (BF_range %i %i) %a)" (int_of_big_int i1) (int_of_big_int i2) pp_lem_l l | BF_concat(ir1,ir2) -> fprintf ppf "(BF_aux (BF_concat %a %a) %a)" pp_lem_range ir1 pp_lem_range ir2 pp_lem_l l let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = @@ -614,35 +548,9 @@ let pp_lem_typdef ppf (TD_aux(td,(l,annot))) = let pp_lem_kindef ppf (KD_aux(kd,(l,annot))) = let print_kd ppf kd = match kd with - | KD_abbrev(kind,id,namescm,typschm) -> - fprintf ppf "@[<0>(KD_abbrev %a %a %a %a)@]" - pp_lem_kind kind pp_lem_id id pp_lem_namescm namescm pp_lem_typscm typschm | KD_nabbrev(kind,id,namescm,n) -> fprintf ppf "@[<0>(KD_nabbrev %a %a %a %a)@]" pp_lem_kind kind pp_lem_id id pp_lem_namescm namescm pp_lem_nexp n - | KD_record(kind,id,nm,typq,fs,_) -> - let f_pp ppf (typ,id) = - fprintf ppf "@[<1>(%a, %a)%a@]" pp_lem_typ typ pp_lem_id id kwd ";" in - fprintf ppf "@[<0>(%a %a %a %a %a [%a] false)@]" - kwd "KD_record" pp_lem_kind kind pp_lem_id id pp_lem_namescm nm pp_lem_typquant typq (list_pp f_pp f_pp) fs - | KD_variant(kind,id,nm,typq,ar,_) -> - let a_pp ppf (Tu_aux(typ_u,l)) = - match typ_u with - | Tu_ty_id(typ,id) -> fprintf ppf "@[<1>(Tu_aux (Tu_ty_id %a %a) %a);@]" - pp_lem_typ typ pp_lem_id id pp_lem_l l - | Tu_id(id) -> fprintf ppf "@[<1>(Tu_aux (Tu_id %a) %a);@]" pp_lem_id id pp_lem_l l - in - fprintf ppf "@[<0>(%a %a %a %a %a [%a] false)@]" - kwd "KD_variant" pp_lem_kind kind pp_lem_id id pp_lem_namescm nm pp_lem_typquant typq (list_pp a_pp a_pp) ar - | KD_enum(kind,id,ns,enums,_) -> - let pp_id_semi ppf id = fprintf ppf "%a%a " pp_lem_id id kwd ";" in - fprintf ppf "@[<0>(%a %a %a %a [%a] false)@]" - kwd "KD_enum" pp_lem_kind kind pp_lem_id id pp_lem_namescm ns (list_pp pp_id_semi pp_lem_id) enums - | KD_register(kind,id,n1,n2,rs) -> - let pp_rid ppf (r,id) = fprintf ppf "(%a, %a)%a " pp_lem_range r pp_lem_id id kwd ";" in - let pp_rids = (list_pp pp_rid pp_rid) in - fprintf ppf "@[<0>(%a %a %a %a %a [%a])@]" - kwd "KD_register" pp_lem_kind kind pp_lem_id id pp_lem_nexp n1 pp_lem_nexp n2 pp_rids rs in fprintf ppf "@[<0>(KD_aux %a (%a, %a))@]" print_kd kd pp_lem_l l pp_annot annot @@ -655,6 +563,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,14 +611,15 @@ 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 | DEF_val(lbind) -> fprintf ppf "(DEF_val %a);@\n" pp_lem_let lbind | DEF_reg_dec(dec) -> fprintf ppf "(DEF_reg_dec %a);@\n" pp_lem_dec dec | DEF_comm d -> fprintf ppf "" + | DEF_fixity (prec, n, id) -> fprintf ppf "(DEF_fixity %a %s %a);@\n" pp_lem_prec prec (lemnum string_of_big_int n) pp_lem_id id | _ -> raise (Reporting_basic.err_unreachable Parse_ast.Unknown "initial_check didn't remove all scattered Defs") 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 deleted file mode 100644 index 3772f549..00000000 --- a/src/pretty_print_ocaml.ml +++ /dev/null @@ -1,756 +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 -open Type_internal -open Ast -open PPrint -open Pretty_print_common - -(**************************************************************************** - * PPrint-based sail-to-ocaml pretty printer -****************************************************************************) - -let star_sp = star ^^ space - -let sanitize_name s = - "_" ^ s - -let doc_id_ocaml (Id_aux(i,_)) = - match i with - | Id("bit") -> string "vbit" - | Id i -> string (sanitize_name i) - | DeIid x -> - (* add an extra space through empty to avoid a closing-comment - * token in case of x ending with star. *) - parens (separate space [colon; string x; empty]) - -let doc_id_ocaml_type (Id_aux(i,_)) = - match i with - | Id("bit") -> string "vbit" - | Id i -> string (sanitize_name i) - | DeIid x -> - (* add an extra space through empty to avoid a closing-comment - * 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,_)) = - match i with - | Id("bit") -> string "vbit" - | Id i -> string ((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. *) - parens (separate space [colon; string (String.capitalize x); empty]) - -let doc_typ_ocaml, doc_atomic_typ_ocaml = - (* following the structure of parser for precedence *) - let rec typ ty = fn_typ ty - and fn_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_fn(arg,ret,efct) -> - separate space [tup_typ arg; arrow; fn_typ ret] - | _ -> tup_typ ty - and tup_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_tup typs -> parens (separate_map star app_typ typs) - | _ -> app_typ ty - and app_typ ((Typ_aux (t, _)) as ty) = match t with - | 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 typ, _)]) -> - string "value" - | Typ_app(Id_aux (Id "range", _), [ - Typ_arg_aux(Typ_arg_nexp n, _); - Typ_arg_aux(Typ_arg_nexp m, _);]) -> - (string "number") - | Typ_app(Id_aux (Id "atom", _), [Typ_arg_aux(Typ_arg_nexp n,_)]) -> - (string "number") - | Typ_app(id,args) -> - (separate_map space doc_typ_arg_ocaml args) ^^ space ^^ (doc_id_ocaml_type id) - | _ -> atomic_typ ty - and atomic_typ ((Typ_aux (t, _)) as ty) = match t with - | Typ_id id -> doc_id_ocaml_type id - | Typ_var v -> doc_var v - | Typ_wild -> underscore - | Typ_app _ | Typ_tup _ | Typ_fn _ -> - (* exhaustiveness matters here to avoid infinite loops - * if we add a new Typ constructor *) - group (parens (typ ty)) - and doc_typ_arg_ocaml (Typ_arg_aux(t,_)) = match t with - | Typ_arg_typ t -> app_typ t - | Typ_arg_nexp n -> empty - | Typ_arg_order o -> empty - | Typ_arg_effect e -> empty - in typ, atomic_typ - -let doc_lit_ocaml in_pat (L_aux(l,_)) = - utf8string (match l with - | L_unit -> "()" - | L_zero -> "Vzero" - | L_one -> "Vone" - | L_true -> "Vone" - | L_false -> "Vzero" - | L_num i -> - let s = string_of_int i in - if (i >= 0) && (i <= 257) then - "bi" ^ s - else - "(big_int_of_int (" ^ s ^ "))" - | L_hex n -> "(num_to_vec " ^ ("0x" ^ n) ^ ")" (*shouldn't happen*) - | L_bin n -> "(num_to_vec " ^ ("0b" ^ n) ^ ")" (*shouldn't happen*) - | L_undef -> "(failwith \"undef literal not supported\")" (* XXX Undef vectors get handled with to_vec_undef. We could support undef bit but would need to check type. For the moment treat as runtime error. *) - | L_string s -> "\"" ^ s ^ "\"") - -(* typ_doc is the doc for the type being quantified *) -let doc_typquant_ocaml (TypQ_aux(tq,_)) typ_doc = typ_doc - -let doc_typscm_ocaml (TypSchm_aux(TypSchm_ts(tq,t),_)) = - (doc_typquant_ocaml tq (doc_typ_ocaml t)) - -(*Note: vector concatenation, literal vectors, indexed vectors, and record should - be removed prior to pp. The latter two have never yet been seen -*) -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) - | P_lit lit -> doc_lit_ocaml true lit - | P_wild -> underscore - | P_id id -> doc_id_ocaml id - | P_as(p,id) -> parens (separate space [pat p; string "as"; doc_id_ocaml id]) - | 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 - | _ -> failwith "encountered unexpected P_app pattern") - | P_vector pats -> - let non_bit_print () = - parens - (separate space [string "VvectorR"; - parens (separate comma_sp [squarebars (separate_map semi pat pats); - 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 ()) - | 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") - | P_vector_indexed _ -> raise (Reporting_basic.err_unreachable l "unhandled vector_indexed pattern") - | P_vector_concat _ -> raise (Reporting_basic.err_unreachable l "unhandled vector_concat pattern") - in pat - -let doc_exp_ocaml, doc_let_ocaml = - let rec top_exp read_registers (E_aux (e, (_,annot))) = - let exp = top_exp read_registers 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))) - | 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) - | E_if(c,t,E_aux(E_block [], _)) -> - parens (string "if" ^^ space ^^ string "to_bool" ^^ parens (exp c) ^/^ - string "then" ^^ space ^^ (exp t)) - | E_if(c,t,e) -> - parens ( - string "if" ^^ space ^^ string "to_bool" ^^ parens (exp c) ^/^ - string "then" ^^ space ^^ group (exp t) ^/^ - string "else" ^^ space ^^ group (exp e)) - | E_for(id,exp1,exp2,exp3,(Ord_aux(order,_)),exp4) -> - let var= doc_id_ocaml id in - let (compare,next) = if order = Ord_inc then string "le_big_int",string "add_big_int" else string "ge_big_int",string "sub_big_int" in - let by = exp exp3 in - let stop = exp exp2 in - (*takes over two names but doesn't require building a closure*) - parens - (separate space [(string "let (__stop,__by) = ") ^^ (parens (doc_op comma stop by)); - string "in" ^/^ empty; - string "let rec foreach"; - var; - equals; - string "if"; - parens (compare ^^ space ^^ var ^^ space ^^ (string "__stop") ); - string "then"; - parens (exp exp4 ^^ space ^^ semi ^^ (string "foreach") ^^ - parens (next ^^ space ^^ var ^^ space ^^ (string "__by"))); - string "in"; - string "foreach"; - exp exp1]) - (*Requires fewer introduced names but introduces a closure*) - (*let forL = if order = Ord_inc then string "foreach_inc" else string "foreach_dec" in - forL ^^ space ^^ (group (exp exp1)) ^^ (group (exp exp2)) ^^ (group (exp full_exp3)) ^/^ - group ((string "fun") ^^ space ^^ (doc_id id) ^^ space ^^ arrow ^/^ (exp exp4)) - - (* this way requires the following OCaml declarations first - - let rec foreach_inc i stop by body = - if i <= stop then (body i; foreach_inc (i + by) stop by body) else () - - let rec foreach_dec i stop by body = - if i >= stop then (body i; foreach_dec (i - by) stop by body) else () - - *)*) - | 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 - | _ -> doc_id_ocaml f,false in - let base_print () = parens (doc_unop call (parens (separate_map comma exp args))) in - if not(ctor) - then base_print () - else (match args with - | [] -> call - | [arg] -> (match arg with - | E_aux(E_lit (L_aux(L_unit,_)),_) -> call - | _ -> 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 - 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_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 - | Base((_,t),Alias alias_info,_,_,_,_) -> - (match alias_info with - | Alias_field(reg,field) -> - let field_f = match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> string "get_register_field_bit" - | _ -> string "get_register_field_vec" in - parens (separate space [field_f; string (sanitize_name reg); string_lit (string field)]) - | Alias_extract(reg,start,stop) -> - if start = stop - then parens (separate space [string "bit_vector_access";string (sanitize_name reg);doc_int start]) - else parens - (separate space [string "vector_subrange"; string (sanitize_name reg); doc_int start; doc_int stop]) - | Alias_pair(reg1,reg2) -> - parens (separate space [string "vector_concat"; - string (sanitize_name reg1); - string (sanitize_name reg2)])) - | _ -> doc_id_ocaml id) - | E_lit lit -> doc_lit_ocaml false lit - | E_cast(typ,e) -> - (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,_)),_);_;_;_]) -> - parens ((concat [string "set_start";space;string (string_of_int i)]) ^//^ - exp e) - | Typ_var (Kid_aux (Var "length",_)) -> - 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,_),_)) -> - braces (separate_map semi_sp doc_fexp fexps) - | 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 - | 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 - | _ -> 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])])) - | E_vector_indexed (iexps, (Def_val_aux (default,_))) -> - (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)) - | _ -> 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 default_string = - (match default with - | Def_val_empty -> string "None" - | Def_val_dec e -> parens (string "Some " ^^ (exp e))) in - let iexp (i,e) = parens (separate_map comma_sp (fun x -> x) [(doc_int i); (exp e)]) in - parens (separate space [call; - (brackets (separate_map semi iexp iexps)); - default_string; - string start; - string size; - 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))) - | E_vector_update_subrange(v,e1,e2,e3) -> - (*Has never happened to date*) - brackets ( - doc_op (string "with") (exp v) - (doc_op equals (exp e1 ^^ colon ^^ exp e2) (exp e3))) - | E_list exps -> - brackets (separate_map semi exp exps) - | E_case(e,pexps) -> - let opening = separate space [string "("; string "match"; top_exp false e; string "with"] in - let cases = separate_map (break 1) doc_case pexps in - surround 2 1 opening cases rparen - | E_exit e -> - separate space [string "exit"; exp e;] - | E_return e -> - separate space [string "begin ret := Some" ; exp e ; string "; raise Sail_return; end"] - | E_app_infix (e1,id,e2) -> - let call = - match annot with - | Base((_,t),External(Some name),_,_,_,_) -> string name - | _ -> 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"; - doc_lexp_ocaml true lexp; (*Rewriter/typecheck should ensure this is only cast or id*) - equals; - string "ref"; - exp eq_exp; - string "in"; - exp in_exp] - - | E_internal_plet (pat,e1,e2) -> - (separate space [(exp e1); string ">>= fun"; doc_pat_ocaml pat;arrow]) ^/^ - exp e2 - - | E_internal_return (e1) -> - separate space [string "return"; exp e1;] - | E_assert (e1, e2) -> - (string "assert") ^^ parens ((string "to_bool") ^^ space ^^ exp e1) (* XXX drops e2 *) - and let_exp (LB_aux(lb,_)) = match lb with - | LB_val_explicit(ts,pat,e) -> - prefix 2 1 - (separate space [string "let"; doc_pat_ocaml pat; equals]) - (top_exp false e) - | LB_val_implicit(pat,e) -> - prefix 2 1 - (separate space [string "let"; doc_pat_ocaml pat; equals]) - (top_exp false e) - - and doc_fexp (FE_aux(FE_Fexp(id,e),_)) = doc_op equals (doc_id_ocaml id) (top_exp false e) - - and doc_case (Pat_aux(Pat_exp(pat,e),_)) = - doc_op arrow (separate space [pipe; doc_pat_ocaml pat]) (group (top_exp false e)) - - and doc_lexp_ocaml top_call ((LEXP_aux(lexp,(l,annot))) as le) = - let exp = top_exp false in - match lexp with - | LEXP_vector(v,e) -> doc_lexp_array_ocaml le - | LEXP_vector_range(v,e1,e2) -> - parens ((string "vector_subrange") ^^ space ^^ (doc_lexp_ocaml false v) ^^ space ^^ (exp e1) ^^ space ^^ (exp e2)) - | LEXP_field(v,id) -> (doc_lexp_ocaml false v) ^^ dot ^^ doc_id_ocaml id - | 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 - | _ -> 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))) - | _ -> - 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 - match lexp with - | LEXP_vector(v,e) -> - if is_bit then (* XXX check whether register or not?? *) - parens ((string "set_register_bit" ^^ space ^^ doc_lexp_ocaml false v ^^ space ^^ exp e ^^ space ^^ exp e_new_v)) - else (* XXX Check whether vector of reg? XXX Does not work for decreasing vector. *) - parens ((string "set_register") ^^ space ^^ - ((group (parens ((string "get_varray") ^^ space ^^ doc_lexp_ocaml false v)) ^^ - dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (exp e))) ^^ space ^^ (exp e_new_v))) - | LEXP_vector_range(v,e1,e2) -> - parens ((string (if is_bitv then "set_vector_subrange_bit" else "set_vector_subrange_vec")) ^^ space ^^ - doc_lexp_ocaml false v ^^ space ^^ exp e1 ^^ space ^^ exp e2 ^^ space ^^ exp e_new_v) - | LEXP_field(v,id) -> - 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 - | Base(_,Alias alias_info,_,_,_,_) -> - (match alias_info with - | Alias_field(reg,field) -> - parens ((if is_bit then string "set_register_field_bit" else string "set_register_field_v") ^^ space ^^ - string (sanitize_name reg) ^^ space ^^string_lit (string field) ^^ space ^^ exp e_new_v) - | Alias_extract(reg,start,stop) -> - if start = stop - then - doc_op (string "<-") - (group (parens ((string (if is_bit then "get_barray" else "get_varray")) ^^ space ^^ string reg)) ^^ - dot ^^ parens ((string "int_of_big_int") ^^ space ^^ (doc_int start))) - (exp e_new_v) - else - parens ((string (if is_bitv then "set_vector_subrange_bit" else "set_vector_subrange_vec")) ^^ space ^^ - 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])) - - 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])) - - (* expose doc_exp and doc_let *) - in top_exp false, let_exp - -(*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] - -let rec doc_range_ocaml (BF_aux(r,_)) = match r with - | BF_single i -> parens (doc_op comma (doc_int i) (doc_int i)) - | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2)) - | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2) - -let doc_typdef_ocaml (TD_aux(td,_)) = match td with - | TD_abbrev(id,nm,typschm) -> - doc_op equals (concat [string "type"; space; doc_id_ocaml_type id;]) (doc_typscm_ocaml typschm) - | TD_record(id,nm,typq,fs,_) -> - let f_pp (typ,id) = concat [doc_id_ocaml_type id; space; colon; doc_typ_ocaml typ; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) (doc_typquant_ocaml typq (braces fs_doc)) - | TD_variant(id,nm,typq,ar,_) -> - let n = List.length ar in - let ar_doc = group (separate_map (break 1) (doc_type_union_ocaml n) ar) in - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) - (if n > 246 - then brackets (space ^^(doc_typquant_ocaml typq ar_doc)) - 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 - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) - (enums_doc) - | TD_register(id,n1,n2,rs) -> - let doc_rid (r,id) = parens (separate comma_sp [string_lit (doc_id id); doc_range_ocaml r;]) in - let doc_rids = group (separate_map (semi ^^ (break 1)) doc_rid rs) in - match n1,n2 with - | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> - let dir = i1 < i2 in - let size = if dir then i2-i1 +1 else i1-i2+1 in - doc_op equals - ((string "let") ^^ space ^^ doc_id_ocaml id ^^ space ^^ (string "init_val")) - (separate space [string "Vregister"; - (parens (separate comma_sp - [parens (separate space - [string "match init_val with"; - pipe; - string "None"; - arrow; - string "ref"; - string "(Array.make"; - doc_int size; - string "Vzero)"; - pipe; - string "Some init_val"; - arrow; - string "ref init_val";]); - doc_nexp n1; - string (if dir then "true" else "false"); - string_lit (doc_id id); - brackets doc_rids]))]) - -let doc_kdef_ocaml (KD_aux(kd,_)) = match kd with - | KD_nabbrev (k, id, name_scm, nexp) -> - separate space [string "let" ; - doc_id_ocaml id; - equals; - doc_nexp nexp] - | KD_abbrev(_,id,nm,typschm) -> - doc_op equals (concat [string "type"; space; doc_id_ocaml_type id;]) (doc_typscm_ocaml typschm) - | KD_record(_,id,nm,typq,fs,_) -> - let f_pp (typ,id) = concat [doc_id_ocaml_type id; space; colon; doc_typ_ocaml typ; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) (doc_typquant_ocaml typq (braces fs_doc)) - | KD_variant(_,id,nm,typq,ar,_) -> - let n = List.length ar in - let ar_doc = group (separate_map (break 1) (doc_type_union_ocaml n) ar) in - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) - (if n > 246 - then brackets (space ^^(doc_typquant_ocaml typq ar_doc)) - 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 - doc_op equals - (concat [string "type"; space; doc_id_ocaml_type id;]) - (enums_doc) - | KD_register(_,id,n1,n2,rs) -> - let doc_rid (r,id) = parens (separate comma_sp [string_lit (doc_id id); doc_range_ocaml r;]) in - let doc_rids = group (separate_map (semi ^^ (break 1)) doc_rid rs) in - match n1,n2 with - | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> - let dir = i1 < i2 in - let size = if dir then i2-i1 +1 else i1-i2 in - doc_op equals - ((string "let") ^^ space ^^ doc_id_ocaml id ^^ space ^^ (string "init_val")) - (separate space [string "Vregister"; - (parens (separate comma_sp - [parens (separate space - [string "match init_val with"; - pipe; - string "None"; - arrow; - string "ref"; - string "(Array.make"; - doc_int size; - string "Vzero)"; - pipe; - string "Some init_val"; - arrow; - string "ref init_val";]); - doc_nexp n1; - string (if dir then "true" else "false"); - string_lit (doc_id id); - brackets doc_rids]))]) - -let doc_rec_ocaml (Rec_aux(r,_)) = match r with - | Rec_nonrec -> empty - | Rec_rec -> string "rec" ^^ space - -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 - separate hardline [string "let ret = ref None in"; - string "try"; - (doc_exp_ocaml ea); - string "with Sail_return -> match(!ret) with"; - string "| Some(x) -> x"; - string "| None -> failwith \"ret unset\"" - ] - else - doc_exp_ocaml ea - | _ -> doc_exp_ocaml ea - -let doc_funcl_ocaml (FCL_aux(FCL_Funcl(id,pat,exp),_)) = - group (doc_op arrow (doc_pat_ocaml pat) (doc_funcl_exp_ocaml exp)) - -let get_id = function - | [] -> failwith "FD_function with empty list" - | (FCL_aux (FCL_Funcl (id,_,_),_))::_ -> id - -let doc_fundef_ocaml (FD_aux(FD_function(r, typa, efa, fcls),_)) = - match fcls with - | [] -> failwith "FD_function with empty function list" - | [FCL_aux (FCL_Funcl(id,pat,exp),_)] -> - (separate space [(string "let"); (doc_rec_ocaml r); (doc_id_ocaml id); (doc_pat_ocaml pat); equals]) ^^ hardline ^^ (doc_funcl_exp_ocaml exp) - | _ -> - let id = get_id fcls in - let sep = hardline ^^ pipe ^^ space in - let clauses = separate_map sep doc_funcl_ocaml fcls in - separate space [string "let"; - doc_rec_ocaml r; - doc_id_ocaml id; - equals; - (string "function"); - (hardline^^pipe); - clauses] - -let doc_dec_ocaml (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 string "true" else string "false" in - separate space [string "let"; - doc_id_ocaml id; - equals; - string "Vregister"; - parens (separate comma [separate space [string "ref"; - parens (separate space - [string "Array.make"; - doc_int (int_of_big_int size); - string "Vzero";])]; - doc_int (int_of_big_int start); - o; - string_lit (doc_id id); - brackets empty])] - | _ -> empty) - | 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)); - string "None"] - |_-> failwith "type was not handled in register declaration") - | _ -> 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 (* - doc_op equals (string "register alias" ^^ space ^^ doc_atomic_typ typ) (doc_alias alspec) *) - -let doc_def_ocaml def = group (match def with - | DEF_default df -> empty - | DEF_spec v_spec -> empty (*unless we want to have a separate pass to create mli files*) - | DEF_type t_def -> doc_typdef_ocaml t_def - | DEF_fundef f_def -> doc_fundef_ocaml f_def - | DEF_val lbind -> doc_let_ocaml lbind - | 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_comm _ -> failwith "unhandled DEF_comm" - ) ^^ hardline - -let doc_defs_ocaml (Defs(defs)) = - separate_map hardline doc_def_ocaml defs -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..e585a8f1 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -40,8 +40,9 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal open Ast +open Ast_util +open Big_int open PPrint open Pretty_print_common @@ -49,27 +50,15 @@ open Pretty_print_common * PPrint-based source-to-source pretty printer ****************************************************************************) - - - let doc_bkind (BK_aux(k,_)) = string (match k with | BK_type -> "Type" | BK_nat -> "Nat" - | BK_order -> "Order" - | BK_effect -> "Effect") + | BK_order -> "Order") 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 - | NC_fixed(n1,n2) -> doc_op equals (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)) - let doc_qi (QI_aux(qi,_)) = match qi with | QI_const n_const -> doc_nexp_constraint n_const | QI_id(KOpt_aux(ki,_)) -> @@ -80,7 +69,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 @@ -100,11 +89,12 @@ let doc_lit (L_aux(l,_)) = | L_one -> "bitone" | L_true -> "true" | L_false -> "false" - | L_num i -> string_of_int i + | L_num i -> string_of_big_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 @@ -120,14 +110,17 @@ let doc_pat, doc_atomic_pat = | P_lit lit -> doc_lit lit | P_wild -> underscore | P_id id -> doc_id id + | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> + doc_var kid + | P_var(p,kid) -> parens (separate space [pat p; string "as"; doc_var kid]) | P_as(p,id) -> parens (separate space [pat p; string "as"; doc_id id]) | P_typ(typ,p) -> separate space [parens (doc_typ typ); atomic_pat p] | P_app(id,[]) -> doc_id id | P_record(fpats,_) -> braces (separate_map semi_sp fpat fpats) | P_vector pats -> brackets (separate_map comma_sp atomic_pat pats) - | 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; coloncolon; 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) @@ -165,7 +158,7 @@ let doc_exp, doc_let = | E_vector_append(l,r) -> doc_op colon (shift_exp l) (cons_exp r) | E_cons(l,r) -> - doc_op colon (shift_exp l) (cons_exp r) + doc_op coloncolon (shift_exp l) (cons_exp r) | _ -> shift_exp expr and shift_exp ((E_aux(e,_)) as expr) = match e with | E_app_infix(l,(Id_aux(Id (">>" | ">>>" | "<<" | "<<<"),_) as op),r) -> @@ -185,7 +178,8 @@ let doc_exp, doc_let = and starstar_exp ((E_aux(e,_)) as expr) = match e with | E_app_infix(l,(Id_aux(Id "**",_) as op),r) -> doc_op (doc_id op) (starstar_exp l) (app_exp r) - | E_if _ | E_for _ | E_let _ -> right_atomic_exp expr + | E_if _ | E_for _ | E_loop _ | E_let _ + | E_internal_let _ | E_internal_plet _ -> right_atomic_exp expr | _ -> app_exp expr and right_atomic_exp ((E_aux(e,_)) as expr) = match e with (* Special case: omit "else ()" when the else branch is empty. *) @@ -195,7 +189,14 @@ let doc_exp, doc_let = | E_if(c,t,e) -> string "if" ^^ space ^^ group (exp c) ^/^ string "then" ^^ space ^^ group (exp t) ^/^ - string "else" ^^ space ^^ group (exp e) + string "else" ^^ space ^^ group (exp e) + | E_loop (While, c, e) -> + separate space [string "while"; atomic_exp c; string "do"] ^/^ + exp e + | E_loop (Until, c, e) -> + (string "repeat" + ^/^ exp e) + ^/^ (string "until" ^^ space ^^ atomic_exp c) | E_for(id,exp1,exp2,exp3,order,exp4) -> string "foreach" ^^ space ^^ group (parens ( @@ -209,6 +210,18 @@ let doc_exp, doc_let = )) ^/^ exp exp4 | E_let(leb,e) -> doc_op (string "in") (let_exp leb) (exp e) + | E_internal_let (lexp, exp1, exp2) -> + let le = + prefix 2 1 + (separate space [string "internal_let"; doc_lexp lexp; equals]) + (exp exp1) in + doc_op (string "in") le (exp exp2) + | E_internal_plet (pat, exp1, exp2) -> + let le = + prefix 2 1 + (separate space [string "internal_plet"; doc_pat pat; equals]) + (exp exp1) in + doc_op (string "in") le (exp exp2) | _ -> group (parens (exp expr)) and app_exp ((E_aux(e,_)) as expr) = match e with | E_app(f,args) -> @@ -238,6 +251,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 +261,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,_),_)) -> @@ -270,13 +285,6 @@ let doc_exp, doc_let = ((match l with | L_one -> "1" | L_zero -> "0" | L_undef -> "u" | _ -> assert false) ^ rst) | _ -> assert false)) exps "")) | _ -> default_print ())) - | E_vector_indexed (iexps, (Def_val_aux (default,_))) -> - let default_string = - (match default with - | Def_val_empty -> string "" - | Def_val_dec e -> concat [semi; space; string "default"; equals; (exp e)]) in - let iexp (i,e) = doc_op equals (doc_int i) (exp e) in - brackets (concat [(separate_map comma iexp iexps); default_string]) | E_vector_update(v,e1,e2) -> brackets (doc_op (string "with") (exp v) (doc_op equals (atomic_exp e1) (exp e2))) | E_vector_update_subrange(v,e1,e2,e3) -> @@ -285,14 +293,22 @@ let doc_exp, doc_let = (doc_op equals (atomic_exp e1 ^^ colon ^^ atomic_exp e2) (exp e3))) | E_list exps -> squarebarbars (separate_map comma exp exps) + | E_try(e,pexps) -> + let opening = separate space [string "try"; exp e; string "catch"; lbrace] in + let cases = separate_map (break 1) doc_case pexps in + surround 2 1 opening cases rbrace | E_case(e,pexps) -> let opening = separate space [string "switch"; exp e; lbrace] in 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] + parens (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_throw e -> + separate space [string "throw"; atomic_exp e;] | E_return e -> separate space [string "return"; atomic_exp e;] | E_assert(c,m) -> @@ -300,7 +316,8 @@ let doc_exp, doc_let = (* adding parens and loop for lower precedence *) | E_app (_, _)|E_vector_access (_, _)|E_vector_subrange (_, _, _) | E_cons (_, _)|E_field (_, _)|E_assign (_, _) - | E_if _ | E_for _ | E_let _ + | E_if _ | E_for _ | E_loop _ | E_let _ + | E_internal_let _ | E_internal_plet _ | E_vector_append _ | E_app_infix (_, (* for every app_infix operator caught at a higher precedence, @@ -325,6 +342,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,27 +360,24 @@ 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 - + *) + | E_internal_return exp1 -> + separate space [string "internal_return"; exp exp1] + | _ -> failwith ("Cannot print: " ^ Ast_util.string_of_exp expr) and let_exp (LB_aux(lb,_)) = match lb with - | LB_val_explicit(ts,pat,e) -> - (match ts with - | TypSchm_aux (TypSchm_ts (TypQ_aux (TypQ_no_forall,_),_),_) -> - prefix 2 1 - (separate space [string "let"; parens (doc_typscm_atomic ts); doc_atomic_pat pat; equals]) - (atomic_exp e) - | _ -> - prefix 2 1 - (separate space [string "let"; doc_typscm_atomic ts; doc_atomic_pat pat; equals]) - (atomic_exp e)) - | LB_val_implicit(pat,e) -> + | LB_val(pat,e) -> prefix 2 1 (separate space [string "let"; doc_atomic_pat pat; equals]) (atomic_exp e) 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 +406,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] - | VS_extern_no_rename(ts,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))] + | VS_val_spec(ts,id,ext_opt,is_cast) -> + let cast_pp = if is_cast then [string "cast"] else [] in + (* This sail syntax only supports a single extern name, so just use the ocaml version *) + let extern_kwd_pp, id_pp = match ext_opt "ocaml" with + | Some ext -> [string "extern"], doc_op equals (doc_id id) (dquotes (string (ext))) + | None -> [], doc_id id + in + separate space ([string "val"] @ cast_pp @ extern_kwd_pp @ [doc_typscm ts] @ [id_pp]) + | _ -> failwith "Invalid valspec" let doc_namescm (Name_sect_aux(ns,_)) = match ns with | Name_sect_none -> empty @@ -443,46 +460,18 @@ let doc_typdef (TD_aux(td,_)) = match td with ]) let doc_kindef (KD_aux(kd,_)) = match kd with - | KD_abbrev(kind,id,nm,typschm) -> - doc_op equals (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) (doc_typscm typschm) | KD_nabbrev(kind,id,nm,n) -> doc_op equals (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) (doc_nexp n) - | KD_record(kind,id,nm,typq,fs,_) -> - let f_pp (typ,id) = concat [doc_typ typ; space; doc_id id; semi] in - let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals - (concat [string "def"; space;doc_kind kind; space; doc_id id; doc_namescm nm]) - (string "const struct" ^^ space ^^ doc_typquant typq (braces fs_doc)) - | KD_variant(kind,id,nm,typq,ar,_) -> - let ar_doc = group (separate_map (semi ^^ break 1) doc_type_union ar) in - doc_op equals - (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) - (string "const union" ^^ space ^^ doc_typquant typq (braces ar_doc)) - | KD_enum(kind,id,nm,enums,_) -> - let enums_doc = group (separate_map (semi ^^ break 1) doc_id enums) in - doc_op equals - (concat [string "def"; space; doc_kind kind; space; doc_id id; doc_namescm nm]) - (string "enumerate" ^^ space ^^ braces enums_doc) - | KD_register(kind,id,n1,n2,rs) -> - let doc_rid (r,id) = separate space [doc_range r; colon; doc_id id] ^^ semi in - let doc_rids = group (separate_map (break 1) doc_rid rs) in - doc_op equals - (string "def" ^^ space ^^ doc_kind kind ^^ space ^^ doc_id id) - (separate space [ - string "register bits"; - brackets (doc_nexp n1 ^^ colon ^^ doc_nexp n2); - braces doc_rids; - ]) - 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 +486,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,8 +537,12 @@ 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) + | DEF_fixity _ -> empty ) ^^ hardline let doc_defs (Defs(defs)) = diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml new file mode 100644 index 00000000..8ebef0f0 --- /dev/null +++ b/src/pretty_print_sail2.ml @@ -0,0 +1,396 @@ + +open Ast +open Ast_util +open Big_int +open PPrint + +let doc_op symb a b = infix 2 1 symb a b + +let doc_id (Id_aux (id_aux, _)) = + string (match id_aux with + | Id v -> v + | DeIid op -> "operator " ^ op) + +let doc_kid kid = string (Ast_util.string_of_kid kid) + +let doc_int n = string (string_of_big_int n) + +let doc_ord (Ord_aux(o,_)) = match o with + | Ord_var v -> doc_kid v + | Ord_inc -> string "inc" + | Ord_dec -> string "dec" + +let rec doc_nexp = + let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_constant c -> string (string_of_big_int c) + | Nexp_id id -> doc_id id + | Nexp_var kid -> doc_kid kid + | _ -> parens (nexp0 nexp) + and nexp0 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_sum (n1, Nexp_aux (Nexp_neg n2, _)) | Nexp_minus (n1, n2) -> + separate space [nexp0 n1; string "-"; nexp1 n2] + | Nexp_sum (n1, Nexp_aux (Nexp_constant c, _)) when lt_big_int c zero_big_int -> + separate space [nexp0 n1; string "-"; doc_int (abs_big_int c)] + | Nexp_sum (n1, n2) -> separate space [nexp0 n1; string "+"; nexp1 n2] + | _ -> nexp1 nexp + and nexp1 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_times (n1, n2) -> separate space [nexp1 n1; string "*"; nexp2 n2] + | _ -> nexp2 nexp + and nexp2 (Nexp_aux (n_aux, _) as nexp) = + match n_aux with + | Nexp_neg n -> separate space [string "-"; atomic_nexp n] + | Nexp_exp n -> separate space [string "2"; string "^"; atomic_nexp n] + | _ -> atomic_nexp nexp + in + nexp0 + +let doc_nc = + let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in + let rec atomic_nc (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_true -> string "true" + | NC_false -> string "false" + | NC_equal (n1, n2) -> nc_op "=" n1 n2 + | NC_not_equal (n1, n2) -> nc_op "!=" n1 n2 + | NC_bounded_ge (n1, n2) -> nc_op ">=" n1 n2 + | NC_bounded_le (n1, n2) -> nc_op "<=" n1 n2 + | NC_set (kid, ints) -> + separate space [doc_kid kid; string "in"; braces (separate_map (comma ^^ space) doc_int ints)] + | _ -> parens (nc0 nc) + and nc0 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_or (c1, c2) -> separate space [nc0 c1; string "|"; nc1 c2] + | _ -> nc1 nc + and nc1 (NC_aux (nc_aux, _) as nc) = + match nc_aux with + | NC_and (c1, c2) -> separate space [nc1 c1; string "&"; atomic_nc c2] + | _ -> atomic_nc nc + in + nc0 + +let rec doc_typ (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_id id -> doc_id id + | Typ_app (id, []) -> doc_id id + | Typ_app (Id_aux (DeIid str, _), [x; y]) -> + separate space [doc_typ_arg x; doc_typ_arg y] + (* + | Typ_app (id, [_; len; _; Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id tid, _)), _)]) when Id.compare (mk_id "vector") id == 0 && Id.compare (mk_id "bit") tid == 0-> + string "bits" ^^ parens (doc_typ_arg len) + *) + | Typ_app (id, typs) -> doc_id id ^^ parens (separate_map (string ", ") doc_typ_arg typs) + | Typ_tup typs -> parens (separate_map (string ", ") doc_typ typs) + | Typ_var kid -> doc_kid kid + (* Resugar set types like {|1, 2, 3|} *) + | Typ_exist ([kid1], NC_aux (NC_set (kid2, ints), _), Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid3, _)), _)]), _)) + when Kid.compare kid1 kid2 == 0 && Kid.compare kid2 kid3 == 0 && Id.compare (mk_id "atom") id == 0 -> + enclose (string "{|") (string "|}") (separate_map (string ", ") doc_int ints) + | Typ_exist (kids, nc, typ) -> + braces (separate_map space doc_kid kids ^^ comma ^^ space ^^ doc_nc nc ^^ dot ^^ space ^^ doc_typ typ) + | Typ_fn (typ1, typ2, Effect_aux (Effect_set [], _)) -> + separate space [doc_typ typ1; string "->"; doc_typ typ2] + | Typ_fn (typ1, typ2, Effect_aux (Effect_set effs, _)) -> + let ocaml_eff = braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs)) in + separate space [doc_typ typ1; string "->"; doc_typ typ2; string "effect"; ocaml_eff] +and doc_typ_arg (Typ_arg_aux (ta_aux, _)) = + match ta_aux with + | Typ_arg_typ typ -> doc_typ typ + | Typ_arg_nexp nexp -> doc_nexp nexp + | Typ_arg_order o -> doc_ord o + +let doc_quants quants = + let doc_qi_kopt (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_id (KOpt_aux (KOpt_none kid, _)) -> [doc_kid kid] + | QI_id kopt when is_nat_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Int"])] + | QI_id kopt when is_typ_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Type"])] + | QI_id kopt when is_order_kopt kopt -> [parens (separate space [doc_kid (kopt_kid kopt); colon; string "Order"])] + | QI_const nc -> [] + in + let qi_nc (QI_aux (qi_aux, _)) = + match qi_aux with + | QI_const nc -> [nc] + | _ -> [] + in + let kdoc = separate space (List.concat (List.map doc_qi_kopt quants)) in + let ncs = List.concat (List.map qi_nc quants) in + match ncs with + | [] -> kdoc + | [nc] -> kdoc ^^ comma ^^ space ^^ doc_nc nc + | nc :: ncs -> kdoc ^^ comma ^^ space ^^ doc_nc (List.fold_left nc_and nc ncs) + +let doc_typschm (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = + match tq_aux with + | TypQ_no_forall -> doc_typ typ + | TypQ_tq [] -> doc_typ typ + | TypQ_tq qs -> + string "forall" ^^ space ^^ doc_quants qs ^^ dot ^//^ doc_typ typ + +let doc_typschm_typ (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = doc_typ typ + +let doc_typschm_quants (TypSchm_aux (TypSchm_ts (TypQ_aux (tq_aux, _), typ), _)) = + match tq_aux with + | TypQ_no_forall -> None + | TypQ_tq [] -> None + | TypQ_tq qs -> Some (doc_quants qs) + +let doc_lit (L_aux(l,_)) = + utf8string (match l with + | L_unit -> "()" + | L_zero -> "bitzero" + | L_one -> "bitone" + | L_true -> "true" + | L_false -> "false" + | L_num i -> string_of_big_int i + | L_hex n -> "0x" ^ n + | L_bin n -> "0b" ^ n + | L_real r -> r + | L_undef -> "undefined" + | L_string s -> "\"" ^ String.escaped s ^ "\"") + +let rec doc_pat (P_aux (p_aux, _) as pat) = + match p_aux with + | P_id id -> doc_id id + | P_tup pats -> lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen + | P_app (id, pats) -> doc_id id ^^ lparen ^^ separate_map (comma ^^ space) doc_pat pats ^^ rparen + | P_typ (typ, pat) -> separate space [doc_pat pat; colon; doc_typ typ] + | P_lit lit -> doc_lit lit + (* P_var short form sugar *) + | P_var (P_aux (P_id id, _), kid) when Id.compare (id_of_kid kid) id == 0 -> + doc_kid kid + | P_var (pat, kid) -> separate space [doc_pat pat; string "as"; doc_kid kid] + | P_vector pats -> brackets (separate_map (comma ^^ space) doc_pat pats) + | P_vector_concat pats -> separate_map (space ^^ string "@" ^^ space) doc_pat pats + | P_wild -> string "_" + | P_as (pat, id) -> separate space [doc_pat pat; string "as"; doc_id id] + | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) + | _ -> string (string_of_pat pat) + +let rec doc_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_block [exp] -> doc_exp exp + | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace + | E_nondet exps -> assert false + (* This is mostly for the -convert option *) + | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> + separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] + | E_app_infix (x, id, y) -> separate space [doc_atomic_exp x; doc_id id; doc_atomic_exp y] + | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) + | E_if (if_exp, then_exp, else_exp) -> + group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) + | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" + | E_cons (exp1, exp2) -> string "E_cons" + | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] + | E_loop (While, cond, exp) -> + separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] + | E_loop (Until, cond, exp) -> + separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] + | E_record_update (exp, fexps) -> + separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] + | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] + | E_case (exp, pexps) -> + separate space [string "match"; doc_exp exp; doc_pexps pexps] + | E_let (LB_aux (LB_val (pat, binding), _), exp) -> + separate space [string "let"; doc_pat pat; equals; doc_exp binding; string "in"; doc_exp exp] + | E_internal_let (lexp, binding, exp) -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding; string "in"; doc_exp exp] + | E_assign (lexp, exp) -> + separate space [doc_lexp lexp; equals; doc_exp exp] + | E_for (id, exp1, exp2, exp3, order, exp4) -> + begin + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ doc_id id; + string "from " ^^ doc_atomic_exp exp1; + string "to " ^^ doc_atomic_exp exp2; + string "by " ^^ doc_atomic_exp exp3; + string "in " ^^ doc_ord order ])) + in + match exp4 with + | E_aux (E_block [_], _) -> header ^//^ doc_exp exp4 + | E_aux (E_block _, _) -> header ^^ space ^^ doc_exp exp4 + | _ -> header ^//^ doc_exp exp4 + end + (* Resugar an assert with an empty message *) + | E_throw exp -> assert false + | E_try (exp, pexps) -> assert false + | E_return exp -> string "return" ^^ parens (doc_exp exp) + | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> + separate space [string "2"; string "^"; doc_atomic_exp exp] + | _ -> doc_atomic_exp exp +and doc_atomic_exp (E_aux (e_aux, _) as exp) = + match e_aux with + | E_cast (typ, exp) -> + separate space [doc_atomic_exp exp; colon; doc_typ typ] + | E_lit lit -> doc_lit lit + | E_id id -> doc_id id + | E_field (exp, id) -> doc_atomic_exp exp ^^ dot ^^ doc_id id + | E_sizeof (Nexp_aux (Nexp_var kid, _)) -> doc_kid kid + | E_sizeof nexp -> string "sizeof" ^^ parens (doc_nexp nexp) + (* Format a function with a unit argument as f() rather than f(()) *) + | E_app (id, [E_aux (E_lit (L_aux (L_unit, _)), _)]) -> doc_id id ^^ string "()" + | E_app (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | E_constraint nc -> string "constraint" ^^ parens (doc_nc nc) + | E_assert (exp1, E_aux (E_lit (L_aux (L_string "", _)), _)) -> string "assert" ^^ parens (doc_exp exp1) + | E_assert (exp1, exp2) -> string "assert" ^^ parens (doc_exp exp1 ^^ comma ^^ space ^^ doc_exp exp2) + | E_exit exp -> string "exit" ^^ parens (doc_exp exp) + | E_vector_access (exp1, exp2) -> doc_atomic_exp exp1 ^^ brackets (doc_exp exp2) + | E_vector_subrange (exp1, exp2, exp3) -> doc_atomic_exp exp1 ^^ brackets (separate space [doc_exp exp2; string ".."; doc_exp exp3]) + | E_vector exps -> brackets (separate_map (comma ^^ space) doc_exp exps) + | E_vector_update (exp1, exp2, exp3) -> + brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; equals; doc_exp exp3]) + | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> + brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) + | _ -> parens (doc_exp exp) +and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = + separate_map (comma ^^ space) doc_fexp fexps +and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = + separate space [doc_id id; equals; doc_exp exp] +and doc_block = function + | [] -> string "()" + | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> + separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [E_aux (E_internal_let (lexp, binding, E_aux (E_block exps, _)), _)] -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [exp] -> doc_exp exp + | exp :: exps -> doc_exp exp ^^ semi ^^ hardline ^^ doc_block exps +and doc_lexp (LEXP_aux (l_aux, _) as lexp) = + match l_aux with + | LEXP_cast (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + | _ -> doc_atomic_lexp lexp +and doc_atomic_lexp (LEXP_aux (l_aux, _) as lexp) = + match l_aux with + | LEXP_id id -> doc_id id + | LEXP_tup lexps -> lparen ^^ separate_map (comma ^^ space) doc_lexp lexps ^^ rparen + | LEXP_field (lexp, id) -> doc_atomic_lexp lexp ^^ dot ^^ doc_id id + | LEXP_vector (lexp, exp) -> doc_atomic_lexp lexp ^^ brackets (doc_exp exp) + | LEXP_vector_range (lexp, exp1, exp2) -> doc_atomic_lexp lexp ^^ brackets (separate space [doc_exp exp1; string ".."; doc_exp exp2]) + | LEXP_memory (id, exps) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_exp exps) + | _ -> parens (doc_lexp lexp) +and doc_pexps pexps = surround 2 0 lbrace (separate_map (comma ^^ hardline) doc_pexp pexps) rbrace +and doc_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_exp (pat, exp) -> separate space [doc_pat pat; string "=>"; doc_exp exp] + | Pat_when (pat, wh, exp) -> + separate space [doc_pat pat; string "if"; doc_exp wh; string "=>"; doc_exp exp] +and doc_letbind (LB_aux (lb_aux, _)) = + match lb_aux with + | LB_val (pat, exp) -> + separate space [doc_pat pat; equals; doc_exp exp] + +let doc_funcl funcl = string "FUNCL" + +let doc_funcl (FCL_aux (FCL_Funcl (id, pat, exp), _)) = + group (separate space [doc_id id; doc_pat pat; equals; doc_exp exp]) + +let doc_default (DT_aux(df,_)) = match df with + | DT_kind(bk,v) -> string "DT_kind" (* separate space [string "default"; doc_bkind bk; doc_var v] *) + | DT_typ(ts,id) -> separate space [string "default"; doc_typschm ts; doc_id id] + | DT_order(ord) -> separate space [string "default"; string "Order"; doc_ord ord] + +let doc_fundef (FD_aux (FD_function (r, typa, efa, funcls), _)) = + match funcls with + | [] -> failwith "Empty function list" + | _ -> + let sep = hardline ^^ string "and" ^^ space in + let clauses = separate_map sep doc_funcl funcls in + string "function" ^^ space ^^ clauses + +let doc_dec (DEC_aux (reg,_)) = + match reg with + | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ] + | DEC_alias(id,alspec) -> string "ALIAS" + | DEC_typ_alias(typ,id,alspec) -> string "ALIAS" + +let doc_field (typ, id) = + separate space [doc_id id; colon; doc_typ typ] + +let doc_union (Tu_aux (tu, l)) = match tu with + | Tu_id id -> doc_id id + | Tu_ty_id (typ, id) -> separate space [doc_id id; colon; doc_typ typ] + +let doc_typdef (TD_aux(td,_)) = match td with + | TD_abbrev (id, _, typschm) -> + begin + match doc_typschm_quants typschm with + | Some qdoc -> + doc_op equals (concat [string "type"; space; doc_id id; space; qdoc]) (doc_typschm_typ typschm) + | None -> + doc_op equals (concat [string "type"; space; doc_id id]) (doc_typschm_typ typschm) + end + | TD_enum (id, _, ids, _) -> + separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) -> + separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) -> + separate space [string "struct"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) -> + separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) -> + separate space [string "union"; doc_id id; doc_quants qs; equals; + surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace] + | _ -> string "TYPEDEF" + +let doc_spec (VS_aux(v,_)) = + let doc_extern ext = + let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ + utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in + let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"]) in + if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) + in + match v with + | VS_val_spec(ts,id,ext,is_cast) -> + string "val" ^^ space + ^^ (if is_cast then (string "cast" ^^ space) else empty) + ^^ doc_id id ^^ space + ^^ doc_extern ext + ^^ colon ^^ space + ^^ doc_typschm ts + +let doc_prec = function + | Infix -> string "infix" + | InfixL -> string "infixl" + | InfixR -> string "infixr" + +let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) = + separate space [string "integer"; doc_id id; equals; doc_nexp nexp] + +let rec doc_scattered (SD_aux (sd_aux, _)) = + match sd_aux with + | SD_scattered_function (_, _, _, id) -> + string "scattered" ^^ space ^^ string "function" ^^ space ^^ doc_id id + | SD_scattered_funcl funcl -> + string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl + | SD_scattered_end id -> + string "end" ^^ space ^^ doc_id id + | _ -> string "SCATTERED" + +let rec doc_def def = group (match def with + | DEF_default df -> doc_default df + | DEF_spec v_spec -> doc_spec v_spec + | DEF_type t_def -> doc_typdef t_def + | DEF_kind k_def -> doc_kind_def k_def + | DEF_fundef f_def -> doc_fundef f_def + | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind + | DEF_internal_mutrec fundefs -> + (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) + ^^ hardline ^^ string "}" + | DEF_reg_dec dec -> doc_dec dec + | DEF_scattered sdef -> doc_scattered sdef + | DEF_fixity (prec, n, id) -> + separate space [doc_prec prec; doc_int n; doc_id id] + | DEF_overload (id, ids) -> + separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] + | DEF_comm (DC_comm s) -> string "TOPLEVEL" + | DEF_comm (DC_comm_struct d) -> string "TOPLEVEL" + ) ^^ hardline + +let doc_defs (Defs(defs)) = + separate_map hardline doc_def defs + +let pp_defs f d = ToChannel.pretty 1. 80 f (doc_defs d) 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 39a8bf58..75e3092f 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -40,68 +40,93 @@ (* SUCH DAMAGE. *) (**************************************************************************) -open Type_internal +let opt_new_parser = ref false +let opt_lem_sequential = ref false +let opt_lem_mwords = ref false type out_type = | Lem_ast_out | Lem_out of string option - | Ocaml_out of string option -let get_lexbuf fn = - let lexbuf = Lexing.from_channel (open_in fn) in - lexbuf.Lexing.lex_curr_p <- { Lexing.pos_fname = fn; - Lexing.pos_lnum = 1; - Lexing.pos_bol = 0; - Lexing.pos_cnum = 0; }; - lexbuf +let get_lexbuf f = + let in_chan = open_in f in + let lexbuf = Lexing.from_channel in_chan in + lexbuf.Lexing.lex_curr_p <- { Lexing.pos_fname = f; + Lexing.pos_lnum = 1; + Lexing.pos_bol = 0; + Lexing.pos_cnum = 0; }; + lexbuf, in_chan let parse_file (f : string) : Parse_ast.defs = - let scanbuf = get_lexbuf f in - let type_names = - try - Pre_parser.file Pre_lexer.token scanbuf - with + if not !opt_new_parser + then + let scanbuf, in_chan = get_lexbuf f in + let type_names = + try + Pre_parser.file Pre_lexer.token scanbuf + with | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p scanbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "pre"))) + let pos = Lexing.lexeme_start_p scanbuf in + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "pre"))) | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) | Lexer.LexError(s,p) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) in - let () = Lexer.custom_type_names := !Lexer.custom_type_names @ type_names in - let lexbuf = get_lexbuf f in + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) + in + close_in in_chan; + Lexer.custom_type_names := !Lexer.custom_type_names @ type_names + else (); + + let lexbuf, in_chan = get_lexbuf f in try - Parser.file Lexer.token lexbuf + let ast = + if !opt_new_parser + then Parser2.file Lexer2.token lexbuf + else Parser.file Lexer.token lexbuf + in + close_in in_chan; ast with - | Parsing.Parse_error -> - let pos = Lexing.lexeme_start_p lexbuf in - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "main"))) - | Parse_ast.Parse_error_locn(l,m) -> - raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) - | 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 + | Parser2.Error -> + let pos = Lexing.lexeme_start_p lexbuf in + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "no information"))) + | Parsing.Parse_error -> + let pos = Lexing.lexeme_start_p lexbuf in + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax (pos, "main"))) + | Parse_ast.Parse_error_locn(l,m) -> + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_syntax_locn (l, m))) + | Lexer.LexError(s,p) -> + raise (Reporting_basic.Fatal_error (Reporting_basic.Err_lex (p, s))) + +let convert_ast (order : Ast.order) (defs : Parse_ast.defs) : unit Ast.defs = Initial_check.process_ast order defs + +let load_file_no_check order f = convert_ast order (parse_file f) + +let load_file order env f = + let ast = convert_ast order (parse_file f) in + Type_check.check env ast + +let opt_just_check = ref false +let opt_ddump_tc_ast = ref false +let opt_ddump_rewrite_ast = ref None +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 opt_ddump_raw_mono_ast = ref false +let opt_dmono_analysis = ref 0 +let opt_auto_mono = ref false + +let monomorphise_ast locs type_env ast = + let ast = Monomorphise.monomorphise (!opt_lem_mwords) (!opt_auto_mono) (!opt_dmono_analysis) + locs type_env ast in + let () = if !opt_ddump_raw_mono_ast then Pretty_print.pp_defs stdout ast else () in + let ienv = Type_check.Env.no_casts Type_check.initial_env in + Type_check.check ienv ast let open_output_with_check file_name = let (temp_file_name, o) = Filename.open_temp_file "ll_temp" "" in @@ -124,6 +149,35 @@ let close_output_with_check (o, temp_file_name, file_name) = let generated_line f = Printf.sprintf "Generated by Sail from %s." f +let output_lem filename libs defs = + let generated_line = generated_line filename in + let seq_suffix = if !opt_lem_sequential then "_sequential" else "" in + let types_module = (filename ^ "_embed_types" ^ seq_suffix) in + let monad_module = if !opt_lem_sequential then "State" else "Prompt" in + let operators_module = if !opt_lem_mwords then "Sail_operators_mwords" else "Sail_operators" in + let libs = List.map (fun lib -> lib ^ seq_suffix) libs in + let base_imports = [ + "Pervasives_extra"; + "Sail_impl_base"; + "Sail_values"; + operators_module; + monad_module + ] in + let ((ot,_, _) as ext_ot) = + open_output_with_check_unformatted (filename ^ "_embed_types" ^ seq_suffix ^ ".lem") in + let ((o,_, _) as ext_o) = + open_output_with_check_unformatted (filename ^ "_embed" ^ seq_suffix ^ ".lem") in + (Pretty_print.pp_defs_lem !opt_lem_sequential !opt_lem_mwords + (ot, base_imports) + (o, base_imports @ (String.capitalize types_module :: libs)) + defs generated_line); + close_output_with_check ext_ot; + close_output_with_check ext_o + +let rec iterate (f : int -> unit) (n : int) : unit = + if n = 0 then () + else (f n; iterate f (n - 1)) + let output1 libpath out_arg filename defs = let f' = Filename.basename (Filename.chop_extension filename) in match out_arg with @@ -134,100 +188,15 @@ let output1 libpath out_arg filename defs = Format.fprintf o "open import Interp_ast@\n"; Format.fprintf o "open import Pervasives@\n"; Format.fprintf o "(*Supply common numeric constants at the right type to alleviate repeated calls to typeclass macro*)\n"; - Format.fprintf o "let zero : integer = integerFromNat 0\n"; - Format.fprintf o "let one : integer = integerFromNat 1\n"; - Format.fprintf o "let two : integer = integerFromNat 2\n"; - Format.fprintf o "let three : integer = integerFromNat 3\n"; - Format.fprintf o "let four : integer = integerFromNat 4\n"; - Format.fprintf o "let five : integer = integerFromNat 5\n"; - Format.fprintf o "let six : integer = integerFromNat 6\n"; - Format.fprintf o "let seven : integer = integerFromNat 7\n"; - Format.fprintf o "let eight : integer = integerFromNat 8\n"; - Format.fprintf o "let fifteen : integer = integerFromNat 15\n"; - Format.fprintf o "let sixteen : integer = integerFromNat 16\n"; - Format.fprintf o "let twenty : integer = integerFromNat 20\n"; - Format.fprintf o "let twentythree : integer = integerFromNat 23\n"; - Format.fprintf o "let twentyfour : integer = integerFromNat 24\n"; - Format.fprintf o "let thirty : integer = integerFromNat 30\n"; - Format.fprintf o "let thirtyone : integer = integerFromNat 31\n"; - Format.fprintf o "let thirtytwo : integer = integerFromNat 32\n"; - Format.fprintf o "let thirtyfive : integer = integerFromNat 35\n"; - Format.fprintf o "let thirtynine : integer = integerFromNat 39\n"; - Format.fprintf o "let forty : integer = integerFromNat 40\n"; - Format.fprintf o "let fortyseven : integer = integerFromNat 47\n"; - Format.fprintf o "let fortyeight : integer = integerFromNat 48\n"; - Format.fprintf o "let fiftyfive : integer = integerFromNat 55\n"; - Format.fprintf o "let fiftysix : integer = integerFromNat 56\n"; - Format.fprintf o "let fiftyseven : integer = integerFromNat 57\n"; - Format.fprintf o "let sixtyone : integer = integerFromNat 61\n"; - Format.fprintf o "let sixtythree : integer = integerFromNat 63\n"; - Format.fprintf o "let sixtyfour : integer = integerFromNat 64\n"; - Format.fprintf o "let onetwentyseven : integer = integerFromNat 127\n"; - Format.fprintf o "let onetwentyeight : integer = integerFromNat 128\n"; - + iterate (fun n -> Format.fprintf o "let int%i : integer = integerFromNat %i\n" (n - 1) (n - 1)) 129; Format.fprintf o "let defs = "; Pretty_print.pp_lem_defs o defs; close_output_with_check ext_o end | Lem_out None -> - let generated_line = generated_line filename in - let types_module = (f' ^ "_embed_types") in - let tofrom_module = (f' ^ "_toFromInterp") in - let ((o,_, _) as ext_o) = - open_output_with_check_unformatted (f' ^ "_embed_types.lem") in - let ((o',_, _) as ext_o') = - open_output_with_check_unformatted (f' ^ "_embed.lem") in - let ((o'',_, _) as ext_o'') = - open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in - let ((o''',_, _) as ext_o''') = - open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in - (Pretty_print.pp_defs_lem - (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) - (o',["Pervasives_extra";"Sail_impl_base";"Prompt";"Sail_values"; - String.capitalize types_module]) - (o'',["Pervasives_extra";"Sail_impl_base";"State";"Sail_values"; - String.capitalize types_module]) - (o''',["Pervasives_extra";"Sail_impl_base";"Sail_values"; - String.capitalize types_module]) - defs generated_line); - close_output_with_check ext_o; - close_output_with_check ext_o'; - close_output_with_check ext_o''; + output_lem f' [] defs | Lem_out (Some lib) -> - let generated_line = generated_line filename in - let types_module = (f' ^ "_embed_types") in - let tofrom_module = (f' ^ "_toFromInterp") in - let ((o,_, _) as ext_o) = - open_output_with_check_unformatted (f' ^ "_embed_types.lem") in - let ((o',_, _) as ext_o') = - open_output_with_check_unformatted (f' ^ "_embed.lem") in - let ((o'',_, _) as ext_o'') = - open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in - let ((o''',_, _) as ext_o''') = - open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in - (Pretty_print.pp_defs_lem - (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) - (o',["Pervasives_extra";"Sail_impl_base";"Prompt"; - "Sail_values";String.capitalize types_module;lib]) - (o'',["Pervasives_extra";"Sail_impl_base";"State"; - "Sail_values";String.capitalize types_module;lib ^ "_sequential"]) - (o''',["Pervasives_extra";"Sail_impl_base"; - "Sail_values";String.capitalize types_module;lib]) - defs generated_line); - close_output_with_check ext_o; - close_output_with_check ext_o'; - close_output_with_check ext_o''; - close_output_with_check ext_o''' - | Ocaml_out None -> - let ((o,temp_file_name, _) as ext_o) = open_output_with_check_unformatted (f' ^ ".ml") in - begin Pretty_print.pp_defs_ocaml o defs (generated_line filename) ["Big_int_Z";"Sail_values"]; - close_output_with_check ext_o - end - | Ocaml_out (Some lib) -> - let ((o,temp_file_name, _) as ext_o) = open_output_with_check_unformatted (f' ^ ".ml") in - Pretty_print.pp_defs_ocaml o defs (generated_line filename) ["Big_int_Z"; "Sail_values"; lib]; - close_output_with_check ext_o - + output_lem f' [lib] defs let output libpath out_arg files = List.iter @@ -235,3 +204,30 @@ let output libpath out_arg files = output1 libpath out_arg f defs) files +let rewrite_step defs (name,rewriter) = + let defs = rewriter defs in + let _ = match !(opt_ddump_rewrite_ast) with + | Some (f, i) -> + begin + let filename = f ^ "_rewrite_" ^ string_of_int i ^ "_" ^ name ^ ".sail" in + (* output "" Lem_ast_out [filename, defs]; *) + let ((ot,_, _) as ext_ot) = open_output_with_check_unformatted filename in + Pretty_print_sail2.pp_defs ot defs; + close_output_with_check ext_ot; + opt_ddump_rewrite_ast := Some (f, i + 1) + end + | _ -> () in + defs + +let rewrite rewriters defs = + try List.fold_left rewrite_step defs rewriters with + | Type_check.Type_error (_, err) -> + prerr_endline (Type_check.string_of_type_error err); + exit 1 + +let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] +let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !opt_lem_mwords x)] +let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem +let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_sil = rewrite Rewrites.rewrite_defs_sil +let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/process_file.mli b/src/process_file.mli index 2c18b830..116df06e 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -41,22 +41,38 @@ (**************************************************************************) 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 : Ast.order -> 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.Env.t -> 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_undefined: 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 rewrite_ast_sil : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs + +val load_file_no_check : Ast.order -> string -> unit Ast.defs +val load_file : Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t + +val opt_new_parser : bool ref +val opt_lem_sequential : bool ref +val opt_lem_mwords : bool ref +val opt_just_check : bool ref +val opt_ddump_tc_ast : bool ref +val opt_ddump_rewrite_ast : ((string * int) option) ref +val opt_dno_cast : bool ref +val opt_ddump_raw_mono_ast : bool ref +val opt_dmono_analysis : int ref +val opt_auto_mono : bool ref type out_type = | Lem_ast_out | Lem_out of string option (* If present, the string is a file to open in the lem backend*) - | Ocaml_out of string option (* If present, the string is a file to open in the ocaml backend*) 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/reporting_basic.ml b/src/reporting_basic.ml index 5ff43208..a47ee8ae 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -87,19 +87,84 @@ (* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (**************************************************************************) -let format_pos ff p = ( - Format.fprintf ff "File \"%s\", line %d, character %d:\n" - p.Lexing.pos_fname p.Lexing.pos_lnum (p.Lexing.pos_cnum - p.Lexing.pos_bol); - Format.pp_print_flush ff ()) +let rec skip_lines in_chan = function + | n when n <= 0 -> () + | n -> input_line in_chan; skip_lines in_chan (n - 1) +let rec read_lines in_chan = function + | n when n <= 0 -> [] + | n -> + let l = input_line in_chan in + let ls = read_lines in_chan (n - 1) in + l :: ls -let format_pos2 ff p1 p2 = ( - Format.fprintf ff "File \"%s\", line %d, character %d to line %d, character %d" - p1.Lexing.pos_fname - p1.Lexing.pos_lnum (p1.Lexing.pos_cnum - p1.Lexing.pos_bol + 1) - p2.Lexing.pos_lnum (p2.Lexing.pos_cnum - p2.Lexing.pos_bol); - Format.pp_print_flush ff () -) +let termcode n = "\x1B[" ^ string_of_int n ^ "m" + +let print_code1 ff fname lnum1 cnum1 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s%s" + (Str.string_before line cnum1) + (termcode 41) + (Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1)) + (termcode 49) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; print_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos ff p = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d:\n\n" + p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol); + print_code1 ff p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (p.pos_cnum - p.pos_bol + 1); + Format.fprintf ff "\n\n"; + Format.pp_print_flush ff () + end + +let print_code2 ff fname lnum1 cnum1 lnum2 cnum2 = + try + let in_chan = open_in fname in + begin + try + skip_lines in_chan (lnum1 - 1); + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s\n" + (Str.string_before line cnum1) + (termcode 41) + (Str.string_after line cnum1) + (termcode 49); + let lines = read_lines in_chan (lnum2 - lnum1 - 1) in + List.iter (fun l -> Format.fprintf ff "%s%s%s\n" (termcode 41) l (termcode 49)) lines; + let line = input_line in_chan in + Format.fprintf ff "%s%s%s%s" + (termcode 41) + (Str.string_before line cnum2) + (termcode 49) + (Str.string_after line cnum2); + close_in in_chan + with e -> (close_in_noerr in_chan; print_endline (Printexc.to_string e)) + end + with _ -> () + +let format_pos2 ff p1 p2 = + let open Lexing in + begin + Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n" + p1.pos_fname + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + if p1.pos_lnum == p2.pos_lnum + then print_code1 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) + else print_code2 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol); + Format.pp_print_flush ff () + end (* reads the part between p1 and p2 from the file *) @@ -171,12 +236,12 @@ let loc_to_string l = type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position let print_err_internal fatal verb_loc p_l m1 m2 = + Format.eprintf "%s at " m1; let _ = (match p_l with Pos p -> print_err_pos p | Loc l -> print_err_loc l | LocD (l1,l2) -> print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in - let m12 = if String.length m2 = 0 then "" else ": " in - Format.eprintf " %s%s%s\n" m1 m12 m2; + Format.eprintf "%s\n" m2; if verb_loc then (match p_l with Loc l -> format_loc_source Format.err_formatter l; Format.pp_print_newline Format.err_formatter (); | _ -> ()); @@ -220,5 +285,6 @@ let report_error e = let (m1, verb_pos, pos_l, m2) = dest_err e in (print_err_internal verb_pos false pos_l m1 m2; exit 1) - - +let print_error e = + let (m1, verb_pos, pos_l, m2) = dest_err e in + print_err_internal verb_pos false pos_l m1 m2 diff --git a/src/reporting_basic.mli b/src/reporting_basic.mli index 559be9d4..3d1cbe13 100644 --- a/src/reporting_basic.mli +++ b/src/reporting_basic.mli @@ -104,3 +104,4 @@ val err_typ_dual : Parse_ast.l -> Parse_ast.l -> string -> exn raising a [Fatal_error] exception is recommended. *) val report_error : error -> 'a +val print_error : error -> unit diff --git a/src/rewriter.ml b/src/rewriter.ml index d26879e9..c483cf9b 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,237 +43,190 @@ 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; } -let (>>) f g = fun x -> g(f(x)) - -let fresh_name_counter = ref 0 - -let fresh_name () = - let current = !fresh_name_counter in - let () = fresh_name_counter := (current + 1) in - current -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 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 +(* The typechecker does not seem to annotate pexps themselves *) +let effect_of_pexp (Pat_aux (pexp,(_,a))) = match a with + | Some (_, _, eff) -> eff + | None -> + (match pexp with + | Pat_exp (_, e) -> effect_of e + | Pat_when (_, g, e) -> union_effects (effect_of g) (effect_of e)) +let effect_of_lb (LB_aux (_,(_,a))) = effect_of_annot a + +let simple_annot l typ = (gen_loc l, Some (Env.empty, typ, no_effect)) + +let rec small (E_aux (exp,_)) = match exp with + | E_id _ + | E_lit _ -> true + | E_cast (_,e) -> small e + | E_list es -> List.for_all small es + | E_cons (e1,e2) -> small e1 && small e2 + | E_sizeof _ -> true + | _ -> false + +let union_eff_exps es = + List.fold_left union_effects no_effect (List.map effect_of es) + +let fun_app_effects id env = + try + match Env.get_val_spec id env with + | (_, Typ_aux (Typ_fn (_,_,feff), _)) -> feff + | _ -> no_effect + with + | _ -> no_effect + +let fix_eff_exp (E_aux (e,((l,_) as annot))) = match snd annot with +| Some (env, typ, eff) -> let effsum = match e with - | E_block es -> eff_union_exps es - | E_nondet es -> eff_union_exps es + | 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_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_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 + | E_lit _ -> eff + | E_cast (_,e) -> effect_of e + | E_app (f,es) -> + union_effects (fun_app_effects f env) (union_eff_exps es) + | E_tuple es -> union_eff_exps es + | E_app_infix (e1,f,e2) -> + union_effects (fun_app_effects f env) (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_loop (_,e1,e2) -> union_eff_exps [e1;e2] + | E_vector es -> 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 -> union_effects eff (effect_of e) + | E_return e -> union_effects eff (effect_of e) + | E_sizeof _ | E_sizeof_internal _ | E_constraint _ -> no_effect + | E_assert (c,m) -> union_effects eff (union_eff_exps [c; m]) + | 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 + 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_tup les -> + List.fold_left (fun eff le -> union_effects eff (effect_of_lexp le)) no_effect les + | 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 = 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 + | Pat_exp (_,e) -> effect_of e + | Pat_when (_,e,e') -> union_effects (effect_of 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 = 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 - | [] -> 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 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 - let actual_rewrite_n nexp = - match nexp.nexp with - | Nconst i -> E_aux (E_lit (L_aux (L_num (int_of_big_int i),l)), (l,simple_annot typ)) - | Nadd (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "+",l)),rewrite n2), - (l, (tag_annot typ (External (Some "add"))))) - | Nmult (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "*",l)),rewrite n2), - (l, tag_annot typ (External (Some "multiply")))) - | Nsub (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "-",l)),rewrite n2), - (l, tag_annot typ (External (Some "minus")))) - | N2n (n, _) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 2,l)), (l, simple_annot (mk_atom_typ n_two))), - (Id_aux (Id "**",l)), - rewrite n), (l, tag_annot typ (External (Some "power")))) - | Npow(n,i) -> E_aux (E_app_infix - (rewrite n, (Id_aux (Id "**",l)), - E_aux (E_lit (L_aux (L_num i,l)), - (l, simple_annot (mk_atom_typ (mk_c_int i))))), - (l, tag_annot typ (External (Some "power")))) - | Nneg(n) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 0,l)), (l, simple_annot (mk_atom_typ n_zero))), - (Id_aux (Id "-",l)), - rewrite n), - (l, tag_annot typ (External (Some "minus")))) - | Nvar v -> (*TODO these need to generate an error as it's a place where there's insufficient specification. - But, for now I need to permit this to make power.sail compile, and most errors are in trap - or vectors *) - (*let _ = Printf.eprintf "unbound variable here %s\n" v in*) - E_aux (E_id (Id_aux (Id v,l)),(l,simple_annot typ)) - | _ -> raise (Reporting_basic.err_unreachable l ("rewrite_nexp given n that can't be rewritten: " ^ (n_to_string nexp))) in - match program_vars with - | None -> actual_rewrite_n nexp - | Some program_vars -> - (match partial_assoc nexp_eq_check nexp program_vars with - | None -> actual_rewrite_n nexp - | Some(None,ev) -> - (*let _ = Printf.eprintf "var case of rewrite, %s\n" ev in*) - E_aux (E_id (Id_aux (Id ev,l)), (l, simple_annot typ)) - | Some(Some f,ev) -> - E_aux (E_app ((Id_aux (Id f,l)), [ (E_aux (E_id (Id_aux (Id ev,l)), (l,simple_annot typ)))]), - (l, tag_annot typ (External (Some f))))) - -let rec match_to_program_vars ns bounds = - match ns with - | [] -> [] - | n::ns -> match find_var_from_nexp n bounds with - | 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) + | LB_val (_,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 (propagate_exp_effect eaux)) +let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) + +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 explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in exp (String.length s - 1) [] - let vector_string_to_bit_list l lit = let hexchar_to_binlist = function @@ -293,46 +247,46 @@ let vector_string_to_bit_list l lit = | 'E' -> ['1';'1';'1';'0'] | 'F' -> ['1';'1';'1';'1'] | _ -> raise (Reporting_basic.err_unreachable l "hexchar_to_binlist given unrecognized character") in - + let s_bin = match lit with | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase s_hex))) | L_bin s_bin -> explode s_bin | _ -> raise (Reporting_basic.err_unreachable l "s_bin given non vector literal") in - List.map (function '0' -> L_aux (L_zero, Parse_ast.Generated l) - | '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 + List.map (function '0' -> L_aux (L_zero, gen_loc l) + | '1' -> L_aux (L_one, gen_loc l) + | _ -> raise (Reporting_basic.err_unreachable (gen_loc 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_lit _ | P_wild | P_id _ | P_var _ -> rewrap 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, false)) | P_vector pats -> rewrap (P_vector(List.map rewrite pats)) - | P_vector_indexed ipats -> rewrap (P_vector_indexed(List.map (fun (i,pat) -> (i, rewrite pat)) ipats)) | 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 @@ -343,194 +297,82 @@ let rewrite_exp rewriters nmap (E_aux (exp,(l,annot))) = | E_if (c,t,e) -> rewrap (E_if (rewrite c,rewrite t, rewrite e)) | E_for (id, e1, e2, e3, o, body) -> rewrap (E_for (id, rewrite e1, rewrite e2, rewrite e3, o, rewrite body)) + | E_loop (loop, e1, e2) -> + rewrap (E_loop (loop, rewrite e1, rewrite e2)) | E_vector exps -> rewrap (E_vector (List.map rewrite exps)) - | E_vector_indexed (exps,(Def_val_aux(default,dannot))) -> - let def = match default with - | Def_val_empty -> default - | Def_val_dec e -> Def_val_dec (rewrite e) in - rewrap (E_vector_indexed (List.map (fun (i,e) -> (i, rewrite e)) exps, Def_val_aux(def,dannot))) | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite vec,rewrite index)) | E_vector_subrange (vec,i1,i2) -> rewrap (E_vector_subrange (rewrite vec,rewrite i1,rewrite i2)) - | E_vector_update (vec,index,new_v) -> + | E_vector_update (vec,index,new_v) -> rewrap (E_vector_update (rewrite vec,rewrite index,rewrite new_v)) | E_vector_update_subrange (vec,i1,i2,new_v) -> rewrap (E_vector_update_subrange (rewrite vec,rewrite i1,rewrite i2,rewrite new_v)) | E_vector_append (v1,v2) -> rewrap (E_vector_append (rewrite v1,rewrite v2)) - | E_list exps -> rewrap (E_list (List.map rewrite exps)) + | E_list exps -> rewrap (E_list (List.map rewrite exps)) | E_cons(h,t) -> rewrap (E_cons (rewrite h,rewrite t)) - | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> - rewrap (E_record - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> + rewrap (E_record + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot))) | E_record_update (re,(FES_aux (FES_Fexps(fexps, bool),fannot))) -> rewrap (E_record_update ((rewrite re), - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot)))) | E_field(exp,id) -> rewrap (E_field(rewrite exp,id)) - | E_case (exp ,pexps) -> - 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)) + | E_case (exp,pexps) -> + let rewrite_pexp = function + | (Pat_aux (Pat_exp(p, e), pannot)) -> + Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters p, rewrite e), pannot) + | (Pat_aux (Pat_when(p, e, e'), pannot)) -> + Pat_aux (Pat_when(rewriters.rewrite_pat rewriters p, rewrite e, rewrite e'), pannot) in + rewrap (E_case (rewrite exp, List.map rewrite_pexp 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 - (*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),_,_,_,_,_))) -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the two types are %s and %s\n" - (t_to_string t) (t_to_string exp_t) in*) - (match t.t,exp_t.t with - (*TODO should pass d_env into here so that I can look at the abbreviations if there are any here*) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("vector",[TA_nexp n2;TA_nexp nw2;TA_ord o2;_]) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("reg",[TA_typ {t=(Tapp("vector",[TA_nexp n2; TA_nexp nw2; TA_ord o2;_]))}]) -> - (match n1.nexp with - | Nconst i1 -> if nexp_eq n1 n2 then new_exp else rewrap (E_cast (t_to_typ t,new_exp)) - | _ -> (match o1.order with - | Odec -> - (*let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in*) - 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) - | Base((_,t),_,_,_,_,_),_ -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the remaining type is %s\n%!" - (t_to_string t) in*) - (match t.t with - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]) -> - (match o1.order with - | Odec -> - let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in - 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) - | _ -> (*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*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (*let _ = Printf.eprintf "Bounds after looking at nmap %s\n" (bounds_to_string bounds) in*) - (match t.t with - (*Old case; should possibly be removed*) - | Tapp("register",[TA_typ {t= Tapp("vector",[ _; TA_nexp r;_;_])}]) - | Tapp("vector", [_;TA_nexp r;_;_]) - | Tabbrev(_, {t=Tapp("vector",[_;TA_nexp r;_;_])}) -> - (*let _ = Printf.eprintf "vector case with %s, bounds are %s\n" - (n_to_string r) (bounds_to_string bounds) in*) - let nexps = expand_nexp r in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l r - | map -> rewrite_nexp_to_exp (Some map) l r) - | Tapp("implicit", [TA_nexp i]) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - 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) -> - (match impl with - | Base((_,t),_,_,_,_,bounds) -> - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match t.t with - | Tapp("atom",[TA_nexp n]) -> - let nexps = expand_nexp n in - (*let _ = Printf.eprintf "Removing sizeof_internal with type %s\n" (t_to_string t) in*) - (match (match_to_program_vars nexps bounds) with - | [] -> 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)) -> - (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" - (t_to_string tu) (t_to_string ti) in*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match (tu.t,ti.t) with - | (Tapp("implicit", [TA_nexp u]),Tapp("implicit",[TA_nexp i])) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - (*add u to program_vars env; for now it will work out properly by accident*) - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - 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"))) + | E_internal_cast (casted_annot,exp) -> + rewrap (E_internal_cast (casted_annot, rewrite exp)) | 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") - -let rewrite_let rewriters map (LB_aux(letbind,(l,annot))) = - let local_map = get_map_tannot annot in - let map = - match map,local_map with - | None,None -> None - | None,Some m -> Some(m, Envmap.empty) - | 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 + | _ -> rewrap exp + +let rewrite_let rewriters (LB_aux(letbind,(l,annot))) = 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_val_implicit ( pat, exp) -> - LB_aux(LB_val_implicit (rewriters.rewrite_pat rewriters map pat, - rewriters.rewrite_exp rewriters map exp),(l,annot)) + | LB_val ( pat, exp) -> + LB_aux(LB_val (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 = - 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))) + (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 _ | DEF_fixity _ -> d | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef) - | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters None letbind) + | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs) + | 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 +380,40 @@ let rewrite_defs_base rewriters (Defs defs) = | [] -> [] | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) in Defs (rewrite defs) - -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 rec introduced_variables (E_aux (exp,(l,annot))) = +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 rewriters_base (Defs defs) + +module Envmap = Finite_map.Fmap_map(String) + +(* 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 @@ -571,13 +421,14 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_as : 'pat * id -> 'pat_aux ; p_typ : Ast.typ * 'pat -> 'pat_aux ; p_id : id -> 'pat_aux + ; p_var : 'pat * kid -> 'pat_aux ; p_app : id * 'pat list -> 'pat_aux ; p_record : 'fpat list * bool -> 'pat_aux ; p_vector : 'pat list -> 'pat_aux - ; p_vector_indexed : (int * 'pat) list -> 'pat_aux ; p_vector_concat : 'pat list -> 'pat_aux ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux + ; p_cons : 'pat * 'pat -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux @@ -588,16 +439,16 @@ let rec fold_pat_aux (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat | P_lit lit -> alg.p_lit lit | P_wild -> alg.p_wild | P_id id -> alg.p_id id - | P_as (p,id) -> alg.p_as (fold_pat alg p,id) + | P_var (p, kid) -> alg.p_var (fold_pat alg p, kid) + | P_as (p,id) -> alg.p_as (fold_pat alg p, id) | P_typ (typ,p) -> alg.p_typ (typ,fold_pat alg p) | P_app (id,ps) -> alg.p_app (id,List.map (fold_pat alg) ps) | P_record (ps,b) -> alg.p_record (List.map (fold_fpat alg) ps, b) | P_vector ps -> alg.p_vector (List.map (fold_pat alg) ps) - | P_vector_indexed ps -> alg.p_vector_indexed (List.map (fun (i,p) -> (i, fold_pat alg p)) ps) | P_vector_concat ps -> alg.p_vector_concat (List.map (fold_pat alg) ps) | P_tup ps -> alg.p_tup (List.map (fold_pat alg) ps) | P_list ps -> alg.p_list (List.map (fold_pat alg) ps) - + | P_cons (ph,pt) -> alg.p_cons (fold_pat alg ph, fold_pat alg pt) and fold_pat (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a pat -> 'pat = function @@ -608,26 +459,27 @@ and fold_fpat_aux (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a fpat_a and fold_fpat (alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg) : 'a fpat -> 'fpat = function | FP_aux (fpat,annot) -> alg.fP_aux (fold_fpat_aux alg fpat,annot) - + (* identity fold from term alg to term alg *) -let id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg = +let id_pat_alg : ('a,'a pat, 'a pat_aux, 'a fpat, 'a fpat_aux) pat_alg = { p_lit = (fun lit -> P_lit lit) ; p_wild = P_wild ; p_as = (fun (pat,id) -> P_as (pat,id)) ; p_typ = (fun (typ,pat) -> P_typ (typ,pat)) ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat,kid)) ; p_app = (fun (id,ps) -> P_app (id,ps)) ; p_record = (fun (ps,b) -> P_record (ps,b)) ; p_vector = (fun ps -> P_vector ps) - ; p_vector_indexed = (fun ps -> P_vector_indexed ps) ; p_vector_concat = (fun ps -> P_vector_concat ps) ; p_tup = (fun ps -> P_tup ps) ; p_list = (fun ps -> P_list ps) + ; p_cons = (fun (ph,pt) -> P_cons (ph,pt)) ; p_aux = (fun (pat,annot) -> P_aux (pat,annot)) ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) ; fP_Fpat = (fun (id,pat) -> FP_Fpat (id,pat)) } - + type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, 'pat,'pat_aux,'fpat,'fpat_aux) exp_alg = @@ -641,8 +493,8 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_tuple : 'exp list -> 'exp_aux ; e_if : 'exp * 'exp * 'exp -> 'exp_aux ; e_for : id * 'exp * 'exp * 'exp * Ast.order * 'exp -> 'exp_aux + ; e_loop : loop * 'exp * 'exp -> 'exp_aux ; e_vector : 'exp list -> 'exp_aux - ; e_vector_indexed : (int * 'exp) list * 'opt_default -> 'exp_aux ; e_vector_access : 'exp * 'exp -> 'exp_aux ; e_vector_subrange : 'exp * 'exp * 'exp -> 'exp_aux ; e_vector_update : 'exp * 'exp * 'exp -> 'exp_aux @@ -656,12 +508,16 @@ 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_constraint : n_constraint -> 'exp_aux ; e_exit : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux ; e_internal_cast : 'a annot * 'exp -> 'exp_aux ; e_internal_exp : 'a annot -> 'exp_aux ; e_internal_exp_user : 'a annot * 'a annot -> 'exp_aux + ; e_comment : string -> 'exp_aux + ; e_comment_struc : 'exp -> 'exp_aux ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux @@ -682,13 +538,13 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; def_val_dec : 'exp -> 'opt_default_aux ; def_val_aux : 'opt_default_aux * 'a annot -> 'opt_default ; pat_exp : 'pat * 'exp -> 'pexp_aux + ; pat_when : 'pat * 'exp * 'exp -> 'pexp_aux ; pat_aux : 'pexp_aux * 'a annot -> 'pexp - ; lB_val_explicit : typschm * 'pat * 'exp -> 'letbind_aux - ; lB_val_implicit : 'pat * 'exp -> 'letbind_aux + ; lB_val : 'pat * 'exp -> 'letbind_aux ; lB_aux : 'letbind_aux * 'a annot -> 'letbind ; pat_alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg } - + let rec fold_exp_aux alg = function | E_block es -> alg.e_block (List.map (fold_exp alg) es) | E_nondet es -> alg.e_nondet (List.map (fold_exp alg) es) @@ -701,9 +557,9 @@ let rec fold_exp_aux alg = function | E_if (e1,e2,e3) -> alg.e_if (fold_exp alg e1, fold_exp alg e2, fold_exp alg e3) | E_for (id,e1,e2,e3,order,e4) -> alg.e_for (id,fold_exp alg e1, fold_exp alg e2, fold_exp alg e3, order, fold_exp alg e4) + | E_loop (loop_type, e1, e2) -> + alg.e_loop (loop_type, fold_exp alg e1, fold_exp alg e2) | E_vector es -> alg.e_vector (List.map (fold_exp alg) es) - | E_vector_indexed (es,opt) -> - alg.e_vector_indexed (List.map (fun (id,e) -> (id,fold_exp alg e)) es, fold_opt_default alg opt) | E_vector_access (e1,e2) -> alg.e_vector_access (fold_exp alg e1, fold_exp alg e2) | E_vector_subrange (e1,e2,e3) -> alg.e_vector_subrange (fold_exp alg e1, fold_exp alg e2, fold_exp alg e3) @@ -720,12 +576,18 @@ 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_constraint nc -> alg.e_constraint nc | 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) | E_internal_cast (annot,e) -> alg.e_internal_cast (annot, fold_exp alg e) | E_internal_exp annot -> alg.e_internal_exp annot + | E_sizeof_internal a -> raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) + "E_sizeof_internal encountered during rewriting") | E_internal_exp_user (annot1,annot2) -> alg.e_internal_exp_user (annot1,annot2) + | E_comment c -> alg.e_comment c + | E_comment_struc e -> alg.e_comment_struc (fold_exp alg e) | E_internal_let (lexp,e1,e2) -> alg.e_internal_let (fold_lexp alg lexp, fold_exp alg e1, fold_exp alg e2) | E_internal_plet (pat,e1,e2) -> @@ -735,6 +597,7 @@ and fold_exp alg (E_aux (exp_aux,annot)) = alg.e_aux (fold_exp_aux alg exp_aux, and fold_lexp_aux alg = function | LEXP_id id -> alg.lEXP_id id | LEXP_memory (id,es) -> alg.lEXP_memory (id, List.map (fold_exp alg) es) + | LEXP_tup les -> alg.lEXP_tup (List.map (fold_lexp alg) les) | LEXP_cast (typ,id) -> alg.lEXP_cast (typ,id) | LEXP_vector (lexp,e) -> alg.lEXP_vector (fold_lexp alg lexp, fold_exp alg e) | LEXP_vector_range (lexp,e1,e2) -> @@ -751,11 +614,12 @@ and fold_opt_default_aux alg = function | Def_val_dec e -> alg.def_val_dec (fold_exp alg e) and fold_opt_default alg (Def_val_aux (opt_default_aux,annot)) = alg.def_val_aux (fold_opt_default_aux alg opt_default_aux, annot) -and fold_pexp_aux alg (Pat_exp (pat,e)) = alg.pat_exp (fold_pat alg.pat_alg pat, fold_exp alg e) +and fold_pexp_aux alg = function + | Pat_exp (pat,e) -> alg.pat_exp (fold_pat alg.pat_alg pat, fold_exp alg e) + | Pat_when (pat,e,e') -> alg.pat_when (fold_pat alg.pat_alg pat, fold_exp alg e, fold_exp alg e') and fold_pexp alg (Pat_aux (pexp_aux,annot)) = alg.pat_aux (fold_pexp_aux alg pexp_aux, annot) and fold_letbind_aux alg = function - | LB_val_explicit (t,pat,e) -> alg.lB_val_explicit (t,fold_pat alg.pat_alg pat, fold_exp alg e) - | LB_val_implicit (pat,e) -> alg.lB_val_implicit (fold_pat alg.pat_alg pat, fold_exp alg e) + | LB_val (pat,e) -> alg.lB_val (fold_pat alg.pat_alg pat, fold_exp alg e) and fold_letbind alg (LB_aux (letbind_aux,annot)) = alg.lB_aux (fold_letbind_aux alg letbind_aux, annot) let id_exp_alg = @@ -769,8 +633,8 @@ let id_exp_alg = ; e_tuple = (fun es -> E_tuple es) ; e_if = (fun (e1,e2,e3) -> E_if (e1,e2,e3)) ; e_for = (fun (id,e1,e2,e3,order,e4) -> E_for (id,e1,e2,e3,order,e4)) + ; e_loop = (fun (lt, e1, e2) -> E_loop (lt, e1, e2)) ; e_vector = (fun es -> E_vector es) - ; e_vector_indexed = (fun (es,opt2) -> E_vector_indexed (es,opt2)) ; e_vector_access = (fun (e1,e2) -> E_vector_access (e1,e2)) ; e_vector_subrange = (fun (e1,e2,e3) -> E_vector_subrange (e1,e2,e3)) ; e_vector_update = (fun (e1,e2,e3) -> E_vector_update (e1,e2,e3)) @@ -784,12 +648,16 @@ 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_constraint = (fun nc -> E_constraint nc) ; e_exit = (fun e1 -> E_exit (e1)) ; e_return = (fun e1 -> E_return e1) ; e_assert = (fun (e1,e2) -> E_assert(e1,e2)) ; e_internal_cast = (fun (a,e1) -> E_internal_cast (a,e1)) ; e_internal_exp = (fun a -> E_internal_exp a) ; e_internal_exp_user = (fun (a1,a2) -> E_internal_exp_user (a1,a2)) + ; e_comment = (fun c -> E_comment c) + ; e_comment_struc = (fun e -> E_comment_struc e) ; e_internal_let = (fun (lexp, e2, e3) -> E_internal_let (lexp,e2,e3)) ; e_internal_plet = (fun (pat, e1, e2) -> E_internal_plet (pat,e1,e2)) ; e_internal_return = (fun e -> E_internal_return e) @@ -810,1348 +678,111 @@ let id_exp_alg = ; def_val_dec = (fun e -> Def_val_dec e) ; def_val_aux = (fun (defval,aux) -> Def_val_aux (defval,aux)) ; pat_exp = (fun (pat,e) -> (Pat_exp (pat,e))) + ; pat_when = (fun (pat,e,e') -> (Pat_when (pat,e,e'))) ; pat_aux = (fun (pexp,a) -> (Pat_aux (pexp,a))) - ; lB_val_explicit = (fun (typ,pat,e) -> LB_val_explicit (typ,pat,e)) - ; lB_val_implicit = (fun (pat,e) -> LB_val_implicit (pat,e)) + ; lB_val = (fun (pat,e) -> LB_val (pat,e)) ; lB_aux = (fun (lb,annot) -> LB_aux (lb,annot)) ; pat_alg = id_pat_alg } - - -let remove_vector_concat_pat pat = - - (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) - let remove_typed_patterns = - fold_pat { id_pat_alg with - p_aux = (function - | (P_typ (_,P_aux (p,_)),annot) - | (p,annot) -> - P_aux (p,annot) - ) - } in - - let pat = remove_typed_patterns pat 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 *) - - (* introduce names for all patterns of form P_vector_concat *) - let name_vector_concat_roots = - { p_lit = (fun lit -> P_lit lit) - ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) - ; 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,((l,_) as annot)) contained_in_p_as -> - match pat with - | 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)) - | _ -> 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_vector_concat_roots pat) false in - - (* 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) - | P_id id -> P_aux (P_id id,a) - | P_as (p,id) -> P_aux (P_as (p,id),a) - | P_wild -> P_aux (P_wild,a) - | _ -> - raise - (Reporting_basic.err_unreachable - l "name_vector_concat_elements: Non-vector in vector-concat pattern") in - P_vector_concat (List.map aux pats) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - 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 - | _ -> [] in - - (* remove names from vectors in vector_concat patterns and collect them as declarations for the - function body or expression *) - let unname_vector_concat_elements = (* : - ('a, - 'a pat * ((tannot exp -> tannot exp) list), - 'a pat_aux * ((tannot exp -> tannot exp) list), - 'a fpat * ((tannot exp -> tannot exp) list), - 'a fpat_aux * ((tannot exp -> tannot exp) list)) - 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 (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 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)), - (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 - (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)]) - (* 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)]) - (* normal vector patterns are fine *) - | _ -> (pos + length, 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 - let pats_tagged = tag_last pats in - let (_,pats',decls') = List.fold_left aux (0,[],[]) 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)) - ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) - ; p_id = (fun id -> (P_id id,[])) - ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in - (P_app (id,ps),List.flatten decls)) - ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in - (P_record (ps,b),List.flatten decls)) - ; p_vector = (fun ps -> let (ps,decls) = List.split ps in - (P_vector ps,List.flatten decls)) - ; p_vector_indexed = (fun ps -> let (is,ps) = List.split ps in - let (ps,decls) = List.split ps in - let ps = List.combine is ps in - (P_vector_indexed ps,List.flatten decls)) - ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in - (P_vector_concat ps,List.flatten decls)) - ; p_tup = (fun ps -> let (ps,decls) = List.split ps in - (P_tup ps,List.flatten decls)) - ; p_list = (fun ps -> let (ps,decls) = List.split ps in - (P_list ps,List.flatten decls)) - ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) - ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) - ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) - } in - - let (pat,decls) = fold_pat unname_vector_concat_elements pat in - - let decls = - let module S = Set.Make(String) in - - let roots_needed = - List.fold_right - (fun (_,(rootid,childid)) roots_needed -> - if S.mem childid roots_needed then - (* let _ = print_endline rootid in *) - S.add rootid roots_needed - else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then - roots_needed - else - S.add rootid roots_needed - ) decls S.empty in - List.filter - (fun (_,(_,childid)) -> - S.mem childid roots_needed || - String.length childid < 3 || - not (String.sub childid 0 2 = String.sub "v__" 0 2)) - decls in - - let (letbinds,decls) = - let (decls,_) = List.split decls in - List.split decls in - - let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in - - - (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, - all P_as and P_id vectors should have their declarations in decls. - Now flatten all vector_concat patterns *) - - let flatten = - let p_vector_concat ps = - let aux p acc = match p with - | (P_aux (P_vector_concat pats,_)) -> pats @ acc - | pat -> pat :: acc in - P_vector_concat (List.fold_right aux ps []) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat flatten pat in - - (* at this point pat should be a flat pattern: no vector_concat patterns - with vector_concats patterns as direct child-nodes anymore *) - - let range a b = - let rec aux a b = if a > b then [] else a :: aux (a+1) b in - if a > b then List.rev (aux b a) else aux a b in - - let remove_vector_concats = - let p_vector_concat ps = - let aux acc (P_aux (p,annot),is_last) = - 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 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 ps_tagged = tag_last ps in - let ps' = List.fold_left aux [] ps_tagged in - let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in - - if last_has_length ps then - P_vector ps' - else - (* If the last vector pattern in the vector_concat pattern has unknown - length we misuse the P_vector_concat constructor's argument to place in - the following way: P_vector_concat [x;y; ... ;z] should be mapped to the - pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) - P_vector_concat ps' in - - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat remove_vector_concats pat in - - (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 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 - 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)) - | 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'), - decls (rewrite_rec body))) - | E_let (LB_aux (LB_val_implicit (pat,v),annot'),body) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - rewrap (E_let (LB_aux (LB_val_implicit (pat,rewrite_rec v),annot'), - decls (rewrite_rec body))) - | exp -> rewrite_base full_exp - -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))) - 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_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_vector_concat_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_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 - 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; - 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_remove_vector_concat_pat} 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 - 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 -> - let vars_t = introduced_variables t in - let vars_e = introduced_variables e in - let new_vars = Envmap.intersect vars_t vars_e in - if Envmap.is_empty new_vars - then (rewrite_base exp)::walker exps - else - let new_nmap = match nmap with - | None -> Some(Nexpmap.empty,new_vars) - | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in - let c' = rewrite_base c in - let t' = rewriters.rewrite_exp rewriters new_nmap t in - let e' = rewriters.rewrite_exp rewriters new_nmap e in - let exps' = walker exps in - fst ((Envmap.fold - (fun (res,effects) i (t,e) -> - let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot bit_t)) in - let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot nat_t)) in - let set_exp = - match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit - | Tapp("range", _) | Tapp("atom", _) -> rangelit - | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) - | Tapp(("reg"|"register"),[TA_typ ({t = 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"})})])}) -> - E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, - (Parse_ast.Generated l,simple_annot bit_t))), - (Parse_ast.Generated l, simple_annot t)) - | _ -> e in - let unioneffs = union_effects effects (get_effsum_exp set_exp) in - ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), - (Parse_ast.Generated l, (tag_annot t Emp_intro))), - 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::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) - | _ -> 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) - | _ -> rewrap lexp) - | _ -> rewrite_base le - - -let rewrite_defs_exp_lift_assign defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_lift_assign_intro; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp_lift_assign_intro; - 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 - | 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 - match exp with - | E_lit (L_aux (((L_num _) as lit),_)) -> - (match (is_within_machine64 t nexps) with - | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp - | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp - | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), - (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) - | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) - | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) - | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) - | E_for (id, e1, e2, e3, o, body) -> - rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) - | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) - | E_vector_subrange (vec,i1,i2) -> - rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) - | E_vector_update (vec,index,new_v) -> - rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) - | E_vector_update_subrange (vec,i1,i2,new_v) -> - rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) - | E_case (exp ,pexps) -> - rewrap (E_case (rewrite_rec exp, - (List.map - (fun (Pat_aux (Pat_exp(p,e),pannot)) -> - Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) - | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) - | E_internal_let (lexp,exp,body) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) - | _ -> rewrite_base full_exp - -let rewrite_defs_separate_numbs defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_separate_ints; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; (*will likely need a new one?*) - rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - 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_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 - 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] -> e (* check with Kathy if that annotation is fine *) - | e :: es -> letbind_wild e (f l es) in - - let e_aux = function - | (E_block es,(l,_)) -> f l es - | (e,annot) -> E_aux (e,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - - rewrite_defs_base - {rewrite_exp = (fun _ _ -> fold_exp alg) - ; 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 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 body = body e in - let annot_pat = (Parse_ast.Generated l,simple_annot unit_t) 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 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 - 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 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) - - -let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = - match l with - | [] -> k [] - | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) - -let rewrite_defs_letbind_effects = - - let rec value ((E_aux (exp_aux,_)) as exp) = - not (effectful exp) && not (updates_vars exp) - and value_optdefault (Def_val_aux (o,_)) = match o with - | Def_val_empty -> true - | Def_val_dec e -> value e - and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = - List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in - - - let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - 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) - - and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = - mapCont n_exp_name exps k - - 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)))) - - 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))) - - and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = - mapCont (n_pexp newreturn) pexps k - - 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)))) - - 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 - match opt_default with - | 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)))) - - 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)))) - | LB_val_implicit (pat,exp1) -> - n_exp exp1 (fun exp1 -> - k (fix_effsum_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 - match lexp_aux with - | 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)))) - | LEXP_cast (typ,id) -> - k (fix_effsum_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))))) - | 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)))))) - | LEXP_field (lexp,id) -> - n_lexp lexp (fun lexp -> - k (fix_effsum_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 exp = - if newreturn then - E_aux (E_internal_return exp,(Parse_ast.Generated l,simple_annot_efr (get_type exp) (get_effsum_exp exp))) - else - exp in - (* n_exp_term forces an expression to be translated into a form - "let .. let .. let .. in EXP" where EXP has no effect and does not update - variables *) - n_exp_pure exp (fun exp -> exp) - - 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 - - match exp_aux with - | E_block es -> failwith "E_block should have been removed till now" - | E_nondet _ -> failwith "E_nondet not supported" - | E_id id -> k exp - | E_lit _ -> k exp - | E_cast (typ,exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_cast (typ,exp')))) - | E_app (id,exps) -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_app (id,exps)))) - | E_app_infix (exp1,id,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_app_infix (exp1,id,exp2))))) - | E_tuple exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_tuple exps))) - | E_if (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - let (E_aux (_,annot2)) = exp2 in - let (E_aux (_,annot3)) = exp3 in - let newreturn = effectful exp2 || effectful exp3 in - let exp2 = n_exp_term newreturn exp2 in - let exp3 = n_exp_term newreturn exp3 in - k (rewrap (E_if (exp1,exp2,exp3)))) - | E_for (id,start,stop,by,dir,body) -> - n_exp_name start (fun start -> - n_exp_name stop (fun stop -> - n_exp_name by (fun by -> - let body = n_exp_term (effectful body) body in - k (rewrap (E_for (id,start,stop,by,dir,body)))))) - | E_vector exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_vector exps))) - | E_vector_indexed (exps,opt_default) -> - let (is,exps) = List.split exps in - n_exp_nameL exps (fun exps -> - n_opt_default opt_default (fun opt_default -> - let exps = List.combine is exps in - k (rewrap (E_vector_indexed (exps,opt_default))))) - | E_vector_access (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_access (exp1,exp2))))) - | E_vector_subrange (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) - | E_vector_update (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_update (exp1,exp2,exp3)))))) - | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - n_exp_name exp4 (fun exp4 -> - k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) - | E_vector_append (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_append (exp1,exp2))))) - | E_list exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_list exps))) - | E_cons (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_cons (exp1,exp2))))) - | E_record fexps -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record fexps))) - | E_record_update (exp1,fexps) -> - n_exp_name exp1 (fun exp1 -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record_update (exp1,fexps))))) - | E_field (exp1,id) -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_field (exp1,id)))) - | E_case (exp1,pexps) -> - let newreturn = - List.fold_left - (fun b (Pat_aux (_,(_,Base (_,_,_,_,effs,_)))) -> b || effectful_effs effs) - false pexps in - n_exp_name exp1 (fun exp1 -> - n_pexpL newreturn pexps (fun pexps -> - k (rewrap (E_case (exp1,pexps))))) - | E_let (lb,body) -> - n_lb lb (fun lb -> - rewrap (E_let (lb,n_exp body k))) - | E_sizeof nexp -> - k (rewrap (E_sizeof nexp)) - | E_sizeof_internal annot -> - k (rewrap (E_sizeof_internal annot)) - | E_assign (lexp,exp1) -> - n_lexp lexp (fun lexp -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_assign (lexp,exp1))))) - | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) - | E_assert (exp1,exp2) -> - n_exp exp1 (fun exp1 -> - n_exp exp2 (fun exp2 -> - k (rewrap (E_assert (exp1,exp2))))) - | E_internal_cast (annot',exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_internal_cast (annot',exp')))) - | E_internal_exp _ -> k exp - | E_internal_exp_user _ -> k exp - | E_internal_let (lexp,exp1,exp2) -> - n_lexp lexp (fun lexp -> - n_exp exp1 (fun exp1 -> - rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) - | E_internal_return exp1 -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_internal_return exp1))) - | E_comment str -> - k (rewrap (E_comment str)) - | E_comment_struc exp' -> - n_exp exp' (fun exp' -> - k (rewrap (E_comment_struc exp'))) - | E_return exp' -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_return exp'))) - | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in - - 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 - 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) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in - 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 - } - -let rewrite_defs_effectful_let_expressions = - - let e_let (lb,body) = - match lb with - | LB_aux (LB_val_explicit (_,pat,exp'),annot') - | LB_aux (LB_val_implicit (pat,exp'),annot') -> - if effectful exp' - then E_internal_plet (pat,exp',body) - else E_let (lb,body) in - - let e_internal_let = fun (lexp,exp1,exp2) -> - if effectful exp1 then - match lexp with - | LEXP_aux (LEXP_id id,annot) - | LEXP_aux (LEXP_cast (_,id),annot) -> - E_internal_plet (P_aux (P_id id,annot),exp1,exp2) - | _ -> failwith "E_internal_plet with unexpected lexp" - else E_internal_let (lexp,exp1,exp2) in - - 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_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, - * internal let-expressions, or internal plet-expressions ended by a term that does not - * access memory or registers and does not update variables *) - -let dedup eq = - List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] - -let eqidtyp (id1,_) (id2,_) = - let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in - let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in - name1 = name2 - -let find_updated_vars exp = - let ( @@ ) (a,b) (a',b') = (a @ a',b @ b') in - let lapp2 (l : (('a list * 'b list) list)) : ('a list * 'b list) = - List.fold_left - (fun ((intros_acc : 'a list),(updates_acc : 'b list)) (intros,updates) -> - (intros_acc @ intros, updates_acc @ updates)) ([],[]) l in - - let (intros,updates) = - fold_exp - { e_aux = (fun (e,_) -> e) - ; e_id = (fun _ -> ([],[])) - ; e_lit = (fun _ -> ([],[])) - ; e_cast = (fun (_,e) -> e) - ; e_block = (fun es -> lapp2 es) - ; e_nondet = (fun es -> lapp2 es) - ; e_app = (fun (_,es) -> lapp2 es) - ; e_app_infix = (fun (e1,_,e2) -> e1 @@ e2) - ; e_tuple = (fun es -> lapp2 es) - ; e_if = (fun (e1,e2,e3) -> e1 @@ e2 @@ e3) - ; e_for = (fun (_,e1,e2,e3,_,e4) -> e1 @@ e2 @@ e3 @@ e4) - ; e_vector = (fun es -> lapp2 es) - ; e_vector_indexed = (fun (es,opt) -> opt @@ lapp2 (List.map snd es)) - ; e_vector_access = (fun (e1,e2) -> e1 @@ e2) - ; e_vector_subrange = (fun (e1,e2,e3) -> e1 @@ e2 @@ e3) - ; e_vector_update = (fun (e1,e2,e3) -> e1 @@ e2 @@ e3) - ; e_vector_update_subrange = (fun (e1,e2,e3,e4) -> e1 @@ e2 @@ e3 @@ e4) - ; e_vector_append = (fun (e1,e2) -> e1 @@ e2) - ; e_list = (fun es -> lapp2 es) - ; e_cons = (fun (e1,e2) -> e1 @@ e2) - ; e_record = (fun fexps -> fexps) - ; e_record_update = (fun (e1,fexp) -> e1 @@ fexp) - ; e_field = (fun (e1,id) -> e1) - ; 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_exit = (fun e1 -> ([],[])) - ; e_return = (fun e1 -> e1) - ; e_assert = (fun (e1,e2) -> ([],[])) - ; e_internal_cast = (fun (_,e1) -> e1) - ; e_internal_exp = (fun _ -> ([],[])) - ; e_internal_exp_user = (fun _ -> ([],[])) - ; e_internal_let = - (fun (([id],acc),e2,e3) -> - let (xs,ys) = ([id],[]) @@ acc @@ e2 @@ e3 in - let ys = List.filter (fun id2 -> not (eqidtyp id id2)) ys in - (xs,ys)) - ; e_internal_plet = (fun (_, e1, e2) -> e1 @@ e2) - ; e_internal_return = (fun e -> e) - ; lEXP_id = (fun id -> (Some id,[],([],[]))) - ; lEXP_memory = (fun (_,es) -> (None,[],lapp2 es)) - ; lEXP_cast = (fun (_,id) -> (Some id,[],([],[]))) - ; lEXP_tup = (fun tups -> failwith "FORCHRISTOPHER:: this needs implementing, not sure what you want to do") - ; lEXP_vector = (fun ((ids,acc),e1) -> (None,ids,acc @@ e1)) - ; lEXP_vector_range = (fun ((ids,acc),e1,e2) -> (None,ids,acc @@ e1 @@ e2)) - ; 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) - | ((_,ids,acc),_) -> (ids,acc) - ) - ; fE_Fexp = (fun (_,e) -> e) - ; fE_aux = (fun (fexp,_) -> fexp) - ; fES_Fexps = (fun (fexps,_) -> lapp2 fexps) - ; fES_aux = (fun (fexp,_) -> fexp) - ; def_val_empty = ([],[]) - ; def_val_dec = (fun e -> e) - ; def_val_aux = (fun (defval,_) -> defval) - ; pat_exp = (fun (_,e) -> e) - ; pat_aux = (fun (pexp,_) -> pexp) - ; lB_val_explicit = (fun (_,_,e) -> e) - ; lB_val_implicit = (fun (_,e) -> e) - ; lB_aux = (fun (lb,_) -> lb) - ; pat_alg = id_pat_alg - } 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 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] -> 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)) - -let mktup_pat l es = - match es with - | [] -> P_aux (P_wild,(Parse_ast.Generated l,simple_annot unit_t)) - | [E_aux (E_id id,_) as exp] -> - P_aux (P_id id,(Parse_ast.Generated l,simple_annot (get_type 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})) - - -type 'a updated_term = - | Added_vars of 'a exp * 'a pat - | Same_vars of 'a exp - -let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = - - let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = - 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_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_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_internal_return exp2 -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_return exp2,swaptyp (get_type 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 - else - E_aux (E_tuple [exp;vars],swaptyp {t = Ttup [get_type exp;get_type vars]} 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 - | _ -> false in - match expaux with - | E_for(id,exp1,exp2,exp3,order,exp4) -> - 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 fname = match effectful exp4,order with - | false, Ord_aux (Ord_inc,_) -> "foreach_inc" - | false, Ord_aux (Ord_dec,_) -> "foreach_dec" - | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" - | 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 - | {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 - | {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) - | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) - | {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 - 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 - 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 - Added_vars (v,pat) - | E_if (c,e1,e2) -> - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in - if vars = [] then - (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) - else - let vartuple = mktup el vars in - 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 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 - Added_vars (v,pat) - | E_case (e1,ps) -> - (* after rewrite_defs_letbind_effects e1 needs no rewriting *) - let vars = - let f acc (Pat_aux (Pat_exp (_,e),_)) = acc @ find_updated_vars e in - List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (List.fold_left f [] ps)) in - if vars = [] then - let ps = List.map (fun (Pat_aux (Pat_exp (p,e),a)) -> Pat_aux (Pat_exp (p,rewrite_var_updates e),a)) ps in - Same_vars (E_aux (E_case (e1,ps),annot)) - else - let vartuple = mktup el vars in - let typ = - let (Pat_aux (Pat_exp (_,first),_)) = List.hd ps in - get_type 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 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 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 - 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 - Added_vars (v,pat) - | E_assign (lexp,vexp) -> - let {effect = Eset effs} = get_effsum_annot annot 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 - 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 - 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 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 - 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 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)) - | _ -> - (* after rewrite_defs_letbind_effects this expression is pure and updates - no variables: check n_exp_term and where it's used. *) - Same_vars (E_aux (expaux,annot)) in - - match expaux with - | E_let (lb,body) -> - let body = rewrite_var_updates body in - let (eff,lb) = match lb with - | LB_aux (LB_val_implicit (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_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)) - | 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 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 - rewrite_var_updates exp - | E_internal_plet (pat,v,body) -> - failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" - (* There are no expressions that have effects or variable updates in - "tail-position": check the definition nexp_term and where it is used. *) - | _ -> exp - -let replace_memwrite_e_assign exp = - let e_aux = fun (expaux,annot) -> - match expaux with - | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) - | _ -> E_aux (expaux,annot) in - fold_exp { id_exp_alg with e_aux = e_aux } exp - - - -let remove_reference_types exp = - - let rec rewrite_t {t = t_aux} = {t = rewrite_t_aux t_aux} - 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) *) - | _ -> 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) - | _ -> 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 - - - -let rewrite_defs_remove_superfluous_letbinds = - - let rec small (E_aux (exp,_)) = match exp with - | E_id _ - | E_lit _ -> true - | E_cast (_,e) -> small e - | E_list es -> List.for_all small es - | E_cons (e1,e2) -> small e1 && small e2 - | E_sizeof _ -> true - | _ -> false in - - let e_aux (exp,annot) = match exp with - | E_let (lb,exp2) -> - begin match lb,exp2 with - (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) - | LB_aux (LB_val_explicit (_,P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_id (Id_aux (id',_)),_) - | LB_aux (LB_val_explicit (_,P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) - | LB_aux (LB_val_implicit (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_id (Id_aux (id',_)),_) - | LB_aux (LB_val_implicit (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at - least when EXP1 is 'small' enough *) - | LB_aux (LB_val_explicit (_,P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - | LB_aux (LB_val_implicit (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' && small exp1 -> - let (E_aux (_,e1annot)) = exp1 in - E_aux (E_internal_return (exp1),e1annot) - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - { rewrite_exp = (fun _ _ -> fold_exp alg) - ; 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_remove_superfluous_returns = - - let has_unittype e = - let {t = t} = get_type e in - t = Tid "unit" in - - let e_aux (exp,annot) = match exp with - | E_internal_plet (pat,exp1,exp2) -> - begin match pat,exp2 with - | P_aux (P_lit (L_aux (lit,_)),_), - E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) - when lit = lit' -> - exp1 - | P_aux (P_wild,pannot), - E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) - when has_unittype exp1 -> - exp1 - | P_aux (P_id (Id_aux (id,_)),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - {rewrite_exp = (fun _ _ -> fold_exp alg) - ; 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_remove_e_assign = - let rewrite_exp _ _ e = - replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in - 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 - } - - -let rewrite_defs_lem = - top_sort_defs >> - rewrite_defs_remove_vector_concat >> - rewrite_defs_exp_lift_assign >> - rewrite_defs_remove_blocks >> - rewrite_defs_letbind_effects >> - rewrite_defs_remove_e_assign >> - rewrite_defs_effectful_let_expressions >> - rewrite_defs_remove_superfluous_letbinds >> - rewrite_defs_remove_superfluous_returns - +(* 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_var = (fun ((v,pat),kid) -> (v, P_var (pat,kid))) + ; 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_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_cons = (fun ((vh,ph),(vt,pt)) -> (join vh vt, P_cons (ph,pt))) + ; 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_loop = (fun (lt, (v1, e1), (v2, e2)) -> + (join_list [v1;v2], E_loop (lt, e1, e2))) + ; e_vector = split_join (fun es -> E_vector es) + ; 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_constraint = (fun nc -> (bot, E_constraint nc)) + ; 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_comment = (fun c -> (bot, E_comment c)) + ; e_comment_struc = (fun (v,e) -> (bot, E_comment_struc e)) (* ignore value by default, since it is comes from a comment *) + ; 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 = (fun ls -> + let (vs,ls) = List.split ls in + (join_list vs, LEXP_tup ls)) + ; 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_when = (fun ((vp,pat),(v,e),(v',e')) -> (join_list [vp;v;v'], Pat_when (pat,e,e'))) + ; pat_aux = (fun ((v,pexp),a) -> (v, Pat_aux (pexp,a))) + ; lB_val = (fun ((vp,pat),(v,e)) -> (join vp v, LB_val (pat,e))) + ; lB_aux = (fun ((vl,lb),annot) -> (vl,LB_aux (lb,annot))) + ; pat_alg = compute_pat_alg bot join + } diff --git a/src/rewriter.mli b/src/rewriter.mli index 615d0fa0..514ed034 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,26 +43,35 @@ 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 - -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; +open Type_check + +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 rewriters_base : tannot rewriters + +(* The identity re-writer *) 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*) + +val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs + +val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp + +val rewrite_pat : tannot rewriters -> tannot pat -> tannot pat + +val rewrite_let : tannot rewriters -> tannot letbind -> tannot letbind + +val rewrite_def : tannot rewriters -> tannot def -> tannot def + +val rewrite_fun : tannot rewriters -> tannot fundef -> tannot fundef (* the type of interpretations of pattern-matching expressions *) type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = @@ -70,21 +80,20 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; p_as : 'pat * id -> 'pat_aux ; p_typ : Ast.typ * 'pat -> 'pat_aux ; p_id : id -> 'pat_aux + ; p_var : 'pat * kid -> 'pat_aux ; p_app : id * 'pat list -> 'pat_aux ; p_record : 'fpat list * bool -> 'pat_aux ; p_vector : 'pat list -> 'pat_aux - ; p_vector_indexed : (int * 'pat) list -> 'pat_aux ; p_vector_concat : 'pat list -> 'pat_aux ; p_tup : 'pat list -> 'pat_aux ; p_list : 'pat list -> 'pat_aux + ; p_cons : 'pat * 'pat -> 'pat_aux ; p_aux : 'pat_aux * 'a annot -> 'pat ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux } - (* fold over pat_aux expressions *) - (* the type of interpretations of expressions *) type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, @@ -99,8 +108,8 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_tuple : 'exp list -> 'exp_aux ; e_if : 'exp * 'exp * 'exp -> 'exp_aux ; e_for : id * 'exp * 'exp * 'exp * Ast.order * 'exp -> 'exp_aux + ; e_loop : loop * 'exp * 'exp -> 'exp_aux ; e_vector : 'exp list -> 'exp_aux - ; e_vector_indexed : (int * 'exp) list * 'opt_default -> 'exp_aux ; e_vector_access : 'exp * 'exp -> 'exp_aux ; e_vector_subrange : 'exp * 'exp * 'exp -> 'exp_aux ; e_vector_update : 'exp * 'exp * 'exp -> 'exp_aux @@ -114,12 +123,16 @@ 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_constraint : n_constraint -> 'exp_aux ; e_exit : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux ; e_internal_cast : 'a annot * 'exp -> 'exp_aux ; e_internal_exp : 'a annot -> 'exp_aux ; e_internal_exp_user : 'a annot * 'a annot -> 'exp_aux + ; e_comment : string -> 'exp_aux + ; e_comment_struc : 'exp -> 'exp_aux ; e_internal_let : 'lexp * 'exp * 'exp -> 'exp_aux ; e_internal_plet : 'pat * 'exp * 'exp -> 'exp_aux ; e_internal_return : 'exp -> 'exp_aux @@ -140,17 +153,56 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; def_val_dec : 'exp -> 'opt_default_aux ; def_val_aux : 'opt_default_aux * 'a annot -> 'opt_default ; pat_exp : 'pat * 'exp -> 'pexp_aux + ; pat_when : 'pat * 'exp * 'exp -> 'pexp_aux ; pat_aux : 'pexp_aux * 'a annot -> 'pexp - ; lB_val_explicit : typschm * 'pat * 'exp -> 'letbind_aux - ; lB_val_implicit : 'pat * 'exp -> 'letbind_aux + ; lB_val : 'pat * 'exp -> 'letbind_aux ; lB_aux : 'letbind_aux * 'a annot -> 'letbind ; pat_alg : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg } +(* fold over patterns *) +val fold_pat : ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg -> 'a pat -> 'pat + (* fold over expressions *) val fold_exp : ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, '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 +val id_exp_alg : + ('a,'a exp,'a exp_aux,'a lexp,'a lexp_aux,'a fexp, + 'a fexp_aux,'a fexps,'a fexps_aux, + 'a opt_default_aux,'a opt_default,'a pexp,'a pexp_aux, + 'a letbind_aux,'a letbind, + 'a pat,'a pat_aux,'a fpat,'a fpat_aux) exp_alg + +val compute_pat_alg : 'b -> ('b -> 'b -> 'b) -> + ('a,('b * 'a pat),('b * 'a pat_aux),('b * 'a fpat),('b * 'a fpat_aux)) pat_alg + +val compute_exp_alg : 'b -> ('b -> 'b -> 'b) -> + ('a,('b * 'a exp),('b * 'a exp_aux),('b * 'a lexp),('b * 'a lexp_aux),('b * 'a fexp), + ('b * 'a fexp_aux),('b * 'a fexps),('b * 'a fexps_aux), + ('b * 'a opt_default_aux),('b * 'a opt_default),('b * 'a pexp),('b * 'a pexp_aux), + ('b * 'a letbind_aux),('b * 'a letbind), + ('b * 'a pat),('b * 'a pat_aux),('b * 'a fpat),('b * 'a fpat_aux)) exp_alg + +val simple_annot : Parse_ast.l -> typ -> Parse_ast.l * tannot + +val union_eff_exps : (tannot exp) list -> effect + +val fix_eff_exp : tannot exp -> tannot exp + +val fix_eff_lexp : tannot lexp -> tannot lexp + +val fix_eff_lb : tannot letbind -> tannot letbind + +val fix_eff_pexp : tannot pexp -> tannot pexp + +val fix_eff_fexp : tannot fexp -> tannot fexp + +val fix_eff_fexps : tannot fexps -> tannot fexps + +val fix_eff_opt_default : tannot opt_default -> tannot opt_default +(* AA: How this is used in rewrite_pat seems suspect to me *) +val vector_string_to_bit_list : Parse_ast.l -> lit_aux -> lit list diff --git a/src/rewrites.ml b/src/rewrites.ml new file mode 100644 index 00000000..80e09e9a --- /dev/null +++ b/src/rewrites.ml @@ -0,0 +1,2789 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* 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 Big_int +open Ast +open Ast_util +open Type_check +open Spec_analysis +open Rewriter + +let (>>) f g = fun x -> g(f(x)) + +let fresh_name_counter = ref 0 + +let fresh_name () = + let current = !fresh_name_counter in + let () = fresh_name_counter := (current + 1) in + current + +let reset_fresh_name_counter () = + fresh_name_counter := 0 + +let fresh_id pre l = + let current = fresh_name () in + Id_aux (Id (pre ^ string_of_int current), gen_loc l) + +let fresh_id_exp pre ((l,annot)) = + let id = fresh_id pre l in + E_aux (E_id id, (gen_loc l, annot)) + +let fresh_id_pat pre ((l,annot)) = + let id = fresh_id pre l in + P_aux (P_id id, (gen_loc l, annot)) + +let get_loc_exp (E_aux (_,(l,_))) = l + +let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Some (env, typ, effect))) +let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect +let annot_pat p_aux l env typ = P_aux (p_aux, (l, Some (env, typ, no_effect))) +let annot_letbind (p_aux, exp) l env typ = + LB_aux (LB_val (annot_pat p_aux l env typ, exp), (l, Some (env, typ, effect_of exp))) + +let simple_num l n = E_aux ( + E_lit (L_aux (L_num n, gen_loc l)), + simple_annot (gen_loc l) + (atom_typ (Nexp_aux (Nexp_constant n, gen_loc l)))) + +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 (propagate_exp_effect eaux)) +let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) + +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 rec small (E_aux (exp,_)) = match exp with + | E_id _ + | E_lit _ -> true + | E_cast (_,e) -> small e + | E_list es -> List.for_all small es + | E_cons (e1,e2) -> small e1 && small e2 + | E_sizeof _ -> true + | _ -> false + +let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with +| Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env) +| Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_exp nexp -> Nexp_aux (Nexp_exp (rewrite_nexp_ids env nexp), l) +| Nexp_neg nexp -> Nexp_aux (Nexp_neg (rewrite_nexp_ids env nexp), l) +| _ -> nexp_aux + +let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = + let rec rewrite_typ env (Typ_aux (typ, l) as typ_aux) = match typ with + | Typ_fn (arg_t, ret_t, eff) -> + Typ_aux (Typ_fn (rewrite_typ env arg_t, rewrite_typ env ret_t, eff), l) + | Typ_tup ts -> + Typ_aux (Typ_tup (List.map (rewrite_typ env) ts), l) + | Typ_exist (kids, c, typ) -> + Typ_aux (Typ_exist (kids, c, rewrite_typ env typ), l) + | Typ_app (id, targs) -> + Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) + | _ -> typ_aux + and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with + | Typ_arg_nexp nexp -> + Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) + | Typ_arg_typ typ -> + Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) + | Typ_arg_order ord -> + Typ_arg_aux (Typ_arg_order ord, l) + in + + let rewrite_annot = function + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_typ env typ, eff)) + | (l, None) -> (l, None) + in + + rewrite_defs_base { + rewriters_base with rewrite_exp = (fun _ -> map_exp_annot rewrite_annot) + }, + rewrite_typ + + +(* Re-write trivial sizeof expressions - trivial meaning that the + value of the sizeof can be directly inferred from the type + variables in scope. *) +let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = + let extract_typ_var l env nexp (id, (_, typ)) = + let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in + match destruct_atom_nexp env typ with + | Some size when prove env (nc_eq size nexp) -> Some var + (* AA: This next case is a bit of a hack... is there a more + general way to deal with trivial nexps that are offset by + constants? This will resolve a 'n - 1 sizeof when 'n is in + scope. *) + | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) -> + let one_exp = infer_exp env (mk_lit_exp (L_num unit_big_int)) in + Some (E_aux (E_app (mk_id "add_range", [var; one_exp]), (gen_loc l, Some (env, atom_typ (nsum size (nint 1)), no_effect)))) + | _ -> + begin + match destruct_vector env typ with + | Some (_, len, _, _) when prove env (nc_eq len nexp) -> + Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) + | _ -> None + end + in + let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = + match nexp_aux with + | Nexp_sum (n1, n2) -> + mk_exp (E_app (mk_id "add_range", [split_nexp n1; split_nexp n2])) + | Nexp_minus (n1, n2) -> + mk_exp (E_app (mk_id "sub_range", [split_nexp n1; split_nexp n2])) + | Nexp_times (n1, n2) -> + mk_exp (E_app (mk_id "mult_range", [split_nexp n1; split_nexp n2])) + | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_range", [split_nexp nexp])) + | _ -> mk_exp (E_sizeof nexp) + in + let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = + let env = env_of orig_exp in + match e_aux with + | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | E_sizeof nexp -> + begin + match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with + | Nexp_aux (Nexp_constant c, _) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | _ -> + let locals = Env.get_locals env in + let exps = Bindings.bindings locals + |> List.map (extract_typ_var l env nexp) + |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) + |> List.concat + in + match exps with + | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) + | [] when split_sizeof -> + fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) + | [] -> orig_exp + end + | _ -> orig_exp + and rewrite_e_sizeof split_sizeof = + { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } + in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true + +(* Rewrite sizeof expressions with type-level variables to + term-level expressions + + For each type-level variable used in a sizeof expressions whose value cannot + be directly extracted from existing parameters of the surrounding function, + a further parameter is added; calls to the function are rewritten + accordingly (possibly causing further rewriting in the calling function) *) +let rewrite_sizeof (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 id_length = Id_aux (Id "length", gen_loc l) in + (try + (match Env.get_val_spec id_length (env_of_annot annot) with + | _ -> + let (_,len,_,_) = vector_typ_args_of typ_aux in + let exp = E_app (id_length, [E_aux (E_id id, annot)]) in + [len, exp]) + with + | _ -> []) + | _ -> []) + | _ -> [] in + (v @ v', P_aux (pat,annot)))} pat) in + + (* Substitute collected values in sizeof expressions *) + let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = + try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) + with + | Not_found -> + let binop nexp1 op nexp2 = E_app_infix ( + E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), + Id_aux (Id op, Parse_ast.Unknown), + E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) + ) in + let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in + (match nexp with + | Nexp_constant i -> E_lit (L_aux (L_num i, l)) + | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 + | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 + | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 + | _ -> E_sizeof nexp_aux) in + + let ex_regex = Str.regexp "'ex[0-9]+" in + + (* Rewrite calls to functions which have had parameters added to pass values + of type-level variables; these are added as sizeof expressions first, and + then further rewritten as above. *) + let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = + let env = env_of_annot annot in + let full_exp = E_aux (exp, annot) in + let orig_exp = E_aux (exp_orig, annot) in + match exp with + | E_app (f, args) -> + if Bindings.mem f param_map then + (* Retrieve instantiation of the type variables of the called function + for the given parameters in the original environment *) + let inst = + try instantiation_of orig_exp with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) in + (* Rewrite the inst using orig_kid so that each type variable has it's + original name rather than a mangled typechecker name *) + let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in + let kid_exp kid = begin + (* We really don't want to see an existential here! *) + assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); + let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in + match uvar with + | Some (U_nexp nexp) -> + let sizeof = E_aux (E_sizeof nexp, (l, Some (env, atom_typ nexp, no_effect))) in + (try rewrite_trivial_sizeof_exp sizeof with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err))) + (* If the type variable is Not_found then it was probably + introduced by a P_var pattern, so it likely exists as + a variable in scope. It can't be an existential because the assert rules that out. *) + | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) + | _ -> + raise (Reporting_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), orig_exp) + else (full_exp, orig_exp) + | _ -> (full_exp, orig_exp) in + + (* Plug this into a folding algorithm that also keeps around a copy of the + original expressions, which we use to infer instantiations of type variables + in the original environments *) + let copy_exp_alg = + { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) + ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) + ; e_id = (fun id -> (E_id id, E_id id)) + ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) + ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) + ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) + ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) + ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) + ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) + ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) + ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) + ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) + ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) + ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) + ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) + ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) + ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) + ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) + ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) + ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) + ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) + ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) + ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) + ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) + ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) + ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) + ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) + ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) + ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) + ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) + ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) + ; e_internal_exp = (fun a -> (E_internal_exp a, E_internal_exp a)) + ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) + ; e_comment = (fun c -> (E_comment c, E_comment c)) + ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) + ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) + ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) + ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) + ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) + ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) + ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) + ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) + ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) + ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) + ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) + ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) + ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) + ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) + ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) + ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) + ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) + ; def_val_empty = (Def_val_empty, Def_val_empty) + ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) + ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) + ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) + ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) + ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) + ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) + ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) + ; pat_alg = id_pat_alg + } in + + let rewrite_sizeof_fun params_map + (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = + let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,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' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + (* ... then rewrite sizeof expressions in current function body *) + let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in + (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_id (id_of_kid kid) ^ "__tv"), l)), + kid_annot kid)), kid_annot kid) in + let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in + let kid_typs = List.map kid_typ (KidSet.elements nvars) in + let kid_pats = List.map kid_pat (KidSet.elements nvars) in + let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in + let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pat, exp), annot) as funcl) = + let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = + let penv = env_of_annot pannot in + let peff = effect_of_annot (snd pannot) in + if KidSet.is_empty nvars then paux else + match pat_typ_of paux with + | Typ_aux (Typ_tup typs, _) -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in + (match pat with + | P_tup pats -> + P_aux (P_tup (kid_pats @ pats), (l, Some (penv, ptyp', peff))) + | P_wild -> P_aux (pat, (l, Some (penv, ptyp', peff))) + | P_typ (Typ_aux (Typ_tup typs, l), pat) -> + P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), + rewrite_pat pat), (l, Some (penv, ptyp', peff))) + | P_as (_, id) | P_id id -> + (* adding parameters here would change the type of id; + we should remove the P_as/P_id here and add a let-binding to the body *) + raise (Reporting_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")) + | ptyp -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in + P_aux (P_tup (kid_pats @ [paux]), (l, Some (penv, ptyp', peff))) 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_def (params_map, defs) = function + | DEF_fundef fd as def -> + let (nvars, fd') = rewrite_sizeof_fun params_map fd in + let id = id_of_fundef fd in + let params_map' = + if KidSet.is_empty nvars then params_map + else Bindings.add id nvars params_map in + (params_map', defs @ [DEF_fundef fd']) + | DEF_val (LB_aux (lb, annot)) -> + begin + let lb' = match lb with + | LB_val (pat, exp) -> + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + LB_val (pat, exp') in + (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) + end + | def -> + (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, ext, is_cast), a)) -> + DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) + | def -> def + in + + let (params_map, defs) = List.fold_left rewrite_sizeof_def + (Bindings.empty, []) defs in + let defs = List.map (rewrite_sizeof_valspec params_map) defs in + Defs defs + (* FIXME: Won't re-check due to flow typing and E_constraint re-write before E_sizeof re-write. + Requires the typechecker to be more smart about different representations for valid flow typing constraints. + fst (check initial_env (Defs defs)) + *) + +let remove_vector_concat_pat pat = + + (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) + let remove_typed_patterns = + fold_pat { id_pat_alg with + p_aux = (function + | (P_typ (_,P_aux (p,_)),annot) + | (p,annot) -> + P_aux (p,annot) + ) + } in + + (* let pat = remove_typed_patterns pat in *) + + let fresh_id_v = fresh_id "v__" 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 *) + + (* introduce names for all patterns of form P_vector_concat *) + let name_vector_concat_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; 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_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_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_aux = + (fun (pat,((l,_) as annot)) contained_in_p_as -> + match pat with + | P_vector_concat pats -> + (if contained_in_p_as + then P_aux (pat,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)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + + let pat = (fold_pat name_vector_concat_roots pat) false in + + (* introduce names for all unnamed child nodes of P_vector_concat *) + let name_vector_concat_elements = + let p_vector_concat pats = + 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 + (Reporting_basic.err_unreachable + l "name_vector_concat_elements: Non-vector in vector-concat pattern") in + P_vector_concat (List.map aux pats) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + 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 + | _ -> [] in + + (* remove names from vectors in vector_concat patterns and collect them as declarations for the + function body or expression *) + let unname_vector_concat_elements = (* : + ('a, + 'a pat * ((tannot exp -> tannot exp) list), + 'a pat_aux * ((tannot exp -> tannot exp) list), + 'a fpat * ((tannot exp -> tannot exp) list), + 'a fpat_aux * ((tannot exp -> tannot exp) list)) + pat_alg = *) + + (* build a let-expression of the form "let child = root[i..j] in body" *) + let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = + let (l,_) = cannot in + let env = env_of_annot rannot in + let rootname = string_of_id rootid in + let childname = string_of_id child 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 + + (* FIXME *) + let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in + (* let (_, _, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of root) (typ_of root)) in + let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + let subv = fix_eff_exp (E_aux (E_app (mk_id subrange_id, [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 (id_pat,subv),cannot)) in + (letbind, + (fun body -> fix_eff_exp (annot_exp (E_let (letbind,body)) l env (typ_of body))), + (rootname,childname)) in + + let p_aux = function + | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> + 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 sub_big_int (add_big_int start length) unit_big_int + else add_big_int (sub_big_int start length) unit_big_int) + | _ -> + 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 + let (pos',index_j) = match length with + | Nexp_aux (Nexp_constant i,_) -> + if is_order_inc ord + then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) + else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) + | 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 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 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', pat_acc @ [P_aux (p,cannot)],decl_acc)) in + let pats_tagged = tag_last pats 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)) + ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) + ; p_id = (fun id -> (P_id id,[])) + ; p_var = (fun ((pat,decls),kid) -> (P_var (pat,kid),decls)) + ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in + (P_app (id,ps),List.flatten decls)) + ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in + (P_record (ps,b),List.flatten decls)) + ; p_vector = (fun ps -> let (ps,decls) = List.split ps in + (P_vector ps,List.flatten decls)) + ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in + (P_vector_concat ps,List.flatten decls)) + ; p_tup = (fun ps -> let (ps,decls) = List.split ps in + (P_tup ps,List.flatten decls)) + ; p_list = (fun ps -> let (ps,decls) = List.split ps in + (P_list ps,List.flatten decls)) + ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) + ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) + ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) + ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) + } in + + let (pat,decls) = fold_pat unname_vector_concat_elements pat in + + let decls = + let module S = Set.Make(String) in + + let roots_needed = + List.fold_right + (fun (_,(rootid,childid)) roots_needed -> + if S.mem childid roots_needed then + (* let _ = print_endline rootid in *) + S.add rootid roots_needed + else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then + roots_needed + else + S.add rootid roots_needed + ) decls S.empty in + List.filter + (fun (_,(_,childid)) -> + S.mem childid roots_needed || + String.length childid < 3 || + not (String.sub childid 0 2 = String.sub "v__" 0 2)) + decls in + + let (letbinds,decls) = + let (decls,_) = List.split decls in + List.split decls in + + let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in + + + (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, + all P_as and P_id vectors should have their declarations in decls. + Now flatten all vector_concat patterns *) + + let flatten = + let p_vector_concat ps = + let aux p acc = match p with + | (P_aux (P_vector_concat pats,_)) -> pats @ acc + | pat -> pat :: acc in + P_vector_concat (List.fold_right aux ps []) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat flatten pat in + + (* at this point pat should be a flat pattern: no vector_concat patterns + with vector_concats patterns as direct child-nodes anymore *) + + let range a b = + let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in + if gt_big_int a b then List.rev (aux b a) else aux a b in + + 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 + let wild _ = P_aux (P_wild,(gen_loc 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 zero_big_int (sub_big_int length unit_big_int))) + | _, _ -> + (*if is_last then*) acc @ [wild zero_big_int] + 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)) = + 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 + let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in + + if last_has_length ps then + P_vector ps' + else + (* If the last vector pattern in the vector_concat pattern has unknown + length we misuse the P_vector_concat constructor's argument to place in + the following way: P_vector_concat [x;y; ... ;z] should be mapped to the + pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) + P_vector_concat ps' in + + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat remove_vector_concats pat in + + (pat,letbinds,decls) + +(* assumes there are no more E_internal expressions *) +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 in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) -> + let aux = function + | (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') + | (Pat_aux (Pat_when (pat,guard,body),annot')) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + Pat_aux (Pat_when (pat, decls (rewrite_rec guard), decls (rewrite_rec body)),annot') in + rewrap (E_case (rewrite_rec e, List.map aux ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | exp -> rewrite_base full_exp + +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 + 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 (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 + | DEF_val (LB_aux (LB_val (pat,exp),a)) -> + 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 (pat,exp),a))] @ defvals + | d -> [d] in + Defs (List.flatten (List.map rewrite_def defs)) + +(* A few helper functions for rewriting guarded pattern clauses. + Used both by the rewriting of P_when and separately by the rewriting of + bitvectors in parameter patterns of function clauses *) + +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_list (pat1 :: pats1), P_cons _ -> + subsumes_pat (rewrap (P_cons (pat1, rewrap (P_list pats1)))) pat2 + | P_cons _, P_list (pat2 :: pats2)-> + subsumes_pat pat1 (rewrap (P_cons (pat2, rewrap (P_list pats2)))) + | P_cons (pat1, pats1), P_cons (pat2, pats2) -> + (match subsumes_pat pat1 pat2, subsumes_pat pats1 pats2 with + | Some substs1, Some substs2 -> Some (substs1 @ substs2) + | _ -> 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_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) +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 l = get_loc_exp e in + let env = env_of e in + let annot = (get_loc_exp e, Some (env_of e, t, no_effect)) in + match cs with + | [(P_aux (P_id id, pannot) as pat, body, _)] -> + fix_eff_exp (annot_exp (E_let (LB_aux (LB_val (pat, e), pannot), body)) l env t) + | _ -> + 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 (annot_exp (E_case (e,ps)) l env t) + +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 (_,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 (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (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 bitwise_and_exp exp1 exp2 = + let (E_aux (_,(l,_))) = exp1 in + let andid = Id_aux (Id "and_bool", gen_loc l) in + annot_exp (E_app(andid,[exp1;exp2])) l (env_of exp1) bool_typ + +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 _ -> + 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_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps +| P_record (fpats,_) -> + List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats + +let contains_bitvector_pexp = function +| Pat_aux (Pat_exp (pat,_),_) | Pat_aux (Pat_when (pat,_,_),_) -> + contains_bitvector_pat pat + +(* Rewrite bitvector patterns to guarded patterns *) + +let remove_bitvector_pat pat = + + let env = try pat_env_of pat with _ -> Env.empty in + + (* 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_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; 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_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_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; 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_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 l typ idx = + let root = annot_exp (E_id rootid) l env typ in + (* FIXME *) + annot_exp (E_vector_access (root, simple_num l idx)) l env bit_typ in + (*let env = env_of_annot rannot in + let t = Env.base_typ_of env (typ_of_annot rannot) in + let (_, _, ord, _) = vector_typ_args_of t in + let access_id = if is_order_inc ord then "bitvector_access_inc" else "bitvector_access_dec" in + E_aux (E_app (mk_id access_id, [root; simple_num l idx]), simple_annot l bit_typ) in*) + + let test_bit_exp rootid l typ idx exp = + let rannot = (l, Some (env_of exp, typ, no_effect)) in + let elem = access_bit_exp rootid l typ idx in + Some (annot_exp (E_app (mk_id "eq", [elem; exp])) l env bool_typ) in + + let test_subvec_exp rootid l typ i j lits = + let (start, length, ord, _) = vector_typ_args_of typ in + let length' = nint (List.length lits) in + let start' = + if is_order_inc ord then nint 0 + else nminus length' (nint 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 eq_big_int s i && eq_big_int l (big_int_of_int (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 ( + annot_exp (E_id rootid) l env typ, + simple_num l i, + simple_num l j) in + (* let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + E_app (mk_id subrange_id, [E_aux (E_id rootid, simple_annot l typ); simple_num l i; simple_num l j]) in *) + annot_exp (E_app( + Id_aux (Id "eq_vec", gen_loc l), + [annot_exp subvec_exp l env typ'; + annot_exp (E_vector lits) l env typ'])) l env 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 l typ idx in + let e = annot_pat (P_id id) l env bit_typ in + let letbind = LB_aux (LB_val (e,elem), (l, Some (env, bit_typ, no_effect))) in + let letexp = (fun body -> + let (E_aux (_,(_,bannot))) = body in + annot_exp (E_let (letbind,body)) l env (typ_of body)) in + (letexp, letbind) in + + let compose_guards guards = + let conj g1 g2 = match g1, g2 with + | Some g1, Some g2 -> Some (bitwise_and_exp g1 g2) + | Some g1, None -> Some g1 + | None, Some g2 -> Some g2 + | None, None -> None in + List.fold_right conj 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 add_big_int idx unit_big_int else sub_big_int idx unit_big_int in + (match ps with + | pat :: ps' -> + (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let e = E_aux (E_lit lit, (gen_loc 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_var = (fun ((pat,gdls),kid) -> (P_var (pat,kid), gdls)) + ; 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_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_cons = (fun ((p,gdls),(p',gdls')) -> + (P_cons (p,p'), flatten_guards_decls [gdls;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_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 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 contains_bitvector_pexp ps -> + let rewrite_pexp = function + | Pat_aux (Pat_exp (pat,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', guard', body'), annot') + | None -> Pat_aux (Pat_exp (pat', body'), annot')) + | Pat_aux (Pat_when (pat,guard,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', bitwise_and_exp guard guard', body'), annot') + | None -> Pat_aux (Pat_when (pat', guard, body'), annot')) in + rewrap (E_case (e, List.map rewrite_pexp ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,(_,decls,_)) = remove_bitvector_pat pat in + rewrap (E_let (LB_aux (LB_val (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_bitvector_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 + | DEF_val (LB_aux (LB_val (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 (pat',exp),a))] @ defvals + | d -> [d] in + (* FIXME See above in rewrite_sizeof *) + (* fst (check initial_env ( *) + Defs (List.flatten (List.map rewrite_def defs)) + (* )) *) + + +(* Remove pattern guards by rewriting them to if-expressions within the + pattern expression. Shares code with the rewriting of bitvector patterns. *) +let rewrite_exp_guarded_pats 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 + let is_guarded_pexp = function + | Pat_aux (Pat_when (_,_,_),_) -> true + | _ -> false in + match exp with + | E_case (e,ps) + when List.exists is_guarded_pexp ps -> + let clause = function + | Pat_aux (Pat_exp (pat, body), annot) -> + (pat, None, rewrite_rec body, annot) + | Pat_aux (Pat_when (pat, guard, body), annot) -> + (pat, Some guard, rewrite_rec 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, Some (env_of e, typ_of e, no_effect)) in + let exp_e' = pat_to_exp pat_e' in + let letbind_e = LB_aux (LB_val (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 + | _ -> rewrite_base full_exp + +let rewrite_defs_guarded_pats = + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats } + + +let id_is_local_var id env = match Env.lookup_id id env with + | Local _ -> 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 id_is_unbound id env = match Env.lookup_id id env with + | Unbound -> true + | _ -> false + +let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_unbound id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local_intro lexp env + +let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with + | Some (_, _, eff) -> effectful_effs eff + | _ -> false + +let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = + match lexp with + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) + | LEXP_vector (lexp, e) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) + | LEXP_vector_range (lexp, e1, e2) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) + | LEXP_field (lexp, id) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + let (LEXP_aux (_, recannot)) = lexp in + let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) + | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) + +(*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 ((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, Some (env,typ,eff)) as annot)) as exp)::exps + when lexp_is_local_intro le env && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (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))] + (*| ((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 + if Envmap.is_empty new_vars + then (rewrite_base exp)::walker exps + else + let new_nmap = match nmap with + | None -> Some(Nexpmap.empty,new_vars) + | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in + let c' = rewrite_base c in + let t' = rewriters.rewrite_exp rewriters new_nmap t in + let e' = rewriters.rewrite_exp rewriters new_nmap e in + let exps' = walker exps in + fst ((Envmap.fold + (fun (res,effects) i (t,e) -> + let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot bit_t)) in + let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot nat_t)) in + let set_exp = + match t.t with + | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit + | Tapp("range", _) | Tapp("atom", _) -> rangelit + | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) + | Tapp(("reg"|"register"),[TA_typ ({t = 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"})})])}) -> + E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, + (Parse_ast.Generated l,simple_annot bit_t))), + (Parse_ast.Generated l, simple_annot t)) + | _ -> e in + let unioneffs = union_effects effects (get_effsum_exp set_exp) in + ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), + (Parse_ast.Generated l, (tag_annot t Emp_intro))), + 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::exps -> (rewrite_rec e)::(walker exps) + in + rewrap (E_block (walker exps)) + | E_assign(le,e) + when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (rewrite_base e) in + let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in + fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) + | _ -> rewrite_base full_exp + +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 + + +let rewrite_defs_exp_lift_assign defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_lift_assign_intro; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp_lift_assign_intro; + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs + +(*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,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 + | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp + | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp + | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), + (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) + | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) + | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) + | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) + | E_for (id, e1, e2, e3, o, body) -> + rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) + | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) + | E_vector_subrange (vec,i1,i2) -> + rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) + | E_vector_update (vec,index,new_v) -> + rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) + | E_vector_update_subrange (vec,i1,i2,new_v) -> + rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) + | E_case (exp ,pexps) -> + rewrap (E_case (rewrite_rec exp, + (List.map + (fun (Pat_aux (Pat_exp(p,e),pannot)) -> + Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) + | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) + | E_internal_let (lexp,exp,body) -> + rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) + | _ -> rewrite_base full_exp + +let rewrite_defs_separate_numbs defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_separate_ints; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; (*will likely need a new one?*) + rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs*) + +let rewrite_defs_early_return = + let is_return (E_aux (exp, _)) = match exp with + | E_return _ -> true + | _ -> false in + + let get_return (E_aux (e, (l, _)) as exp) = match e with + | E_return e -> e + | _ -> exp in + + let e_block es = + match es with + | [E_aux (e, _)] -> e + | _ :: _ when is_return (Util.last es) -> + let (E_aux (_, annot) as e) = get_return (Util.last es) in + E_return (E_aux (E_block (Util.butlast es @ [get_return e]), annot)) + | _ -> E_block es in + + let e_if (e1, e2, e3) = + if is_return e2 && is_return e3 then + let (E_aux (_, annot)) = get_return e2 in + E_return (E_aux (E_if (e1, get_return e2, get_return e3), annot)) + else E_if (e1, e2, e3) in + + let e_case (e, pes) = + let is_return_pexp (Pat_aux (pexp, _)) = match pexp with + | Pat_exp (_, e) | Pat_when (_, _, e) -> is_return e in + let get_return_pexp (Pat_aux (pexp, a)) = match pexp with + | Pat_exp (p, e) -> Pat_aux (Pat_exp (p, get_return e), a) + | Pat_when (p, g, e) -> Pat_aux (Pat_when (p, g, get_return e), a) in + let annot = match List.map get_return_pexp pes with + | Pat_aux (Pat_exp (_, E_aux (_, annot)), _) :: _ -> annot + | Pat_aux (Pat_when (_, _, E_aux (_, annot)), _) :: _ -> annot + | [] -> (Parse_ast.Unknown, None) in + if List.for_all is_return_pexp pes + then E_return (E_aux (E_case (e, List.map get_return_pexp pes), annot)) + else E_case (e, pes) in + + let e_aux (exp, (l, annot)) = + let full_exp = fix_eff_exp (E_aux (exp, (l, annot))) in + match annot with + | Some (env, typ, eff) when is_return full_exp -> + (* Add escape effect annotation, since we use the exception mechanism + of the state monad to implement early return in the Lem backend *) + let annot' = Some (env, typ, union_effects eff (mk_effect [BE_escape])) in + E_aux (exp, (l, annot')) + | _ -> full_exp in + + let rewrite_funcl_early_return _ (FCL_aux (FCL_Funcl (id, pat, exp), a)) = + let exp = + exp + (* Pull early returns out as far as possible *) + |> fold_exp { id_exp_alg with e_block = e_block; e_if = e_if; e_case = e_case } + (* Remove singleton E_return *) + |> get_return + (* Fix effect annotations *) + |> fold_exp { id_exp_alg with e_aux = e_aux } in + let a = match a with + | (l, Some (env, typ, eff)) -> + (l, Some (env, typ, union_effects eff (effect_of exp))) + | _ -> a in + FCL_aux (FCL_Funcl (id, pat, exp), a) in + + let rewrite_fun_early_return rewriters + (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), a)) = + FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, + List.map (rewrite_funcl_early_return rewriters) funcls), a) in + + rewrite_defs_base { rewriters_base with rewrite_fun = rewrite_fun_early_return } + +(* Propagate effects of functions, if effect checking and propagation + have not been performed already by the type checker. *) +let rewrite_fix_val_specs (Defs defs) = + let find_vs env val_specs id = + try Bindings.find id val_specs with + | Not_found -> + begin + try Env.get_val_spec id env with + | _ -> + raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) + ("No val spec found for " ^ string_of_id id)) + end + in + + let add_eff_to_vs eff = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff'), a)) -> + (tq, Typ_aux (Typ_fn (args_t, ret_t, union_effects eff eff'), a)) + | vs -> vs + in + + let eff_of_vs = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> eff + | _ -> no_effect + in + + let e_aux val_specs (exp, (l, annot)) = + match fix_eff_exp (E_aux (exp, (l, annot))) with + | E_aux (E_app_infix (_, f, _) as exp, (l, Some (env, typ, eff))) + | E_aux (E_app (f, _) as exp, (l, Some (env, typ, eff))) -> + let vs = find_vs env val_specs f in + let env = Env.update_val_spec f vs env in + E_aux (exp, (l, Some (env, typ, union_effects eff (eff_of_vs vs)))) + | e_aux -> e_aux + in + + let rewrite_exp val_specs = fold_exp { id_exp_alg with e_aux = e_aux val_specs } in + + let rewrite_funcl (val_specs, funcls) (FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))) = + let exp = propagate_exp_effect (rewrite_exp val_specs exp) in + let vs, eff = match find_vs (env_of_annot (l, annot)) val_specs id with + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> + let eff' = union_effects eff (effect_of exp) in + let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in + let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in + (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' + in + let annot = add_effect_annot annot eff in + (Bindings.add id vs val_specs, + funcls @ [FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))]) + in + + let rewrite_fundef (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) = + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + (* Repeat once to cross-propagate effects between clauses *) + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + let is_funcl_rec (FCL_aux (FCL_Funcl (id, _, exp), _)) = + fst (fold_exp + { (compute_exp_alg false (||) ) with + e_app = (fun (f, es) -> + let (rs, es) = List.split es in + (List.fold_left (||) (string_of_id f = string_of_id id) rs, + E_app (f, es))); + e_app_infix = (fun ((r1,e1), f, (r2,e2)) -> + (r1 || r2 || (string_of_id f = string_of_id id), + E_app_infix (e1, f, e2))) } + exp) + in + let recopt = + if List.exists is_funcl_rec funcls then + Rec_aux (Rec_rec, Parse_ast.Unknown) + else recopt + in + (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) in + + let rec rewrite_fundefs (val_specs, fundefs) = + match fundefs with + | fundef :: fundefs -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, fundef :: fundefs) + | [] -> (val_specs, []) in + + let rewrite_def (val_specs, defs) = function + | DEF_fundef fundef -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + (val_specs, defs @ [DEF_fundef fundef]) + | DEF_internal_mutrec fundefs -> + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, defs @ [DEF_internal_mutrec fundefs]) + | DEF_val (LB_aux (LB_val (pat, exp), a)) -> + (val_specs, defs @ [DEF_val (LB_aux (LB_val (pat, rewrite_exp val_specs exp), a))]) + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) -> + let typschm, val_specs = + if Bindings.mem id val_specs then begin + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), Parse_ast.Unknown), val_specs + end else begin + let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in + typschm, Bindings.add id (tq, typ) val_specs + end + in + (val_specs, defs @ [DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a))]) + | def -> (val_specs, defs @ [def]) + in + + let rewrite_val_specs val_specs = function + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + when Bindings.mem id val_specs -> + let typschm = match typschm with + | TypSchm_aux (TypSchm_ts (tq, typ), l) -> + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), l) + in + DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + | def -> def + in + + let (val_specs, defs) = List.fold_left rewrite_def (Bindings.empty, []) defs in + let defs = List.map (rewrite_val_specs val_specs) defs in + + (* if !Type_check.opt_no_effects + then *) + Defs defs + (* else Defs defs *) + +(* Turn constraints into numeric expressions with sizeof *) +let rewrite_constraint = + let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) + and rewrite_nc_aux = function + | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) + | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) + | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) + | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) + | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) + | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) + | NC_false -> E_lit (mk_lit L_false) + | NC_true -> E_lit (mk_lit L_true) + | NC_set (kid, ints) -> + unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (nc_eq (nvar kid) (nconstant int))) nc_true ints)) + in + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_constraint nc -> + check_exp (env_of exp) (rewrite_nc nc) bool_typ + | _ -> exp + in + + let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } + +let rewrite_type_union_typs rw_typ (Tu_aux (tu, annot)) = + match tu with + | Tu_id id -> Tu_aux (Tu_id id, annot) + | Tu_ty_id (typ, id) -> Tu_aux (Tu_ty_id (rw_typ typ, id), annot) + +let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = + match td with + | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) + | TD_record (id, nso, typq, typ_ids, flag) -> + TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) + | TD_variant (id, nso, typq, tus, flag) -> + TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) + | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) + | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) + +(* FIXME: other reg_dec types *) +let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = + match ds with + | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) + | _ -> assert false + +(* Remove overload definitions and cast val specs from the + specification because the interpreter doesn't know about them.*) +let rewrite_overload_cast (Defs defs) = + let remove_cast_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot) + in + let simple_def = function + | DEF_spec vs -> DEF_spec (remove_cast_vs vs) + | def -> def + in + let is_overload = function + | DEF_overload _ -> true + | _ -> false + in + let defs = List.map simple_def defs in + Defs (List.filter (fun def -> not (is_overload def)) defs) + + +let rewrite_undefined mwords = + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_lit (L_aux (L_undef, l)) -> + check_exp (env_of exp) (undefined_of_typ mwords l (fun _ -> ()) (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) + | _ -> exp + in + let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) } + +let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) +and simple_typ_aux = function + | Typ_id id -> Typ_id id + | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> + Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) + | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) + | Typ_fn (typ1, typ2, effs) -> Typ_fn (simple_typ typ1, simple_typ typ2, effs) + | Typ_tup typs -> Typ_tup (List.map simple_typ typs) + | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ + | typ_aux -> typ_aux +and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = + match typ_arg_aux with + | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] + | _ -> [] + +(* This pass aims to remove all the Num quantifiers from the specification. *) +let rewrite_simple_types (Defs defs) = + let is_simple = function + | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true + | _ -> false + in + let simple_typquant (TypQ_aux (tq_aux, annot)) = + match tq_aux with + | TypQ_no_forall -> TypQ_aux (TypQ_no_forall, annot) + | TypQ_tq quants -> TypQ_aux (TypQ_tq (List.filter (fun q -> is_simple q) quants), annot) + in + let simple_typschm (TypSchm_aux (TypSchm_ts (typq, typ), annot)) = + TypSchm_aux (TypSchm_ts (simple_typquant typq, simple_typ typ), annot) + in + let simple_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, is_cast) -> VS_aux (VS_val_spec (simple_typschm typschm, id, ext, is_cast), annot) + in + let rec simple_lit (L_aux (lit_aux, l) as lit) = + match lit_aux with + | L_bin _ | L_hex _ -> + E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) + | _ -> E_lit lit + in + let simple_def = function + | DEF_spec vs -> DEF_spec (simple_vs vs) + | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) + | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) + | def -> def + in + let simple_pat = { + id_pat_alg with + p_typ = (fun (typ, pat) -> P_typ (simple_typ typ, pat)); + p_var = (fun (pat, kid) -> unaux_pat pat); + p_vector = (fun pats -> P_list pats) + } in + let simple_exp = { + id_exp_alg with + e_lit = simple_lit; + e_vector = (fun exps -> E_list exps); + e_cast = (fun (typ, exp) -> E_cast (simple_typ typ, exp)); + (* e_assert = (fun (E_aux (_, annot), str) -> E_assert (E_aux (E_lit (mk_lit L_true), annot), str)); *) + lEXP_cast = (fun (typ, lexp) -> LEXP_cast (simple_typ typ, lexp)); + pat_alg = simple_pat + } in + let simple_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp simple_exp); + rewrite_pat = (fun _ -> fold_pat simple_pat) } + in + let defs = Defs (List.map simple_def defs) in + rewrite_defs_base simple_defs defs + +let rewrite_tuple_vector_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, lannot), exp) -> + let typ = Env.base_typ_of env (typ_of exp) in + if is_vector_typ typ then + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (start, _, ord, etyp) = vector_typ_args_of typ in + let len (LEXP_aux (le, lannot)) = + let ltyp = Env.base_typ_of env (typ_of_annot lannot) in + if is_vector_typ ltyp then + let (_, len, _, _) = vector_typ_args_of ltyp in + match nexp_simp len with + | Nexp_aux (Nexp_constant len, _) -> len + | _ -> unit_big_int + else unit_big_int in + let next i step = + if is_order_inc ord + then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) + else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in + let i = match nexp_simp start with + | (Nexp_aux (Nexp_constant i, _)) -> i + | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in + let l = gen_loc (fst annot) in + let exp' = + if small exp then strip_exp exp + else mk_exp (E_id (mk_id "split_vec")) in + let lexp_to_exp (i, exps) lexp = + let (j, i') = next i (len lexp) in + let i_exp = mk_exp (E_lit (mk_lit (L_num i))) in + let j_exp = mk_exp (E_lit (mk_lit (L_num j))) in + let sub = mk_exp (E_vector_subrange (exp', i_exp, j_exp)) in + (i', exps @ [sub]) in + let (_, exps) = List.fold_left lexp_to_exp (i, []) lexps in + let tup = mk_exp (E_tuple exps) in + let lexp = LEXP_aux (LEXP_tup (List.map strip_lexp lexps), (l, ())) in + let e_aux = + if small exp then mk_exp (E_assign (lexp, tup)) + else mk_exp ( + E_let ( + mk_letbind (mk_pat (P_id (mk_id "split_vec"))) (strip_exp exp), + mk_exp (E_assign (lexp, tup)))) in + begin + try check_exp env e_aux unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + else E_aux (e_aux, annot) + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_tuple_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, _), exp) -> + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in + let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in + let block = mk_exp (E_block (List.mapi block_assign lexps)) in + let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in + let let_exp = mk_exp (E_let (letbind, block)) in + begin + try check_exp env let_exp unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_simple_assignments defs = + let assign_e_aux e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (lexp, exp) -> + let (lexp, rhs) = rewrite_local_lexp lexp in + let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in + check_exp env assign unit_typ + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_e_aux e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_defs_remove_blocks = + let letbind_wild v body = + let l = get_loc_exp v in + let env = env_of v in + let typ = typ_of v in + annot_exp (E_let (annot_letbind (P_wild, v) l env typ, body)) l env (typ_of body) in + (* let pat = annot_pat P_wild l env typ in + let (E_aux (_,(l,tannot))) = v in + let annot_pat = (simple_annot l (typ_of v)) in + let annot_lb = (gen_loc l, tannot) in + let annot_let = (gen_loc l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in + E_aux (E_let (LB_aux (LB_val (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,gen_loc 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 + + let e_aux = function + | (E_block es,(l,_)) -> f l es + | (e,annot) -> E_aux (e,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + + rewrite_defs_base + {rewrite_exp = (fun _ -> fold_exp alg) + ; 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 letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = + (* body is a function : E_id variable -> actual body *) + 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 body = body (annot_exp (E_lit (mk_lit L_unit)) l env unit_typ) in + let body_typ = try typ_of body with _ -> unit_typ in + let lb = annot_letbind (P_wild, v) l env unit_typ in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env body_typ) + | Some (env, typ, eff) -> + let id = fresh_id "w__" l in + let lb = annot_letbind (P_id id, v) l env typ in + let body = body (annot_exp (E_id id) l env typ) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | 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 = + match l with + | [] -> k [] + | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) + +let rewrite_defs_letbind_effects = + + let rec value ((E_aux (exp_aux,_)) as 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 + and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = + List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in + + + let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + 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 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 + + 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_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 = + match pexp with + | Pat_aux (Pat_exp (pat,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) + | Pat_aux (Pat_when (pat,guard,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_when (pat,n_exp_term newreturn guard,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 + + 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_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 + match opt_default with + | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) + | Def_val_dec exp -> + n_exp_name exp (fun exp -> + 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 (pat,exp1) -> + n_exp exp1 (fun exp1 -> + k (fix_eff_lb (LB_aux (LB_val (pat,exp1),annot)))) + + and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = + let (LEXP_aux (lexp_aux,annot)) = lexp in + match lexp_aux with + | LEXP_id _ -> k lexp + | LEXP_memory (id,es) -> + n_exp_nameL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) + | LEXP_tup es -> + n_lexpL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_tup es,annot)))) + | LEXP_cast (typ,id) -> + 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_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_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) + | LEXP_field (lexp,id) -> + n_lexp lexp (fun lexp -> + k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) + + and n_lexpL (lexps : 'a lexp list) (k : 'a lexp list -> 'a exp) : 'a exp = + mapCont n_lexp lexps k + + and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = + let (E_aux (_,(l,tannot))) = exp in + let exp = + if newreturn then + (* let typ = try typ_of exp with _ -> unit_typ in *) + annot_exp (E_internal_return exp) l (env_of exp) (typ_of exp) + else + exp in + (* n_exp_term forces an expression to be translated into a form + "let .. let .. let .. in EXP" where EXP has no effect and does not update + variables *) + n_exp_pure exp (fun exp -> exp) + + and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + + 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" + | E_nondet _ -> failwith "E_nondet not supported" + | E_id id -> k exp + | E_lit _ -> k exp + | E_cast (typ,exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_cast (typ,exp')))) + | E_app (id,exps) -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_app (id,exps)))) + | E_app_infix (exp1,id,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_app_infix (exp1,id,exp2))))) + | E_tuple exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_tuple exps))) + | E_if (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + let (E_aux (_,annot2)) = exp2 in + let (E_aux (_,annot3)) = exp3 in + let newreturn = effectful exp2 || effectful exp3 in + let exp2 = n_exp_term newreturn exp2 in + let exp3 = n_exp_term newreturn exp3 in + k (rewrap (E_if (exp1,exp2,exp3)))) + | E_for (id,start,stop,by,dir,body) -> + n_exp_name start (fun start -> + n_exp_name stop (fun stop -> + n_exp_name by (fun by -> + let body = n_exp_term (effectful body) body in + k (rewrap (E_for (id,start,stop,by,dir,body)))))) + | E_loop (loop, cond, body) -> + let cond = n_exp_term (effectful cond) cond in + let body = n_exp_term (effectful body) body in + k (rewrap (E_loop (loop,cond,body))) + | E_vector exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_vector exps))) + | E_vector_access (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_access (exp1,exp2))))) + | E_vector_subrange (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) + | E_vector_update (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_update (exp1,exp2,exp3)))))) + | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + n_exp_name exp4 (fun exp4 -> + k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) + | E_vector_append (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_append (exp1,exp2))))) + | E_list exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_list exps))) + | E_cons (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_cons (exp1,exp2))))) + | E_record fexps -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record fexps))) + | E_record_update (exp1,fexps) -> + n_exp_name exp1 (fun exp1 -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record_update (exp1,fexps))))) + | E_field (exp1,id) -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_field (exp1,id)))) + | E_case (exp1,pexps) -> + let newreturn = List.exists effectful_pexp pexps in + n_exp_name exp1 (fun exp1 -> + n_pexpL newreturn pexps (fun pexps -> + k (rewrap (E_case (exp1,pexps))))) + | E_let (lb,body) -> + n_lb lb (fun lb -> + rewrap (E_let (lb,n_exp body k))) + | E_sizeof nexp -> + k (rewrap (E_sizeof nexp)) + | E_constraint nc -> + k (rewrap (E_constraint nc)) + | E_sizeof_internal annot -> + k (rewrap (E_sizeof_internal annot)) + | E_assign (lexp,exp1) -> + n_lexp lexp (fun lexp -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_assign (lexp,exp1))))) + | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) + | E_assert (exp1,exp2) -> + n_exp exp1 (fun exp1 -> + n_exp exp2 (fun exp2 -> + k (rewrap (E_assert (exp1,exp2))))) + | E_internal_cast (annot',exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_internal_cast (annot',exp')))) + | E_internal_exp _ -> k exp + | E_internal_exp_user _ -> k exp + | E_internal_let (lexp,exp1,exp2) -> + n_lexp lexp (fun lexp -> + n_exp exp1 (fun exp1 -> + rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) + | E_internal_return exp1 -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_internal_return exp1))) + | E_comment str -> + k (rewrap (E_comment str)) + | E_comment_struc exp' -> + n_exp exp' (fun exp' -> + k (rewrap (E_comment_struc exp'))) + | E_return exp' -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_return exp'))) + | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in + + let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = + let effectful_funcl (FCL_aux (FCL_Funcl(_, _, exp), _)) = effectful exp in + let newreturn = List.exists effectful_funcl 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) + in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in + let rewrite_def rewriters def = + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) + match def with + | DEF_val (LB_aux (lb, annot)) -> + let rewrap lb = DEF_val (LB_aux (lb, annot)) in + begin + match lb with + | LB_val (pat, exp) -> + rewrap (LB_val (pat, n_exp_term (effectful exp) exp)) + end + | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) + | DEF_internal_mutrec fdefs -> + DEF_internal_mutrec (List.map (rewrite_fun rewriters) fdefs) + | d -> d in + 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 + } + +let rewrite_defs_effectful_let_expressions = + + let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with + | LEXP_id id -> P_aux (P_id id, annot) + | LEXP_cast (typ, id) -> P_aux (P_typ (typ, P_aux (P_id id, annot)), annot) + | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) + | _ -> raise (Reporting_basic.err_unreachable l "unexpected local lexp") in + + let e_let (lb,body) = + match lb with + | LB_aux (LB_val (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) + when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> + (* Rewrite assignments to local variables into let bindings *) + let (lhs, rhs) = rewrite_local_lexp le in + E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs exp), annot), body) + | LB_aux (LB_val (pat,exp'),annot') -> + if effectful exp' + then E_internal_plet (pat,exp',body) + else E_let (lb,body) in + + let e_internal_let = fun (lexp,exp1,exp2) -> + match lexp with + | LEXP_aux (LEXP_id id,annot) + | LEXP_aux (LEXP_cast (_,id),annot) -> + if effectful exp1 then + E_internal_plet (P_aux (P_id id,annot),exp1,exp2) + else + let lb = LB_aux (LB_val (P_aux (P_id id,annot), exp1), annot) in + E_let (lb, exp2) + | _ -> failwith "E_internal_let with unexpected lexp" in + + 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_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, + * internal let-expressions, or internal plet-expressions ended by a term that does not + * access memory or registers and does not update variables *) + +let dedup eq = + List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] + +let eqidtyp (id1,_) (id2,_) = + let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in + let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in + name1 = name2 + +let find_introduced_vars exp = + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) + | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) + when id_is_unbound id env -> IdSet.add id ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + fst (fold_exp + { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) + +let find_updated_vars exp = + let intros = find_introduced_vars exp in + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) + when id_is_local_var id env && not (IdSet.mem id intros) -> + (id, annot) :: ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + dedup eqidtyp (fst (fold_exp + { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) + +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 + | [] -> annot_exp (E_lit (mk_lit L_unit)) (gen_loc l) Env.empty unit_typ + | [e] -> e + | e :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + propagate_exp_effect (annot_exp (E_tuple es) (gen_loc l) (env_of e) typ) + +let mktup_pat l es = + match es with + | [] -> annot_pat P_wild (gen_loc l) Env.empty unit_typ + | [E_aux (E_id id,_) as exp] -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + let pats = List.map (function + | (E_aux (E_id id,_) as exp) -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp -> + annot_pat P_wild (gen_loc l) (env_of exp) (typ_of exp)) es in + annot_pat (P_tup pats) (gen_loc l) (env_of exp) typ + + +type 'a updated_term = + | Added_vars of 'a exp * 'a pat + | Same_vars of 'a exp + +let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = + + let env = env_of exp in + + let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = + match expaux with + | E_let (lb,exp) -> + let exp = add_vars overwrite exp vars in + 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 (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 (typ_of exp2) annot) + | E_internal_return exp2 -> + let exp2 = add_vars overwrite exp2 vars in + 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 + 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 + let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], gen_loc 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 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" + | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" + | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" + | _ -> raise (Reporting_basic.err_unreachable el + "Could not determine foreach combinator") in + let funcl = Id_aux (Id fname,gen_loc el) in + let loopvar = + (* 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 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) + | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) + | {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 *) + annot_exp (E_id id) l env int_typ in + let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), + (gen_loc el, annot4)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_loop(loop,cond,body) -> + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars body) in + let vartuple = mktup el vars in + (* let cond = rewrite_var_updates (add_vars false cond vartuple) in *) + let body = rewrite_var_updates (add_vars overwrite body vartuple) in + let (E_aux (_,(_,bannot))) = body in + let fname = match loop, effectful cond, effectful body with + | While, false, false -> "while_PP" + | While, false, true -> "while_PM" + | While, true, false -> "while_MP" + | While, true, true -> "while_MM" + | Until, false, false -> "until_PP" + | Until, false, true -> "until_PM" + | Until, true, false -> "until_MP" + | Until, true, true -> "until_MM" in + let funcl = Id_aux (Id fname,gen_loc el) in + let v = E_aux (E_app (funcl,[cond;body;vartuple]), (gen_loc el, bannot)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (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))) + (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in + if vars = [] then + (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) + else + let vartuple = mktup el vars in + 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 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), (gen_loc el, Some (env, typ, eff))) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_case (e1,ps) -> + (* after rewrite_defs_letbind_effects e1 needs no rewriting *) + let vars = + let f acc (Pat_aux ((Pat_exp (_,e)|Pat_when (_,_,e)),_)) = + acc @ find_updated_vars e in + List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) + (dedup eqidtyp (List.fold_left f [] ps)) in + if vars = [] then + let ps = List.map (function + | Pat_aux (Pat_exp (p,e),a) -> + Pat_aux (Pat_exp (p,rewrite_var_updates e),a) + | Pat_aux (Pat_when (p,g,e),a) -> + Pat_aux (Pat_when (p,g,rewrite_var_updates e),a)) ps in + Same_vars (E_aux (E_case (e1,ps),annot)) + else + let vartuple = mktup el vars in + let rewrite_pexp (Pat_aux (pexp, (l, _))) = match pexp with + | Pat_exp (pat, exp) -> + let exp = rewrite_var_updates (add_vars overwrite exp vartuple) in + let pannot = (l, Some (env_of exp, typ_of exp, effect_of exp)) in + Pat_aux (Pat_exp (pat, exp), pannot) + | Pat_when _ -> + raise (Reporting_basic.err_unreachable l + "Guarded patterns should have been rewritten already") in + let typ = match ps with + | Pat_aux ((Pat_exp (_,first)|Pat_when (_,_,first)),_) :: _ -> typ_of first + | _ -> unit_typ in + let v = propagate_exp_effect (annot_exp (E_case (e1, List.map rewrite_pexp ps)) pl env typ) in + (* let (ps,typ,effs) = + let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = + 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 = 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,no_effect) ps in + let v = E_aux (E_case (e1,ps), (gen_loc pl, Some (env_of_annot annot, typ, effs))) in *) + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_assign (lexp,vexp) -> + 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 effectful exp then + Same_vars (E_aux (E_assign (lexp,vexp),annot)) + else + (match lexp with + | LEXP_aux (LEXP_id id,annot) -> + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_cast (_,id),annot) -> + let pat = annot_pat (P_id id) pl env (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 = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update (eid,i,vexp)) l1 env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (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 = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update_subrange (eid,i,j,vexp)) l env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (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. *) + Same_vars (E_aux (expaux,annot)) in + + match expaux with + | E_let (lb,body) -> + let body = rewrite_var_updates body in + let (LB_aux (LB_val (pat, v), lbannot)) = lb in + let lb = match rewrite v pat with + | Added_vars (v, P_aux (pat, _)) -> + annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) + | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | 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 + | _ -> + raise (Reporting_basic.err_unreachable l + "E_internal_let with a lexp that is not a variable") in + let pat = annot_pat (P_id id) l env (typ_of v) in + let lb = annot_letbind (P_id id, v) l env (typ_of v) in + let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in + rewrite_var_updates exp + (* 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 = (gen_loc l, Some (env, vtyp, veff)) in + let lb = LB_aux (LB_val (pat,v),lbannot) in + let exp = E_aux (E_let (lb,body),(gen_loc 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" + (* There are no expressions that have effects or variable updates in + "tail-position": check the definition nexp_term and where it is used. *) + | _ -> exp + +let replace_memwrite_e_assign exp = + let e_aux = fun (expaux,annot) -> + match expaux with + | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) + | _ -> E_aux (expaux,annot) in + fold_exp { id_exp_alg with e_aux = e_aux } exp + + + +let remove_reference_types exp = + + 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 + | 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_arg t_arg = match t_arg with + | 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 + | (l, None) -> (l, None) + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in + + map_exp_annot rewrite_annot exp + + + +let rewrite_defs_remove_superfluous_letbinds = + + let e_aux (exp,annot) = match exp with + | E_let (lb,exp2) -> + begin match lb,exp2 with + (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_id (Id_aux (id',_)),_) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at + least when EXP1 is 'small' enough *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' && small exp1 -> + let (E_aux (_,e1annot)) = exp1 in + E_aux (E_internal_return (exp1),e1annot) + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; 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_remove_superfluous_returns = + + 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) when effectful exp1 -> + begin match pat,exp2 with + | P_aux (P_lit (L_aux (lit,_)),_), + E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) + when lit = lit' -> + exp1 + | P_aux (P_wild,pannot), + E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) + when has_unittype exp1 -> + exp1 + | P_aux (P_id (Id_aux (id,_)),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; 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_remove_e_assign = + let rewrite_exp _ e = + replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in + 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 + } + +let recheck_defs defs = fst (check initial_env defs) + +let rewrite_defs_lem = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + (* ("simple_assignments", rewrite_simple_assignments); *) + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ("guarded_pats", rewrite_defs_guarded_pats); + (* ("recheck_defs", recheck_defs); *) + ("early_return", rewrite_defs_early_return); + ("nexp_ids", rewrite_defs_nexp_ids); + ("fix_val_specs", rewrite_fix_val_specs); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + ("remove_blocks", rewrite_defs_remove_blocks); + ("letbind_effects", rewrite_defs_letbind_effects); + ("remove_e_assign", rewrite_defs_remove_e_assign); + ("effectful_let_expressions", rewrite_defs_effectful_let_expressions); + ("remove_superfluous_letbinds", rewrite_defs_remove_superfluous_letbinds); + ("remove_superfluous_returns", rewrite_defs_remove_superfluous_returns) + ] + +let rewrite_defs_ocaml = [ + (* ("top_sort_defs", top_sort_defs); *) + (* ("undefined", rewrite_undefined); *) + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("simple_types", rewrite_simple_types); + ("overload_cast", rewrite_overload_cast); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + (* ("separate_numbs", rewrite_defs_separate_numbs) *) + ] + +let rewrite_defs_sil = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ] + +let rewrite_check_annot = + let check_annot exp = + try + prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); + let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in + (if not (alpha_equivalent (env_of exp) (typ_of exp) (Env.expand_synonyms (env_of exp) (typ_of exp))) + then raise (Reporting_basic.err_typ Parse_ast.Unknown "Found synonym in annotation") + else ()); + exp + with + Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) + in + let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> check_annot (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } + +let rewrite_defs_check = [ + ("check_annotations", rewrite_check_annot); + ] diff --git a/src/initial_check_full_ast.mli b/src/rewrites.mli index be612532..432a2bd8 100644 --- a/src/initial_check_full_ast.mli +++ b/src/rewrites.mli @@ -9,6 +9,7 @@ (* Robert Norton-Wright *) (* Christopher Pulte *) (* Peter Sewell *) +(* Thomas Bauereiss *) (* *) (* All rights reserved. *) (* *) @@ -41,11 +42,22 @@ (**************************************************************************) open Ast -open Type_internal +open Type_check -(*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 +(* Re-write undefined to functions created by -undefined_gen flag *) +val rewrite_undefined : bool -> tannot defs -> tannot defs -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 +(* Perform rewrites to exclude AST nodes not supported for ocaml out*) +val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list + +(* Perform rewrites to exclude AST nodes not supported for lem out*) +val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list + +(* Perform rewrites to sail intermediate language *) +val rewrite_defs_sil : (string * (tannot defs -> tannot defs)) list + +(* This is a special rewriter pass that checks AST invariants without + actually doing any re-writing *) +val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list + +val simple_typ : typ -> typ diff --git a/src/sail.ml b/src/sail.ml index 4e76551f..dbd95f1d 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -49,43 +49,102 @@ let opt_print_initial_env = ref false let opt_print_verbose = ref false let opt_print_lem_ast = ref false let opt_print_lem = ref false +let opt_print_sil = ref false let opt_print_ocaml = ref false +let opt_convert = ref false +let opt_memo_z3 = ref false +let opt_sanity = 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), "<prefix> select output filename prefix"); + ( "-ocaml", + Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen], + " output an OCaml translated version of the input"); + ( "-ocaml_trace", + Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen; Arg.Set Ocaml_backend.opt_trace_ocaml], + " output an OCaml translated version of the input with tracing instrumentation, implies -ocaml"); + ( "-ocaml_lib", + Arg.String (fun l -> opt_libs_ocaml := l::!opt_libs_ocaml), + "<filename> provide additional library to open in OCaml output"); ( "-lem_ast", Arg.Set opt_print_lem_ast, " output a Lem AST representation of the input"); + ( "-sil", + Arg.Tuple [Arg.Set opt_print_sil; Arg.Set Initial_check.opt_undefined_gen], + " output a SIL translated version of the input"); ( "-lem", Arg.Set opt_print_lem, " output a Lem translated version of the input"); - ( "-ocaml", - Arg.Set opt_print_ocaml, - " output an OCaml translated version of the input"); ( "-lem_lib", Arg.String (fun l -> opt_libs_lem := l::!opt_libs_lem), "<filename> provide additional library to open in Lem output"); - ( "-ocaml_lib", - Arg.String (fun l -> opt_libs_ocaml := l::!opt_libs_ocaml), - "<filename> provide additional library to open in OCaml output"); -(* - ( "-i", - 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"); + ( "-lem_sequential", + Arg.Set Process_file.opt_lem_sequential, + " use sequential state monad for Lem output"); + ( "-lem_mwords", + Arg.Set Process_file.opt_lem_mwords, + " use native machine word library for Lem output"); + ( "-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"); + ( "-memo_z3", + Arg.Set opt_memo_z3, + " memoize calls to z3, improving performance when typechecking repeatedly"); + ( "-undefined_gen", + Arg.Set Initial_check.opt_undefined_gen, + " generate undefined_type functions for types in the specification"); + ( "-no_effects", + Arg.Set Type_check.opt_no_effects, + " (experimental) turn off effect checking"); + ( "-new_parser", + Arg.Set Process_file.opt_new_parser, + " (experimental) use new parser"); + ( "-convert", + Arg.Set opt_convert, + " (experimental) convert sail to new syntax for use with -new_parser"); + ( "-just_check", + Arg.Set opt_just_check, + " (experimental) terminate immediately after typechecking"); + ( "-ddump_raw_mono_ast", + Arg.Set opt_ddump_raw_mono_ast, + " (debug) dump the monomorphised ast before type-checking"); + ( "-dmono_analysis", + Arg.Set_int opt_dmono_analysis, + " (debug) dump information about monomorphisation analysis: 0 silent, 3 max"); + ( "-auto_mono", + Arg.Set opt_auto_mono, + " automatically infer how to monomorphise code"); ( "-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"); + ( "-ddump_tc_ast", + Arg.Set opt_ddump_tc_ast, + " (debug) dump the typechecked ast to stdout"); + ( "-ddump_rewrite_ast", + Arg.String (fun l -> opt_ddump_rewrite_ast := Some (l, 0)), + "<prefix> (debug) dump the ast after each rewriting step to <prefix>_<i>.lem"); + ( "-dtc_verbose", + Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity), + "<verbosity> (debug) verbose typechecker output: 0 is silent"); + ( "-dno_cast", + Arg.Set opt_dno_cast, + " (debug) typecheck without any implicit casting"); + ( "-dsanity", + Arg.Set opt_sanity, + " (debug) sanity check the AST (slow)"); + ( "-dmagic_hash", + Arg.Set Initial_check.opt_magic_hash, + " (debug) allow special character # in identifiers"); ( "-v", Arg.Set opt_print_version, " print version"); @@ -104,48 +163,64 @@ let _ = let main() = - if !(opt_print_version) + 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 + if !opt_memo_z3 then Constraint.load_digests () 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 = rewrite_ast ast in + let ast = convert_ast Ast_util.inc_ord ast in + + if !opt_convert + then (Pretty_print_sail2.pp_defs stdout ast; exit 0) + else (); + + let (ast, type_envs) = check_ast ast in + + let (ast, type_envs) = + match !opt_mono_split, !opt_auto_mono with + | [], false -> ast, type_envs + | locs, _ -> monomorphise_ast locs type_envs ast + in + + let ast = + if !Initial_check.opt_undefined_gen then + rewrite_undefined (rewrite_ast ast) + else rewrite_ast ast in + let out_name = match !opt_file_out with + | None when parsed = [] -> "out.sail" | None -> fst (List.hd parsed) | Some f -> f ^ ".sail" in + + if !opt_memo_z3 then Constraint.save_digests () else (); + (*let _ = Printf.eprintf "Type checked, next to pretty print" in*) - begin + begin + (if !(opt_sanity) + then + let _ = rewrite_ast_check ast in + () + else ()); (if !(opt_print_verbose) then ((Pretty_print.pp_defs stdout) ast) else ()); (if !(opt_print_lem_ast) then output "" Lem_ast_out [out_name,ast] else ()); + (if !(opt_print_sil) + then + let ast = rewrite_ast_sil ast in + Pretty_print_sail2.pp_defs stdout ast + else ()); (if !(opt_print_ocaml) - then let ast_ocaml = rewrite_ast_ocaml ast in - if !(opt_libs_ocaml) = [] - then output "" (Ocaml_out None) [out_name,ast_ocaml] - else output "" (Ocaml_out (Some (List.hd !opt_libs_ocaml))) [out_name,ast_ocaml] + then + let ast_ocaml = rewrite_ast_ocaml ast in + let out = match !opt_file_out with None -> "out" | Some s -> s in + Ocaml_backend.ocaml_compile out ast_ocaml else ()); (if !(opt_print_lem) then let ast_lem = rewrite_ast_lem ast in 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..bdbc031a 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"] + then ["bit";"vector";"unit";"string";"int";"bool"] 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,39 +203,32 @@ 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_exist (kids,_,t') -> List.fold_left (fun s kid -> Nameset.remove (string_of_kid kid) s) (free_type_names_t consider_var t') kids 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 = match t with - | Typ_wild -> used | Typ_var (Kid_aux (Var v,l)) -> if consider_var then conditional_add_typ bound used (Ast.Id_aux (Ast.Id v,l)) @@ -248,7 +237,8 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,_)) : Nameset.t = | Typ_fn(arg,ret,_) -> fv_of_typ consider_var bound (fv_of_typ consider_var bound used arg) ret | Typ_tup ts -> List.fold_right (fun t n -> fv_of_typ consider_var bound n t) ts used | Typ_app(id,targs) -> - List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) + List.fold_right (fun ta n -> fv_of_targ consider_var bound n ta) targs (conditional_add_typ bound used id) + | Typ_exist (kids,_,t') -> fv_of_typ consider_var (List.fold_left (fun b (Kid_aux (Var v,_)) -> Nameset.add v b) bound kids) used t' and fv_of_targ consider_var bound used (Ast.Typ_arg_aux(targ,_)) : Nameset.t = match targ with | Typ_arg_typ t -> fv_of_typ consider_var bound used t @@ -285,22 +275,20 @@ 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) | P_vector pats | Ast.P_vector_concat pats | Ast.P_tup pats | Ast.P_list pats -> list_fv bound used pats - | P_vector_indexed ipats -> - List.fold_right (fun (_,p) (b,n) -> pat_bindings consider_var b n p) ipats (bound,used) | _ -> bound,used let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset.t * Nameset.t * Nameset.t) = @@ -324,14 +312,8 @@ 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 - | E_vector_indexed (es_i,(Ast.Def_val_aux(default,_))) -> - let bound,used,set = - List.fold_right - (fun (_,e) (b,u,s) -> fv_of_exp consider_var b u s e) es_i (bound,used,set) in - (match default with - | Def_val_empty -> bound,used,set - | Def_val_dec e -> fv_of_exp consider_var bound used set e) + fv_of_exp consider_var (Nameset.add (string_of_id id) bound) used set body + | E_loop(_, cond, body) -> list_fv bound used set [cond; body] | E_vector_access(v,i) -> list_fv bound used set [v;i] | E_vector_subrange(v,i1,i2) -> list_fv bound used set [v;i1;i2] | E_vector_update(v,i,e) -> list_fv bound used set [v;i;e] @@ -358,6 +340,7 @@ let rec fv_of_exp consider_var bound used set (E_aux (e,(_,tannot))) : (Nameset. b,used,set | E_exit e -> fv_of_exp consider_var bound used set e | E_assert(c,m) -> list_fv bound used set [c;m] + | E_return e -> fv_of_exp consider_var bound used set e | _ -> bound,used,set and fv_of_pes consider_var bound used set pes = @@ -367,14 +350,14 @@ and fv_of_pes consider_var bound used set pes = let bound_p,us_p = pat_bindings consider_var bound used p in let bound_e,us_e,set_e = fv_of_exp consider_var bound_p us_p set e in fv_of_pes consider_var bound us_e set_e pes + | Pat_aux(Pat_when (p,g,e),_)::pes -> + let bound_p,us_p = pat_bindings consider_var bound used p in + let bound_g,us_g,set_g = fv_of_exp consider_var bound_p us_p set g in + let bound_e,us_e,set_e = fv_of_exp consider_var bound_g us_g set_g e in + fv_of_pes consider_var bound us_e set_e pes and fv_of_let consider_var bound used set (LB_aux(lebind,_)) = match lebind with - | LB_val_explicit(typsch,pat,exp) -> - let bound_t,us_t = fv_of_typschm consider_var bound used typsch in - let bound_p, us_p = pat_bindings consider_var (Nameset.union bound bound_t) used pat in - let _,us_e,set_e = fv_of_exp consider_var (Nameset.union bound bound_t) used set exp in - (Nameset.union bound_t bound_p),Nameset.union us_t (Nameset.union us_p us_e),set_e - | LB_val_implicit(pat,exp) -> + | LB_val(pat,exp) -> let bound_p, us_p = pat_bindings consider_var bound used pat in let _,us_e,set_e = fv_of_exp consider_var bound used set exp in bound_p,Nameset.union us_p us_e,set_e @@ -383,13 +366,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 +384,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 +401,36 @@ 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_abbrev(_,id,_,typschm) -> - init_env (id_to_string 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 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 - typ_variants consider_var bindings tunions - | KD_enum(_,id,_,ids,_) -> - Nameset.of_list (List.map id_to_string (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 + | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp 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)) = @@ -466,10 +438,10 @@ let fv_of_funcl consider_var base_bounds (FCL_aux(FCL_Funcl(id,pat,exp),l)) = let _, exp_ns, exp_sets = fv_of_exp consider_var pat_bs pat_ns mt exp in (pat_bs,exp_ns,exp_sets) -let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_)) = +let fv_of_fun consider_var (FD_aux (FD_function(rec_opt,tannot_opt,_,funcls),_) as fd) = 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,16 +449,20 @@ 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 exp_ns) funcls mt in - init_env fun_name,Nameset.union ns ns_r + let ns_vs = init_env ("val:" ^ (string_of_id (id_of_fundef fd))) in + (* let _ = Printf.eprintf "Function %s uses %s\n" fun_name (set_to_string (Nameset.union ns ns_r)) in *) + init_env fun_name, Nameset.union ns_vs (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,_,_) -> + 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 +471,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 +482,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 +506,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 +523,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 +535,8 @@ 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_fixity _ -> mt,mt + | 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 @@ -596,6 +576,20 @@ let rec print_dependencies orig_queue work_queue names = print_dependencies orig_queue orig_queue uses)); print_dependencies orig_queue wq names +let merge_mutrecs defs = + let merge_aux ((binds', uses'), def) ((binds, uses), fundefs) = + let fundefs = match def with + | DEF_fundef fundef -> fundef :: fundefs + | DEF_internal_mutrec fundefs' -> fundefs' @ fundefs + | _ -> + (* let _ = Pretty_print_sail2.pp_defs stderr (Defs [def]) in *) + raise (Reporting_basic.err_unreachable (def_loc def) + "Trying to merge non-function definition with mutually recursive functions") in + (* let _ = Printf.eprintf " - Merging %s (using %s)\n" (set_to_string binds') (set_to_string uses') in *) + ((Nameset.union binds' binds, Nameset.union uses' uses), fundefs) in + let ((binds, uses), fundefs) = List.fold_right merge_aux defs ((mt, mt), []) in + ((binds, uses), DEF_internal_mutrec fundefs) + let rec topological_sort work_queue defs = match work_queue with | [] -> List.rev defs @@ -609,11 +603,15 @@ let rec topological_sort work_queue defs = else match List.stable_sort compare_dbts work_queue with (*We wait to sort until there are no 0 dependency nodes on top*) | [] -> failwith "sort shrunk the list???" - | (((n,uses),_)::_) as wq -> + | (((n,uses),def)::rest) as wq -> if (Nameset.cardinal uses = 0) then topological_sort wq defs - else let _ = Printf.eprintf "Uses on failure are %s, binds are %s\n" (set_to_string uses) (set_to_string n) - in let _ = print_dependencies wq wq uses in failwith "A dependency was unmet" + else + let _ = Printf.eprintf "Merging (potentially) mutually recursive definitions %s and %s\n" (set_to_string n) (set_to_string uses) in + let is_used ((binds', uses'), def') = not(Nameset.is_empty(Nameset.inter binds' uses)) in + let (used, rest) = List.partition is_used rest in + let wq = merge_mutrecs (((n,uses),def)::used) :: rest in + topological_sort wq defs let rec add_to_partial_order ((binds,uses),def) = function | [] -> 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/test/pattern.sail b/src/test/pattern.sail index cabe7dad..97e5a0ef 100644 --- a/src/test/pattern.sail +++ b/src/test/pattern.sail @@ -4,9 +4,9 @@ register nat x register nat y typedef wordsize = forall Nat 'n, 'n IN {8,16,32}. [|'n|] -let forall Nat 'n. (wordsize<'n>) word = 8 +(* let forall Nat 'n. (wordsize<'n>) word = 8 *) -function nat main _ = { +function nat main () = { (* works - x and y are set to 42 *) n := 1; diff --git a/src/trace_viewer/.gitignore b/src/trace_viewer/.gitignore new file mode 100644 index 00000000..c1f9aea6 --- /dev/null +++ b/src/trace_viewer/.gitignore @@ -0,0 +1,6 @@ +*~ +*.js +*.js.map + +# Dependencies +node_modules/ diff --git a/src/trace_viewer/List-add.svg b/src/trace_viewer/List-add.svg new file mode 100644 index 00000000..f8031599 --- /dev/null +++ b/src/trace_viewer/List-add.svg @@ -0,0 +1,56 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg id="svg6431" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns="http://www.w3.org/2000/svg" sodipodi:docname="list-add.svg" xmlns:sodipodi="http://inkscape.sourceforge.net/DTD/sodipodi-0.dtd" height="48px" sodipodi:version="0.32" width="48px" xmlns:cc="http://web.resource.org/cc/" xmlns:xlink="http://www.w3.org/1999/xlink" sodipodi:docbase="/home/jimmac/src/cvs/tango-icon-theme/scalable/actions" xmlns:dc="http://purl.org/dc/elements/1.1/"> + <defs id="defs6433"> + <linearGradient id="linearGradient4975" y2="48.548" gradientUnits="userSpaceOnUse" x2="45.919" gradientTransform="translate(-18.018 -13.571)" y1="36.423" x1="34.893"> + <stop id="stop1324" stop-color="#729fcf" offset="0"/> + <stop id="stop1326" stop-color="#5187d6" offset="1"/> + </linearGradient> + <linearGradient id="linearGradient7922" y2="34.977" gradientUnits="userSpaceOnUse" x2="27.901" y1="22.852" x1="16.875"> + <stop id="stop7918" stop-color="#fff" offset="0"/> + <stop id="stop7920" stop-color="#fff" stop-opacity=".34021" offset="1"/> + </linearGradient> + <radialGradient id="radialGradient2097" gradientUnits="userSpaceOnUse" cy="35.127" cx="23.071" gradientTransform="matrix(.91481 .012650 -.0082150 .21356 2.2539 27.189)" r="10.319"> + <stop id="stop2093" offset="0"/> + <stop id="stop2095" stop-opacity="0" offset="1"/> + </radialGradient> + </defs> + <sodipodi:namedview id="base" bordercolor="#666666" pagecolor="#ffffff" showgrid="false" borderopacity="0.15686275" showguides="true"/> + <metadata id="metadata6436"> + <rdf:RDF> + <cc:Work rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type rdf:resource="http://purl.org/dc/dcmitype/StillImage"/> + <dc:title>Add</dc:title> + <dc:date>2006-01-04</dc:date> + <dc:creator> + <cc:Agent> + <dc:title>Andreas Nilsson</dc:title> + </cc:Agent> + </dc:creator> + <dc:source>http://tango-project.org</dc:source> + <dc:subject> + <rdf:Bag> + <rdf:li>add</rdf:li> + <rdf:li>plus</rdf:li> + </rdf:Bag> + </dc:subject> + <cc:license rdf:resource="http://creativecommons.org/licenses/by-sa/2.0/"/> + </cc:Work> + <cc:License rdf:about="http://creativecommons.org/licenses/by-sa/2.0/"> + <cc:permits rdf:resource="http://web.resource.org/cc/Reproduction"/> + <cc:permits rdf:resource="http://web.resource.org/cc/Distribution"/> + <cc:requires rdf:resource="http://web.resource.org/cc/Notice"/> + <cc:requires rdf:resource="http://web.resource.org/cc/Attribution"/> + <cc:permits rdf:resource="http://web.resource.org/cc/DerivativeWorks"/> + <cc:requires rdf:resource="http://web.resource.org/cc/ShareAlike"/> + </cc:License> + </rdf:RDF> + </metadata> + <g id="layer1"> + <path id="path1361" sodipodi:rx="10.319340" sodipodi:ry="2.3201940" sodipodi:type="arc" d="m33.278 34.941a10.319 2.3202 0 1 1 -20.638 0 10.319 2.3202 0 1 1 20.638 0z" opacity=".2" transform="matrix(1.5505 0 0 1.293 -11.597 -8.1782)" sodipodi:cy="34.940620" sodipodi:cx="22.958872" fill="url(#radialGradient2097)"/> + <path id="text1314" d="m27.514 37.543v-9.027l9.979-0.04v-6.996h-9.97l-0.009-9.96-7.016 0.011 0.005 9.931-9.99 0.074-0.036 6.969 10.034-0.029 0.007 9.04 6.996 0.027z" sodipodi:nodetypes="ccccccccccccc" stroke="#3465a4" stroke-width="1px" fill="#75a1d0"/> + <path id="path7076" opacity=".40860" d="m26.499 36.534v-9.034h10.002l-0.006-5.025h-9.987v-9.995l-4.995 0.018 0.009 9.977-10.026 0.018-0.027 4.973 10.064 0.009-0.013 9.028 4.979 0.031z" sodipodi:nodetypes="ccccccccccccc" stroke="url(#linearGradient7922)" stroke-width="1px" fill="url(#linearGradient4975)"/> + <path id="path7914" opacity=".31183" d="m11 25c0 1.938 25.984-0.969 25.984-0.031v-3l-9.984 0.031v-9.965h-6v9.965h-10v3z" fill-rule="evenodd" sodipodi:nodetypes="ccccccccc" fill="#fff"/> + </g> +</svg> diff --git a/src/trace_viewer/List-remove.svg b/src/trace_viewer/List-remove.svg new file mode 100644 index 00000000..18c9a135 --- /dev/null +++ b/src/trace_viewer/List-remove.svg @@ -0,0 +1,117 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:cc="http://web.resource.org/cc/" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:svg="http://www.w3.org/2000/svg" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:sodipodi="http://inkscape.sourceforge.net/DTD/sodipodi-0.dtd" xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" width="48px" height="48px" id="svg6431" sodipodi:version="0.32" inkscape:version="0.43+devel" sodipodi:docbase="/home/jimmac/src/cvs/tango-icon-theme/scalable/actions" sodipodi:docname="list-remove.svg"> + <defs id="defs6433"> + <linearGradient inkscape:collect="always" id="linearGradient2091"> + <stop style="stop-color:#000000;stop-opacity:1;" offset="0" id="stop2093"/> + <stop style="stop-color:#000000;stop-opacity:0;" offset="1" id="stop2095"/> + </linearGradient> + <radialGradient inkscape:collect="always" xlink:href="#linearGradient2091" id="radialGradient2097" cx="23.070683" cy="35.127438" fx="23.070683" fy="35.127438" r="10.319340" gradientTransform="matrix(0.914812,1.265023e-2,-8.21502e-3,0.213562,2.253914,27.18889)" gradientUnits="userSpaceOnUse"/> + <linearGradient id="linearGradient7916"> + <stop style="stop-color:#ffffff;stop-opacity:1;" offset="0" id="stop7918"/> + <stop style="stop-color:#ffffff;stop-opacity:0.34020618;" offset="1.0000000" id="stop7920"/> + </linearGradient> + <linearGradient inkscape:collect="always" id="linearGradient8662"> + <stop style="stop-color:#000000;stop-opacity:1;" offset="0" id="stop8664"/> + <stop style="stop-color:#000000;stop-opacity:0;" offset="1" id="stop8666"/> + </linearGradient> + <radialGradient inkscape:collect="always" xlink:href="#linearGradient8662" id="radialGradient1503" gradientUnits="userSpaceOnUse" gradientTransform="matrix(1.000000,0.000000,0.000000,0.536723,-1.018989e-13,16.87306)" cx="24.837126" cy="36.421127" fx="24.837126" fy="36.421127" r="15.644737"/> + <linearGradient inkscape:collect="always" id="linearGradient2847"> + <stop style="stop-color:#3465a4;stop-opacity:1;" offset="0" id="stop2849"/> + <stop style="stop-color:#3465a4;stop-opacity:0;" offset="1" id="stop2851"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2847" id="linearGradient1488" gradientUnits="userSpaceOnUse" gradientTransform="matrix(-1.000000,0.000000,0.000000,-1.000000,-1.242480,40.08170)" x1="37.128052" y1="29.729605" x2="37.065414" y2="26.194071"/> + <linearGradient id="linearGradient2831"> + <stop style="stop-color:#3465a4;stop-opacity:1;" offset="0" id="stop2833"/> + <stop id="stop2855" offset="0.33333334" style="stop-color:#5b86be;stop-opacity:1;"/> + <stop style="stop-color:#83a8d8;stop-opacity:0;" offset="1" id="stop2835"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2831" id="linearGradient1486" gradientUnits="userSpaceOnUse" gradientTransform="translate(-48.30498,-6.043298)" x1="13.478554" y1="10.612206" x2="15.419417" y2="19.115122"/> + <linearGradient id="linearGradient2380"> + <stop style="stop-color:#b9cfe7;stop-opacity:1" offset="0" id="stop2382"/> + <stop style="stop-color:#729fcf;stop-opacity:1" offset="1" id="stop2384"/> + </linearGradient> + <linearGradient id="linearGradient2682"> + <stop style="stop-color:#3977c3;stop-opacity:1;" offset="0" id="stop2684"/> + <stop style="stop-color:#89aedc;stop-opacity:0;" offset="1" id="stop2686"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2682" id="linearGradient2688" x1="36.713837" y1="31.455952" x2="37.124462" y2="24.842253" gradientUnits="userSpaceOnUse" gradientTransform="translate(-48.77039,-5.765705)"/> + <linearGradient inkscape:collect="always" id="linearGradient2690"> + <stop style="stop-color:#c4d7eb;stop-opacity:1;" offset="0" id="stop2692"/> + <stop style="stop-color:#c4d7eb;stop-opacity:0;" offset="1" id="stop2694"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2690" id="linearGradient2696" x1="32.647972" y1="30.748846" x2="37.124462" y2="24.842253" gradientUnits="userSpaceOnUse" gradientTransform="translate(-48.77039,-5.765705)"/> + <linearGradient inkscape:collect="always" id="linearGradient2871"> + <stop style="stop-color:#3465a4;stop-opacity:1;" offset="0" id="stop2873"/> + <stop style="stop-color:#3465a4;stop-opacity:1" offset="1" id="stop2875"/> + </linearGradient> + <linearGradient id="linearGradient2402"> + <stop style="stop-color:#729fcf;stop-opacity:1;" offset="0" id="stop2404"/> + <stop style="stop-color:#528ac5;stop-opacity:1;" offset="1" id="stop2406"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2797" id="linearGradient1493" gradientUnits="userSpaceOnUse" x1="5.9649176" y1="26.048164" x2="52.854097" y2="26.048164"/> + <linearGradient inkscape:collect="always" id="linearGradient2797"> + <stop style="stop-color:#ffffff;stop-opacity:1;" offset="0" id="stop2799"/> + <stop style="stop-color:#ffffff;stop-opacity:0;" offset="1" id="stop2801"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2797" id="linearGradient1491" gradientUnits="userSpaceOnUse" x1="5.9649176" y1="26.048164" x2="52.854097" y2="26.048164"/> + <linearGradient inkscape:collect="always" id="linearGradient7179"> + <stop style="stop-color:#ffffff;stop-opacity:1;" offset="0" id="stop7181"/> + <stop style="stop-color:#ffffff;stop-opacity:0;" offset="1" id="stop7183"/> + </linearGradient> + <linearGradient id="linearGradient2316"> + <stop style="stop-color:#000000;stop-opacity:1;" offset="0" id="stop2318"/> + <stop style="stop-color:#ffffff;stop-opacity:0.65979379;" offset="1" id="stop2320"/> + </linearGradient> + <linearGradient id="linearGradient1322"> + <stop id="stop1324" offset="0.0000000" style="stop-color:#729fcf"/> + <stop id="stop1326" offset="1.0000000" style="stop-color:#5187d6;stop-opacity:1.0000000;"/> + </linearGradient> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient1322" id="linearGradient4975" x1="34.892849" y1="36.422989" x2="45.918697" y2="48.547989" gradientUnits="userSpaceOnUse" gradientTransform="translate(-18.01785,-13.57119)"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient7179" id="linearGradient7185" x1="13.435029" y1="13.604306" x2="22.374878" y2="23.554308" gradientUnits="userSpaceOnUse"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient7179" id="linearGradient7189" gradientUnits="userSpaceOnUse" x1="13.435029" y1="13.604306" x2="22.374878" y2="23.554308" gradientTransform="matrix(-1.000000,0.000000,0.000000,-1.000000,47.93934,50.02474)"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2380" id="linearGradient7180" gradientUnits="userSpaceOnUse" x1="62.513836" y1="36.061237" x2="15.984863" y2="20.60858"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2871" id="linearGradient7182" gradientUnits="userSpaceOnUse" x1="46.834816" y1="45.264122" x2="45.380436" y2="50.939667"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2402" id="linearGradient7184" gradientUnits="userSpaceOnUse" x1="18.935766" y1="23.667896" x2="53.588622" y2="26.649362"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient2871" id="linearGradient7186" gradientUnits="userSpaceOnUse" x1="46.834816" y1="45.264122" x2="45.380436" y2="50.939667"/> + <linearGradient inkscape:collect="always" xlink:href="#linearGradient7916" id="linearGradient7922" x1="16.874998" y1="22.851799" x2="27.900846" y2="34.976799" gradientUnits="userSpaceOnUse"/> + </defs> + <sodipodi:namedview id="base" pagecolor="#ffffff" bordercolor="#666666" borderopacity="0.10980392" inkscape:pageopacity="0.0" inkscape:pageshadow="2" inkscape:zoom="1" inkscape:cx="38.727739" inkscape:cy="26.974252" inkscape:current-layer="layer1" showgrid="false" inkscape:grid-bbox="true" inkscape:document-units="px" inkscape:window-width="1280" inkscape:window-height="949" inkscape:window-x="380" inkscape:window-y="79" inkscape:showpageshadow="false"/> + <metadata id="metadata6436"> + <rdf:RDF> + <cc:Work rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type rdf:resource="http://purl.org/dc/dcmitype/StillImage"/> + <dc:title>Remove</dc:title> + <dc:date>2006-01-04</dc:date> + <dc:creator> + <cc:Agent> + <dc:title>Andreas Nilsson</dc:title> + </cc:Agent> + </dc:creator> + <dc:source>http://tango-project.org</dc:source> + <dc:subject> + <rdf:Bag> + <rdf:li>remove</rdf:li> + <rdf:li>delete</rdf:li> + </rdf:Bag> + </dc:subject> + <cc:license rdf:resource="http://creativecommons.org/licenses/by-sa/2.0/"/> + </cc:Work> + <cc:License rdf:about="http://creativecommons.org/licenses/by-sa/2.0/"> + <cc:permits rdf:resource="http://web.resource.org/cc/Reproduction"/> + <cc:permits rdf:resource="http://web.resource.org/cc/Distribution"/> + <cc:requires rdf:resource="http://web.resource.org/cc/Notice"/> + <cc:requires rdf:resource="http://web.resource.org/cc/Attribution"/> + <cc:permits rdf:resource="http://web.resource.org/cc/DerivativeWorks"/> + <cc:requires rdf:resource="http://web.resource.org/cc/ShareAlike"/> + </cc:License> + </rdf:RDF> + </metadata> + <g id="layer1" inkscape:label="Layer 1" inkscape:groupmode="layer"> + <path style="font-size:59.901077px;font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;text-align:start;line-height:125.00000%;writing-mode:lr-tb;text-anchor:start;fill:#75a1d0;fill-opacity:1.0000000;stroke:#3465a4;stroke-width:1.0000004px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Bitstream Vera Sans" d="M 27.514356,28.359472 L 39.633445,28.475543 L 39.633445,21.480219 L 27.523285,21.480219 L 20.502546,21.462362 L 8.5441705,21.489147 L 8.5084565,28.457686 L 20.511475,28.475543 L 27.514356,28.359472 z " id="text1314" sodipodi:nodetypes="ccccccccc"/> + <path style="font-size:59.901077px;font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;text-align:start;line-height:125.00000%;writing-mode:lr-tb;text-anchor:start;opacity:0.40860215;fill:url(#linearGradient4975);fill-opacity:1.0000000;stroke:url(#linearGradient7922);stroke-width:1.0000006px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;font-family:Bitstream Vera Sans" d="M 38.579429,27.484113 L 38.588357,22.475309 L 9.5267863,22.493166 L 9.5000003,27.466256 L 38.579429,27.484113 z " id="path7076" sodipodi:nodetypes="ccccc"/> + <path style="fill:#ffffff;fill-opacity:1.0000000;fill-rule:evenodd;stroke:none;stroke-width:1.0000000px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1.0000000;opacity:0.31182796" d="M 9.0000000,25.000000 C 9.0000000,26.937500 39.125000,24.062500 39.125000,25.000000 L 39.125000,22.000000 L 9.0000000,22.000000 L 9.0000000,25.000000 z " id="path7914" sodipodi:nodetypes="ccccc"/> + <path sodipodi:type="arc" style="opacity:0.10439561;fill:url(#radialGradient2097);fill-opacity:1;stroke:none;stroke-width:3;stroke-linecap:round;stroke-linejoin:round;stroke-miterlimit:4;stroke-dasharray:none;stroke-dashoffset:0;stroke-opacity:1" id="path1361" sodipodi:cx="22.958872" sodipodi:cy="34.94062" sodipodi:rx="10.31934" sodipodi:ry="2.320194" d="M 33.278212 34.94062 A 10.31934 2.320194 0 1 1 12.639532,34.94062 A 10.31934 2.320194 0 1 1 33.278212 34.94062 z" transform="matrix(2.32573,0,0,1.293,-29.39613,-8.178198)" inkscape:r_cx="true" inkscape:r_cy="true"/> + </g> +</svg>
\ No newline at end of file diff --git a/src/trace_viewer/README b/src/trace_viewer/README new file mode 100644 index 00000000..547a1435 --- /dev/null +++ b/src/trace_viewer/README @@ -0,0 +1,11 @@ + +To use, first make sure node.js and npm are installed (e.g. via the +Ubuntu package manager), then run the following in this directory: + +> npm install + +> npm run tsc + +> ./node_modules/.bin/electron . + +and point the file selector at a trace produced by sail -ocaml_trace
\ No newline at end of file diff --git a/src/trace_viewer/index.css b/src/trace_viewer/index.css new file mode 100644 index 00000000..35ebcb23 --- /dev/null +++ b/src/trace_viewer/index.css @@ -0,0 +1,86 @@ + +body { + background-color: #202020; + color: #DCDCCC; + font-family: monospace; + font-size: 14pt; + font-weight: bold; +} + +img { + height: 30px; +} + +#control { + position: fixed; + bottom: 0px; + left:10%; + right:10%; + width:80%; +} + +#command { + font-size: 16pt; + width: 100%; +} + +.call { + background-color: #313131; + border: 1px; + border-left: 5px; + border-color: rgb(118, 173, 160); + border-style: solid; + padding-top: 2px; + padding-bottom: 2px; + margin: 0px; + min-height: 32px; + display: flex; + align-items: center; +} + +.write { + background-color: #313131; + border: 1px; + border-left: 5px; + border-color: rgb(255, 40, 40); + border-style: solid; + padding-top: 2px; + padding-bottom: 2px; + margin: 0px; + min-height: 32px; + display: flex; + align-items: center; +} + +.load { + background-color: #313131; + color: white; + border: 1px; + border-left: 5px; + border-color: #ff9100; + border-style: solid; + padding-top: 2px; + padding-bottom: 2px; + margin: 0px; + min-height: 32px; + display: flex; + align-items: center; +} + +.read { + background-color: #313131; + border: 1px; + border-left: 5px; + border-color: rgb(107, 199, 47); + border-style: solid; + padding-top: 2px; + padding-bottom: 2px; + margin: 0px; + min-height: 32px; + display: flex; + align-items: center; +} + +.tree { + padding-left: 20px; +}
\ No newline at end of file diff --git a/src/trace_viewer/index.html b/src/trace_viewer/index.html new file mode 100644 index 00000000..9efcca56 --- /dev/null +++ b/src/trace_viewer/index.html @@ -0,0 +1,19 @@ +<!DOCTYPE html> +<html> + <head> + <meta charset="UTF-8"> + <title>Sail Trace Viewer</title> + <script type="text/javascript"> + var exports = {} + </script> + <script type="text/javascript" src="index.js"></script> + <link rel="stylesheet" type="text/css" href="index.css"> + </head> + <body> + <div id="container"> + </div> + <div id="control"> + <input type="text" id="command"> + </div> + </body> +</html>
\ No newline at end of file diff --git a/src/trace_viewer/index.ts b/src/trace_viewer/index.ts new file mode 100644 index 00000000..f9b5041b --- /dev/null +++ b/src/trace_viewer/index.ts @@ -0,0 +1,287 @@ +import {remote} from "electron" +import fs = require("fs") +const dialog = remote.dialog +const app = remote.app + +let topCallDiv = document.createElement("div") + +const max_arg_length = 5000 + +abstract class Event { + caller: Call + + protected div: HTMLDivElement | null = null + + public hide(): void { + if (this.div != null) { + this.div.remove() + this.div = null + } + } + + protected abstract showText(text: HTMLParagraphElement): void + + public show(): HTMLDivElement { + let callerDiv: HTMLDivElement = (this.caller != null) ? this.caller.show() : topCallDiv + + if (this.div != null) { + return this.div + } else { + this.div = document.createElement("div") + this.div.className = "tree" + callerDiv.appendChild(this.div) + let text = document.createElement("p") + this.showText(text) + this.div.appendChild(text) + return this.div + } + } +} + +class Load extends Event { + loc: string + val: string + + constructor(loc: string, val: string) { + super() + this.loc = loc + this.val = val + } + + protected showText(text: HTMLParagraphElement): void { + text.className = "load" + text.insertAdjacentText('beforeend', this.loc + " " + this.val) + } +} + +class Read extends Event { + reg: string + value: string + + constructor(reg: string, value: string) { + super() + this.reg = reg + this.value = value + } + + public showText(text: HTMLParagraphElement): void { + text.className = "read" + text.insertAdjacentText('beforeend', this.reg + " " + this.value) + } +} + +class Write extends Event { + reg: string + value: string + + constructor(reg: string, value: string) { + super() + this.reg = reg + this.value = value + } + + public showText(text: HTMLParagraphElement): void { + text.className = "write" + text.insertAdjacentText('beforeend', this.reg + " " + this.value) + } +} + +class Call { + fn: string + arg: string + ret: string + callees: (Call | Event)[] = [] + caller: Call + + private div: HTMLDivElement | null = null + + private toggle: boolean = false + private toggleImg: HTMLImageElement | null = null + + constructor(fn: string, arg: string, ret: string) { + this.fn = fn + this.arg = arg + this.ret = ret + } + + public expand() { + if (this.caller != undefined) { + this.caller.expand() + } + this.showChildren() + } + + public iter(f: (call: Call) => void): void { + f(this) + this.callees.forEach((callee) => { + if (callee instanceof Call) { callee.iter(f) } + }) + + } + + public show(): HTMLDivElement { + let callerDiv: HTMLDivElement = (this.caller != null) ? this.caller.show() : topCallDiv + + if (this.div != null) { + return this.div + } else { + this.div = document.createElement("div") + this.div.className = "tree" + callerDiv.appendChild(this.div) + let text = document.createElement("p") + text.className = "call" + if (this.callees.length > 0) { + this.toggleImg = document.createElement("img") + this.toggleImg.src = "List-add.svg" + this.toggleImg.addEventListener('click', () => { + if (this.toggle) { + this.hideChildren() + } else { + this.showChildren() + } + }) + text.appendChild(this.toggleImg) + } + this.toggle = false + let display_arg = this.arg + if (this.arg.length > max_arg_length) { + display_arg = this.arg.slice(0, max_arg_length) + } + let display_ret = this.ret + if (this.ret.length > max_arg_length) { + display_ret = this.ret.slice(0, max_arg_length) + } + + text.insertAdjacentText('beforeend', this.fn + " " + display_arg + " -> " + display_ret) + this.div.appendChild(text) + return this.div + } + } + + public hide(): void { + if (this.toggle == true) { + this.hideChildren() + } + + if (this.div != null) { + this.div.remove() + this.div = null + } + if (this.toggleImg != null) { + this.toggleImg.remove() + this.toggleImg = null + } + } + + public hideChildren(): void { + this.callees.forEach(call => { + call.hide() + }) + + if (this.toggleImg != null) { + this.toggleImg.src = "List-add.svg" + this.toggle = false + } else { + alert("this.toggleImg was null!") + } + } + + public showChildren(): void { + this.callees.forEach(call => { + call.show() + }); + + if (this.toggleImg != null) { + this.toggleImg.src = "List-remove.svg" + this.toggle = true + } else { + alert("this.toggleImg was null!") + } + } + + public appendChild(child: Call | Write | Read | Load): void { + child.caller = this + + this.callees.push(child) + } +} + +document.addEventListener('DOMContentLoaded', () => { + let rootCall = new Call("ROOT", "", "") + topCallDiv.id = "root" + document.getElementById("container")!.appendChild(topCallDiv) + + let commandInput = document.getElementById("command") as HTMLInputElement + + commandInput.addEventListener("keydown", (event) => { + if(event.keyCode == 13) { + let cmd = commandInput.value.split(" ") + commandInput.value = "" + + if (cmd[0] == "function") { + rootCall.iter((call) => { + if (call.fn == cmd[1]) { call.caller.expand() } + }) + } + } + }) + + let files = dialog.showOpenDialog(remote.getCurrentWindow(), {title: "Select log file", defaultPath: app.getAppPath()}) + + if (files == [] || files == undefined) { + dialog.showErrorBox("Error", "No file selected") + app.exit(1) + } + + fs.readFile(files[0], 'utf-8', (err, data) => { + if (err) { + dialog.showErrorBox("Error", "An error occurred when reading the log: " + err.message) + app.exit(1) + } + + let lines = data.split("\n") + // let indents = lines.map(line => line.search(/[^\s]/) / 2) + lines = lines.map(line => line.trim()) + + let stack : Call[] = [rootCall] + + lines.forEach(line => { + if (line.match(/^Call:/)) { + let words = line.slice(6).split(" ") + let call = new Call(words[0], words.slice(1).join(" "), "") + if (stack.length > 0) { + stack[stack.length - 1].appendChild(call) + } + stack.push(call) + } else if (line.match(/^Return:/)) { + let call = stack.pop() + if (call == undefined) { + alert("Unbalanced return") + app.exit(1) + } else { + call.ret = line.slice(8) + } + } else if (line.match(/^Write:/)) { + let words = line.slice(7).split(" ") + let write = new Write(words[0], words.slice(1).join(" ")) + if (stack.length > 0) { + stack[stack.length - 1].appendChild(write) + } + } else if (line.match(/^Read:/)) { + let words = line.slice(6).split(" ") + let read = new Read(words[0], words.slice(1).join(" ")) + if (stack.length > 0) { + stack[stack.length - 1].appendChild(read) + } + } else if (line.match(/^Load:/)) { + let words = line.slice(6).split(" ") + let load = new Load(words[0], words[1]) + if (stack.length > 0) { + stack[stack.length - 1].appendChild(load) + } + } + }) + + rootCall.show() + }) +})
\ No newline at end of file diff --git a/src/trace_viewer/main.ts b/src/trace_viewer/main.ts new file mode 100644 index 00000000..5cc33452 --- /dev/null +++ b/src/trace_viewer/main.ts @@ -0,0 +1,12 @@ +import {app, BrowserWindow} from 'electron' + +let win : BrowserWindow | null = null + +app.on('ready', () => { + win = new BrowserWindow({width: 1920, height: 1200}) + win.loadURL('file://' + __dirname + '/index.html') + //win.webContents.openDevTools() + win.on('close', () => { + win = null + }) +})
\ No newline at end of file diff --git a/src/trace_viewer/package.json b/src/trace_viewer/package.json new file mode 100644 index 00000000..e3a88d30 --- /dev/null +++ b/src/trace_viewer/package.json @@ -0,0 +1,15 @@ +{ + "name": "trace_viewer", + "version": "1.0.0", + "description": "", + "main": "main.js", + "scripts": { + "test": "echo \"Error: no test specified\" && exit 1", + "tsc": "./node_modules/typescript/bin/tsc" + }, + "devDependencies": { + "@types/node": "^8.0.46", + "electron": "1.7.9", + "typescript": "^2.5.3" + } +} diff --git a/src/trace_viewer/tsconfig.json b/src/trace_viewer/tsconfig.json new file mode 100644 index 00000000..e66156b3 --- /dev/null +++ b/src/trace_viewer/tsconfig.json @@ -0,0 +1,18 @@ +{ + "compileOnSave": true, + "compilerOptions": { + "target": "es5", + "moduleResolution": "node", + "pretty": true, + "newLine": "LF", + "allowSyntheticDefaultImports": true, + "strict": true, + "noUnusedLocals": true, + "noUnusedParameters": true, + "sourceMap": true, + "strictNullChecks": true, + "skipLibCheck": true, + "allowJs": true, + "jsx": "preserve" + } +}
\ No newline at end of file diff --git a/src/type_check.ml b/src/type_check.ml index c4119281..6c158f9e 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,3524 @@ (* 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} +open Util +open Ast_util +open Big_int + +(* opt_tc_debug controls the verbosity of the type checker. 0 is + silent, 1 prints a tree of the type derivation and 2 is like 1 but + with much more debug information. *) +let opt_tc_debug = ref 0 + +(* opt_no_effects turns of the effect checking. This can break + re-writer passes, so it should only be used for debugging. *) +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 () + +type type_error = + (* First parameter is the error that caused us to start doing type + coercions, the second is the errors encountered by all possible + coercions *) + | Err_no_casts of type_error * type_error list + | Err_no_overloading of id * (id * type_error) list + | Err_unresolved_quants of id * quant_item list + | Err_subtype of typ * typ * n_constraint list + | Err_no_num_ident of id + | Err_other of string + +let pp_type_error err = + let open PPrint in + let rec pp_err = function + | Err_no_casts (trigger, []) -> + (string "Tried performing type coercion because" ^//^ pp_err trigger) + ^/^ string "No possible coercions" + | Err_no_casts (trigger, errs) -> + (string "Tried performing type coerction because" ^//^ pp_err trigger) + | Err_no_overloading (id, errs) -> + string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^ + group (separate_map hardline (fun (id, err) -> string (string_of_id id) ^^ colon ^^ space ^^ pp_err err) errs) + | Err_subtype (typ1, typ2, []) -> + separate space [ string (string_of_typ typ1); + string "is not a subtype of"; + string (string_of_typ typ2) ] + | Err_subtype (typ1, typ2, constrs) -> + separate space [ string (string_of_typ typ1); + string "is not a subtype of"; + string (string_of_typ typ2) ] + ^/^ string "in context" + ^//^ string (string_of_list ", " string_of_n_constraint constrs) + | Err_no_num_ident id -> + string "No num identifier" ^^ space ^^ string (string_of_id id) + | Err_other str -> string str 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 + pp_err err -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 rec string_of_type_error err = + let open PPrint in + let b = Buffer.create 20 in + ToBuffer.pretty 1. 120 b (pp_type_error err); + "\n" ^ Buffer.contents b + +exception Type_error of l * type_error;; + +let typ_error l m = raise (Type_error (l, Err_other m)) + +let typ_raise l err = raise (Type_error (l, err)) + +let deinfix = function + | Id_aux (Id v, l) -> Id_aux (DeIid v, l) + | Id_aux (DeIid v, l) -> Id_aux (DeIid v, l) + +let field_name rec_id id = + match rec_id, id with + | Id_aux (Id r, _), Id_aux (Id v, l) -> Id_aux (Id (r ^ "." ^ v), l) + | _, _ -> assert false + +let string_of_bind (typquant, typ) = string_of_typquant typquant ^ ". " ^ string_of_typ typ + +let orig_kid (Kid_aux (Var v, l) as kid) = + try + let i = String.rindex v '#' in + Kid_aux (Var ("'" ^ String.sub v (i + 1) (String.length v - i - 1)), l) + with + | Not_found -> kid + +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 is_list (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_typ typ, _)]) + when string_of_id f = "list" -> Some typ + | _ -> None + +(* 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 + ^ "}" + +(**************************************************************************) +(* 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_app (id, nexps) -> Nexp_app (id, List.map (nexp_subst sv subst) nexps) + | 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_equal (subst, nconstant int) + | (int :: ints) -> NC_or (mk_nc (NC_equal (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_equal (n1, n2) -> NC_equal (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_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2) + | NC_set (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) + | NC_false -> NC_false + | NC_true -> NC_true + +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_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) + | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv subst nc, typ_subst_nexp sv subst typ) +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 + +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_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) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_typ sv subst typ) +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 + +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_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) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc, typ_subst_order sv subst typ) +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) + +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_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) + | Typ_exist (kids, nc, typ) when KidSet.mem sv (KidSet.of_list kids) -> Typ_exist (kids, nc, typ) + | Typ_exist (kids, nc, typ) -> Typ_exist (kids, nc_subst_nexp sv (Nexp_var subst) nc, typ_subst_kid sv subst typ) +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) + +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 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 update_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 -> id -> t -> typquant * typ + val add_local : id -> mut * typ -> t -> t + val get_locals : t -> (mut * typ) Bindings.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 is_register : id -> t -> bool + val get_register : id -> t -> typ + val add_register : id -> typ -> t -> t + val add_regtyp : id -> big_int -> big_int -> (index_range * id) list -> t -> t + val is_regtyp : id -> t -> bool + val get_regtyp : id -> t -> big_int * big_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 -> (t -> typ_arg list -> typ) -> t -> t + val get_typ_synonym : id -> t -> t -> typ_arg list -> typ + val add_num_def : id -> nexp -> t -> t + val get_num_def : id -> t -> nexp + val add_overloads : id -> id list -> t -> t + val get_overloads : id -> t -> id list + val is_extern : id -> t -> string -> bool + val add_extern : id -> (string -> string option) -> t -> t + val get_extern : id -> t -> string -> string + 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 allow_polymorphic_undefineds : t -> t + val polymorphic_undefineds : t -> bool + val lookup_id : id -> t -> lvar + val fresh_kid : ?kid:kid -> t -> kid + val expand_synonyms : t -> typ -> typ + val base_typ_of : t -> typ -> typ + val add_smt_op : id -> string -> t -> t + val get_smt_op : id -> t -> string + (* Well formedness-checks *) + val wf_typ : ?exs:KidSet.t -> t -> typ -> unit + val wf_constraint : ?exs:KidSet.t -> t -> n_constraint -> unit + + (* Some of the code in the environment needs to use the Z3 prover, + which is defined below. To break the circularity this would cause + (as the prove code depends on the environment), we add a + reference to the prover to the initial environment. *) + val add_prover : (t -> n_constraint -> bool) -> t -> t + + (* This must not be exported, initial_env sets up a correct initial + environment. *) + 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 : (big_int * big_int * (index_range * id) list) Bindings.t; + variants : (typquant * type_union list) Bindings.t; + typ_vars : base_kind_aux KBindings.t; + typ_synonyms : (t -> typ_arg list -> typ) Bindings.t; + num_defs : nexp 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; + externs : (string -> string option) Bindings.t; + smt_ops : string Bindings.t; + casts : id list; + allow_casts : bool; + constraints : n_constraint list; + default_order : order option; + ret_typ : typ option; + poly_undefineds : bool; + prove : t -> n_constraint -> bool + } + + 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; + num_defs = Bindings.empty; + overloads = Bindings.empty; + flow = Bindings.empty; + enums = Bindings.empty; + records = Bindings.empty; + accessors = Bindings.empty; + externs = Bindings.empty; + smt_ops = Bindings.empty; + casts = []; + allow_casts = true; + constraints = []; + default_order = None; + ret_typ = None; + poly_undefineds = false; + prove = (fun _ _ -> false) + } + + let add_prover f env = { env with prove = f } + + 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 + + let bk_counter = ref 0 + let bk_name () = let kid = mk_kid ("bk#" ^ string_of_int !bk_counter) in incr bk_counter; kid + + let kinds_typq kinds = mk_typquant (List.map (fun k -> mk_qi_id k (bk_name ())) kinds) + + let builtin_typs = + List.fold_left (fun m (name, kinds) -> Bindings.add (mk_id name) (kinds_typq kinds) m) Bindings.empty + [ ("range", [BK_nat; BK_nat]); + ("atom", [BK_nat]); + ("vector", [BK_nat; BK_nat; BK_order; BK_type]); + ("register", [BK_type]); + ("bit", []); + ("unit", []); + ("int", []); + ("nat", []); + ("bool", []); + ("real", []); + ("list", [BK_type]); + ("string", []); + ("itself", [BK_type]) + ] + + 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 + || Bindings.mem id builtin_typs + + 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 add_smt_op id str env = + typ_print ("Adding smt binding " ^ string_of_id id ^ " to " ^ str); + { env with smt_ops = Bindings.add id str env.smt_ops } + + let get_smt_op (Id_aux (_, l) as id) env = + let rec first_smt_op = function + | id :: ids -> (try Bindings.find id env.smt_ops with Not_found -> first_smt_op ids) + | [] -> typ_error l ("No SMT op for " ^ string_of_id id) + in + try Bindings.find id env.smt_ops with + | Not_found -> first_smt_op (get_overloads id env) + + let rec infer_kind env id = + if Bindings.mem id builtin_typs then + Bindings.find id builtin_typs + else if Bindings.mem id env.variants then + fst (Bindings.find id env.variants) + else if Bindings.mem id env.records then + fst (Bindings.find id env.records) + else if Bindings.mem id env.enums || Bindings.mem id env.regtyps then + mk_typquant [] + else if Bindings.mem id env.typ_synonyms then + typ_error (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id) + else + typ_error (id_loc id) ("Cannot infer kind of " ^ string_of_id id) + + let check_args_typquant id env args typq = + let kopts, ncs = quant_split typq in + let rec subst_args kopts args = + match kopts, args with + | kopt :: kopts, Typ_arg_aux (Typ_arg_nexp arg, _) :: args when is_nat_kopt kopt -> + List.map (nc_subst_nexp (kopt_kid kopt) (unaux_nexp arg)) (subst_args kopts args) + | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> + subst_args kopts args + | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> + subst_args kopts args + | [], [] -> ncs + | _, Typ_arg_aux (_, l) :: _ -> typ_error l "ERROR 1" + | _, _ -> typ_error Parse_ast.Unknown "ERROR 2" 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 ncs = subst_args kopts args in + if List.for_all (env.prove env) ncs + then () + else typ_error (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id) + + 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 env 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 env []) + 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) + + (* Check if a type, order, n-expression or constraint is + well-formed. Throws a type error if the type is badly formed. *) + let rec wf_typ ?exs:(exs=KidSet.empty) env typ = + typ_debug ("Well-formed " ^ string_of_typ typ); + let (Typ_aux (typ_aux, l)) = expand_synonyms env typ in + match typ_aux with + | Typ_id id when bound_typ_id env id -> + let typq = infer_kind env id in + if quant_kopts typq != [] + then typ_error l ("Type constructor " ^ string_of_id id ^ " expected " ^ string_of_typquant typq) + else () + | 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 ~exs:exs env typ_arg; wf_typ ~exs:exs env typ_ret + | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs + | Typ_app (id, args) when bound_typ_id env id -> + List.iter (wf_typ_arg ~exs:exs env) args; + check_args_typquant id env args (infer_kind env id) + | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id) + | Typ_exist ([], _, _) -> typ_error l ("Existential must have some type variables") + | Typ_exist (kids, nc, typ) when KidSet.is_empty exs -> + wf_constraint ~exs:(KidSet.of_list kids) env nc; wf_typ ~exs:(KidSet.of_list kids) env typ + | Typ_exist (_, _, _) -> typ_error l ("Nested existentials are not allowed") + and wf_typ_arg ?exs:(exs=KidSet.empty) env (Typ_arg_aux (typ_arg_aux, _)) = + match typ_arg_aux with + | Typ_arg_nexp nexp -> wf_nexp ~exs:exs env nexp + | Typ_arg_typ typ -> wf_typ ~exs:exs env typ + | Typ_arg_order ord -> wf_order env ord + and wf_nexp ?exs:(exs=KidSet.empty) env (Nexp_aux (nexp_aux, l)) = + match nexp_aux with + | Nexp_id _ -> () + | Nexp_var kid when KidSet.mem kid exs -> () + | 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_app (id, nexps) -> + let _ = get_smt_op id env in + List.iter (fun n -> wf_nexp ~exs:exs env n) nexps + | Nexp_times (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 + | Nexp_sum (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 + | Nexp_minus (nexp1, nexp2) -> wf_nexp ~exs:exs env nexp1; wf_nexp ~exs:exs env nexp2 + | Nexp_exp nexp -> wf_nexp ~exs:exs env nexp (* MAYBE: Could put restrictions on what is allowed here *) + | Nexp_neg nexp -> wf_nexp ~exs:exs 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 -> () + and wf_constraint ?exs:(exs=KidSet.empty) env (NC_aux (nc, _)) = + match nc with + | NC_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 + | NC_not_equal (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 + | NC_bounded_ge (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 + | NC_bounded_le (n1, n2) -> wf_nexp ~exs:exs env n1; wf_nexp ~exs:exs env n2 + | NC_set (kid, ints) -> () (* MAYBE: We could demand that ints are all unique here *) + | NC_or (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 + | NC_and (nc1, nc2) -> wf_constraint ~exs:exs env nc1; wf_constraint ~exs:exs env nc2 + | NC_true | NC_false -> () + + let counter = ref 0 + + let fresh_kid ?kid:(kid=mk_kid "") env = + let suffix = if Kid.compare kid (mk_kid "") = 0 then "#" else "#" ^ string_of_id (id_of_kid kid) in + let fresh = Kid_aux (Var ("'fv" ^ string_of_int !counter ^ suffix), Parse_ast.Unknown) in + incr counter; fresh + + let freshen_kid env kid (typq, typ) = + let fresh = fresh_kid ~kid: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 update_val_spec id bind env = + 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 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 update_val_spec id bind env + + 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 + let type_unions = List.concat (List.map (fun (_, (_, tus)) -> tus) (Bindings.bindings env.variants)) in + List.exists (is_ctor id) type_unions + + 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 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 rectyp = match record_typ_args (quant_items typq) with + | [] -> mk_id_typ id + | args -> mk_typ (Typ_app (id, args)) + in + 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 id ^ "." ^ string_of_id fid ^ " :: " ^ string_of_bind (typq, acc_typ)); + Bindings.add (field_name id 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 rec_id 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 (field_name rec_id id) env.accessors) + with + | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_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 is_register id env = + Bindings.mem id env.registers + + 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 is_extern id env backend = + try not (Bindings.find id env.externs backend = None) with + | Not_found -> false + (* Bindings.mem id env.externs *) + + let add_extern id ext env = + { env with externs = Bindings.add id ext env.externs } + + let get_extern id env backend = + try + match Bindings.find id env.externs backend with + | Some ext -> ext + | None -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id) + with + | Not_found -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id) + + 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_big_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_big_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 = + wf_typ env typ; + 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 gt_big_int base top + then check_index_ranges IdSet.empty gt_big_int (add_big_int base unit_big_int) (sub_big_int top unit_big_int) ranges + else check_index_ranges IdSet.empty lt_big_int (sub_big_int base unit_big_int) (add_big_int top unit_big_int) 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 get_locals env = env.locals + + 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_print ("Adding kind identifier " ^ string_of_kid kid ^ " :: " ^ string_of_base_kind_aux k); + { env with typ_vars = KBindings.add kid k env.typ_vars } + end + + let add_num_def id nexp env = + if Bindings.mem id env.num_defs + then typ_error (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound") + else + begin + typ_print ("Adding Num identifier " ^ string_of_id id ^ " :: " ^ string_of_nexp nexp); + { env with num_defs = Bindings.add id nexp env.num_defs } + end + + let get_num_def id env = + try Bindings.find id env.num_defs with + | Not_found -> typ_raise (id_loc id) (Err_no_num_ident id) + + 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 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 + + 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)) + | Typ_id id when is_regtyp id env -> + let base, top, ranges = get_regtyp id env in + let len = sub_big_int (abs_big_int (sub_big_int top base)) unit_big_int in + vector_typ (nconstant base) (nconstant len) (get_default_order env) bit_typ + (* TODO registers with non-default order? non-bitvector registers? *) + | 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 allow_polymorphic_undefineds env = + { env with poly_undefineds = true } + + let polymorphic_undefineds env = env.poly_undefineds + +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 (nint 0) l ord typ + | Ord_aux (Ord_dec, _) as ord -> + vector_typ (nminus l (nint 1)) l ord typ + +let ex_counter = ref 0 + +let fresh_existential ?name:(n="") () = + let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in + incr ex_counter; fresh + +let destruct_exist env typ = + match Env.expand_synonyms env typ with + | Typ_aux (Typ_exist (kids, nc, typ), _) -> + let fresh_kids = List.map (fun kid -> (kid, fresh_existential ~name:(string_of_id (id_of_kid kid)) ())) kids in + let nc = List.fold_left (fun nc (kid, fresh) -> nc_subst_nexp kid (Nexp_var fresh) nc) nc fresh_kids in + let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst_nexp kid (Nexp_var fresh) typ) typ fresh_kids in + Some (List.map snd fresh_kids, nc, typ) + | _ -> None + +let is_exist = function + | Typ_aux (Typ_exist (_, _, _), _) -> true + | _ -> false + +let exist_typ constr typ = + let fresh_kid = fresh_existential () in + mk_typ (Typ_exist ([fresh_kid], constr fresh_kid, typ fresh_kid)) + +let destruct_vector env typ = + let destruct_vector' = 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" -> Some (n1, n2, o, vtyp) + | typ -> None + in + destruct_vector' (Env.expand_synonyms env typ) + +let rec is_typ_monomorphic (Typ_aux (typ, _)) = + match typ with + | Typ_id _ -> true + | Typ_tup typs -> List.for_all is_typ_monomorphic typs + | Typ_app (id, args) -> List.for_all is_typ_arg_monomorphic args + | Typ_fn (typ1, typ2, _) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2 + | Typ_exist _ | Typ_var _ -> false +and is_typ_arg_monomorphic (Typ_arg_aux (arg, _)) = + match arg with + | Typ_arg_nexp _ -> true + | Typ_arg_typ typ -> is_typ_monomorphic typ + | Typ_arg_order (Ord_aux (Ord_dec, _)) | Typ_arg_order (Ord_aux (Ord_inc, _)) -> true + | Typ_arg_order (Ord_aux (Ord_var _, _)) -> false + +(**************************************************************************) +(* 3. Subtyping and constraint solving *) +(**************************************************************************) + +let rec simp_typ (Typ_aux (typ_aux, l)) = Typ_aux (simp_typ_aux typ_aux, l) +and simp_typ_aux = function + | Typ_exist (kids1, nc1, Typ_aux (Typ_exist (kids2, nc2, typ), _)) -> + Typ_exist (kids1 @ kids2, nc_and nc1 nc2, typ) + | typ_aux -> typ_aux + +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_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, [(nint 0, nvar kid)])) + | Typ_id v -> + begin + try normalize_typ env (Env.get_typ_synonym v env 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 "atom", _), [Typ_arg_aux (Typ_arg_nexp n, _)]) -> + let kid = Env.fresh_kid env in + Tnf_index_sort (IS_prop (kid, [(n, nvar kid); (nvar kid, n)])) + | 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 env args) with + | Not_found -> Tnf_app (id, List.map (normalize_typ_arg env) args) + end + | Typ_exist (kids, nc, typ) -> typ_error l "Cannot normalise existential type" + | 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 + +(* 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 env var_of (Nexp_aux (nexp, l)) = + match nexp with + | Nexp_id v -> nexp_constraint env var_of (Env.get_num_def v env) + | Nexp_var kid -> Constraint.variable (var_of kid) + | Nexp_constant c -> Constraint.constant c + | Nexp_times (nexp1, nexp2) -> Constraint.mult (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | Nexp_sum (nexp1, nexp2) -> Constraint.add (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | Nexp_minus (nexp1, nexp2) -> Constraint.sub (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | Nexp_exp nexp -> Constraint.pow2 (nexp_constraint env var_of nexp) + | Nexp_neg nexp -> Constraint.sub (Constraint.constant (big_int_of_int 0)) (nexp_constraint env var_of nexp) + | Nexp_app (id, nexps) -> Constraint.app (Env.get_smt_op id env) (List.map (nexp_constraint env var_of) nexps) + +let rec nc_constraint env var_of (NC_aux (nc, l)) = + match nc with + | NC_equal (nexp1, nexp2) -> Constraint.eq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | NC_not_equal (nexp1, nexp2) -> Constraint.neq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | NC_bounded_ge (nexp1, nexp2) -> Constraint.gteq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | NC_bounded_le (nexp1, nexp2) -> Constraint.lteq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | NC_set (_, []) -> Constraint.literal false + | NC_set (kid, (int :: ints)) -> + List.fold_left Constraint.disj + (Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant int)) + (List.map (fun i -> Constraint.eq (nexp_constraint env var_of (nvar kid)) (Constraint.constant i)) ints) + | NC_or (nc1, nc2) -> Constraint.disj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) + | NC_and (nc1, nc2) -> Constraint.conj (nc_constraint env var_of nc1) (nc_constraint env var_of nc2) + | NC_false -> Constraint.literal false + | NC_true -> Constraint.literal true + +let rec nc_constraints env var_of ncs = + match ncs with + | [] -> Constraint.literal true + | [nc] -> nc_constraint env var_of nc + | (nc :: ncs) -> + Constraint.conj (nc_constraint env var_of nc) (nc_constraints env var_of ncs) + +let prove_z3' env constr = + 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 env var_of (Env.get_constraints env)) (constr var_of) in + match Constraint.call_z3 constr with + | Constraint.Unsat -> typ_debug "unsat"; true + | Constraint.Sat -> typ_debug "sat"; false + | Constraint.Unknown -> typ_debug "unknown"; false + +let prove_z3 env nc = + typ_print ("Prove " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc); + prove_z3' env (fun var_of -> Constraint.negate (nc_constraint env var_of nc)) + +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_equal (nexp1, nexp2) when compare_const eq_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_le (nexp1, nexp2) when compare_const le_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_bounded_ge (nexp1, nexp2) when compare_const ge_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> true + | NC_equal (nexp1, nexp2) when compare_const (fun c1 c2 -> not (eq_big_int c1 c2)) (nexp_simp nexp1) (nexp_simp nexp2) -> false + | NC_bounded_le (nexp1, nexp2) when compare_const gt_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> false + | NC_bounded_ge (nexp1, nexp2) when compare_const lt_big_int (nexp_simp nexp1) (nexp_simp nexp2) -> false + | NC_true -> true + | NC_false -> 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 env var_of nexp1) (nexp_constraint env var_of nexp2) + | ((nexp1, nexp2) :: props) -> + Constraint.disj (Constraint.gt (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2)) (neg_props props) + in + let rec pos_props props = + match props with + | [] -> Constraint.literal true + | [(nexp1, nexp2)] -> Constraint.lteq (nexp_constraint env var_of nexp1) (nexp_constraint env var_of nexp2) + | ((nexp1, nexp2) :: props) -> + Constraint.conj (Constraint.lteq (nexp_constraint env var_of nexp1) (nexp_constraint env 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 env 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.Sat -> 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_equal (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 + +(**************************************************************************) +(* 4. Unification *) +(**************************************************************************) + +let rec nexp_frees ?exs:(exs=KidSet.empty) (Nexp_aux (nexp, l)) = + match nexp with + | Nexp_id _ -> KidSet.empty + | Nexp_var kid -> KidSet.singleton kid + | Nexp_constant _ -> KidSet.empty + | Nexp_times (n1, n2) -> KidSet.union (nexp_frees ~exs:exs n1) (nexp_frees ~exs:exs n2) + | Nexp_sum (n1, n2) -> KidSet.union (nexp_frees ~exs:exs n1) (nexp_frees ~exs:exs n2) + | Nexp_minus (n1, n2) -> KidSet.union (nexp_frees ~exs:exs n1) (nexp_frees ~exs:exs n2) + | Nexp_app (id, ns) -> List.fold_left KidSet.union KidSet.empty (List.map (fun n -> nexp_frees ~exs:exs n) ns) + | Nexp_exp n -> nexp_frees ~exs:exs n + | Nexp_neg n -> nexp_frees ~exs:exs n + +let order_frees (Ord_aux (ord_aux, l)) = + match ord_aux with + | Ord_var kid -> KidSet.singleton kid + | _ -> KidSet.empty + +let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) = + match typ_aux with + | Typ_id v -> KidSet.empty + | Typ_var kid when KidSet.mem kid exs -> KidSet.empty + | Typ_var kid -> KidSet.singleton kid + | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs) + | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args) + | Typ_exist (kids, nc, typ) -> typ_frees ~exs:(KidSet.of_list kids) typ +and typ_arg_frees ?exs:(exs=KidSet.empty) (Typ_arg_aux (typ_arg_aux, l)) = + match typ_arg_aux with + | Typ_arg_nexp n -> nexp_frees ~exs:exs n + | Typ_arg_typ typ -> typ_frees ~exs:exs typ + | Typ_arg_order ord -> order_frees ord + +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 -> eq_big_int 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 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 nc_identical (NC_aux (nc1, _)) (NC_aux (nc2, _)) = + match nc1, nc2 with + | NC_equal (n1a, n1b), NC_equal (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | NC_not_equal (n1a, n1b), NC_not_equal (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | NC_bounded_ge (n1a, n1b), NC_bounded_ge (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | NC_bounded_le (n1a, n1b), NC_bounded_le (n2a, n2b) -> nexp_identical n1a n2a && nexp_identical n1b n2b + | NC_or (nc1a, nc1b), NC_or (nc2a, nc2b) -> nc_identical nc1a nc2a && nc_identical nc1b nc2b + | NC_and (nc1a, nc1b), NC_and (nc2a, nc2b) -> nc_identical nc1a nc2a && nc_identical nc1b nc2b + | NC_true, NC_true -> true + | NC_false, NC_false -> true + | NC_set (kid1, ints1), NC_set (kid2, ints2) when List.length ints1 = List.length ints2 -> + Kid.compare kid1 kid2 = 0 && List.for_all2 (fun i1 i2 -> i1 = i2) ints1 ints2 + | _, _ -> false + +let typ_identical env typ1 typ2 = + let rec typ_identical' (Typ_aux (typ1, _)) (Typ_aux (typ2, _)) = + match typ1, typ2 with + | 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 + | Typ_exist (kids1, nc1, typ1), Typ_exist (kids2, nc2, typ2) when List.length kids1 = List.length kids2 -> + List.for_all2 (fun k1 k2 -> Kid.compare k1 k2 = 0) kids1 kids2 && nc_identical nc1 nc2 && typ_identical' typ1 typ2 + | _, _ -> 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 + in + typ_identical' (Env.expand_synonyms env typ1) (Env.expand_synonyms env typ2) + +type uvar = + | U_nexp of nexp + | U_order of order + | U_effect of effect + | U_typ of typ + +let uvar_subst_nexp sv subst = function + | U_nexp nexp -> U_nexp (nexp_subst sv subst nexp) + | U_typ typ -> U_typ (typ_subst_nexp sv subst typ) + | U_effect eff -> U_effect eff + | U_order ord -> U_order ord + +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_equal (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_equal (n1a, n2a), Parse_ast.Unknown)) -> + unify_nexps l env goals n1b n2b + | Nexp_constant c2 -> + begin + match n1a with + | Nexp_aux (Nexp_constant c1,_) when eq_big_int (mod_big_int c2 c1) zero_big_int -> + unify_nexps l env goals n1b (mk_nexp (Nexp_constant (div_big_int c2 c1))) + | _ -> unify_error l ("Cannot unify Nat expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2) + end + | _ -> 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_equal (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 rec 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_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, [arg1]), Typ_app (f2, [arg2a; arg2b]) + when Id.compare (mk_id "atom") f1 = 0 && Id.compare (mk_id "range") f2 = 0 -> + unify_typ_arg_list 0 KBindings.empty [] [] [arg1; arg1] [arg2a; arg2b] + | Typ_app (f1, [arg1a; arg1b]), Typ_app (f2, [arg2]) + when Id.compare (mk_id "range") f1 = 0 && Id.compare (mk_id "atom") f2 = 0 -> + unify_typ_arg_list 0 KBindings.empty [] [] [arg1a; arg1b] [arg2; arg2] + | 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 (nexp_simp 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 + | _, _ -> unify_error l (string_of_typ_arg typ_arg1 ^ " cannot be unified with type argument " ^ string_of_typ_arg typ_arg2) + in + match destruct_exist env typ2 with + | Some (kids, nc, typ2) -> + let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in + let (unifiers, _, _) = unify l env typ1 typ2 in + typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + unifiers, kids, Some nc + | None -> + let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in + unify_typ l typ1 typ2, [], None + +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) + +(**************************************************************************) +(* 4.5. Subtyping with existentials *) +(**************************************************************************) + +let destruct_atom_nexp env typ = + match Env.expand_synonyms env typ with + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _)]), _) + when string_of_id f = "atom" -> Some n + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp n, _); Typ_arg_aux (Typ_arg_nexp m, _)]), _) + when string_of_id f = "range" && nexp_identical n m -> Some n + | _ -> None + +let destruct_atom_kid env typ = + match Env.expand_synonyms env typ with + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid, _)), _)]), _) + when string_of_id f = "atom" -> Some kid + | Typ_aux (Typ_app (f, [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid1, _)), _); + Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_var kid2, _)), _)]), _) + when string_of_id f = "range" && Kid.compare kid1 kid2 = 0 -> Some kid1 + | _ -> None + +let nc_subst_uvar kid uvar nc = + match uvar with + | U_nexp nexp -> nc_subst_nexp kid (unaux_nexp nexp) nc + | _ -> nc + +let uv_nexp_constraint env (kid, uvar) = + match uvar with + | U_nexp nexp -> Env.add_constraint (nc_eq (nvar kid) nexp) env + | _ -> env + +let rec alpha_equivalent env typ1 typ2 = + let counter = ref 0 in + let new_kid () = let kid = mk_kid ("alpha#" ^ string_of_int !counter) in (incr counter; kid) in + + let rec relabel (Typ_aux (aux, l) as typ) = + let relabelled_aux = + match aux with + | Typ_id _ | Typ_var _ -> aux + | Typ_fn (typ1, typ2, eff) -> Typ_fn (relabel typ1, relabel typ2, eff) + | Typ_tup typs -> Typ_tup (List.map relabel typs) + | Typ_exist (kids, nc, typ) -> + let kids = List.map (fun kid -> (kid, new_kid ())) kids in + let nc = List.fold_left (fun nc (kid, nk) -> nc_subst_nexp kid (Nexp_var nk) nc) nc kids in + let typ = List.fold_left (fun nc (kid, nk) -> typ_subst_nexp kid (Nexp_var nk) nc) typ kids in + Typ_exist (List.map snd kids, nc, typ) + | Typ_app (id, args) -> + Typ_app (id, List.map relabel_arg args) + in + Typ_aux (relabelled_aux, l) + and relabel_arg (Typ_arg_aux (aux, l) as arg) = + match aux with + | Typ_arg_nexp _ | Typ_arg_order _ -> arg + | Typ_arg_typ typ -> Typ_arg_aux (Typ_arg_typ (relabel typ), l) + in + + let typ1 = relabel (Env.expand_synonyms env typ1) in + counter := 0; + let typ2 = relabel (Env.expand_synonyms env typ2) in + typ_debug ("Alpha equivalence for " ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2); + if typ_identical env typ1 typ2 + then (typ_debug "alpha-equivalent"; true) + else (typ_debug "Not alpha-equivalent"; false) + +let rec subtyp l env typ1 typ2 = + typ_print ("Subtype " ^ string_of_typ typ1 ^ " and " ^ string_of_typ typ2); + match destruct_exist env typ1, destruct_exist env typ2 with + (* Ensure alpha equivalent types are always subtypes of one another + - this ensures that we can always re-check inferred types. *) + | _, _ when alpha_equivalent env typ1 typ2 -> () + (* Special case for two existentially quantified numeric (atom) types *) + | Some (kids1, nc1, typ1), Some (_ :: _ :: _ as kids2, nc2, typ2) + when is_some (destruct_atom_kid env typ1) && is_some (destruct_atom_kid env typ2) -> + let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env kids1 in + let env = Env.add_constraint nc1 env in + let Some atom_kid1 = destruct_atom_kid env typ1 in + let Some atom_kid2 = destruct_atom_kid env typ2 in + let kids2 = List.filter (fun kid -> Kid.compare atom_kid2 kid <> 0) kids2 in + let env = Env.add_typ_var atom_kid2 BK_nat env in + let env = Env.add_constraint (nc_eq (nvar atom_kid1) (nvar atom_kid2)) env in + let constr var_of = + Constraint.forall (List.map var_of kids2) (Constraint.negate (nc_constraint env var_of nc2)) + in + if prove_z3' env constr then () + else typ_error l ("Existential atom subtyping failed") + | Some (kids, nc, typ1), _ -> + let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env kids in + let env = Env.add_constraint nc env in + subtyp l env typ1 typ2 + | _, Some (kids, nc, typ2) -> + let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env kids in + let unifiers, existential_kids, existential_nc = + try unify l env typ2 typ1 with + | Unification_error (_, m) -> typ_error l m + in + let nc = List.fold_left (fun nc (kid, uvar) -> nc_subst_uvar kid uvar nc) nc (KBindings.bindings unifiers) in + let env = match existential_kids, existential_nc with + | [], None -> env + | _, Some enc -> + let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env existential_kids in + let env = List.fold_left uv_nexp_constraint env (KBindings.bindings unifiers) in + Env.add_constraint enc env + in + if prove env nc then () + else typ_error l ("Could not show " ^ string_of_typ typ1 ^ " is a subset of existential " ^ string_of_typ typ2) + | _, None -> + if subtyp_tnf env (normalize_typ env typ1) (normalize_typ env typ2) + then () + else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env)) + +let typ_equality l env typ1 typ2 = + subtyp l env typ1 typ2; subtyp l env typ2 typ1 + +let subtype_check env typ1 typ2 = + try subtyp Parse_ast.Unknown env typ1 typ2; true with + | Type_error _ -> false + +(**************************************************************************) +(* 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 (nint 0) (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_dec, _) -> + dvector_typ env + (nint (String.length str - 1)) + (nint (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 (nint 0) (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit"))) + | Ord_aux (Ord_dec, _) -> + dvector_typ env + (nint (String.length str * 4 - 1)) + (nint (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 destruct_vec_typ l env typ = + let destruct_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 + destruct_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) + +let pat_env_of (P_aux (_, (l, tannot))) = env_of_annot (l, tannot) + +(* Flow typing *) + +let rec big_int_of_nexp (Nexp_aux (nexp, _)) = match nexp with + | Nexp_constant c -> Some c + | Nexp_times (n1, n2) -> + Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + | Nexp_sum (n1, n2) -> + Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + | Nexp_minus (n1, n2) -> + Util.option_binop add_big_int (big_int_of_nexp n1) (big_int_of_nexp n2) + | Nexp_exp n -> + Util.option_map (power_int_positive_big_int 2) (big_int_of_nexp n) + | _ -> None + +let destruct_atom (Typ_aux (typ_aux, _)) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id f = "atom" -> + Util.option_map (fun c -> (c, nexp)) (big_int_of_nexp nexp) + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp1, _); Typ_arg_aux (Typ_arg_nexp nexp2, _)]) + when string_of_id f = "range" -> + begin + match big_int_of_nexp nexp1, big_int_of_nexp nexp2 with + | Some c1, Some c2 -> if eq_big_int c1 c2 then Some (c1, nexp1) else None + | _ -> None + end + | _ -> None + +exception Not_a_constraint;; + +let rec assert_nexp env exp = + match destruct_atom_nexp env (typ_of exp) with + | Some nexp -> nexp + | None -> raise Not_a_constraint + +let rec assert_constraint env (E_aux (exp_aux, _) as exp) = + match exp_aux with + | E_app (op, [x; y]) when string_of_id op = "or_bool" -> + nc_or (assert_constraint env x) (assert_constraint env y) + | E_app (op, [x; y]) when string_of_id op = "and_bool" -> + nc_and (assert_constraint env x) (assert_constraint env y) + | E_app (op, [x; y]) when string_of_id op = "gteq_atom" -> + nc_gteq (assert_nexp env x) (assert_nexp env y) + | E_app (op, [x; y]) when string_of_id op = "lteq_atom" -> + nc_lteq (assert_nexp env x) (assert_nexp env y) + | E_app (op, [x; y]) when string_of_id op = "gt_atom" -> + nc_gt (assert_nexp env x) (assert_nexp env y) + | E_app (op, [x; y]) when string_of_id op = "lt_atom" -> + nc_lt (assert_nexp env x) (assert_nexp env y) + | E_app (op, [x; y]) when string_of_id op = "eq_atom" -> + nc_eq (assert_nexp env x) (assert_nexp env y) + | E_app (op, [x; y]) when string_of_id op = "neq_atom" -> + nc_neq (assert_nexp env x) (assert_nexp env y) + | _ -> + begin + typ_debug ("Unable to construct a constraint for expression " ^ string_of_exp exp); + raise Not_a_constraint + end + +type flow_constraint = + | Flow_lteq of big_int * nexp + | Flow_gteq of big_int * nexp + +let restrict_range_upper c1 nexp1 (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 nexp2, _)]) + when string_of_id f = "range" -> + begin + match big_int_of_nexp nexp2 with + | Some c2 -> + let upper = if (lt_big_int c1 c2) then nexp1 else nexp2 in + range_typ nexp upper + | _ -> typ + end + | _ -> typ + +let restrict_range_lower c1 nexp1 (Typ_aux (typ_aux, l) as typ) = + match typ_aux with + | Typ_app (f, [Typ_arg_aux (Typ_arg_nexp nexp2, _); Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id f = "range" -> + begin + match big_int_of_nexp nexp2 with + | Some c2 -> + let lower = if (gt_big_int c1 c2) then nexp1 else nexp2 in + range_typ lower nexp + | _ -> typ + end + | _ -> typ + +let apply_flow_constraint = function + | Flow_lteq (c, nexp) -> + (restrict_range_upper c nexp, + restrict_range_lower (succ_big_int c) (nexp_simp (nsum nexp (nint 1)))) + | Flow_gteq (c, nexp) -> + (restrict_range_lower c nexp, + restrict_range_upper (pred_big_int c) (nexp_simp (nminus nexp (nint 1)))) + +let rec infer_flow env (E_aux (exp_aux, (l, _)) as exp) = + match exp_aux with + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lt_range_atom" -> + let kid = Env.fresh_kid env in + begin + match destruct_atom (typ_of y) with + | Some (c, nexp) -> + [(v, Flow_lteq (pred_big_int c, nexp_simp (nminus nexp (nint 1))))], [] + | _ -> [], [] + end + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "lteq_range_atom" -> + let kid = Env.fresh_kid env in + begin + match destruct_atom (typ_of y) with + | Some (c, nexp) -> [(v, Flow_lteq (c, nexp))], [] + | _ -> [], [] + end + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gt_range_atom" -> + let kid = Env.fresh_kid env in + begin + match destruct_atom (typ_of y) with + | Some (c, nexp) -> + [(v, Flow_gteq (succ_big_int c, nexp_simp (nsum nexp (nint 1))))], [] + | _ -> [], [] + end + | E_app (f, [E_aux (E_id v, _); y]) when string_of_id f = "gteq_range_atom" -> + let kid = Env.fresh_kid env in + begin + match destruct_atom (typ_of y) with + | Some (c, nexp) -> [(v, Flow_gteq (c, nexp))], [] + | _ -> [], [] + end + | _ -> try [], [assert_constraint env exp] with Not_a_constraint -> [], [] + +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 env typ1 typ2 = + let Typ_aux (typ1_aux, _) = Env.expand_synonyms env typ1 in + let Typ_aux (typ2_aux, _) = Env.expand_synonyms env typ2 in + match typ1_aux, typ2_aux with + | Typ_exist (_, _, typ1), _ -> match_typ env typ1 typ2 + | _, Typ_exist (_, _, typ2) -> match_typ env typ1 typ2 + | _, 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 env) 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 env from_typ cast_from_typ && match_typ env 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, err) -> decr depth; typ_raise l err + +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, err) -> decr depth; typ_raise l err + +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 strip_lexp : 'a lexp -> unit lexp = function lexp -> map_lexp_annot (fun (l, _) -> (l, ())) lexp + +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 add_effect (E_aux (exp, (l, Some (env, 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 = + 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 exps with + | [] -> typ_equality l env typ unit_typ; [] + | [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 + add_effect inferred_exp (mk_effect [BE_escape]) :: check_block l (Env.add_constraint nc env) exps typ + | ((E_aux (E_assert (constr_exp, assert_msg), _) as exp) :: exps) -> + begin + try + let constr_exp = crule check_exp env constr_exp bool_typ in + let nc = assert_constraint env constr_exp in + let cexp = annot_exp (E_constraint nc) bool_typ in + let checked_msg = crule check_exp env assert_msg string_typ in + let texp = annot_exp_effect (E_assert (cexp, checked_msg)) unit_typ (mk_effect [BE_escape]) in + texp :: check_block l (Env.add_constraint nc env) exps typ + with + | Not_a_constraint -> + let constr_exp = crule check_exp env constr_exp bool_typ in + let checked_msg = crule check_exp env assert_msg string_typ in + let texp = annot_exp_effect (E_assert (constr_exp, checked_msg)) unit_typ (mk_effect [BE_escape]) in + texp :: check_block l env exps typ + end + | (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 rec check_case pat typ = match pat with + | Pat_aux (Pat_exp (P_aux (P_lit lit, _) as pat, case), annot) -> + let guard = mk_exp (E_app_infix (mk_exp (E_id (mk_id "p#")), mk_id "==", mk_exp (E_lit lit))) in + check_case (Pat_aux (Pat_when (mk_pat (P_id (mk_id "p#")), guard, case), annot)) typ + | Pat_aux (Pat_when (P_aux (P_lit lit, _) as pat, guard, case), annot) -> + let guard' = mk_exp (E_app_infix (mk_exp (E_id (mk_id "p#")), mk_id "==", mk_exp (E_lit lit))) in + check_case (Pat_aux (Pat_when (mk_pat (P_id (mk_id "p#")), mk_exp (E_app_infix (guard, mk_id "&", guard')), case), annot)) typ + | 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 + let flows, constrs = infer_flow env checked_guard in + let env' = add_constraints constrs (add_flows true flows env) 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_try (exp, cases), _ -> + let checked_exp = crule check_exp env exp typ in + let check_case pat typ = match pat with + | Pat_aux (Pat_exp (pat, case), (l, _)) -> + let tpat, env = bind_pat env pat exc_typ 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 exc_typ 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_try (checked_exp, List.map (fun case -> check_case case typ) cases)) typ + | E_cons (x, xs), _ -> + begin + match is_list (Env.expand_synonyms env typ) with + | Some elem_typ -> + let checked_xs = crule check_exp env xs typ in + let checked_x = crule check_exp env x elem_typ in + annot_exp (E_cons (checked_x, checked_xs)) typ + | None -> typ_error l ("Cons " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) + end + | E_list xs, _ -> + begin + match is_list (Env.expand_synonyms env typ) with + | Some elem_typ -> + let checked_xs = List.map (fun x -> crule check_exp env x elem_typ) xs in + annot_exp (E_list checked_xs) typ + | None -> typ_error l ("List " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ) + end + | E_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, ()))), _ -> + (* TODO: this could also infer exp - also fix code duplication with E_record below *) + let checked_exp = crule check_exp env exp typ in + let rectyp_id = match Env.expand_synonyms env typ with + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + rectyp_id + | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + in + let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = + let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ 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 + FE_aux (FE_Fexp (field, checked_exp), (l, None)) + in + annot_exp (E_record_update (checked_exp, FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ + | E_record (FES_aux (FES_Fexps (fexps, flag), (l, ()))), _ -> + (* TODO: check record fields are total *) + let rectyp_id = match Env.expand_synonyms env typ with + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + rectyp_id + | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + in + let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = + let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ 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 + FE_aux (FE_Fexp (field, checked_exp), (l, None)) + in + annot_exp (E_record (FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ + | E_let (LB_aux (letbind, (let_loc, _)), exp), _ -> + begin + match letbind with + | LB_val (P_aux (P_typ (ptyp, _), _) as pat, bind) -> + Env.wf_typ env ptyp; + let checked_bind = crule check_exp env bind ptyp in + let tpat, env = bind_pat env pat ptyp in + annot_exp (E_let (LB_aux (LB_val (tpat, checked_bind), (let_loc, None)), crule check_exp env exp typ)) typ + | LB_val (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 (tpat, inferred_bind), (let_loc, None)), crule check_exp env exp typ)) typ + end + | E_app_infix (x, op, y), _ -> + 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 -> + Env.wf_constraint env nc; + 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 + | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) + | (errs, (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 (_, err) -> + typ_print ("Error : " ^ string_of_type_error err); + try_overload (errs @ [(f, err)], fs) + end + in + try_overload ([], Env.get_overloads f env) + | E_return exp, _ -> + let checked_exp = match Env.get_ret_typ env with + | Some ret_typ -> crule check_exp env exp ret_typ + | None -> typ_error l "Cannot use return outside a function" + in + annot_exp (E_return checked_exp) typ + | 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_throw exp, _ -> + let checked_exp = crule check_exp env exp exc_typ in + annot_exp_effect (E_throw checked_exp) typ (mk_effect [BE_escape]) + | E_internal_let (lexp, bind, exp), _ -> + let E_aux (E_assign (lexp, bind), _), env = bind_assignment env lexp bind in + let checked_exp = crule check_exp env exp typ in + annot_exp (E_internal_let (lexp, bind, checked_exp)) typ + | E_vector vec, _ -> + let (start, len, ord, vtyp) = destruct_vec_typ l env typ in + let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in + if prove env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ + else typ_error l "List length didn't match" (* FIXME: improve error message *) + | E_lit (L_aux (L_undef, _) as lit), _ -> + if is_typ_monomorphic typ || Env.polymorphic_undefineds env + then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef]) + else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction") + (* 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 arg_typ, _)]) + when string_of_id id = "register" && Env.is_register reg env -> + let rtyp = Env.get_register reg env in + subtyp l env rtyp arg_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_exp 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 switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let rec try_casts trigger errs = function + | [] -> typ_raise l (Err_no_casts (trigger, errs)) + | (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 (_, err) -> try_casts trigger (err :: errs) casts + end + in + begin + try + typ_debug ("PERFORMING TYPE COERCION: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ); + subtyp l env (typ_of annotated_exp) typ; switch_typ annotated_exp typ + with + | Type_error (_, trigger) when Env.allow_casts env -> + let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in + try_casts trigger [] casts + | Type_error (l, err) -> typ_error l "Subtype error" + 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 switch_typ (E_aux (exp, (l, Some (env, _, eff)))) typ = E_aux (exp, (l, Some (env, typ, eff))) in + let rec try_casts = function + | [] -> unify_error l "No valid casts resulted in unification" + | (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 (_, err) -> try_casts casts + | Unification_error (_, err) -> try_casts 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_pat pat ^ " to " ^ 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_var (pat, kid) -> + let typ = Env.expand_synonyms env typ in + begin + match destruct_exist env typ, typ with + | Some ([kid'], nc, ex_typ), _ -> + let env = Env.add_typ_var kid BK_nat env in + let ex_typ = typ_subst_nexp kid' (Nexp_var kid) ex_typ in + let env = Env.add_constraint (nc_subst_nexp kid' (Nexp_var kid) nc) env in + let typed_pat, env = bind_pat env pat ex_typ in + annot_pat (P_var (typed_pat, kid)) typ, env + | Some _, _ -> typ_error l ("Cannot bind type variable pattern against multiple argument existential") + | None, Typ_aux (Typ_id id, _) when Id.compare id (mk_id "int") == 0 -> + let env = Env.add_typ_var kid BK_nat env in + let typed_pat, env = bind_pat env pat (atom_typ (nvar kid)) in + annot_pat (P_var (typed_pat, kid)) typ, env + | None, Typ_aux (Typ_id id, _) when Id.compare id (mk_id "nat") == 0 -> + let env = Env.add_typ_var kid BK_nat env in + let env = Env.add_constraint (nc_gt (nvar kid) (nint 0)) env in + let typed_pat, env = bind_pat env pat (atom_typ (nvar kid)) in + annot_pat (P_var (typed_pat, kid)) typ, env + | None, Typ_aux (Typ_app (id, [Typ_arg_aux (Typ_arg_nexp lo, _); Typ_arg_aux (Typ_arg_nexp hi, _)]), _) + when Id.compare id (mk_id "range") == 0 -> + let env = Env.add_typ_var kid BK_nat env in + let env = Env.add_constraint (nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi)) env in + let typed_pat, env = bind_pat env pat (atom_typ (nvar kid)) in + annot_pat (P_var (typed_pat, kid)) typ, env + | None, _ -> typ_error l ("Cannot bind type variable against non existential or numeric type") + end + | P_wild -> annot_pat P_wild typ, env + | P_cons (hd_pat, tl_pat) -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (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 Env.expand_synonyms env typ with + | Typ_aux (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 " ^ string_of_pat pat ^ " against non-list type " ^ string_of_typ typ) + end + | P_tup [] -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" -> + annot_pat (P_tup []) typ, env + | _ -> typ_error l "Cannot match unit pattern against non-unit type" + end + | P_tup pats -> + begin + match Env.expand_synonyms env typ with + | Typ_aux (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, _, _ (* FIXME! *) = 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) + | P_as (pat, id) -> + let (typed_pat, env) = bind_pat env pat typ in + annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) env + | _ -> + 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) -> + Env.wf_typ env typ_annot; + 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 typed_pat, env = bind_pat env pat bit_typ in + pats @ [typed_pat], env + in + let ((typed_pat :: typed_pats) as pats), env = + List.fold_left fold_pats ([], env) (pat :: pats) in + let len = nexp_simp (nint (List.length pats)) in + let etyp = pat_typ_of typed_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) = destruct_vec_typ l env (pat_typ_of inferred_pat) in + let fold_len len pat = + let (_, len', _, vtyp') = destruct_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 + | P_as (pat, id) -> + let (typed_pat, env) = infer_pat env pat in + annot_pat (P_as (typed_pat, id)) (pat_typ_of typed_pat), Env.add_local id (Immutable, pat_typ_of typed_pat) 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, true + | Local (Mutable, typ) -> typ, LEXP_id v, false + | _ -> typ_error l "l-expression field is not a register or a local mutable type" + end + | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) -> + begin + (* Check: is this ok if the vector is immutable? *) + let is_immutable, vtyp, is_register = 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, false + | Local (Mutable, vtyp) -> false, vtyp, false + | Register vtyp -> false, vtyp, true + 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), is_register + end + in + let regtyp, inferred_flexp, is_register = 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_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_id regtyp_id, _)), _)]), _) + | Typ_aux (Typ_id regtyp_id, _) when Env.is_regtyp regtyp_id env -> + let eff = mk_effect [BE_wreg] in + 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) (nint 1) (mk_typ (Typ_id (mk_id "bit"))) + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> + dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) (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 + let checked_exp = crule check_exp env exp vec_typ in + annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, 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 eff = if is_register then mk_effect [BE_wreg] else no_effect in + let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let unifiers, _, _ (* FIXME *) = 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 eff, 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.add_local v (Mutable, typ_annot) 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 = Env.expand_synonyms env typ in + let (Typ_aux (typ_aux, _)) = typ in + match typ_aux with + | Typ_tup typs -> + let bind_tuple_lexp lexp typ (tlexps, env) = + let tlexp, env = bind_lexp env lexp typ in tlexp :: tlexps, env + in + let tlexps, env = + try List.fold_right2 bind_tuple_lexp lexps typs ([], env) with + | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length" + in + annot_lexp (LEXP_tup tlexps) typ, env + (* This case is pretty much just for the PSTATE.<N,Z,C,V> := vector pattern which is really common in ASL. *) + (* Maybe this code can be made not horrible? *) + | Typ_app (id, _) when Id.compare id (mk_id "vector") == 0 -> + begin + match destruct_vector env typ with + | Some (_, vec_len, _, _) -> + let bind_bits_tuple lexp (tlexps, env, llen) = + match lexp with + | LEXP_aux (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) + | Unbound -> + typ_error l "Unbound variable in vector tuple assignment" + | Local (Mutable, vtyp) | Register vtyp -> + let llen' = match destruct_vector env vtyp with + | Some (_, llen', _, _) -> llen' + | None -> typ_error l "Variables in vector tuple assignment must be vectors" + in + let tlexp, env = bind_lexp env lexp vtyp in + tlexp :: tlexps, env, nsum llen llen' + end + | LEXP_aux (LEXP_field (LEXP_aux (LEXP_id v, _), fid), _) -> + (* FIXME: will only work for ASL *) + let rec_id = + match Env.lookup_id v env with + | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id + | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") + in + let typq, (Typ_aux (Typ_fn (_, vtyp, _), _)) = Env.get_accessor rec_id fid env in + let llen' = match destruct_vector env vtyp with + | Some (_, llen', _, _) -> llen' + | None -> typ_error l "Variables in vector tuple assignment must be vectors" + in + let tlexp, env = bind_lexp env lexp vtyp in + tlexp :: tlexps, env, nsum llen llen' + | _ -> typ_error l "bit vector assignment must only contain identifiers" + in + let tlexps, env, lexp_len = List.fold_right bind_bits_tuple lexps ([], env, nint 0) in + if prove env (nc_eq vec_len lexp_len) + then annot_lexp (LEXP_tup tlexps) typ, env + else typ_error l "Vector and tuple length must be the same in assignment" + | None -> typ_error l ("Malformed vector type " ^ string_of_typ typ) + end + | _ -> typ_error l ("Cannot bind tuple l-expression against non tuple or vector type " ^ string_of_typ typ) + 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, 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_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 && is_register -> + subtyp l env typ (typ_of access); + 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 + | LEXP_field (LEXP_aux (LEXP_id v, _), fid) -> + (* FIXME: will only work for ASL *) + let rec_id = + match Env.lookup_id v env with + | Register (Typ_aux (Typ_id rec_id, _)) -> rec_id + | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here") + in + let typq, (Typ_aux (Typ_fn (_, ret_typ, _), _)) = Env.get_accessor rec_id fid env in + annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ (mk_effect [BE_wreg]), env + | _ -> typ_error l ("Unhandled l-expression " ^ string_of_lexp lexp) + +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 -> + Env.wf_constraint env nc; + annot_exp (E_constraint nc) bool_typ + | 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_app (Id_aux (Id "register", _), [Typ_arg_aux (Typ_arg_typ ((Typ_aux (Typ_id regtyp, _) as regtyp_aux)), _)]), _) + | (Typ_aux (Typ_id regtyp, _) as regtyp_aux) 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 + let checked_exp = crule check_exp env (strip_exp inferred_exp) regtyp_aux 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) (nint 1) bit_typ in + annot_exp (E_field (checked_exp, field)) vec_typ + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_dec, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int n m) unit_big_int)) bit_typ in + annot_exp (E_field (checked_exp, field)) vec_typ + | BF_aux (BF_single n, _), Ord_aux (Ord_inc, _) -> + let vec_typ = dvector_typ env (nconstant n) (nint 1) bit_typ in + annot_exp (E_field (checked_exp, field)) vec_typ + | BF_aux (BF_range (n, m), _), Ord_aux (Ord_inc, _) -> + let vec_typ = dvector_typ env (nconstant n) (nconstant (add_big_int (sub_big_int m n) unit_big_int)) bit_typ in + annot_exp (E_field (checked_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 rectyp 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_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, ()))) -> + let inferred_exp = irule infer_exp env exp in + let typ = typ_of inferred_exp in + let rectyp_id = match Env.expand_synonyms env typ with + | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env -> + rectyp_id + | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record") + in + let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) = + let (typq, Typ_aux (Typ_fn (rectyp_q, field_typ, _), _)) = Env.get_accessor rectyp_id field env in + let unifiers, _, _ (* FIXME *) = try unify l env rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in + let field_typ' = subst_unifiers unifiers field_typ in + let inferred_exp = crule check_exp env exp field_typ' in + FE_aux (FE_Fexp (field, inferred_exp), (l, None)) + in + annot_exp (E_record_update (inferred_exp, FES_aux (FES_Fexps (List.map check_fexp fexps, flag), (l, None)))) typ + | 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) -> 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 + | (errs, []) -> typ_raise l (Err_no_overloading (f, errs)) + | (errs, (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 (_, err) -> + typ_print ("Error : " ^ string_of_type_error err); + try_overload (errs @ [(f, err)], fs) + end + in + try_overload ([], Env.get_overloads f env) + | E_app (f, xs) -> infer_funapp l env f xs None + | E_loop (loop_type, cond, body) -> + let checked_cond = crule check_exp env cond bool_typ in + let checked_body = crule check_exp env body unit_typ in + annot_exp (E_loop (loop_type, checked_cond, checked_body)) unit_typ + | E_for (v, f, t, step, ord, body) -> + begin + let f, t, is_dec = match ord with + | Ord_aux (Ord_inc, _) -> f, t, false + | Ord_aux (Ord_dec, _) -> t, f, true (* reverse direction to typechecking downto as upto 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 loop_vtyp = exist_typ (fun e -> nc_and (nc_lteq l1 (nvar e)) (nc_lteq (nvar e) u2)) (fun e -> atom_typ (nvar e)) in + let checked_body = crule check_exp (Env.add_local v (Immutable, loop_vtyp) env) body unit_typ in + annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ *) + | Some (l1, l2), Some (u1, u2) when prove env (nc_lteq l2 u1) -> + let kid = mk_kid ("loop_" ^ string_of_id v) in + if KBindings.mem kid (Env.get_typ_vars env) + then typ_error l "Nested loop variables cannot have the same name" + else + begin + let env = Env.add_typ_var kid BK_nat env in + let env = Env.add_constraint (nc_and (nc_lteq l1 (nvar kid)) (nc_lteq (nvar kid) u2)) env in + let loop_vtyp = atom_typ (nvar kid) in + let checked_body = crule check_exp (Env.add_local v (Immutable, loop_vtyp) env) body unit_typ in + if not is_dec (* undo reverse direction in annoteded ast for downto loop *) + then annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ + else annot_exp (E_for (v, inferred_t, inferred_f, checked_step, ord, checked_body)) unit_typ + end + | _, _ -> 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_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ()))) + | E_vector_update_subrange (v, n, m, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update_subrange", [v; n; m; exp]), (l, ()))) + | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "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 (nint 0)); + mk_typ_arg (Typ_arg_nexp (nint (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 (nint (List.length vec - 1))); + mk_typ_arg (Typ_arg_nexp (nint (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_effect (E_assert (checked_test, checked_msg)) unit_typ (mk_effect [BE_escape]) + | _ -> 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 switch_annot env typ (E_aux (exp, (l, Some (_, _, eff)))) = E_aux (exp, (l, Some (env, typ, eff))) in + let all_unifiers = ref KBindings.empty in + let ex_goal = ref None in + let prove_goal env = match !ex_goal with + | Some goal when prove env goal -> () + | Some goal -> typ_error l ("Could not prove existential goal: " ^ string_of_n_constraint goal) + | None -> () + in + let universals = Env.get_typ_vars env in + let universal_constraints = Env.get_constraints env in + let is_bound kid env = KBindings.mem kid (Env.get_typ_vars env) in + let rec number n = function + | [] -> [] + | (x :: xs) -> (n, x) :: number (n + 1) xs + in + let solve_quant env = function + | QI_aux (QI_id _, _) -> false + | QI_aux (QI_const nc, _) -> prove env nc + in + let rec instantiate env 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 env) quants + then + let iuargs = List.map2 (fun utyp (n, uarg) -> (n, crule check_exp env uarg utyp)) utyps uargs in + (iuargs, ret_typ, env) + else typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants + ^ " not resolved during application of " ^ string_of_id f ^ " unresolved args: " ^ string_of_list ", " (fun (_, exp) -> string_of_exp exp) uargs) + end + | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) + when List.for_all (fun kid -> is_bound kid env) (KidSet.elements (typ_frees typ)) -> + begin + let carg = crule check_exp env arg typ in + let (iargs, ret_typ', env) = instantiate env quants (utyps, typs) ret_typ (uargs, args) in + ((n, carg) :: iargs, ret_typ', env) + end + | (utyps, (typ :: typs)), (uargs, ((n, arg) :: args)) -> + begin + typ_debug ("INSTANTIATE: " ^ string_of_exp arg ^ " with " ^ string_of_typ typ); + let iarg = irule infer_exp env arg in + typ_debug ("INFER: " ^ string_of_exp arg ^ " type " ^ string_of_typ (typ_of iarg)); + try + (* If we get an existential when instantiating, we prepend + the identifier of the exisitential with the tag argN# to + denote that it was bound by the Nth argument to the + function. *) + let ex_tag = "arg" ^ string_of_int n ^ "#" in + let iarg, (unifiers, ex_kids, ex_nc) = 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)); + typ_debug ("EX KIDS: " ^ string_of_list ", " string_of_kid ex_kids); + let env = match ex_kids, ex_nc with + | [], None -> env + | _, Some enc -> + let enc = List.fold_left (fun nc kid -> nc_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) nc) enc ex_kids in + let env = List.fold_left (fun env kid -> Env.add_typ_var (prepend_kid ex_tag kid) BK_nat env) env ex_kids in + Env.add_constraint enc env + in + let tag_unifier uvar = List.fold_left (fun uvar kid -> uvar_subst_nexp kid (Nexp_var (prepend_kid ex_tag kid)) uvar) uvar ex_kids in + let unifiers = KBindings.map tag_unifier unifiers in + 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'', env) = instantiate env quants' (utyps', typs') ret_typ' (uargs, args) in + ((n, iarg) :: iargs, ret_typ'', env) + with + | Unification_error (l, str) -> + typ_print ("Unification error: " ^ str); + instantiate env 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 env quants typs ret_typ = + match ret_ctx_typ with + | None -> (quants, typs, ret_typ, env) + | Some rct when is_exist (Env.expand_synonyms env rct) -> (quants, typs, ret_typ, env) + | Some rct -> + begin + typ_debug ("RCT is " ^ string_of_typ rct); + typ_debug ("INSTANTIATE RETURN:" ^ string_of_typ ret_typ); + let unifiers, ex_kids, ex_nc = + try unify l env ret_typ rct with + | Unification_error _ -> typ_debug "UERROR"; KBindings.empty, [], None + in + typ_debug (string_of_list ", " (fun (kid, uvar) -> string_of_kid kid ^ " => " ^ string_of_uvar uvar) (KBindings.bindings unifiers)); + if ex_kids = [] then () else (typ_debug ("EX GOAL: " ^ string_of_option string_of_n_constraint ex_nc); ex_goal := ex_nc); + all_unifiers := merge_uvars l !all_unifiers unifiers; + let env = List.fold_left (fun env kid -> Env.add_typ_var kid BK_nat env) env ex_kids 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' = + match ex_nc with + | None -> subst_unifiers unifiers ret_typ + | Some nc -> mk_typ (Typ_exist (ex_kids, nc, subst_unifiers unifiers ret_typ)) + in + (quants', typs', ret_typ', env) + end + in + let (quants, typ_args, typ_ret, env), eff = + match Env.expand_synonyms env f_typ with + | Typ_aux (Typ_fn (Typ_aux (Typ_tup typ_args, _), typ_ret, eff), _) -> + instantiate_ret env (quant_items typq) typ_args typ_ret, eff + | Typ_aux (Typ_fn (typ_arg, typ_ret, eff), _) -> + instantiate_ret env (quant_items typq) [typ_arg] typ_ret, eff + | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type") + in + let (xs_instantiated, typ_ret, env) = instantiate env 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 + + prove_goal env; + + let ty_vars = List.map fst (KBindings.bindings (Env.get_typ_vars env)) in + let existentials = List.filter (fun kid -> not (KBindings.mem kid universals)) ty_vars in + let num_new_ncs = List.length (Env.get_constraints env) - List.length universal_constraints in + let ex_constraints = take num_new_ncs (Env.get_constraints env) in + + typ_debug ("Existentials: " ^ string_of_list ", " string_of_kid existentials); + typ_debug ("Existential constraints: " ^ string_of_list ", " string_of_n_constraint ex_constraints); + + let typ_ret = + if KidSet.is_empty (KidSet.of_list existentials) || KidSet.is_empty (typ_frees typ_ret) + then (typ_debug "Returning Existential"; typ_ret) + else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, typ_ret)) + in + let typ_ret = simp_typ typ_ret in + let exp = annot_exp (E_app (f, xs_reordered)) typ_ret eff in + typ_debug ("RETURNING: " ^ string_of_typ (typ_of exp)); + match ret_ctx_typ with + | None -> + exp, !all_unifiers + | Some rct -> + let exp = type_coercion env exp rct in + typ_debug ("RETURNING AFTER COERCION " ^ string_of_typ (typ_of exp)); + exp, !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_annot annot eff = match annot with + | Some (env, typ, eff') -> Some (env, typ, union_effects eff eff') + | None -> None + +let add_effect (E_aux (exp, (l, annot))) eff = + E_aux (exp, (l, add_effect_annot annot eff)) + +let effect_of_lexp (LEXP_aux (exp, (l, annot))) = effect_of_annot annot + +let add_effect_lexp (LEXP_aux (lexp, (l, annot))) eff = + LEXP_aux (lexp, (l, add_effect_annot annot eff)) + +let effect_of_pat (P_aux (exp, (l, annot))) = effect_of_annot annot + +let add_effect_pat (P_aux (pat, (l, annot))) eff = + P_aux (pat, (l, add_effect_annot annot eff)) + +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_vector_access (v, i) -> + let p_v = propagate_exp_effect v in + let p_i = propagate_exp_effect i in + E_vector_access (p_v, p_i), collect_effects [p_v; p_i] + | E_vector_subrange (v, i, j) -> + let p_v = propagate_exp_effect v in + let p_i = propagate_exp_effect i in + let p_j = propagate_exp_effect j in + E_vector_subrange (p_v, p_i, p_j), collect_effects [p_v; p_i; p_j] + | E_vector_update (v, i, x) -> + let p_v = propagate_exp_effect v in + let p_i = propagate_exp_effect i in + let p_x = propagate_exp_effect x in + E_vector_update (p_v, p_i, p_x), collect_effects [p_v; p_i; p_x] + | E_vector_update_subrange (v, i, j, v') -> + let p_v = propagate_exp_effect v in + let p_i = propagate_exp_effect i in + let p_j = propagate_exp_effect j in + let p_v' = propagate_exp_effect v' in + E_vector_update_subrange (p_v, p_i, p_j, p_v'), collect_effects [p_v; p_i; p_j; p_v'] + | E_vector_append (v1, v2) -> + let p_v1 = propagate_exp_effect v1 in + let p_v2 = propagate_exp_effect v2 in + E_vector_append (p_v1, p_v2), collect_effects [p_v1; p_v2] + | 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_record_update (exp, FES_aux (FES_Fexps (fexps, flag), (l, _))) -> + let p_exp = propagate_exp_effect exp in + let p_fexps = List.map propagate_fexp_effect fexps in + E_record_update (p_exp, FES_aux (FES_Fexps (List.map fst p_fexps, flag), (l, None))), + List.fold_left union_effects no_effect (effect_of p_exp :: List.map snd p_fexps) + | E_record (FES_aux (FES_Fexps (fexps, flag), (l, _))) -> + let p_fexps = List.map propagate_fexp_effect fexps in + E_record (FES_aux (FES_Fexps (List.map fst p_fexps, flag), (l, None))), + List.fold_left union_effects no_effect (List.map snd p_fexps) + | E_try (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_try (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_loop (loop_type, cond, body) -> + let p_cond = propagate_exp_effect cond in + let p_body = propagate_exp_effect body in + E_loop (loop_type, p_cond, p_body), + union_effects (effect_of p_cond) (effect_of 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_cons (x, xs) -> + let p_x = propagate_exp_effect x in + let p_xs = propagate_exp_effect xs in + E_cons (p_x, p_xs), union_effects (effect_of p_x) (effect_of p_xs) + | E_list xs -> + let p_xs = List.map propagate_exp_effect xs in + E_list p_xs, collect_effects p_xs + | 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_internal_let (lexp, bind, exp) -> + let p_lexp = propagate_lexp_effect lexp in + let p_bind = propagate_exp_effect bind in + let p_exp = propagate_exp_effect exp in + E_internal_let (p_lexp, p_bind, p_exp), union_effects (effect_of_lexp p_lexp) (collect_effects [p_bind; p_exp]) + | 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_throw exp -> + let p_exp = propagate_exp_effect exp in + E_throw 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 + | E_internal_let (lexp, exp, body) -> + let p_lexp = propagate_lexp_effect lexp in + let p_exp = propagate_exp_effect exp in + let p_body = propagate_exp_effect body in + E_internal_let (p_lexp, p_exp, p_body), + union_effects (effect_of_lexp p_lexp) (collect_effects [p_exp; p_body]) + | E_internal_plet (pat, exp, body) -> + let p_pat = propagate_pat_effect pat in + let p_exp = propagate_exp_effect exp in + let p_body = propagate_exp_effect body in + E_internal_plet (p_pat, p_exp, p_body), + union_effects (effect_of_pat p_pat) (collect_effects [p_exp; p_body]) + | E_internal_return exp -> + let p_exp = propagate_exp_effect exp in + E_internal_return p_exp, 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_fexp_effect (FE_aux (FE_Fexp (id, exp), (l, _))) = + let p_exp = propagate_exp_effect exp in + FE_aux (FE_Fexp (id, p_exp), (l, None)), effect_of p_exp + +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_var (pat, kid) -> + let p_pat = propagate_pat_effect pat in + P_var (p_pat, kid), effect_of_pat p_pat + | 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 (pat, exp) -> + let p_pat = propagate_pat_effect pat in + let p_exp = propagate_exp_effect exp in + LB_val (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 (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 (P_aux (P_typ (typ_annot, tpat), (l, Some (env, typ_annot, no_effect))), checked_bind), (l, None)))], env + | LB_val (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 (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 + (* We want to forbid polymorphic undefined values in all cases, + except when type checking the specific undefined_(type) + functions created by the -undefined_gen functions in + initial_check.ml. Only in these functions will the rewriter + be able to correctly re-write the polymorphic undefineds + (due to the specific form the functions have *) + let env = + if Str.string_match (Str.regexp_string "undefined_") (string_of_id id) 0 + then Env.allow_polymorphic_undefineds env + else 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, (fun _ -> None), false), (Parse_ast.Unknown, None))) + +let check_tannotopt env 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 env 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 = + 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 typ_error 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 -> typ_error l "funcl list is empty" + 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 + check_tannotopt env 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, ext_opt, is_cast) -> + let env = match ext_opt "smt" with Some op -> Env.add_smt_op id op env | None -> env in + Env.wf_typ (add_typquant quants env) typ; + let env = + (* match ext_opt with + | None -> env + | Some ext -> *) + Env.add_extern id ext_opt env + in + let env = if is_cast then Env.add_cast id env else env in + (id, quants, typ, env) + in + [DEF_spec (VS_aux (vs, (l, None)))], Env.add_val_spec id (quants, Env.expand_synonyms env typ) env + +let check_default env (DT_aux (ds, l)) = 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)) + | 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 (add_big_int (sub_big_int basec topc) unit_big_int)) 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) -> + let typ' = mk_typ (Typ_fn (typ, ret_typ, no_effect)) in + env + |> Env.add_union_id v (typq, typ') + |> Env.add_val_spec v (typq, typ') + +(* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) +let mk_synonym typq typ = + let kopts, ncs = quant_split typq in + let rec subst_args kopts args = + match kopts, args with + | kopt :: kopts, Typ_arg_aux (Typ_arg_nexp arg, _) :: args when is_nat_kopt kopt -> + let typ, ncs = subst_args kopts args in + typ_subst_nexp (kopt_kid kopt) (unaux_nexp arg) typ, + List.map (nc_subst_nexp (kopt_kid kopt) (unaux_nexp arg)) ncs + | kopt :: kopts, Typ_arg_aux (Typ_arg_typ arg, _) :: args when is_typ_kopt kopt -> + let typ, ncs = subst_args kopts args in + typ_subst_typ (kopt_kid kopt) (unaux_typ arg) typ, ncs + | kopt :: kopts, Typ_arg_aux (Typ_arg_order arg, _) :: args when is_order_kopt kopt -> + let typ, ncs = subst_args kopts args in + typ_subst_order (kopt_kid kopt) (unaux_order arg) typ, ncs + | [], [] -> typ, ncs + | _, Typ_arg_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments" + | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments" 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 + fun env args -> + let typ, ncs = subst_args kopts args in + if List.for_all (prove env) ncs + then typ + else typ_error Parse_ast.Unknown "Could not prove constraints in type synonym" + +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 (mk_synonym typq 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 check_kinddef env (KD_aux (kdef, (l, _))) = + let kd_err () = raise (Reporting_basic.err_unreachable Parse_ast.Unknown "Unimplemented kind def") in + match kdef with + | KD_nabbrev ((K_aux(K_kind([BK_aux (BK_nat, _)]),_) as kind), id, nmscm, nexp) -> + [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))], + Env.add_num_def id nexp env + | _ -> kd_err () + +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 -> check_kinddef env kdef + | DEF_type tdef -> check_typedef env tdef + | DEF_fixity (prec, n, op) -> [DEF_fixity (prec, n, op)], env + | 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, _))) -> + let env = Env.add_register id typ env in + [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, Some (env, typ, no_effect))))], 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 + +let check env defs = + try check' env defs with + | Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) + +let initial_env = + Env.empty + |> Env.add_prover prove + (* |> Env.add_typ_synonym (mk_id "atom") (fun _ args -> mk_typ (Typ_app (mk_id "range", args @ args))) *) + (* Internal functions for Monomorphise.AtomToItself *) -(*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 + |> Env.add_extern (mk_id "size_itself_int") (fun _ -> Some "size_itself_int") + |> Env.add_val_spec (mk_id "size_itself_int") + (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), + Parse_ast.Unknown)],Parse_ast.Unknown), + function_typ (app_typ (mk_id "itself") [mk_typ_arg (Typ_arg_nexp (nvar (mk_kid "n")))]) + (atom_typ (nvar (mk_kid "n"))) no_effect) + |> Env.add_extern (mk_id "make_the_value") (fun _ -> Some "make_the_value") + |> Env.add_val_spec (mk_id "make_the_value") + (TypQ_aux (TypQ_tq [QI_aux (QI_id (KOpt_aux (KOpt_none (mk_kid "n"),Parse_ast.Unknown)), + Parse_ast.Unknown)],Parse_ast.Unknown), + function_typ (atom_typ (nvar (mk_kid "n"))) + (app_typ (mk_id "itself") [mk_typ_arg (Typ_arg_nexp (nvar (mk_kid "n")))]) no_effect) diff --git a/src/type_check.mli b/src/type_check.mli index 4f78dd03..355740dc 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,224 @@ (**************************************************************************) open Ast -open Type_internal -type kind = Type_internal.kind -type typ = Type_internal.t -type 'a emap = 'a Envmap.t +open Ast_util +open Big_int -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 +type type_error = + | Err_no_casts of type_error * type_error list + | Err_no_overloading of id * (id * type_error) list + | Err_unresolved_quants of id * quant_item list + | Err_subtype of typ * typ * n_constraint list + | Err_no_num_ident of id + | Err_other of string -val check : envs -> tannot defs -> tannot defs * envs -val typ_to_t : envs -> bool -> bool -> Ast.typ -> t +exception Type_error of l * type_error;; + +val string_of_type_error : type_error -> string + +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 update_val_spec : id -> typquant * typ -> t -> t + + val get_register : id -> t -> typ + + val get_regtyp : id -> t -> big_int * big_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 + + val get_locals : t -> (mut * typ) Bindings.t + + (* 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 add_typ_var : kid -> base_kind_aux -> t -> t + + val is_record : id -> t -> bool + + val get_accessor : id -> 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 -> (t -> typ_arg list -> typ) + + val get_overloads : id -> t -> id list + + val get_num_def : id -> t -> nexp + + val is_extern : id -> t -> string -> bool + + val get_extern : id -> t -> string -> string + + (* 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 + + val is_union_constructor : id -> t -> bool + + (* Return a fresh kind identifier that doesn't exist in the + environment. The optional argument bases the new identifer on the + old one. *) + val fresh_kid : ?kid: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 + +(* Push all the type variables and constraints from a typquant into an environment *) +val add_typquant : typquant -> Env.t -> Env.t + +(* When the typechecker creates new type variables it gives them fresh + names of the form 'fvXXX#name, where XXX is a number (not + necessarily three digits), and name is the original name when the + type variable was created by renaming an exisiting type variable to + avoid shadowing. orig_kid takes such a type variable and strips out + the 'fvXXX# part. It returns the type variable unmodified if it is + not of this form. *) +val orig_kid : kid -> kid + +(* 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 + +val exist_typ : (kid -> n_constraint) -> (kid -> 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 +val strip_lexp : 'a lexp -> unit lexp + +(* 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 + +val infer_exp : Env.t -> unit exp -> tannot exp + +val prove : Env.t -> n_constraint -> bool + +val subtype_check : Env.t -> typ -> typ -> bool + +(* 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 pat_typ_of : tannot pat -> typ +val pat_env_of : tannot pat -> Env.t + +val effect_of : tannot exp -> effect +val effect_of_annot : tannot -> effect +val add_effect_annot : tannot -> effect -> tannot + +val destruct_atom_nexp : Env.t -> typ -> nexp option + +(* Safely destructure an existential type. Returns None if the type is + not existential. This function will pick a fresh name for the + existential to ensure that no name-clashes occur. *) +val destruct_exist : Env.t -> typ -> (kid list * n_constraint * typ) option + +val destruct_vector : Env.t -> typ -> (nexp * nexp * order * typ) option + +type uvar = + | U_nexp of nexp + | U_order of order + | U_effect of effect + | U_typ of typ + +val string_of_uvar : uvar -> string + +val unify : l -> Env.t -> typ -> typ -> uvar KBindings.t * kid list * n_constraint option + +val alpha_equivalent : Env.t -> typ -> typ -> bool + +(* 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 +val propagate_pexp_effect : tannot pexp -> tannot pexp * effect + +(* 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 + +(* Like check but throws type_errors rather than Sail generic errors + from Reporting_basic. *) +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 ddf0b692..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_string "2147483648"))) ; - TA_nexp (mk_c (big_int_of_string "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..4f7878c7 100644 --- a/src/util.ml +++ b/src/util.ml @@ -86,6 +86,15 @@ (* IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (**************************************************************************) +let rec last = function + | [x] -> x + | _ :: xs -> last xs + | [] -> raise (Failure "last") + +let rec butlast = function + | [x] -> [] + | x :: xs -> x :: butlast xs + | [] -> [] module Duplicate(S : Set.S) = struct @@ -144,7 +153,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 +212,15 @@ let option_bind f = function | None -> None | Some(o) -> f o +let rec option_binop f x y = match x, y with + | Some x, Some y -> Some (f x y) + | _ -> None + +let rec option_these = function + | Some x :: xs -> x :: option_these xs + | None :: xs -> option_these xs + | [] -> [] + let changed2 f g x h y = match (g x, h y) with | (None,None) -> None @@ -240,6 +265,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 @@ -325,3 +356,17 @@ 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) +let string_of_option string_of = function + | None -> "" + | Some x -> string_of x + +let is_some = function + | Some _ -> true + | None -> false + +let is_none opt = not (is_some opt) + +let rec take n xs = match n, xs with + | 0, _ -> [] + | n, [] -> [] + | n, (x :: xs) -> x :: take (n - 1) xs diff --git a/src/util.mli b/src/util.mli index c565cdce..38af1fc2 100644 --- a/src/util.mli +++ b/src/util.mli @@ -40,6 +40,11 @@ (* SUCH DAMAGE. *) (**************************************************************************) +(* Last element of a list *) +val last : 'a list -> 'a + +val butlast : 'a list -> 'a list + (** Mixed useful things *) module Duplicate(S : Set.S) : sig type dups = @@ -77,10 +82,18 @@ 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 (Some x) (Some y)] returns [Some (f x y)], + and in all other cases, [option_binop] returns [None]. *) +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 +(** [option_these xs] extracts the elements of the list [xs] + wrapped in [Some]. *) +val option_these : 'a option list -> 'a list + (** [changed2 f g x h y] applies [g] to [x] and [h] to [y]. If both function applications return [None], then [None] is returned. Otherwise [f] is applied to the results. For this @@ -145,6 +158,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 +211,12 @@ module ExtraSet : functor (S : Set.S) -> (*Formatting functions*) val string_of_list : string -> ('a -> string) -> 'a list -> string + +val string_of_option : ('a -> string) -> 'a option -> string + +val split_on_char : char -> string -> string list + +val is_some : 'a option -> bool +val is_none : 'a option -> bool + +val take : int -> 'a list -> 'a list |
