summaryrefslogtreecommitdiff
path: root/src/specialize.ml
diff options
context:
space:
mode:
authorAlasdair Armstrong2018-01-17 18:51:42 +0000
committerAlasdair Armstrong2018-01-18 16:13:11 +0000
commit952fcb88797a1771eb018e63e8446055e944e035 (patch)
tree12cdc5f1054dfad02fa76abd22247564eb133a21 /src/specialize.ml
parent254b72f60388271058c6d259d5a98424e94cafc7 (diff)
Modified unification so Type_check.instantiation_of works after sizeof rewriting
This change allows the AST to be type-checked after sizeof re-writing. It modifies the unification algorithm to better support checking multiplication in constraints, by using division and modulus SMT operators if they are defined. Also made sure the typechecker doesn't re-introduce E_constraint nodes, otherwise re-checking after sizeof-rewriting will re-introduce constraint nodes.
Diffstat (limited to 'src/specialize.ml')
-rw-r--r--src/specialize.ml86
1 files changed, 86 insertions, 0 deletions
diff --git a/src/specialize.ml b/src/specialize.ml
new file mode 100644
index 00000000..881881f4
--- /dev/null
+++ b/src/specialize.ml
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(* 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 Rewriter
+
+(* Returns an IdSet with the function ids that have X-kinded
+ parameters, e.g. val f : forall ('a : X). 'a -> 'a. The first
+ argument specifies what X should be - it should be one of:
+ is_nat_kopt, is_order_kopt, or is_type_kopt from Ast_util.
+*)
+let rec polymorphic_functions is_kopt (Defs defs) =
+ match defs with
+ | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ) , _), id, _, externs), _)) :: defs ->
+ let is_type_polymorphic = List.exists is_kopt (quant_kopts typq) in
+ if is_type_polymorphic then
+ IdSet.add id (polymorphic_functions is_kopt (Defs defs))
+ else
+ polymorphic_functions is_kopt (Defs defs)
+ | _ :: defs -> polymorphic_functions is_kopt (Defs defs)
+ | [] -> IdSet.empty
+
+(* Returns a list of all the instantiations of a function id in an
+ ast. *)
+let rec instantiations_of id ast =
+ let instantiations = ref [] in
+
+ let inspect_exp = function
+ | E_aux (E_app (id', _), _) as exp when Id.compare id id' = 0 ->
+ instantiations := Type_check.instantiation_of exp :: !instantiations;
+ exp
+ | exp -> exp
+ in
+
+ let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> inspect_exp (E_aux (exp, annot))) } in
+ let _ = rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } ast in
+
+ !instantiations