From 703e996e44d0c1773fb23cd554b896318fae081b Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 7 Mar 2019 20:22:03 +0000 Subject: C: Refactor C backend Main change is splitting apart the Sail->IR compilation stage and the C code generation and optimization phase. Rather than variously calling the intermediate language either bytecode (when it's not really) or simply IR, we give it a name: Jib (a type of Sail). Most of the types are still prefixed by c/C, and I don't think it's worth changing this. The various parts of the C backend are now in the src/jib/ subdirectory src/jib/anf.ml - Sail->ANF translation src/jib/jib_util.ml - various Jib AST processing and helper functions (formerly bytecode_util) src/jib/jib_compile.ml - Sail->Jib translation (using Sail->ANF) src/jib/c_backend.ml - Jib->C code generator and optimizations Further, bytecode.ott is now jib.ott and generates jib.ml (which still lives in src/ for now) The optimizations in c_backend.ml should eventually be moved in a separate jib_optimization file. The Sail->Jib compilation can be parameterised by two functions - one is a custom ANF->ANF optimization pass that can be specified on a per Jib backend basis, and the other is the rule for translating Sail types in Jib types. This can be more or less precise depending on how precise we want to be about bit-widths etc, i.e. we only care about <64 and >64 for C, but for SMT generation we would want to be as precise as possible. Additional improvements: The Jib IR is now agnostic about whether arguments are allocated on the heap vs the stack and this is handled by the C code generator. jib.ott now has some more comments explaining various parts of the Jib AST. A Set module and comparison function for ctyps is defined, and some functions now return ctyp sets rather than lists to avoid repeated work. --- language/bytecode.ott | 172 -- language/jib.ott | 223 +++ src/Makefile | 24 +- src/_tags | 1 + src/anf.ml | 717 --------- src/anf.mli | 125 -- src/bytecode_interpreter.ml | 162 -- src/bytecode_util.ml | 771 --------- src/c_backend.ml | 3715 ------------------------------------------- src/c_backend.mli | 141 -- src/isail.ml | 49 +- src/jib/anf.ml | 717 +++++++++ src/jib/anf.mli | 125 ++ src/jib/c_backend.ml | 2420 ++++++++++++++++++++++++++++ src/jib/c_backend.mli | 118 ++ src/jib/jib_compile.ml | 1367 ++++++++++++++++ src/jib/jib_compile.mli | 87 + src/jib/jib_util.ml | 935 +++++++++++ src/sail.ml | 16 +- 19 files changed, 6015 insertions(+), 5870 deletions(-) delete mode 100644 language/bytecode.ott create mode 100644 language/jib.ott delete mode 100644 src/anf.ml delete mode 100644 src/anf.mli delete mode 100644 src/bytecode_interpreter.ml delete mode 100644 src/bytecode_util.ml delete mode 100644 src/c_backend.ml delete mode 100644 src/c_backend.mli create mode 100644 src/jib/anf.ml create mode 100644 src/jib/anf.mli create mode 100644 src/jib/c_backend.ml create mode 100644 src/jib/c_backend.mli create mode 100644 src/jib/jib_compile.ml create mode 100644 src/jib/jib_compile.mli create mode 100644 src/jib/jib_util.ml diff --git a/language/bytecode.ott b/language/bytecode.ott deleted file mode 100644 index cc329e02..00000000 --- a/language/bytecode.ott +++ /dev/null @@ -1,172 +0,0 @@ -indexvar n , m , i , j ::= - {{ phantom }} - {{ com Index variables for meta-lists }} - -metavar nat ::= - {{ phantom }} - {{ ocaml int }} - {{ lem nat }} - -metavar id ::= - {{ phantom }} - {{ ocaml id }} - {{ lem id }} - -metavar mid ::= - {{ phantom }} - {{ ocaml id option }} - {{ lem maybe id }} - -metavar string ::= - {{ phantom }} - {{ ocaml string }} - {{ lem string }} - -metavar op ::= - {{ phantom }} - {{ ocaml string }} - {{ lem string }} - -metavar bool ::= - {{ phantom }} - {{ ocaml bool }} - {{ lem bool }} - -metavar value ::= - {{ phantom }} - {{ lem vl }} - {{ ocaml vl }} - -embed -{{ lem - -open import Ast -open import Value2 - -}} - -grammar - -% Fragments are small pure snippets of (abstract) C code, mostly -% expressions, used by the aval and cval types. -fragment :: 'F_' ::= - | id :: :: id - | '&' id :: :: ref - | value :: :: lit - | have_exception :: :: have_exception - | current_exception :: :: current_exception - | fragment op fragment' :: :: op - | op fragment :: :: unary - | string ( fragment0 , ... , fragmentn ) :: :: call - | fragment . string :: :: field - | string :: :: raw - | poly fragment :: :: poly - -% init / clear -> create / kill - -ctyp :: 'CT_' ::= - {{ com C type }} - | mpz_t :: :: lint -% Arbitrary precision GMP integer, mpz_t in C. - | bv_t ( bool ) :: :: lbits -% Variable length bitvector - flag represents direction, true - dec or false - inc - | sbv_t ( bool ) :: :: sbits -% Small variable length bitvector - less than 64 bits - | 'uint64_t' ( nat , bool ) :: :: fbits -% Fixed length bitvector that fits within a 64-bit word. - int -% represents length, and flag is the same as CT_bv. - | 'int64_t' nat :: :: fint -% Used for (signed) integers that fit within 64-bits. - | unit_t :: :: unit -% unit is a value in sail, so we represent it as a one element type -% here too for clarity but we actually compile it to an int which is -% always 0. - | bool_t :: :: bool - | real_t :: :: real - | bit_t :: :: bit -% The real type in sail. Abstract here, but implemented using either -% GMP rationals or high-precision floating point. - | ( ctyp0 , ... , ctypn ) :: :: tup - | string_t :: :: string - | enum id ( id0 , ... , idn ) :: :: enum - | struct id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: struct - | variant id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: variant -% Abstractly represent how all the Sail user defined types get mapped -% into C. We don't fully worry about precise implementation details at -% this point, as C doesn't have variants or tuples natively, but these -% need to be encoded. - | vector ( bool , ctyp ) :: :: vector - | list ( ctyp ) :: :: list -% A vector type for non-bit vectors, and a list type. - | ref ( ctyp ) :: :: ref - | poly :: :: poly - -cval :: 'CV_' ::= - {{ ocaml fragment * ctyp }} - {{ lem fragment * ctyp }} - -clexp :: 'CL_' ::= - | id : ctyp :: :: id - | clexp . string :: :: field - | * clexp :: :: addr - | clexp . nat :: :: tuple - | current_exception : ctyp :: :: current_exception - | have_exception :: :: have_exception - -ctype_def :: 'CTD_' ::= - {{ com C type definition }} - | enum id = id0 '|' ... '|' idn :: :: enum - | struct id = { id0 : ctyp0 , ... , idn : ctypn } :: :: struct - | variant id = { id0 : ctyp0 , ... , idn : ctypn } :: :: variant - -iannot :: 'IA_' ::= - {{ lem nat * nat * nat }} - {{ ocaml int * int * int }} - -instr :: 'I_' ::= - {{ aux _ iannot }} - | ctyp id :: :: decl - | ctyp id = cval :: :: init - | if ( cval ) { instr0 ; ... ; instrn } - else { instr0 ; ... ; instrm } : ctyp :: :: if - | jump ( cval ) string :: :: jump - | clexp = bool id ( cval0 , ... , cvaln ) :: :: funcall - | clexp = cval :: :: copy - | alias clexp = cval :: :: alias - | clear ctyp id :: :: clear - | return cval :: :: return - | { instr0 ; ... ; instrn } :: :: block - | try { instr0 ; ... ; instrn } :: :: try_block - | throw cval :: :: throw - | '//' string :: :: comment - | C string :: :: raw % only used for GCC attributes - | string : :: :: label - | goto string :: :: goto - | undefined ctyp :: :: undefined - | match_failure :: :: match_failure - -% For optimising away allocations. - | reset ctyp id :: :: reset - | ctyp id = cval :: :: reinit - -cdef :: 'CDEF_' ::= - | register id : ctyp = { - instr0 ; ... ; instrn - } :: :: reg_dec - | ctype_def :: :: type - | let nat ( id0 : ctyp0 , ... , idn : ctypn ) = { - instr0 ; ... ; instrm - } :: :: let -% The first list of instructions creates up the global letbinding, the -% second kills it. - | val id ( ctyp0 , ... , ctypn ) -> ctyp - :: :: spec - | function id mid ( id0 , ... , idn ) { - instr0 ; ... ; instrm - } :: :: fundef - | startup id { - instr0 ; ... ; instrn - } :: :: startup - | finish id { - instr0 ; ... ; instrn - } :: :: finish diff --git a/language/jib.ott b/language/jib.ott new file mode 100644 index 00000000..7b5d0162 --- /dev/null +++ b/language/jib.ott @@ -0,0 +1,223 @@ +indexvar n , m , i , j ::= + {{ phantom }} + {{ com Index variables for meta-lists }} + +metavar nat ::= + {{ phantom }} + {{ ocaml int }} + {{ lem nat }} + +metavar id ::= + {{ phantom }} + {{ ocaml id }} + {{ lem id }} + +metavar mid ::= + {{ phantom }} + {{ ocaml id option }} + {{ lem maybe id }} + +metavar string ::= + {{ phantom }} + {{ ocaml string }} + {{ lem string }} + +metavar op ::= + {{ phantom }} + {{ ocaml string }} + {{ lem string }} + +metavar bool ::= + {{ phantom }} + {{ ocaml bool }} + {{ lem bool }} + +metavar value ::= + {{ phantom }} + {{ lem vl }} + {{ ocaml vl }} + +embed +{{ lem + +open import Ast +open import Value2 + +}} + +grammar + +% Fragments are small pure snippets of (abstract) C code, mostly +% expressions, used by the aval and cval types. + +fragment :: 'F_' ::= + | id :: :: id + | '&' id :: :: ref + | value :: :: lit + | have_exception :: :: have_exception + | current_exception :: :: current_exception + | fragment op fragment' :: :: op + | op fragment :: :: unary + | string ( fragment0 , ... , fragmentn ) :: :: call + | fragment . string :: :: field + | string :: :: raw + | poly fragment :: :: poly + +% Note that init / clear are sometimes refered to as create / kill + +%%% IR types + +ctyp :: 'CT_' ::= + {{ com C type }} +% Integer types +% +% lint is a large (l) arbitrary precision integer, mpz_t in C. +% fint(n) is a fixed precision signed integer that is representable in exactly n bits + | lint :: :: lint + | fint nat :: :: fint + +% Bitvector types - flag represents bit indexing direction, true - dec or false - inc +% +% lbits is a large (l) arbitrary precision bitvector +% sbits is a small (s) bitvector, such that sbits(n, _) is guaranteed to have a length of at most n. +% fbits is a fixed (f) bitvector, such that fbits(n, _) has a length of exactly n bits + | lbits ( bool ) :: :: lbits + | sbits ( nat , bool ) :: :: sbits + | fbits ( nat , bool ) :: :: fbits + +% Other Sail types + | unit :: :: unit + | bool_t :: :: bool + | bit :: :: bit + | string_t :: :: string + +% The real type in sail. Abstract here, so the code generator can +% choose to implement it using either GMP rationals or high-precision +% floating point. + | real :: :: real + + | ( ctyp0 , ... , ctypn ) :: :: tup + +% Abstractly represent how all the Sail user defined types get mapped +% into C. We don't fully worry about precise implementation details at +% this point, as C doesn't have variants or tuples natively, but these +% need to be encoded. + | enum id ( id0 , ... , idn ) :: :: enum + | struct id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: struct + | variant id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: variant + +% A vector type for non-bit vectors, and a (linked) list type. + | vector ( bool , ctyp ) :: :: vector + | list ( ctyp ) :: :: list + + | ref ( ctyp ) :: :: ref + +% We can still have a very limited amount of polymorphism in this IR +% representation, as variants can have polymorphic constructors. The +% reason is we can put more precise types into constructors and then +% consume them as more general types meaning the underlying +% representation (rather than the high-level sail types) are what we +% need to specialise constructors, e.g. Some(0xFF) would be a Some +% constructor containing a fbits(8, true), but this could be pattern +% matched as Some(x) where the matching context expects x to have type +% lbits, and this must work without compiling to type incorrect C. + | poly :: :: poly + + +cval :: 'CV_' ::= + {{ ocaml fragment * ctyp }} + {{ lem fragment * ctyp }} + +clexp :: 'CL_' ::= + | id : ctyp :: :: id + | clexp . string :: :: field + | * clexp :: :: addr + | clexp . nat :: :: tuple + | current_exception : ctyp :: :: current_exception + | have_exception :: :: have_exception + | return : ctyp :: :: return + +ctype_def :: 'CTD_' ::= + {{ com C type definition }} + | enum id = id0 '|' ... '|' idn :: :: enum + | struct id = { id0 : ctyp0 , ... , idn : ctypn } :: :: struct + | variant id = { id0 : ctyp0 , ... , idn : ctypn } :: :: variant + +iannot :: 'IA_' ::= + {{ lem nat * nat * nat }} + {{ ocaml int * int * int }} + +instr :: 'I_' ::= + {{ aux _ iannot }} +% The following are the minimal set of instructions output by +% Jib_compile.ml. + | ctyp id :: :: decl + | ctyp id = cval :: :: init + | jump ( cval ) string :: :: jump + | goto string :: :: goto + | string : :: :: label + | clexp = bool id ( cval0 , ... , cvaln ) :: :: funcall + | clexp = cval :: :: copy + | clear ctyp id :: :: clear + | undefined ctyp :: :: undefined + | match_failure :: :: match_failure + | end :: :: end + +% All instructions containing nested instructions can be flattened +% away. try and throw only exist for internal use within +% Jib_compile.ml, as exceptional control flow is handled by a separate +% Jib->Jib pass. + | if ( cval ) { instr0 ; ... ; instrn } + else { instr0 ; ... ; instrm } : ctyp :: :: if + | { instr0 ; ... ; instrn } :: :: block + | try { instr0 ; ... ; instrn } :: :: try_block + | throw cval :: :: throw + +% We can embed either comments or pass raw-strings through to the +% code-generator. The first is useful for annotating generated source, +% the second for inserting instrumention. I_raw should be side-effect +% free. + | '//' string :: :: comment + | C string :: :: raw + +% Jib_compile.ml will represent all returns as assigments to the clexp +% CL_return, followed by end to signify the end of the +% function. + | return cval :: :: return + +% For optimising away allocations and copying. + | reset ctyp id :: :: reset + | ctyp id = cval :: :: reinit + | alias clexp = cval :: :: alias + +cdef :: 'CDEF_' ::= + | register id : ctyp = { + instr0 ; ... ; instrn + } :: :: reg_dec + | ctype_def :: :: type + +% The first list of instructions sets up the global letbinding, while +% the second clears it. + | let nat ( id0 : ctyp0 , ... , idn : ctypn ) = { + instr0 ; ... ; instrm + } :: :: let + + | val id ( ctyp0 , ... , ctypn ) -> ctyp :: :: spec + +% If mid = Some id this indicates that the caller should allocate the +% return type and passes a pointer to it as an extra argument id for +% the function to fill in. This is only done via Jib->Jib rewrites +% used when compiling to C. + | function id mid ( id0 , ... , idn ) { + instr0 ; ... ; instrm + } :: :: fundef + +% Each function can have custom global state. In CDEF_startup and +% CDEF_finish all I_decl and I_init nodes are treated as global and no +% nested-instructions (if/block) are allowed. + | startup id { + instr0 ; ... ; instrn + } :: :: startup + | finish id { + instr0 ; ... ; instrn + } :: :: finish diff --git a/src/Makefile b/src/Makefile index beba66df..d71c9fb8 100644 --- a/src/Makefile +++ b/src/Makefile @@ -74,16 +74,16 @@ full: sail lib doc ast.lem: ../language/sail.ott ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott -bytecode.lem: ../language/bytecode.ott ast.lem - ott -sort false -generate_aux_rules true -o bytecode.lem -picky_multiple_parses true ../language/bytecode.ott +jib.lem: ../language/jib.ott ast.lem + ott -sort false -generate_aux_rules true -o jib.lem -picky_multiple_parses true ../language/jib.ott ast.ml: ast.lem lem -ocaml ast.lem sed -i.bak -f ast.sed ast.ml -bytecode.ml: bytecode.lem - lem -ocaml bytecode.lem -lib . -lib gen_lib/ - sed -i.bak -f ast.sed bytecode.ml +jib.ml: jib.lem + lem -ocaml jib.lem -lib . -lib gen_lib/ + sed -i.bak -f ast.sed jib.ml manifest.ml: echo "(* Generated file -- do not edit. *)" > manifest.ml @@ -99,18 +99,18 @@ else echo let version=\"$(shell grep '^version:' ../opam | grep -o -E '"[^"]+"')\" >> manifest.ml endif -sail: ast.ml bytecode.ml manifest.ml +sail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa -isail: ast.ml bytecode.ml manifest.ml +isail: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind isail.native -coverage: ast.ml bytecode.ml manifest.ml +coverage: ast.ml jib.ml manifest.ml BISECT_COVERAGE=YES ocamlbuild -use-ocamlfind -plugin-tag 'package(bisect_ppx-ocamlbuild)' isail.native sail.native: sail -sail.byte: ast.ml bytecode.ml manifest.ml +sail.byte: ast.ml jib.ml manifest.ml ocamlbuild -use-ocamlfind -cflag -g sail.byte interpreter: lem_interp/interp_ast.lem @@ -132,9 +132,9 @@ clean: -rm -f ast.ml -rm -f ast.lem -rm -f ast.ml.bak - -rm -f bytecode.ml - -rm -f bytecode.lem - -rm -f bytecode.ml.bak + -rm -f jib.ml + -rm -f jib.lem + -rm -f jib.ml.bak -rm -f manifest.ml doc: diff --git a/src/_tags b/src/_tags index aac18862..f792fefa 100644 --- a/src/_tags +++ b/src/_tags @@ -11,6 +11,7 @@ true: -traverse, debug, use_menhir <**/*.m{l,li}>: package(lem) : include +: include or : include # disable partial match and unused variable warnings diff --git a/src/anf.ml b/src/anf.ml deleted file mode 100644 index 5db836e9..00000000 --- a/src/anf.ml +++ /dev/null @@ -1,717 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util -open Type_check -open PPrint - -module Big_int = Nat_big_num - -(**************************************************************************) -(* 1. Conversion to A-normal form (ANF) *) -(**************************************************************************) - -(* The first step in compiling sail is converting the Sail expression - grammar into A-normal form. Essentially this converts expressions - such as f(g(x), h(y)) into something like: - - let v0 = g(x) in let v1 = h(x) in f(v0, v1) - - Essentially the arguments to every function must be trivial, and - complex expressions must be let bound to new variables, or used in - a block, assignment, or control flow statement (if, for, and - while/until loops). The aexp datatype represents these expressions, - while aval represents the trivial values. - - The convention is that the type of an aexp is given by last - argument to a constructor. It is omitted where it is obvious - for - example all for loops have unit as their type. If some constituent - part of the aexp has an annotation, the it refers to the previous - argument, so in - - AE_let (id, typ1, _, body, typ2) - - typ1 is the type of the bound identifer, whereas typ2 is the type - of the whole let expression (and therefore also the body). - - See Flanagan et al's 'The Essence of Compiling with Continuations' - *) -type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l - -and 'a aexp_aux = - | AE_val of 'a aval - | AE_app of id * ('a aval) list * 'a - | AE_cast of 'a aexp * 'a - | AE_assign of id * 'a * 'a aexp - | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a - | AE_block of ('a aexp) list * 'a aexp * 'a - | AE_return of 'a aval * 'a - | AE_throw of 'a aval * 'a - | AE_if of 'a aval * 'a aexp * 'a aexp * 'a - | AE_field of 'a aval * id * 'a - | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a - | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp - | AE_loop of loop * 'a aexp * 'a aexp - | AE_short_circuit of sc_op * 'a aval * 'a aexp - -and sc_op = SC_and | SC_or - -and 'a apat = AP_aux of 'a apat_aux * Env.t * l - -and 'a apat_aux = - | AP_tup of ('a apat) list - | AP_id of id * 'a - | AP_global of id * 'a - | AP_app of id * 'a apat * 'a - | AP_cons of 'a apat * 'a apat - | AP_nil of 'a - | AP_wild of 'a - -and 'a aval = - | AV_lit of lit * 'a - | AV_id of id * 'a lvar - | AV_ref of id * 'a lvar - | AV_tuple of ('a aval) list - | AV_list of ('a aval) list * 'a - | AV_vector of ('a aval) list * 'a - | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a * ctyp - -(* Renaming variables in ANF expressions *) - -let rec apat_bindings (AP_aux (apat_aux, _, _)) = - match apat_aux with - | AP_tup apats -> List.fold_left IdSet.union IdSet.empty (List.map apat_bindings apats) - | AP_id (id, _) -> IdSet.singleton id - | AP_global (id, _) -> IdSet.empty - | AP_app (id, apat, _) -> apat_bindings apat - | AP_cons (apat1, apat2) -> IdSet.union (apat_bindings apat1) (apat_bindings apat2) - | AP_nil _ -> IdSet.empty - | AP_wild _ -> IdSet.empty - -(** This function returns the types of all bound variables in a - pattern. It ignores AP_global, apat_globals is used for that. *) -let rec apat_types (AP_aux (apat_aux, _, _)) = - let merge id b1 b2 = - match b1, b2 with - | None, None -> None - | Some v, None -> Some v - | None, Some v -> Some v - | Some _, Some _ -> assert false - in - match apat_aux with - | AP_tup apats -> List.fold_left (Bindings.merge merge) Bindings.empty (List.map apat_types apats) - | AP_id (id, typ) -> Bindings.singleton id typ - | AP_global (id, _) -> Bindings.empty - | AP_app (id, apat, _) -> apat_types apat - | AP_cons (apat1, apat2) -> (Bindings.merge merge) (apat_types apat1) (apat_types apat2) - | AP_nil _ -> Bindings.empty - | AP_wild _ -> Bindings.empty - -let rec apat_rename from_id to_id (AP_aux (apat_aux, env, l)) = - let apat_aux = match apat_aux with - | AP_tup apats -> AP_tup (List.map (apat_rename from_id to_id) apats) - | AP_id (id, typ) when Id.compare id from_id = 0 -> AP_id (to_id, typ) - | AP_id (id, typ) -> AP_id (id, typ) - | AP_global (id, typ) -> AP_global (id, typ) - | AP_app (ctor, apat, typ) -> AP_app (ctor, apat_rename from_id to_id apat, typ) - | AP_cons (apat1, apat2) -> AP_cons (apat_rename from_id to_id apat1, apat_rename from_id to_id apat2) - | AP_nil typ -> AP_nil typ - | AP_wild typ -> AP_wild typ - in - AP_aux (apat_aux, env, l) - -let rec aval_rename from_id to_id = function - | AV_lit (lit, typ) -> AV_lit (lit, typ) - | AV_id (id, lvar) when Id.compare id from_id = 0 -> AV_id (to_id, lvar) - | AV_id (id, lvar) -> AV_id (id, lvar) - | AV_ref (id, lvar) when Id.compare id from_id = 0 -> AV_ref (to_id, lvar) - | AV_ref (id, lvar) -> AV_ref (id, lvar) - | AV_tuple avals -> AV_tuple (List.map (aval_rename from_id to_id) avals) - | AV_list (avals, typ) -> AV_list (List.map (aval_rename from_id to_id) avals, typ) - | AV_vector (avals, typ) -> AV_vector (List.map (aval_rename from_id to_id) avals, typ) - | AV_record (avals, typ) -> AV_record (Bindings.map (aval_rename from_id to_id) avals, typ) - | AV_C_fragment (fragment, typ, ctyp) -> AV_C_fragment (frag_rename from_id to_id fragment, typ, ctyp) - -let rec aexp_rename from_id to_id (AE_aux (aexp, env, l)) = - let recur = aexp_rename from_id to_id in - let aexp = match aexp with - | AE_val aval -> AE_val (aval_rename from_id to_id aval) - | AE_app (id, avals, typ) -> AE_app (id, List.map (aval_rename from_id to_id) avals, typ) - | AE_cast (aexp, typ) -> AE_cast (recur aexp, typ) - | AE_assign (id, typ, aexp) when Id.compare from_id id = 0 -> AE_assign (to_id, typ, aexp_rename from_id to_id aexp) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, aexp_rename from_id to_id aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when Id.compare from_id id = 0 -> AE_let (mut, id, typ1, recur aexp1, aexp2, typ2) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, recur aexp1, recur aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map recur aexps, recur aexp, typ) - | AE_return (aval, typ) -> AE_return (aval_rename from_id to_id aval, typ) - | AE_throw (aval, typ) -> AE_throw (aval_rename from_id to_id aval, typ) - | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval_rename from_id to_id aval, recur then_aexp, recur else_aexp, typ) - | AE_field (aval, id, typ) -> AE_field (aval_rename from_id to_id aval, id, typ) - | AE_case (aval, apexps, typ) -> AE_case (aval_rename from_id to_id aval, List.map (apexp_rename from_id to_id) apexps, typ) - | AE_try (aexp, apexps, typ) -> AE_try (aexp_rename from_id to_id aexp, List.map (apexp_rename from_id to_id) apexps, typ) - | AE_record_update (aval, avals, typ) -> AE_record_update (aval_rename from_id to_id aval, Bindings.map (aval_rename from_id to_id) avals, typ) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when Id.compare from_id to_id = 0 -> AE_for (id, aexp1, aexp2, aexp3, order, aexp4) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> AE_for (id, recur aexp1, recur aexp2, recur aexp3, order, recur aexp4) - | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, recur aexp1, recur aexp2) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval_rename from_id to_id aval, recur aexp) - in - AE_aux (aexp, env, l) - -and apexp_rename from_id to_id (apat, aexp1, aexp2) = - if IdSet.mem from_id (apat_bindings apat) then - (apat, aexp1, aexp2) - else - (apat, aexp_rename from_id to_id aexp1, aexp_rename from_id to_id aexp2) - -let shadow_counter = ref 0 - -let new_shadow id = - let shadow_id = append_id id ("shadow#" ^ string_of_int !shadow_counter) in - incr shadow_counter; - shadow_id - -let rec no_shadow ids (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_val aval -> AE_val aval - | AE_app (id, avals, typ) -> AE_app (id, avals, typ) - | AE_cast (aexp, typ) -> AE_cast (no_shadow ids aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, no_shadow ids aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when IdSet.mem id ids -> - let shadow_id = new_shadow id in - let aexp1 = no_shadow ids aexp1 in - let ids = IdSet.add shadow_id ids in - AE_let (mut, shadow_id, typ1, aexp1, no_shadow ids (aexp_rename id shadow_id aexp2), typ2) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> - AE_let (mut, id, typ1, no_shadow ids aexp1, no_shadow (IdSet.add id ids) aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (no_shadow ids) aexps, no_shadow ids aexp, typ) - | AE_return (aval, typ) -> AE_return (aval, typ) - | AE_throw (aval, typ) -> AE_throw (aval, typ) - | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval, no_shadow ids then_aexp, no_shadow ids else_aexp, typ) - | AE_field (aval, id, typ) -> AE_field (aval, id, typ) - | AE_case (aval, apexps, typ) -> AE_case (aval, List.map (no_shadow_apexp ids) apexps, typ) - | AE_try (aexp, apexps, typ) -> AE_try (no_shadow ids aexp, List.map (no_shadow_apexp ids) apexps, typ) - | AE_record_update (aval, avals, typ) -> AE_record_update (aval, avals, typ) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when IdSet.mem id ids -> - let shadow_id = new_shadow id in - let aexp1 = no_shadow ids aexp1 in - let aexp2 = no_shadow ids aexp2 in - let aexp3 = no_shadow ids aexp3 in - let ids = IdSet.add shadow_id ids in - AE_for (shadow_id, aexp1, aexp2, aexp3, order, no_shadow ids (aexp_rename id shadow_id aexp4)) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let ids = IdSet.add id ids in - AE_for (id, no_shadow ids aexp1, no_shadow ids aexp2, no_shadow ids aexp3, order, no_shadow ids aexp4) - | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, no_shadow ids aexp1, no_shadow ids aexp2) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, no_shadow ids aexp) - in - AE_aux (aexp, env, l) - -and no_shadow_apexp ids (apat, aexp1, aexp2) = - let shadows = IdSet.inter (apat_bindings apat) ids in - let shadows = List.map (fun id -> id, new_shadow id) (IdSet.elements shadows) in - let rename aexp = List.fold_left (fun aexp (from_id, to_id) -> aexp_rename from_id to_id aexp) aexp shadows in - let rename_apat apat = List.fold_left (fun apat (from_id, to_id) -> apat_rename from_id to_id apat) apat shadows in - let ids = IdSet.union (apat_bindings apat) (IdSet.union ids (IdSet.of_list (List.map snd shadows))) in - (rename_apat apat, no_shadow ids (rename aexp1), no_shadow ids (rename aexp2)) - -(* Map over all the avals in an aexp. *) -let rec map_aval f (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_val v -> AE_val (f env l v) - | AE_cast (aexp, typ) -> AE_cast (map_aval f aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_aval f aexp) - | AE_app (id, vs, typ) -> AE_app (id, List.map (f env l) vs, typ) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> - AE_let (mut, id, typ1, map_aval f aexp1, map_aval f aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_aval f) aexps, map_aval f aexp, typ) - | AE_return (aval, typ) -> AE_return (f env l aval, typ) - | AE_throw (aval, typ) -> AE_throw (f env l aval, typ) - | AE_if (aval, aexp1, aexp2, typ2) -> - AE_if (f env l aval, map_aval f aexp1, map_aval f aexp2, typ2) - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_aval f aexp1, map_aval f aexp2) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - AE_for (id, map_aval f aexp1, map_aval f aexp2, map_aval f aexp3, order, map_aval f aexp4) - | AE_record_update (aval, updates, typ) -> - AE_record_update (f env l aval, Bindings.map (f env l) updates, typ) - | AE_field (aval, field, typ) -> - AE_field (f env l aval, field, typ) - | AE_case (aval, cases, typ) -> - AE_case (f env l aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (map_aval f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, f env l aval, map_aval f aexp) - in - AE_aux (aexp, env, l) - -(* Map over all the functions in an aexp. *) -let rec map_functions f (AE_aux (aexp, env, l)) = - let aexp = match aexp with - | AE_app (id, vs, typ) -> f env l id vs typ - | AE_cast (aexp, typ) -> AE_cast (map_functions f aexp, typ) - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_functions f aexp) - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, map_functions f aexp) - | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, map_functions f aexp1, map_functions f aexp2, typ2) - | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_functions f) aexps, map_functions f aexp, typ) - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, map_functions f aexp1, map_functions f aexp2, typ) - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_functions f aexp1, map_functions f aexp2) - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - AE_for (id, map_functions f aexp1, map_functions f aexp2, map_functions f aexp3, order, map_functions f aexp4) - | AE_case (aval, cases, typ) -> - AE_case (aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) - | AE_try (aexp, cases, typ) -> - AE_try (map_functions f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) - -(* For debugging we provide a pretty printer for ANF expressions. *) - -let pp_lvar lvar doc = - match lvar with - | Register (_, _, typ) -> - string "[R/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Local (Mutable, typ) -> - string "[M/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Local (Immutable, typ) -> - string "[I/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Enum typ -> - string "[E/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - | Unbound -> string "[?]" ^^ doc - -let pp_annot typ doc = - string "[" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc - -let pp_order = function - | Ord_aux (Ord_inc, _) -> string "inc" - | Ord_aux (Ord_dec, _) -> string "dec" - | _ -> assert false (* Order types have been specialised, so no polymorphism in C backend. *) - -let rec pp_aexp (AE_aux (aexp, _, _)) = - match aexp with - | AE_val v -> pp_aval v - | AE_cast (aexp, typ) -> - pp_annot typ (string "$" ^^ pp_aexp aexp) - | AE_assign (id, typ, aexp) -> - pp_annot typ (pp_id id) ^^ string " := " ^^ pp_aexp aexp - | AE_app (id, args, typ) -> - pp_annot typ (pp_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) - | AE_short_circuit (SC_or, aval, aexp) -> - pp_aval aval ^^ string " || " ^^ pp_aexp aexp - | AE_short_circuit (SC_and, aval, aexp) -> - pp_aval aval ^^ string " && " ^^ pp_aexp aexp - | AE_let (mut, id, id_typ, binding, body, typ) -> group - begin - let let_doc = string (match mut with Immutable -> "let" | Mutable -> "let mut") in - match binding with - | AE_aux (AE_let _, _, _) -> - (pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="]) - ^^ hardline ^^ nest 2 (pp_aexp binding)) - ^^ hardline ^^ string "in" ^^ space ^^ pp_aexp body - | _ -> - pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="; pp_aexp binding; string "in"]) - ^^ hardline ^^ pp_aexp body - end - | AE_if (cond, then_aexp, else_aexp, typ) -> - pp_annot typ (separate space [ string "if"; pp_aval cond; - string "then"; pp_aexp then_aexp; - string "else"; pp_aexp else_aexp ]) - | AE_block (aexps, aexp, typ) -> - pp_annot typ (surround 2 0 lbrace (pp_block (aexps @ [aexp])) rbrace) - | AE_return (v, typ) -> pp_annot typ (string "return" ^^ parens (pp_aval v)) - | AE_throw (v, typ) -> pp_annot typ (string "throw" ^^ parens (pp_aval v)) - | AE_loop (While, aexp1, aexp2) -> - separate space [string "while"; pp_aexp aexp1; string "do"; pp_aexp aexp2] - | AE_loop (Until, aexp1, aexp2) -> - separate space [string "repeat"; pp_aexp aexp2; string "until"; pp_aexp aexp1] - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let header = - string "foreach" ^^ space ^^ - group (parens (separate (break 1) - [ pp_id id; - string "from " ^^ pp_aexp aexp1; - string "to " ^^ pp_aexp aexp2; - string "by " ^^ pp_aexp aexp3; - string "in " ^^ pp_order order ])) - in - header ^//^ pp_aexp aexp4 - | AE_field (aval, field, typ) -> pp_annot typ (parens (pp_aval aval ^^ string "." ^^ pp_id field)) - | AE_case (aval, cases, typ) -> - pp_annot typ (separate space [string "match"; pp_aval aval; pp_cases cases]) - | AE_try (aexp, cases, typ) -> - pp_annot typ (separate space [string "try"; pp_aexp aexp; pp_cases cases]) - | AE_record_update (aval, updates, typ) -> - braces (pp_aval aval ^^ string " with " - ^^ separate (string ", ") (List.map (fun (id, aval) -> pp_id id ^^ string " = " ^^ pp_aval aval) - (Bindings.bindings updates))) - -and pp_apat (AP_aux (apat_aux, _, _)) = - match apat_aux with - | AP_wild _ -> string "_" - | AP_id (id, typ) -> pp_annot typ (pp_id id) - | AP_global (id, _) -> pp_id id - | AP_tup apats -> parens (separate_map (comma ^^ space) pp_apat apats) - | AP_app (id, apat, typ) -> pp_annot typ (pp_id id ^^ parens (pp_apat apat)) - | AP_nil _ -> string "[||]" - | AP_cons (hd_apat, tl_apat) -> pp_apat hd_apat ^^ string " :: " ^^ pp_apat tl_apat - -and pp_cases cases = surround 2 0 lbrace (separate_map (comma ^^ hardline) pp_case cases) rbrace - -and pp_case (apat, guard, body) = - separate space [pp_apat apat; string "if"; pp_aexp guard; string "=>"; pp_aexp body] - -and pp_block = function - | [] -> string "()" - | [aexp] -> pp_aexp aexp - | aexp :: aexps -> pp_aexp aexp ^^ semi ^^ hardline ^^ pp_block aexps - -and pp_aval = function - | AV_lit (lit, typ) -> pp_annot typ (string (string_of_lit lit)) - | AV_id (id, lvar) -> pp_lvar lvar (pp_id id) - | AV_tuple avals -> parens (separate_map (comma ^^ space) pp_aval avals) - | AV_ref (id, lvar) -> string "ref" ^^ space ^^ pp_lvar lvar (pp_id id) - | AV_C_fragment (frag, typ, ctyp) -> - pp_annot typ (string ("(" ^ string_of_ctyp ctyp ^ ")" ^ string_of_fragment frag |> Util.cyan |> Util.clear)) - | AV_vector (avals, typ) -> - pp_annot typ (string "[" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "]") - | AV_list (avals, typ) -> - pp_annot typ (string "[|" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "|]") - | AV_record (fields, typ) -> - pp_annot typ (string "struct {" - ^^ separate_map (comma ^^ space) (fun (id, field) -> pp_id id ^^ string " = " ^^ pp_aval field) (Bindings.bindings fields) - ^^ string "}") - -let ae_lit lit typ = AE_val (AV_lit (lit, typ)) - -let is_dead_aexp (AE_aux (_, env, _)) = prove __POS__ env nc_false - -(** GLOBAL: gensym_counter is used to generate fresh identifiers where - needed. It should be safe to reset between top level - definitions. **) -let gensym_counter = ref 0 - -let gensym () = - let id = mk_id ("gs#" ^ string_of_int !gensym_counter) in - incr gensym_counter; - id - -let rec split_block l = function - | [exp] -> [], exp - | exp :: exps -> - let exps, last = split_block l exps in - exp :: exps, last - | [] -> - raise (Reporting.err_unreachable l __POS__ "empty block found when converting to ANF") - -let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = - let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in - match p_aux with - | P_id id when global -> mk_apat (AP_global (id, typ_of_pat pat)) - | P_id id -> mk_apat (AP_id (id, typ_of_pat pat)) - | P_wild -> mk_apat (AP_wild (typ_of_pat pat)) - | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)) - | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, typ_of_pat pat)) - | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), typ_of_pat pat)) - | P_typ (_, pat) -> anf_pat ~global:global pat - | P_var (pat, _) -> anf_pat ~global:global pat - | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) - | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) - | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) - | _ -> - raise (Reporting.err_unreachable (fst annot) __POS__ - ("Could not convert pattern to ANF: " ^ string_of_pat pat)) - -let rec apat_globals (AP_aux (aux, _, _)) = - match aux with - | AP_nil _ | AP_wild _ | AP_id _ -> [] - | AP_global (id, typ) -> [(id, typ)] - | AP_tup apats -> List.concat (List.map apat_globals apats) - | AP_app (_, apat, _) -> apat_globals apat - | AP_cons (hd_apat, tl_apat) -> apat_globals hd_apat @ apat_globals tl_apat - -let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = - let mk_aexp aexp = AE_aux (aexp, env_of_annot exp_annot, l) in - - let to_aval (AE_aux (aexp_aux, env, l) as aexp) = - let mk_aexp aexp = AE_aux (aexp, env, l) in - match aexp_aux with - | AE_val v -> (v, fun x -> x) - | AE_short_circuit (_, _, _) -> - let id = gensym () in - (AV_id (id, Local (Immutable, bool_typ)), fun x -> mk_aexp (AE_let (Immutable, id, bool_typ, aexp, x, typ_of exp))) - | AE_app (_, _, typ) - | AE_let (_, _, _, _, _, typ) - | AE_return (_, typ) - | AE_throw (_, typ) - | AE_cast (_, typ) - | AE_if (_, _, _, typ) - | AE_field (_, _, typ) - | AE_case (_, _, typ) - | AE_try (_, _, typ) - | AE_record_update (_, _, typ) - | AE_block (_, _, typ) -> - let id = gensym () in - (AV_id (id, Local (Immutable, typ)), fun x -> mk_aexp (AE_let (Immutable, id, typ, aexp, x, typ_of exp))) - | AE_assign _ | AE_for _ | AE_loop _ -> - let id = gensym () in - (AV_id (id, Local (Immutable, unit_typ)), fun x -> mk_aexp (AE_let (Immutable, id, unit_typ, aexp, x, typ_of exp))) - in - match e_aux with - | E_lit lit -> mk_aexp (ae_lit lit (typ_of exp)) - - | E_block [] -> - Util.warn (Reporting.loc_to_string l - ^ "\n\nTranslating empty block (possibly assigning to an uninitialized variable at the end of a block?)"); - mk_aexp (ae_lit (L_aux (L_unit, l)) (typ_of exp)) - | E_block exps -> - let exps, last = split_block l exps in - let aexps = List.map anf exps in - let alast = anf last in - mk_aexp (AE_block (aexps, alast, typ_of exp)) - - | E_assign (LEXP_aux (LEXP_deref dexp, _), exp) -> - let gs = gensym () in - mk_aexp (AE_let (Mutable, gs, typ_of dexp, anf dexp, mk_aexp (AE_assign (gs, typ_of dexp, anf exp)), unit_typ)) - - | E_assign (LEXP_aux (LEXP_id id, _), exp) - | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> - let aexp = anf exp in - mk_aexp (AE_assign (id, lvar_typ (Env.lookup_id id (env_of exp)), aexp)) - - | E_assign (lexp, _) -> - raise (Reporting.err_unreachable l __POS__ - ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) - - | E_loop (loop_typ, cond, exp) -> - let acond = anf cond in - let aexp = anf exp in - mk_aexp (AE_loop (loop_typ, acond, aexp)) - - | E_for (id, exp1, exp2, exp3, order, body) -> - let aexp1, aexp2, aexp3, abody = anf exp1, anf exp2, anf exp3, anf body in - mk_aexp (AE_for (id, aexp1, aexp2, aexp3, order, abody)) - - | E_if (cond, then_exp, else_exp) -> - let cond_val, wrap = to_aval (anf cond) in - let then_aexp = anf then_exp in - let else_aexp = anf else_exp in - wrap (mk_aexp (AE_if (cond_val, then_aexp, else_aexp, typ_of exp))) - - | E_app_infix (x, Id_aux (Id op, l), y) -> - anf (E_aux (E_app (Id_aux (DeIid op, l), [x; y]), exp_annot)) - | E_app_infix (x, Id_aux (DeIid op, l), y) -> - anf (E_aux (E_app (Id_aux (Id op, l), [x; y]), exp_annot)) - - | E_vector exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_vector (List.map fst avals, typ_of exp)))) - - | E_list exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_list (List.map fst avals, typ_of exp)))) - - | E_field (field_exp, id) -> - let aval, wrap = to_aval (anf field_exp) in - wrap (mk_aexp (AE_field (aval, id, typ_of exp))) - - | E_record_update (exp, fexps) -> - let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = - let aval, wrap = to_aval (anf exp) in - (id, aval), wrap - in - let aval, exp_wrap = to_aval (anf exp) in - let fexps = List.map anf_fexp fexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in - let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in - exp_wrap (wrap (mk_aexp (AE_record_update (aval, record, typ_of exp)))) - - | E_app (id, [exp1; exp2]) when string_of_id id = "and_bool" -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap = to_aval aexp1 in - wrap (mk_aexp (AE_short_circuit (SC_and, aval1, aexp2))) - - | E_app (id, [exp1; exp2]) when string_of_id id = "or_bool" -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap = to_aval aexp1 in - wrap (mk_aexp (AE_short_circuit (SC_or, aval1, aexp2))) - - | E_app (id, exps) -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_app (id, List.map fst avals, typ_of exp))) - - | E_throw exn_exp -> - let aexp = anf exn_exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_throw (aval, typ_of exp))) - - | E_exit exp -> - let aexp = anf exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_app (mk_id "sail_exit", [aval], unit_typ))) - - | E_return ret_exp -> - let aexp = anf ret_exp in - let aval, wrap = to_aval aexp in - wrap (mk_aexp (AE_return (aval, typ_of exp))) - - | E_assert (exp1, exp2) -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap1 = to_aval aexp1 in - let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_assert", [aval1; aval2], unit_typ)))) - - | E_cons (exp1, exp2) -> - let aexp1 = anf exp1 in - let aexp2 = anf exp2 in - let aval1, wrap1 = to_aval aexp1 in - let aval2, wrap2 = to_aval aexp2 in - wrap1 (wrap2 (mk_aexp (AE_app (mk_id "cons", [aval1; aval2], unit_typ)))) - - | E_id id -> - let lvar = Env.lookup_id id (env_of exp) in - begin match lvar with - | _ -> mk_aexp (AE_val (AV_id (id, lvar))) - end - - | E_ref id -> - let lvar = Env.lookup_id id (env_of exp) in - mk_aexp (AE_val (AV_ref (id, lvar))) - - | E_case (match_exp, pexps) -> - let match_aval, match_wrap = to_aval (anf match_exp) in - let anf_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_when (pat, guard, body) -> - (anf_pat pat, anf guard, anf body) - | Pat_exp (pat, body) -> - (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) - in - match_wrap (mk_aexp (AE_case (match_aval, List.map anf_pexp pexps, typ_of exp))) - - | E_try (match_exp, pexps) -> - let match_aexp = anf match_exp in - let anf_pexp (Pat_aux (pat_aux, _)) = - match pat_aux with - | Pat_when (pat, guard, body) -> - (anf_pat pat, anf guard, anf body) - | Pat_exp (pat, body) -> - (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) - in - mk_aexp (AE_try (match_aexp, List.map anf_pexp pexps, typ_of exp)) - - | E_var (LEXP_aux (LEXP_id id, _), binding, body) - | E_var (LEXP_aux (LEXP_cast (_, id), _), binding, body) - | E_let (LB_aux (LB_val (P_aux (P_id id, _), binding), _), body) -> - let env = env_of body in - let lvar = Env.lookup_id id env in - mk_aexp (AE_let (Mutable, id, lvar_typ lvar, anf binding, anf body, typ_of exp)) - - | E_var (lexp, _, _) -> - raise (Reporting.err_unreachable l __POS__ - ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) - - | E_let (LB_aux (LB_val (pat, binding), _), body) -> - anf (E_aux (E_case (binding, [Pat_aux (Pat_exp (pat, body), (Parse_ast.Unknown, empty_tannot))]), exp_annot)) - - | E_tuple exps -> - let aexps = List.map anf exps in - let avals = List.map to_aval aexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in - wrap (mk_aexp (AE_val (AV_tuple (List.map fst avals)))) - - | E_record fexps -> - let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = - let aval, wrap = to_aval (anf exp) in - (id, aval), wrap - in - let fexps = List.map anf_fexp fexps in - let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in - let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in - wrap (mk_aexp (AE_val (AV_record (record, typ_of exp)))) - - | E_cast (typ, exp) -> mk_aexp (AE_cast (anf exp, typ)) - - | E_vector_access _ | E_vector_subrange _ | E_vector_update _ | E_vector_update_subrange _ | E_vector_append _ -> - (* Should be re-written by type checker *) - raise (Reporting.err_unreachable l __POS__ "encountered raw vector operation when converting to ANF") - - | E_internal_value _ -> - (* Interpreter specific *) - raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") - - | E_sizeof nexp -> - (* Sizeof nodes removed by sizeof rewriting pass *) - raise (Reporting.err_unreachable l __POS__ ("encountered E_sizeof node " ^ string_of_nexp nexp ^ " when converting to ANF")) - - | E_constraint _ -> - (* Sizeof nodes removed by sizeof rewriting pass *) - raise (Reporting.err_unreachable l __POS__ "encountered E_constraint node when converting to ANF") - - | E_nondet _ -> - (* We don't compile E_nondet nodes *) - raise (Reporting.err_unreachable l __POS__ "encountered E_nondet node when converting to ANF") - - | E_internal_return _ | E_internal_plet _ -> - raise (Reporting.err_unreachable l __POS__ "encountered unexpected internal node when converting to ANF") diff --git a/src/anf.mli b/src/anf.mli deleted file mode 100644 index 6b9c9b51..00000000 --- a/src/anf.mli +++ /dev/null @@ -1,125 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Type_check - -(* The A-normal form (ANF) grammar *) - -type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l - -and 'a aexp_aux = - | AE_val of 'a aval - | AE_app of id * ('a aval) list * 'a - | AE_cast of 'a aexp * 'a - | AE_assign of id * 'a * 'a aexp - | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a - | AE_block of ('a aexp) list * 'a aexp * 'a - | AE_return of 'a aval * 'a - | AE_throw of 'a aval * 'a - | AE_if of 'a aval * 'a aexp * 'a aexp * 'a - | AE_field of 'a aval * id * 'a - | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a - | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a - | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp - | AE_loop of loop * 'a aexp * 'a aexp - | AE_short_circuit of sc_op * 'a aval * 'a aexp - -and sc_op = SC_and | SC_or - -and 'a apat = AP_aux of 'a apat_aux * Env.t * l - -and 'a apat_aux = - | AP_tup of ('a apat) list - | AP_id of id * 'a - | AP_global of id * 'a - | AP_app of id * 'a apat * 'a - | AP_cons of 'a apat * 'a apat - | AP_nil of 'a - | AP_wild of 'a - -and 'a aval = - | AV_lit of lit * 'a - | AV_id of id * 'a lvar - | AV_ref of id * 'a lvar - | AV_tuple of ('a aval) list - | AV_list of ('a aval) list * 'a - | AV_vector of ('a aval) list * 'a - | AV_record of ('a aval) Bindings.t * 'a - | AV_C_fragment of fragment * 'a * ctyp - -val gensym : unit -> id - -(* Functions for transforming ANF expressions *) - -val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp - -val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp - -val no_shadow : IdSet.t -> 'a aexp -> 'a aexp - -val apat_globals : 'a apat -> (id * 'a) list - -val apat_types : 'a apat -> 'a Bindings.t - -val is_dead_aexp : 'a aexp -> bool - -(* Compiling to ANF expressions *) - -val anf_pat : ?global:bool -> tannot pat -> typ apat - -val anf : tannot exp -> typ aexp - -(* Pretty printing ANF expressions *) -val pp_aval : typ aval -> PPrint.document -val pp_aexp : typ aexp -> PPrint.document diff --git a/src/bytecode_interpreter.ml b/src/bytecode_interpreter.ml deleted file mode 100644 index 398e0c9d..00000000 --- a/src/bytecode_interpreter.ml +++ /dev/null @@ -1,162 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util - -module StringMap = Map.Make(String) - -type 'a frame = { - jump_table : int StringMap.t; - locals : 'a Bindings.t; - pc : int; - instrs : instr array - } - -type 'a gstate = { - globals : 'a Bindings.t; - cdefs : cdef list - } - -type 'a stack = { - top : 'a frame; - ret : ('a -> 'a frame) list - } - -let make_jump_table instrs = - let rec aux n = function - | I_aux (I_label label, _) :: instrs -> StringMap.add label n (aux (n + 1) instrs) - | _ :: instrs -> aux (n + 1) instrs - | [] -> StringMap.empty - in - aux 0 instrs - -let new_gstate cdefs = { - globals = Bindings.empty; - cdefs = cdefs - } - -let new_stack instrs = { - top = { - jump_table = make_jump_table instrs; - locals = Bindings.empty; - pc = 0; - instrs = Array.of_list instrs - }; - ret = [] - } - -let with_top stack f = - { stack with top = f (stack.top) } - -let eval_fragment gstate locals = function - | F_id id -> - begin match Bindings.find_opt id locals with - | Some vl -> vl - | None -> - begin match Bindings.find_opt id gstate.globals with - | Some vl -> vl - | None -> failwith "Identifier not found" - end - end - | F_lit vl -> vl - | _ -> failwith "Cannot eval fragment" - -let is_function id = function - | CDEF_fundef (id', _, _, _) when Id.compare id id' = 0 -> true - | _ -> false - -let step (gstate, stack) = - let I_aux (instr_aux, (_, l)) = stack.top.instrs.(stack.top.pc) in - match instr_aux with - | I_decl _ -> - gstate, with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) - - | I_init (_, id, (fragment, _)) -> - let vl = eval_fragment gstate stack.top.locals fragment in - gstate, - with_top stack (fun frame -> { frame with pc = frame.pc + 1; locals = Bindings.add id vl frame.locals }) - - | I_jump ((fragment, _), label) -> - let vl = eval_fragment gstate stack.top.locals fragment in - gstate, - begin match vl with - | V_bool true -> - with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) - | V_bool false -> - with_top stack (fun frame -> { frame with pc = frame.pc + 1 }) - | _ -> - failwith "Type error" - end - - | I_funcall (clexp, _, id, cvals) -> - let args = List.map (fun (fragment, _) -> eval_fragment gstate stack.top.locals fragment) cvals in - let params, instrs = - match List.find_opt (is_function id) gstate.cdefs with - | Some (CDEF_fundef (_, _, params, instrs)) -> params, instrs - | _ -> failwith "Function not found" - in - gstate, - { - top = { - jump_table = make_jump_table instrs; - locals = List.fold_left2 (fun locals param arg -> Bindings.add param arg locals) Bindings.empty params args; - pc = 0; - instrs = Array.of_list instrs; - }; - ret = (fun vl -> { stack.top with pc = stack.top.pc + 1 }) :: stack.ret - } - - | I_goto label -> - gstate, with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table }) - - | _ -> raise (Reporting.err_unreachable l __POS__ "Unhandled instruction") diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml deleted file mode 100644 index 630d2a48..00000000 --- a/src/bytecode_util.ml +++ /dev/null @@ -1,771 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Value2 -open PPrint - -(* Define wrappers for creating bytecode instructions. Each function - uses a counter to assign each instruction a unique identifier. *) - -let instr_counter = ref 0 - -let instr_number () = - let n = !instr_counter in - incr instr_counter; - n - -let idecl ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_decl (ctyp, id), (instr_number (), l)) - -let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_reset (ctyp, id), (instr_number (), l)) - -let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = - I_aux (I_init (ctyp, id, cval), (instr_number (), l)) - -let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = - I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) - -let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = - I_aux (I_funcall (clexp, false, id, cvals), (instr_number (), l)) - -let iextern ?loc:(l=Parse_ast.Unknown) clexp id cvals = - I_aux (I_funcall (clexp, true, id, cvals), (instr_number (), l)) - -let icopy l clexp cval = - I_aux (I_copy (clexp, cval), (instr_number (), l)) - -let ialias l clexp cval = - I_aux (I_alias (clexp, cval), (instr_number (), l)) - -let iclear ?loc:(l=Parse_ast.Unknown) ctyp id = - I_aux (I_clear (ctyp, id), (instr_number (), l)) - -let ireturn ?loc:(l=Parse_ast.Unknown) cval = - I_aux (I_return cval, (instr_number (), l)) - -let iblock ?loc:(l=Parse_ast.Unknown) instrs = - I_aux (I_block instrs, (instr_number (), l)) - -let itry_block ?loc:(l=Parse_ast.Unknown) instrs = - I_aux (I_try_block instrs, (instr_number (), l)) - -let ithrow ?loc:(l=Parse_ast.Unknown) cval = - I_aux (I_throw cval, (instr_number (), l)) -let icomment ?loc:(l=Parse_ast.Unknown) str = - I_aux (I_comment str, (instr_number (), l)) - -let ilabel ?loc:(l=Parse_ast.Unknown) label = - I_aux (I_label label, (instr_number (), l)) -let igoto ?loc:(l=Parse_ast.Unknown) label = - I_aux (I_goto label, (instr_number (), l)) - -let iundefined ?loc:(l=Parse_ast.Unknown) ctyp = - I_aux (I_undefined ctyp, (instr_number (), l)) - -let imatch_failure ?loc:(l=Parse_ast.Unknown) () = - I_aux (I_match_failure, (instr_number (), l)) - -let iraw ?loc:(l=Parse_ast.Unknown) str = - I_aux (I_raw str, (instr_number (), l)) - -let ijump ?loc:(l=Parse_ast.Unknown) cval label = - I_aux (I_jump (cval, label), (instr_number (), l)) - -let rec frag_rename from_id to_id = function - | F_id id when Id.compare id from_id = 0 -> F_id to_id - | F_id id -> F_id id - | F_ref id when Id.compare id from_id = 0 -> F_ref to_id - | F_ref id -> F_ref id - | F_lit v -> F_lit v - | F_have_exception -> F_have_exception - | F_current_exception -> F_current_exception - | F_call (call, frags) -> F_call (call, List.map (frag_rename from_id to_id) frags) - | F_op (f1, op, f2) -> F_op (frag_rename from_id to_id f1, op, frag_rename from_id to_id f2) - | F_unary (op, f) -> F_unary (op, frag_rename from_id to_id f) - | F_field (f, field) -> F_field (frag_rename from_id to_id f, field) - | F_raw raw -> F_raw raw - | F_poly f -> F_poly (frag_rename from_id to_id f) - -let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) - -let rec clexp_rename from_id to_id = function - | CL_id (id, ctyp) when Id.compare id from_id = 0 -> CL_id (to_id, ctyp) - | CL_id (id, ctyp) -> CL_id (id, ctyp) - | CL_field (clexp, field) -> - CL_field (clexp_rename from_id to_id clexp, field) - | CL_addr clexp -> - CL_addr (clexp_rename from_id to_id clexp) - | CL_tuple (clexp, n) -> - CL_tuple (clexp_rename from_id to_id clexp, n) - | CL_current_exception ctyp -> CL_current_exception ctyp - | CL_have_exception -> CL_have_exception - -let rec instr_rename from_id to_id (I_aux (instr, aux)) = - let instr = match instr with - | I_decl (ctyp, id) when Id.compare id from_id = 0 -> I_decl (ctyp, to_id) - | I_decl (ctyp, id) -> I_decl (ctyp, id) - - | I_init (ctyp, id, cval) when Id.compare id from_id = 0 -> - I_init (ctyp, to_id, cval_rename from_id to_id cval) - | I_init (ctyp, id, cval) -> - I_init (ctyp, id, cval_rename from_id to_id cval) - - | I_if (cval, then_instrs, else_instrs, ctyp2) -> - I_if (cval_rename from_id to_id cval, - List.map (instr_rename from_id to_id) then_instrs, - List.map (instr_rename from_id to_id) else_instrs, - ctyp2) - - | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) - - | I_funcall (clexp, extern, id, args) -> - I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) - - | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) - | I_alias (clexp, cval) -> I_alias (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) - - | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) - | I_clear (ctyp, id) -> I_clear (ctyp, id) - - | I_return cval -> I_return (cval_rename from_id to_id cval) - - | I_block instrs -> I_block (List.map (instr_rename from_id to_id) instrs) - - | I_try_block instrs -> I_try_block (List.map (instr_rename from_id to_id) instrs) - - | I_throw cval -> I_throw (cval_rename from_id to_id cval) - - | I_comment str -> I_comment str - - | I_raw str -> I_raw str - - | I_label label -> I_label label - - | I_goto label -> I_goto label - - | I_undefined ctyp -> I_undefined ctyp - - | I_match_failure -> I_match_failure - - | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id) - | I_reset (ctyp, id) -> I_reset (ctyp, id) - - | I_reinit (ctyp, id, cval) when Id.compare id from_id = 0 -> - I_reinit (ctyp, to_id, cval_rename from_id to_id cval) - | I_reinit (ctyp, id, cval) -> - I_reinit (ctyp, id, cval_rename from_id to_id cval) - in - I_aux (instr, aux) - -(**************************************************************************) -(* 1. Instruction pretty printer *) -(**************************************************************************) - -let string_of_value = function - | V_bits [] -> "UINT64_C(0)" - | V_bits bs -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" - | V_int i -> Big_int.to_string i ^ "l" - | V_bool true -> "true" - | V_bool false -> "false" - | V_null -> "NULL" - | V_unit -> "UNIT" - | V_bit Sail2_values.B0 -> "UINT64_C(0)" - | V_bit Sail2_values.B1 -> "UINT64_C(1)" - | V_string str -> "\"" ^ str ^ "\"" - | V_ctor_kind str -> "Kind_" ^ Util.zencode_string str - | _ -> failwith "Cannot convert value to string" - -let rec string_of_fragment ?zencode:(zencode=true) = function - | F_id id when zencode -> Util.zencode_string (string_of_id id) - | F_id id -> string_of_id id - | F_ref id when zencode -> "&" ^ Util.zencode_string (string_of_id id) - | F_ref id -> "&" ^ string_of_id id - | F_lit v -> string_of_value v - | F_call (str, frags) -> - Printf.sprintf "%s(%s)" str (Util.string_of_list ", " (string_of_fragment ~zencode:zencode) frags) - | F_field (f, field) -> - Printf.sprintf "%s.%s" (string_of_fragment' ~zencode:zencode f) field - | F_op (f1, op, f2) -> - Printf.sprintf "%s %s %s" (string_of_fragment' ~zencode:zencode f1) op (string_of_fragment' ~zencode:zencode f2) - | F_unary (op, f) -> - op ^ string_of_fragment' ~zencode:zencode f - | F_have_exception -> "have_exception" - | F_current_exception -> "(*current_exception)" - | F_raw raw -> raw - | F_poly f -> string_of_fragment ~zencode:zencode f -and string_of_fragment' ?zencode:(zencode=true) f = - match f with - | F_op _ | F_unary _ -> "(" ^ string_of_fragment ~zencode:zencode f ^ ")" - | _ -> string_of_fragment ~zencode:zencode f - -(* String representation of ctyps here is only for debugging and - intermediate language pretty-printer. *) -and string_of_ctyp = function - | CT_lint -> "int" - | CT_lbits true -> "lbits(dec)" - | CT_lbits false -> "lbits(inc)" - | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" - | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" - | CT_sbits true -> "sbits(dec)" - | CT_sbits false -> "sbits(inc)" - | CT_fint n -> "int(" ^ string_of_int n ^ ")" - | CT_bit -> "bit" - | CT_unit -> "unit" - | CT_bool -> "bool" - | CT_real -> "real" - | CT_tup ctyps -> "(" ^ Util.string_of_list ", " string_of_ctyp ctyps ^ ")" - | CT_struct (id, _) | CT_enum (id, _) | CT_variant (id, _) -> string_of_id id - | CT_string -> "string" - | CT_vector (true, ctyp) -> "vector(dec, " ^ string_of_ctyp ctyp ^ ")" - | CT_vector (false, ctyp) -> "vector(inc, " ^ string_of_ctyp ctyp ^ ")" - | CT_list ctyp -> "list(" ^ string_of_ctyp ctyp ^ ")" - | CT_ref ctyp -> "ref(" ^ string_of_ctyp ctyp ^ ")" - | CT_poly -> "*" - -(** This function is like string_of_ctyp, but recursively prints all - constructors in variants and structs. Used for debug output. *) -and full_string_of_ctyp = function - | CT_lint -> "int" - | CT_lbits true -> "lbits(dec)" - | CT_lbits false -> "lbits(inc)" - | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" - | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" - | CT_sbits true -> "sbits(dec)" - | CT_sbits false -> "sbits(inc)" - | CT_fint n -> "int(" ^ string_of_int n ^ ")" - | CT_bit -> "bit" - | CT_unit -> "unit" - | CT_bool -> "bool" - | CT_real -> "real" - | CT_tup ctyps -> "(" ^ Util.string_of_list ", " full_string_of_ctyp ctyps ^ ")" - | CT_enum (id, _) -> string_of_id id - | CT_struct (id, ctors) | CT_variant (id, ctors) -> - "struct " ^ string_of_id id - ^ "{ " - ^ Util.string_of_list ", " (fun (id, ctyp) -> string_of_id id ^ " : " ^ full_string_of_ctyp ctyp) ctors - ^ "}" - | CT_string -> "string" - | CT_vector (true, ctyp) -> "vector(dec, " ^ full_string_of_ctyp ctyp ^ ")" - | CT_vector (false, ctyp) -> "vector(inc, " ^ full_string_of_ctyp ctyp ^ ")" - | CT_list ctyp -> "list(" ^ full_string_of_ctyp ctyp ^ ")" - | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" - | CT_poly -> "*" - -let rec map_ctyp f = function - | (CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ - | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp - | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) - | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) - | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) - | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) - | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) - | CT_variant (id, ctors) -> f (CT_variant (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) - -let rec ctyp_equal ctyp1 ctyp2 = - match ctyp1, ctyp2 with - | CT_lint, CT_lint -> true - | CT_lbits d1, CT_lbits d2 -> d1 = d2 - | CT_sbits d1, CT_sbits d2 -> d1 = d2 - | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2 - | CT_bit, CT_bit -> true - | CT_fint n, CT_fint m -> n = m - | CT_unit, CT_unit -> true - | CT_bool, CT_bool -> true - | CT_struct (id1, _), CT_struct (id2, _) -> Id.compare id1 id2 = 0 - | CT_enum (id1, _), CT_enum (id2, _) -> Id.compare id1 id2 = 0 - | CT_variant (id1, _), CT_variant (id2, _) -> Id.compare id1 id2 = 0 - | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> - List.for_all2 ctyp_equal ctyps1 ctyps2 - | CT_string, CT_string -> true - | CT_real, CT_real -> true - | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 - | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 - | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 - | CT_poly, CT_poly -> true - | _, _ -> false - -let rec ctyp_unify ctyp1 ctyp2 = - match ctyp1, ctyp2 with - | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> - List.concat (List.map2 ctyp_unify ctyps1 ctyps2) - - | CT_vector (b1, ctyp1), CT_vector (b2, ctyp2) when b1 = b2 -> - ctyp_unify ctyp1 ctyp2 - - | CT_list ctyp1, CT_list ctyp2 -> ctyp_unify ctyp1 ctyp2 - - | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_unify ctyp1 ctyp2 - - | CT_poly, _ -> [ctyp2] - - | _, _ when ctyp_equal ctyp1 ctyp2 -> [] - | _, _ -> raise (Invalid_argument "ctyp_unify") - -let rec ctyp_suprema = function - | CT_lint -> CT_lint - | CT_lbits d -> CT_lbits d - | CT_fbits (_, d) -> CT_lbits d - | CT_sbits d -> CT_lbits d - | CT_fint _ -> CT_lint - | CT_unit -> CT_unit - | CT_bool -> CT_bool - | CT_real -> CT_real - | CT_bit -> CT_bit - | CT_tup ctyps -> CT_tup (List.map ctyp_suprema ctyps) - | CT_string -> CT_string - | CT_enum (id, ids) -> CT_enum (id, ids) - (* Do we really never want to never call ctyp_suprema on constructor - fields? Doing it causes issues for structs (see - test/c/stack_struct.sail) but it might be wrong to not call it - for nested variants... *) - | CT_struct (id, ctors) -> CT_struct (id, ctors) - | CT_variant (id, ctors) -> CT_variant (id, ctors) - | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) - | CT_list ctyp -> CT_list (ctyp_suprema ctyp) - | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) - | CT_poly -> CT_poly - -let rec ctyp_ids = function - | CT_enum (id, _) -> IdSet.singleton id - | CT_struct (id, ctors) | CT_variant (id, ctors) -> - IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) - | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit - | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty - -let rec unpoly = function - | F_poly f -> unpoly f - | F_call (call, fs) -> F_call (call, List.map unpoly fs) - | F_field (f, field) -> F_field (unpoly f, field) - | F_op (f1, op, f2) -> F_op (unpoly f1, op, unpoly f2) - | F_unary (op, f) -> F_unary (op, unpoly f) - | f -> f - -let rec is_polymorphic = function - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false - | CT_tup ctyps -> List.exists is_polymorphic ctyps - | CT_enum _ -> false - | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors - | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp - | CT_poly -> true - -let pp_id id = - string (string_of_id id) - -let pp_ctyp ctyp = - string (string_of_ctyp ctyp |> Util.yellow |> Util.clear) - -let pp_keyword str = - string ((str |> Util.red |> Util.clear) ^ " ") - -let pp_cval (frag, ctyp) = - string (string_of_fragment ~zencode:false frag) ^^ string " : " ^^ pp_ctyp ctyp - -let rec pp_clexp = function - | CL_id (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | CL_field (clexp, field) -> parens (pp_clexp clexp) ^^ string "." ^^ string field - | CL_tuple (clexp, n) -> parens (pp_clexp clexp) ^^ string "." ^^ string (string_of_int n) - | CL_addr clexp -> string "*" ^^ pp_clexp clexp - | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp - | CL_have_exception -> string "have_exception" - -let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = - match instr with - | I_decl (ctyp, id) -> - pp_keyword "var" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_if (cval, then_instrs, else_instrs, ctyp) -> - let pp_if_block = function - | [] -> string "{}" - | instrs -> surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - in - parens (pp_ctyp ctyp) ^^ space - ^^ pp_keyword "if" ^^ pp_cval cval - ^^ if short then - empty - else - pp_keyword " then" ^^ pp_if_block then_instrs - ^^ pp_keyword " else" ^^ pp_if_block else_instrs - | I_jump (cval, label) -> - pp_keyword "jump" ^^ pp_cval cval ^^ space ^^ string (label |> Util.blue |> Util.clear) - | I_block instrs -> - surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - | I_try_block instrs -> - pp_keyword "try" ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - | I_reset (ctyp, id) -> - pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_init (ctyp, id, cval) -> - pp_keyword "create" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval - | I_reinit (ctyp, id, cval) -> - pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval - | I_funcall (x, _, f, args) -> - separate space [ pp_clexp x; string "="; - string (string_of_id f |> Util.green |> Util.clear) ^^ parens (separate_map (string ", ") pp_cval args) ] - | I_copy (clexp, cval) -> - separate space [pp_clexp clexp; string "="; pp_cval cval] - | I_alias (clexp, cval) -> - pp_keyword "alias" ^^ separate space [pp_clexp clexp; string "="; pp_cval cval] - | I_clear (ctyp, id) -> - pp_keyword "kill" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp - | I_return cval -> - pp_keyword "return" ^^ pp_cval cval - | I_throw cval -> - pp_keyword "throw" ^^ pp_cval cval - | I_comment str -> - string ("// " ^ str |> Util.magenta |> Util.clear) - | I_label str -> - string (str |> Util.blue |> Util.clear) ^^ string ":" - | I_goto str -> - pp_keyword "goto" ^^ string (str |> Util.blue |> Util.clear) - | I_match_failure -> - pp_keyword "match_failure" - | I_undefined ctyp -> - pp_keyword "undefined" ^^ pp_ctyp ctyp - | I_raw str -> - pp_keyword "C" ^^ string (str |> Util.cyan |> Util.clear) - -let pp_ctype_def = function - | CTD_enum (id, ids) -> - pp_keyword "enum" ^^ pp_id id ^^ string " = " - ^^ separate_map (string " | ") pp_id ids - | CTD_struct (id, fields) -> - pp_keyword "struct" ^^ pp_id id ^^ string " = " - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) fields) rbrace - | CTD_variant (id, ctors) -> - pp_keyword "union" ^^ pp_id id ^^ string " = " - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) ctors) rbrace - -let pp_cdef = function - | CDEF_spec (id, ctyps, ctyp) -> - pp_keyword "val" ^^ pp_id id ^^ string " : " ^^ parens (separate_map (comma ^^ space) pp_ctyp ctyps) ^^ string " -> " ^^ pp_ctyp ctyp - ^^ hardline - | CDEF_fundef (id, ret, args, instrs) -> - let ret = match ret with - | None -> empty - | Some id -> space ^^ pp_id id - in - pp_keyword "function" ^^ pp_id id ^^ ret ^^ parens (separate_map (comma ^^ space) pp_id args) ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_reg_dec (id, ctyp, instrs) -> - pp_keyword "register" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_type tdef -> pp_ctype_def tdef ^^ hardline - | CDEF_let (n, bindings, instrs) -> - let pp_binding (id, ctyp) = pp_id id ^^ string " : " ^^ pp_ctyp ctyp in - pp_keyword "let" ^^ string (string_of_int n) ^^ parens (separate_map (comma ^^ space) pp_binding bindings) ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace ^^ space - ^^ hardline - | CDEF_startup (id, instrs)-> - pp_keyword "startup" ^^ pp_id id ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - | CDEF_finish (id, instrs)-> - pp_keyword "finish" ^^ pp_id id ^^ space - ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace - ^^ hardline - -(**************************************************************************) -(* 2. Dependency Graphs *) -(**************************************************************************) - -type graph_node = - | G_label of string - | G_instr of int * instr - | G_start - -let string_of_node = function - | G_label label -> label - | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) - | G_start -> "START" - -module Node = struct - type t = graph_node - let compare gn1 gn2 = - match gn1, gn2 with - | G_label str1, G_label str2 -> String.compare str1 str2 - | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 - | G_start , G_start -> 0 - | G_start , _ -> 1 - | _ , G_start -> -1 - | G_instr _, _ -> 1 - | _ , G_instr _ -> -1 -end - -module NodeGraph = Graph.Make(Node) - -module NM = Map.Make(Node) -module NS = Set.Make(Node) - -type dep_graph = NodeGraph.graph - -let rec fragment_deps = function - | F_id id | F_ref id -> IdSet.singleton id - | F_lit _ -> IdSet.empty - | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag - | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags) - | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2) - | F_current_exception -> IdSet.empty - | F_have_exception -> IdSet.empty - | F_raw _ -> IdSet.empty - -let cval_deps = function (frag, _) -> fragment_deps frag - -let rec clexp_deps = function - | CL_id (id, _) -> IdSet.singleton id - | CL_field (clexp, _) -> clexp_deps clexp - | CL_tuple (clexp, _) -> clexp_deps clexp - | CL_addr clexp -> clexp_deps clexp - | CL_have_exception -> IdSet.empty - | CL_current_exception _ -> IdSet.empty - -(* Return the direct, read/write dependencies of a single instruction *) -let instr_deps = function - | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id - | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id - | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id - | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty - | I_jump (cval, label) -> cval_deps cval, IdSet.empty - | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp - | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp - | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id - | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty - | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty - | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty - | I_label label -> IdSet.empty, IdSet.empty - | I_goto label -> IdSet.empty, IdSet.empty - | I_undefined _ -> IdSet.empty, IdSet.empty - | I_match_failure -> IdSet.empty, IdSet.empty - -(* instrs_graph returns the control-flow graph for a list of - instructions. *) -let instrs_graph instrs = - let icounter = ref 0 in - let graph = ref NodeGraph.empty in - - let rec add_instr last_instrs (I_aux (instr, _) as iaux) = - incr icounter; - let node = G_instr (!icounter, iaux) in - match instr with - | I_block instrs | I_try_block instrs -> - List.fold_left add_instr last_instrs instrs - | I_if (_, then_instrs, else_instrs, _) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - let n1 = List.fold_left add_instr [node] then_instrs in - let n2 = List.fold_left add_instr [node] else_instrs in - incr icounter; - let join = G_instr (!icounter, icomment "join") in - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; - List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; - [join] - | I_return _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | I_label label -> - graph := NodeGraph.add_edge' (G_label label) node !graph; - node :: last_instrs - | I_goto label -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edge' node (G_label label) !graph; - [] - | I_jump (cval, label) -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - graph := NodeGraph.add_edges' (G_label label) [] !graph; - [node] - | I_match_failure -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [] - | _ -> - List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; - [node] - in - ignore (List.fold_left add_instr [G_start] instrs); - let graph = NodeGraph.fix_leaves !graph in - graph - -let make_dot id graph = - Util.opt_colors := false; - let to_string node = String.escaped (string_of_node node) in - let node_color = function - | G_start -> "lightpink" - | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" - | G_instr (_, I_aux (I_init _, _)) -> "springgreen" - | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" - | G_instr (_, I_aux (I_goto _, _)) -> "orange1" - | G_instr (_, I_aux (I_label _, _)) -> "white" - | G_instr (_, I_aux (I_raw _, _)) -> "khaki" - | G_instr (_, I_aux (I_return _, _)) -> "deeppink" - | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" - | G_instr _ -> "azure" - | G_label _ -> "lightpink" - in - let edge_color from_node to_node = - match from_node, to_node with - | G_start , _ -> "goldenrod4" - | G_label _, _ -> "darkgreen" - | _ , G_label _ -> "goldenrod4" - | G_instr _, G_instr _ -> "black" - | _ , _ -> "coral3" - in - let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in - NodeGraph.make_dot node_color edge_color to_string out_chan graph; - close_out out_chan - -let rec map_clexp_ctyp f = function - | CL_id (id, ctyp) -> CL_id (id, f ctyp) - | CL_field (clexp, field) -> CL_field (map_clexp_ctyp f clexp, field) - | CL_tuple (clexp, n) -> CL_tuple (map_clexp_ctyp f clexp, n) - | CL_addr clexp -> CL_addr (map_clexp_ctyp f clexp) - | CL_current_exception ctyp -> CL_current_exception (f ctyp) - | CL_have_exception -> CL_have_exception - -let rec map_instr_ctyp f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl (ctyp, id) -> I_decl (f ctyp, id) - | I_init (ctyp1, id, (frag, ctyp2)) -> I_init (f ctyp1, id, (frag, f ctyp2)) - | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> - I_if ((frag, f ctyp1), List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs, f ctyp2) - | I_jump ((frag, ctyp), label) -> I_jump ((frag, f ctyp), label) - | I_funcall (clexp, extern, id, cvals) -> - I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals) - | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp)) - | I_alias (clexp, (frag, ctyp)) -> I_alias (map_clexp_ctyp f clexp, (frag, f ctyp)) - | I_clear (ctyp, id) -> I_clear (f ctyp, id) - | I_return (frag, ctyp) -> I_return (frag, f ctyp) - | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs) - | I_try_block instrs -> I_try_block (List.map (map_instr_ctyp f) instrs) - | I_throw (frag, ctyp) -> I_throw (frag, f ctyp) - | I_undefined ctyp -> I_undefined (f ctyp) - | I_reset (ctyp, id) -> I_reset (f ctyp, id) - | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2)) - | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr - in - I_aux (instr, aux) - -(** Map over each instruction within an instruction, bottom-up *) -let rec map_instr f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_init _ | I_reset _ | I_reinit _ - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp) - | I_block instrs -> - I_block (List.map (map_instr f) instrs) - | I_try_block instrs -> - I_try_block (List.map (map_instr f) instrs) - in - f (I_aux (instr, aux)) - -(** Map over each instruction in a cdef using map_instr *) -let cdef_map_instr f = function - | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs) - | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr f) instrs) - | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) - | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) - | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) - | CDEF_type tdef -> CDEF_type tdef - -let ctype_def_map_ctyp f = function - | CTD_enum (id, ids) -> CTD_enum (id, ids) - | CTD_struct (id, ctors) -> CTD_struct (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) - | CTD_variant (id, ctors) -> CTD_variant (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) - -(** Map over each ctyp in a cdef using map_instr_ctyp *) -let cdef_map_ctyp f = function - | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, f ctyp, List.map (map_instr_ctyp f) instrs) - | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr_ctyp f) instrs) - | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) - | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) - | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) - | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) - | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) - -(* Map over all sequences of instructions contained within an instruction *) -let rec map_instrs f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr - | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) - | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr - in - I_aux (instr, aux) - -let rec instr_ids (I_aux (instr, _)) = - let reads, writes = instr_deps instr in - IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) - -let rec instr_reads (I_aux (instr, _)) = - let reads, _ = instr_deps instr in - IdSet.of_list (IdSet.elements reads) - -let rec instr_writes (I_aux (instr, _)) = - let _, writes = instr_deps instr in - IdSet.of_list (IdSet.elements writes) - -let rec filter_instrs f instrs = - let filter_instrs' = function - | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) - | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) - | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> - I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) - | instr -> instr - in - List.filter f (List.map filter_instrs' instrs) diff --git a/src/c_backend.ml b/src/c_backend.ml deleted file mode 100644 index 14930d47..00000000 --- a/src/c_backend.ml +++ /dev/null @@ -1,3715 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Ast -open Ast_util -open Bytecode -open Bytecode_util -open Type_check -open PPrint -open Value2 - -open Anf - -module Big_int = Nat_big_num - -let c_verbosity = ref 0 - -let opt_debug_flow_graphs = ref false -let opt_debug_function = ref "" -let opt_trace = ref false -let opt_smt_trace = ref false -let opt_static = ref false -let opt_no_main = ref false -let opt_memo_cache = ref false -let opt_no_rts = ref false -let opt_prefix = ref "z" -let opt_extra_params = ref None -let opt_extra_arguments = ref None - -let extra_params () = - match !opt_extra_params with - | Some str -> str ^ ", " - | _ -> "" - -let extra_arguments is_extern = - match !opt_extra_arguments with - | Some str when not is_extern -> str ^ ", " - | _ -> "" - -(* Optimization flags *) -let optimize_primops = ref false -let optimize_hoist_allocations = ref false -let optimize_struct_updates = ref false -let optimize_alias = ref false -let optimize_experimental = ref false - -let c_debug str = - if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () - -let c_error ?loc:(l=Parse_ast.Unknown) message = - raise (Reporting.err_general l ("\nC backend: " ^ message)) - -let zencode_id = function - | Id_aux (Id str, l) -> Id_aux (Id (Util.zencode_string str), l) - | Id_aux (DeIid str, l) -> Id_aux (Id (Util.zencode_string ("op " ^ str)), l) - -(**************************************************************************) -(* 2. Converting sail types to C types *) -(**************************************************************************) - -let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) -let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) - -(** The context type contains two type-checking - environments. ctx.local_env contains the closest typechecking - environment, usually from the expression we are compiling, whereas - ctx.tc_env is the global type checking environment from - type-checking the entire AST. We also keep track of local variables - in ctx.locals, so we know when their type changes due to flow - typing. *) -type ctx = - { records : (ctyp Bindings.t) Bindings.t; - enums : IdSet.t Bindings.t; - variants : (ctyp Bindings.t) Bindings.t; - tc_env : Env.t; - local_env : Env.t; - locals : (mut * ctyp) Bindings.t; - letbinds : int list; - recursive_functions : IdSet.t; - no_raw : bool; - optimize_smt : bool; - iterate_size : bool; - } - -let initial_ctx env = - { records = Bindings.empty; - enums = Bindings.empty; - variants = Bindings.empty; - tc_env = env; - local_env = env; - locals = Bindings.empty; - letbinds = []; - recursive_functions = IdSet.empty; - no_raw = false; - optimize_smt = true; - iterate_size = false; - } - -let initial_ctx_iterate env = - { (initial_ctx env) with iterate_size = true } - -let rec iterate_size ctx size n m = - if size > 64 then - CT_lint - else if prove __POS__ ctx.local_env (nc_and (nc_lteq (nconstant (min_int size)) n) (nc_lteq m (nconstant (max_int size)))) then - CT_fint size - else - iterate_size ctx (size + 1) n m - -(** Convert a sail type into a C-type. This function can be quite - slow, because it uses ctx.local_env and SMT to analyse the Sail - types and attempts to fit them into the smallest possible C - types, provided ctx.optimize_smt is true (default) **) -let rec ctyp_of_typ ctx typ = - let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in - match typ_aux with - | Typ_id id when string_of_id id = "bit" -> CT_bit - | Typ_id id when string_of_id id = "bool" -> CT_bool - | Typ_id id when string_of_id id = "int" -> CT_lint - | Typ_id id when string_of_id id = "nat" -> CT_lint - | Typ_id id when string_of_id id = "unit" -> CT_unit - | Typ_id id when string_of_id id = "string" -> CT_string - | Typ_id id when string_of_id id = "real" -> CT_real - - | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool - - | Typ_app (id, args) when string_of_id id = "itself" -> - ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) - | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> - begin match destruct_range Env.empty typ with - | None -> assert false (* Checked if range type in guard *) - | Some (kids, constr, n, m) -> - let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - if ctx.iterate_size then - iterate_size ctx 2 (nconstant n) (nconstant m) - else - CT_fint 64 - | n, m when ctx.optimize_smt -> - if ctx.iterate_size then - iterate_size ctx 2 n m - else if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then - CT_fint 64 - else - CT_lint - | _ -> CT_lint - end - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> - CT_list (ctyp_of_typ ctx typ) - - (* When converting a sail bitvector type into C, we have three options in order of efficiency: - - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. - - If the length is less than 64, then use a small bits type, sbits. - - If the length may be larger than 64, use a large bits type lbits. *) - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) - when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - begin match nexp_simp n with - | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) - | n when ctx.optimize_smt && prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction - | _ -> CT_lbits direction - end - - | Typ_app (id, [A_aux (A_nexp n, _); - A_aux (A_order ord, _); - A_aux (A_typ typ, _)]) - when string_of_id id = "vector" -> - let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in - CT_vector (direction, ctyp_of_typ ctx typ) - - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> - CT_ref (ctyp_of_typ ctx typ) - - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) - | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> Bindings.bindings) - | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) - - | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) - - | Typ_exist _ when ctx.optimize_smt -> - (* Use Type_check.destruct_exist when optimising with SMT, to - ensure that we don't cause any type variable clashes in - local_env, and that we can optimize the existential based upon - it's constraints. *) - begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with - | Some (kids, nc, typ) -> - let env = add_existential l kids nc ctx.local_env in - ctyp_of_typ { ctx with local_env = env } typ - | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") - end - - | Typ_exist (_, _, typ) -> ctyp_of_typ ctx typ - - | Typ_var kid -> CT_poly - - | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) - -let rec is_stack_ctyp ctyp = match ctyp with - | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true - | CT_fint n -> n <= 64 - | CT_lbits _ | CT_lint | CT_real | CT_string | CT_list _ | CT_vector _ -> false - | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields - | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) - | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps - | CT_ref ctyp -> true - | CT_poly -> true - -let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) - -let is_fbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_fbits _ -> true - | _ -> false - -let is_sbits_typ ctx typ = - match ctyp_of_typ ctx typ with - | CT_sbits _ -> true - | _ -> false - -let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty - -(**************************************************************************) -(* 3. Optimization of primitives and literals *) -(**************************************************************************) - -let hex_char = - let open Sail2_values in - function - | '0' -> [B0; B0; B0; B0] - | '1' -> [B0; B0; B0; B1] - | '2' -> [B0; B0; B1; B0] - | '3' -> [B0; B0; B1; B1] - | '4' -> [B0; B1; B0; B0] - | '5' -> [B0; B1; B0; B1] - | '6' -> [B0; B1; B1; B0] - | '7' -> [B0; B1; B1; B1] - | '8' -> [B1; B0; B0; B0] - | '9' -> [B1; B0; B0; B1] - | 'A' | 'a' -> [B1; B0; B1; B0] - | 'B' | 'b' -> [B1; B0; B1; B1] - | 'C' | 'c' -> [B1; B1; B0; B0] - | 'D' | 'd' -> [B1; B1; B0; B1] - | 'E' | 'e' -> [B1; B1; B1; B0] - | 'F' | 'f' -> [B1; B1; B1; B1] - | _ -> failwith "Invalid hex character" - -let literal_to_fragment (L_aux (l_aux, _) as lit) = - match l_aux with - | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - Some (F_lit (V_int n), CT_fint 64) - | L_hex str when String.length str <= 16 -> - let padding = 16 - String.length str in - let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in - let content = Util.string_to_list str |> List.map hex_char |> List.concat in - Some (F_lit (V_bits (padding @ content)), CT_fbits (String.length str * 4, true)) - | L_unit -> Some (F_lit V_unit, CT_unit) - | L_true -> Some (F_lit (V_bool true), CT_bool) - | L_false -> Some (F_lit (V_bool false), CT_bool) - | _ -> None - -let c_literals ctx = - let rec c_literal env l = function - | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> - begin - match literal_to_fragment lit with - | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) - | None -> v - end - | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) - | v -> v - in - map_aval c_literal - -let mask m = - if Big_int.less_equal m (Big_int.of_int 64) then - let n = Big_int.to_int m in - if n = 0 then - "UINT64_C(0)" - else if n mod 4 = 0 then - "UINT64_C(0x" ^ String.make (16 - n / 4) '0' ^ String.make (n / 4) 'F' ^ ")" - else - "UINT64_C(" ^ String.make (64 - n) '0' ^ String.make n '1' ^ ")" - else - failwith "Tried to create a mask literal for a vector greater than 64 bits." - -let rec is_bitvector = function - | [] -> true - | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals - | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals - | _ :: _ -> false - -let rec value_of_aval_bit = function - | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 - | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 - | _ -> assert false - -let rec c_aval ctx = function - | AV_lit (lit, typ) as v -> - begin - match literal_to_fragment lit with - | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) - | None -> v - end - | AV_C_fragment (str, typ, ctyp) -> AV_C_fragment (str, typ, ctyp) - (* An id can be converted to a C fragment if it's type can be - stack-allocated. *) - | AV_id (id, lvar) as v -> - begin - match lvar with - | Local (_, typ) -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp then - begin - try - (* We need to check that id's type hasn't changed due to flow typing *) - let _, ctyp' = Bindings.find id ctx.locals in - if ctyp_equal ctyp ctyp' then - AV_C_fragment (F_id id, typ, ctyp) - else - (* id's type changed due to flow - typing, so it's really still heap allocated! *) - v - with - (* Hack: Assuming global letbindings don't change from flow typing... *) - Not_found -> AV_C_fragment (F_id id, typ, ctyp) - end - else - v - | Register (_, _, typ) when is_stack_typ ctx typ -> - let ctyp = ctyp_of_typ ctx typ in - if is_stack_ctyp ctyp then - AV_C_fragment (F_id id, typ, ctyp) - else - v - | _ -> v - end - | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> - let bitstring = F_lit (V_bits (List.map value_of_aval_bit v)) in - AV_C_fragment (bitstring, typ, CT_fbits (List.length v, true)) - | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) - | aval -> aval - -let is_c_fragment = function - | AV_C_fragment _ -> true - | _ -> false - -let c_fragment = function - | AV_C_fragment (frag, _, _) -> frag - | _ -> assert false - -let v_mask_lower i = F_lit (V_bits (Util.list_init i (fun _ -> Sail2_values.B1))) - -(* Map over all the functions in an aexp. *) -let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = - let ctx = { ctx with local_env = env } in - let aexp = match aexp with - | AE_app (id, vs, typ) -> f ctx id vs typ - - | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) - - | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) - - | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) - - | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> - let aexp1 = analyze_functions ctx f aexp1 in - (* Use aexp2's environment because it will contain constraints for id *) - let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in - let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in - AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) - - | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) - - | AE_if (aval, aexp1, aexp2, typ) -> - AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) - - | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) - - | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> - let aexp1 = analyze_functions ctx f aexp1 in - let aexp2 = analyze_functions ctx f aexp2 in - let aexp3 = analyze_functions ctx f aexp3 in - let aexp4 = analyze_functions ctx f aexp4 in - (* Currently we assume that loop indexes are always safe to put into an int64 *) - let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in - AE_for (id, aexp1, aexp2, aexp3, order, aexp4) - - | AE_case (aval, cases, typ) -> - let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = - let pat_bindings = Bindings.bindings (apat_types pat) in - let ctx = { ctx with local_env = env } in - let ctx = - List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings - in - pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 - in - AE_case (aval, List.map analyze_case cases, typ) - - | AE_try (aexp, cases, typ) -> - AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) - - | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v - in - AE_aux (aexp, env, l) - -let analyze_primop' ctx id args typ = - let no_change = AE_app (id, args, typ) in - let args = List.map (c_aval ctx) args in - let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in - - let v_one = F_lit (V_int (Big_int.of_int 1)) in - let v_int n = F_lit (V_int (Big_int.of_int n)) in - - c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); - - match extern, args with - | "eq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) - | "eq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_call ("eq_sbits", [v1; v2]), typ, CT_bool)) - - | "neq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ, CT_bool)) - | "neq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_call ("neq_sbits", [v1; v2]), typ, CT_bool)) - - | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> - AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) - - | "zeros", [_] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_raw "0x0", typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) - | _ -> no_change - end - - | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) - | _ -> no_change - end - - | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) - | _ -> no_change - end - - | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)] - when n <= 63 -> - AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord))) - - | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool)) - | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) - | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool)) - | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> - AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool)) - - | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) - | "xor_bits", [AV_C_fragment (v1, _, (CT_sbits _ as ctyp)); AV_C_fragment (v2, _, CT_sbits _)] -> - AE_val (AV_C_fragment (F_call ("xor_sbits", [v1; v2]), typ, ctyp)) - - | "or_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) - - | "and_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> - AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) - - | "not_bits", [AV_C_fragment (v, _, ctyp)] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ, ctyp)) - | _ -> no_change - end - - | "vector_subrange", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] - when is_fbits_typ ctx typ -> - let len = F_op (f, "-", F_op (t, "-", v_one)) in - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), - typ, - ctyp_of_typ ctx typ)) - - | "vector_access", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (n, _, _)] -> - AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) - - | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> - AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) - - | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] - when is_fbits_typ ctx typ -> - AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), - typ, - ctyp_of_typ ctx typ)) - - | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] - when is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("sslice", [vec; start; len]), typ, ctyp_of_typ ctx typ)) - - | "undefined_bit", _ -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) - - (* Optimized routines for all combinations of fixed and small bits - appends, where the result is guaranteed to be smaller than 64. *) - | "append", [AV_C_fragment (vec1, _, CT_fbits (0, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2)) as v2] - when ord1 = ord2 -> - AE_val v2 - | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] - when ord1 = ord2 && n1 + n2 <= 64 -> - AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) - - | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ)) - - | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits ord2)] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ)) - - | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_sbits ord2)] - when ord1 = ord2 && is_sbits_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ)) - - | "undefined_vector", [AV_C_fragment (len, _, _); _] -> - begin match destruct_vector ctx.tc_env typ with - | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) - when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "sail_unsigned", [AV_C_fragment (frag, vtyp, _)] -> - begin match destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _) - when Big_int.less_equal n (Big_int.of_int 63) && is_stack_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("fast_unsigned", [frag]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "sail_signed", [AV_C_fragment (frag, vtyp, _)] -> - begin match destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ -> - AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> - begin match destruct_range Env.empty typ with - | None -> no_change - | Some (kids, constr, n, m) -> - match nexp_simp n, nexp_simp m with - | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) - when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> - AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) - | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> - AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) - | _ -> no_change - end - - | "neg_int", [AV_C_fragment (frag, _, _)] -> - AE_val (AV_C_fragment (F_op (v_int 0, "-", frag), typ, CT_fint 64)) - - | "replicate_bits", [AV_C_fragment (vec, vtyp, _); AV_C_fragment (times, _, _)] -> - begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with - | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) - when Big_int.less_equal n (Big_int.of_int 64) -> - AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ, ctyp_of_typ ctx typ)) - | _ -> no_change - end - - | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true)); - AV_C_fragment (hi, _, CT_fint 64); - AV_C_fragment (lo, _, CT_fint 64); - AV_C_fragment (ys, _, CT_fbits (m, true))] -> - AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) - - | "undefined_bool", _ -> - AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) - - | _, _ -> - c_debug (lazy ("No optimization routine found")); - no_change - -let analyze_primop ctx id args typ = - let no_change = AE_app (id, args, typ) in - if !optimize_primops then - try analyze_primop' ctx id args typ with - | Failure str -> - (c_debug (lazy ("Analyze primop failed for id " ^ string_of_id id ^ " reason: " ^ str))); - no_change - else - no_change - -(**************************************************************************) -(* 4. Conversion to low-level AST *) -(**************************************************************************) - -(** We now use a low-level AST (see language/bytecode.ott) that is - only slightly abstracted away from C. To be succint in comments we - usually refer to this as Sail IR or IR rather than low-level AST - repeatedly. - - The general idea is ANF expressions are converted into lists of - instructions (type instr) where allocations and deallocations are - now made explicit. ANF values (aval) are mapped to the cval type, - which is even simpler still. Some things are still more abstract - than in C, so the type definitions follow the sail type definition - structure, just with typ (from ast.ml) replaced with - ctyp. Top-level declarations that have no meaning for the backend - are not included at this level. - - The convention used here is that functions of the form compile_X - compile the type X into types in this AST, so compile_aval maps - avals into cvals. Note that the return types for these functions - are often quite complex, and they usually return some tuple - containing setup instructions (to allocate memory for the - expression), cleanup instructions (to deallocate that memory) and - possibly typing information about what has been translated. **) - -let ctype_def_ctyps = function - | CTD_enum _ -> [] - | CTD_struct (_, fields) -> List.map snd fields - | CTD_variant (_, ctors) -> List.map snd ctors - -let cval_ctyp = function (_, ctyp) -> ctyp - -let rec clexp_ctyp = function - | CL_id (_, ctyp) -> ctyp - | CL_field (clexp, field) -> - begin match clexp_ctyp clexp with - | CT_struct (id, ctors) -> - begin - try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with - | Not_found -> c_error ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field) - end - | ctyp -> c_error ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp) - end - | CL_addr clexp -> - begin match clexp_ctyp clexp with - | CT_ref ctyp -> ctyp - | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) - end - | CL_tuple (clexp, n) -> - begin match clexp_ctyp clexp with - | CT_tup typs -> - begin - try List.nth typs n with - | _ -> c_error "Tuple assignment index out of bounds" - end - | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) - end - | CL_have_exception -> CT_bool - | CL_current_exception ctyp -> ctyp - -let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) - -let rec instr_ctyps (I_aux (instr, aux)) = - match instr with - | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> [ctyp] - | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> [ctyp; cval_ctyp cval] - | I_if (cval, instrs1, instrs2, ctyp) -> - ctyp :: cval_ctyp cval :: List.concat (List.map instr_ctyps instrs1 @ List.map instr_ctyps instrs2) - | I_funcall (clexp, _, _, cvals) -> - clexp_ctyp clexp :: List.map cval_ctyp cvals - | I_copy (clexp, cval) | I_alias (clexp, cval) -> [clexp_ctyp clexp; cval_ctyp cval] - | I_block instrs | I_try_block instrs -> List.concat (List.map instr_ctyps instrs) - | I_throw cval | I_jump (cval, _) | I_return cval -> [cval_ctyp cval] - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure -> [] - -let rec c_ast_registers = function - | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast - | _ :: ast -> c_ast_registers ast - | [] -> [] - -let cdef_ctyps ctx = function - | CDEF_reg_dec (_, ctyp, instrs) -> ctyp :: List.concat (List.map instr_ctyps instrs) - | CDEF_spec (_, ctyps, ctyp) -> ctyp :: ctyps - | CDEF_fundef (id, _, _, instrs) -> - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let arg_ctyps, ret_ctyp = - List.map (ctyp_of_typ ctx) arg_typs, - ctyp_of_typ { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } ret_typ - in - ret_ctyp :: arg_ctyps @ List.concat (List.map instr_ctyps instrs) - - | CDEF_startup (id, instrs) | CDEF_finish (id, instrs) -> List.concat (List.map instr_ctyps instrs) - | CDEF_type tdef -> ctype_def_ctyps tdef - | CDEF_let (_, bindings, instrs) -> - List.map snd bindings - @ List.concat (List.map instr_ctyps instrs) - -let is_ct_enum = function - | CT_enum _ -> true - | _ -> false - -let is_ct_variant = function - | CT_variant _ -> true - | _ -> false - -let is_ct_tup = function - | CT_tup _ -> true - | _ -> false - -let is_ct_list = function - | CT_list _ -> true - | _ -> false - -let is_ct_vector = function - | CT_vector _ -> true - | _ -> false - -let is_ct_struct = function - | CT_struct _ -> true - | _ -> false - -let is_ct_ref = function - | CT_ref _ -> true - | _ -> false - -let rec chunkify n xs = - match Util.take n xs, Util.drop n xs with - | xs, [] -> [xs] - | xs, ys -> xs :: chunkify n ys - -let rec compile_aval l ctx = function - | AV_C_fragment (frag, typ, ctyp) -> - let ctyp' = ctyp_of_typ ctx typ in - if not (ctyp_equal ctyp ctyp' || ctx.iterate_size) then - raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp')); - [], (frag, ctyp_of_typ ctx typ), [] - - | AV_id (id, typ) -> - begin - try - let _, ctyp = Bindings.find id ctx.locals in - [], (F_id id, ctyp), [] - with - | Not_found -> - [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), [] - end - - | AV_ref (id, typ) -> - [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] - - | AV_lit (L_aux (L_string str, _), typ) -> - [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), [] - - | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> - let gs = gensym () in - [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)], - (F_id gs, CT_lint), - [iclear CT_lint gs] - - | AV_lit (L_aux (L_num n, _), typ) -> - let gs = gensym () in - [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)], - (F_id gs, CT_lint), - [iclear CT_lint gs] - - | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), [] - | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), [] - - | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), [] - | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), [] - - | AV_lit (L_aux (L_real str, _), _) -> - let gs = gensym () in - [iinit CT_real gs (F_lit (V_string str), CT_string)], - (F_id gs, CT_real), - [iclear CT_real gs] - - | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), [] - - | AV_lit (L_aux (_, l) as lit, _) -> - c_error ~loc:l ("Encountered unexpected literal " ^ string_of_lit lit) - - | AV_tuple avals -> - let elements = List.map (compile_aval l ctx) avals in - let cvals = List.map (fun (_, cval, _) -> cval) elements in - let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in - let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in - let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in - let gs = gensym () in - setup - @ [idecl tup_ctyp gs] - @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals, - (F_id gs, CT_tup (List.map cval_ctyp cvals)), - [iclear tup_ctyp gs] - @ cleanup - - | AV_record (fields, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let gs = gensym () in - let compile_fields (id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] - @ field_cleanup - in - [idecl ctyp gs] - @ List.concat (List.map compile_fields (Bindings.bindings fields)), - (F_id gs, ctyp), - [iclear ctyp gs] - - | AV_vector ([], _) -> - c_error "Encountered empty vector literal" - - (* Convert a small bitvector to a uint64_t literal. *) - | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 -> - begin - let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in - let len = List.length avals in - match destruct_vector ctx.tc_env typ with - | Some (_, Ord_aux (Ord_inc, _), _) -> - [], (bitstring, CT_fbits (len, false)), [] - | Some (_, Ord_aux (Ord_dec, _), _) -> - [], (bitstring, CT_fbits (len, true)), [] - | Some _ -> - c_error "Encountered order polymorphic bitvector literal" - | None -> - c_error "Encountered vector literal without vector type" - end - - (* Convert a bitvector literal that is larger than 64-bits to a - variable size bitvector, converting it in 64-bit chunks. *) - | AV_vector (avals, typ) when is_bitvector avals -> - let len = List.length avals in - let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in - let first_chunk = bitstring (Util.take (len mod 64) avals) in - let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in - let gs = gensym () in - [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))] - @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true)) - (mk_id "append_64") - [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks, - (F_id gs, CT_lbits true), - [iclear (CT_lbits true) gs] - - (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) - when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 -> - let len = List.length avals in - let direction = match ord with - | Ord_aux (Ord_inc, _) -> false - | Ord_aux (Ord_dec, _) -> true - | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found" - in - let gs = gensym () in - let ctyp = CT_fbits (len, direction) in - let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in - let aval_mask i aval = - let setup, cval, cleanup = compile_aval l ctx aval in - match cval with - | (F_lit (V_bit Sail2_values.B0), _) -> [] - | (F_lit (V_bit Sail2_values.B1), _) -> - [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] - | _ -> - setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup - in - [idecl ctyp gs; - icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)] - @ List.concat (List.mapi aval_mask (List.rev avals)), - (F_id gs, ctyp), - [] - - (* Compiling a vector literal that isn't a bitvector *) - | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _)) - when string_of_id id = "vector" -> - let len = List.length avals in - let direction = match ord with - | Ord_aux (Ord_inc, _) -> false - | Ord_aux (Ord_dec, _) -> true - | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found" - in - let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in - let gs = gensym () in - let aval_set i aval = - let setup, cval, cleanup = compile_aval l ctx aval in - setup - @ [iextern (CL_id (gs, vector_ctyp)) - (mk_id "internal_vector_update") - [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]] - @ cleanup - in - [idecl vector_ctyp gs; - iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]] - @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)), - (F_id gs, vector_ctyp), - [iclear vector_ctyp gs] - - | AV_vector _ as aval -> - c_error ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type") - - | AV_list (avals, Typ_aux (typ, _)) -> - let ctyp = match typ with - | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ - | _ -> c_error "Invalid list type" - in - let gs = gensym () in - let mk_cons aval = - let setup, cval, cleanup = compile_aval l ctx aval in - setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup - in - [idecl (CT_list ctyp) gs] - @ List.concat (List.map mk_cons (List.rev avals)), - (F_id gs, CT_list ctyp), - [iclear (CT_list ctyp) gs] - -let compile_funcall l ctx id args typ = - let setup = ref [] in - let cleanup = ref [] in - - let quant, Typ_aux (fn_typ, _) = - try Env.get_val_spec id ctx.local_env - with Type_error _ -> - c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env - in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - let final_ctyp = ctyp_of_typ ctx typ in - - let setup_arg ctyp aval = - let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in - setup := List.rev arg_setup @ !setup; - cleanup := arg_cleanup @ !cleanup; - let have_ctyp = cval_ctyp cval in - if is_polymorphic ctyp then - (F_poly (fst cval), have_ctyp) - else if ctyp_equal ctyp have_ctyp then - cval - else - let gs = gensym () in - setup := iinit ctyp gs cval :: !setup; - cleanup := iclear ctyp gs :: !cleanup; - (F_id gs, ctyp) - in - - assert (List.length arg_ctyps = List.length args); - - let setup_args = List.map2 setup_arg arg_ctyps args in - - List.rev !setup, - begin fun clexp -> - if ctyp_equal (clexp_ctyp clexp) ret_ctyp then - ifuncall clexp id setup_args - else - let gs = gensym () in - iblock [idecl ret_ctyp gs; - ifuncall (CL_id (gs, ret_ctyp)) id setup_args; - icopy l clexp (F_id gs, ret_ctyp); - iclear ret_ctyp gs] - end, - !cleanup - -let rec apat_ctyp ctx (AP_aux (apat, _, _)) = - match apat with - | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats) - | AP_global (_, typ) -> ctyp_of_typ ctx typ - | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat) - | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ - | AP_app (_, _, typ) -> ctyp_of_typ ctx typ - -let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = - let ctx = { ctx with local_env = env } in - match apat_aux, cval with - | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env -> - [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label], - [], - ctx - - | AP_global (pid, typ), (frag, ctyp) -> - let global_ctyp = ctyp_of_typ ctx typ in - [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx - - | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp -> - begin match Env.lookup_id pid ctx.tc_env with - | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx - | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx - end - - | AP_id (pid, typ), _ -> - let ctyp = cval_ctyp cval in - let id_ctyp = ctyp_of_typ ctx typ in - c_debug (lazy ("Adding local " ^ string_of_id pid ^ " : " ^ string_of_ctyp id_ctyp)); - let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in - [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx - - | AP_tup apats, (frag, ctyp) -> - begin - let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in - let fold (instrs, cleanup, n, ctx) apat ctyp = - let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in - instrs @ instrs', cleanup' @ cleanup, n + 1, ctx - in - match ctyp with - | CT_tup ctyps -> - let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in - instrs, cleanup, ctx - | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp) - end - - | AP_app (ctor, apat, variant_typ), (frag, ctyp) -> - begin match ctyp with - | CT_variant (_, ctors) -> - let ctor_c_id = string_of_id ctor in - let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in - (* These should really be the same, something has gone wrong if they are not. *) - if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then - c_error ~loc:l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ))) - else (); - let ctor_c_id, ctor_ctyp = - if is_polymorphic ctor_ctyp then - let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in - (if List.length unification > 0 then - ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification - else - ctor_c_id), - ctyp_suprema (apat_ctyp ctx apat) - else - ctor_c_id, ctor_ctyp - in - let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in - [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label] - @ instrs, - cleanup, - ctx - | ctyp -> - c_error ~loc:l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s" - (string_of_id ctor) - (string_of_typ variant_typ) - (string_of_fragment ~zencode:false frag) - (string_of_ctyp ctyp)) - end - - | AP_wild _, _ -> [], [], ctx - - | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) -> - let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in - let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in - [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx - - | AP_cons _, (_, _) -> c_error "Tried to pattern match cons on non list type" - - | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx - -let unit_fragment = (F_lit V_unit, CT_unit) - -(** GLOBAL: label_counter is used to make sure all labels have unique - names. Like gensym_counter it should be safe to reset between - top-level definitions. **) -let label_counter = ref 0 - -let label str = - let str = str ^ string_of_int !label_counter in - incr label_counter; - str - -let pointer_assign ctyp1 ctyp2 = - match ctyp1 with - | CT_ref ctyp1 -> true - | _ -> false - -let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = - let ctx = { ctx with local_env = env } in - match aexp_aux with - | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) -> - let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in - let setup, call, cleanup = compile_aexp ctx binding in - let letb_setup, letb_cleanup = - [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id] - in - let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in - let setup, call, cleanup = compile_aexp ctx body in - letb_setup @ setup, call, cleanup @ letb_cleanup - - | AE_app (id, vs, typ) -> - compile_funcall l ctx id vs typ - - | AE_val aval -> - let setup, cval, cleanup = compile_aval l ctx aval in - setup, (fun clexp -> icopy l clexp cval), cleanup - - (* Compile case statements *) - | AE_case (aval, cases, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in - let case_return_id = gensym () in - let finish_match_label = label "finish_match_" in - let compile_case (apat, guard, body) = - let trivial_guard = match guard with - | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true - | _ -> false - in - let case_label = label "case_" in - c_debug (lazy ("Compiling match")); - let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in - c_debug (lazy ("Compiled match")); - let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let case_instrs = - destructure @ [icomment "end destructuring"] - @ (if not trivial_guard then - guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit] - @ [icomment "end guard"] - else []) - @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup - @ [igoto finish_match_label] - in - if is_dead_aexp body then - [ilabel case_label] - else - [iblock case_instrs; ilabel case_label] - in - [icomment "begin match"] - @ aval_setup @ [idecl ctyp case_return_id] - @ List.concat (List.map compile_case cases) - @ [imatch_failure ()] - @ [ilabel finish_match_label], - (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)), - [iclear ctyp case_return_id] - @ aval_cleanup - @ [icomment "end match"] - - (* Compile try statement *) - | AE_try (aexp, cases, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in - let try_return_id = gensym () in - let handled_exception_label = label "handled_exception_" in - let fallthrough_label = label "fallthrough_exception_" in - let compile_case (apat, guard, body) = - let trivial_guard = match guard with - | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) - | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true - | _ -> false - in - let try_label = label "try_" in - let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in - let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in - let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let case_instrs = - destructure @ [icomment "end destructuring"] - @ (if not trivial_guard then - guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup - @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label] - @ [icomment "end guard"] - else []) - @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup - @ [igoto handled_exception_label] - in - [iblock case_instrs; ilabel try_label] - in - assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); - [idecl ctyp try_return_id; - itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); - ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label] - @ List.concat (List.map compile_case cases) - @ [igoto fallthrough_label; - ilabel handled_exception_label; - icopy l CL_have_exception (F_lit (V_bool false), CT_bool); - ilabel fallthrough_label], - (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)), - [] - - | AE_if (aval, then_aexp, else_aexp, if_typ) -> - if is_dead_aexp then_aexp then - compile_aexp ctx else_aexp - else if is_dead_aexp else_aexp then - compile_aexp ctx then_aexp - else - let if_ctyp = ctyp_of_typ ctx if_typ in - let compile_branch aexp = - let setup, call, cleanup = compile_aexp ctx aexp in - fun clexp -> setup @ [call clexp] @ cleanup - in - let setup, cval, cleanup = compile_aval l ctx aval in - setup, - (fun clexp -> iif cval - (compile_branch then_aexp clexp) - (compile_branch else_aexp clexp) - if_ctyp), - cleanup - - (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *) - | AE_record_update (aval, fields, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let ctors = match ctyp with - | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors - | _ -> c_error "Cannot perform record update for non-record type" - in - let gs = gensym () in - let compile_fields (id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] - @ field_cleanup - in - let setup, cval, cleanup = compile_aval l ctx aval in - [idecl ctyp gs] - @ setup - @ [icopy l (CL_id (gs, ctyp)) cval] - @ cleanup - @ List.concat (List.map compile_fields (Bindings.bindings fields)), - (fun clexp -> icopy l clexp (F_id gs, ctyp)), - [iclear ctyp gs] - - | AE_short_circuit (SC_and, aval, aexp) -> - let left_setup, cval, left_cleanup = compile_aval l ctx aval in - let right_setup, call, right_cleanup = compile_aexp ctx aexp in - let gs = gensym () in - left_setup - @ [ idecl CT_bool gs; - iif cval - (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)] - CT_bool ] - @ left_cleanup, - (fun clexp -> icopy l clexp (F_id gs, CT_bool)), - [] - | AE_short_circuit (SC_or, aval, aexp) -> - let left_setup, cval, left_cleanup = compile_aval l ctx aval in - let right_setup, call, right_cleanup = compile_aexp ctx aexp in - let gs = gensym () in - left_setup - @ [ idecl CT_bool gs; - iif cval - [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)] - (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) - CT_bool ] - @ left_cleanup, - (fun clexp -> icopy l clexp (F_id gs, CT_bool)), - [] - - (* This is a faster assignment rule for updating fields of a - struct. Turned on by !optimize_struct_updates. *) - | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _)) - when Id.compare id rid = 0 && !optimize_struct_updates -> - c_debug (lazy ("Optimizing struct update")); - let compile_fields (field_id, aval) = - let field_setup, cval, field_cleanup = compile_aval l ctx aval in - field_setup - @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval] - @ field_cleanup - in - List.concat (List.map compile_fields (Bindings.bindings fields)), - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_assign (id, assign_typ, aexp) -> - let assign_ctyp = - match Bindings.find_opt id ctx.locals with - | Some (_, ctyp) -> ctyp - | None -> ctyp_of_typ ctx assign_typ - in - let setup, call, cleanup = compile_aexp ctx aexp in - setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup - - | AE_block (aexps, aexp, _) -> - let block = compile_block ctx aexps in - let setup, call, cleanup = compile_aexp ctx aexp in - block @ setup, call, cleanup - - | AE_loop (While, cond, body) -> - let loop_start_label = label "while_" in - let loop_end_label = label "wend_" in - let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let unit_gs = gensym () in - let loop_test = (F_unary ("!", F_id gs), CT_bool) in - [idecl CT_bool gs; idecl CT_unit unit_gs] - @ [ilabel loop_start_label] - @ [iblock (cond_setup - @ [cond_call (CL_id (gs, CT_bool))] - @ cond_cleanup - @ [ijump loop_test loop_end_label] - @ body_setup - @ [body_call (CL_id (unit_gs, CT_unit))] - @ body_cleanup - @ [igoto loop_start_label])] - @ [ilabel loop_end_label], - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_loop (Until, cond, body) -> - let loop_start_label = label "repeat_" in - let loop_end_label = label "until_" in - let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let gs = gensym () in - let unit_gs = gensym () in - let loop_test = (F_id gs, CT_bool) in - [idecl CT_bool gs; idecl CT_unit unit_gs] - @ [ilabel loop_start_label] - @ [iblock (body_setup - @ [body_call (CL_id (unit_gs, CT_unit))] - @ body_cleanup - @ cond_setup - @ [cond_call (CL_id (gs, CT_bool))] - @ cond_cleanup - @ [ijump loop_test loop_end_label] - @ [igoto loop_start_label])] - @ [ilabel loop_end_label], - (fun clexp -> icopy l clexp unit_fragment), - [] - - | AE_cast (aexp, typ) -> compile_aexp ctx aexp - - | AE_return (aval, typ) -> - let fn_return_ctyp = match Env.get_ret_typ env with - | Some typ -> ctyp_of_typ ctx typ - | None -> c_error ~loc:l "No function return type found when compiling return statement" - in - (* Cleanup info will be re-added by fix_early_return *) - let return_setup, cval, _ = compile_aval l ctx aval in - let creturn = - if ctyp_equal fn_return_ctyp (cval_ctyp cval) then - [ireturn cval] - else - let gs = gensym () in - [idecl fn_return_ctyp gs; - icopy l (CL_id (gs, fn_return_ctyp)) cval; - ireturn (F_id gs, fn_return_ctyp)] - in - return_setup @ creturn, - (fun clexp -> icomment "unreachable after return"), - [] - - | AE_throw (aval, typ) -> - (* Cleanup info will be handled by fix_exceptions *) - let throw_setup, cval, _ = compile_aval l ctx aval in - throw_setup @ [ithrow cval], - (fun clexp -> icomment "unreachable after throw"), - [] - - | AE_field (aval, id, typ) -> - let ctyp = ctyp_of_typ ctx typ in - let setup, cval, cleanup = compile_aval l ctx aval in - setup, - (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)), - cleanup - - | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) -> - (* We assume that all loop indices are safe to put in a CT_fint. *) - let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in - - let is_inc = match ord with - | Ord_inc -> true - | Ord_dec -> false - | Ord_var _ -> c_error "Polymorphic loop direction in C backend" - in - - (* Loop variables *) - let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in - let from_gs = gensym () in - let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in - let to_gs = gensym () in - let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in - let step_gs = gensym () in - let variable_init gs setup call cleanup = - [idecl (CT_fint 64) gs; - iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)] - in - - let loop_start_label = label "for_start_" in - let loop_end_label = label "for_end_" in - let body_setup, body_call, body_cleanup = compile_aexp ctx body in - let body_gs = gensym () in - - variable_init from_gs from_setup from_call from_cleanup - @ variable_init to_gs to_setup to_call to_cleanup - @ variable_init step_gs step_setup step_call step_cleanup - @ [iblock ([idecl (CT_fint 64) loop_var; - icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64)); - idecl CT_unit body_gs; - iblock ([ilabel loop_start_label] - @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label] - @ body_setup - @ [body_call (CL_id (body_gs, CT_unit))] - @ body_cleanup - @ [icopy l (CL_id (loop_var, (CT_fint 64))) - (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))] - @ [igoto loop_start_label]); - ilabel loop_end_label])], - (fun clexp -> icopy l clexp unit_fragment), - [] - -and compile_block ctx = function - | [] -> [] - | exp :: exps -> - let setup, call, cleanup = compile_aexp ctx exp in - let rest = compile_block ctx exps in - let gs = gensym () in - iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest - -(** Compile a sail type definition into a IR one. Most of the - actual work of translating the typedefs into C is done by the code - generator, as it's easy to keep track of structs, tuples and unions - in their sail form at this level, and leave the fiddly details of - how they get mapped to C in the next stage. This function also adds - details of the types it compiles to the context, ctx, which is why - it returns a ctypdef * ctx pair. **) -let compile_type_def ctx (TD_aux (type_def, _)) = - match type_def with - | TD_enum (id, ids, _) -> - CTD_enum (id, ids), - { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } - - | TD_record (id, _, ctors, _) -> - let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in - CTD_struct (id, Bindings.bindings ctors), - { ctx with records = Bindings.add id ctors ctx.records } - - | TD_variant (id, typq, tus, _) -> - let compile_tu = function - | Tu_aux (Tu_ty_id (typ, id), _) -> - let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in - ctyp_of_typ ctx typ, id - in - let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in - CTD_variant (id, Bindings.bindings ctus), - { ctx with variants = Bindings.add id ctus ctx.variants } - - (* Will be re-written before here, see bitfield.ml *) - | TD_bitfield _ -> failwith "Cannot compile TD_bitfield" - (* All type abbreviations are filtered out in compile_def *) - | TD_abbrev _ -> assert false - -let instr_split_at f = - let rec instr_split_at' f before = function - | [] -> (List.rev before, []) - | instr :: instrs when f instr -> (List.rev before, instr :: instrs) - | instr :: instrs -> instr_split_at' f (instr :: before) instrs - in - instr_split_at' f [] - -let generate_cleanup instrs = - let generate_cleanup' (I_aux (instr, _)) = - match instr with - | I_init (ctyp, id, cval) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)] - | I_decl (ctyp, id) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)] - | instr -> [] - in - let is_clear ids = function - | I_aux (I_clear (_, id), _) -> IdSet.add id ids - | _ -> ids - in - let cleaned = List.fold_left is_clear IdSet.empty instrs in - instrs - |> List.map generate_cleanup' - |> List.concat - |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) - |> List.map snd - -(** Functions that have heap-allocated return types are implemented by - passing a pointer a location where the return value should be - stored. The ANF -> Sail IR pass for expressions simply outputs an - I_return instruction for any return value, so this function walks - over the IR ast for expressions and modifies the return statements - into code that sets that pointer, as well as adds extra control - flow to cleanup heap-allocated variables correctly when a function - terminates early. See the generate_cleanup function for how this is - done. *) -let fix_early_return ret ctx instrs = - let end_function_label = label "end_function_" in - let is_return_recur (I_aux (instr, _)) = - match instr with - | I_return _ | I_if _ | I_block _ -> true - | _ -> false - in - let rec rewrite_return historic instrs = - match instr_split_at is_return_recur instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_return (historic @ before) instrs)] - @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] - @ rewrite_return historic after - | before, I_aux (I_return cval, (_, l)) :: after -> - let cleanup_label = label "cleanup_" in - let end_cleanup_label = label "end_cleanup_" in - before - @ [icopy l ret cval; - igoto cleanup_label] - (* This is probably dead code until cleanup_label, but how can we be sure there are no jumps into it? *) - @ rewrite_return (historic @ before) after - @ [igoto end_cleanup_label] - @ [ilabel cleanup_label] - @ generate_cleanup (historic @ before) - @ [igoto end_function_label] - @ [ilabel end_cleanup_label] - | _, _ -> assert false - in - rewrite_return [] instrs - @ [ilabel end_function_label] - -(* This is like fix_early_return, but for stack allocated returns. *) -let fix_early_stack_return ctx instrs = - let is_return_recur (I_aux (instr, _)) = - match instr with - | I_return _ | I_if _ | I_block _ -> true - | _ -> false - in - let rec rewrite_return historic instrs = - match instr_split_at is_return_recur instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_return (historic @ before) instrs)] - @ rewrite_return (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] - @ rewrite_return historic after - | before, (I_aux (I_return cval, _) as ret) :: after -> - before - @ [icomment "early return cleanup"] - @ generate_cleanup (historic @ before) - @ [ret] - (* There could be jumps into here *) - @ rewrite_return (historic @ before) after - | _, _ -> assert false - in - rewrite_return [] instrs - -let fix_exception_block ?return:(return=None) ctx instrs = - let end_block_label = label "end_block_exception_" in - let is_exception_stop (I_aux (instr, _)) = - match instr with - | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true - | _ -> false - in - (* In this function 'after' is instructions after the one we've - matched on, 'before is instructions before the instruction we've - matched with, but after the previous match, and 'historic' are - all the befores from previous matches. *) - let rec rewrite_exception historic instrs = - match instr_split_at is_exception_stop instrs with - | instrs, [] -> instrs - | before, I_aux (I_block instrs, _) :: after -> - before - @ [iblock (rewrite_exception (historic @ before) instrs)] - @ rewrite_exception (historic @ before) after - | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> - let historic = historic @ before in - before - @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] - @ rewrite_exception historic after - | before, I_aux (I_throw cval, (_, l)) :: after -> - before - @ [icopy l (CL_current_exception (cval_ctyp cval)) cval; - icopy l CL_have_exception (F_lit (V_bool true), CT_bool)] - @ generate_cleanup (historic @ before) - @ [igoto end_block_label] - @ rewrite_exception (historic @ before) after - | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> - let effects = match Env.get_val_spec f ctx.tc_env with - | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects - | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) - | _ -> assert false (* valspec must have function type *) - in - if has_effect effects BE_escape then - before - @ [funcall; - iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] - @ rewrite_exception (historic @ before) after - else - before @ funcall :: rewrite_exception (historic @ before) after - | _, _ -> assert false (* unreachable *) - in - match return with - | None -> - rewrite_exception [] instrs @ [ilabel end_block_label] - | Some ctyp -> - rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp] - -let rec map_try_block f (I_aux (instr, aux)) = - let instr = match instr with - | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr - | I_if (cval, instrs1, instrs2, ctyp) -> - I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) - | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr - | I_block instrs -> I_block (List.map (map_try_block f) instrs) - | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) - | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ -> instr - in - I_aux (instr, aux) - -let fix_exception ?return:(return=None) ctx instrs = - let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in - fix_exception_block ~return:return ctx instrs - -let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp = - match p_aux with - | P_id id -> (id, ([], [])) - | P_wild -> let gs = gensym () in (gs, ([], [])) - | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], [])) - | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp - | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp - | _ -> - let apat = anf_pat pat in - let gs = gensym () in - let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in - (gs, (destructure, cleanup)) - -let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps = - match p_aux with - | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps - | P_tup pats when List.length pats = List.length ctyps -> - [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, [] - | _ when List.length ctyps = 1 -> - [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], [] - - | _ -> - let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in - let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in - destructure - @ [idecl (CT_tup ctyps) arg_id] - @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids, - List.map (fun (id, _) -> id, ([], [])) new_ids, - [iclear (CT_tup ctyps) arg_id] - @ cleanup - -let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs)) - -let fix_destructure fail_label = function - | ([], cleanup) -> ([], cleanup) - | destructure, cleanup -> - let body_label = label "fundef_body_" in - (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup) - -let letdef_count = ref 0 - -(** Compile a Sail toplevel definition into an IR definition **) -let rec compile_def n total ctx def = - match def with - | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _)) - when !opt_memo_cache -> - let digest = - def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string - in - let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in - let cached = - if Sys.file_exists cachefile then - let in_chan = open_in cachefile in - try - let compiled = Marshal.from_channel in_chan in - close_in in_chan; - Some (compiled, ctx) - with - | _ -> close_in in_chan; None - else - None - in - begin match cached with - | Some (compiled, ctx) -> - Util.progress "Compiling " (string_of_id id) n total; - compiled, ctx - | None -> - let compiled, ctx = compile_def' n total ctx def in - let out_chan = open_out cachefile in - Marshal.to_channel out_chan compiled [Marshal.Closures]; - close_out out_chan; - compiled, ctx - end - - | _ -> compile_def' n total ctx def - -and compile_def' n total ctx = function - | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> - [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx - | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> - let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in - let setup, call, cleanup = compile_aexp ctx aexp in - let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in - [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx - - | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> - c_debug (lazy "Compiling VS"); - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx - - | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> - c_debug (lazy ("Compiling function " ^ string_of_id id)); - Util.progress "Compiling " (string_of_id id) n total; - - (* Find the function's type. *) - let quant, Typ_aux (fn_typ, _) = - try Env.get_val_spec id ctx.local_env - with Type_error _ -> - c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env - in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - - (* Handle the argument pattern. *) - let fundef_label = label "fundef_fail_" in - let orig_ctx = ctx in - (* The context must be updated before we call ctyp_of_typ on the argument types. *) - let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in - - let arg_ctyps = List.map (ctyp_of_typ ctx) arg_typs in - let ret_ctyp = ctyp_of_typ ctx ret_typ in - - (* Optimize and compile the expression to ANF. *) - let aexp = no_shadow (pat_ids pat) (anf exp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in - - if Id.compare (mk_id !opt_debug_function) id = 0 then - let header = - Printf.sprintf "Sail ANF for %s %s %s. (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) - (string_of_typquant quant) - Util.(string_of_list ", " (fun typ -> string_of_typ typ |> yellow |> clear) arg_typs) - Util.(string_of_typ ret_typ |> yellow |> clear) - - in - prerr_endline (Util.header header (List.length arg_typs + 2)); - prerr_endline (Pretty_print_sail.to_string (pp_aexp aexp)) - else (); - - (* Compile the function arguments as patterns. *) - let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in - let ctx = - (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *) - List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps - in - - (* Optimize and compile the expression from ANF to C. *) - let aexp = no_shadow (pat_ids pat) (anf exp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in - c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp))); - let setup, call, cleanup = compile_aexp ctx aexp in - c_debug (lazy "Compiled aexp"); - let gs = gensym () in - let destructure, destructure_cleanup = - compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label - in - - if is_stack_ctyp ret_ctyp then - let instrs = arg_setup @ destructure @ [idecl ret_ctyp gs] @ setup @ [call (CL_id (gs, ret_ctyp))] @ cleanup @ destructure_cleanup @ arg_cleanup @ [ireturn (F_id gs, ret_ctyp)] in - let instrs = fix_early_stack_return ctx instrs in - let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in - [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx - else - let instrs = arg_setup @ destructure @ setup @ [call (CL_addr (CL_id (gs, CT_ref ret_ctyp)))] @ cleanup @ destructure_cleanup @ arg_cleanup in - let instrs = fix_early_return (CL_addr (CL_id (gs, CT_ref ret_ctyp))) ctx instrs in - let instrs = fix_exception ctx instrs in - [CDEF_fundef (id, Some gs, List.map fst compiled_args, instrs)], orig_ctx - - | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> - c_error ~loc:l "Encountered function with no clauses" - | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) -> - c_error ~loc:l "Encountered function with multiple clauses" - - (* All abbreviations should expanded by the typechecker, so we don't - need to translate type abbreviations into C typedefs. *) - | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx - - | DEF_type type_def -> - let tdef, ctx = compile_type_def ctx type_def in - [CDEF_type tdef], ctx - - | DEF_val (LB_aux (LB_val (pat, exp), _)) -> - c_debug (lazy ("Compiling letbind " ^ string_of_pat pat)); - let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in - let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in - let setup, call, cleanup = compile_aexp ctx aexp in - let apat = anf_pat ~global:true pat in - let gs = gensym () in - let end_label = label "let_end_" in - let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in - let gs_setup, gs_cleanup = - [idecl ctyp gs], [iclear ctyp gs] - in - let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in - let n = !letdef_count in - incr letdef_count; - let instrs = - gs_setup @ setup - @ [call (CL_id (gs, ctyp))] - @ cleanup - @ destructure - @ destructure_cleanup @ gs_cleanup - @ [ilabel end_label] - in - [CDEF_let (n, bindings, instrs)], - { ctx with letbinds = n :: ctx.letbinds } - - (* Only DEF_default that matters is default Order, but all order - polymorphism is specialised by this point. *) - | DEF_default _ -> [], ctx - - (* Overloading resolved by type checker *) - | DEF_overload _ -> [], ctx - - (* Only the parser and sail pretty printer care about this. *) - | DEF_fixity _ -> [], ctx - - (* We just ignore any pragmas we don't want to deal with. *) - | DEF_pragma _ -> [], ctx - - | DEF_internal_mutrec fundefs -> - let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in - List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs - - | def -> - c_error ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def)) - -(** To keep things neat we use GCC's local labels extension to limit - the scope of labels. We do this by iterating over all the blocks - and adding a __label__ declaration with all the labels local to - that block. The add_local_labels function is called by the code - generator just before it outputs C. - - See https://gcc.gnu.org/onlinedocs/gcc/Local-Labels.html **) -let add_local_labels' instrs = - let is_label (I_aux (instr, _)) = - match instr with - | I_label str -> [str] - | _ -> [] - in - let labels = List.concat (List.map is_label instrs) in - let local_label_decl = iraw ("__label__ " ^ String.concat ", " labels ^ ";\n") in - if labels = [] then - instrs - else - local_label_decl :: instrs - -let add_local_labels instrs = - match map_instrs add_local_labels' (iblock instrs) with - | I_aux (I_block instrs, _) -> instrs - | _ -> assert false - -(**************************************************************************) -(* 5. Optimizations *) -(**************************************************************************) - -let rec clexp_rename from_id to_id = - let rename id = if Id.compare id from_id = 0 then to_id else id in - function - | CL_id (id, ctyp) -> CL_id (rename id, ctyp) - | CL_field (clexp, field) -> CL_field (clexp_rename from_id to_id clexp, field) - | CL_tuple (clexp, n) -> CL_tuple (clexp_rename from_id to_id clexp, n) - | CL_addr clexp -> CL_addr (clexp_rename from_id to_id clexp) - | CL_current_exception ctyp -> CL_current_exception ctyp - | CL_have_exception -> CL_have_exception - -let rec instrs_rename from_id to_id = - let rename id = if Id.compare id from_id = 0 then to_id else id in - let crename = cval_rename from_id to_id in - let irename instrs = instrs_rename from_id to_id instrs in - let lrename = clexp_rename from_id to_id in - function - | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs - | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs - | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs - | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs - | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs - | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs - | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> - I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs - | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs - | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs - | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs - | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs - | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs - | (I_aux ((I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs - | [] -> [] - -let hoist_ctyp = function - | CT_lint | CT_lbits _ | CT_struct _ -> true - | _ -> false - -let hoist_counter = ref 0 -let hoist_id () = - let id = mk_id ("gh#" ^ string_of_int !hoist_counter) in - incr hoist_counter; - id - -let hoist_allocations ctx = function - | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id ctx.recursive_functions -> - c_debug (lazy (Printf.sprintf "skipping recursive function %s" (string_of_id function_id))); - [cdef] - - | CDEF_fundef (function_id, heap_return, args, body) -> - let decls = ref [] in - let cleanups = ref [] in - let rec hoist = function - | I_aux (I_decl (ctyp, decl_id), annot) :: instrs when hoist_ctyp ctyp -> - let hid = hoist_id () in - decls := idecl ctyp hid :: !decls; - cleanups := iclear ctyp hid :: !cleanups; - let instrs = instrs_rename decl_id hid instrs in - I_aux (I_reset (ctyp, hid), annot) :: hoist instrs - - | I_aux (I_init (ctyp, decl_id, cval), annot) :: instrs when hoist_ctyp ctyp -> - let hid = hoist_id () in - decls := idecl ctyp hid :: !decls; - cleanups := iclear ctyp hid :: !cleanups; - let instrs = instrs_rename decl_id hid instrs in - I_aux (I_reinit (ctyp, hid, cval), annot) :: hoist instrs - - | I_aux (I_clear (ctyp, _), _) :: instrs when hoist_ctyp ctyp -> - hoist instrs - - | I_aux (I_block block, annot) :: instrs -> - I_aux (I_block (hoist block), annot) :: hoist instrs - | I_aux (I_try_block block, annot) :: instrs -> - I_aux (I_try_block (hoist block), annot) :: hoist instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), annot) :: instrs -> - I_aux (I_if (cval, hoist then_instrs, hoist else_instrs, ctyp), annot) :: hoist instrs - - | instr :: instrs -> instr :: hoist instrs - | [] -> [] - in - let body = hoist body in - if !decls = [] then - [CDEF_fundef (function_id, heap_return, args, body)] - else - [CDEF_startup (function_id, List.rev !decls); - CDEF_fundef (function_id, heap_return, args, body); - CDEF_finish (function_id, !cleanups)] - - | cdef -> [cdef] - -let flat_counter = ref 0 -let flat_id () = - let id = mk_id ("local#" ^ string_of_int !flat_counter) in - incr flat_counter; - id - -let rec flatten_instrs = function - | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> - let fid = flat_id () in - I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) - - | I_aux ((I_block block | I_try_block block), _) :: instrs -> - flatten_instrs block @ flatten_instrs instrs - - | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> - let then_label = label "then_" in - let endif_label = label "endif_" in - [ijump cval then_label] - @ flatten_instrs else_instrs - @ [igoto endif_label] - @ [ilabel then_label] - @ flatten_instrs then_instrs - @ [ilabel endif_label] - @ flatten_instrs instrs - - | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs - - | instr :: instrs -> instr :: flatten_instrs instrs - | [] -> [] - -let flatten_cdef = - function - | CDEF_fundef (function_id, heap_return, args, body) -> - flat_counter := 0; - CDEF_fundef (function_id, heap_return, args, flatten_instrs body) - - | CDEF_let (n, bindings, instrs) -> - flat_counter := 0; - CDEF_let (n, bindings, flatten_instrs instrs) - - | cdef -> cdef - - -let rec specialize_variants ctx prior = - let unifications = ref (Bindings.empty) in - - let fix_variant_ctyp var_id new_ctors = function - | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) - | ctyp -> ctyp - in - - let specialize_constructor ctx ctor_id ctyp = - function - | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> - (* Work out how each call to a constructor in instantiated and add that to unifications *) - let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in - let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in - unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; - - (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) - let casts = - let cast_to_suprema (frag, ctyp) = - let suprema = ctyp_suprema ctyp in - if ctyp_equal ctyp suprema then - [], (unpoly frag, ctyp), [] - else - let gs = gensym () in - [idecl suprema gs; - icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], - (F_id gs, suprema), - [iclear suprema gs] - in - List.map cast_to_suprema [cval] - in - let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in - let cvals = List.map (fun (_, cval, _) -> cval) casts in - let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in - - let mk_funcall instr = - if List.length setup = 0 then - instr - else - iblock (setup @ [instr] @ cleanup) - in - - mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) - - | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> - c_error ~loc:l "Multiple argument constructor found" - - | instr -> instr - in - - function - | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> - let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in - - let cdefs = - List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) - cdefs - polymorphic_ctors - in - - let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in - let specialized_ctors = Bindings.bindings !unifications in - let new_ctors = monomorphic_ctors @ specialized_ctors in - - let ctx = { - ctx with variants = Bindings.add var_id - (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) - ctx.variants - } in - - let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in - let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in - specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs - - | cdef :: cdefs -> - let remove_poly (I_aux (instr, aux)) = - match instr with - | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> - I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) - | instr -> I_aux (instr, aux) - in - let cdef = cdef_map_instr remove_poly cdef in - specialize_variants ctx (cdef :: prior) cdefs - - | [] -> List.rev prior, ctx - -(** Once we specialize variants, there may be additional type - dependencies which could be in the wrong order. As such we need to - sort the type definitions in the list of cdefs. *) -let sort_ctype_defs cdefs = - (* Split the cdefs into type definitions and non type definitions *) - let is_ctype_def = function CDEF_type _ -> true | _ -> false in - let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in - let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in - let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in - - let ctdef_id = function - | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id - in - - let ctdef_ids = function - | CTD_enum _ -> IdSet.empty - | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> - List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors - in - - (* Create a reverse (i.e. from types to the types that are dependent - upon them) id graph of dependencies between types *) - let module IdGraph = Graph.Make(Id) in - - let graph = - List.fold_left (fun g ctdef -> - List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) - (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) - (IdSet.elements (ctdef_ids ctdef))) - IdGraph.empty - ctype_defs - in - - (* Then select the ctypes in the correct order as given by the topsort *) - let ids = IdGraph.topsort graph in - let ctype_defs = - List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids - in - - ctype_defs @ cdefs - -let removed = icomment "REMOVED" - -let is_not_removed = function - | I_aux (I_comment "REMOVED", _) -> false - | _ -> true - -(** This optimization looks for patterns of the form: - - create x : t; - x = y; - // modifications to x, and no changes to y - y = x; - // no further changes to x - kill x; - - If found, we can remove the variable x, and directly modify y instead. *) -let remove_alias ctx = - let pattern ctyp id = - let alias = ref None in - let rec scan ctyp id n instrs = - match n, !alias, instrs with - | 0, None, I_aux (I_copy (CL_id (id', ctyp'), (F_id a, ctyp'')), _) :: instrs - when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - alias := Some a; - scan ctyp id 1 instrs - - | 1, Some a, I_aux (I_copy (CL_id (a', ctyp'), (F_id id', ctyp'')), _) :: instrs - when Id.compare a a' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - scan ctyp id 2 instrs - - | 1, Some a, instr :: instrs -> - if IdSet.mem a (instr_ids instr) then - None - else - scan ctyp id 1 instrs - - | 2, Some a, I_aux (I_clear (ctyp', id'), _) :: instrs - when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' -> - scan ctyp id 2 instrs - - | 2, Some a, instr :: instrs -> - if IdSet.mem id (instr_ids instr) then - None - else - scan ctyp id 2 instrs - - | 2, Some a, [] -> !alias - - | n, _, _ :: instrs when n = 0 || n > 2 -> scan ctyp id n instrs - | _, _, I_aux (_, (_, l)) :: instrs -> raise (Reporting.err_unreachable l __POS__ "optimize_alias") - | _, _, [] -> None - in - scan ctyp id 0 - in - let remove_alias id alias = function - | I_aux (I_copy (CL_id (id', _), (F_id alias', _)), _) - when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed - | I_aux (I_copy (CL_id (alias', _), (F_id id', _)), _) - when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed - | I_aux (I_clear (_, id'), _) -> removed - | instr -> instr - in - let rec opt = function - | I_aux (I_decl (ctyp, id), _) as instr :: instrs -> - begin match pattern ctyp id instrs with - | None -> instr :: opt instrs - | Some alias -> - let instrs = List.map (map_instr (remove_alias id alias)) instrs in - filter_instrs is_not_removed (List.map (instr_rename id alias) instrs) - end - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, opt body)] - | cdef -> [cdef] - - -(** This pass ensures that all variables created by I_decl have unique names *) -let unique_names = - let unique_counter = ref 0 in - let unique_id () = - let id = mk_id ("u#" ^ string_of_int !unique_counter) in - incr unique_counter; - id - in - - let rec opt seen = function - | I_aux (I_decl (ctyp, id), aux) :: instrs when IdSet.mem id seen -> - let id' = unique_id () in - let instrs', seen = opt seen instrs in - I_aux (I_decl (ctyp, id'), aux) :: instrs_rename id id' instrs', seen - - | I_aux (I_decl (ctyp, id), aux) :: instrs -> - let instrs', seen = opt (IdSet.add id seen) instrs in - I_aux (I_decl (ctyp, id), aux) :: instrs', seen - - | I_aux (I_block block, aux) :: instrs -> - let block', seen = opt seen block in - let instrs', seen = opt seen instrs in - I_aux (I_block block', aux) :: instrs', seen - - | I_aux (I_try_block block, aux) :: instrs -> - let block', seen = opt seen block in - let instrs', seen = opt seen instrs in - I_aux (I_try_block block', aux) :: instrs', seen - - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - let then_instrs', seen = opt seen then_instrs in - let else_instrs', seen = opt seen else_instrs in - let instrs', seen = opt seen instrs in - I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen - - | instr :: instrs -> - let instrs', seen = opt seen instrs in - instr :: instrs', seen - - | [] -> [], seen - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, fst (opt IdSet.empty body))] - | CDEF_reg_dec (id, ctyp, instrs) -> - [CDEF_reg_dec (id, ctyp, fst (opt IdSet.empty instrs))] - | CDEF_let (n, bindings, instrs) -> - [CDEF_let (n, bindings, fst (opt IdSet.empty instrs))] - | cdef -> [cdef] - -(** This optimization looks for patterns of the form - - create x : t; - create y : t; - // modifications to y, no changes to x - x = y; - kill y; - - If found we can replace y by x *) -let combine_variables ctx = - let pattern ctyp id = - let combine = ref None in - let rec scan id n instrs = - match n, !combine, instrs with - | 0, None, I_aux (I_block block, _) :: instrs -> - begin match scan id 0 block with - | Some combine -> Some combine - | None -> scan id 0 instrs - end - - | 0, None, I_aux (I_decl (ctyp', id'), _) :: instrs when ctyp_equal ctyp ctyp' -> - combine := Some id'; - scan id 1 instrs - - | 1, Some c, I_aux (I_copy (CL_id (id', ctyp'), (F_id c', ctyp'')), _) :: instrs - when Id.compare c c' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> - scan id 2 instrs - - (* Ignore seemingly early clears of x, as this can happen along exception paths *) - | 1, Some c, I_aux (I_clear (_, id'), _) :: instrs - when Id.compare id id' = 0 -> - scan id 1 instrs - - | 1, Some c, instr :: instrs -> - if IdSet.mem id (instr_ids instr) then - None - else - scan id 1 instrs - - | 2, Some c, I_aux (I_clear (ctyp', c'), _) :: instrs - when Id.compare c c' = 0 && ctyp_equal ctyp ctyp' -> - !combine - - | 2, Some c, instr :: instrs -> - if IdSet.mem c (instr_ids instr) then - None - else - scan id 2 instrs - - | 2, Some c, [] -> !combine - - | n, _, _ :: instrs -> scan id n instrs - | _, _, [] -> None - in - scan id 0 - in - let remove_variable id = function - | I_aux (I_decl (_, id'), _) when Id.compare id id' = 0 -> removed - | I_aux (I_clear (_, id'), _) when Id.compare id id' = 0 -> removed - | instr -> instr - in - let is_not_self_assignment = function - | I_aux (I_copy (CL_id (id, _), (F_id id', _)), _) when Id.compare id id' = 0 -> false - | _ -> true - in - let rec opt = function - | (I_aux (I_decl (ctyp, id), _) as instr) :: instrs -> - begin match pattern ctyp id instrs with - | None -> instr :: opt instrs - | Some combine -> - let instrs = List.map (map_instr (remove_variable combine)) instrs in - let instrs = filter_instrs (fun i -> is_not_removed i && is_not_self_assignment i) - (List.map (instr_rename combine id) instrs) in - opt (instr :: instrs) - end - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - [CDEF_fundef (function_id, heap_return, args, opt body)] - | cdef -> [cdef] - -(** hoist_alias looks for patterns like - - recreate x; y = x; // no furthner mentions of x - - Provided x has a certain type, then we can make y an alias to x - (denoted in the IR as 'alias y = x'). This only works if y also has - a lifespan that also spans the entire function body. It's possible - we may need to do a more thorough lifetime evaluation to get this - to be 100% correct - so it's behind the -Oexperimental flag - for now. Some benchmarking shows that this kind of optimization - is very valuable however! *) -let hoist_alias ctx = - (* Must return true for a subset of the types hoist_ctyp would return true for. *) - let is_struct = function - | CT_struct _ -> true - | _ -> false - in - let pattern heap_return id ctyp instrs = - let rec scan instrs = - match instrs with - (* The only thing that has a longer lifetime than id is the - function return, so we want to make sure we avoid that - case. *) - | (I_aux (I_copy (clexp, (F_id id', ctyp')), aux) as instr) :: instrs - when not (IdSet.mem heap_return (instr_writes instr)) && Id.compare id id' = 0 - && ctyp_equal (clexp_ctyp clexp) ctyp && ctyp_equal ctyp ctyp' -> - if List.exists (IdSet.mem id) (List.map instr_ids instrs) then - instr :: scan instrs - else - I_aux (I_alias (clexp, (F_id id', ctyp')), aux) :: instrs - - | instr :: instrs -> instr :: scan instrs - | [] -> [] - in - scan instrs - in - let optimize heap_return = - let rec opt = function - | (I_aux (I_reset (ctyp, id), _) as instr) :: instrs when not (is_stack_ctyp ctyp) && is_struct ctyp -> - instr :: opt (pattern heap_return id ctyp instrs) - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs - - | instr :: instrs -> - instr :: opt instrs - | [] -> [] - in - opt - in - function - | CDEF_fundef (function_id, Some heap_return, args, body) -> - [CDEF_fundef (function_id, Some heap_return, args, optimize heap_return body)] - | cdef -> [cdef] - -let concatMap f xs = List.concat (List.map f xs) - -let optimize ctx cdefs = - let nothing cdefs = cdefs in - cdefs - |> (if !optimize_alias then concatMap unique_names else nothing) - |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing) - |> (if !optimize_alias then concatMap (combine_variables ctx) else nothing) - (* We need the runtime to initialize hoisted allocations *) - |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations ctx) else nothing) - |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap (hoist_alias ctx) else nothing) - -(**************************************************************************) -(* 6. Code generation *) -(**************************************************************************) - -let sgen_id id = Util.zencode_string (string_of_id id) -let codegen_id id = string (sgen_id id) - -let sgen_function_id id = - let str = Util.zencode_string (string_of_id id) in - !opt_prefix ^ String.sub str 1 (String.length str - 1) - -let codegen_function_id id = string (sgen_function_id id) - -let rec sgen_ctyp = function - | CT_unit -> "unit" - | CT_bit -> "fbits" - | CT_bool -> "bool" - | CT_fbits _ -> "fbits" - | CT_sbits _ -> "sbits" - | CT_fint _ -> "mach_int" - | CT_lint -> "sail_int" - | CT_lbits _ -> "lbits" - | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) - | CT_struct (id, _) -> "struct " ^ sgen_id id - | CT_enum (id, _) -> "enum " ^ sgen_id id - | CT_variant (id, _) -> "struct " ^ sgen_id id - | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) - | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) - | CT_string -> "sail_string" - | CT_real -> "real" - | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" - | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) - -let rec sgen_ctyp_name = function - | CT_unit -> "unit" - | CT_bit -> "fbits" - | CT_bool -> "bool" - | CT_fbits _ -> "fbits" - | CT_sbits _ -> "sbits" - | CT_fint _ -> "mach_int" - | CT_lint -> "sail_int" - | CT_lbits _ -> "lbits" - | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) - | CT_struct (id, _) -> sgen_id id - | CT_enum (id, _) -> sgen_id id - | CT_variant (id, _) -> sgen_id id - | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) - | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) - | CT_string -> "sail_string" - | CT_real -> "real" - | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp - | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) - -let sgen_cval_param (frag, ctyp) = - match ctyp with - | CT_lbits direction -> - string_of_fragment frag ^ ", " ^ string_of_bool direction - | CT_sbits direction -> - string_of_fragment frag ^ ", " ^ string_of_bool direction - | CT_fbits (len, direction) -> - string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction - | _ -> - string_of_fragment frag - -let sgen_cval = function (frag, _) -> string_of_fragment frag - -let rec sgen_clexp = function - | CL_id (id, _) -> "&" ^ sgen_id id - | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ Util.zencode_string field ^ ")" - | CL_tuple (clexp, n) -> "&((" ^ sgen_clexp clexp ^ ")->ztup" ^ string_of_int n ^ ")" - | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -let rec sgen_clexp_pure = function - | CL_id (id, _) -> sgen_id id - | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ Util.zencode_string field - | CL_tuple (clexp, n) -> sgen_clexp_pure clexp ^ ".ztup" ^ string_of_int n - | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -(** Generate instructions to copy from a cval to a clexp. This will - insert any needed type conversions from big integers to small - integers (or vice versa), or from arbitrary-length bitvectors to - and from uint64 bitvectors as needed. *) -let rec codegen_conversion l clexp cval = - let open Printf in - let ctyp_to = clexp_ctyp clexp in - let ctyp_from = cval_ctyp cval in - match ctyp_to, ctyp_from with - (* When both types are equal, we don't need any conversion. *) - | _, _ when ctyp_equal ctyp_to ctyp_from -> - if is_stack_ctyp ctyp_to then - ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) - else - ksprintf string " COPY(%s)(%s, %s);" (sgen_ctyp_name ctyp_to) (sgen_clexp clexp) (sgen_cval cval) - - | CT_ref ctyp_to, ctyp_from -> - codegen_conversion l (CL_addr clexp) cval - - (* If we have to convert between tuple types, convert the fields individually. *) - | CT_tup ctyps_to, CT_tup ctyps_from when List.length ctyps_to = List.length ctyps_from -> - let conversions = - List.mapi (fun i ctyp -> codegen_conversion l (CL_tuple (clexp, i)) (F_field (fst cval, "ztup" ^ string_of_int i), ctyp)) ctyps_from - in - string " /* conversions */" - ^^ hardline - ^^ separate hardline conversions - ^^ hardline - ^^ string " /* end conversions */" - - (* For anything not special cased, just try to call a appropriate CONVERT_OF function. *) - | _, _ when is_stack_ctyp (clexp_ctyp clexp) -> - ksprintf string " %s = CONVERT_OF(%s, %s)(%s);" - (sgen_clexp_pure clexp) (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_cval_param cval) - | _, _ -> - ksprintf string " CONVERT_OF(%s, %s)(%s, %s);" - (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_clexp clexp) (sgen_cval_param cval) - -let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = - let open Printf in - match instr with - | I_decl (ctyp, id) when is_stack_ctyp ctyp -> - ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) - | I_decl (ctyp, id) -> - ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline - ^^ ksprintf string " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) - - | I_copy (clexp, cval) -> codegen_conversion l clexp cval - - | I_alias (clexp, cval) -> - ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) - - | I_jump (cval, label) -> - ksprintf string " if (%s) goto %s;" (sgen_cval cval) label - - | I_if (cval, [then_instr], [], ctyp) -> - ksprintf string " if (%s)" (sgen_cval cval) ^^ hardline - ^^ twice space ^^ codegen_instr fid ctx then_instr - | I_if (cval, then_instrs, [], ctyp) -> - string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) - | I_if (cval, then_instrs, else_instrs, ctyp) -> - string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) - ^^ space ^^ string "else" ^^ space - ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) - - | I_block instrs -> - string " {" - ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline - ^^ string " }" - - | I_try_block instrs -> - string " { /* try */" - ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline - ^^ string " }" - - | I_funcall (x, extern, f, args) -> - let c_args = Util.string_of_list ", " sgen_cval args in - let ctyp = clexp_ctyp x in - let is_extern = Env.is_extern f ctx.tc_env "c" || extern in - let fname = - if Env.is_extern f ctx.tc_env "c" then - Env.get_extern f ctx.tc_env "c" - else if extern then - string_of_id f - else - sgen_function_id f - in - let fname = - match fname, ctyp with - | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) - | "eq_anything", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "eq_anything function with bad arity." - end - | "length", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "length_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "length function with bad arity." - end - | "vector_access", CT_bit -> "bitvector_access" - | "vector_access", _ -> - begin match args with - | cval :: _ -> Printf.sprintf "vector_access_%s" (sgen_ctyp_name (cval_ctyp cval)) - | _ -> c_error "vector access function with bad arity." - end - | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) - | "vector_update", CT_fbits _ -> "update_fbits" - | "vector_update", CT_lbits _ -> "update_lbits" - | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) - | "string_of_bits", _ -> - begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "string_of_fbits" - | CT_lbits _ -> "string_of_lbits" - | _ -> assert false - end - | "decimal_string_of_bits", _ -> - begin match cval_ctyp (List.nth args 0) with - | CT_fbits _ -> "decimal_string_of_fbits" - | CT_lbits _ -> "decimal_string_of_lbits" - | _ -> assert false - end - | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) - | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) - | "undefined_vector", CT_fbits _ -> "UNDEFINED(fbits)" - | "undefined_vector", CT_lbits _ -> "UNDEFINED(lbits)" - | "undefined_bit", _ -> "UNDEFINED(fbits)" - | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) - | fname, _ -> fname - in - if fname = "sail_assert" && !optimize_experimental then - empty - else if fname = "reg_deref" then - if is_stack_ctyp ctyp then - string (Printf.sprintf " %s = *(%s);" (sgen_clexp_pure x) c_args) - else - string (Printf.sprintf " COPY(%s)(&%s, *(%s));" (sgen_ctyp_name ctyp) (sgen_clexp_pure x) c_args) - else - if is_stack_ctyp ctyp then - string (Printf.sprintf " %s = %s(%s%s);" (sgen_clexp_pure x) fname (extra_arguments is_extern) c_args) - else - string (Printf.sprintf " %s(%s%s, %s);" fname (extra_arguments is_extern) (sgen_clexp x) c_args) - - | I_clear (ctyp, id) when is_stack_ctyp ctyp -> - empty - | I_clear (ctyp, id) -> - string (Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - - | I_init (ctyp, id, cval) -> - codegen_instr fid ctx (idecl ctyp id) ^^ hardline - ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval - - | I_reinit (ctyp, id, cval) -> - codegen_instr fid ctx (ireset ctyp id) ^^ hardline - ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval - - | I_reset (ctyp, id) when is_stack_ctyp ctyp -> - string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | I_reset (ctyp, id) -> - string (Printf.sprintf " RECREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - - | I_return cval -> - string (Printf.sprintf " return %s;" (sgen_cval cval)) - - | I_throw cval -> - c_error ~loc:l "I_throw reached code generator" - - | I_undefined ctyp -> - let rec codegen_exn_return ctyp = - match ctyp with - | CT_unit -> "UNIT", [] - | CT_bit -> "UINT64_C(0)", [] - | CT_fint _ -> "INT64_C(0xdeadc0de)", [] - | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] - | CT_sbits _ -> "undefined_sbits()", [] - | CT_bool -> "false", [] - | CT_enum (_, ctor :: _) -> sgen_id ctor, [] - | CT_tup ctyps when is_stack_ctyp ctyp -> - let gs = gensym () in - let fold (inits, prev) (n, ctyp) = - let init, prev' = codegen_exn_return ctyp in - Printf.sprintf ".ztup%d = %s" n init :: inits, prev @ prev' - in - let inits, prev = List.fold_left fold ([], []) (List.mapi (fun i x -> (i, x)) ctyps) in - sgen_id gs, - [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) - ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev - | CT_struct (id, ctors) when is_stack_ctyp ctyp -> - let gs = gensym () in - let fold (inits, prev) (id, ctyp) = - let init, prev' = codegen_exn_return ctyp in - Printf.sprintf ".%s = %s" (sgen_id id) init :: inits, prev @ prev' - in - let inits, prev = List.fold_left fold ([], []) ctors in - sgen_id gs, - [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) - ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev - | ctyp -> c_error ("Cannot create undefined value for type: " ^ string_of_ctyp ctyp) - in - let ret, prev = codegen_exn_return ctyp in - separate_map hardline (fun str -> string (" " ^ str)) (List.rev prev) - ^^ hardline - ^^ string (Printf.sprintf " return %s;" ret) - - | I_comment str -> - string (" /* " ^ str ^ " */") - - | I_label str -> - string (str ^ ": ;") - - | I_goto str -> - string (Printf.sprintf " goto %s;" str) - - | I_raw _ when ctx.no_raw -> empty - | I_raw str -> - string (" " ^ str) - - | I_match_failure -> - string (" sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");") - -let codegen_type_def ctx = function - | CTD_enum (id, ((first_id :: _) as ids)) -> - let codegen_eq = - let name = sgen_id id in - string (Printf.sprintf "static bool eq_%s(enum %s op1, enum %s op2) { return op1 == op2; }" name name name) - in - let codegen_undefined = - let name = sgen_id id in - string (Printf.sprintf "enum %s UNDEFINED(%s)(unit u) { return %s; }" name name (sgen_id first_id)) - in - string (Printf.sprintf "// enum %s" (string_of_id id)) ^^ hardline - ^^ separate space [string "enum"; codegen_id id; lbrace; separate_map (comma ^^ space) codegen_id ids; rbrace ^^ semi] - ^^ twice hardline - ^^ codegen_eq - ^^ twice hardline - ^^ codegen_undefined - - | CTD_enum (id, []) -> c_error ("Cannot compile empty enum " ^ string_of_id id) - - | CTD_struct (id, ctors) -> - let struct_ctyp = CT_struct (id, ctors) in - c_debug (lazy (Printf.sprintf "Generating struct for %s" (full_string_of_ctyp struct_ctyp))); - - (* Generate a set_T function for every struct T *) - let codegen_set (id, ctyp) = - if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op.%s;" (sgen_id id) (sgen_id id)) - else - string (Printf.sprintf "COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) - in - let codegen_setter id ctors = - string (let n = sgen_id id in Printf.sprintf "static void COPY(%s)(struct %s *rop, const struct %s op)" n n n) ^^ space - ^^ surround 2 0 lbrace - (separate_map hardline codegen_set (Bindings.bindings ctors)) - rbrace - in - (* Generate an init/clear_T function for every struct T *) - let codegen_field_init f (id, ctyp) = - if not (is_stack_ctyp ctyp) then - [string (Printf.sprintf "%s(%s)(&op->%s);" f (sgen_ctyp_name ctyp) (sgen_id id))] - else [] - in - let codegen_init f id ctors = - string (let n = sgen_id id in Printf.sprintf "static void %s(%s)(struct %s *op)" f n n) ^^ space - ^^ surround 2 0 lbrace - (separate hardline (Bindings.bindings ctors |> List.map (codegen_field_init f) |> List.concat)) - rbrace - in - let codegen_eq = - let codegen_eq_test (id, ctyp) = - string (Printf.sprintf "EQUAL(%s)(op1.%s, op2.%s)" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) - in - string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2)" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ space - ^^ surround 2 0 lbrace - (string "return" ^^ space - ^^ separate_map (string " && ") codegen_eq_test ctors - ^^ string ";") - rbrace - in - (* Generate the struct and add the generated functions *) - let codegen_ctor (id, ctyp) = - string (sgen_ctyp ctyp) ^^ space ^^ codegen_id id - in - string (Printf.sprintf "// struct %s" (string_of_id id)) ^^ hardline - ^^ string "struct" ^^ space ^^ codegen_id id ^^ space - ^^ surround 2 0 lbrace - (separate_map (semi ^^ hardline) codegen_ctor ctors ^^ semi) - rbrace - ^^ semi ^^ twice hardline - ^^ codegen_setter id (ctor_bindings ctors) - ^^ (if not (is_stack_ctyp struct_ctyp) then - twice hardline - ^^ codegen_init "CREATE" id (ctor_bindings ctors) - ^^ twice hardline - ^^ codegen_init "RECREATE" id (ctor_bindings ctors) - ^^ twice hardline - ^^ codegen_init "KILL" id (ctor_bindings ctors) - else empty) - ^^ twice hardline - ^^ codegen_eq - - | CTD_variant (id, tus) -> - let codegen_tu (ctor_id, ctyp) = - separate space [string "struct"; lbrace; string (sgen_ctyp ctyp); codegen_id ctor_id ^^ semi; rbrace] - in - (* Create an if, else if, ... block that does something for each constructor *) - let rec each_ctor v f = function - | [] -> string "{}" - | [(ctor_id, ctyp)] -> - string (Printf.sprintf "if (%skind == Kind_%s)" v (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (f ctor_id ctyp) - ^^ hardline ^^ rbrace - | (ctor_id, ctyp) :: ctors -> - string (Printf.sprintf "if (%skind == Kind_%s) " v (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (f ctor_id ctyp) - ^^ hardline ^^ rbrace ^^ string " else " ^^ each_ctor v f ctors - in - let codegen_init = - let n = sgen_id id in - let ctor_id, ctyp = List.hd tus in - string (Printf.sprintf "static void CREATE(%s)(struct %s *op)" n n) - ^^ hardline - ^^ surround 2 0 lbrace - (string (Printf.sprintf "op->kind = Kind_%s;" (sgen_id ctor_id)) ^^ hardline - ^^ if not (is_stack_ctyp ctyp) then - string (Printf.sprintf "CREATE(%s)(&op->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) - else empty) - rbrace - in - let codegen_reinit = - let n = sgen_id id in - string (Printf.sprintf "static void RECREATE(%s)(struct %s *op) {}" n n) - in - let clear_field v ctor_id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "/* do nothing */") - else - string (Printf.sprintf "KILL(%s)(&%s->%s);" (sgen_ctyp_name ctyp) v (sgen_id ctor_id)) - in - let codegen_clear = - let n = sgen_id id in - string (Printf.sprintf "static void KILL(%s)(struct %s *op)" n n) ^^ hardline - ^^ surround 2 0 lbrace - (each_ctor "op->" (clear_field "op") tus ^^ semi) - rbrace - in - let codegen_ctor (ctor_id, ctyp) = - let ctor_args, tuple, tuple_cleanup = - let tuple_set i ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "op.ztup%d = op%d;" i i) - else - string (Printf.sprintf "COPY(%s)(&op.ztup%d, op%d);" (sgen_ctyp_name ctyp) i i) - in - Printf.sprintf "%s op" (sgen_ctyp ctyp), empty, empty - in - string (Printf.sprintf "static void %s(%sstruct %s *rop, %s)" (sgen_function_id ctor_id) (extra_params ()) (sgen_id id) ctor_args) ^^ hardline - ^^ surround 2 0 lbrace - (tuple - ^^ each_ctor "rop->" (clear_field "rop") tus ^^ hardline - ^^ string ("rop->kind = Kind_" ^ sgen_id ctor_id) ^^ semi ^^ hardline - ^^ if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op;" (sgen_id ctor_id)) - else - string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline - ^^ string (Printf.sprintf "COPY(%s)(&rop->%s, op);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline - ^^ tuple_cleanup) - rbrace - in - let codegen_setter = - let n = sgen_id id in - let set_field ctor_id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "rop->%s = op.%s;" (sgen_id ctor_id) (sgen_id ctor_id)) - else - string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) - ^^ string (Printf.sprintf " COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) - in - string (Printf.sprintf "static void COPY(%s)(struct %s *rop, struct %s op)" n n n) ^^ hardline - ^^ surround 2 0 lbrace - (each_ctor "rop->" (clear_field "rop") tus - ^^ semi ^^ hardline - ^^ string "rop->kind = op.kind" - ^^ semi ^^ hardline - ^^ each_ctor "op." set_field tus) - rbrace - in - let codegen_eq = - let codegen_eq_test ctor_id ctyp = - string (Printf.sprintf "return EQUAL(%s)(op1.%s, op2.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) - in - let rec codegen_eq_tests = function - | [] -> string "return false;" - | (ctor_id, ctyp) :: ctors -> - string (Printf.sprintf "if (op1.kind == Kind_%s && op2.kind == Kind_%s) " (sgen_id ctor_id) (sgen_id ctor_id)) ^^ lbrace ^^ hardline - ^^ jump 0 2 (codegen_eq_test ctor_id ctyp) - ^^ hardline ^^ rbrace ^^ string " else " ^^ codegen_eq_tests ctors - in - let n = sgen_id id in - string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2) " n n n) - ^^ surround 2 0 lbrace (codegen_eq_tests tus) rbrace - in - string (Printf.sprintf "// union %s" (string_of_id id)) ^^ hardline - ^^ string "enum" ^^ space - ^^ string ("kind_" ^ sgen_id id) ^^ space - ^^ separate space [ lbrace; - separate_map (comma ^^ space) (fun id -> string ("Kind_" ^ sgen_id id)) (List.map fst tus); - rbrace ^^ semi ] - ^^ twice hardline - ^^ string "struct" ^^ space ^^ codegen_id id ^^ space - ^^ surround 2 0 lbrace - (separate space [string "enum"; string ("kind_" ^ sgen_id id); string "kind" ^^ semi] - ^^ hardline - ^^ string "union" ^^ space - ^^ surround 2 0 lbrace - (separate_map (semi ^^ hardline) codegen_tu tus ^^ semi) - rbrace - ^^ semi) - rbrace - ^^ semi - ^^ twice hardline - ^^ codegen_init - ^^ twice hardline - ^^ codegen_reinit - ^^ twice hardline - ^^ codegen_clear - ^^ twice hardline - ^^ codegen_setter - ^^ twice hardline - ^^ codegen_eq - ^^ twice hardline - ^^ separate_map (twice hardline) codegen_ctor tus - (* If this is the exception type, then we setup up some global variables to deal with exceptions. *) - ^^ if string_of_id id = "exception" then - twice hardline - ^^ string "struct zexception *current_exception = NULL;" - ^^ hardline - ^^ string "bool have_exception = false;" - else - empty - -(** GLOBAL: because C doesn't have real anonymous tuple types - (anonymous structs don't quite work the way we need) every tuple - type in the spec becomes some generated named struct in C. This is - done in such a way that every possible tuple type has a unique name - associated with it. This global variable keeps track of these - generated struct names, so we never generate two copies of the - struct that is used to represent them in C. - - The way this works is that codegen_def scans each definition's type - annotations for tuple types and generates the required structs - using codegen_type_def before the actual definition is generated by - codegen_def'. - - This variable should be reset to empty only when the entire AST has - been translated to C. **) -let generated = ref IdSet.empty - -let codegen_tup ctx ctyps = - let id = mk_id ("tuple_" ^ string_of_ctyp (CT_tup ctyps)) in - if IdSet.mem id !generated then - empty - else - begin - let _, fields = List.fold_left (fun (n, fields) ctyp -> n + 1, Bindings.add (mk_id ("tup" ^ string_of_int n)) ctyp fields) - (0, Bindings.empty) - ctyps - in - generated := IdSet.add id !generated; - codegen_type_def ctx (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline - end - -let codegen_node id ctyp = - string (Printf.sprintf "struct node_%s {\n %s hd;\n struct node_%s *tl;\n};\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string (Printf.sprintf "typedef struct node_%s *%s;" (sgen_id id) (sgen_id id)) - -let codegen_list_init id = - string (Printf.sprintf "static void CREATE(%s)(%s *rop) { *rop = NULL; }" (sgen_id id) (sgen_id id)) - -let codegen_list_clear id ctyp = - string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " if (*rop == NULL) return;") - ^^ (if is_stack_ctyp ctyp then empty - else string (Printf.sprintf " KILL(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp))) - ^^ string (Printf.sprintf " KILL(%s)(&(*rop)->tl);\n" (sgen_id id)) - ^^ string " free(*rop);" - ^^ string "}" - -let codegen_list_set id ctyp = - string (Printf.sprintf "static void internal_set_%s(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string " if (op == NULL) { *rop = NULL; return; };\n" - ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then - string " (*rop)->hd = op->hd;\n" - else - string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) - ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, op->hd);\n" (sgen_ctyp_name ctyp))) - ^^ string (Printf.sprintf " internal_set_%s(&(*rop)->tl, op->tl);\n" (sgen_id id)) - ^^ string "}" - ^^ twice hardline - ^^ string (Printf.sprintf "static void COPY(%s)(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) - ^^ string (Printf.sprintf " internal_set_%s(rop, op);\n" (sgen_id id)) - ^^ string "}" - -let codegen_cons id ctyp = - let cons_id = mk_id ("cons#" ^ string_of_ctyp ctyp) in - string (Printf.sprintf "static void %s(%s *rop, const %s x, const %s xs) {\n" (sgen_function_id cons_id) (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then - string " (*rop)->hd = x;\n" - else - string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) - ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, x);\n" (sgen_ctyp_name ctyp))) - ^^ string " (*rop)->tl = xs;\n" - ^^ string "}" - -let codegen_pick id ctyp = - if is_stack_ctyp ctyp then - string (Printf.sprintf "static %s pick_%s(const %s xs) { return xs->hd; }" (sgen_ctyp ctyp) (sgen_ctyp_name ctyp) (sgen_id id)) - else - string (Printf.sprintf "static void pick_%s(%s *x, const %s xs) { COPY(%s)(x, xs->hd); }" (sgen_ctyp_name ctyp) (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp)) - -let codegen_list ctx ctyp = - let id = mk_id (string_of_ctyp (CT_list ctyp)) in - if IdSet.mem id !generated then - empty - else - begin - generated := IdSet.add id !generated; - codegen_node id ctyp ^^ twice hardline - ^^ codegen_list_init id ^^ twice hardline - ^^ codegen_list_clear id ctyp ^^ twice hardline - ^^ codegen_list_set id ctyp ^^ twice hardline - ^^ codegen_cons id ctyp ^^ twice hardline - ^^ codegen_pick id ctyp ^^ twice hardline - end - -(* Generate functions for working with non-bit vectors of some specific type. *) -let codegen_vector ctx (direction, ctyp) = - let id = mk_id (string_of_ctyp (CT_vector (direction, ctyp))) in - if IdSet.mem id !generated then - empty - else - let vector_typedef = - string (Printf.sprintf "struct %s {\n size_t len;\n %s *data;\n};\n" (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (Printf.sprintf "typedef struct %s %s;" (sgen_id id) (sgen_id id)) - in - let vector_init = - string (Printf.sprintf "static void CREATE(%s)(%s *rop) {\n rop->len = 0;\n rop->data = NULL;\n}" (sgen_id id) (sgen_id id)) - in - let vector_set = - string (Printf.sprintf "static void COPY(%s)(%s *rop, %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) - ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) - ^^ string " rop->len = op.len;\n" - ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ string " for (int i = 0; i < op.len; i++) {\n" - ^^ string (if is_stack_ctyp ctyp then - " (rop->data)[i] = op.data[i];\n" - else - Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, op.data[i]);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - let vector_clear = - string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) - ^^ (if is_stack_ctyp ctyp then empty - else - string " for (int i = 0; i < (rop->len); i++) {\n" - ^^ string (Printf.sprintf " KILL(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n") - ^^ string " if (rop->data != NULL) free(rop->data);\n" - ^^ string "}" - in - let vector_update = - string (Printf.sprintf "static void vector_update_%s(%s *rop, %s op, mpz_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string " if (rop->data == op.data) {\n" - ^^ string (if is_stack_ctyp ctyp then - " rop->data[m] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string " } else {\n" - ^^ string (Printf.sprintf " COPY(%s)(rop, op);\n" (sgen_id id)) - ^^ string (if is_stack_ctyp ctyp then - " rop->data[m] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - let internal_vector_update = - string (Printf.sprintf "static void internal_vector_update_%s(%s *rop, %s op, const int64_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (if is_stack_ctyp ctyp then - " rop->data[n] = elem;\n" - else - Printf.sprintf " COPY(%s)((rop->data) + n, elem);\n" (sgen_ctyp_name ctyp)) - ^^ string "}" - in - let vector_access = - if is_stack_ctyp ctyp then - string (Printf.sprintf "static %s vector_access_%s(%s op, mpz_t n) {\n" (sgen_ctyp ctyp) (sgen_id id) (sgen_id id)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string " return op.data[m];\n" - ^^ string "}" - else - string (Printf.sprintf "static void vector_access_%s(%s *rop, %s op, mpz_t n) {\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) - ^^ string " int m = mpz_get_ui(n);\n" - ^^ string (Printf.sprintf " COPY(%s)(rop, op.data[m]);\n" (sgen_ctyp_name ctyp)) - ^^ string "}" - in - let internal_vector_init = - string (Printf.sprintf "static void internal_vector_init_%s(%s *rop, const int64_t len) {\n" (sgen_id id) (sgen_id id)) - ^^ string " rop->len = len;\n" - ^^ string (Printf.sprintf " rop->data = malloc(len * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ (if not (is_stack_ctyp ctyp) then - string " for (int i = 0; i < len; i++) {\n" - ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) - ^^ string " }\n" - else empty) - ^^ string "}" - in - let vector_undefined = - string (Printf.sprintf "static void undefined_vector_%s(%s *rop, mpz_t len, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) - ^^ string (Printf.sprintf " rop->len = mpz_get_ui(len);\n") - ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) - ^^ string " for (int i = 0; i < (rop->len); i++) {\n" - ^^ string (if is_stack_ctyp ctyp then - " (rop->data)[i] = elem;\n" - else - Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, elem);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) - ^^ string " }\n" - ^^ string "}" - in - begin - generated := IdSet.add id !generated; - vector_typedef ^^ twice hardline - ^^ vector_init ^^ twice hardline - ^^ vector_clear ^^ twice hardline - ^^ vector_undefined ^^ twice hardline - ^^ vector_access ^^ twice hardline - ^^ vector_set ^^ twice hardline - ^^ vector_update ^^ twice hardline - ^^ internal_vector_update ^^ twice hardline - ^^ internal_vector_init ^^ twice hardline - end - -let is_decl = function - | I_aux (I_decl _, _) -> true - | _ -> false - -let codegen_decl = function - | I_aux (I_decl (ctyp, id), _) -> - string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - | _ -> assert false - -let codegen_alloc = function - | I_aux (I_decl (ctyp, id), _) when is_stack_ctyp ctyp -> empty - | I_aux (I_decl (ctyp, id), _) -> - string (Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) - | _ -> assert false - -let codegen_def' ctx = function - | CDEF_reg_dec (id, ctyp, _) -> - string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline - ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) - - | CDEF_spec (id, arg_ctyps, ret_ctyp) -> - let static = if !opt_static then "static " else "" in - if Env.is_extern id ctx.tc_env "c" then - empty - else if is_stack_ctyp ret_ctyp then - string (Printf.sprintf "%s%s %s(%s%s);" static (sgen_ctyp ret_ctyp) (sgen_function_id id) (extra_params ()) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) - else - string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) - - | CDEF_fundef (id, ret_arg, args, instrs) as def -> - if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); - - (* Extract type information about the function from the environment. *) - let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in - let arg_typs, ret_typ = match fn_typ with - | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ - | _ -> assert false - in - let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in - let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in - - (* Check that the function has the correct arity at this point. *) - if List.length arg_ctyps <> List.length args then - c_error ~loc:(id_loc id) ("function arguments " - ^ Util.string_of_list ", " string_of_id args - ^ " matched against type " - ^ Util.string_of_list ", " string_of_ctyp arg_ctyps) - else (); - - (* If this function is set as opt_debug_function, then output its IR *) - if Id.compare (mk_id !opt_debug_function) id = 0 then - let header = - Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id) - (Util.string_of_list ", " string_of_id args) - (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps) - Util.(string_of_ctyp ret_ctyp |> yellow |> clear) - in - prerr_endline (Util.header header (List.length arg_ctyps + 2)); - prerr_endline (Pretty_print_sail.to_string (separate_map hardline pp_instr instrs)) - else (); - - let instrs = add_local_labels instrs in - let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in - let function_header = - match ret_arg with - | None -> - assert (is_stack_ctyp ret_ctyp); - (if !opt_static then string "static " else empty) - ^^ string (sgen_ctyp ret_ctyp) ^^ space ^^ codegen_function_id id ^^ parens (string (extra_params ()) ^^ string args) ^^ hardline - | Some gs -> - assert (not (is_stack_ctyp ret_ctyp)); - (if !opt_static then string "static " else empty) - ^^ string "void" ^^ space ^^ codegen_function_id id - ^^ parens (string (extra_params ()) ^^ string (sgen_ctyp ret_ctyp ^ " *" ^ sgen_id gs ^ ", ") ^^ string args) - ^^ hardline - in - function_header - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline - ^^ string "}" - - | CDEF_type ctype_def -> - codegen_type_def ctx ctype_def - - | CDEF_startup (id, instrs) -> - let static = if !opt_static then "static " else "" in - let startup_header = string (Printf.sprintf "%svoid startup_%s(void)" static (sgen_function_id id)) in - separate_map hardline codegen_decl instrs - ^^ twice hardline - ^^ startup_header ^^ hardline - ^^ string "{" - ^^ jump 0 2 (separate_map hardline codegen_alloc instrs) ^^ hardline - ^^ string "}" - - | CDEF_finish (id, instrs) -> - let static = if !opt_static then "static " else "" in - let finish_header = string (Printf.sprintf "%svoid finish_%s(void)" static (sgen_function_id id)) in - separate_map hardline codegen_decl (List.filter is_decl instrs) - ^^ twice hardline - ^^ finish_header ^^ hardline - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline - ^^ string "}" - - | CDEF_let (number, bindings, instrs) -> - let instrs = add_local_labels instrs in - let setup = - List.concat (List.map (fun (id, ctyp) -> [idecl ctyp id]) bindings) - in - let cleanup = - List.concat (List.map (fun (id, ctyp) -> [iclear ctyp id]) bindings) - in - separate_map hardline (fun (id, ctyp) -> string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id))) bindings - ^^ hardline ^^ string (Printf.sprintf "static void create_letbind_%d(void) " number) - ^^ string "{" - ^^ jump 0 2 (separate_map hardline codegen_alloc setup) ^^ hardline - ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") { ctx with no_raw = true }) instrs) ^^ hardline - ^^ string "}" - ^^ hardline ^^ string (Printf.sprintf "static void kill_letbind_%d(void) " number) - ^^ string "{" - ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") ctx) cleanup) ^^ hardline - ^^ string "}" - -(** As we generate C we need to generate specialized version of tuple, - list, and vector type. These must be generated in the correct - order. The ctyp_dependencies function generates a list of - c_gen_typs in the order they must be generated. Types may be - repeated in ctyp_dependencies so it's up to the code-generator not - to repeat definitions pointlessly (using the !generated variable) - *) -type c_gen_typ = - | CTG_tup of ctyp list - | CTG_list of ctyp - | CTG_vector of bool * ctyp - -let rec ctyp_dependencies = function - | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] - | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] - | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] - | CT_ref ctyp -> ctyp_dependencies ctyp - | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) - | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) - | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] - -let codegen_ctg ctx = function - | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp) - | CTG_tup ctyps -> codegen_tup ctx ctyps - | CTG_list ctyp -> codegen_list ctx ctyp - -(** When we generate code for a definition, we need to first generate - any auxillary type definitions that are required. *) -let codegen_def ctx def = - let ctyps = cdef_ctyps ctx def in - (* We should have erased any polymorphism introduced by variants at this point! *) - if List.exists is_polymorphic ctyps then - let polymorphic_ctyps = List.filter is_polymorphic ctyps in - prerr_endline (Pretty_print_sail.to_string (pp_cdef def)); - c_error (Printf.sprintf "Found polymorphic types:\n%s\nwhile generating definition." - (Util.string_of_list "\n" string_of_ctyp polymorphic_ctyps)) - else - let deps = List.concat (List.map ctyp_dependencies ctyps) in - separate_map hardline (codegen_ctg ctx) deps - ^^ codegen_def' ctx def - -let is_cdef_startup = function - | CDEF_startup _ -> true - | _ -> false - -let sgen_startup = function - | CDEF_startup (id, _) -> - Printf.sprintf " startup_%s();" (sgen_id id) - | _ -> assert false - -let sgen_instr id ctx instr = - Pretty_print_sail.to_string (codegen_instr id ctx instr) - -let is_cdef_finish = function - | CDEF_startup _ -> true - | _ -> false - -let sgen_finish = function - | CDEF_startup (id, _) -> - Printf.sprintf " finish_%s();" (sgen_id id) - | _ -> assert false - -let instrument_tracing ctx = - let module StringSet = Set.Make(String) in - let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in - let rec instrument = function - | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> - let trace_start = - iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id))) - in - let trace_arg cval = - let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval)) - else - iraw "trace_unknown();" - in - let rec trace_args = function - | [] -> [] - | [cval] -> [trace_arg cval] - | cval :: cvals -> - trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals - in - let trace_end = iraw "trace_end();" in - let trace_ret = iraw "trace_unknown();" - (* - let ctyp_name = sgen_ctyp_name ctyp in - if StringSet.mem ctyp_name traceable then - iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) - else - iraw "trace_unknown();" - *) - in - [trace_start] - @ trace_args args - @ [iraw "trace_argend();"; - instr; - trace_end; - trace_ret; - iraw "trace_retend();"] - @ instrument instrs - - | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs - | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs - | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> - I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs - - | instr :: instrs -> instr :: instrument instrs - | [] -> [] - in - function - | CDEF_fundef (function_id, heap_return, args, body) -> - CDEF_fundef (function_id, heap_return, args, instrument body) - | cdef -> cdef - -let bytecode_ast ctx rewrites (Defs defs) = - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in - - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in - let total = List.length defs in - let _, chunks, ctx = - List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs - in - let cdefs = List.concat (List.rev chunks) in - let cdefs, ctx = specialize_variants ctx [] cdefs in - rewrites cdefs - -let rec get_recursive_functions (Defs defs) = - match defs with - | DEF_internal_mutrec fundefs :: defs -> - IdSet.union (List.map id_of_fundef fundefs |> IdSet.of_list) (get_recursive_functions (Defs defs)) - - | (DEF_fundef fdef as def) :: defs -> - let open Rewriter in - let ids = ref IdSet.empty in - let collect_funcalls e_aux annot = - match e_aux with - | E_app (id, args) -> (ids := IdSet.add id !ids; E_aux (e_aux, annot)) - | _ -> E_aux (e_aux, annot) - in - let map_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> collect_funcalls e_aux annot) - } in - let map_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp map_exp) } in - let _ = rewrite_def map_defs def in - if IdSet.mem (id_of_fundef fdef) !ids then - IdSet.add (id_of_fundef fdef) (get_recursive_functions (Defs defs)) - else - get_recursive_functions (Defs defs) - - | _ :: defs -> get_recursive_functions (Defs defs) - | [] -> IdSet.empty - -let trace_cval = function (frag, ctyp) -> string_of_fragment frag ^ " : " ^ string_of_ctyp ctyp - -let rec trace_clexp = function - | CL_id (id, ctyp) -> sgen_id id ^ " : " ^ string_of_ctyp ctyp - | CL_field (clexp, field) -> "(" ^ trace_clexp clexp ^ ")->" ^ field ^ ")" - | CL_tuple (clexp, n) -> "(" ^ trace_clexp clexp ^ ")." ^ string_of_int n - | CL_addr clexp -> "*(" ^ trace_clexp clexp ^ ")" - | CL_have_exception -> "have_exception" - | CL_current_exception _ -> "current_exception" - -let rec smt_trace_instrs ctx function_id = function - | I_aux (I_jump (cval, label), aux) :: instrs -> - iraw ("printf(\"!branch %s %s\\n\"," ^ sgen_cval cval ^ " ?\"true\":\"false\", \"" ^ trace_cval cval ^ "\");") - :: I_aux (I_jump (cval, label), aux) - :: smt_trace_instrs ctx function_id instrs - - | (I_aux ((I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval)), _) as instr) :: instrs -> - iraw ("printf(\"!create " ^ Util.zencode_string (string_of_id id) ^ " : " ^ string_of_ctyp ctyp ^ " = " ^ trace_cval cval ^ "\\n\");") - :: instr - :: smt_trace_instrs ctx function_id instrs - - | (I_aux ((I_decl (ctyp, id) | I_reset (ctyp, id)), _) as instr) :: instrs -> - iraw ("printf(\"!create " ^ Util.zencode_string (string_of_id id) ^ " : " ^ string_of_ctyp ctyp ^ "\\n\");") - :: instr - :: smt_trace_instrs ctx function_id instrs - - | I_aux (I_funcall (x, extern, f, args), aux) :: instrs -> - let extern_name = - if Env.is_extern f ctx.tc_env "c" then - Some (Env.get_extern f ctx.tc_env "c") - else if extern then - Some (string_of_id f) - else None - in - begin match extern_name with - | Some name -> - iraw ("printf(\"!" - ^ trace_clexp x - ^ " = " - ^ string_of_id f ^ "(" ^ Util.string_of_list ", " (fun cval -> String.escaped (trace_cval cval)) args ^ ")\\n\");") - :: I_aux (I_funcall (x, extern, f, args), aux) - :: smt_trace_instrs ctx function_id instrs - | None -> - iraw ("printf(\"!call " ^ string_of_id f ^ "(" ^ Util.string_of_list ", " (fun cval -> String.escaped (trace_cval cval)) args ^ ")\\n\");") - :: I_aux (I_funcall (x, extern, f, args), aux) - :: iraw ("printf(\"!" ^ trace_clexp x ^ " = endcall " ^ string_of_id f ^ "\\n\");") - :: smt_trace_instrs ctx function_id instrs - end - - | I_aux (I_return cval, aux) :: instrs -> - iraw ("printf(\"!return " ^ trace_cval cval ^ "\\n\");") - :: I_aux (I_return cval, aux) - :: smt_trace_instrs ctx function_id instrs - - | instr :: instrs -> instr :: smt_trace_instrs ctx function_id instrs - - | [] -> [] - -let smt_trace ctx = - function - | CDEF_fundef (function_id, heap_return, args, body) -> - let string_of_heap_return = function - | Some id -> Util.zencode_string (string_of_id id) - | None -> "return" - in - let body = - iraw ("printf(\"!link " ^ string_of_heap_return heap_return ^ "(" ^ Util.string_of_list ", " (fun id -> Util.zencode_string (string_of_id id)) args ^ ")\\n\");") - :: smt_trace_instrs ctx function_id body - in - CDEF_fundef (function_id, heap_return, args, body) - - | cdef -> cdef - -let compile_ast ctx output_chan c_includes (Defs defs) = - try - c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions")); - let recursive_functions = Spec_analysis.top_sort_defs (Defs defs) |> get_recursive_functions in - let ctx = { ctx with recursive_functions = recursive_functions } in - c_debug (lazy (Util.string_of_list ", " string_of_id (IdSet.elements recursive_functions))); - - let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in - let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in - let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in - - if !opt_memo_cache then - (try - if Sys.is_directory "_sbuild" then - () - else - raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!") - with - | Sys_error _ -> Unix.mkdir "_sbuild" 0o775) - else (); - - let total = List.length defs in - let _, chunks, ctx = - List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs - in - let cdefs = List.concat (List.rev chunks) in - - let cdefs, ctx = specialize_variants ctx [] cdefs in - let cdefs = sort_ctype_defs cdefs in - let cdefs = optimize ctx cdefs in - let cdefs = if !opt_trace then List.map (instrument_tracing ctx) cdefs else cdefs in - - let cdefs = if !opt_smt_trace then List.map (fun cdef -> smt_trace ctx (flatten_cdef cdef)) cdefs else cdefs in - - let docs = List.map (codegen_def ctx) cdefs in - - let preamble = separate hardline - ([ string "#include \"sail.h\"" ] - @ (if !opt_no_rts then [] else - [ string "#include \"rts.h\""; - string "#include \"elf.h\"" ]) - @ (List.map (fun h -> string (Printf.sprintf "#include \"%s\"" h)) c_includes)) - in - - let exn_boilerplate = - if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else - ([ " current_exception = malloc(sizeof(struct zexception));"; - " CREATE(zexception)(current_exception);" ], - [ " KILL(zexception)(current_exception);"; - " free(current_exception);"; - " if (have_exception) fprintf(stderr, \"Exiting due to uncaught exception\\n\");" ]) - in - - let letbind_initializers = - List.map (fun n -> Printf.sprintf " create_letbind_%d();" n) (List.rev ctx.letbinds) - in - let letbind_finalizers = - List.map (fun n -> Printf.sprintf " kill_letbind_%d();" n) ctx.letbinds - in - let startup cdefs = - List.map sgen_startup (List.filter is_cdef_startup cdefs) - in - let finish cdefs = - List.map sgen_finish (List.filter is_cdef_finish cdefs) - in - - let regs = c_ast_registers cdefs in - - let register_init_clear (id, ctyp, instrs) = - if is_stack_ctyp ctyp then - List.map (sgen_instr (mk_id "reg") ctx) instrs, [] - else - [ Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] - @ List.map (sgen_instr (mk_id "reg") ctx) instrs, - [ Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] - in - - let model_init = separate hardline (List.map string - ( [ "void model_init(void)"; - "{"; - " setup_rts();" ] - @ fst exn_boilerplate - @ startup cdefs - @ List.concat (List.map (fun r -> fst (register_init_clear r)) regs) - @ (if regs = [] then [] else [ Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "initialize_registers")) ]) - @ letbind_initializers - @ [ "}" ] )) - in - - let model_fini = separate hardline (List.map string - ( [ "void model_fini(void)"; - "{" ] - @ letbind_finalizers - @ List.concat (List.map (fun r -> snd (register_init_clear r)) regs) - @ finish cdefs - @ snd exn_boilerplate - @ [ " cleanup_rts();"; - "}" ] )) - in - - let model_default_main = separate hardline (List.map string - [ "int model_main(int argc, char *argv[])"; - "{"; - " model_init();"; - " if (process_arguments(argc, argv)) exit(EXIT_FAILURE);"; - Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "main")); - " model_fini();"; - " return EXIT_SUCCESS;"; - "}" ] ) - in - - let model_main = separate hardline (if (!opt_no_main) then [] else List.map string - [ "int main(int argc, char *argv[])"; - "{"; - " return model_main(argc, argv);"; - "}" ] ) - in - - let hlhl = hardline ^^ hardline in - - Pretty_print_sail.to_string (preamble ^^ hlhl ^^ separate hlhl docs ^^ hlhl - ^^ (if not !opt_no_rts then - model_init ^^ hlhl - ^^ model_fini ^^ hlhl - ^^ model_default_main ^^ hlhl - else - empty) - ^^ model_main ^^ hardline) - |> output_string output_chan - with - Type_error (_, l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) diff --git a/src/c_backend.mli b/src/c_backend.mli deleted file mode 100644 index 4017130a..00000000 --- a/src/c_backend.mli +++ /dev/null @@ -1,141 +0,0 @@ -(**************************************************************************) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(**************************************************************************) - -open Bytecode -open Type_check - -(** Global compilation options *) - -(** Output a dataflow graph for each generated function in Graphviz - (dot) format. *) -val opt_debug_flow_graphs : bool ref - -(** Print the ANF and IR representations of a specific function. *) -val opt_debug_function : string ref - -(** Instrument generated code to output a trace. opt_smt_trace is WIP - but intended to enable generating traces suitable for concolic - execution with SMT. *) -val opt_trace : bool ref -val opt_smt_trace : bool ref - -(** Define generated functions as static *) -val opt_static : bool ref - -(** Do not generate a main function *) -val opt_no_main : bool ref - -(** (WIP) Do not include rts.h (the runtime), and do not generate code - that requires any setup or teardown routines to be run by a runtime - before executing any instruction semantics. *) -val opt_no_rts : bool ref - -(** Ordinarily we use plain z-encoding to name-mangle generated Sail - identifiers into a form suitable for C. If opt_prefix is set, then - the "z" which is added on the front of each generated C function - will be replaced by opt_prefix. E.g. opt_prefix := "sail_" would - give sail_my_function rather than zmy_function. *) -val opt_prefix : string ref - -(** opt_extra_params and opt_extra_arguments allow additional state to - be threaded through the generated C code by adding an additional - parameter to each function type, and then giving an extra argument - to each function call. For example we could have - - opt_extra_params := Some "CPUMIPSState *env" - opt_extra_arguments := Some "env" - - and every generated function will take a pointer to a QEMU MIPS - processor state, and each function will be passed the env argument - when it is called. *) -val opt_extra_params : string option ref -val opt_extra_arguments : string option ref - -(** (WIP) [opt_memo_cache] will store the compiled function - definitions in file _sbuild/ccacheDIGEST where DIGEST is the md5sum - of the original function to be compiled. Enabled using the -memo - flag. Uses Marshal so it's quite picky about the exact version of - the Sail version. This cache can obviously become stale if the C - backend changes - it'll load an old version compiled without said - changes. *) -val opt_memo_cache : bool ref - -(** Optimization flags *) - -val optimize_primops : bool ref -val optimize_hoist_allocations : bool ref -val optimize_struct_updates : bool ref -val optimize_alias : bool ref -val optimize_experimental : bool ref - -(** The compilation context. *) -type ctx - -(** Create a context from a typechecking environment. This environment - should be the environment returned by typechecking the full AST. *) -val initial_ctx : Env.t -> ctx - -(** Same as initial ctx, but iterate to find more precise bounds on - integers. *) -val initial_ctx_iterate : Env.t -> ctx - -(** Convert a typ to a IR ctyp *) -val ctyp_of_typ : ctx -> Ast.typ -> ctyp - -val compile_aexp : ctx -> Ast.typ Anf.aexp -> instr list * (clexp -> instr) * instr list - -val compile_ast : ctx -> out_channel -> string list -> tannot Ast.defs -> unit - -val bytecode_ast : ctx -> (cdef list -> cdef list) -> tannot Ast.defs -> cdef list - -(** Rewriting steps for compiled ASTs *) -val flatten_instrs : instr list -> instr list - -val flatten_cdef : cdef -> cdef diff --git a/src/isail.ml b/src/isail.ml index 4c7cf8d6..e47973b4 100644 --- a/src/isail.ml +++ b/src/isail.ml @@ -57,7 +57,6 @@ open Pretty_print_sail type mode = | Evaluation of frame - | Bytecode of Value2.vl Bytecode_interpreter.gstate * Value2.vl Bytecode_interpreter.stack | Normal | Emacs @@ -67,7 +66,6 @@ let prompt () = match !current_mode with | Normal -> "sail> " | Evaluation _ -> "eval> " - | Bytecode _ -> "ir> " | Emacs -> "" let eval_clear = ref true @@ -76,7 +74,6 @@ let mode_clear () = match !current_mode with | Normal -> () | Evaluation _ -> if !eval_clear then LNoise.clear_screen () else () - | Bytecode _ -> () (* if !eval_clear then LNoise.clear_screen () else () *) | Emacs -> () let rec user_input callback = @@ -126,22 +123,6 @@ let print_program () = | Evaluation (Done (_, v)) -> print_endline (Value.string_of_value v |> Util.green |> Util.clear) | Evaluation _ -> () - | Bytecode (_, stack) -> - let open Bytecode_interpreter in - let open Bytecode_util in - let pc = stack.top.pc in - let instrs = stack.top.instrs in - for i = 0 to stack.top.pc - 1 do - print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) - done; - print_endline (">> " ^ Pretty_print_sail.to_string (pp_instr instrs.(stack.top.pc))); - for i = stack.top.pc + 1 to Array.length instrs - 1 do - print_endline (" " ^ Pretty_print_sail.to_string (pp_instr instrs.(i))) - done; - print_endline sep; - print_endline (Util.string_of_list ", " - (fun (id, vl) -> Printf.sprintf "%s = %s" (string_of_id id) (string_of_value vl)) - (Bindings.bindings stack.top.locals)) let rec run () = match !current_mode with @@ -165,7 +146,6 @@ let rec run () = print_endline "Breakpoint"; current_mode := Evaluation frame end - | Bytecode _ -> () let rec run_steps n = print_endline ("step " ^ string_of_int n); @@ -191,7 +171,6 @@ let rec run_steps n = print_endline "Breakpoint"; current_mode := Evaluation frame end - | Bytecode _ -> () let help = function | ":t" | ":type" -> @@ -372,16 +351,19 @@ let handle_input' input = | ":pretty" -> print_endline (Pretty_print_sail.to_string (Latex.defs !Interactive.ast)) | ":compile" -> + (* let open PPrint in let open C_backend in let ast = Process_file.rewrite_ast_c !Interactive.env !Interactive.ast in let ast, env = Specialize.(specialize typ_ord_specialization ast !Interactive.env) in let ctx = initial_ctx env in interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast + *) + () | ":ir" -> print_endline arg; - let open Bytecode in - let open Bytecode_util in + let open Jib in + let open Jib_util in let open PPrint in let is_cdef = function | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true @@ -426,16 +408,6 @@ let handle_input' input = (* See initial_check.mli for an explanation of why we need this. *) Initial_check.have_undefined_builtins := false; Process_file.clear_symbols () - | ":exec" -> - let open Bytecode_interpreter in - let exp = Type_check.infer_exp !Interactive.env (Initial_check.exp_of_string arg) in - let anf = Anf.anf exp in - let ctx = C_backend.initial_ctx !Interactive.env in - let ctyp = C_backend.ctyp_of_typ ctx (Type_check.typ_of exp) in - let setup, call, cleanup = C_backend.compile_aexp ctx anf in - let instrs = C_backend.flatten_instrs (setup @ [call (CL_id (mk_id "interactive#", ctyp))] @ cleanup) in - current_mode := Bytecode (new_gstate !interactive_bytecode, new_stack instrs); - print_program () | _ -> unrecognised_command cmd end | Expression str -> @@ -538,17 +510,6 @@ let handle_input' input = current_mode := Evaluation frame end end - | Bytecode (gstate, stack) -> - begin match input with - | Command (cmd, arg) -> - () - | Expression str -> - print_endline "Evaluating IR, cannot evaluate expression" - | Empty -> - let gstate, stack = Bytecode_interpreter.step (gstate, stack) in - current_mode := Bytecode (gstate, stack); - print_program () - end let handle_input input = try handle_input' input with diff --git a/src/jib/anf.ml b/src/jib/anf.ml new file mode 100644 index 00000000..16fb6756 --- /dev/null +++ b/src/jib/anf.ml @@ -0,0 +1,717 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_util +open Type_check +open PPrint + +module Big_int = Nat_big_num + +(**************************************************************************) +(* 1. Conversion to A-normal form (ANF) *) +(**************************************************************************) + +(* The first step in compiling sail is converting the Sail expression + grammar into A-normal form. Essentially this converts expressions + such as f(g(x), h(y)) into something like: + + let v0 = g(x) in let v1 = h(x) in f(v0, v1) + + Essentially the arguments to every function must be trivial, and + complex expressions must be let bound to new variables, or used in + a block, assignment, or control flow statement (if, for, and + while/until loops). The aexp datatype represents these expressions, + while aval represents the trivial values. + + The convention is that the type of an aexp is given by last + argument to a constructor. It is omitted where it is obvious - for + example all for loops have unit as their type. If some constituent + part of the aexp has an annotation, the it refers to the previous + argument, so in + + AE_let (id, typ1, _, body, typ2) + + typ1 is the type of the bound identifer, whereas typ2 is the type + of the whole let expression (and therefore also the body). + + See Flanagan et al's 'The Essence of Compiling with Continuations' + *) +type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l + +and 'a aexp_aux = + | AE_val of 'a aval + | AE_app of id * ('a aval) list * 'a + | AE_cast of 'a aexp * 'a + | AE_assign of id * 'a * 'a aexp + | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a + | AE_block of ('a aexp) list * 'a aexp * 'a + | AE_return of 'a aval * 'a + | AE_throw of 'a aval * 'a + | AE_if of 'a aval * 'a aexp * 'a aexp * 'a + | AE_field of 'a aval * id * 'a + | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a + | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp + | AE_loop of loop * 'a aexp * 'a aexp + | AE_short_circuit of sc_op * 'a aval * 'a aexp + +and sc_op = SC_and | SC_or + +and 'a apat = AP_aux of 'a apat_aux * Env.t * l + +and 'a apat_aux = + | AP_tup of ('a apat) list + | AP_id of id * 'a + | AP_global of id * 'a + | AP_app of id * 'a apat * 'a + | AP_cons of 'a apat * 'a apat + | AP_nil of 'a + | AP_wild of 'a + +and 'a aval = + | AV_lit of lit * 'a + | AV_id of id * 'a lvar + | AV_ref of id * 'a lvar + | AV_tuple of ('a aval) list + | AV_list of ('a aval) list * 'a + | AV_vector of ('a aval) list * 'a + | AV_record of ('a aval) Bindings.t * 'a + | AV_C_fragment of fragment * 'a * ctyp + +(* Renaming variables in ANF expressions *) + +let rec apat_bindings (AP_aux (apat_aux, _, _)) = + match apat_aux with + | AP_tup apats -> List.fold_left IdSet.union IdSet.empty (List.map apat_bindings apats) + | AP_id (id, _) -> IdSet.singleton id + | AP_global (id, _) -> IdSet.empty + | AP_app (id, apat, _) -> apat_bindings apat + | AP_cons (apat1, apat2) -> IdSet.union (apat_bindings apat1) (apat_bindings apat2) + | AP_nil _ -> IdSet.empty + | AP_wild _ -> IdSet.empty + +(** This function returns the types of all bound variables in a + pattern. It ignores AP_global, apat_globals is used for that. *) +let rec apat_types (AP_aux (apat_aux, _, _)) = + let merge id b1 b2 = + match b1, b2 with + | None, None -> None + | Some v, None -> Some v + | None, Some v -> Some v + | Some _, Some _ -> assert false + in + match apat_aux with + | AP_tup apats -> List.fold_left (Bindings.merge merge) Bindings.empty (List.map apat_types apats) + | AP_id (id, typ) -> Bindings.singleton id typ + | AP_global (id, _) -> Bindings.empty + | AP_app (id, apat, _) -> apat_types apat + | AP_cons (apat1, apat2) -> (Bindings.merge merge) (apat_types apat1) (apat_types apat2) + | AP_nil _ -> Bindings.empty + | AP_wild _ -> Bindings.empty + +let rec apat_rename from_id to_id (AP_aux (apat_aux, env, l)) = + let apat_aux = match apat_aux with + | AP_tup apats -> AP_tup (List.map (apat_rename from_id to_id) apats) + | AP_id (id, typ) when Id.compare id from_id = 0 -> AP_id (to_id, typ) + | AP_id (id, typ) -> AP_id (id, typ) + | AP_global (id, typ) -> AP_global (id, typ) + | AP_app (ctor, apat, typ) -> AP_app (ctor, apat_rename from_id to_id apat, typ) + | AP_cons (apat1, apat2) -> AP_cons (apat_rename from_id to_id apat1, apat_rename from_id to_id apat2) + | AP_nil typ -> AP_nil typ + | AP_wild typ -> AP_wild typ + in + AP_aux (apat_aux, env, l) + +let rec aval_rename from_id to_id = function + | AV_lit (lit, typ) -> AV_lit (lit, typ) + | AV_id (id, lvar) when Id.compare id from_id = 0 -> AV_id (to_id, lvar) + | AV_id (id, lvar) -> AV_id (id, lvar) + | AV_ref (id, lvar) when Id.compare id from_id = 0 -> AV_ref (to_id, lvar) + | AV_ref (id, lvar) -> AV_ref (id, lvar) + | AV_tuple avals -> AV_tuple (List.map (aval_rename from_id to_id) avals) + | AV_list (avals, typ) -> AV_list (List.map (aval_rename from_id to_id) avals, typ) + | AV_vector (avals, typ) -> AV_vector (List.map (aval_rename from_id to_id) avals, typ) + | AV_record (avals, typ) -> AV_record (Bindings.map (aval_rename from_id to_id) avals, typ) + | AV_C_fragment (fragment, typ, ctyp) -> AV_C_fragment (frag_rename from_id to_id fragment, typ, ctyp) + +let rec aexp_rename from_id to_id (AE_aux (aexp, env, l)) = + let recur = aexp_rename from_id to_id in + let aexp = match aexp with + | AE_val aval -> AE_val (aval_rename from_id to_id aval) + | AE_app (id, avals, typ) -> AE_app (id, List.map (aval_rename from_id to_id) avals, typ) + | AE_cast (aexp, typ) -> AE_cast (recur aexp, typ) + | AE_assign (id, typ, aexp) when Id.compare from_id id = 0 -> AE_assign (to_id, typ, aexp_rename from_id to_id aexp) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, aexp_rename from_id to_id aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when Id.compare from_id id = 0 -> AE_let (mut, id, typ1, recur aexp1, aexp2, typ2) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, recur aexp1, recur aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map recur aexps, recur aexp, typ) + | AE_return (aval, typ) -> AE_return (aval_rename from_id to_id aval, typ) + | AE_throw (aval, typ) -> AE_throw (aval_rename from_id to_id aval, typ) + | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval_rename from_id to_id aval, recur then_aexp, recur else_aexp, typ) + | AE_field (aval, id, typ) -> AE_field (aval_rename from_id to_id aval, id, typ) + | AE_case (aval, apexps, typ) -> AE_case (aval_rename from_id to_id aval, List.map (apexp_rename from_id to_id) apexps, typ) + | AE_try (aexp, apexps, typ) -> AE_try (aexp_rename from_id to_id aexp, List.map (apexp_rename from_id to_id) apexps, typ) + | AE_record_update (aval, avals, typ) -> AE_record_update (aval_rename from_id to_id aval, Bindings.map (aval_rename from_id to_id) avals, typ) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when Id.compare from_id to_id = 0 -> AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> AE_for (id, recur aexp1, recur aexp2, recur aexp3, order, recur aexp4) + | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, recur aexp1, recur aexp2) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval_rename from_id to_id aval, recur aexp) + in + AE_aux (aexp, env, l) + +and apexp_rename from_id to_id (apat, aexp1, aexp2) = + if IdSet.mem from_id (apat_bindings apat) then + (apat, aexp1, aexp2) + else + (apat, aexp_rename from_id to_id aexp1, aexp_rename from_id to_id aexp2) + +let shadow_counter = ref 0 + +let new_shadow id = + let shadow_id = append_id id ("shadow#" ^ string_of_int !shadow_counter) in + incr shadow_counter; + shadow_id + +let rec no_shadow ids (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_val aval -> AE_val aval + | AE_app (id, avals, typ) -> AE_app (id, avals, typ) + | AE_cast (aexp, typ) -> AE_cast (no_shadow ids aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, no_shadow ids aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) when IdSet.mem id ids -> + let shadow_id = new_shadow id in + let aexp1 = no_shadow ids aexp1 in + let ids = IdSet.add shadow_id ids in + AE_let (mut, shadow_id, typ1, aexp1, no_shadow ids (aexp_rename id shadow_id aexp2), typ2) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> + AE_let (mut, id, typ1, no_shadow ids aexp1, no_shadow (IdSet.add id ids) aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (no_shadow ids) aexps, no_shadow ids aexp, typ) + | AE_return (aval, typ) -> AE_return (aval, typ) + | AE_throw (aval, typ) -> AE_throw (aval, typ) + | AE_if (aval, then_aexp, else_aexp, typ) -> AE_if (aval, no_shadow ids then_aexp, no_shadow ids else_aexp, typ) + | AE_field (aval, id, typ) -> AE_field (aval, id, typ) + | AE_case (aval, apexps, typ) -> AE_case (aval, List.map (no_shadow_apexp ids) apexps, typ) + | AE_try (aexp, apexps, typ) -> AE_try (no_shadow ids aexp, List.map (no_shadow_apexp ids) apexps, typ) + | AE_record_update (aval, avals, typ) -> AE_record_update (aval, avals, typ) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) when IdSet.mem id ids -> + let shadow_id = new_shadow id in + let aexp1 = no_shadow ids aexp1 in + let aexp2 = no_shadow ids aexp2 in + let aexp3 = no_shadow ids aexp3 in + let ids = IdSet.add shadow_id ids in + AE_for (shadow_id, aexp1, aexp2, aexp3, order, no_shadow ids (aexp_rename id shadow_id aexp4)) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let ids = IdSet.add id ids in + AE_for (id, no_shadow ids aexp1, no_shadow ids aexp2, no_shadow ids aexp3, order, no_shadow ids aexp4) + | AE_loop (loop, aexp1, aexp2) -> AE_loop (loop, no_shadow ids aexp1, no_shadow ids aexp2) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, no_shadow ids aexp) + in + AE_aux (aexp, env, l) + +and no_shadow_apexp ids (apat, aexp1, aexp2) = + let shadows = IdSet.inter (apat_bindings apat) ids in + let shadows = List.map (fun id -> id, new_shadow id) (IdSet.elements shadows) in + let rename aexp = List.fold_left (fun aexp (from_id, to_id) -> aexp_rename from_id to_id aexp) aexp shadows in + let rename_apat apat = List.fold_left (fun apat (from_id, to_id) -> apat_rename from_id to_id apat) apat shadows in + let ids = IdSet.union (apat_bindings apat) (IdSet.union ids (IdSet.of_list (List.map snd shadows))) in + (rename_apat apat, no_shadow ids (rename aexp1), no_shadow ids (rename aexp2)) + +(* Map over all the avals in an aexp. *) +let rec map_aval f (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_val v -> AE_val (f env l v) + | AE_cast (aexp, typ) -> AE_cast (map_aval f aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_aval f aexp) + | AE_app (id, vs, typ) -> AE_app (id, List.map (f env l) vs, typ) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> + AE_let (mut, id, typ1, map_aval f aexp1, map_aval f aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_aval f) aexps, map_aval f aexp, typ) + | AE_return (aval, typ) -> AE_return (f env l aval, typ) + | AE_throw (aval, typ) -> AE_throw (f env l aval, typ) + | AE_if (aval, aexp1, aexp2, typ2) -> + AE_if (f env l aval, map_aval f aexp1, map_aval f aexp2, typ2) + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_aval f aexp1, map_aval f aexp2) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + AE_for (id, map_aval f aexp1, map_aval f aexp2, map_aval f aexp3, order, map_aval f aexp4) + | AE_record_update (aval, updates, typ) -> + AE_record_update (f env l aval, Bindings.map (f env l) updates, typ) + | AE_field (aval, field, typ) -> + AE_field (f env l aval, field, typ) + | AE_case (aval, cases, typ) -> + AE_case (f env l aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (map_aval f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_aval f aexp1, map_aval f aexp2) cases, typ) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, f env l aval, map_aval f aexp) + in + AE_aux (aexp, env, l) + +(* Map over all the functions in an aexp. *) +let rec map_functions f (AE_aux (aexp, env, l)) = + let aexp = match aexp with + | AE_app (id, vs, typ) -> f env l id vs typ + | AE_cast (aexp, typ) -> AE_cast (map_functions f aexp, typ) + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, map_functions f aexp) + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, map_functions f aexp) + | AE_let (mut, id, typ1, aexp1, aexp2, typ2) -> AE_let (mut, id, typ1, map_functions f aexp1, map_functions f aexp2, typ2) + | AE_block (aexps, aexp, typ) -> AE_block (List.map (map_functions f) aexps, map_functions f aexp, typ) + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, map_functions f aexp1, map_functions f aexp2, typ) + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, map_functions f aexp1, map_functions f aexp2) + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + AE_for (id, map_functions f aexp1, map_functions f aexp2, map_functions f aexp3, order, map_functions f aexp4) + | AE_case (aval, cases, typ) -> + AE_case (aval, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) + | AE_try (aexp, cases, typ) -> + AE_try (map_functions f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, map_functions f aexp1, map_functions f aexp2) cases, typ) + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) + +(* For debugging we provide a pretty printer for ANF expressions. *) + +let pp_lvar lvar doc = + match lvar with + | Register (_, _, typ) -> + string "[R/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Local (Mutable, typ) -> + string "[M/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Local (Immutable, typ) -> + string "[I/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Enum typ -> + string "[E/" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + | Unbound -> string "[?]" ^^ doc + +let pp_annot typ doc = + string "[" ^^ string (string_of_typ typ |> Util.yellow |> Util.clear) ^^ string "]" ^^ doc + +let pp_order = function + | Ord_aux (Ord_inc, _) -> string "inc" + | Ord_aux (Ord_dec, _) -> string "dec" + | _ -> assert false (* Order types have been specialised, so no polymorphism in C backend. *) + +let rec pp_aexp (AE_aux (aexp, _, _)) = + match aexp with + | AE_val v -> pp_aval v + | AE_cast (aexp, typ) -> + pp_annot typ (string "$" ^^ pp_aexp aexp) + | AE_assign (id, typ, aexp) -> + pp_annot typ (pp_id id) ^^ string " := " ^^ pp_aexp aexp + | AE_app (id, args, typ) -> + pp_annot typ (pp_id id ^^ parens (separate_map (comma ^^ space) pp_aval args)) + | AE_short_circuit (SC_or, aval, aexp) -> + pp_aval aval ^^ string " || " ^^ pp_aexp aexp + | AE_short_circuit (SC_and, aval, aexp) -> + pp_aval aval ^^ string " && " ^^ pp_aexp aexp + | AE_let (mut, id, id_typ, binding, body, typ) -> group + begin + let let_doc = string (match mut with Immutable -> "let" | Mutable -> "let mut") in + match binding with + | AE_aux (AE_let _, _, _) -> + (pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="]) + ^^ hardline ^^ nest 2 (pp_aexp binding)) + ^^ hardline ^^ string "in" ^^ space ^^ pp_aexp body + | _ -> + pp_annot typ (separate space [string "let"; pp_annot id_typ (pp_id id); string "="; pp_aexp binding; string "in"]) + ^^ hardline ^^ pp_aexp body + end + | AE_if (cond, then_aexp, else_aexp, typ) -> + pp_annot typ (separate space [ string "if"; pp_aval cond; + string "then"; pp_aexp then_aexp; + string "else"; pp_aexp else_aexp ]) + | AE_block (aexps, aexp, typ) -> + pp_annot typ (surround 2 0 lbrace (pp_block (aexps @ [aexp])) rbrace) + | AE_return (v, typ) -> pp_annot typ (string "return" ^^ parens (pp_aval v)) + | AE_throw (v, typ) -> pp_annot typ (string "throw" ^^ parens (pp_aval v)) + | AE_loop (While, aexp1, aexp2) -> + separate space [string "while"; pp_aexp aexp1; string "do"; pp_aexp aexp2] + | AE_loop (Until, aexp1, aexp2) -> + separate space [string "repeat"; pp_aexp aexp2; string "until"; pp_aexp aexp1] + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let header = + string "foreach" ^^ space ^^ + group (parens (separate (break 1) + [ pp_id id; + string "from " ^^ pp_aexp aexp1; + string "to " ^^ pp_aexp aexp2; + string "by " ^^ pp_aexp aexp3; + string "in " ^^ pp_order order ])) + in + header ^//^ pp_aexp aexp4 + | AE_field (aval, field, typ) -> pp_annot typ (parens (pp_aval aval ^^ string "." ^^ pp_id field)) + | AE_case (aval, cases, typ) -> + pp_annot typ (separate space [string "match"; pp_aval aval; pp_cases cases]) + | AE_try (aexp, cases, typ) -> + pp_annot typ (separate space [string "try"; pp_aexp aexp; pp_cases cases]) + | AE_record_update (aval, updates, typ) -> + braces (pp_aval aval ^^ string " with " + ^^ separate (string ", ") (List.map (fun (id, aval) -> pp_id id ^^ string " = " ^^ pp_aval aval) + (Bindings.bindings updates))) + +and pp_apat (AP_aux (apat_aux, _, _)) = + match apat_aux with + | AP_wild _ -> string "_" + | AP_id (id, typ) -> pp_annot typ (pp_id id) + | AP_global (id, _) -> pp_id id + | AP_tup apats -> parens (separate_map (comma ^^ space) pp_apat apats) + | AP_app (id, apat, typ) -> pp_annot typ (pp_id id ^^ parens (pp_apat apat)) + | AP_nil _ -> string "[||]" + | AP_cons (hd_apat, tl_apat) -> pp_apat hd_apat ^^ string " :: " ^^ pp_apat tl_apat + +and pp_cases cases = surround 2 0 lbrace (separate_map (comma ^^ hardline) pp_case cases) rbrace + +and pp_case (apat, guard, body) = + separate space [pp_apat apat; string "if"; pp_aexp guard; string "=>"; pp_aexp body] + +and pp_block = function + | [] -> string "()" + | [aexp] -> pp_aexp aexp + | aexp :: aexps -> pp_aexp aexp ^^ semi ^^ hardline ^^ pp_block aexps + +and pp_aval = function + | AV_lit (lit, typ) -> pp_annot typ (string (string_of_lit lit)) + | AV_id (id, lvar) -> pp_lvar lvar (pp_id id) + | AV_tuple avals -> parens (separate_map (comma ^^ space) pp_aval avals) + | AV_ref (id, lvar) -> string "ref" ^^ space ^^ pp_lvar lvar (pp_id id) + | AV_C_fragment (frag, typ, ctyp) -> + pp_annot typ (string ("(" ^ string_of_ctyp ctyp ^ ")" ^ string_of_fragment frag |> Util.cyan |> Util.clear)) + | AV_vector (avals, typ) -> + pp_annot typ (string "[" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "]") + | AV_list (avals, typ) -> + pp_annot typ (string "[|" ^^ separate_map (comma ^^ space) pp_aval avals ^^ string "|]") + | AV_record (fields, typ) -> + pp_annot typ (string "struct {" + ^^ separate_map (comma ^^ space) (fun (id, field) -> pp_id id ^^ string " = " ^^ pp_aval field) (Bindings.bindings fields) + ^^ string "}") + +let ae_lit lit typ = AE_val (AV_lit (lit, typ)) + +let is_dead_aexp (AE_aux (_, env, _)) = prove __POS__ env nc_false + +(** GLOBAL: gensym_counter is used to generate fresh identifiers where + needed. It should be safe to reset between top level + definitions. **) +let gensym_counter = ref 0 + +let gensym () = + let id = mk_id ("gs#" ^ string_of_int !gensym_counter) in + incr gensym_counter; + id + +let rec split_block l = function + | [exp] -> [], exp + | exp :: exps -> + let exps, last = split_block l exps in + exp :: exps, last + | [] -> + raise (Reporting.err_unreachable l __POS__ "empty block found when converting to ANF") + +let rec anf_pat ?global:(global=false) (P_aux (p_aux, annot) as pat) = + let mk_apat aux = AP_aux (aux, env_of_annot annot, fst annot) in + match p_aux with + | P_id id when global -> mk_apat (AP_global (id, typ_of_pat pat)) + | P_id id -> mk_apat (AP_id (id, typ_of_pat pat)) + | P_wild -> mk_apat (AP_wild (typ_of_pat pat)) + | P_tup pats -> mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)) + | P_app (id, [subpat]) -> mk_apat (AP_app (id, anf_pat ~global:global subpat, typ_of_pat pat)) + | P_app (id, pats) -> mk_apat (AP_app (id, mk_apat (AP_tup (List.map (fun pat -> anf_pat ~global:global pat) pats)), typ_of_pat pat)) + | P_typ (_, pat) -> anf_pat ~global:global pat + | P_var (pat, _) -> anf_pat ~global:global pat + | P_cons (hd_pat, tl_pat) -> mk_apat (AP_cons (anf_pat ~global:global hd_pat, anf_pat ~global:global tl_pat)) + | P_list pats -> List.fold_right (fun pat apat -> mk_apat (AP_cons (anf_pat ~global:global pat, apat))) pats (mk_apat (AP_nil (typ_of_pat pat))) + | P_lit (L_aux (L_unit, _)) -> mk_apat (AP_wild (typ_of_pat pat)) + | _ -> + raise (Reporting.err_unreachable (fst annot) __POS__ + ("Could not convert pattern to ANF: " ^ string_of_pat pat)) + +let rec apat_globals (AP_aux (aux, _, _)) = + match aux with + | AP_nil _ | AP_wild _ | AP_id _ -> [] + | AP_global (id, typ) -> [(id, typ)] + | AP_tup apats -> List.concat (List.map apat_globals apats) + | AP_app (_, apat, _) -> apat_globals apat + | AP_cons (hd_apat, tl_apat) -> apat_globals hd_apat @ apat_globals tl_apat + +let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) = + let mk_aexp aexp = AE_aux (aexp, env_of_annot exp_annot, l) in + + let to_aval (AE_aux (aexp_aux, env, l) as aexp) = + let mk_aexp aexp = AE_aux (aexp, env, l) in + match aexp_aux with + | AE_val v -> (v, fun x -> x) + | AE_short_circuit (_, _, _) -> + let id = gensym () in + (AV_id (id, Local (Immutable, bool_typ)), fun x -> mk_aexp (AE_let (Immutable, id, bool_typ, aexp, x, typ_of exp))) + | AE_app (_, _, typ) + | AE_let (_, _, _, _, _, typ) + | AE_return (_, typ) + | AE_throw (_, typ) + | AE_cast (_, typ) + | AE_if (_, _, _, typ) + | AE_field (_, _, typ) + | AE_case (_, _, typ) + | AE_try (_, _, typ) + | AE_record_update (_, _, typ) + | AE_block (_, _, typ) -> + let id = gensym () in + (AV_id (id, Local (Immutable, typ)), fun x -> mk_aexp (AE_let (Immutable, id, typ, aexp, x, typ_of exp))) + | AE_assign _ | AE_for _ | AE_loop _ -> + let id = gensym () in + (AV_id (id, Local (Immutable, unit_typ)), fun x -> mk_aexp (AE_let (Immutable, id, unit_typ, aexp, x, typ_of exp))) + in + match e_aux with + | E_lit lit -> mk_aexp (ae_lit lit (typ_of exp)) + + | E_block [] -> + Util.warn (Reporting.loc_to_string l + ^ "\n\nTranslating empty block (possibly assigning to an uninitialized variable at the end of a block?)"); + mk_aexp (ae_lit (L_aux (L_unit, l)) (typ_of exp)) + | E_block exps -> + let exps, last = split_block l exps in + let aexps = List.map anf exps in + let alast = anf last in + mk_aexp (AE_block (aexps, alast, typ_of exp)) + + | E_assign (LEXP_aux (LEXP_deref dexp, _), exp) -> + let gs = gensym () in + mk_aexp (AE_let (Mutable, gs, typ_of dexp, anf dexp, mk_aexp (AE_assign (gs, typ_of dexp, anf exp)), unit_typ)) + + | E_assign (LEXP_aux (LEXP_id id, _), exp) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), exp) -> + let aexp = anf exp in + mk_aexp (AE_assign (id, lvar_typ (Env.lookup_id id (env_of exp)), aexp)) + + | E_assign (lexp, _) -> + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) + + | E_loop (loop_typ, cond, exp) -> + let acond = anf cond in + let aexp = anf exp in + mk_aexp (AE_loop (loop_typ, acond, aexp)) + + | E_for (id, exp1, exp2, exp3, order, body) -> + let aexp1, aexp2, aexp3, abody = anf exp1, anf exp2, anf exp3, anf body in + mk_aexp (AE_for (id, aexp1, aexp2, aexp3, order, abody)) + + | E_if (cond, then_exp, else_exp) -> + let cond_val, wrap = to_aval (anf cond) in + let then_aexp = anf then_exp in + let else_aexp = anf else_exp in + wrap (mk_aexp (AE_if (cond_val, then_aexp, else_aexp, typ_of exp))) + + | E_app_infix (x, Id_aux (Id op, l), y) -> + anf (E_aux (E_app (Id_aux (DeIid op, l), [x; y]), exp_annot)) + | E_app_infix (x, Id_aux (DeIid op, l), y) -> + anf (E_aux (E_app (Id_aux (Id op, l), [x; y]), exp_annot)) + + | E_vector exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_vector (List.map fst avals, typ_of exp)))) + + | E_list exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_list (List.map fst avals, typ_of exp)))) + + | E_field (field_exp, id) -> + let aval, wrap = to_aval (anf field_exp) in + wrap (mk_aexp (AE_field (aval, id, typ_of exp))) + + | E_record_update (exp, fexps) -> + let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = + let aval, wrap = to_aval (anf exp) in + (id, aval), wrap + in + let aval, exp_wrap = to_aval (anf exp) in + let fexps = List.map anf_fexp fexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in + let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in + exp_wrap (wrap (mk_aexp (AE_record_update (aval, record, typ_of exp)))) + + | E_app (id, [exp1; exp2]) when string_of_id id = "and_bool" -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap = to_aval aexp1 in + wrap (mk_aexp (AE_short_circuit (SC_and, aval1, aexp2))) + + | E_app (id, [exp1; exp2]) when string_of_id id = "or_bool" -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap = to_aval aexp1 in + wrap (mk_aexp (AE_short_circuit (SC_or, aval1, aexp2))) + + | E_app (id, exps) -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_app (id, List.map fst avals, typ_of exp))) + + | E_throw exn_exp -> + let aexp = anf exn_exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_throw (aval, typ_of exp))) + + | E_exit exp -> + let aexp = anf exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_app (mk_id "sail_exit", [aval], unit_typ))) + + | E_return ret_exp -> + let aexp = anf ret_exp in + let aval, wrap = to_aval aexp in + wrap (mk_aexp (AE_return (aval, typ_of exp))) + + | E_assert (exp1, exp2) -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap1 = to_aval aexp1 in + let aval2, wrap2 = to_aval aexp2 in + wrap1 (wrap2 (mk_aexp (AE_app (mk_id "sail_assert", [aval1; aval2], unit_typ)))) + + | E_cons (exp1, exp2) -> + let aexp1 = anf exp1 in + let aexp2 = anf exp2 in + let aval1, wrap1 = to_aval aexp1 in + let aval2, wrap2 = to_aval aexp2 in + wrap1 (wrap2 (mk_aexp (AE_app (mk_id "cons", [aval1; aval2], unit_typ)))) + + | E_id id -> + let lvar = Env.lookup_id id (env_of exp) in + begin match lvar with + | _ -> mk_aexp (AE_val (AV_id (id, lvar))) + end + + | E_ref id -> + let lvar = Env.lookup_id id (env_of exp) in + mk_aexp (AE_val (AV_ref (id, lvar))) + + | E_case (match_exp, pexps) -> + let match_aval, match_wrap = to_aval (anf match_exp) in + let anf_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_when (pat, guard, body) -> + (anf_pat pat, anf guard, anf body) + | Pat_exp (pat, body) -> + (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) + in + match_wrap (mk_aexp (AE_case (match_aval, List.map anf_pexp pexps, typ_of exp))) + + | E_try (match_exp, pexps) -> + let match_aexp = anf match_exp in + let anf_pexp (Pat_aux (pat_aux, _)) = + match pat_aux with + | Pat_when (pat, guard, body) -> + (anf_pat pat, anf guard, anf body) + | Pat_exp (pat, body) -> + (anf_pat pat, mk_aexp (AE_val (AV_lit (mk_lit (L_true), bool_typ))), anf body) + in + mk_aexp (AE_try (match_aexp, List.map anf_pexp pexps, typ_of exp)) + + | E_var (LEXP_aux (LEXP_id id, _), binding, body) + | E_var (LEXP_aux (LEXP_cast (_, id), _), binding, body) + | E_let (LB_aux (LB_val (P_aux (P_id id, _), binding), _), body) -> + let env = env_of body in + let lvar = Env.lookup_id id env in + mk_aexp (AE_let (Mutable, id, lvar_typ lvar, anf binding, anf body, typ_of exp)) + + | E_var (lexp, _, _) -> + raise (Reporting.err_unreachable l __POS__ + ("Encountered complex l-expression " ^ string_of_lexp lexp ^ " when converting to ANF")) + + | E_let (LB_aux (LB_val (pat, binding), _), body) -> + anf (E_aux (E_case (binding, [Pat_aux (Pat_exp (pat, body), (Parse_ast.Unknown, empty_tannot))]), exp_annot)) + + | E_tuple exps -> + let aexps = List.map anf exps in + let avals = List.map to_aval aexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd avals) in + wrap (mk_aexp (AE_val (AV_tuple (List.map fst avals)))) + + | E_record fexps -> + let anf_fexp (FE_aux (FE_Fexp (id, exp), _)) = + let aval, wrap = to_aval (anf exp) in + (id, aval), wrap + in + let fexps = List.map anf_fexp fexps in + let wrap = List.fold_left (fun f g x -> f (g x)) (fun x -> x) (List.map snd fexps) in + let record = List.fold_left (fun r (id, aval) -> Bindings.add id aval r) Bindings.empty (List.map fst fexps) in + wrap (mk_aexp (AE_val (AV_record (record, typ_of exp)))) + + | E_cast (typ, exp) -> mk_aexp (AE_cast (anf exp, typ)) + + | E_vector_access _ | E_vector_subrange _ | E_vector_update _ | E_vector_update_subrange _ | E_vector_append _ -> + (* Should be re-written by type checker *) + raise (Reporting.err_unreachable l __POS__ "encountered raw vector operation when converting to ANF") + + | E_internal_value _ -> + (* Interpreter specific *) + raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF") + + | E_sizeof nexp -> + (* Sizeof nodes removed by sizeof rewriting pass *) + raise (Reporting.err_unreachable l __POS__ ("encountered E_sizeof node " ^ string_of_nexp nexp ^ " when converting to ANF")) + + | E_constraint _ -> + (* Sizeof nodes removed by sizeof rewriting pass *) + raise (Reporting.err_unreachable l __POS__ "encountered E_constraint node when converting to ANF") + + | E_nondet _ -> + (* We don't compile E_nondet nodes *) + raise (Reporting.err_unreachable l __POS__ "encountered E_nondet node when converting to ANF") + + | E_internal_return _ | E_internal_plet _ -> + raise (Reporting.err_unreachable l __POS__ "encountered unexpected internal node when converting to ANF") diff --git a/src/jib/anf.mli b/src/jib/anf.mli new file mode 100644 index 00000000..e8d58fe4 --- /dev/null +++ b/src/jib/anf.mli @@ -0,0 +1,125 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Type_check + +(* The A-normal form (ANF) grammar *) + +type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l + +and 'a aexp_aux = + | AE_val of 'a aval + | AE_app of id * ('a aval) list * 'a + | AE_cast of 'a aexp * 'a + | AE_assign of id * 'a * 'a aexp + | AE_let of mut * id * 'a * 'a aexp * 'a aexp * 'a + | AE_block of ('a aexp) list * 'a aexp * 'a + | AE_return of 'a aval * 'a + | AE_throw of 'a aval * 'a + | AE_if of 'a aval * 'a aexp * 'a aexp * 'a + | AE_field of 'a aval * id * 'a + | AE_case of 'a aval * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_try of 'a aexp * ('a apat * 'a aexp * 'a aexp) list * 'a + | AE_record_update of 'a aval * ('a aval) Bindings.t * 'a + | AE_for of id * 'a aexp * 'a aexp * 'a aexp * order * 'a aexp + | AE_loop of loop * 'a aexp * 'a aexp + | AE_short_circuit of sc_op * 'a aval * 'a aexp + +and sc_op = SC_and | SC_or + +and 'a apat = AP_aux of 'a apat_aux * Env.t * l + +and 'a apat_aux = + | AP_tup of ('a apat) list + | AP_id of id * 'a + | AP_global of id * 'a + | AP_app of id * 'a apat * 'a + | AP_cons of 'a apat * 'a apat + | AP_nil of 'a + | AP_wild of 'a + +and 'a aval = + | AV_lit of lit * 'a + | AV_id of id * 'a lvar + | AV_ref of id * 'a lvar + | AV_tuple of ('a aval) list + | AV_list of ('a aval) list * 'a + | AV_vector of ('a aval) list * 'a + | AV_record of ('a aval) Bindings.t * 'a + | AV_C_fragment of fragment * 'a * ctyp + +val gensym : unit -> id + +(* Functions for transforming ANF expressions *) + +val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp + +val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp + +val no_shadow : IdSet.t -> 'a aexp -> 'a aexp + +val apat_globals : 'a apat -> (id * 'a) list + +val apat_types : 'a apat -> 'a Bindings.t + +val is_dead_aexp : 'a aexp -> bool + +(* Compiling to ANF expressions *) + +val anf_pat : ?global:bool -> tannot pat -> typ apat + +val anf : tannot exp -> typ aexp + +(* Pretty printing ANF expressions *) +val pp_aval : typ aval -> PPrint.document +val pp_aexp : typ aexp -> PPrint.document diff --git a/src/jib/c_backend.ml b/src/jib/c_backend.ml new file mode 100644 index 00000000..a08261fc --- /dev/null +++ b/src/jib/c_backend.ml @@ -0,0 +1,2420 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_compile +open Jib_util +open Type_check +open PPrint +open Value2 + +open Anf + +module Big_int = Nat_big_num + +let c_verbosity = ref 0 + +let opt_debug_flow_graphs = ref false +let opt_static = ref false +let opt_no_main = ref false +let opt_memo_cache = ref false +let opt_no_rts = ref false +let opt_prefix = ref "z" +let opt_extra_params = ref None +let opt_extra_arguments = ref None + +let extra_params () = + match !opt_extra_params with + | Some str -> str ^ ", " + | _ -> "" + +let extra_arguments is_extern = + match !opt_extra_arguments with + | Some str when not is_extern -> str ^ ", " + | _ -> "" + +(* Optimization flags *) +let optimize_primops = ref false +let optimize_hoist_allocations = ref false +let optimize_struct_updates = ref false +let optimize_alias = ref false +let optimize_experimental = ref false + +let c_debug str = + if !c_verbosity > 0 then prerr_endline (Lazy.force str) else () + +let c_error ?loc:(l=Parse_ast.Unknown) message = + raise (Reporting.err_general l ("\nC backend: " ^ message)) + +let zencode_id = function + | Id_aux (Id str, l) -> Id_aux (Id (Util.zencode_string str), l) + | Id_aux (DeIid str, l) -> Id_aux (Id (Util.zencode_string ("op " ^ str)), l) + +(**************************************************************************) +(* 2. Converting sail types to C types *) +(**************************************************************************) + +let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) +let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) + +(** Convert a sail type into a C-type. This function can be quite + slow, because it uses ctx.local_env and SMT to analyse the Sail + types and attempts to fit them into the smallest possible C + types, provided ctx.optimize_smt is true (default) **) +let rec ctyp_of_typ ctx typ = + let Typ_aux (typ_aux, l) as typ = Env.expand_synonyms ctx.tc_env typ in + match typ_aux with + | Typ_id id when string_of_id id = "bit" -> CT_bit + | Typ_id id when string_of_id id = "bool" -> CT_bool + | Typ_id id when string_of_id id = "int" -> CT_lint + | Typ_id id when string_of_id id = "nat" -> CT_lint + | Typ_id id when string_of_id id = "unit" -> CT_unit + | Typ_id id when string_of_id id = "string" -> CT_string + | Typ_id id when string_of_id id = "real" -> CT_real + + | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool + + | Typ_app (id, args) when string_of_id id = "itself" -> + ctyp_of_typ ctx (Typ_aux (Typ_app (mk_id "atom", args), l)) + | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" || string_of_id id = "implicit" -> + begin match destruct_range Env.empty typ with + | None -> assert false (* Checked if range type in guard *) + | Some (kids, constr, n, m) -> + let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + CT_fint 64 + | n, m -> + if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then + CT_fint 64 + else + CT_lint + end + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> + CT_list (ctyp_of_typ ctx typ) + + (* When converting a sail bitvector type into C, we have three options in order of efficiency: + - If the length is obviously static and smaller than 64, use the fixed bits type (aka uint64_t), fbits. + - If the length is less than 64, then use a small bits type, sbits. + - If the length may be larger than 64, use a large bits type lbits. *) + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ (Typ_aux (Typ_id vtyp_id, _)), _)]) + when string_of_id id = "vector" && string_of_id vtyp_id = "bit" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + begin match nexp_simp n with + | Nexp_aux (Nexp_constant n, _) when Big_int.less_equal n (Big_int.of_int 64) -> CT_fbits (Big_int.to_int n, direction) + | n when prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction) + | _ -> CT_lbits direction + end + + | Typ_app (id, [A_aux (A_nexp n, _); + A_aux (A_order ord, _); + A_aux (A_typ typ, _)]) + when string_of_id id = "vector" -> + let direction = match ord with Ord_aux (Ord_dec, _) -> true | Ord_aux (Ord_inc, _) -> false | _ -> assert false in + CT_vector (direction, ctyp_of_typ ctx typ) + + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "register" -> + CT_ref (ctyp_of_typ ctx typ) + + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.records -> CT_struct (id, Bindings.find id ctx.records |> Bindings.bindings) + | Typ_id id | Typ_app (id, _) when Bindings.mem id ctx.variants -> CT_variant (id, Bindings.find id ctx.variants |> Bindings.bindings) + | Typ_id id when Bindings.mem id ctx.enums -> CT_enum (id, Bindings.find id ctx.enums |> IdSet.elements) + + | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs) + + | Typ_exist _ -> + (* Use Type_check.destruct_exist when optimising with SMT, to + ensure that we don't cause any type variable clashes in + local_env, and that we can optimize the existential based upon + it's constraints. *) + begin match destruct_exist (Env.expand_synonyms ctx.local_env typ) with + | Some (kids, nc, typ) -> + let env = add_existential l kids nc ctx.local_env in + ctyp_of_typ { ctx with local_env = env } typ + | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!") + end + + | Typ_var kid -> CT_poly + + | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ) + +let rec is_stack_ctyp ctyp = match ctyp with + | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_enum _ -> true + | CT_fint n -> n <= 64 + | CT_lbits _ | CT_lint | CT_real | CT_string | CT_list _ | CT_vector _ -> false + | CT_struct (_, fields) -> List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) fields + | CT_variant (_, ctors) -> false (* List.for_all (fun (_, ctyp) -> is_stack_ctyp ctyp) ctors *) (* FIXME *) + | CT_tup ctyps -> List.for_all is_stack_ctyp ctyps + | CT_ref ctyp -> true + | CT_poly -> true + +let is_stack_typ ctx typ = is_stack_ctyp (ctyp_of_typ ctx typ) + +let is_fbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_fbits _ -> true + | _ -> false + +let is_sbits_typ ctx typ = + match ctyp_of_typ ctx typ with + | CT_sbits _ -> true + | _ -> false + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty + +(**************************************************************************) +(* 3. Optimization of primitives and literals *) +(**************************************************************************) + +let hex_char = + let open Sail2_values in + function + | '0' -> [B0; B0; B0; B0] + | '1' -> [B0; B0; B0; B1] + | '2' -> [B0; B0; B1; B0] + | '3' -> [B0; B0; B1; B1] + | '4' -> [B0; B1; B0; B0] + | '5' -> [B0; B1; B0; B1] + | '6' -> [B0; B1; B1; B0] + | '7' -> [B0; B1; B1; B1] + | '8' -> [B1; B0; B0; B0] + | '9' -> [B1; B0; B0; B1] + | 'A' | 'a' -> [B1; B0; B1; B0] + | 'B' | 'b' -> [B1; B0; B1; B1] + | 'C' | 'c' -> [B1; B1; B0; B0] + | 'D' | 'd' -> [B1; B1; B0; B1] + | 'E' | 'e' -> [B1; B1; B1; B0] + | 'F' | 'f' -> [B1; B1; B1; B1] + | _ -> failwith "Invalid hex character" + +let literal_to_fragment (L_aux (l_aux, _) as lit) = + match l_aux with + | L_num n when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + Some (F_lit (V_int n), CT_fint 64) + | L_hex str when String.length str <= 16 -> + let padding = 16 - String.length str in + let padding = Util.list_init padding (fun _ -> Sail2_values.B0) in + let content = Util.string_to_list str |> List.map hex_char |> List.concat in + Some (F_lit (V_bits (padding @ content)), CT_fbits (String.length str * 4, true)) + | L_unit -> Some (F_lit V_unit, CT_unit) + | L_true -> Some (F_lit (V_bool true), CT_bool) + | L_false -> Some (F_lit (V_bool false), CT_bool) + | _ -> None + +let c_literals ctx = + let rec c_literal env l = function + | AV_lit (lit, typ) as v when is_stack_ctyp (ctyp_of_typ { ctx with local_env = env } typ) -> + begin + match literal_to_fragment lit with + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) + | None -> v + end + | AV_tuple avals -> AV_tuple (List.map (c_literal env l) avals) + | v -> v + in + map_aval c_literal + +let mask m = + if Big_int.less_equal m (Big_int.of_int 64) then + let n = Big_int.to_int m in + if n = 0 then + "UINT64_C(0)" + else if n mod 4 = 0 then + "UINT64_C(0x" ^ String.make (16 - n / 4) '0' ^ String.make (n / 4) 'F' ^ ")" + else + "UINT64_C(" ^ String.make (64 - n) '0' ^ String.make n '1' ^ ")" + else + failwith "Tried to create a mask literal for a vector greater than 64 bits." + +let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + +let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + +let rec c_aval ctx = function + | AV_lit (lit, typ) as v -> + begin + match literal_to_fragment lit with + | Some (frag, ctyp) -> AV_C_fragment (frag, typ, ctyp) + | None -> v + end + | AV_C_fragment (str, typ, ctyp) -> AV_C_fragment (str, typ, ctyp) + (* An id can be converted to a C fragment if it's type can be + stack-allocated. *) + | AV_id (id, lvar) as v -> + begin + match lvar with + | Local (_, typ) -> + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + begin + try + (* We need to check that id's type hasn't changed due to flow typing *) + let _, ctyp' = Bindings.find id ctx.locals in + if ctyp_equal ctyp ctyp' then + AV_C_fragment (F_id id, typ, ctyp) + else + (* id's type changed due to flow + typing, so it's really still heap allocated! *) + v + with + (* Hack: Assuming global letbindings don't change from flow typing... *) + Not_found -> AV_C_fragment (F_id id, typ, ctyp) + end + else + v + | Register (_, _, typ) when is_stack_typ ctx typ -> + let ctyp = ctyp_of_typ ctx typ in + if is_stack_ctyp ctyp then + AV_C_fragment (F_id id, typ, ctyp) + else + v + | _ -> v + end + | AV_vector (v, typ) when is_bitvector v && List.length v <= 64 -> + let bitstring = F_lit (V_bits (List.map value_of_aval_bit v)) in + AV_C_fragment (bitstring, typ, CT_fbits (List.length v, true)) + | AV_tuple avals -> AV_tuple (List.map (c_aval ctx) avals) + | aval -> aval + +let is_c_fragment = function + | AV_C_fragment _ -> true + | _ -> false + +let c_fragment = function + | AV_C_fragment (frag, _, _) -> frag + | _ -> assert false + +let v_mask_lower i = F_lit (V_bits (Util.list_init i (fun _ -> Sail2_values.B1))) + +(* Map over all the functions in an aexp. *) +let rec analyze_functions ctx f (AE_aux (aexp, env, l)) = + let ctx = { ctx with local_env = env } in + let aexp = match aexp with + | AE_app (id, vs, typ) -> f ctx id vs typ + + | AE_cast (aexp, typ) -> AE_cast (analyze_functions ctx f aexp, typ) + + | AE_assign (id, typ, aexp) -> AE_assign (id, typ, analyze_functions ctx f aexp) + + | AE_short_circuit (op, aval, aexp) -> AE_short_circuit (op, aval, analyze_functions ctx f aexp) + + | AE_let (mut, id, typ1, aexp1, (AE_aux (_, env2, _) as aexp2), typ2) -> + let aexp1 = analyze_functions ctx f aexp1 in + (* Use aexp2's environment because it will contain constraints for id *) + let ctyp1 = ctyp_of_typ { ctx with local_env = env2 } typ1 in + let ctx = { ctx with locals = Bindings.add id (mut, ctyp1) ctx.locals } in + AE_let (mut, id, typ1, aexp1, analyze_functions ctx f aexp2, typ2) + + | AE_block (aexps, aexp, typ) -> AE_block (List.map (analyze_functions ctx f) aexps, analyze_functions ctx f aexp, typ) + + | AE_if (aval, aexp1, aexp2, typ) -> + AE_if (aval, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2, typ) + + | AE_loop (loop_typ, aexp1, aexp2) -> AE_loop (loop_typ, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) + + | AE_for (id, aexp1, aexp2, aexp3, order, aexp4) -> + let aexp1 = analyze_functions ctx f aexp1 in + let aexp2 = analyze_functions ctx f aexp2 in + let aexp3 = analyze_functions ctx f aexp3 in + let aexp4 = analyze_functions ctx f aexp4 in + (* Currently we assume that loop indexes are always safe to put into an int64 *) + let ctx = { ctx with locals = Bindings.add id (Immutable, CT_fint 64) ctx.locals } in + AE_for (id, aexp1, aexp2, aexp3, order, aexp4) + + | AE_case (aval, cases, typ) -> + let analyze_case (AP_aux (_, env, _) as pat, aexp1, aexp2) = + let pat_bindings = Bindings.bindings (apat_types pat) in + let ctx = { ctx with local_env = env } in + let ctx = + List.fold_left (fun ctx (id, typ) -> { ctx with locals = Bindings.add id (Immutable, ctyp_of_typ ctx typ) ctx.locals }) ctx pat_bindings + in + pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2 + in + AE_case (aval, List.map analyze_case cases, typ) + + | AE_try (aexp, cases, typ) -> + AE_try (analyze_functions ctx f aexp, List.map (fun (pat, aexp1, aexp2) -> pat, analyze_functions ctx f aexp1, analyze_functions ctx f aexp2) cases, typ) + + | AE_field _ | AE_record_update _ | AE_val _ | AE_return _ | AE_throw _ as v -> v + in + AE_aux (aexp, env, l) + +let analyze_primop' ctx id args typ = + let no_change = AE_app (id, args, typ) in + let args = List.map (c_aval ctx) args in + let extern = if Env.is_extern id ctx.tc_env "c" then Env.get_extern id ctx.tc_env "c" else failwith "Not extern" in + + let v_one = F_lit (V_int (Big_int.of_int 1)) in + let v_int n = F_lit (V_int (Big_int.of_int n)) in + + c_debug (lazy ("Analyzing primop " ^ extern ^ "(" ^ Util.string_of_list ", " (fun aval -> Pretty_print_sail.to_string (pp_aval aval)) args ^ ")")); + + match extern, args with + | "eq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) + | "eq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("eq_sbits", [v1; v2]), typ, CT_bool)) + + | "neq_bits", [AV_C_fragment (v1, _, CT_fbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "!=", v2), typ, CT_bool)) + | "neq_bits", [AV_C_fragment (v1, _, CT_sbits _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_call ("neq_sbits", [v1; v2]), typ, CT_bool)) + + | "eq_int", [AV_C_fragment (v1, typ1, _); AV_C_fragment (v2, typ2, _)] -> + AE_val (AV_C_fragment (F_op (v1, "==", v2), typ, CT_bool)) + + | "zeros", [_] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_raw "0x0", typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + + | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true))) + | _ -> no_change + end + + | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)] + when n <= 63 -> + AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord))) + + | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool)) + | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool)) + | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool)) + | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] -> + AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool)) + + | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp)) + | "xor_bits", [AV_C_fragment (v1, _, (CT_sbits _ as ctyp)); AV_C_fragment (v2, _, CT_sbits _)] -> + AE_val (AV_C_fragment (F_call ("xor_sbits", [v1; v2]), typ, ctyp)) + + | "or_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "|", v2), typ, ctyp)) + + | "and_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] -> + AE_val (AV_C_fragment (F_op (v1, "&", v2), typ, ctyp)) + + | "not_bits", [AV_C_fragment (v, _, ctyp)] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_op (F_unary ("~", v), "&", v_mask_lower (Big_int.to_int n)), typ, ctyp)) + | _ -> no_change + end + + | "vector_subrange", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (f, _, _); AV_C_fragment (t, _, _)] + when is_fbits_typ ctx typ -> + let len = F_op (f, "-", F_op (t, "-", v_one)) in + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", t)), + typ, + ctyp_of_typ ctx typ)) + + | "vector_access", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (n, _, _)] -> + AE_val (AV_C_fragment (F_op (v_one, "&", F_op (vec, ">>", n)), typ, CT_bit)) + + | "eq_bit", [AV_C_fragment (a, _, _); AV_C_fragment (b, _, _)] -> + AE_val (AV_C_fragment (F_op (a, "==", b), typ, CT_bool)) + + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_fbits_typ ctx typ -> + AE_val (AV_C_fragment (F_op (F_call ("safe_rshift", [F_raw "UINT64_MAX"; F_op (v_int 64, "-", len)]), "&", F_op (vec, ">>", start)), + typ, + ctyp_of_typ ctx typ)) + + | "slice", [AV_C_fragment (vec, _, CT_fbits _); AV_C_fragment (start, _, _); AV_C_fragment (len, _, _)] + when is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("sslice", [vec; start; len]), typ, ctyp_of_typ ctx typ)) + + | "undefined_bit", _ -> + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, CT_bit)) + + (* Optimized routines for all combinations of fixed and small bits + appends, where the result is guaranteed to be smaller than 64. *) + | "append", [AV_C_fragment (vec1, _, CT_fbits (0, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2)) as v2] + when ord1 = ord2 -> + AE_val v2 + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && n1 + n2 <= 64 -> + AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1))) + + | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ)) + + | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))] + when ord1 = ord2 && is_sbits_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ)) + + | "undefined_vector", [AV_C_fragment (len, _, _); _] -> + begin match destruct_vector ctx.tc_env typ with + | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _)) + when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_lit (V_bit Sail2_values.B0), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "sail_unsigned", [AV_C_fragment (frag, vtyp, _)] -> + begin match destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _) + when Big_int.less_equal n (Big_int.of_int 63) && is_stack_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("fast_unsigned", [frag]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "sail_signed", [AV_C_fragment (frag, vtyp, _)] -> + begin match destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ -> + AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] -> + begin match destruct_range Env.empty typ with + | None -> no_change + | Some (kids, constr, n, m) -> + match nexp_simp n, nexp_simp m with + | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _) + when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) + | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) -> + AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_fint 64)) + | _ -> no_change + end + + | "neg_int", [AV_C_fragment (frag, _, _)] -> + AE_val (AV_C_fragment (F_op (v_int 0, "-", frag), typ, CT_fint 64)) + + | "replicate_bits", [AV_C_fragment (vec, vtyp, _); AV_C_fragment (times, _, _)] -> + begin match destruct_vector ctx.tc_env typ, destruct_vector ctx.tc_env vtyp with + | Some (Nexp_aux (Nexp_constant n, _), _, _), Some (Nexp_aux (Nexp_constant m, _), _, _) + when Big_int.less_equal n (Big_int.of_int 64) -> + AE_val (AV_C_fragment (F_call ("fast_replicate_bits", [F_lit (V_int m); vec; times]), typ, ctyp_of_typ ctx typ)) + | _ -> no_change + end + + | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true)); + AV_C_fragment (hi, _, CT_fint 64); + AV_C_fragment (lo, _, CT_fint 64); + AV_C_fragment (ys, _, CT_fbits (m, true))] -> + AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true))) + + | "undefined_bool", _ -> + AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool)) + + | _, _ -> + c_debug (lazy ("No optimization routine found")); + no_change + +let analyze_primop ctx id args typ = + let no_change = AE_app (id, args, typ) in + if !optimize_primops then + try analyze_primop' ctx id args typ with + | Failure str -> + (c_debug (lazy ("Analyze primop failed for id " ^ string_of_id id ^ " reason: " ^ str))); + no_change + else + no_change + +let generate_cleanup instrs = + let generate_cleanup' (I_aux (instr, _)) = + match instr with + | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)] + | I_decl (ctyp, id) -> [(id, iclear ctyp id)] + | instr -> [] + in + let is_clear ids = function + | I_aux (I_clear (_, id), _) -> IdSet.add id ids + | _ -> ids + in + let cleaned = List.fold_left is_clear IdSet.empty instrs in + instrs + |> List.map generate_cleanup' + |> List.concat + |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) + |> List.map snd + +(** Functions that have heap-allocated return types are implemented by + passing a pointer a location where the return value should be + stored. The ANF -> Sail IR pass for expressions simply outputs an + I_return instruction for any return value, so this function walks + over the IR ast for expressions and modifies the return statements + into code that sets that pointer, as well as adds extra control + flow to cleanup heap-allocated variables correctly when a function + terminates early. See the generate_cleanup function for how this is + done. *) +let fix_early_heap_return ret ret_ctyp instrs = + let end_function_label = label "end_function_" in + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ | I_undefined _ -> true + | _ -> false + in + let rec rewrite_return instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return instrs)] + @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + before + @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ rewrite_return after + | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after -> + before + @ [I_aux (I_funcall (CL_addr (CL_id (ret, CT_ref ctyp)), extern, fid, args), aux)] + @ rewrite_return after + | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after -> + before + @ [I_aux (I_copy (CL_addr (CL_id (ret, CT_ref ctyp)), cval), aux)] + @ rewrite_return after + | before, I_aux ((I_end | I_undefined _), _) :: after -> + before + @ [igoto end_function_label] + @ rewrite_return after + | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after -> + before @ instr :: rewrite_return after + | _, _ -> assert false + in + rewrite_return instrs + @ [ilabel end_function_label] + +(* This is like fix_early_return, but for stack allocated returns. *) +let fix_early_stack_return ret ret_ctyp instrs = + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ -> true + | _ -> false + in + let rec rewrite_return instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return instrs)] + @ rewrite_return after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + before + @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp] + @ rewrite_return after + | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after -> + before + @ [I_aux (I_funcall (CL_id (ret, ctyp), extern, fid, args), aux)] + @ rewrite_return after + | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after -> + before + @ [I_aux (I_copy (CL_id (ret, ctyp), cval), aux)] + @ rewrite_return after + | before, I_aux (I_end, _) :: after -> + before + @ [ireturn (F_id ret, ret_ctyp)] + @ rewrite_return after + | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after -> + before @ instr :: rewrite_return after + | _, _ -> assert false + in + rewrite_return instrs + +let rec insert_heap_returns ret_ctyps = function + | (CDEF_spec (id, _, ret_ctyp) as cdef) :: cdefs -> + cdef :: insert_heap_returns (Bindings.add id ret_ctyp ret_ctyps) cdefs + + | CDEF_fundef (id, None, args, body) :: cdefs -> + let gs = gensym () in + begin match Bindings.find_opt id ret_ctyps with + | None -> + raise (Reporting.err_general (id_loc id) ("Cannot find return type for function " ^ string_of_id id)) + | Some ret_ctyp when not (is_stack_ctyp ret_ctyp) -> + CDEF_fundef (id, Some gs, args, fix_early_heap_return gs ret_ctyp body) + :: insert_heap_returns ret_ctyps cdefs + | Some ret_ctyp -> + CDEF_fundef (id, None, args, fix_early_stack_return gs ret_ctyp (idecl ret_ctyp gs :: body)) + :: insert_heap_returns ret_ctyps cdefs + end + + | CDEF_fundef (id, gs, _, _) :: _ -> + raise (Reporting.err_unreachable (id_loc id) __POS__ "Found function with return already re-written in insert_heap_returns") + + | cdef :: cdefs -> + cdef :: insert_heap_returns ret_ctyps cdefs + + | [] -> [] + +(** To keep things neat we use GCC's local labels extension to limit + the scope of labels. We do this by iterating over all the blocks + and adding a __label__ declaration with all the labels local to + that block. The add_local_labels function is called by the code + generator just before it outputs C. + + See https://gcc.gnu.org/onlinedocs/gcc/Local-Labels.html **) +let add_local_labels' instrs = + let is_label (I_aux (instr, _)) = + match instr with + | I_label str -> [str] + | _ -> [] + in + let labels = List.concat (List.map is_label instrs) in + let local_label_decl = iraw ("__label__ " ^ String.concat ", " labels ^ ";\n") in + if labels = [] then + instrs + else + local_label_decl :: instrs + +let add_local_labels instrs = + match map_instrs add_local_labels' (iblock instrs) with + | I_aux (I_block instrs, _) -> instrs + | _ -> assert false + +(**************************************************************************) +(* 5. Optimizations *) +(**************************************************************************) + +let rec instrs_rename from_id to_id = + let rename id = if Id.compare id from_id = 0 then to_id else id in + let crename = cval_rename from_id to_id in + let irename instrs = instrs_rename from_id to_id instrs in + let lrename = clexp_rename from_id to_id in + function + | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs + | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs + | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs + | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs + | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs + | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs -> + I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs + | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs + | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs + | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs + | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs + | (I_aux ((I_comment _ | I_raw _ | I_end | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs + | [] -> [] + +let hoist_ctyp = function + | CT_lint | CT_lbits _ | CT_struct _ -> true + | _ -> false + +let hoist_counter = ref 0 +let hoist_id () = + let id = mk_id ("gh#" ^ string_of_int !hoist_counter) in + incr hoist_counter; + id + +let hoist_allocations recursive_functions = function + | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id recursive_functions -> + c_debug (lazy (Printf.sprintf "skipping recursive function %s" (string_of_id function_id))); + [cdef] + + | CDEF_fundef (function_id, heap_return, args, body) -> + let decls = ref [] in + let cleanups = ref [] in + let rec hoist = function + | I_aux (I_decl (ctyp, decl_id), annot) :: instrs when hoist_ctyp ctyp -> + let hid = hoist_id () in + decls := idecl ctyp hid :: !decls; + cleanups := iclear ctyp hid :: !cleanups; + let instrs = instrs_rename decl_id hid instrs in + I_aux (I_reset (ctyp, hid), annot) :: hoist instrs + + | I_aux (I_init (ctyp, decl_id, cval), annot) :: instrs when hoist_ctyp ctyp -> + let hid = hoist_id () in + decls := idecl ctyp hid :: !decls; + cleanups := iclear ctyp hid :: !cleanups; + let instrs = instrs_rename decl_id hid instrs in + I_aux (I_reinit (ctyp, hid, cval), annot) :: hoist instrs + + | I_aux (I_clear (ctyp, _), _) :: instrs when hoist_ctyp ctyp -> + hoist instrs + + | I_aux (I_block block, annot) :: instrs -> + I_aux (I_block (hoist block), annot) :: hoist instrs + | I_aux (I_try_block block, annot) :: instrs -> + I_aux (I_try_block (hoist block), annot) :: hoist instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), annot) :: instrs -> + I_aux (I_if (cval, hoist then_instrs, hoist else_instrs, ctyp), annot) :: hoist instrs + + | instr :: instrs -> instr :: hoist instrs + | [] -> [] + in + let body = hoist body in + if !decls = [] then + [CDEF_fundef (function_id, heap_return, args, body)] + else + [CDEF_startup (function_id, List.rev !decls); + CDEF_fundef (function_id, heap_return, args, body); + CDEF_finish (function_id, !cleanups)] + + | cdef -> [cdef] + +let flat_counter = ref 0 +let flat_id () = + let id = mk_id ("local#" ^ string_of_int !flat_counter) in + incr flat_counter; + id + +let rec flatten_instrs = function + | I_aux (I_decl (ctyp, decl_id), aux) :: instrs -> + let fid = flat_id () in + I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs) + + | I_aux ((I_block block | I_try_block block), _) :: instrs -> + flatten_instrs block @ flatten_instrs instrs + + | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs -> + let then_label = label "then_" in + let endif_label = label "endif_" in + [ijump cval then_label] + @ flatten_instrs else_instrs + @ [igoto endif_label] + @ [ilabel then_label] + @ flatten_instrs then_instrs + @ [ilabel endif_label] + @ flatten_instrs instrs + + | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs + + | instr :: instrs -> instr :: flatten_instrs instrs + | [] -> [] + +let flatten_cdef = + function + | CDEF_fundef (function_id, heap_return, args, body) -> + flat_counter := 0; + CDEF_fundef (function_id, heap_return, args, flatten_instrs body) + + | CDEF_let (n, bindings, instrs) -> + flat_counter := 0; + CDEF_let (n, bindings, flatten_instrs instrs) + + | cdef -> cdef + +let rec specialize_variants ctx prior = + let unifications = ref (Bindings.empty) in + + let fix_variant_ctyp var_id new_ctors = function + | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) + | ctyp -> ctyp + in + + let specialize_constructor ctx ctor_id ctyp = + function + | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + (* Work out how each call to a constructor in instantiated and add that to unifications *) + let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in + let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in + unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; + + (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) + let casts = + let cast_to_suprema (frag, ctyp) = + let suprema = ctyp_suprema ctyp in + if ctyp_equal ctyp suprema then + [], (unpoly frag, ctyp), [] + else + let gs = gensym () in + [idecl suprema gs; + icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], + (F_id gs, suprema), + [iclear suprema gs] + in + List.map cast_to_suprema [cval] + in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in + let cvals = List.map (fun (_, cval, _) -> cval) casts in + let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in + + let mk_funcall instr = + if List.length setup = 0 then + instr + else + iblock (setup @ [instr] @ cleanup) + in + + mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) + + | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + c_error ~loc:l "Multiple argument constructor found" + + | instr -> instr + in + + function + | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> + let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in + + let cdefs = + List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) + cdefs + polymorphic_ctors + in + + let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in + let specialized_ctors = Bindings.bindings !unifications in + let new_ctors = monomorphic_ctors @ specialized_ctors in + + let ctx = { + ctx with variants = Bindings.add var_id + (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) + ctx.variants + } in + + let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in + let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in + specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs + + | cdef :: cdefs -> + let remove_poly (I_aux (instr, aux)) = + match instr with + | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> + I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) + | instr -> I_aux (instr, aux) + in + let cdef = cdef_map_instr remove_poly cdef in + specialize_variants ctx (cdef :: prior) cdefs + + | [] -> List.rev prior, ctx + +(** Once we specialize variants, there may be additional type + dependencies which could be in the wrong order. As such we need to + sort the type definitions in the list of cdefs. *) +let sort_ctype_defs cdefs = + (* Split the cdefs into type definitions and non type definitions *) + let is_ctype_def = function CDEF_type _ -> true | _ -> false in + let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in + let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in + let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in + + let ctdef_id = function + | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id + in + + let ctdef_ids = function + | CTD_enum _ -> IdSet.empty + | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> + List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors + in + + (* Create a reverse (i.e. from types to the types that are dependent + upon them) id graph of dependencies between types *) + let module IdGraph = Graph.Make(Id) in + + let graph = + List.fold_left (fun g ctdef -> + List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) + (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) + (IdSet.elements (ctdef_ids ctdef))) + IdGraph.empty + ctype_defs + in + + (* Then select the ctypes in the correct order as given by the topsort *) + let ids = IdGraph.topsort graph in + let ctype_defs = + List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids + in + + ctype_defs @ cdefs + +let removed = icomment "REMOVED" + +let is_not_removed = function + | I_aux (I_comment "REMOVED", _) -> false + | _ -> true + +(** This optimization looks for patterns of the form: + + create x : t; + x = y; + // modifications to x, and no changes to y + y = x; + // no further changes to x + kill x; + + If found, we can remove the variable x, and directly modify y instead. *) +let remove_alias = + let pattern ctyp id = + let alias = ref None in + let rec scan ctyp id n instrs = + match n, !alias, instrs with + | 0, None, I_aux (I_copy (CL_id (id', ctyp'), (F_id a, ctyp'')), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + alias := Some a; + scan ctyp id 1 instrs + + | 1, Some a, I_aux (I_copy (CL_id (a', ctyp'), (F_id id', ctyp'')), _) :: instrs + when Id.compare a a' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan ctyp id 2 instrs + + | 1, Some a, instr :: instrs -> + if IdSet.mem a (instr_ids instr) then + None + else + scan ctyp id 1 instrs + + | 2, Some a, I_aux (I_clear (ctyp', id'), _) :: instrs + when Id.compare id id' = 0 && ctyp_equal ctyp ctyp' -> + scan ctyp id 2 instrs + + | 2, Some a, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan ctyp id 2 instrs + + | 2, Some a, [] -> !alias + + | n, _, _ :: instrs when n = 0 || n > 2 -> scan ctyp id n instrs + | _, _, I_aux (_, (_, l)) :: instrs -> raise (Reporting.err_unreachable l __POS__ "optimize_alias") + | _, _, [] -> None + in + scan ctyp id 0 + in + let remove_alias id alias = function + | I_aux (I_copy (CL_id (id', _), (F_id alias', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_copy (CL_id (alias', _), (F_id id', _)), _) + when Id.compare id id' = 0 && Id.compare alias alias' = 0 -> removed + | I_aux (I_clear (_, id'), _) -> removed + | instr -> instr + in + let rec opt = function + | I_aux (I_decl (ctyp, id), _) as instr :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some alias -> + let instrs = List.map (map_instr (remove_alias id alias)) instrs in + filter_instrs is_not_removed (List.map (instr_rename id alias) instrs) + end + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, opt body)] + | cdef -> [cdef] + +(** This pass ensures that all variables created by I_decl have unique names *) +let unique_names = + let unique_counter = ref 0 in + let unique_id () = + let id = mk_id ("u#" ^ string_of_int !unique_counter) in + incr unique_counter; + id + in + + let rec opt seen = function + | I_aux (I_decl (ctyp, id), aux) :: instrs when IdSet.mem id seen -> + let id' = unique_id () in + let instrs', seen = opt seen instrs in + I_aux (I_decl (ctyp, id'), aux) :: instrs_rename id id' instrs', seen + + | I_aux (I_decl (ctyp, id), aux) :: instrs -> + let instrs', seen = opt (IdSet.add id seen) instrs in + I_aux (I_decl (ctyp, id), aux) :: instrs', seen + + | I_aux (I_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_block block', aux) :: instrs', seen + + | I_aux (I_try_block block, aux) :: instrs -> + let block', seen = opt seen block in + let instrs', seen = opt seen instrs in + I_aux (I_try_block block', aux) :: instrs', seen + + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + let then_instrs', seen = opt seen then_instrs in + let else_instrs', seen = opt seen else_instrs in + let instrs', seen = opt seen instrs in + I_aux (I_if (cval, then_instrs', else_instrs', ctyp), aux) :: instrs', seen + + | instr :: instrs -> + let instrs', seen = opt seen instrs in + instr :: instrs', seen + + | [] -> [], seen + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, fst (opt IdSet.empty body))] + | CDEF_reg_dec (id, ctyp, instrs) -> + [CDEF_reg_dec (id, ctyp, fst (opt IdSet.empty instrs))] + | CDEF_let (n, bindings, instrs) -> + [CDEF_let (n, bindings, fst (opt IdSet.empty instrs))] + | cdef -> [cdef] + +(** This optimization looks for patterns of the form + + create x : t; + create y : t; + // modifications to y, no changes to x + x = y; + kill y; + + If found we can replace y by x *) +let combine_variables = + let pattern ctyp id = + let combine = ref None in + let rec scan id n instrs = + match n, !combine, instrs with + | 0, None, I_aux (I_block block, _) :: instrs -> + begin match scan id 0 block with + | Some combine -> Some combine + | None -> scan id 0 instrs + end + + | 0, None, I_aux (I_decl (ctyp', id'), _) :: instrs when ctyp_equal ctyp ctyp' -> + combine := Some id'; + scan id 1 instrs + + | 1, Some c, I_aux (I_copy (CL_id (id', ctyp'), (F_id c', ctyp'')), _) :: instrs + when Id.compare c c' = 0 && Id.compare id id' = 0 && ctyp_equal ctyp ctyp' && ctyp_equal ctyp' ctyp'' -> + scan id 2 instrs + + (* Ignore seemingly early clears of x, as this can happen along exception paths *) + | 1, Some c, I_aux (I_clear (_, id'), _) :: instrs + when Id.compare id id' = 0 -> + scan id 1 instrs + + | 1, Some c, instr :: instrs -> + if IdSet.mem id (instr_ids instr) then + None + else + scan id 1 instrs + + | 2, Some c, I_aux (I_clear (ctyp', c'), _) :: instrs + when Id.compare c c' = 0 && ctyp_equal ctyp ctyp' -> + !combine + + | 2, Some c, instr :: instrs -> + if IdSet.mem c (instr_ids instr) then + None + else + scan id 2 instrs + + | 2, Some c, [] -> !combine + + | n, _, _ :: instrs -> scan id n instrs + | _, _, [] -> None + in + scan id 0 + in + let remove_variable id = function + | I_aux (I_decl (_, id'), _) when Id.compare id id' = 0 -> removed + | I_aux (I_clear (_, id'), _) when Id.compare id id' = 0 -> removed + | instr -> instr + in + let is_not_self_assignment = function + | I_aux (I_copy (CL_id (id, _), (F_id id', _)), _) when Id.compare id id' = 0 -> false + | _ -> true + in + let rec opt = function + | (I_aux (I_decl (ctyp, id), _) as instr) :: instrs -> + begin match pattern ctyp id instrs with + | None -> instr :: opt instrs + | Some combine -> + let instrs = List.map (map_instr (remove_variable combine)) instrs in + let instrs = filter_instrs (fun i -> is_not_removed i && is_not_self_assignment i) + (List.map (instr_rename combine id) instrs) in + opt (instr :: instrs) + end + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + [CDEF_fundef (function_id, heap_return, args, opt body)] + | cdef -> [cdef] + +(** hoist_alias looks for patterns like + + recreate x; y = x; // no furthner mentions of x + + Provided x has a certain type, then we can make y an alias to x + (denoted in the IR as 'alias y = x'). This only works if y also has + a lifespan that also spans the entire function body. It's possible + we may need to do a more thorough lifetime evaluation to get this + to be 100% correct - so it's behind the -Oexperimental flag + for now. Some benchmarking shows that this kind of optimization + is very valuable however! *) +let hoist_alias = + (* Must return true for a subset of the types hoist_ctyp would return true for. *) + let is_struct = function + | CT_struct _ -> true + | _ -> false + in + let pattern heap_return id ctyp instrs = + let rec scan instrs = + match instrs with + (* The only thing that has a longer lifetime than id is the + function return, so we want to make sure we avoid that + case. *) + | (I_aux (I_copy (clexp, (F_id id', ctyp')), aux) as instr) :: instrs + when not (IdSet.mem heap_return (instr_writes instr)) && Id.compare id id' = 0 + && ctyp_equal (clexp_ctyp clexp) ctyp && ctyp_equal ctyp ctyp' -> + if List.exists (IdSet.mem id) (List.map instr_ids instrs) then + instr :: scan instrs + else + I_aux (I_alias (clexp, (F_id id', ctyp')), aux) :: instrs + + | instr :: instrs -> instr :: scan instrs + | [] -> [] + in + scan instrs + in + let optimize heap_return = + let rec opt = function + | (I_aux (I_reset (ctyp, id), _) as instr) :: instrs when not (is_stack_ctyp ctyp) && is_struct ctyp -> + instr :: opt (pattern heap_return id ctyp instrs) + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (opt block), aux) :: opt instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (opt block), aux) :: opt instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, opt then_instrs, opt else_instrs, ctyp), aux) :: opt instrs + + | instr :: instrs -> + instr :: opt instrs + | [] -> [] + in + opt + in + function + | CDEF_fundef (function_id, Some heap_return, args, body) -> + [CDEF_fundef (function_id, Some heap_return, args, optimize heap_return body)] + | cdef -> [cdef] + +let concatMap f xs = List.concat (List.map f xs) + +let optimize recursive_functions cdefs = + let nothing cdefs = cdefs in + cdefs + |> (if !optimize_alias then concatMap unique_names else nothing) + |> (if !optimize_alias then concatMap remove_alias else nothing) + |> (if !optimize_alias then concatMap combine_variables else nothing) + (* We need the runtime to initialize hoisted allocations *) + |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations recursive_functions) else nothing) + |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap hoist_alias else nothing) + +(**************************************************************************) +(* 6. Code generation *) +(**************************************************************************) + +let sgen_id id = Util.zencode_string (string_of_id id) +let codegen_id id = string (sgen_id id) + +let sgen_function_id id = + let str = Util.zencode_string (string_of_id id) in + !opt_prefix ^ String.sub str 1 (String.length str - 1) + +let codegen_function_id id = string (sgen_function_id id) + +let rec sgen_ctyp = function + | CT_unit -> "unit" + | CT_bit -> "fbits" + | CT_bool -> "bool" + | CT_fbits _ -> "fbits" + | CT_sbits _ -> "sbits" + | CT_fint _ -> "mach_int" + | CT_lint -> "sail_int" + | CT_lbits _ -> "lbits" + | CT_tup _ as tup -> "struct " ^ Util.zencode_string ("tuple_" ^ string_of_ctyp tup) + | CT_struct (id, _) -> "struct " ^ sgen_id id + | CT_enum (id, _) -> "enum " ^ sgen_id id + | CT_variant (id, _) -> "struct " ^ sgen_id id + | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) + | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_string -> "sail_string" + | CT_real -> "real" + | CT_ref ctyp -> sgen_ctyp ctyp ^ "*" + | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) + +let rec sgen_ctyp_name = function + | CT_unit -> "unit" + | CT_bit -> "fbits" + | CT_bool -> "bool" + | CT_fbits _ -> "fbits" + | CT_sbits _ -> "sbits" + | CT_fint _ -> "mach_int" + | CT_lint -> "sail_int" + | CT_lbits _ -> "lbits" + | CT_tup _ as tup -> Util.zencode_string ("tuple_" ^ string_of_ctyp tup) + | CT_struct (id, _) -> sgen_id id + | CT_enum (id, _) -> sgen_id id + | CT_variant (id, _) -> sgen_id id + | CT_list _ as l -> Util.zencode_string (string_of_ctyp l) + | CT_vector _ as v -> Util.zencode_string (string_of_ctyp v) + | CT_string -> "sail_string" + | CT_real -> "real" + | CT_ref ctyp -> "ref_" ^ sgen_ctyp_name ctyp + | CT_poly -> "POLY" (* c_error "Tried to generate code for non-monomorphic type" *) + +let sgen_cval_param (frag, ctyp) = + match ctyp with + | CT_lbits direction -> + string_of_fragment frag ^ ", " ^ string_of_bool direction + | CT_sbits (_, direction) -> + string_of_fragment frag ^ ", " ^ string_of_bool direction + | CT_fbits (len, direction) -> + string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction + | _ -> + string_of_fragment frag + +let sgen_cval = function (frag, _) -> string_of_fragment frag + +let rec sgen_clexp = function + | CL_id (id, _) -> "&" ^ sgen_id id + | CL_field (clexp, field) -> "&((" ^ sgen_clexp clexp ^ ")->" ^ Util.zencode_string field ^ ")" + | CL_tuple (clexp, n) -> "&((" ^ sgen_clexp clexp ^ ")->ztup" ^ string_of_int n ^ ")" + | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))" + | CL_have_exception -> "have_exception" + | CL_current_exception _ -> "current_exception" + | CL_return _ -> assert false + +let rec sgen_clexp_pure = function + | CL_id (id, _) -> sgen_id id + | CL_field (clexp, field) -> sgen_clexp_pure clexp ^ "." ^ Util.zencode_string field + | CL_tuple (clexp, n) -> sgen_clexp_pure clexp ^ ".ztup" ^ string_of_int n + | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))" + | CL_have_exception -> "have_exception" + | CL_current_exception _ -> "current_exception" + | CL_return _ -> assert false + +(** Generate instructions to copy from a cval to a clexp. This will + insert any needed type conversions from big integers to small + integers (or vice versa), or from arbitrary-length bitvectors to + and from uint64 bitvectors as needed. *) +let rec codegen_conversion l clexp cval = + let open Printf in + let ctyp_to = clexp_ctyp clexp in + let ctyp_from = cval_ctyp cval in + match ctyp_to, ctyp_from with + (* When both types are equal, we don't need any conversion. *) + | _, _ when ctyp_equal ctyp_to ctyp_from -> + if is_stack_ctyp ctyp_to then + ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) + else + ksprintf string " COPY(%s)(%s, %s);" (sgen_ctyp_name ctyp_to) (sgen_clexp clexp) (sgen_cval cval) + + | CT_ref ctyp_to, ctyp_from -> + codegen_conversion l (CL_addr clexp) cval + + (* If we have to convert between tuple types, convert the fields individually. *) + | CT_tup ctyps_to, CT_tup ctyps_from when List.length ctyps_to = List.length ctyps_from -> + let conversions = + List.mapi (fun i ctyp -> codegen_conversion l (CL_tuple (clexp, i)) (F_field (fst cval, "ztup" ^ string_of_int i), ctyp)) ctyps_from + in + string " /* conversions */" + ^^ hardline + ^^ separate hardline conversions + ^^ hardline + ^^ string " /* end conversions */" + + (* For anything not special cased, just try to call a appropriate CONVERT_OF function. *) + | _, _ when is_stack_ctyp (clexp_ctyp clexp) -> + ksprintf string " %s = CONVERT_OF(%s, %s)(%s);" + (sgen_clexp_pure clexp) (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_cval_param cval) + | _, _ -> + ksprintf string " CONVERT_OF(%s, %s)(%s, %s);" + (sgen_ctyp_name ctyp_to) (sgen_ctyp_name ctyp_from) (sgen_clexp clexp) (sgen_cval_param cval) + +let rec codegen_instr fid ctx (I_aux (instr, (_, l))) = + let open Printf in + match instr with + | I_decl (ctyp, id) when is_stack_ctyp ctyp -> + ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) + | I_decl (ctyp, id) -> + ksprintf string " %s %s;" (sgen_ctyp ctyp) (sgen_id id) ^^ hardline + ^^ ksprintf string " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) + + | I_copy (clexp, cval) -> codegen_conversion l clexp cval + + | I_alias (clexp, cval) -> + ksprintf string " %s = %s;" (sgen_clexp_pure clexp) (sgen_cval cval) + + | I_jump (cval, label) -> + ksprintf string " if (%s) goto %s;" (sgen_cval cval) label + + | I_if (cval, [then_instr], [], ctyp) -> + ksprintf string " if (%s)" (sgen_cval cval) ^^ hardline + ^^ twice space ^^ codegen_instr fid ctx then_instr + | I_if (cval, then_instrs, [], ctyp) -> + string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + | I_if (cval, then_instrs, else_instrs, ctyp) -> + string " if" ^^ space ^^ parens (string (sgen_cval cval)) ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) then_instrs) (twice space ^^ rbrace) + ^^ space ^^ string "else" ^^ space + ^^ surround 0 0 lbrace (separate_map hardline (codegen_instr fid ctx) else_instrs) (twice space ^^ rbrace) + + | I_block instrs -> + string " {" + ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline + ^^ string " }" + + | I_try_block instrs -> + string " { /* try */" + ^^ jump 2 2 (separate_map hardline (codegen_instr fid ctx) instrs) ^^ hardline + ^^ string " }" + + | I_funcall (x, extern, f, args) -> + let c_args = Util.string_of_list ", " sgen_cval args in + let ctyp = clexp_ctyp x in + let is_extern = Env.is_extern f ctx.tc_env "c" || extern in + let fname = + if Env.is_extern f ctx.tc_env "c" then + Env.get_extern f ctx.tc_env "c" + else if extern then + string_of_id f + else + sgen_function_id f + in + let fname = + match fname, ctyp with + | "internal_pick", _ -> Printf.sprintf "pick_%s" (sgen_ctyp_name ctyp) + | "eq_anything", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "eq_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "eq_anything function with bad arity." + end + | "length", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "length_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "length function with bad arity." + end + | "vector_access", CT_bit -> "bitvector_access" + | "vector_access", _ -> + begin match args with + | cval :: _ -> Printf.sprintf "vector_access_%s" (sgen_ctyp_name (cval_ctyp cval)) + | _ -> c_error "vector access function with bad arity." + end + | "vector_update_subrange", _ -> Printf.sprintf "vector_update_subrange_%s" (sgen_ctyp_name ctyp) + | "vector_subrange", _ -> Printf.sprintf "vector_subrange_%s" (sgen_ctyp_name ctyp) + | "vector_update", CT_fbits _ -> "update_fbits" + | "vector_update", CT_lbits _ -> "update_lbits" + | "vector_update", _ -> Printf.sprintf "vector_update_%s" (sgen_ctyp_name ctyp) + | "string_of_bits", _ -> + begin match cval_ctyp (List.nth args 0) with + | CT_fbits _ -> "string_of_fbits" + | CT_lbits _ -> "string_of_lbits" + | _ -> assert false + end + | "decimal_string_of_bits", _ -> + begin match cval_ctyp (List.nth args 0) with + | CT_fbits _ -> "decimal_string_of_fbits" + | CT_lbits _ -> "decimal_string_of_lbits" + | _ -> assert false + end + | "internal_vector_update", _ -> Printf.sprintf "internal_vector_update_%s" (sgen_ctyp_name ctyp) + | "internal_vector_init", _ -> Printf.sprintf "internal_vector_init_%s" (sgen_ctyp_name ctyp) + | "undefined_vector", CT_fbits _ -> "UNDEFINED(fbits)" + | "undefined_vector", CT_lbits _ -> "UNDEFINED(lbits)" + | "undefined_bit", _ -> "UNDEFINED(fbits)" + | "undefined_vector", _ -> Printf.sprintf "UNDEFINED(vector_%s)" (sgen_ctyp_name ctyp) + | fname, _ -> fname + in + if fname = "sail_assert" && !optimize_experimental then + empty + else if fname = "reg_deref" then + if is_stack_ctyp ctyp then + string (Printf.sprintf " %s = *(%s);" (sgen_clexp_pure x) c_args) + else + string (Printf.sprintf " COPY(%s)(&%s, *(%s));" (sgen_ctyp_name ctyp) (sgen_clexp_pure x) c_args) + else + if is_stack_ctyp ctyp then + string (Printf.sprintf " %s = %s(%s%s);" (sgen_clexp_pure x) fname (extra_arguments is_extern) c_args) + else + string (Printf.sprintf " %s(%s%s, %s);" fname (extra_arguments is_extern) (sgen_clexp x) c_args) + + | I_clear (ctyp, id) when is_stack_ctyp ctyp -> + empty + | I_clear (ctyp, id) -> + string (Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + + | I_init (ctyp, id, cval) -> + codegen_instr fid ctx (idecl ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval + + | I_reinit (ctyp, id, cval) -> + codegen_instr fid ctx (ireset ctyp id) ^^ hardline + ^^ codegen_conversion Parse_ast.Unknown (CL_id (id, ctyp)) cval + + | I_reset (ctyp, id) when is_stack_ctyp ctyp -> + string (Printf.sprintf " %s %s;" (sgen_ctyp ctyp) (sgen_id id)) + | I_reset (ctyp, id) -> + string (Printf.sprintf " RECREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + + | I_return cval -> + string (Printf.sprintf " return %s;" (sgen_cval cval)) + + | I_throw cval -> + c_error ~loc:l "I_throw reached code generator" + + | I_undefined ctyp -> + let rec codegen_exn_return ctyp = + match ctyp with + | CT_unit -> "UNIT", [] + | CT_bit -> "UINT64_C(0)", [] + | CT_fint _ -> "INT64_C(0xdeadc0de)", [] + | CT_fbits _ -> "UINT64_C(0xdeadc0de)", [] + | CT_sbits _ -> "undefined_sbits()", [] + | CT_bool -> "false", [] + | CT_enum (_, ctor :: _) -> sgen_id ctor, [] + | CT_tup ctyps when is_stack_ctyp ctyp -> + let gs = gensym () in + let fold (inits, prev) (n, ctyp) = + let init, prev' = codegen_exn_return ctyp in + Printf.sprintf ".ztup%d = %s" n init :: inits, prev @ prev' + in + let inits, prev = List.fold_left fold ([], []) (List.mapi (fun i x -> (i, x)) ctyps) in + sgen_id gs, + [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) + ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev + | CT_struct (id, ctors) when is_stack_ctyp ctyp -> + let gs = gensym () in + let fold (inits, prev) (id, ctyp) = + let init, prev' = codegen_exn_return ctyp in + Printf.sprintf ".%s = %s" (sgen_id id) init :: inits, prev @ prev' + in + let inits, prev = List.fold_left fold ([], []) ctors in + sgen_id gs, + [Printf.sprintf "struct %s %s = { " (sgen_ctyp_name ctyp) (sgen_id gs) + ^ Util.string_of_list ", " (fun x -> x) inits ^ " };"] @ prev + | ctyp -> c_error ("Cannot create undefined value for type: " ^ string_of_ctyp ctyp) + in + let ret, prev = codegen_exn_return ctyp in + separate_map hardline (fun str -> string (" " ^ str)) (List.rev prev) + ^^ hardline + ^^ string (Printf.sprintf " return %s;" ret) + + | I_comment str -> + string (" /* " ^ str ^ " */") + + | I_label str -> + string (str ^ ": ;") + + | I_goto str -> + string (Printf.sprintf " goto %s;" str) + + | I_raw _ when ctx.no_raw -> empty + | I_raw str -> + string (" " ^ str) + + | I_end -> assert false + + | I_match_failure -> + string (" sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");") + +let codegen_type_def ctx = function + | CTD_enum (id, ((first_id :: _) as ids)) -> + let codegen_eq = + let name = sgen_id id in + string (Printf.sprintf "static bool eq_%s(enum %s op1, enum %s op2) { return op1 == op2; }" name name name) + in + let codegen_undefined = + let name = sgen_id id in + string (Printf.sprintf "enum %s UNDEFINED(%s)(unit u) { return %s; }" name name (sgen_id first_id)) + in + string (Printf.sprintf "// enum %s" (string_of_id id)) ^^ hardline + ^^ separate space [string "enum"; codegen_id id; lbrace; separate_map (comma ^^ space) codegen_id ids; rbrace ^^ semi] + ^^ twice hardline + ^^ codegen_eq + ^^ twice hardline + ^^ codegen_undefined + + | CTD_enum (id, []) -> c_error ("Cannot compile empty enum " ^ string_of_id id) + + | CTD_struct (id, ctors) -> + let struct_ctyp = CT_struct (id, ctors) in + c_debug (lazy (Printf.sprintf "Generating struct for %s" (full_string_of_ctyp struct_ctyp))); + + (* Generate a set_T function for every struct T *) + let codegen_set (id, ctyp) = + if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op.%s;" (sgen_id id) (sgen_id id)) + else + string (Printf.sprintf "COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) + in + let codegen_setter id ctors = + string (let n = sgen_id id in Printf.sprintf "static void COPY(%s)(struct %s *rop, const struct %s op)" n n n) ^^ space + ^^ surround 2 0 lbrace + (separate_map hardline codegen_set (Bindings.bindings ctors)) + rbrace + in + (* Generate an init/clear_T function for every struct T *) + let codegen_field_init f (id, ctyp) = + if not (is_stack_ctyp ctyp) then + [string (Printf.sprintf "%s(%s)(&op->%s);" f (sgen_ctyp_name ctyp) (sgen_id id))] + else [] + in + let codegen_init f id ctors = + string (let n = sgen_id id in Printf.sprintf "static void %s(%s)(struct %s *op)" f n n) ^^ space + ^^ surround 2 0 lbrace + (separate hardline (Bindings.bindings ctors |> List.map (codegen_field_init f) |> List.concat)) + rbrace + in + let codegen_eq = + let codegen_eq_test (id, ctyp) = + string (Printf.sprintf "EQUAL(%s)(op1.%s, op2.%s)" (sgen_ctyp_name ctyp) (sgen_id id) (sgen_id id)) + in + string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2)" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ space + ^^ surround 2 0 lbrace + (string "return" ^^ space + ^^ separate_map (string " && ") codegen_eq_test ctors + ^^ string ";") + rbrace + in + (* Generate the struct and add the generated functions *) + let codegen_ctor (id, ctyp) = + string (sgen_ctyp ctyp) ^^ space ^^ codegen_id id + in + string (Printf.sprintf "// struct %s" (string_of_id id)) ^^ hardline + ^^ string "struct" ^^ space ^^ codegen_id id ^^ space + ^^ surround 2 0 lbrace + (separate_map (semi ^^ hardline) codegen_ctor ctors ^^ semi) + rbrace + ^^ semi ^^ twice hardline + ^^ codegen_setter id (ctor_bindings ctors) + ^^ (if not (is_stack_ctyp struct_ctyp) then + twice hardline + ^^ codegen_init "CREATE" id (ctor_bindings ctors) + ^^ twice hardline + ^^ codegen_init "RECREATE" id (ctor_bindings ctors) + ^^ twice hardline + ^^ codegen_init "KILL" id (ctor_bindings ctors) + else empty) + ^^ twice hardline + ^^ codegen_eq + + | CTD_variant (id, tus) -> + let codegen_tu (ctor_id, ctyp) = + separate space [string "struct"; lbrace; string (sgen_ctyp ctyp); codegen_id ctor_id ^^ semi; rbrace] + in + (* Create an if, else if, ... block that does something for each constructor *) + let rec each_ctor v f = function + | [] -> string "{}" + | [(ctor_id, ctyp)] -> + string (Printf.sprintf "if (%skind == Kind_%s)" v (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (f ctor_id ctyp) + ^^ hardline ^^ rbrace + | (ctor_id, ctyp) :: ctors -> + string (Printf.sprintf "if (%skind == Kind_%s) " v (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (f ctor_id ctyp) + ^^ hardline ^^ rbrace ^^ string " else " ^^ each_ctor v f ctors + in + let codegen_init = + let n = sgen_id id in + let ctor_id, ctyp = List.hd tus in + string (Printf.sprintf "static void CREATE(%s)(struct %s *op)" n n) + ^^ hardline + ^^ surround 2 0 lbrace + (string (Printf.sprintf "op->kind = Kind_%s;" (sgen_id ctor_id)) ^^ hardline + ^^ if not (is_stack_ctyp ctyp) then + string (Printf.sprintf "CREATE(%s)(&op->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) + else empty) + rbrace + in + let codegen_reinit = + let n = sgen_id id in + string (Printf.sprintf "static void RECREATE(%s)(struct %s *op) {}" n n) + in + let clear_field v ctor_id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "/* do nothing */") + else + string (Printf.sprintf "KILL(%s)(&%s->%s);" (sgen_ctyp_name ctyp) v (sgen_id ctor_id)) + in + let codegen_clear = + let n = sgen_id id in + string (Printf.sprintf "static void KILL(%s)(struct %s *op)" n n) ^^ hardline + ^^ surround 2 0 lbrace + (each_ctor "op->" (clear_field "op") tus ^^ semi) + rbrace + in + let codegen_ctor (ctor_id, ctyp) = + let ctor_args, tuple, tuple_cleanup = + let tuple_set i ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "op.ztup%d = op%d;" i i) + else + string (Printf.sprintf "COPY(%s)(&op.ztup%d, op%d);" (sgen_ctyp_name ctyp) i i) + in + Printf.sprintf "%s op" (sgen_ctyp ctyp), empty, empty + in + string (Printf.sprintf "static void %s(%sstruct %s *rop, %s)" (sgen_function_id ctor_id) (extra_params ()) (sgen_id id) ctor_args) ^^ hardline + ^^ surround 2 0 lbrace + (tuple + ^^ each_ctor "rop->" (clear_field "rop") tus ^^ hardline + ^^ string ("rop->kind = Kind_" ^ sgen_id ctor_id) ^^ semi ^^ hardline + ^^ if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op;" (sgen_id ctor_id)) + else + string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline + ^^ string (Printf.sprintf "COPY(%s)(&rop->%s, op);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) ^^ hardline + ^^ tuple_cleanup) + rbrace + in + let codegen_setter = + let n = sgen_id id in + let set_field ctor_id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "rop->%s = op.%s;" (sgen_id ctor_id) (sgen_id ctor_id)) + else + string (Printf.sprintf "CREATE(%s)(&rop->%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id)) + ^^ string (Printf.sprintf " COPY(%s)(&rop->%s, op.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) + in + string (Printf.sprintf "static void COPY(%s)(struct %s *rop, struct %s op)" n n n) ^^ hardline + ^^ surround 2 0 lbrace + (each_ctor "rop->" (clear_field "rop") tus + ^^ semi ^^ hardline + ^^ string "rop->kind = op.kind" + ^^ semi ^^ hardline + ^^ each_ctor "op." set_field tus) + rbrace + in + let codegen_eq = + let codegen_eq_test ctor_id ctyp = + string (Printf.sprintf "return EQUAL(%s)(op1.%s, op2.%s);" (sgen_ctyp_name ctyp) (sgen_id ctor_id) (sgen_id ctor_id)) + in + let rec codegen_eq_tests = function + | [] -> string "return false;" + | (ctor_id, ctyp) :: ctors -> + string (Printf.sprintf "if (op1.kind == Kind_%s && op2.kind == Kind_%s) " (sgen_id ctor_id) (sgen_id ctor_id)) ^^ lbrace ^^ hardline + ^^ jump 0 2 (codegen_eq_test ctor_id ctyp) + ^^ hardline ^^ rbrace ^^ string " else " ^^ codegen_eq_tests ctors + in + let n = sgen_id id in + string (Printf.sprintf "static bool EQUAL(%s)(struct %s op1, struct %s op2) " n n n) + ^^ surround 2 0 lbrace (codegen_eq_tests tus) rbrace + in + string (Printf.sprintf "// union %s" (string_of_id id)) ^^ hardline + ^^ string "enum" ^^ space + ^^ string ("kind_" ^ sgen_id id) ^^ space + ^^ separate space [ lbrace; + separate_map (comma ^^ space) (fun id -> string ("Kind_" ^ sgen_id id)) (List.map fst tus); + rbrace ^^ semi ] + ^^ twice hardline + ^^ string "struct" ^^ space ^^ codegen_id id ^^ space + ^^ surround 2 0 lbrace + (separate space [string "enum"; string ("kind_" ^ sgen_id id); string "kind" ^^ semi] + ^^ hardline + ^^ string "union" ^^ space + ^^ surround 2 0 lbrace + (separate_map (semi ^^ hardline) codegen_tu tus ^^ semi) + rbrace + ^^ semi) + rbrace + ^^ semi + ^^ twice hardline + ^^ codegen_init + ^^ twice hardline + ^^ codegen_reinit + ^^ twice hardline + ^^ codegen_clear + ^^ twice hardline + ^^ codegen_setter + ^^ twice hardline + ^^ codegen_eq + ^^ twice hardline + ^^ separate_map (twice hardline) codegen_ctor tus + (* If this is the exception type, then we setup up some global variables to deal with exceptions. *) + ^^ if string_of_id id = "exception" then + twice hardline + ^^ string "struct zexception *current_exception = NULL;" + ^^ hardline + ^^ string "bool have_exception = false;" + else + empty + +(** GLOBAL: because C doesn't have real anonymous tuple types + (anonymous structs don't quite work the way we need) every tuple + type in the spec becomes some generated named struct in C. This is + done in such a way that every possible tuple type has a unique name + associated with it. This global variable keeps track of these + generated struct names, so we never generate two copies of the + struct that is used to represent them in C. + + The way this works is that codegen_def scans each definition's type + annotations for tuple types and generates the required structs + using codegen_type_def before the actual definition is generated by + codegen_def'. + + This variable should be reset to empty only when the entire AST has + been translated to C. **) +let generated = ref IdSet.empty + +let codegen_tup ctx ctyps = + let id = mk_id ("tuple_" ^ string_of_ctyp (CT_tup ctyps)) in + if IdSet.mem id !generated then + empty + else + begin + let _, fields = List.fold_left (fun (n, fields) ctyp -> n + 1, Bindings.add (mk_id ("tup" ^ string_of_int n)) ctyp fields) + (0, Bindings.empty) + ctyps + in + generated := IdSet.add id !generated; + codegen_type_def ctx (CTD_struct (id, Bindings.bindings fields)) ^^ twice hardline + end + +let codegen_node id ctyp = + string (Printf.sprintf "struct node_%s {\n %s hd;\n struct node_%s *tl;\n};\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string (Printf.sprintf "typedef struct node_%s *%s;" (sgen_id id) (sgen_id id)) + +let codegen_list_init id = + string (Printf.sprintf "static void CREATE(%s)(%s *rop) { *rop = NULL; }" (sgen_id id) (sgen_id id)) + +let codegen_list_clear id ctyp = + string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " if (*rop == NULL) return;") + ^^ (if is_stack_ctyp ctyp then empty + else string (Printf.sprintf " KILL(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp))) + ^^ string (Printf.sprintf " KILL(%s)(&(*rop)->tl);\n" (sgen_id id)) + ^^ string " free(*rop);" + ^^ string "}" + +let codegen_list_set id ctyp = + string (Printf.sprintf "static void internal_set_%s(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string " if (op == NULL) { *rop = NULL; return; };\n" + ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then + string " (*rop)->hd = op->hd;\n" + else + string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) + ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, op->hd);\n" (sgen_ctyp_name ctyp))) + ^^ string (Printf.sprintf " internal_set_%s(&(*rop)->tl, op->tl);\n" (sgen_id id)) + ^^ string "}" + ^^ twice hardline + ^^ string (Printf.sprintf "static void COPY(%s)(%s *rop, const %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) + ^^ string (Printf.sprintf " internal_set_%s(rop, op);\n" (sgen_id id)) + ^^ string "}" + +let codegen_cons id ctyp = + let cons_id = mk_id ("cons#" ^ string_of_ctyp ctyp) in + string (Printf.sprintf "static void %s(%s *rop, const %s x, const %s xs) {\n" (sgen_function_id cons_id) (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string (Printf.sprintf " *rop = malloc(sizeof(struct node_%s));\n" (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then + string " (*rop)->hd = x;\n" + else + string (Printf.sprintf " CREATE(%s)(&(*rop)->hd);\n" (sgen_ctyp_name ctyp)) + ^^ string (Printf.sprintf " COPY(%s)(&(*rop)->hd, x);\n" (sgen_ctyp_name ctyp))) + ^^ string " (*rop)->tl = xs;\n" + ^^ string "}" + +let codegen_pick id ctyp = + if is_stack_ctyp ctyp then + string (Printf.sprintf "static %s pick_%s(const %s xs) { return xs->hd; }" (sgen_ctyp ctyp) (sgen_ctyp_name ctyp) (sgen_id id)) + else + string (Printf.sprintf "static void pick_%s(%s *x, const %s xs) { COPY(%s)(x, xs->hd); }" (sgen_ctyp_name ctyp) (sgen_ctyp ctyp) (sgen_id id) (sgen_ctyp_name ctyp)) + +let codegen_list ctx ctyp = + let id = mk_id (string_of_ctyp (CT_list ctyp)) in + if IdSet.mem id !generated then + empty + else + begin + generated := IdSet.add id !generated; + codegen_node id ctyp ^^ twice hardline + ^^ codegen_list_init id ^^ twice hardline + ^^ codegen_list_clear id ctyp ^^ twice hardline + ^^ codegen_list_set id ctyp ^^ twice hardline + ^^ codegen_cons id ctyp ^^ twice hardline + ^^ codegen_pick id ctyp ^^ twice hardline + end + +(* Generate functions for working with non-bit vectors of some specific type. *) +let codegen_vector ctx (direction, ctyp) = + let id = mk_id (string_of_ctyp (CT_vector (direction, ctyp))) in + if IdSet.mem id !generated then + empty + else + let vector_typedef = + string (Printf.sprintf "struct %s {\n size_t len;\n %s *data;\n};\n" (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (Printf.sprintf "typedef struct %s %s;" (sgen_id id) (sgen_id id)) + in + let vector_init = + string (Printf.sprintf "static void CREATE(%s)(%s *rop) {\n rop->len = 0;\n rop->data = NULL;\n}" (sgen_id id) (sgen_id id)) + in + let vector_set = + string (Printf.sprintf "static void COPY(%s)(%s *rop, %s op) {\n" (sgen_id id) (sgen_id id) (sgen_id id)) + ^^ string (Printf.sprintf " KILL(%s)(rop);\n" (sgen_id id)) + ^^ string " rop->len = op.len;\n" + ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ string " for (int i = 0; i < op.len; i++) {\n" + ^^ string (if is_stack_ctyp ctyp then + " (rop->data)[i] = op.data[i];\n" + else + Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, op.data[i]);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + let vector_clear = + string (Printf.sprintf "static void KILL(%s)(%s *rop) {\n" (sgen_id id) (sgen_id id)) + ^^ (if is_stack_ctyp ctyp then empty + else + string " for (int i = 0; i < (rop->len); i++) {\n" + ^^ string (Printf.sprintf " KILL(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n") + ^^ string " if (rop->data != NULL) free(rop->data);\n" + ^^ string "}" + in + let vector_update = + string (Printf.sprintf "static void vector_update_%s(%s *rop, %s op, mpz_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string " if (rop->data == op.data) {\n" + ^^ string (if is_stack_ctyp ctyp then + " rop->data[m] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string " } else {\n" + ^^ string (Printf.sprintf " COPY(%s)(rop, op);\n" (sgen_id id)) + ^^ string (if is_stack_ctyp ctyp then + " rop->data[m] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + m, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + let internal_vector_update = + string (Printf.sprintf "static void internal_vector_update_%s(%s *rop, %s op, const int64_t n, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (if is_stack_ctyp ctyp then + " rop->data[n] = elem;\n" + else + Printf.sprintf " COPY(%s)((rop->data) + n, elem);\n" (sgen_ctyp_name ctyp)) + ^^ string "}" + in + let vector_access = + if is_stack_ctyp ctyp then + string (Printf.sprintf "static %s vector_access_%s(%s op, mpz_t n) {\n" (sgen_ctyp ctyp) (sgen_id id) (sgen_id id)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string " return op.data[m];\n" + ^^ string "}" + else + string (Printf.sprintf "static void vector_access_%s(%s *rop, %s op, mpz_t n) {\n" (sgen_id id) (sgen_ctyp ctyp) (sgen_id id)) + ^^ string " int m = mpz_get_ui(n);\n" + ^^ string (Printf.sprintf " COPY(%s)(rop, op.data[m]);\n" (sgen_ctyp_name ctyp)) + ^^ string "}" + in + let internal_vector_init = + string (Printf.sprintf "static void internal_vector_init_%s(%s *rop, const int64_t len) {\n" (sgen_id id) (sgen_id id)) + ^^ string " rop->len = len;\n" + ^^ string (Printf.sprintf " rop->data = malloc(len * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ (if not (is_stack_ctyp ctyp) then + string " for (int i = 0; i < len; i++) {\n" + ^^ string (Printf.sprintf " CREATE(%s)((rop->data) + i);\n" (sgen_ctyp_name ctyp)) + ^^ string " }\n" + else empty) + ^^ string "}" + in + let vector_undefined = + string (Printf.sprintf "static void undefined_vector_%s(%s *rop, mpz_t len, %s elem) {\n" (sgen_id id) (sgen_id id) (sgen_ctyp ctyp)) + ^^ string (Printf.sprintf " rop->len = mpz_get_ui(len);\n") + ^^ string (Printf.sprintf " rop->data = malloc((rop->len) * sizeof(%s));\n" (sgen_ctyp ctyp)) + ^^ string " for (int i = 0; i < (rop->len); i++) {\n" + ^^ string (if is_stack_ctyp ctyp then + " (rop->data)[i] = elem;\n" + else + Printf.sprintf " CREATE(%s)((rop->data) + i);\n COPY(%s)((rop->data) + i, elem);\n" (sgen_ctyp_name ctyp) (sgen_ctyp_name ctyp)) + ^^ string " }\n" + ^^ string "}" + in + begin + generated := IdSet.add id !generated; + vector_typedef ^^ twice hardline + ^^ vector_init ^^ twice hardline + ^^ vector_clear ^^ twice hardline + ^^ vector_undefined ^^ twice hardline + ^^ vector_access ^^ twice hardline + ^^ vector_set ^^ twice hardline + ^^ vector_update ^^ twice hardline + ^^ internal_vector_update ^^ twice hardline + ^^ internal_vector_init ^^ twice hardline + end + +let is_decl = function + | I_aux (I_decl _, _) -> true + | _ -> false + +let codegen_decl = function + | I_aux (I_decl (ctyp, id), _) -> + string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) + | _ -> assert false + +let codegen_alloc = function + | I_aux (I_decl (ctyp, id), _) when is_stack_ctyp ctyp -> empty + | I_aux (I_decl (ctyp, id), _) -> + string (Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id)) + | _ -> assert false + +let codegen_def' ctx = function + | CDEF_reg_dec (id, ctyp, _) -> + string (Printf.sprintf "// register %s" (string_of_id id)) ^^ hardline + ^^ string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id)) + + | CDEF_spec (id, arg_ctyps, ret_ctyp) -> + let static = if !opt_static then "static " else "" in + if Env.is_extern id ctx.tc_env "c" then + empty + else if is_stack_ctyp ret_ctyp then + string (Printf.sprintf "%s%s %s(%s%s);" static (sgen_ctyp ret_ctyp) (sgen_function_id id) (extra_params ()) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) + else + string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps)) + + | CDEF_fundef (id, ret_arg, args, instrs) as def -> + if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else (); + + (* Extract type information about the function from the environment. *) + let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + + (* Check that the function has the correct arity at this point. *) + if List.length arg_ctyps <> List.length args then + c_error ~loc:(id_loc id) ("function arguments " + ^ Util.string_of_list ", " string_of_id args + ^ " matched against type " + ^ Util.string_of_list ", " string_of_ctyp arg_ctyps) + else (); + + let instrs = add_local_labels instrs in + let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in + let function_header = + match ret_arg with + | None -> + assert (is_stack_ctyp ret_ctyp); + (if !opt_static then string "static " else empty) + ^^ string (sgen_ctyp ret_ctyp) ^^ space ^^ codegen_function_id id ^^ parens (string (extra_params ()) ^^ string args) ^^ hardline + | Some gs -> + assert (not (is_stack_ctyp ret_ctyp)); + (if !opt_static then string "static " else empty) + ^^ string "void" ^^ space ^^ codegen_function_id id + ^^ parens (string (extra_params ()) ^^ string (sgen_ctyp ret_ctyp ^ " *" ^ sgen_id gs ^ ", ") ^^ string args) + ^^ hardline + in + function_header + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline + ^^ string "}" + + | CDEF_type ctype_def -> + codegen_type_def ctx ctype_def + + | CDEF_startup (id, instrs) -> + let static = if !opt_static then "static " else "" in + let startup_header = string (Printf.sprintf "%svoid startup_%s(void)" static (sgen_function_id id)) in + separate_map hardline codegen_decl instrs + ^^ twice hardline + ^^ startup_header ^^ hardline + ^^ string "{" + ^^ jump 0 2 (separate_map hardline codegen_alloc instrs) ^^ hardline + ^^ string "}" + + | CDEF_finish (id, instrs) -> + let static = if !opt_static then "static " else "" in + let finish_header = string (Printf.sprintf "%svoid finish_%s(void)" static (sgen_function_id id)) in + separate_map hardline codegen_decl (List.filter is_decl instrs) + ^^ twice hardline + ^^ finish_header ^^ hardline + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr id ctx) instrs) ^^ hardline + ^^ string "}" + + | CDEF_let (number, bindings, instrs) -> + let instrs = add_local_labels instrs in + let setup = + List.concat (List.map (fun (id, ctyp) -> [idecl ctyp id]) bindings) + in + let cleanup = + List.concat (List.map (fun (id, ctyp) -> [iclear ctyp id]) bindings) + in + separate_map hardline (fun (id, ctyp) -> string (Printf.sprintf "%s %s;" (sgen_ctyp ctyp) (sgen_id id))) bindings + ^^ hardline ^^ string (Printf.sprintf "static void create_letbind_%d(void) " number) + ^^ string "{" + ^^ jump 0 2 (separate_map hardline codegen_alloc setup) ^^ hardline + ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") { ctx with no_raw = true }) instrs) ^^ hardline + ^^ string "}" + ^^ hardline ^^ string (Printf.sprintf "static void kill_letbind_%d(void) " number) + ^^ string "{" + ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") ctx) cleanup) ^^ hardline + ^^ string "}" + +(** As we generate C we need to generate specialized version of tuple, + list, and vector type. These must be generated in the correct + order. The ctyp_dependencies function generates a list of + c_gen_typs in the order they must be generated. Types may be + repeated in ctyp_dependencies so it's up to the code-generator not + to repeat definitions pointlessly (using the !generated variable) + *) +type c_gen_typ = + | CTG_tup of ctyp list + | CTG_list of ctyp + | CTG_vector of bool * ctyp + +let rec ctyp_dependencies = function + | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps] + | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp] + | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)] + | CT_ref ctyp -> ctyp_dependencies ctyp + | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) + | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors) + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> [] + +let codegen_ctg ctx = function + | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp) + | CTG_tup ctyps -> codegen_tup ctx ctyps + | CTG_list ctyp -> codegen_list ctx ctyp + +(** When we generate code for a definition, we need to first generate + any auxillary type definitions that are required. *) +let codegen_def ctx def = + let ctyps = cdef_ctyps def |> CTSet.elements in + (* We should have erased any polymorphism introduced by variants at this point! *) + if List.exists is_polymorphic ctyps then + let polymorphic_ctyps = List.filter is_polymorphic ctyps in + prerr_endline (Pretty_print_sail.to_string (pp_cdef def)); + c_error (Printf.sprintf "Found polymorphic types:\n%s\nwhile generating definition." + (Util.string_of_list "\n" string_of_ctyp polymorphic_ctyps)) + else + let deps = List.concat (List.map ctyp_dependencies ctyps) in + separate_map hardline (codegen_ctg ctx) deps + ^^ codegen_def' ctx def + +let is_cdef_startup = function + | CDEF_startup _ -> true + | _ -> false + +let sgen_startup = function + | CDEF_startup (id, _) -> + Printf.sprintf " startup_%s();" (sgen_id id) + | _ -> assert false + +let sgen_instr id ctx instr = + Pretty_print_sail.to_string (codegen_instr id ctx instr) + +let is_cdef_finish = function + | CDEF_startup _ -> true + | _ -> false + +let sgen_finish = function + | CDEF_startup (id, _) -> + Printf.sprintf " finish_%s();" (sgen_id id) + | _ -> assert false + +let instrument_tracing ctx = + let module StringSet = Set.Make(String) in + let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in + let rec instrument = function + | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs -> + let trace_start = + iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id))) + in + let trace_arg cval = + let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in + if StringSet.mem ctyp_name traceable then + iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval)) + else + iraw "trace_unknown();" + in + let rec trace_args = function + | [] -> [] + | [cval] -> [trace_arg cval] + | cval :: cvals -> + trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals + in + let trace_end = iraw "trace_end();" in + let trace_ret = iraw "trace_unknown();" + (* + let ctyp_name = sgen_ctyp_name ctyp in + if StringSet.mem ctyp_name traceable then + iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp)) + else + iraw "trace_unknown();" + *) + in + [trace_start] + @ trace_args args + @ [iraw "trace_argend();"; + instr; + trace_end; + trace_ret; + iraw "trace_retend();"] + @ instrument instrs + + | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs + | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs + | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs -> + I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs + + | instr :: instrs -> instr :: instrument instrs + | [] -> [] + in + function + | CDEF_fundef (function_id, heap_return, args, body) -> + CDEF_fundef (function_id, heap_return, args, instrument body) + | cdef -> cdef + +let rec get_recursive_functions (Defs defs) = + match defs with + | DEF_internal_mutrec fundefs :: defs -> + IdSet.union (List.map id_of_fundef fundefs |> IdSet.of_list) (get_recursive_functions (Defs defs)) + + | (DEF_fundef fdef as def) :: defs -> + let open Rewriter in + let ids = ref IdSet.empty in + let collect_funcalls e_aux annot = + match e_aux with + | E_app (id, args) -> (ids := IdSet.add id !ids; E_aux (e_aux, annot)) + | _ -> E_aux (e_aux, annot) + in + let map_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> collect_funcalls e_aux annot) + } in + let map_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp map_exp) } in + let _ = rewrite_def map_defs def in + if IdSet.mem (id_of_fundef fdef) !ids then + IdSet.add (id_of_fundef fdef) (get_recursive_functions (Defs defs)) + else + get_recursive_functions (Defs defs) + + | _ :: defs -> get_recursive_functions (Defs defs) + | [] -> IdSet.empty + +let jib_of_ast env ast = + let ctx = + initial_ctx + ~convert_typ:ctyp_of_typ + ~optimize_anf:(fun ctx aexp -> analyze_functions ctx analyze_primop (c_literals ctx aexp)) + env + in + Jib_compile.compile_ast ctx ast + +let compile_ast env output_chan c_includes ast = + try + c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions")); + let recursive_functions = Spec_analysis.top_sort_defs ast |> get_recursive_functions in + + let cdefs, ctx = jib_of_ast env ast in + let cdefs = insert_heap_returns Bindings.empty cdefs in + let cdefs = optimize recursive_functions cdefs in + + let docs = separate_map (hardline ^^ hardline) (codegen_def ctx) cdefs in + + let preamble = separate hardline + ([ string "#include \"sail.h\"" ] + @ (if !opt_no_rts then [] else + [ string "#include \"rts.h\""; + string "#include \"elf.h\"" ]) + @ (List.map (fun h -> string (Printf.sprintf "#include \"%s\"" h)) c_includes)) + in + + let exn_boilerplate = + if not (Bindings.mem (mk_id "exception") ctx.variants) then ([], []) else + ([ " current_exception = malloc(sizeof(struct zexception));"; + " CREATE(zexception)(current_exception);" ], + [ " KILL(zexception)(current_exception);"; + " free(current_exception);"; + " if (have_exception) fprintf(stderr, \"Exiting due to uncaught exception\\n\");" ]) + in + + let letbind_initializers = + List.map (fun n -> Printf.sprintf " create_letbind_%d();" n) (List.rev ctx.letbinds) + in + let letbind_finalizers = + List.map (fun n -> Printf.sprintf " kill_letbind_%d();" n) ctx.letbinds + in + let startup cdefs = + List.map sgen_startup (List.filter is_cdef_startup cdefs) + in + let finish cdefs = + List.map sgen_finish (List.filter is_cdef_finish cdefs) + in + + let regs = c_ast_registers cdefs in + + let register_init_clear (id, ctyp, instrs) = + if is_stack_ctyp ctyp then + List.map (sgen_instr (mk_id "reg") ctx) instrs, [] + else + [ Printf.sprintf " CREATE(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] + @ List.map (sgen_instr (mk_id "reg") ctx) instrs, + [ Printf.sprintf " KILL(%s)(&%s);" (sgen_ctyp_name ctyp) (sgen_id id) ] + in + + let model_init = separate hardline (List.map string + ( [ "void model_init(void)"; + "{"; + " setup_rts();" ] + @ fst exn_boilerplate + @ startup cdefs + @ List.concat (List.map (fun r -> fst (register_init_clear r)) regs) + @ (if regs = [] then [] else [ Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "initialize_registers")) ]) + @ letbind_initializers + @ [ "}" ] )) + in + + let model_fini = separate hardline (List.map string + ( [ "void model_fini(void)"; + "{" ] + @ letbind_finalizers + @ List.concat (List.map (fun r -> snd (register_init_clear r)) regs) + @ finish cdefs + @ snd exn_boilerplate + @ [ " cleanup_rts();"; + "}" ] )) + in + + let model_default_main = separate hardline (List.map string + [ "int model_main(int argc, char *argv[])"; + "{"; + " model_init();"; + " if (process_arguments(argc, argv)) exit(EXIT_FAILURE);"; + Printf.sprintf " %s(UNIT);" (sgen_function_id (mk_id "main")); + " model_fini();"; + " return EXIT_SUCCESS;"; + "}" ] ) + in + + let model_main = separate hardline (if (!opt_no_main) then [] else List.map string + [ "int main(int argc, char *argv[])"; + "{"; + " return model_main(argc, argv);"; + "}" ] ) + in + + let hlhl = hardline ^^ hardline in + + Pretty_print_sail.to_string (preamble ^^ hlhl ^^ docs ^^ hlhl + ^^ (if not !opt_no_rts then + model_init ^^ hlhl + ^^ model_fini ^^ hlhl + ^^ model_default_main ^^ hlhl + else + empty) + ^^ model_main ^^ hardline) + |> output_string output_chan + with + | Type_error (_, l, err) -> + c_error ~loc:l ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err) diff --git a/src/jib/c_backend.mli b/src/jib/c_backend.mli new file mode 100644 index 00000000..2fc5be94 --- /dev/null +++ b/src/jib/c_backend.mli @@ -0,0 +1,118 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Jib +open Type_check + +(** Global compilation options *) + +(** Output a dataflow graph for each generated function in Graphviz + (dot) format. *) +val opt_debug_flow_graphs : bool ref + +(** Define generated functions as static *) +val opt_static : bool ref + +(** Do not generate a main function *) +val opt_no_main : bool ref + +(** (WIP) Do not include rts.h (the runtime), and do not generate code + that requires any setup or teardown routines to be run by a runtime + before executing any instruction semantics. *) +val opt_no_rts : bool ref + +(** Ordinarily we use plain z-encoding to name-mangle generated Sail + identifiers into a form suitable for C. If opt_prefix is set, then + the "z" which is added on the front of each generated C function + will be replaced by opt_prefix. E.g. opt_prefix := "sail_" would + give sail_my_function rather than zmy_function. *) +val opt_prefix : string ref + +(** opt_extra_params and opt_extra_arguments allow additional state to + be threaded through the generated C code by adding an additional + parameter to each function type, and then giving an extra argument + to each function call. For example we could have + + opt_extra_params := Some "CPUMIPSState *env" + opt_extra_arguments := Some "env" + + and every generated function will take a pointer to a QEMU MIPS + processor state, and each function will be passed the env argument + when it is called. *) +val opt_extra_params : string option ref +val opt_extra_arguments : string option ref + +(** (WIP) [opt_memo_cache] will store the compiled function + definitions in file _sbuild/ccacheDIGEST where DIGEST is the md5sum + of the original function to be compiled. Enabled using the -memo + flag. Uses Marshal so it's quite picky about the exact version of +b the Sail version. This cache can obviously become stale if the C + backend changes - it'll load an old version compiled without said + changes. *) +val opt_memo_cache : bool ref + +(** Optimization flags *) + +val optimize_primops : bool ref +val optimize_hoist_allocations : bool ref +val optimize_struct_updates : bool ref +val optimize_alias : bool ref +val optimize_experimental : bool ref + +(** Convert a typ to a IR ctyp *) +val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp + +(** Rewriting steps for compiled ASTs *) +val flatten_instrs : instr list -> instr list + +val flatten_cdef : cdef -> cdef + +val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx +val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml new file mode 100644 index 00000000..8411f464 --- /dev/null +++ b/src/jib/jib_compile.ml @@ -0,0 +1,1367 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Jib_util +open Type_check +open Value2 + +open Anf + +let opt_memo_cache = ref false + +(**************************************************************************) +(* 4. Conversion to low-level AST *) +(**************************************************************************) + +(** We now use a low-level AST called Jib (see language/bytecode.ott) + that is only slightly abstracted away from C. To be succint in + comments we usually refer to this as Sail IR or IR rather than + low-level AST repeatedly. + + The general idea is ANF expressions are converted into lists of + instructions (type instr) where allocations and deallocations are + now made explicit. ANF values (aval) are mapped to the cval type, + which is even simpler still. Some things are still more abstract + than in C, so the type definitions follow the sail type definition + structure, just with typ (from ast.ml) replaced with + ctyp. Top-level declarations that have no meaning for the backend + are not included at this level. + + The convention used here is that functions of the form compile_X + compile the type X into types in this AST, so compile_aval maps + avals into cvals. Note that the return types for these functions + are often quite complex, and they usually return some tuple + containing setup instructions (to allocate memory for the + expression), cleanup instructions (to deallocate that memory) and + possibly typing information about what has been translated. **) + +(* FIXME: This stage shouldn't care about this *) +let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1)) +let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1)) + +let rec is_bitvector = function + | [] -> true + | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals + | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals + | _ :: _ -> false + +let rec value_of_aval_bit = function + | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0 + | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1 + | _ -> assert false + +let is_ct_enum = function + | CT_enum _ -> true + | _ -> false + +let is_ct_variant = function + | CT_variant _ -> true + | _ -> false + +let is_ct_tup = function + | CT_tup _ -> true + | _ -> false + +let is_ct_list = function + | CT_list _ -> true + | _ -> false + +let is_ct_vector = function + | CT_vector _ -> true + | _ -> false + +let is_ct_struct = function + | CT_struct _ -> true + | _ -> false + +let is_ct_ref = function + | CT_ref _ -> true + | _ -> false + +let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty + +(** The context type contains two type-checking + environments. ctx.local_env contains the closest typechecking + environment, usually from the expression we are compiling, whereas + ctx.tc_env is the global type checking environment from + type-checking the entire AST. We also keep track of local variables + in ctx.locals, so we know when their type changes due to flow + typing. *) +type ctx = + { records : (ctyp Bindings.t) Bindings.t; + enums : IdSet.t Bindings.t; + variants : (ctyp Bindings.t) Bindings.t; + tc_env : Env.t; + local_env : Env.t; + locals : (mut * ctyp) Bindings.t; + letbinds : int list; + no_raw : bool; + convert_typ : ctx -> typ -> ctyp; + optimize_anf : ctx -> typ aexp -> typ aexp + } + +let initial_ctx ~convert_typ:convert_typ ~optimize_anf:optimize_anf env = + { records = Bindings.empty; + enums = Bindings.empty; + variants = Bindings.empty; + tc_env = env; + local_env = env; + locals = Bindings.empty; + letbinds = []; + no_raw = false; + convert_typ = convert_typ; + optimize_anf = optimize_anf + } + +let ctyp_of_typ ctx typ = ctx.convert_typ ctx typ + +let rec chunkify n xs = + match Util.take n xs, Util.drop n xs with + | xs, [] -> [xs] + | xs, ys -> xs :: chunkify n ys + +let rec compile_aval l ctx = function + | AV_C_fragment (frag, typ, ctyp) -> + let ctyp' = ctyp_of_typ ctx typ in + if not (ctyp_equal ctyp ctyp') then + raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp')); + [], (frag, ctyp_of_typ ctx typ), [] + + | AV_id (id, typ) -> + begin + try + let _, ctyp = Bindings.find id ctx.locals in + [], (F_id id, ctyp), [] + with + | Not_found -> + [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), [] + end + + | AV_ref (id, typ) -> + [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), [] + + | AV_lit (L_aux (L_string str, _), typ) -> + [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), [] + + | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) -> + let gs = gensym () in + [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)], + (F_id gs, CT_lint), + [iclear CT_lint gs] + + | AV_lit (L_aux (L_num n, _), typ) -> + let gs = gensym () in + [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)], + (F_id gs, CT_lint), + [iclear CT_lint gs] + + | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), [] + | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), [] + + | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), [] + | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), [] + + | AV_lit (L_aux (L_real str, _), _) -> + let gs = gensym () in + [iinit CT_real gs (F_lit (V_string str), CT_string)], + (F_id gs, CT_real), + [iclear CT_real gs] + + | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), [] + + | AV_lit (L_aux (_, l) as lit, _) -> + raise (Reporting.err_general l ("Encountered unexpected literal " ^ string_of_lit lit ^ " when converting ANF represention into IR")) + + | AV_tuple avals -> + let elements = List.map (compile_aval l ctx) avals in + let cvals = List.map (fun (_, cval, _) -> cval) elements in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in + let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in + let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in + let gs = gensym () in + setup + @ [idecl tup_ctyp gs] + @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals, + (F_id gs, CT_tup (List.map cval_ctyp cvals)), + [iclear tup_ctyp gs] + @ cleanup + + | AV_record (fields, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let gs = gensym () in + let compile_fields (id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] + @ field_cleanup + in + [idecl ctyp gs] + @ List.concat (List.map compile_fields (Bindings.bindings fields)), + (F_id gs, ctyp), + [iclear ctyp gs] + + | AV_vector ([], _) -> + raise (Reporting.err_general l "Encountered empty vector literal") + + (* Convert a small bitvector to a uint64_t literal. *) + | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 -> + begin + let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in + let len = List.length avals in + match destruct_vector ctx.tc_env typ with + | Some (_, Ord_aux (Ord_inc, _), _) -> + [], (bitstring, CT_fbits (len, false)), [] + | Some (_, Ord_aux (Ord_dec, _), _) -> + [], (bitstring, CT_fbits (len, true)), [] + | Some _ -> + raise (Reporting.err_general l "Encountered order polymorphic bitvector literal") + | None -> + raise (Reporting.err_general l "Encountered vector literal without vector type") + end + + (* Convert a bitvector literal that is larger than 64-bits to a + variable size bitvector, converting it in 64-bit chunks. *) + | AV_vector (avals, typ) when is_bitvector avals -> + let len = List.length avals in + let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in + let first_chunk = bitstring (Util.take (len mod 64) avals) in + let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in + let gs = gensym () in + [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))] + @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true)) + (mk_id "append_64") + [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks, + (F_id gs, CT_lbits true), + [iclear (CT_lbits true) gs] + + (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _)) + when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 -> + let len = List.length avals in + let direction = match ord with + | Ord_aux (Ord_inc, _) -> false + | Ord_aux (Ord_dec, _) -> true + | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found") + in + let gs = gensym () in + let ctyp = CT_fbits (len, direction) in + let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in + let aval_mask i aval = + let setup, cval, cleanup = compile_aval l ctx aval in + match cval with + | (F_lit (V_bit Sail2_values.B0), _) -> [] + | (F_lit (V_bit Sail2_values.B1), _) -> + [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] + | _ -> + setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup + in + [idecl ctyp gs; + icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)] + @ List.concat (List.mapi aval_mask (List.rev avals)), + (F_id gs, ctyp), + [] + + (* Compiling a vector literal that isn't a bitvector *) + | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _)) + when string_of_id id = "vector" -> + let len = List.length avals in + let direction = match ord with + | Ord_aux (Ord_inc, _) -> false + | Ord_aux (Ord_dec, _) -> true + | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found") + in + let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in + let gs = gensym () in + let aval_set i aval = + let setup, cval, cleanup = compile_aval l ctx aval in + setup + @ [iextern (CL_id (gs, vector_ctyp)) + (mk_id "internal_vector_update") + [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]] + @ cleanup + in + [idecl vector_ctyp gs; + iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]] + @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)), + (F_id gs, vector_ctyp), + [iclear vector_ctyp gs] + + | AV_vector _ as aval -> + raise (Reporting.err_general l ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type")) + + | AV_list (avals, Typ_aux (typ, _)) -> + let ctyp = match typ with + | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ + | _ -> raise (Reporting.err_general l "Invalid list type") + in + let gs = gensym () in + let mk_cons aval = + let setup, cval, cleanup = compile_aval l ctx aval in + setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup + in + [idecl (CT_list ctyp) gs] + @ List.concat (List.map mk_cons (List.rev avals)), + (F_id gs, CT_list ctyp), + [iclear (CT_list ctyp) gs] + +let compile_funcall l ctx id args typ = + let setup = ref [] in + let cleanup = ref [] in + + let quant, Typ_aux (fn_typ, _) = + (* If we can't find a function in local_env, fall back to the + global env - this happens when representing assertions, exit, + etc as functions in the IR. *) + try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env + in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + let final_ctyp = ctyp_of_typ ctx typ in + + let setup_arg ctyp aval = + let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in + setup := List.rev arg_setup @ !setup; + cleanup := arg_cleanup @ !cleanup; + let have_ctyp = cval_ctyp cval in + if is_polymorphic ctyp then + (F_poly (fst cval), have_ctyp) + else if ctyp_equal ctyp have_ctyp then + cval + else + let gs = gensym () in + setup := iinit ctyp gs cval :: !setup; + cleanup := iclear ctyp gs :: !cleanup; + (F_id gs, ctyp) + in + + assert (List.length arg_ctyps = List.length args); + + let setup_args = List.map2 setup_arg arg_ctyps args in + + List.rev !setup, + begin fun clexp -> + if ctyp_equal (clexp_ctyp clexp) ret_ctyp then + ifuncall clexp id setup_args + else + let gs = gensym () in + iblock [idecl ret_ctyp gs; + ifuncall (CL_id (gs, ret_ctyp)) id setup_args; + icopy l clexp (F_id gs, ret_ctyp); + iclear ret_ctyp gs] + end, + !cleanup + +let rec apat_ctyp ctx (AP_aux (apat, _, _)) = + match apat with + | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats) + | AP_global (_, typ) -> ctyp_of_typ ctx typ + | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat) + | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ + | AP_app (_, _, typ) -> ctyp_of_typ ctx typ + +let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label = + let ctx = { ctx with local_env = env } in + match apat_aux, cval with + | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env -> + [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label], + [], + ctx + + | AP_global (pid, typ), (frag, ctyp) -> + let global_ctyp = ctyp_of_typ ctx typ in + [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx + + | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp -> + begin match Env.lookup_id pid ctx.tc_env with + | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx + | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx + end + + | AP_id (pid, typ), _ -> + let ctyp = cval_ctyp cval in + let id_ctyp = ctyp_of_typ ctx typ in + let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in + [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx + + | AP_tup apats, (frag, ctyp) -> + begin + let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in + let fold (instrs, cleanup, n, ctx) apat ctyp = + let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in + instrs @ instrs', cleanup' @ cleanup, n + 1, ctx + in + match ctyp with + | CT_tup ctyps -> + let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in + instrs, cleanup, ctx + | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp) + end + + | AP_app (ctor, apat, variant_typ), (frag, ctyp) -> + begin match ctyp with + | CT_variant (_, ctors) -> + let ctor_c_id = string_of_id ctor in + let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in + (* These should really be the same, something has gone wrong if they are not. *) + if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then + raise (Reporting.err_general l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ)))) + else (); + let ctor_c_id, ctor_ctyp = + if is_polymorphic ctor_ctyp then + let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in + (if List.length unification > 0 then + ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification + else + ctor_c_id), + ctyp_suprema (apat_ctyp ctx apat) + else + ctor_c_id, ctor_ctyp + in + let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in + [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label] + @ instrs, + cleanup, + ctx + | ctyp -> + raise (Reporting.err_general l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s" + (string_of_id ctor) + (string_of_typ variant_typ) + (string_of_fragment ~zencode:false frag) + (string_of_ctyp ctyp))) + end + + | AP_wild _, _ -> [], [], ctx + + | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) -> + let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in + let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in + [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx + + | AP_cons _, (_, _) -> + raise (Reporting.err_general l "Tried to pattern match cons on non list type") + + | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx + +let unit_fragment = (F_lit V_unit, CT_unit) + +let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) = + let ctx = { ctx with local_env = env } in + match aexp_aux with + | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) -> + let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in + let setup, call, cleanup = compile_aexp ctx binding in + let letb_setup, letb_cleanup = + [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id] + in + let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in + let setup, call, cleanup = compile_aexp ctx body in + letb_setup @ setup, call, cleanup @ letb_cleanup + + | AE_app (id, vs, typ) -> + compile_funcall l ctx id vs typ + + | AE_val aval -> + let setup, cval, cleanup = compile_aval l ctx aval in + setup, (fun clexp -> icopy l clexp cval), cleanup + + (* Compile case statements *) + | AE_case (aval, cases, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in + let case_return_id = gensym () in + let finish_match_label = label "finish_match_" in + let compile_case (apat, guard, body) = + let trivial_guard = match guard with + | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true + | _ -> false + in + let case_label = label "case_" in + let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in + let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let case_instrs = + destructure @ [icomment "end destructuring"] + @ (if not trivial_guard then + guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup + @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit] + @ [icomment "end guard"] + else []) + @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup + @ [igoto finish_match_label] + in + if is_dead_aexp body then + [ilabel case_label] + else + [iblock case_instrs; ilabel case_label] + in + [icomment "begin match"] + @ aval_setup @ [idecl ctyp case_return_id] + @ List.concat (List.map compile_case cases) + @ [imatch_failure ()] + @ [ilabel finish_match_label], + (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)), + [iclear ctyp case_return_id] + @ aval_cleanup + @ [icomment "end match"] + + (* Compile try statement *) + | AE_try (aexp, cases, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in + let try_return_id = gensym () in + let handled_exception_label = label "handled_exception_" in + let fallthrough_label = label "fallthrough_exception_" in + let compile_case (apat, guard, body) = + let trivial_guard = match guard with + | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _) + | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true + | _ -> false + in + let try_label = label "try_" in + let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in + let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in + let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let case_instrs = + destructure @ [icomment "end destructuring"] + @ (if not trivial_guard then + guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup + @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label] + @ [icomment "end guard"] + else []) + @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup + @ [igoto handled_exception_label] + in + [iblock case_instrs; ilabel try_label] + in + assert (ctyp_equal ctyp (ctyp_of_typ ctx typ)); + [idecl ctyp try_return_id; + itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup); + ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label] + @ List.concat (List.map compile_case cases) + @ [igoto fallthrough_label; + ilabel handled_exception_label; + icopy l CL_have_exception (F_lit (V_bool false), CT_bool); + ilabel fallthrough_label], + (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)), + [] + + | AE_if (aval, then_aexp, else_aexp, if_typ) -> + if is_dead_aexp then_aexp then + compile_aexp ctx else_aexp + else if is_dead_aexp else_aexp then + compile_aexp ctx then_aexp + else + let if_ctyp = ctyp_of_typ ctx if_typ in + let compile_branch aexp = + let setup, call, cleanup = compile_aexp ctx aexp in + fun clexp -> setup @ [call clexp] @ cleanup + in + let setup, cval, cleanup = compile_aval l ctx aval in + setup, + (fun clexp -> iif cval + (compile_branch then_aexp clexp) + (compile_branch else_aexp clexp) + if_ctyp), + cleanup + + (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *) + | AE_record_update (aval, fields, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let ctors = match ctyp with + | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors + | _ -> raise (Reporting.err_general l "Cannot perform record update for non-record type") + in + let gs = gensym () in + let compile_fields (id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval] + @ field_cleanup + in + let setup, cval, cleanup = compile_aval l ctx aval in + [idecl ctyp gs] + @ setup + @ [icopy l (CL_id (gs, ctyp)) cval] + @ cleanup + @ List.concat (List.map compile_fields (Bindings.bindings fields)), + (fun clexp -> icopy l clexp (F_id gs, ctyp)), + [iclear ctyp gs] + + | AE_short_circuit (SC_and, aval, aexp) -> + let left_setup, cval, left_cleanup = compile_aval l ctx aval in + let right_setup, call, right_cleanup = compile_aexp ctx aexp in + let gs = gensym () in + left_setup + @ [ idecl CT_bool gs; + iif cval + (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) + [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)] + CT_bool ] + @ left_cleanup, + (fun clexp -> icopy l clexp (F_id gs, CT_bool)), + [] + | AE_short_circuit (SC_or, aval, aexp) -> + let left_setup, cval, left_cleanup = compile_aval l ctx aval in + let right_setup, call, right_cleanup = compile_aexp ctx aexp in + let gs = gensym () in + left_setup + @ [ idecl CT_bool gs; + iif cval + [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)] + (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup) + CT_bool ] + @ left_cleanup, + (fun clexp -> icopy l clexp (F_id gs, CT_bool)), + [] + + (* This is a faster assignment rule for updating fields of a + struct. *) + | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _)) + when Id.compare id rid = 0 -> + let compile_fields (field_id, aval) = + let field_setup, cval, field_cleanup = compile_aval l ctx aval in + field_setup + @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval] + @ field_cleanup + in + List.concat (List.map compile_fields (Bindings.bindings fields)), + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_assign (id, assign_typ, aexp) -> + let assign_ctyp = + match Bindings.find_opt id ctx.locals with + | Some (_, ctyp) -> ctyp + | None -> ctyp_of_typ ctx assign_typ + in + let setup, call, cleanup = compile_aexp ctx aexp in + setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup + + | AE_block (aexps, aexp, _) -> + let block = compile_block ctx aexps in + let setup, call, cleanup = compile_aexp ctx aexp in + block @ setup, call, cleanup + + | AE_loop (While, cond, body) -> + let loop_start_label = label "while_" in + let loop_end_label = label "wend_" in + let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let unit_gs = gensym () in + let loop_test = (F_unary ("!", F_id gs), CT_bool) in + [idecl CT_bool gs; idecl CT_unit unit_gs] + @ [ilabel loop_start_label] + @ [iblock (cond_setup + @ [cond_call (CL_id (gs, CT_bool))] + @ cond_cleanup + @ [ijump loop_test loop_end_label] + @ body_setup + @ [body_call (CL_id (unit_gs, CT_unit))] + @ body_cleanup + @ [igoto loop_start_label])] + @ [ilabel loop_end_label], + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_loop (Until, cond, body) -> + let loop_start_label = label "repeat_" in + let loop_end_label = label "until_" in + let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let gs = gensym () in + let unit_gs = gensym () in + let loop_test = (F_id gs, CT_bool) in + [idecl CT_bool gs; idecl CT_unit unit_gs] + @ [ilabel loop_start_label] + @ [iblock (body_setup + @ [body_call (CL_id (unit_gs, CT_unit))] + @ body_cleanup + @ cond_setup + @ [cond_call (CL_id (gs, CT_bool))] + @ cond_cleanup + @ [ijump loop_test loop_end_label] + @ [igoto loop_start_label])] + @ [ilabel loop_end_label], + (fun clexp -> icopy l clexp unit_fragment), + [] + + | AE_cast (aexp, typ) -> compile_aexp ctx aexp + + | AE_return (aval, typ) -> + let fn_return_ctyp = match Env.get_ret_typ env with + | Some typ -> ctyp_of_typ ctx typ + | None -> raise (Reporting.err_general l "No function return type found when compiling return statement") + in + (* Cleanup info will be re-added by fix_early_(heap/stack)_return *) + let return_setup, cval, _ = compile_aval l ctx aval in + let creturn = + if ctyp_equal fn_return_ctyp (cval_ctyp cval) then + [ireturn cval] + else + let gs = gensym () in + [idecl fn_return_ctyp gs; + icopy l (CL_id (gs, fn_return_ctyp)) cval; + ireturn (F_id gs, fn_return_ctyp)] + in + return_setup @ creturn, + (fun clexp -> icomment "unreachable after return"), + [] + + | AE_throw (aval, typ) -> + (* Cleanup info will be handled by fix_exceptions *) + let throw_setup, cval, _ = compile_aval l ctx aval in + throw_setup @ [ithrow cval], + (fun clexp -> icomment "unreachable after throw"), + [] + + | AE_field (aval, id, typ) -> + let ctyp = ctyp_of_typ ctx typ in + let setup, cval, cleanup = compile_aval l ctx aval in + setup, + (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)), + cleanup + + | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) -> + (* We assume that all loop indices are safe to put in a CT_fint. *) + let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in + + let is_inc = match ord with + | Ord_inc -> true + | Ord_dec -> false + | Ord_var _ -> raise (Reporting.err_general l "Polymorphic loop direction in C backend") + in + + (* Loop variables *) + let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in + let from_gs = gensym () in + let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in + let to_gs = gensym () in + let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in + let step_gs = gensym () in + let variable_init gs setup call cleanup = + [idecl (CT_fint 64) gs; + iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)] + in + + let loop_start_label = label "for_start_" in + let loop_end_label = label "for_end_" in + let body_setup, body_call, body_cleanup = compile_aexp ctx body in + let body_gs = gensym () in + + variable_init from_gs from_setup from_call from_cleanup + @ variable_init to_gs to_setup to_call to_cleanup + @ variable_init step_gs step_setup step_call step_cleanup + @ [iblock ([idecl (CT_fint 64) loop_var; + icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64)); + idecl CT_unit body_gs; + iblock ([ilabel loop_start_label] + @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label] + @ body_setup + @ [body_call (CL_id (body_gs, CT_unit))] + @ body_cleanup + @ [icopy l (CL_id (loop_var, (CT_fint 64))) + (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))] + @ [igoto loop_start_label]); + ilabel loop_end_label])], + (fun clexp -> icopy l clexp unit_fragment), + [] + +and compile_block ctx = function + | [] -> [] + | exp :: exps -> + let setup, call, cleanup = compile_aexp ctx exp in + let rest = compile_block ctx exps in + let gs = gensym () in + iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest + +(** Compile a sail type definition into a IR one. Most of the + actual work of translating the typedefs into C is done by the code + generator, as it's easy to keep track of structs, tuples and unions + in their sail form at this level, and leave the fiddly details of + how they get mapped to C in the next stage. This function also adds + details of the types it compiles to the context, ctx, which is why + it returns a ctypdef * ctx pair. **) +let compile_type_def ctx (TD_aux (type_def, (l, _))) = + match type_def with + | TD_enum (id, ids, _) -> + CTD_enum (id, ids), + { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums } + + | TD_record (id, _, ctors, _) -> + let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in + CTD_struct (id, Bindings.bindings ctors), + { ctx with records = Bindings.add id ctors ctx.records } + + | TD_variant (id, typq, tus, _) -> + let compile_tu = function + | Tu_aux (Tu_ty_id (typ, id), _) -> + let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in + ctyp_of_typ ctx typ, id + in + let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in + CTD_variant (id, Bindings.bindings ctus), + { ctx with variants = Bindings.add id ctus ctx.variants } + + (* Will be re-written before here, see bitfield.ml *) + | TD_bitfield _ -> + Reporting.unreachable l __POS__ "Cannot compile TD_bitfield" + + (* All type abbreviations are filtered out in compile_def *) + | TD_abbrev _ -> + Reporting.unreachable l __POS__ "Found TD_abbrev in compile_type_def" + +let generate_cleanup instrs = + let generate_cleanup' (I_aux (instr, _)) = + match instr with + | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)] + | I_decl (ctyp, id) -> [(id, iclear ctyp id)] + | instr -> [] + in + let is_clear ids = function + | I_aux (I_clear (_, id), _) -> IdSet.add id ids + | _ -> ids + in + let cleaned = List.fold_left is_clear IdSet.empty instrs in + instrs + |> List.map generate_cleanup' + |> List.concat + |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned)) + |> List.map snd + +let fix_exception_block ?return:(return=None) ctx instrs = + let end_block_label = label "end_block_exception_" in + let is_exception_stop (I_aux (instr, _)) = + match instr with + | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true + | _ -> false + in + (* In this function 'after' is instructions after the one we've + matched on, 'before is instructions before the instruction we've + matched with, but after the previous match, and 'historic' are + all the befores from previous matches. *) + let rec rewrite_exception historic instrs = + match instr_split_at is_exception_stop instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_exception (historic @ before) instrs)] + @ rewrite_exception (historic @ before) after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + let historic = historic @ before in + before + @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp] + @ rewrite_exception historic after + | before, I_aux (I_throw cval, (_, l)) :: after -> + before + @ [icopy l (CL_current_exception (cval_ctyp cval)) cval; + icopy l CL_have_exception (F_lit (V_bool true), CT_bool)] + @ generate_cleanup (historic @ before) + @ [igoto end_block_label] + @ rewrite_exception (historic @ before) after + | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after -> + let effects = match Env.get_val_spec f ctx.tc_env with + | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects + | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *) + | _ -> assert false (* valspec must have function type *) + in + if has_effect effects BE_escape then + before + @ [funcall; + iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit] + @ rewrite_exception (historic @ before) after + else + before @ funcall :: rewrite_exception (historic @ before) after + | _, _ -> assert false (* unreachable *) + in + match return with + | None -> + rewrite_exception [] instrs @ [ilabel end_block_label] + | Some ctyp -> + rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp] + +let rec map_try_block f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp) + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr + | I_block instrs -> I_block (List.map (map_try_block f) instrs) + | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs)) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ | I_end -> instr + in + I_aux (instr, aux) + +let fix_exception ?return:(return=None) ctx instrs = + let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in + fix_exception_block ~return:return ctx instrs + +let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp = + match p_aux with + | P_id id -> (id, ([], [])) + | P_wild -> let gs = gensym () in (gs, ([], [])) + | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], [])) + | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp + | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp + | _ -> + let apat = anf_pat pat in + let gs = gensym () in + let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in + (gs, (destructure, cleanup)) + +let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps = + match p_aux with + | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps + | P_tup pats when List.length pats = List.length ctyps -> + [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, [] + | _ when List.length ctyps = 1 -> + [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], [] + + | _ -> + let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in + let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in + destructure + @ [idecl (CT_tup ctyps) arg_id] + @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids, + List.map (fun (id, _) -> id, ([], [])) new_ids, + [iclear (CT_tup ctyps) arg_id] + @ cleanup + +let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs)) + +let fix_destructure fail_label = function + | ([], cleanup) -> ([], cleanup) + | destructure, cleanup -> + let body_label = label "fundef_body_" in + (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup) + +(** Functions that have heap-allocated return types are implemented by + passing a pointer a location where the return value should be + stored. The ANF -> Sail IR pass for expressions simply outputs an + I_return instruction for any return value, so this function walks + over the IR ast for expressions and modifies the return statements + into code that sets that pointer, as well as adds extra control + flow to cleanup heap-allocated variables correctly when a function + terminates early. See the generate_cleanup function for how this is + done. *) +let fix_early_return ret instrs = + let end_function_label = label "end_function_" in + let is_return_recur (I_aux (instr, _)) = + match instr with + | I_return _ | I_undefined _ | I_if _ | I_block _ -> true + | _ -> false + in + let rec rewrite_return historic instrs = + match instr_split_at is_return_recur instrs with + | instrs, [] -> instrs + | before, I_aux (I_block instrs, _) :: after -> + before + @ [iblock (rewrite_return (historic @ before) instrs)] + @ rewrite_return (historic @ before) after + | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after -> + let historic = historic @ before in + before + @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp] + @ rewrite_return historic after + | before, I_aux (I_return cval, (_, l)) :: after -> + let cleanup_label = label "cleanup_" in + let end_cleanup_label = label "end_cleanup_" in + before + @ [icopy l ret cval; + igoto cleanup_label] + (* This is probably dead code until cleanup_label, but we cannot be sure there are no jumps into it. *) + @ rewrite_return (historic @ before) after + @ [igoto end_cleanup_label; + ilabel cleanup_label] + @ generate_cleanup (historic @ before) + @ [igoto end_function_label; + ilabel end_cleanup_label] + | before, I_aux (I_undefined _, (_, l)) :: after -> + let cleanup_label = label "cleanup_" in + let end_cleanup_label = label "end_cleanup_" in + before + @ [igoto cleanup_label] + @ rewrite_return (historic @ before) after + @ [igoto end_cleanup_label; + ilabel cleanup_label] + @ generate_cleanup (historic @ before) + @ [igoto end_function_label; + ilabel end_cleanup_label] + | _, _ -> assert false + in + rewrite_return [] instrs + @ [ilabel end_function_label; iend ()] + +let letdef_count = ref 0 + +(** Compile a Sail toplevel definition into an IR definition **) +let rec compile_def n total ctx def = + match def with + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _)) + when !opt_memo_cache -> + let digest = + def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string + in + let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in + let cached = + if Sys.file_exists cachefile then + let in_chan = open_in cachefile in + try + let compiled = Marshal.from_channel in_chan in + close_in in_chan; + Some (compiled, ctx) + with + | _ -> close_in in_chan; None + else + None + in + begin match cached with + | Some (compiled, ctx) -> + Util.progress "Compiling " (string_of_id id) n total; + compiled, ctx + | None -> + let compiled, ctx = compile_def' n total ctx def in + let out_chan = open_out cachefile in + Marshal.to_channel out_chan compiled [Marshal.Closures]; + close_out out_chan; + compiled, ctx + end + + | _ -> compile_def' n total ctx def + +and compile_def' n total ctx = function + | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) -> + [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx + | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) -> + let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let setup, call, cleanup = compile_aexp ctx aexp in + let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in + [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx + + | DEF_reg_dec (DEC_aux (_, (l, _))) -> + raise (Reporting.err_general l "Cannot compile alias register declaration") + + | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) -> + let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in + let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in + [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx + + | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) -> + Util.progress "Compiling " (string_of_id id) n total; + + (* Find the function's type. *) + let quant, Typ_aux (fn_typ, _) = + try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env + in + let arg_typs, ret_typ = match fn_typ with + | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ + | _ -> assert false + in + + (* Handle the argument pattern. *) + let fundef_label = label "fundef_fail_" in + let orig_ctx = ctx in + (* The context must be updated before we call ctyp_of_typ on the argument types. *) + let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in + + let arg_ctyps = List.map (ctyp_of_typ ctx) arg_typs in + let ret_ctyp = ctyp_of_typ ctx ret_typ in + + (* Compile the function arguments as patterns. *) + let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in + let ctx = + (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *) + List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps + in + + (* Optimize and compile the expression to ANF. *) + let aexp = no_shadow (pat_ids pat) (anf exp) in + let aexp = ctx.optimize_anf ctx aexp in + + let setup, call, cleanup = compile_aexp ctx aexp in + let destructure, destructure_cleanup = + compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label + in + + let instrs = arg_setup @ destructure @ setup @ [call (CL_return ret_ctyp)] @ cleanup @ destructure_cleanup @ arg_cleanup in + let instrs = fix_early_return (CL_return ret_ctyp) instrs in + let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in + [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx + + | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) -> + raise (Reporting.err_general l "Encountered function with no clauses") + + | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) -> + raise (Reporting.err_general l "Encountered function with multiple clauses") + + (* All abbreviations should expanded by the typechecker, so we don't + need to translate type abbreviations into C typedefs. *) + | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx + + | DEF_type type_def -> + let tdef, ctx = compile_type_def ctx type_def in + [CDEF_type tdef], ctx + + | DEF_val (LB_aux (LB_val (pat, exp), _)) -> + let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in + let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in + let setup, call, cleanup = compile_aexp ctx aexp in + let apat = anf_pat ~global:true pat in + let gs = gensym () in + let end_label = label "let_end_" in + let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in + let gs_setup, gs_cleanup = + [idecl ctyp gs], [iclear ctyp gs] + in + let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in + let n = !letdef_count in + incr letdef_count; + let instrs = + gs_setup @ setup + @ [call (CL_id (gs, ctyp))] + @ cleanup + @ destructure + @ destructure_cleanup @ gs_cleanup + @ [ilabel end_label] + in + [CDEF_let (n, bindings, instrs)], + { ctx with letbinds = n :: ctx.letbinds } + + (* Only DEF_default that matters is default Order, but all order + polymorphism is specialised by this point. *) + | DEF_default _ -> [], ctx + + (* Overloading resolved by type checker *) + | DEF_overload _ -> [], ctx + + (* Only the parser and sail pretty printer care about this. *) + | DEF_fixity _ -> [], ctx + + (* We just ignore any pragmas we don't want to deal with. *) + | DEF_pragma _ -> [], ctx + + (* Termination measures only needed for Coq, and other theorem prover output *) + | DEF_measure _ -> [], ctx + + | DEF_internal_mutrec fundefs -> + let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in + List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs + + (* Scattereds and mapdefs should be removed by this point *) + | (DEF_scattered _ | DEF_mapdef _) as def -> + raise (Reporting.err_general Parse_ast.Unknown ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def))) + +let rec specialize_variants ctx prior = + let unifications = ref (Bindings.empty) in + + let fix_variant_ctyp var_id new_ctors = function + | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors) + | ctyp -> ctyp + in + + let specialize_constructor ctx ctor_id ctyp = + function + | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + (* Work out how each call to a constructor in instantiated and add that to unifications *) + let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in + let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in + unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications; + + (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *) + let casts = + let cast_to_suprema (frag, ctyp) = + let suprema = ctyp_suprema ctyp in + if ctyp_equal ctyp suprema then + [], (unpoly frag, ctyp), [] + else + let gs = gensym () in + [idecl suprema gs; + icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)], + (F_id gs, suprema), + [iclear suprema gs] + in + List.map cast_to_suprema [cval] + in + let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in + let cvals = List.map (fun (_, cval, _) -> cval) casts in + let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in + + let mk_funcall instr = + if List.length setup = 0 then + instr + else + iblock (setup @ [instr] @ cleanup) + in + + mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux)) + + | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 -> + Reporting.unreachable l __POS__ "Multiple argument constructor found" + + | instr -> instr + in + + function + | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs -> + let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in + + let cdefs = + List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs) + cdefs + polymorphic_ctors + in + + let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in + let specialized_ctors = Bindings.bindings !unifications in + let new_ctors = monomorphic_ctors @ specialized_ctors in + + let ctx = { + ctx with variants = Bindings.add var_id + (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors) + ctx.variants + } in + + let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in + let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in + specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs + + | cdef :: cdefs -> + let remove_poly (I_aux (instr, aux)) = + match instr with + | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp -> + I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux) + | instr -> I_aux (instr, aux) + in + let cdef = cdef_map_instr remove_poly cdef in + specialize_variants ctx (cdef :: prior) cdefs + + | [] -> List.rev prior, ctx + +(** Once we specialize variants, there may be additional type + dependencies which could be in the wrong order. As such we need to + sort the type definitions in the list of cdefs. *) +let sort_ctype_defs cdefs = + (* Split the cdefs into type definitions and non type definitions *) + let is_ctype_def = function CDEF_type _ -> true | _ -> false in + let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in + let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in + let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in + + let ctdef_id = function + | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id + in + + let ctdef_ids = function + | CTD_enum _ -> IdSet.empty + | CTD_struct (_, ctors) | CTD_variant (_, ctors) -> + List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors + in + + (* Create a reverse (i.e. from types to the types that are dependent + upon them) id graph of dependencies between types *) + let module IdGraph = Graph.Make(Id) in + + let graph = + List.fold_left (fun g ctdef -> + List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g) + (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *) + (IdSet.elements (ctdef_ids ctdef))) + IdGraph.empty + ctype_defs + in + + (* Then select the ctypes in the correct order as given by the topsort *) + let ids = IdGraph.topsort graph in + let ctype_defs = + List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids + in + + ctype_defs @ cdefs + +let compile_ast ctx (Defs defs) = + let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in + let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in + + let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in + + if !opt_memo_cache then + (try + if Sys.is_directory "_sbuild" then + () + else + raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!") + with + | Sys_error _ -> Unix.mkdir "_sbuild" 0o775) + else (); + + let total = List.length defs in + let _, chunks, ctx = + List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs + in + let cdefs = List.concat (List.rev chunks) in + let cdefs, ctx = specialize_variants ctx [] cdefs in + let cdefs = sort_ctype_defs cdefs in + cdefs, ctx diff --git a/src/jib/jib_compile.mli b/src/jib/jib_compile.mli new file mode 100644 index 00000000..50054149 --- /dev/null +++ b/src/jib/jib_compile.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Anf +open Ast +open Ast_util +open Jib +open Type_check + +(** Context for compiling Sail to Jib. We need to pass a (global) + typechecking environment given by checking the full AST. We have to + provide a conversion function from Sail types into Jib types, as + well as a function that optimizes ANF expressions (which can just + be the identity function) *) +type ctx = + { records : (ctyp Bindings.t) Bindings.t; + enums : IdSet.t Bindings.t; + variants : (ctyp Bindings.t) Bindings.t; + tc_env : Env.t; + local_env : Env.t; + locals : (mut * ctyp) Bindings.t; + letbinds : int list; + no_raw : bool; + convert_typ : ctx -> typ -> ctyp; + optimize_anf : ctx -> typ aexp -> typ aexp + } + +val initial_ctx : + convert_typ:(ctx -> typ -> ctyp) -> + optimize_anf:(ctx -> typ aexp -> typ aexp) -> + Env.t -> + ctx + +(** Compile a Sail definition into a Jib definition. The first two + arguments are is the current definition number and the total number + of definitions, and can be used to drive a progress bar (see + Util.progress). *) +val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx + +val compile_ast : ctx -> tannot defs -> cdef list * ctx diff --git a/src/jib/jib_util.ml b/src/jib/jib_util.ml new file mode 100644 index 00000000..d9c6a541 --- /dev/null +++ b/src/jib/jib_util.ml @@ -0,0 +1,935 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Ast_util +open Jib +open Value2 +open PPrint + +(* Define wrappers for creating bytecode instructions. Each function + uses a counter to assign each instruction a unique identifier. *) + +let instr_counter = ref 0 + +let instr_number () = + let n = !instr_counter in + incr instr_counter; + n + +let idecl ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_decl (ctyp, id), (instr_number (), l)) + +let ireset ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_reset (ctyp, id), (instr_number (), l)) + +let iinit ?loc:(l=Parse_ast.Unknown) ctyp id cval = + I_aux (I_init (ctyp, id, cval), (instr_number (), l)) + +let iif ?loc:(l=Parse_ast.Unknown) cval then_instrs else_instrs ctyp = + I_aux (I_if (cval, then_instrs, else_instrs, ctyp), (instr_number (), l)) + +let ifuncall ?loc:(l=Parse_ast.Unknown) clexp id cvals = + I_aux (I_funcall (clexp, false, id, cvals), (instr_number (), l)) + +let iextern ?loc:(l=Parse_ast.Unknown) clexp id cvals = + I_aux (I_funcall (clexp, true, id, cvals), (instr_number (), l)) + +let icopy l clexp cval = + I_aux (I_copy (clexp, cval), (instr_number (), l)) + +let ialias l clexp cval = + I_aux (I_alias (clexp, cval), (instr_number (), l)) + +let iclear ?loc:(l=Parse_ast.Unknown) ctyp id = + I_aux (I_clear (ctyp, id), (instr_number (), l)) + +let ireturn ?loc:(l=Parse_ast.Unknown) cval = + I_aux (I_return cval, (instr_number (), l)) + +let iend ?loc:(l=Parse_ast.Unknown) () = + I_aux (I_end, (instr_number (), l)) + +let iblock ?loc:(l=Parse_ast.Unknown) instrs = + I_aux (I_block instrs, (instr_number (), l)) + +let itry_block ?loc:(l=Parse_ast.Unknown) instrs = + I_aux (I_try_block instrs, (instr_number (), l)) + +let ithrow ?loc:(l=Parse_ast.Unknown) cval = + I_aux (I_throw cval, (instr_number (), l)) +let icomment ?loc:(l=Parse_ast.Unknown) str = + I_aux (I_comment str, (instr_number (), l)) + +let ilabel ?loc:(l=Parse_ast.Unknown) label = + I_aux (I_label label, (instr_number (), l)) +let igoto ?loc:(l=Parse_ast.Unknown) label = + I_aux (I_goto label, (instr_number (), l)) + +let iundefined ?loc:(l=Parse_ast.Unknown) ctyp = + I_aux (I_undefined ctyp, (instr_number (), l)) + +let imatch_failure ?loc:(l=Parse_ast.Unknown) () = + I_aux (I_match_failure, (instr_number (), l)) + +let iraw ?loc:(l=Parse_ast.Unknown) str = + I_aux (I_raw str, (instr_number (), l)) + +let ijump ?loc:(l=Parse_ast.Unknown) cval label = + I_aux (I_jump (cval, label), (instr_number (), l)) + +let rec frag_rename from_id to_id = function + | F_id id when Id.compare id from_id = 0 -> F_id to_id + | F_id id -> F_id id + | F_ref id when Id.compare id from_id = 0 -> F_ref to_id + | F_ref id -> F_ref id + | F_lit v -> F_lit v + | F_have_exception -> F_have_exception + | F_current_exception -> F_current_exception + | F_call (call, frags) -> F_call (call, List.map (frag_rename from_id to_id) frags) + | F_op (f1, op, f2) -> F_op (frag_rename from_id to_id f1, op, frag_rename from_id to_id f2) + | F_unary (op, f) -> F_unary (op, frag_rename from_id to_id f) + | F_field (f, field) -> F_field (frag_rename from_id to_id f, field) + | F_raw raw -> F_raw raw + | F_poly f -> F_poly (frag_rename from_id to_id f) + +let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp) + +let rec clexp_rename from_id to_id = function + | CL_id (id, ctyp) when Id.compare id from_id = 0 -> CL_id (to_id, ctyp) + | CL_id (id, ctyp) -> CL_id (id, ctyp) + | CL_field (clexp, field) -> + CL_field (clexp_rename from_id to_id clexp, field) + | CL_addr clexp -> + CL_addr (clexp_rename from_id to_id clexp) + | CL_tuple (clexp, n) -> + CL_tuple (clexp_rename from_id to_id clexp, n) + | CL_current_exception ctyp -> CL_current_exception ctyp + | CL_have_exception -> CL_have_exception + | CL_return ctyp -> CL_return ctyp + +let rec instr_rename from_id to_id (I_aux (instr, aux)) = + let instr = match instr with + | I_decl (ctyp, id) when Id.compare id from_id = 0 -> I_decl (ctyp, to_id) + | I_decl (ctyp, id) -> I_decl (ctyp, id) + + | I_init (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_init (ctyp, to_id, cval_rename from_id to_id cval) + | I_init (ctyp, id, cval) -> + I_init (ctyp, id, cval_rename from_id to_id cval) + + | I_if (cval, then_instrs, else_instrs, ctyp2) -> + I_if (cval_rename from_id to_id cval, + List.map (instr_rename from_id to_id) then_instrs, + List.map (instr_rename from_id to_id) else_instrs, + ctyp2) + + | I_jump (cval, label) -> I_jump (cval_rename from_id to_id cval, label) + + | I_funcall (clexp, extern, id, args) -> + I_funcall (clexp_rename from_id to_id clexp, extern, id, List.map (cval_rename from_id to_id) args) + + | I_copy (clexp, cval) -> I_copy (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + | I_alias (clexp, cval) -> I_alias (clexp_rename from_id to_id clexp, cval_rename from_id to_id cval) + + | I_clear (ctyp, id) when Id.compare id from_id = 0 -> I_clear (ctyp, to_id) + | I_clear (ctyp, id) -> I_clear (ctyp, id) + + | I_return cval -> I_return (cval_rename from_id to_id cval) + + | I_block instrs -> I_block (List.map (instr_rename from_id to_id) instrs) + + | I_try_block instrs -> I_try_block (List.map (instr_rename from_id to_id) instrs) + + | I_throw cval -> I_throw (cval_rename from_id to_id cval) + + | I_comment str -> I_comment str + + | I_raw str -> I_raw str + + | I_label label -> I_label label + + | I_goto label -> I_goto label + + | I_undefined ctyp -> I_undefined ctyp + + | I_match_failure -> I_match_failure + + | I_end -> I_end + + | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id) + | I_reset (ctyp, id) -> I_reset (ctyp, id) + + | I_reinit (ctyp, id, cval) when Id.compare id from_id = 0 -> + I_reinit (ctyp, to_id, cval_rename from_id to_id cval) + | I_reinit (ctyp, id, cval) -> + I_reinit (ctyp, id, cval_rename from_id to_id cval) + in + I_aux (instr, aux) + +(**************************************************************************) +(* 1. Instruction pretty printer *) +(**************************************************************************) + +let string_of_value = function + | V_bits [] -> "UINT64_C(0)" + | V_bits bs -> "UINT64_C(" ^ Sail2_values.show_bitlist bs ^ ")" + | V_int i -> Big_int.to_string i ^ "l" + | V_bool true -> "true" + | V_bool false -> "false" + | V_null -> "NULL" + | V_unit -> "UNIT" + | V_bit Sail2_values.B0 -> "UINT64_C(0)" + | V_bit Sail2_values.B1 -> "UINT64_C(1)" + | V_string str -> "\"" ^ str ^ "\"" + | V_ctor_kind str -> "Kind_" ^ Util.zencode_string str + | _ -> failwith "Cannot convert value to string" + +let rec string_of_fragment ?zencode:(zencode=true) = function + | F_id id when zencode -> Util.zencode_string (string_of_id id) + | F_id id -> string_of_id id + | F_ref id when zencode -> "&" ^ Util.zencode_string (string_of_id id) + | F_ref id -> "&" ^ string_of_id id + | F_lit v -> string_of_value v + | F_call (str, frags) -> + Printf.sprintf "%s(%s)" str (Util.string_of_list ", " (string_of_fragment ~zencode:zencode) frags) + | F_field (f, field) -> + Printf.sprintf "%s.%s" (string_of_fragment' ~zencode:zencode f) field + | F_op (f1, op, f2) -> + Printf.sprintf "%s %s %s" (string_of_fragment' ~zencode:zencode f1) op (string_of_fragment' ~zencode:zencode f2) + | F_unary (op, f) -> + op ^ string_of_fragment' ~zencode:zencode f + | F_have_exception -> "have_exception" + | F_current_exception -> "(*current_exception)" + | F_raw raw -> raw + | F_poly f -> string_of_fragment ~zencode:zencode f +and string_of_fragment' ?zencode:(zencode=true) f = + match f with + | F_op _ | F_unary _ -> "(" ^ string_of_fragment ~zencode:zencode f ^ ")" + | _ -> string_of_fragment ~zencode:zencode f + +(* String representation of ctyps here is only for debugging and + intermediate language pretty-printer. *) +and string_of_ctyp = function + | CT_lint -> "int" + | CT_lbits true -> "lbits(dec)" + | CT_lbits false -> "lbits(inc)" + | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)" + | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)" + | CT_sbits (n, true) -> "sbits(" ^ string_of_int n ^ ", dec)" + | CT_sbits (n, false) -> "sbits(" ^ string_of_int n ^ ", inc)" + | CT_fint n -> "int(" ^ string_of_int n ^ ")" + | CT_bit -> "bit" + | CT_unit -> "unit" + | CT_bool -> "bool" + | CT_real -> "real" + | CT_tup ctyps -> "(" ^ Util.string_of_list ", " string_of_ctyp ctyps ^ ")" + | CT_struct (id, _) | CT_enum (id, _) | CT_variant (id, _) -> string_of_id id + | CT_string -> "string" + | CT_vector (true, ctyp) -> "vector(dec, " ^ string_of_ctyp ctyp ^ ")" + | CT_vector (false, ctyp) -> "vector(inc, " ^ string_of_ctyp ctyp ^ ")" + | CT_list ctyp -> "list(" ^ string_of_ctyp ctyp ^ ")" + | CT_ref ctyp -> "ref(" ^ string_of_ctyp ctyp ^ ")" + | CT_poly -> "*" + +(** This function is like string_of_ctyp, but recursively prints all + constructors in variants and structs. Used for debug output. *) +and full_string_of_ctyp = function + | CT_tup ctyps -> "(" ^ Util.string_of_list ", " full_string_of_ctyp ctyps ^ ")" + | CT_struct (id, ctors) | CT_variant (id, ctors) -> + "struct " ^ string_of_id id + ^ "{ " + ^ Util.string_of_list ", " (fun (id, ctyp) -> string_of_id id ^ " : " ^ full_string_of_ctyp ctyp) ctors + ^ "}" + | CT_vector (true, ctyp) -> "vector(dec, " ^ full_string_of_ctyp ctyp ^ ")" + | CT_vector (false, ctyp) -> "vector(inc, " ^ full_string_of_ctyp ctyp ^ ")" + | CT_list ctyp -> "list(" ^ full_string_of_ctyp ctyp ^ ")" + | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")" + | ctyp -> string_of_ctyp ctyp + +let rec map_ctyp f = function + | (CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ + | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp + | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps)) + | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp)) + | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp)) + | CT_list ctyp -> f (CT_list (map_ctyp f ctyp)) + | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) + | CT_variant (id, ctors) -> f (CT_variant (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors)) + +let rec ctyp_equal ctyp1 ctyp2 = + match ctyp1, ctyp2 with + | CT_lint, CT_lint -> true + | CT_lbits d1, CT_lbits d2 -> d1 = d2 + | CT_sbits (m1, d1), CT_sbits (m2, d2) -> m1 = m2 && d1 = d2 + | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2 + | CT_bit, CT_bit -> true + | CT_fint n, CT_fint m -> n = m + | CT_unit, CT_unit -> true + | CT_bool, CT_bool -> true + | CT_struct (id1, _), CT_struct (id2, _) -> Id.compare id1 id2 = 0 + | CT_enum (id1, _), CT_enum (id2, _) -> Id.compare id1 id2 = 0 + | CT_variant (id1, _), CT_variant (id2, _) -> Id.compare id1 id2 = 0 + | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> + List.for_all2 ctyp_equal ctyps1 ctyps2 + | CT_string, CT_string -> true + | CT_real, CT_real -> true + | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> d1 = d2 && ctyp_equal ctyp1 ctyp2 + | CT_list ctyp1, CT_list ctyp2 -> ctyp_equal ctyp1 ctyp2 + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_equal ctyp1 ctyp2 + | CT_poly, CT_poly -> true + | _, _ -> false + +let rec ctyp_compare ctyp1 ctyp2 = + let lex_ord c1 c2 = if c1 = 0 then c2 else c1 in + match ctyp1, ctyp2 with + | CT_lint, CT_lint -> 0 + | CT_lint, _ -> 1 + | _, CT_lint -> -1 + + | CT_fint n, CT_fint m -> compare n m + | CT_fint _, _ -> 1 + | _, CT_fint _ -> -1 + + | CT_fbits (n, ord1), CT_fbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2) + | CT_fbits _, _ -> 1 + | _, CT_fbits _ -> -1 + + | CT_sbits (n, ord1), CT_sbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2) + | CT_sbits _, _ -> 1 + | _, CT_sbits _ -> -1 + + | CT_lbits ord1 , CT_lbits ord2 -> compare ord1 ord2 + | CT_lbits _, _ -> 1 + | _, CT_lbits _ -> -1 + + | CT_bit, CT_bit -> 0 + | CT_bit, _ -> 1 + | _, CT_bit -> -1 + + | CT_unit, CT_unit -> 0 + | CT_unit, _ -> 1 + | _, CT_unit -> -1 + + | CT_real, CT_real -> 0 + | CT_real, _ -> 1 + | _, CT_real -> -1 + + | CT_poly, CT_poly -> 0 + | CT_poly, _ -> 1 + | _, CT_poly -> -1 + + | CT_bool, CT_bool -> 0 + | CT_bool, _ -> 1 + | _, CT_bool -> -1 + + | CT_string, CT_string -> 0 + | CT_string, _ -> 1 + | _, CT_string -> -1 + + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_compare ctyp1 ctyp2 + | CT_ref _, _ -> 1 + | _, CT_ref _ -> -1 + + | CT_list ctyp1, CT_list ctyp2 -> ctyp_compare ctyp1 ctyp2 + | CT_list _, _ -> 1 + | _, CT_list _ -> -1 + + | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) -> + lex_ord (ctyp_compare ctyp1 ctyp2) (compare d1 d2) + | CT_vector _, _ -> 1 + | _, CT_vector _ -> -1 + + | ctyp1, ctyp2 -> String.compare (full_string_of_ctyp ctyp1) (full_string_of_ctyp ctyp2) + +module CT = struct + type t = ctyp + let compare ctyp1 ctyp2 = ctyp_compare ctyp1 ctyp2 +end + +module CTSet = Set.Make(CT) + +let rec ctyp_unify ctyp1 ctyp2 = + match ctyp1, ctyp2 with + | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 -> + List.concat (List.map2 ctyp_unify ctyps1 ctyps2) + + | CT_vector (b1, ctyp1), CT_vector (b2, ctyp2) when b1 = b2 -> + ctyp_unify ctyp1 ctyp2 + + | CT_list ctyp1, CT_list ctyp2 -> ctyp_unify ctyp1 ctyp2 + + | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_unify ctyp1 ctyp2 + + | CT_poly, _ -> [ctyp2] + + | _, _ when ctyp_equal ctyp1 ctyp2 -> [] + | _, _ -> raise (Invalid_argument "ctyp_unify") + +let rec ctyp_suprema = function + | CT_lint -> CT_lint + | CT_lbits d -> CT_lbits d + | CT_fbits (_, d) -> CT_lbits d + | CT_sbits (_, d) -> CT_lbits d + | CT_fint _ -> CT_lint + | CT_unit -> CT_unit + | CT_bool -> CT_bool + | CT_real -> CT_real + | CT_bit -> CT_bit + | CT_tup ctyps -> CT_tup (List.map ctyp_suprema ctyps) + | CT_string -> CT_string + | CT_enum (id, ids) -> CT_enum (id, ids) + (* Do we really never want to never call ctyp_suprema on constructor + fields? Doing it causes issues for structs (see + test/c/stack_struct.sail) but it might be wrong to not call it + for nested variants... *) + | CT_struct (id, ctors) -> CT_struct (id, ctors) + | CT_variant (id, ctors) -> CT_variant (id, ctors) + | CT_vector (d, ctyp) -> CT_vector (d, ctyp_suprema ctyp) + | CT_list ctyp -> CT_list (ctyp_suprema ctyp) + | CT_ref ctyp -> CT_ref (ctyp_suprema ctyp) + | CT_poly -> CT_poly + +let rec ctyp_ids = function + | CT_enum (id, _) -> IdSet.singleton id + | CT_struct (id, ctors) | CT_variant (id, ctors) -> + IdSet.add id (List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors) + | CT_tup ctyps -> List.fold_left (fun ids ctyp -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctyps + | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> ctyp_ids ctyp + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_unit + | CT_bool | CT_real | CT_bit | CT_string | CT_poly -> IdSet.empty + +let rec unpoly = function + | F_poly f -> unpoly f + | F_call (call, fs) -> F_call (call, List.map unpoly fs) + | F_field (f, field) -> F_field (unpoly f, field) + | F_op (f1, op, f2) -> F_op (unpoly f1, op, unpoly f2) + | F_unary (op, f) -> F_unary (op, unpoly f) + | f -> f + +let rec is_polymorphic = function + | CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string -> false + | CT_tup ctyps -> List.exists is_polymorphic ctyps + | CT_enum _ -> false + | CT_struct (_, ctors) | CT_variant (_, ctors) -> List.exists (fun (_, ctyp) -> is_polymorphic ctyp) ctors + | CT_vector (_, ctyp) | CT_list ctyp | CT_ref ctyp -> is_polymorphic ctyp + | CT_poly -> true + +let pp_id id = + string (string_of_id id) + +let pp_ctyp ctyp = + string (string_of_ctyp ctyp |> Util.yellow |> Util.clear) + +let pp_keyword str = + string ((str |> Util.red |> Util.clear) ^ " ") + +let pp_cval (frag, ctyp) = + string (string_of_fragment ~zencode:false frag) ^^ string " : " ^^ pp_ctyp ctyp + +let rec pp_clexp = function + | CL_id (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | CL_field (clexp, field) -> parens (pp_clexp clexp) ^^ string "." ^^ string field + | CL_tuple (clexp, n) -> parens (pp_clexp clexp) ^^ string "." ^^ string (string_of_int n) + | CL_addr clexp -> string "*" ^^ pp_clexp clexp + | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp + | CL_have_exception -> string "have_exception" + | CL_return ctyp -> string "return : " ^^ pp_ctyp ctyp + +let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) = + match instr with + | I_decl (ctyp, id) -> + pp_keyword "var" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_if (cval, then_instrs, else_instrs, ctyp) -> + let pp_if_block = function + | [] -> string "{}" + | instrs -> surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + in + parens (pp_ctyp ctyp) ^^ space + ^^ pp_keyword "if" ^^ pp_cval cval + ^^ if short then + empty + else + pp_keyword " then" ^^ pp_if_block then_instrs + ^^ pp_keyword " else" ^^ pp_if_block else_instrs + | I_jump (cval, label) -> + pp_keyword "jump" ^^ pp_cval cval ^^ space ^^ string (label |> Util.blue |> Util.clear) + | I_block instrs -> + surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + | I_try_block instrs -> + pp_keyword "try" ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + | I_reset (ctyp, id) -> + pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_init (ctyp, id, cval) -> + pp_keyword "create" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval + | I_reinit (ctyp, id, cval) -> + pp_keyword "recreate" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ string " = " ^^ pp_cval cval + | I_funcall (x, _, f, args) -> + separate space [ pp_clexp x; string "="; + string (string_of_id f |> Util.green |> Util.clear) ^^ parens (separate_map (string ", ") pp_cval args) ] + | I_copy (clexp, cval) -> + separate space [pp_clexp clexp; string "="; pp_cval cval] + | I_alias (clexp, cval) -> + pp_keyword "alias" ^^ separate space [pp_clexp clexp; string "="; pp_cval cval] + | I_clear (ctyp, id) -> + pp_keyword "kill" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp + | I_return cval -> + pp_keyword "return" ^^ pp_cval cval + | I_throw cval -> + pp_keyword "throw" ^^ pp_cval cval + | I_comment str -> + string ("// " ^ str |> Util.magenta |> Util.clear) + | I_label str -> + string (str |> Util.blue |> Util.clear) ^^ string ":" + | I_goto str -> + pp_keyword "goto" ^^ string (str |> Util.blue |> Util.clear) + | I_match_failure -> + pp_keyword "match_failure" + | I_end -> + pp_keyword "end" + | I_undefined ctyp -> + pp_keyword "undefined" ^^ pp_ctyp ctyp + | I_raw str -> + pp_keyword "C" ^^ string (str |> Util.cyan |> Util.clear) + +let pp_ctype_def = function + | CTD_enum (id, ids) -> + pp_keyword "enum" ^^ pp_id id ^^ string " = " + ^^ separate_map (string " | ") pp_id ids + | CTD_struct (id, fields) -> + pp_keyword "struct" ^^ pp_id id ^^ string " = " + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) fields) rbrace + | CTD_variant (id, ctors) -> + pp_keyword "union" ^^ pp_id id ^^ string " = " + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) (fun (id, ctyp) -> pp_id id ^^ string " : " ^^ pp_ctyp ctyp) ctors) rbrace + +let pp_cdef = function + | CDEF_spec (id, ctyps, ctyp) -> + pp_keyword "val" ^^ pp_id id ^^ string " : " ^^ parens (separate_map (comma ^^ space) pp_ctyp ctyps) ^^ string " -> " ^^ pp_ctyp ctyp + ^^ hardline + | CDEF_fundef (id, ret, args, instrs) -> + let ret = match ret with + | None -> empty + | Some id -> space ^^ pp_id id + in + pp_keyword "function" ^^ pp_id id ^^ ret ^^ parens (separate_map (comma ^^ space) pp_id args) ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_reg_dec (id, ctyp, instrs) -> + pp_keyword "register" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_type tdef -> pp_ctype_def tdef ^^ hardline + | CDEF_let (n, bindings, instrs) -> + let pp_binding (id, ctyp) = pp_id id ^^ string " : " ^^ pp_ctyp ctyp in + pp_keyword "let" ^^ string (string_of_int n) ^^ parens (separate_map (comma ^^ space) pp_binding bindings) ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace ^^ space + ^^ hardline + | CDEF_startup (id, instrs)-> + pp_keyword "startup" ^^ pp_id id ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + | CDEF_finish (id, instrs)-> + pp_keyword "finish" ^^ pp_id id ^^ space + ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace + ^^ hardline + +(**************************************************************************) +(* 2. Dependency Graphs *) +(**************************************************************************) + +type graph_node = + | G_label of string + | G_instr of int * instr + | G_start + +let string_of_node = function + | G_label label -> label + | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr) + | G_start -> "START" + +module Node = struct + type t = graph_node + let compare gn1 gn2 = + match gn1, gn2 with + | G_label str1, G_label str2 -> String.compare str1 str2 + | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2 + | G_start , G_start -> 0 + | G_start , _ -> 1 + | _ , G_start -> -1 + | G_instr _, _ -> 1 + | _ , G_instr _ -> -1 +end + +module NodeGraph = Graph.Make(Node) + +module NM = Map.Make(Node) +module NS = Set.Make(Node) + +type dep_graph = NodeGraph.graph + +let rec fragment_deps = function + | F_id id | F_ref id -> IdSet.singleton id + | F_lit _ -> IdSet.empty + | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag + | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags) + | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2) + | F_current_exception -> IdSet.empty + | F_have_exception -> IdSet.empty + | F_raw _ -> IdSet.empty + +let cval_deps = function (frag, _) -> fragment_deps frag + +let rec clexp_deps = function + | CL_id (id, _) -> IdSet.singleton id + | CL_field (clexp, _) -> clexp_deps clexp + | CL_tuple (clexp, _) -> clexp_deps clexp + | CL_addr clexp -> clexp_deps clexp + | CL_have_exception -> IdSet.empty + | CL_current_exception _ -> IdSet.empty + | CL_return _ -> IdSet.empty + +(* Return the direct, read/write dependencies of a single instruction *) +let instr_deps = function + | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id + | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id + | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty + | I_jump (cval, label) -> cval_deps cval, IdSet.empty + | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp + | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp + | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp + | I_clear (_, id) -> IdSet.singleton id, IdSet.singleton id + | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty + | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty + | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty + | I_label label -> IdSet.empty, IdSet.empty + | I_goto label -> IdSet.empty, IdSet.empty + | I_undefined _ -> IdSet.empty, IdSet.empty + | I_match_failure -> IdSet.empty, IdSet.empty + | I_end -> IdSet.empty, IdSet.empty + +(* instrs_graph returns the control-flow graph for a list of + instructions. *) +let instrs_graph instrs = + let icounter = ref 0 in + let graph = ref NodeGraph.empty in + + let rec add_instr last_instrs (I_aux (instr, _) as iaux) = + incr icounter; + let node = G_instr (!icounter, iaux) in + match instr with + | I_block instrs | I_try_block instrs -> + List.fold_left add_instr last_instrs instrs + | I_if (_, then_instrs, else_instrs, _) -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + let n1 = List.fold_left add_instr [node] then_instrs in + let n2 = List.fold_left add_instr [node] else_instrs in + incr icounter; + let join = G_instr (!icounter, icomment "join") in + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n1; + List.iter (fun i -> graph := NodeGraph.add_edge' i join !graph) n2; + [join] + | I_return _ -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] + | I_label label -> + graph := NodeGraph.add_edge' (G_label label) node !graph; + node :: last_instrs + | I_goto label -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edge' node (G_label label) !graph; + [] + | I_jump (cval, label) -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + graph := NodeGraph.add_edges' (G_label label) [] !graph; + [node] + | I_match_failure -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [] + | _ -> + List.iter (fun i -> graph := NodeGraph.add_edge' i node !graph) last_instrs; + [node] + in + ignore (List.fold_left add_instr [G_start] instrs); + let graph = NodeGraph.fix_leaves !graph in + graph + +let make_dot id graph = + Util.opt_colors := false; + let to_string node = String.escaped (string_of_node node) in + let node_color = function + | G_start -> "lightpink" + | G_instr (_, I_aux (I_decl _, _)) -> "olivedrab1" + | G_instr (_, I_aux (I_init _, _)) -> "springgreen" + | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff" + | G_instr (_, I_aux (I_goto _, _)) -> "orange1" + | G_instr (_, I_aux (I_label _, _)) -> "white" + | G_instr (_, I_aux (I_raw _, _)) -> "khaki" + | G_instr (_, I_aux (I_return _, _)) -> "deeppink" + | G_instr (_, I_aux (I_undefined _, _)) -> "deeppink" + | G_instr _ -> "azure" + | G_label _ -> "lightpink" + in + let edge_color from_node to_node = + match from_node, to_node with + | G_start , _ -> "goldenrod4" + | G_label _, _ -> "darkgreen" + | _ , G_label _ -> "goldenrod4" + | G_instr _, G_instr _ -> "black" + | _ , _ -> "coral3" + in + let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in + NodeGraph.make_dot node_color edge_color to_string out_chan graph; + close_out out_chan + +let rec map_clexp_ctyp f = function + | CL_id (id, ctyp) -> CL_id (id, f ctyp) + | CL_field (clexp, field) -> CL_field (map_clexp_ctyp f clexp, field) + | CL_tuple (clexp, n) -> CL_tuple (map_clexp_ctyp f clexp, n) + | CL_addr clexp -> CL_addr (map_clexp_ctyp f clexp) + | CL_current_exception ctyp -> CL_current_exception (f ctyp) + | CL_have_exception -> CL_have_exception + | CL_return ctyp -> CL_return (f ctyp) + +let rec map_instr_ctyp f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl (ctyp, id) -> I_decl (f ctyp, id) + | I_init (ctyp1, id, (frag, ctyp2)) -> I_init (f ctyp1, id, (frag, f ctyp2)) + | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) -> + I_if ((frag, f ctyp1), List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs, f ctyp2) + | I_jump ((frag, ctyp), label) -> I_jump ((frag, f ctyp), label) + | I_funcall (clexp, extern, id, cvals) -> + I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals) + | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp)) + | I_alias (clexp, (frag, ctyp)) -> I_alias (map_clexp_ctyp f clexp, (frag, f ctyp)) + | I_clear (ctyp, id) -> I_clear (f ctyp, id) + | I_return (frag, ctyp) -> I_return (frag, f ctyp) + | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs) + | I_try_block instrs -> I_try_block (List.map (map_instr_ctyp f) instrs) + | I_throw (frag, ctyp) -> I_throw (frag, f ctyp) + | I_undefined ctyp -> I_undefined (f ctyp) + | I_reset (ctyp, id) -> I_reset (f ctyp, id) + | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2)) + | I_end -> I_end + | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr + in + I_aux (instr, aux) + +(** Map over each instruction within an instruction, bottom-up *) +let rec map_instr f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_init _ | I_reset _ | I_reinit _ + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp) + | I_block instrs -> + I_block (List.map (map_instr f) instrs) + | I_try_block instrs -> + I_try_block (List.map (map_instr f) instrs) + in + f (I_aux (instr, aux)) + +(** Map over each instruction in a cdef using map_instr *) +let cdef_map_instr f = function + | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs) + | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr f) instrs) + | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr f) instrs) + | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr f) instrs) + | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr f) instrs) + | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp) + | CDEF_type tdef -> CDEF_type tdef + +let ctype_def_map_ctyp f = function + | CTD_enum (id, ids) -> CTD_enum (id, ids) + | CTD_struct (id, ctors) -> CTD_struct (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) + | CTD_variant (id, ctors) -> CTD_variant (id, List.map (fun (field, ctyp) -> (field, f ctyp)) ctors) + +(** Map over each ctyp in a cdef using map_instr_ctyp *) +let cdef_map_ctyp f = function + | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, f ctyp, List.map (map_instr_ctyp f) instrs) + | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr_ctyp f) instrs) + | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs) + | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs) + | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs) + | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp) + | CDEF_type tdef -> CDEF_type (ctype_def_map_ctyp f tdef) + +(* Map over all sequences of instructions contained within an instruction *) +let rec map_instrs f (I_aux (instr, aux)) = + let instr = match instr with + | I_decl _ | I_init _ | I_reset _ | I_reinit _ -> instr + | I_if (cval, instrs1, instrs2, ctyp) -> + I_if (cval, f (List.map (map_instrs f) instrs1), f (List.map (map_instrs f) instrs2), ctyp) + | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr + | I_block instrs -> I_block (f (List.map (map_instrs f) instrs)) + | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs)) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> instr + in + I_aux (instr, aux) + +let rec instr_ids (I_aux (instr, _)) = + let reads, writes = instr_deps instr in + IdSet.of_list (IdSet.elements reads @ IdSet.elements writes) + +let rec instr_reads (I_aux (instr, _)) = + let reads, _ = instr_deps instr in + IdSet.of_list (IdSet.elements reads) + +let rec instr_writes (I_aux (instr, _)) = + let _, writes = instr_deps instr in + IdSet.of_list (IdSet.elements writes) + +let rec filter_instrs f instrs = + let filter_instrs' = function + | I_aux (I_block instrs, aux) -> I_aux (I_block (filter_instrs f instrs), aux) + | I_aux (I_try_block instrs, aux) -> I_aux (I_try_block (filter_instrs f instrs), aux) + | I_aux (I_if (cval, instrs1, instrs2, ctyp), aux) -> + I_aux (I_if (cval, filter_instrs f instrs1, filter_instrs f instrs2, ctyp), aux) + | instr -> instr + in + List.filter f (List.map filter_instrs' instrs) + +(** GLOBAL: label_counter is used to make sure all labels have unique + names. Like gensym_counter it should be safe to reset between + top-level definitions. **) +let label_counter = ref 0 + +let label str = + let str = str ^ string_of_int !label_counter in + incr label_counter; + str + +let cval_ctyp = function (_, ctyp) -> ctyp + +let rec clexp_ctyp = function + | CL_id (_, ctyp) -> ctyp + | CL_return ctyp -> ctyp + | CL_field (clexp, field) -> + begin match clexp_ctyp clexp with + | CT_struct (id, ctors) -> + begin + try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with + | Not_found -> failwith ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field) + end + | ctyp -> failwith ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp) + end + | CL_addr clexp -> + begin match clexp_ctyp clexp with + | CT_ref ctyp -> ctyp + | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) + end + | CL_tuple (clexp, n) -> + begin match clexp_ctyp clexp with + | CT_tup typs -> + begin + try List.nth typs n with + | _ -> failwith "Tuple assignment index out of bounds" + end + | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp) + end + | CL_have_exception -> CT_bool + | CL_current_exception ctyp -> ctyp + +let rec instr_ctyps (I_aux (instr, aux)) = + match instr with + | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> + CTSet.singleton ctyp + | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> + CTSet.add ctyp (CTSet.singleton (cval_ctyp cval)) + | I_if (cval, instrs1, instrs2, ctyp) -> + CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2) + |> CTSet.add (cval_ctyp cval) + |> CTSet.add ctyp + | I_funcall (clexp, _, _, cvals) -> + List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map cval_ctyp cvals) + |> CTSet.add (clexp_ctyp clexp) + | I_copy (clexp, cval) | I_alias (clexp, cval) -> + CTSet.add (clexp_ctyp clexp) (CTSet.singleton (cval_ctyp cval)) + | I_block instrs | I_try_block instrs -> + instrs_ctyps instrs + | I_throw cval | I_jump (cval, _) | I_return cval -> + CTSet.singleton (cval_ctyp cval) + | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_end -> + CTSet.empty + +and instrs_ctyps instrs = List.fold_left CTSet.union CTSet.empty (List.map instr_ctyps instrs) + +let ctype_def_ctyps = function + | CTD_enum _ -> [] + | CTD_struct (_, fields) -> List.map snd fields + | CTD_variant (_, ctors) -> List.map snd ctors + +let cdef_ctyps = function + | CDEF_reg_dec (_, ctyp, instrs) -> + CTSet.add ctyp (instrs_ctyps instrs) + | CDEF_spec (_, ctyps, ctyp) -> + CTSet.add ctyp (List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty ctyps) + | CDEF_fundef (_, _, _, instrs) | CDEF_startup (_, instrs) | CDEF_finish (_, instrs) -> + instrs_ctyps instrs + | CDEF_type tdef -> + List.fold_right CTSet.add (ctype_def_ctyps tdef) CTSet.empty + | CDEF_let (_, bindings, instrs) -> + List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map snd bindings) + |> CTSet.union (instrs_ctyps instrs) + +let rec c_ast_registers = function + | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast + | _ :: ast -> c_ast_registers ast + | [] -> [] + +let instr_split_at f = + let rec instr_split_at' f before = function + | [] -> (List.rev before, []) + | instr :: instrs when f instr -> (List.rev before, instr :: instrs) + | instr :: instrs -> instr_split_at' f (instr :: before) instrs + in + instr_split_at' f [] diff --git a/src/sail.ml b/src/sail.ml index 77f0e32d..813d8ec1 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -183,11 +183,8 @@ let options = Arg.align ([ Arg.Set C_backend.opt_static, " make generated C functions static"); ( "-trace", - Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml], + Arg.Tuple [Arg.Set Ocaml_backend.opt_trace_ocaml], " instrument output with tracing"); - ( "-smt_trace", - Arg.Tuple [Arg.Set C_backend.opt_smt_trace], - " instrument output with tracing for SMT"); ( "-cgen", Arg.Set opt_print_cgen, " generate CGEN source"); @@ -310,9 +307,6 @@ let options = Arg.align ([ ( "-dmagic_hash", Arg.Set Initial_check.opt_magic_hash, " (debug) allow special character # in identifiers"); - ( "-dfunction", - Arg.String (fun f -> C_backend.opt_debug_function := f), - " (debug) print debugging output for a single function"); ( "-dprofile", Arg.Set Profile.opt_profile, " (debug) provide basic profiling information for rewriting passes within Sail"); @@ -441,22 +435,22 @@ let main() = in let output_chan = match !opt_file_out with Some f -> open_out (f ^ ".c") | None -> stdout in Util.opt_warnings := true; - C_backend.compile_ast (C_backend.initial_ctx type_envs) output_chan (!opt_includes_c) ast_c; + C_backend.compile_ast type_envs output_chan (!opt_includes_c) ast_c; close_out output_chan else ()); (if !(opt_print_ir) then let ast_c = rewrite_ast_c type_envs ast in let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in - let ast_c, type_envs = Specialize.(specialize' 2 int_specialization_with_externs ast_c type_envs) in + let ast_c, type_envs = Specialize.(specialize' 2 int_specialization ast_c type_envs) in let output_chan = match !opt_file_out with | Some f -> Util.opt_colors := false; open_out (f ^ ".ir.sail") | None -> stdout in Util.opt_warnings := true; - let cdefs = C_backend.(bytecode_ast (initial_ctx_iterate type_envs) (List.map flatten_cdef) ast_c) in - let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Bytecode_util.pp_cdef cdefs) in + let cdefs, _ = C_backend.jib_of_ast type_envs ast_c in + let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Jib_util.pp_cdef cdefs) in output_string output_chan (str ^ "\n"); close_out output_chan else ()); -- cgit v1.2.3