From 4db4b9619318970a0228954f64a61123c4961910 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Tue, 9 Oct 2018 21:47:31 +0100
Subject: Monad refactoring in Lem shallow embedding

- Merge tag reading/writing outcomes into memory value reading/writing outcomes
- Add effective address to Write_mem; this duplicates information in the
  Write_ea outcome that should come before, but it makes the effective address
  more conveniently available in events and traces, and it allows the following
  simplification in the state monad:
- Remove write_ea field from state record; the effective address is now
  expected as a parameter to the write_memS function
- Remove last_exclusive_operation_was_load field from state record; this was
  used to keep track of exclusive loads, but this was a a relatively coarse
  approximation anyway, so it might make more sense to track this in
  (architecture-specific) Sail code.  Overall, the state record now simply
  contains the fields regstate, memstate, tagstate.
---
 src/gen_lib/sail2_prompt_monad.lem  | 110 +++++++++++++++++++-----------------
 src/gen_lib/sail2_state_lifting.lem |  28 +++++----
 src/gen_lib/sail2_state_monad.lem   |  93 +++++++++++++-----------------
 3 files changed, 110 insertions(+), 121 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 78b1615e..991d3895 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -8,19 +8,17 @@ type address = list bitU
 
 type monad 'regval 'a 'e =
   | Done of 'a
-  (* Read a number of bytes from memory, returned in little endian order *)
-  | Read_mem of read_kind * address * nat * (list memory_byte -> monad 'regval 'a 'e)
-  (* Read the tag of a memory address *)
-  | Read_tag of address * (bitU -> monad 'regval 'a 'e)
-  (* Tell the system a write is imminent, at address lifted, of size nat *)
+  (* Read a number of bytes from memory, returned in little endian order,
+     together with a tag. *)
+  | Read_mem of read_kind * address * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
+  (* Tell the system a write is imminent, at the given address and with the
+     given size. *)
   | Write_ea of write_kind * address * nat * monad 'regval 'a 'e
   (* Request the result of store-exclusive *)
   | Excl_res of (bool -> monad 'regval 'a 'e)
-  (* Request to write memory at last signalled address. Memory value should be 8
-     times the size given in ea signal, given in little endian order *)
-  | Write_memv of list memory_byte * (bool -> monad 'regval 'a 'e)
-  (* Request to write the tag at given address. *)
-  | Write_tag of address * bitU * (bool -> monad 'regval 'a 'e)
+  (* Request to write a memory value of the given size together with a tag
+     at the given address. *)
+  | Write_mem of write_kind * address * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
   (* Tell the system to dynamically recalculate dependency footprint *)
   | Footprint of monad 'regval 'a 'e
   (* Request a memory barrier *)
@@ -38,26 +36,36 @@ type monad 'regval 'a 'e =
   (* Exception of type 'e *)
   | Exception of 'e
 
+type event 'regval =
+  | E_read_mem of read_kind * address * nat * (list memory_byte * bitU)
+  | E_write_mem of write_kind * address * nat * list memory_byte * bitU * bool
+  | E_write_ea of write_kind * address * nat
+  | E_excl_res of bool
+  | E_barrier of barrier_kind
+  | E_footprint
+  | E_read_reg of register_name * 'regval
+  | E_write_reg of register_name * 'regval
+  | E_undefined of bool
+  | E_print of string
+
 val return : forall 'rv 'a 'e. 'a -> monad 'rv 'a 'e
 let return a = Done a
 
 val bind : forall 'rv 'a 'b 'e. monad 'rv 'a 'e -> ('a -> monad 'rv 'b 'e) -> monad 'rv 'b 'e
 let rec bind m f = match m with
   | Done a -> f a
-  | Read_mem rk a sz k -> Read_mem rk a sz (fun v -> bind (k v) f)
-  | Read_tag a k ->       Read_tag a       (fun v -> bind (k v) f)
-  | Write_memv descr k -> Write_memv descr (fun v -> bind (k v) f)
-  | Write_tag a t k ->    Write_tag a t    (fun v -> bind (k v) f)
-  | Read_reg descr k ->   Read_reg descr   (fun v -> bind (k v) f)
-  | Excl_res k ->         Excl_res         (fun v -> bind (k v) f)
-  | Undefined k ->        Undefined        (fun v -> bind (k v) f)
-  | Write_ea wk a sz k -> Write_ea wk a sz (bind k f)
-  | Footprint k ->        Footprint        (bind k f)
-  | Barrier bk k ->       Barrier bk       (bind k f)
-  | Write_reg r v k ->    Write_reg r v    (bind k f)
-  | Print msg k ->        Print msg        (bind k f)
-  | Fail descr ->         Fail descr
-  | Exception e ->        Exception e
+  | Read_mem rk a sz k ->      Read_mem rk a sz      (fun v -> bind (k v) f)
+  | Write_mem wk a sz v t k -> Write_mem wk a sz v t (fun v -> bind (k v) f)
+  | Read_reg descr k ->        Read_reg descr        (fun v -> bind (k v) f)
+  | Excl_res k ->              Excl_res              (fun v -> bind (k v) f)
+  | Undefined k ->             Undefined             (fun v -> bind (k v) f)
+  | Write_ea wk a sz k ->      Write_ea wk a sz      (bind k f)
+  | Footprint k ->             Footprint             (bind k f)
+  | Barrier bk k ->            Barrier bk            (bind k f)
+  | Write_reg r v k ->         Write_reg r v         (bind k f)
+  | Print msg k ->             Print msg             (bind k f)
+  | Fail descr ->              Fail descr
+  | Exception e ->             Exception e
 end
 
 val exit : forall 'rv 'a 'e. unit -> monad 'rv 'a 'e
@@ -74,21 +82,19 @@ let throw e = Exception e
 
 val try_catch : forall 'rv 'a 'e1 'e2. monad 'rv 'a 'e1 -> ('e1 -> monad 'rv 'a 'e2) -> monad 'rv 'a 'e2
 let rec try_catch m h = match m with
-  | Done a ->             Done a
-  | Read_mem rk a sz k -> Read_mem rk a sz (fun v -> try_catch (k v) h)
-  | Read_tag a k ->       Read_tag a       (fun v -> try_catch (k v) h)
-  | Write_memv descr k -> Write_memv descr (fun v -> try_catch (k v) h)
-  | Write_tag a t k ->    Write_tag a t    (fun v -> try_catch (k v) h)
-  | Read_reg descr k ->   Read_reg descr   (fun v -> try_catch (k v) h)
-  | Excl_res k ->         Excl_res         (fun v -> try_catch (k v) h)
-  | Undefined k ->        Undefined        (fun v -> try_catch (k v) h)
-  | Write_ea wk a sz k -> Write_ea wk a sz (try_catch k h)
-  | Footprint k ->        Footprint        (try_catch k h)
-  | Barrier bk k ->       Barrier bk       (try_catch k h)
-  | Write_reg r v k ->    Write_reg r v    (try_catch k h)
-  | Print msg k ->        Print msg        (try_catch k h)
-  | Fail descr ->         Fail descr
-  | Exception e ->        h e
+  | Done a -> Done a
+  | Read_mem rk a sz k ->      Read_mem rk a sz      (fun v -> try_catch (k v) h)
+  | Write_mem wk a sz v t k -> Write_mem wk a sz v t (fun v -> try_catch (k v) h)
+  | Read_reg descr k ->        Read_reg descr        (fun v -> try_catch (k v) h)
+  | Excl_res k ->              Excl_res              (fun v -> try_catch (k v) h)
+  | Undefined k ->             Undefined             (fun v -> try_catch (k v) h)
+  | Write_ea wk a sz k ->      Write_ea wk a sz      (try_catch k h)
+  | Footprint k ->             Footprint             (try_catch k h)
+  | Barrier bk k ->            Barrier bk            (try_catch k h)
+  | Write_reg r v k ->         Write_reg r v         (try_catch k h)
+  | Print msg k ->             Print msg             (try_catch k h)
+  | Fail descr ->              Fail descr
+  | Exception e ->             h e
 end
 
 (* For early return, we abuse exceptions by throwing and catching
@@ -126,19 +132,19 @@ let maybe_fail msg = function
   | Nothing -> Fail msg
 end
 
-val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte) 'e
+val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
 let read_mem_bytes rk addr sz =
   Read_mem rk (bits_of addr) (nat_of_int sz) return
 
-val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e
+val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
 let read_mem rk addr sz =
   bind
     (read_mem_bytes rk addr sz)
-    (fun bytes ->
-       maybe_fail "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)))
-
-val read_tag : forall 'rv 'a 'e. Bitvector 'a => 'a -> monad 'rv bitU 'e
-let read_tag addr = Read_tag (bits_of addr) return
+    (fun (bytes, tag) ->
+       match of_bits (bits_of_mem_bytes bytes) with
+         | Just v -> return (v, tag)
+         | Nothing -> Fail "bits_of_mem_bytes"
+       end)
 
 val excl_result : forall 'rv 'e. unit -> monad 'rv bool 'e
 let excl_result () =
@@ -148,15 +154,13 @@ let excl_result () =
 val write_mem_ea : forall 'rv 'a 'e. Bitvector 'a => write_kind -> 'a -> integer -> monad 'rv unit 'e
 let write_mem_ea wk addr sz = Write_ea wk (bits_of addr) (nat_of_int sz) (Done ())
 
-val write_mem_val : forall 'rv 'a 'e. Bitvector 'a => 'a -> monad 'rv bool 'e
-let write_mem_val v = match mem_bytes_of_bits v with
-  | Just v -> Write_memv v return
-  | Nothing -> Fail "write_mem_val"
+val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
+  write_kind -> 'a -> integer -> 'b -> bitU -> monad 'rv bool 'e
+let write_mem wk addr sz v tag = match mem_bytes_of_bits v with
+  | Just v -> Write_mem wk (bits_of addr) (nat_of_int sz) v tag return
+  | Nothing -> Fail "write_mem"
 end
 
-val write_tag : forall 'rv 'a 'e. Bitvector 'a => 'a -> bitU -> monad 'rv bool 'e
-let write_tag addr b = Write_tag (bits_of addr) b return
-
 val read_reg : forall 's 'rv 'a 'e. register_ref 's 'rv 'a -> monad 'rv 'a 'e
 let read_reg reg =
   let k v =
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 039343e2..42e2c0f3 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -9,19 +9,17 @@ open import {isabelle} `Sail2_state_monad_lemmas`
 
 val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e
 let rec liftState ra s = match s with
-  | (Done a)             -> returnS a
-  | (Read_mem rk a sz k) -> bindS (read_mem_bytesS rk a sz) (fun v -> liftState ra (k v))
-  | (Read_tag t k)       -> bindS (read_tagS t)             (fun v -> liftState ra (k v))
-  | (Write_memv a k)     -> bindS (write_mem_bytesS a)      (fun v -> liftState ra (k v))
-  | (Write_tag a t k)    -> bindS (write_tagS a t)          (fun v -> liftState ra (k v))
-  | (Read_reg r k)       -> bindS (read_regvalS ra r)       (fun v -> liftState ra (k v))
-  | (Excl_res k)         -> bindS (excl_resultS ())         (fun v -> liftState ra (k v))
-  | (Undefined k)        -> bindS (undefined_boolS ())      (fun v -> liftState ra (k v))
-  | (Write_ea wk a sz k) -> seqS (write_mem_eaS wk a sz)    (liftState ra k)
-  | (Write_reg r v k)    -> seqS (write_regvalS ra r v)     (liftState ra k)
-  | (Footprint k)        -> liftState ra k
-  | (Barrier _ k)        -> liftState ra k
-  | (Print _ k)          -> liftState ra k (* TODO *)
-  | (Fail descr)         -> failS descr
-  | (Exception e)        -> throwS e
+  | (Done a)                  -> returnS a
+  | (Read_mem rk a sz k)      -> bindS (read_mem_bytesS rk a sz)      (fun v -> liftState ra (k v))
+  | (Write_mem wk a sz v t k) -> bindS (write_mem_bytesS wk a sz v t) (fun v -> liftState ra (k v))
+  | (Read_reg r k)            -> bindS (read_regvalS ra r)            (fun v -> liftState ra (k v))
+  | (Excl_res k)              -> bindS (excl_resultS ())              (fun v -> liftState ra (k v))
+  | (Undefined k)             -> bindS (undefined_boolS ())           (fun v -> liftState ra (k v))
+  | (Write_reg r v k)         -> seqS (write_regvalS ra r v)          (liftState ra k)
+  | (Write_ea _ _ _ k)        -> liftState ra k
+  | (Footprint k)             -> liftState ra k
+  | (Barrier _ k)             -> liftState ra k
+  | (Print _ k)               -> liftState ra k (* TODO *)
+  | (Fail descr)              -> failS descr
+  | (Exception e)             -> throwS e
 end
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 30b296cc..89b29fa5 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -11,17 +11,13 @@ type tagstate = map integer bitU
 type sequential_state 'regs =
   <| regstate : 'regs;
      memstate : memstate;
-     tagstate : tagstate;
-     write_ea : maybe (write_kind * integer * integer);
-     last_exclusive_operation_was_load : bool |>
+     tagstate : tagstate |>
 
 val init_state : forall 'regs. 'regs -> sequential_state 'regs
 let init_state regs =
   <| regstate = regs;
      memstate = Map.empty;
-     tagstate = Map.empty;
-     write_ea = Nothing;
-     last_exclusive_operation_was_load = false |>
+     tagstate = Map.empty |>
 
 type ex 'e =
   | Failure of string
@@ -124,66 +120,57 @@ let read_tagS addr =
   readS (fun s -> fromMaybe B0 (Map.lookup addr s.tagstate)))
 
 (* Read bytes from memory and return in little endian order *)
-val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte) 'e
-let read_mem_bytesS read_kind addr sz =
+val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte * bitU) 'e
+let read_mem_bytesS _ addr sz =
   maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
   let sz = integerFromNat sz in
   let addrs = index_list addr (addr+sz-1) 1 in
   let read_byte s addr = Map.lookup addr s.memstate in
-  readS (fun s -> just_list (List.map (read_byte s) addrs)) >>$= (function
-    | Just mem_val ->
-       updateS (fun s ->
-         if read_is_exclusive read_kind
-         then <| s with last_exclusive_operation_was_load = true |>
-         else s) >>$
-       returnS mem_val
-    | Nothing -> failS "read_memS"
+  let read_tag s addr = Map.findWithDefault addr B0 s.tagstate in
+  readS (fun s ->
+    (just_list (List.map (read_byte s) addrs),
+     List.foldl and_bit B1 (List.map (read_tag s) addrs))) >>$=
+  (function
+    | (Just mem_val, tag) -> returnS (mem_val, tag)
+    | _ -> failS "read_memS"
   end))
 
-val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e
+val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
 let read_memS rk a sz =
-  read_mem_bytesS rk a (nat_of_int sz) >>$= (fun bytes ->
-  maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)))
+  read_mem_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
+  maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val ->
+  returnS (mem_val, tag)))
 
 val excl_resultS : forall 'regs 'e. unit -> monadS 'regs bool 'e
-let excl_resultS () =
-  readS (fun s -> s.last_exclusive_operation_was_load) >>$= (fun excl_load ->
-  updateS (fun s -> <| s with last_exclusive_operation_was_load = false |>) >>$
-  chooseS (if excl_load then {false; true} else {false}))
-
-val write_mem_eaS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> monadS 'regs unit 'e
-let write_mem_eaS write_kind addr sz =
+let excl_resultS =
+  (* TODO: This used to be more deterministic, checking a flag in the state
+     whether an exclusive load has occurred before.  However, this does not
+     seem very precise; it might be safer to overapproximate the possible
+     behaviours by always making a nondeterministic choice. *)
+  undefined_boolS
+
+(* Write little-endian list of bytes to given address *)
+val write_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
+let write_mem_bytesS _ addr sz v t =
   maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
   let sz = integerFromNat sz in
-  updateS (fun s -> <| s with write_ea = Just (write_kind, addr, sz) |>))
-
-(* Write little-endian list of bytes to previously announced address *)
-val write_mem_bytesS : forall 'regs 'e. list memory_byte -> monadS 'regs bool 'e
-let write_mem_bytesS v =
-  readS (fun s -> s.write_ea) >>$= (function
-      | Nothing -> failS "write ea has not been announced yet"
-      | Just (_, addr, sz) ->
-         let addrs = index_list addr (addr+sz-1) 1 in
-         (*let v = external_mem_value (bits_of v) in*)
-         let a_v = List.zip addrs v in
-         let write_byte mem (addr, v) = Map.insert addr v mem in
-         updateS (fun s ->
-           <| s with memstate = List.foldl write_byte s.memstate a_v |>) >>$
-         returnS true
-    end)
-
-val write_mem_valS : forall 'regs 'e 'a. Bitvector 'a => 'a -> monadS 'regs bool 'e
-let write_mem_valS v = match mem_bytes_of_bits v with
-  | Just v -> write_mem_bytesS v
-  | Nothing -> failS "write_mem_val"
+  let addrs = index_list addr (addr+sz-1) 1 in
+  (*let v = external_mem_value (bits_of v) in*)
+  let a_v = List.zip addrs v in
+  let write_byte mem (addr, v) = Map.insert addr v mem in
+  let write_tag mem addr = Map.insert addr t mem in
+  updateS (fun s ->
+    <| s with memstate = List.foldl write_byte s.memstate a_v;
+              tagstate = List.foldl write_tag s.tagstate addrs |>) >>$
+  returnS true)
+
+val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
+  write_kind -> 'a -> nat -> 'b -> bitU -> monadS 'regs bool 'e
+let write_memS wk addr sz v t = match mem_bytes_of_bits v with
+  | Just v -> write_mem_bytesS wk addr sz v t
+  | Nothing -> failS "write_mem"
 end
 
-val write_tagS : forall 'regs 'a 'e. Bitvector 'a => 'a -> bitU -> monadS 'regs bool 'e
-let write_tagS addr t =
-   maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
-   updateS (fun s -> <| s with tagstate = Map.insert addr t s.tagstate |>) >>$
-   returnS true)
-
 val read_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> monadS 'regs 'a 'e
 let read_regS reg = readS (fun s -> reg.read_from s.regstate)
 
-- 
cgit v1.2.3


From 10cb6bf0b0c37ccf7ec1bc222ed0a694fd815843 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Tue, 23 Oct 2018 11:28:39 +0100
Subject: Add helper functions in Sail Lem library

Running traces, directly accessing memory state
---
 src/gen_lib/sail2_prompt_monad.lem  | 58 +++++++++++++++++++++++++++++++++++++
 src/gen_lib/sail2_state_lifting.lem | 27 +++++++++++++++--
 src/gen_lib/sail2_state_monad.lem   | 37 ++++++++++++-----------
 3 files changed, 102 insertions(+), 20 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 991d3895..5a6d2aef 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -48,6 +48,8 @@ type event 'regval =
   | E_undefined of bool
   | E_print of string
 
+type trace 'regval = list (event 'regval)
+
 val return : forall 'rv 'a 'e. 'a -> monad 'rv 'a 'e
 let return a = Done a
 
@@ -218,6 +220,62 @@ let barrier bk = Barrier bk (Done ())
 val footprint : forall 'rv 'e. unit -> monad 'rv unit 'e
 let footprint _ = Footprint (Done ())
 
+(* Event traces *)
+
+val emitEvent : forall 'regval 'a 'e. Eq 'regval => monad 'regval 'a 'e -> event 'regval -> maybe (monad 'regval 'a 'e)
+let emitEvent m e = match (e, m) with
+  | (E_read_mem rk a sz v, Read_mem rk' a' sz' k) ->
+     if rk' = rk && a' = a && sz' = sz then Just (k v) else Nothing
+  | (E_write_mem wk a sz v tag r, Write_mem wk' a' sz' v' tag' k) ->
+     if wk' = wk && a' = a && sz' = sz && v' = v && tag' = tag then Just (k r) else Nothing
+  | (E_read_reg r v, Read_reg r' k) ->
+     if r' = r then Just (k v) else Nothing
+  | (E_write_reg r v, Write_reg r' v' k) ->
+     if r' = r && v' = v then Just k else Nothing
+  | (E_write_ea wk a sz, Write_ea wk' a' sz' k) ->
+     if wk' = wk && a' = a && sz' = sz then Just k else Nothing
+  | (E_barrier bk, Barrier bk' k) ->
+     if bk' = bk then Just k else Nothing
+  | (E_print m, Print m' k) ->
+     if m' = m then Just k else Nothing
+  | (E_excl_res v, Excl_res k) -> Just (k v)
+  | (E_undefined v, Undefined k) -> Just (k v)
+  | (E_footprint, Footprint k) -> Just k
+  | _ -> Nothing
+end
+
+val runTrace : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> maybe (monad 'regval 'a 'e)
+let rec runTrace t m = match t with
+  | [] -> Just m
+  | e :: t' -> Maybe.bind (emitEvent m e) (runTrace t')
+end
+
+val final : forall 'regval 'a 'e. monad 'regval 'a 'e -> bool
+let final = function
+  | Done _ -> true
+  | Fail _ -> true
+  | Exception _ -> true
+  | _ -> false
+end
+
+val hasTrace : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool
+let hasTrace t m = match runTrace t m with
+  | Just m -> final m
+  | Nothing -> false
+end
+
+val hasException : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool
+let hasException t m = match runTrace t m with
+  | Just (Exception _) -> true
+  | _ -> false
+end
+
+val hasFailure : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool
+let hasFailure t m = match runTrace t m with
+  | Just (Fail _) -> true
+  | _ -> false
+end
+
 (* Define a type synonym that also takes the register state as a type parameter,
    in order to make switching to the state monad without changing generated
    definitions easier, see also lib/hol/prompt_monad.lem. *)
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 42e2c0f3..314c562d 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -5,10 +5,9 @@ open import Sail2_prompt
 open import Sail2_state_monad
 open import {isabelle} `Sail2_state_monad_lemmas`
 
-(* State monad wrapper around prompt monad *)
-
+(* Lifting from prompt monad to state monad *)
 val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e
-let rec liftState ra s = match s with
+let rec liftState ra m = match m with
   | (Done a)                  -> returnS a
   | (Read_mem rk a sz k)      -> bindS (read_mem_bytesS rk a sz)      (fun v -> liftState ra (k v))
   | (Write_mem wk a sz v t k) -> bindS (write_mem_bytesS wk a sz v t) (fun v -> liftState ra (k v))
@@ -23,3 +22,25 @@ let rec liftState ra s = match s with
   | (Fail descr)              -> failS descr
   | (Exception e)             -> throwS e
 end
+
+val runTraceS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> trace 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
+let rec runTraceS ra t s =
+  match t with
+  | [] -> Just s
+  | E_read_mem _ addr sz (v, tag) :: t' ->
+     Maybe.bind (unsigned addr) (fun addr ->
+     Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
+     if v' = v && tag' = tag then runTraceS ra t' s else Nothing))
+  | E_write_mem _ addr sz v tag _ :: t' ->
+     Maybe.bind (unsigned addr) (fun addr ->
+     runTraceS ra t' (put_mem_bytes addr sz v tag s))
+  | E_read_reg r v :: t' ->
+     let (read_reg, _) = ra in
+     Maybe.bind (read_reg r s.regstate) (fun v' ->
+     if v' = v then runTraceS ra t' s else Nothing)
+  | E_write_reg r v :: t' ->
+     let (_, write_reg) = ra in
+     Maybe.bind (write_reg r v s.regstate) (fun s' ->
+     runTraceS ra t' <| s with regstate = s' |>)
+  | _ :: t' -> runTraceS ra t' s
+end
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 89b29fa5..84ae86d8 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -120,20 +120,21 @@ let read_tagS addr =
   readS (fun s -> fromMaybe B0 (Map.lookup addr s.tagstate)))
 
 (* Read bytes from memory and return in little endian order *)
-val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte * bitU) 'e
-let read_mem_bytesS _ addr sz =
-  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
+val get_mem_bytes : forall 'regs. integer -> nat -> sequential_state 'regs -> maybe (list memory_byte * bitU)
+let get_mem_bytes addr sz s =
   let sz = integerFromNat sz in
   let addrs = index_list addr (addr+sz-1) 1 in
   let read_byte s addr = Map.lookup addr s.memstate in
   let read_tag s addr = Map.findWithDefault addr B0 s.tagstate in
-  readS (fun s ->
-    (just_list (List.map (read_byte s) addrs),
-     List.foldl and_bit B1 (List.map (read_tag s) addrs))) >>$=
-  (function
-    | (Just mem_val, tag) -> returnS (mem_val, tag)
-    | _ -> failS "read_memS"
-  end))
+  Maybe.map
+    (fun mem_val -> (mem_val, List.foldl and_bit B1 (List.map (read_tag s) addrs)))
+    (just_list (List.map (read_byte s) addrs))
+
+val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte * bitU) 'e
+let read_mem_bytesS _ addr sz =
+  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
+  readS (get_mem_bytes addr sz) >>$=
+  maybe_failS "read_memS")
 
 val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
 let read_memS rk a sz =
@@ -150,18 +151,20 @@ let excl_resultS =
   undefined_boolS
 
 (* Write little-endian list of bytes to given address *)
-val write_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
-let write_mem_bytesS _ addr sz v t =
-  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
+val put_mem_bytes : forall 'regs. integer -> nat -> list memory_byte -> bitU -> sequential_state 'regs -> sequential_state 'regs
+let put_mem_bytes addr sz v t s =
   let sz = integerFromNat sz in
   let addrs = index_list addr (addr+sz-1) 1 in
-  (*let v = external_mem_value (bits_of v) in*)
   let a_v = List.zip addrs v in
   let write_byte mem (addr, v) = Map.insert addr v mem in
   let write_tag mem addr = Map.insert addr t mem in
-  updateS (fun s ->
-    <| s with memstate = List.foldl write_byte s.memstate a_v;
-              tagstate = List.foldl write_tag s.tagstate addrs |>) >>$
+  <| s with memstate = List.foldl write_byte s.memstate a_v;
+            tagstate = List.foldl write_tag s.tagstate addrs |>
+
+val write_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
+let write_mem_bytesS _ addr sz v t =
+  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
+  updateS (put_mem_bytes addr sz v t) >>$
   returnS true)
 
 val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
-- 
cgit v1.2.3


From d733aa5c7409c645807589d268c0b80055bf671d Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Tue, 20 Nov 2018 18:32:37 +0000
Subject: Use nat instead of (list bitU) for addresses in monad outcomes

Removes some friction by back-and-forth conversion when handling events
---
 src/gen_lib/sail2_prompt_monad.lem  | 34 ++++++++++++++++++++-------------
 src/gen_lib/sail2_state_lifting.lem |  6 ++----
 src/gen_lib/sail2_state_monad.lem   | 38 ++++++++++++++++++-------------------
 src/gen_lib/sail2_values.lem        |  3 +++
 4 files changed, 44 insertions(+), 37 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 5a6d2aef..ae1f2cd8 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -9,16 +9,17 @@ type address = list bitU
 type monad 'regval 'a 'e =
   | Done of 'a
   (* Read a number of bytes from memory, returned in little endian order,
-     together with a tag. *)
-  | Read_mem of read_kind * address * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
+     together with a tag.  The first nat specifies the address, the second
+     the number of bytes. *)
+  | Read_mem of read_kind * nat * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
   (* Tell the system a write is imminent, at the given address and with the
      given size. *)
-  | Write_ea of write_kind * address * nat * monad 'regval 'a 'e
+  | Write_ea of write_kind * nat * nat * monad 'regval 'a 'e
   (* Request the result of store-exclusive *)
   | Excl_res of (bool -> monad 'regval 'a 'e)
   (* Request to write a memory value of the given size together with a tag
      at the given address. *)
-  | Write_mem of write_kind * address * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
+  | Write_mem of write_kind * nat * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
   (* Tell the system to dynamically recalculate dependency footprint *)
   | Footprint of monad 'regval 'a 'e
   (* Request a memory barrier *)
@@ -37,9 +38,9 @@ type monad 'regval 'a 'e =
   | Exception of 'e
 
 type event 'regval =
-  | E_read_mem of read_kind * address * nat * (list memory_byte * bitU)
-  | E_write_mem of write_kind * address * nat * list memory_byte * bitU * bool
-  | E_write_ea of write_kind * address * nat
+  | E_read_mem of read_kind * nat * nat * (list memory_byte * bitU)
+  | E_write_mem of write_kind * nat * nat * list memory_byte * bitU * bool
+  | E_write_ea of write_kind * nat * nat
   | E_excl_res of bool
   | E_barrier of barrier_kind
   | E_footprint
@@ -136,7 +137,9 @@ end
 
 val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
 let read_mem_bytes rk addr sz =
-  Read_mem rk (bits_of addr) (nat_of_int sz) return
+  bind
+    (maybe_fail "nat_of_bv" (nat_of_bv addr))
+    (fun addr -> Read_mem rk addr (nat_of_int sz) return)
 
 val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
 let read_mem rk addr sz =
@@ -154,14 +157,19 @@ let excl_result () =
   Excl_res k
 
 val write_mem_ea : forall 'rv 'a 'e. Bitvector 'a => write_kind -> 'a -> integer -> monad 'rv unit 'e
-let write_mem_ea wk addr sz = Write_ea wk (bits_of addr) (nat_of_int sz) (Done ())
+let write_mem_ea wk addr sz =
+  bind
+    (maybe_fail "nat_of_bv" (nat_of_bv addr))
+    (fun addr -> Write_ea wk addr (nat_of_int sz) (Done ()))
 
 val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
   write_kind -> 'a -> integer -> 'b -> bitU -> monad 'rv bool 'e
-let write_mem wk addr sz v tag = match mem_bytes_of_bits v with
-  | Just v -> Write_mem wk (bits_of addr) (nat_of_int sz) v tag return
-  | Nothing -> Fail "write_mem"
-end
+let write_mem wk addr sz v tag =
+  match (mem_bytes_of_bits v, nat_of_bv addr) with
+    | (Just v, Just addr) ->
+       Write_mem wk addr (nat_of_int sz) v tag return
+    | _ -> Fail "write_mem"
+  end
 
 val read_reg : forall 's 'rv 'a 'e. register_ref 's 'rv 'a -> monad 'rv 'a 'e
 let read_reg reg =
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 314c562d..3cc396f2 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -28,12 +28,10 @@ let rec runTraceS ra t s =
   match t with
   | [] -> Just s
   | E_read_mem _ addr sz (v, tag) :: t' ->
-     Maybe.bind (unsigned addr) (fun addr ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
-     if v' = v && tag' = tag then runTraceS ra t' s else Nothing))
+     if v' = v && tag' = tag then runTraceS ra t' s else Nothing)
   | E_write_mem _ addr sz v tag _ :: t' ->
-     Maybe.bind (unsigned addr) (fun addr ->
-     runTraceS ra t' (put_mem_bytes addr sz v tag s))
+     runTraceS ra t' (put_mem_bytes addr sz v tag s)
   | E_read_reg r v :: t' ->
      let (read_reg, _) = ra in
      Maybe.bind (read_reg r s.regstate) (fun v' ->
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 84ae86d8..6c1cd4bd 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -4,8 +4,8 @@ open import Sail2_values
 
 (* 'a is result type *)
 
-type memstate = map integer memory_byte
-type tagstate = map integer bitU
+type memstate = map nat memory_byte
+type tagstate = map nat bitU
 (* type regstate = map string (vector bitU) *)
 
 type sequential_state 'regs =
@@ -116,31 +116,30 @@ end
 
 val read_tagS : forall 'regs 'a 'e. Bitvector 'a => 'a -> monadS 'regs bitU 'e
 let read_tagS addr =
-  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
+  maybe_failS "nat_of_bv" (nat_of_bv addr) >>$= (fun addr ->
   readS (fun s -> fromMaybe B0 (Map.lookup addr s.tagstate)))
 
 (* Read bytes from memory and return in little endian order *)
-val get_mem_bytes : forall 'regs. integer -> nat -> sequential_state 'regs -> maybe (list memory_byte * bitU)
+val get_mem_bytes : forall 'regs. nat -> nat -> sequential_state 'regs -> maybe (list memory_byte * bitU)
 let get_mem_bytes addr sz s =
-  let sz = integerFromNat sz in
-  let addrs = index_list addr (addr+sz-1) 1 in
+  let addrs = genlist (fun n -> addr + n) sz in
   let read_byte s addr = Map.lookup addr s.memstate in
   let read_tag s addr = Map.findWithDefault addr B0 s.tagstate in
   Maybe.map
     (fun mem_val -> (mem_val, List.foldl and_bit B1 (List.map (read_tag s) addrs)))
     (just_list (List.map (read_byte s) addrs))
 
-val read_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => read_kind -> 'a -> nat -> monadS 'regs (list memory_byte * bitU) 'e
+val read_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte * bitU) 'e
 let read_mem_bytesS _ addr sz =
-  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
   readS (get_mem_bytes addr sz) >>$=
-  maybe_failS "read_memS")
+  maybe_failS "read_memS"
 
 val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
 let read_memS rk a sz =
+  maybe_failS "nat_of_bv" (nat_of_bv a) >>$= (fun a ->
   read_mem_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
   maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val ->
-  returnS (mem_val, tag)))
+  returnS (mem_val, tag))))
 
 val excl_resultS : forall 'regs 'e. unit -> monadS 'regs bool 'e
 let excl_resultS =
@@ -151,28 +150,27 @@ let excl_resultS =
   undefined_boolS
 
 (* Write little-endian list of bytes to given address *)
-val put_mem_bytes : forall 'regs. integer -> nat -> list memory_byte -> bitU -> sequential_state 'regs -> sequential_state 'regs
+val put_mem_bytes : forall 'regs. nat -> nat -> list memory_byte -> bitU -> sequential_state 'regs -> sequential_state 'regs
 let put_mem_bytes addr sz v t s =
-  let sz = integerFromNat sz in
-  let addrs = index_list addr (addr+sz-1) 1 in
+  let addrs = genlist (fun n -> addr + n) sz in
   let a_v = List.zip addrs v in
   let write_byte mem (addr, v) = Map.insert addr v mem in
   let write_tag mem addr = Map.insert addr t mem in
   <| s with memstate = List.foldl write_byte s.memstate a_v;
             tagstate = List.foldl write_tag s.tagstate addrs |>
 
-val write_mem_bytesS : forall 'regs 'e 'a. Bitvector 'a => write_kind -> 'a -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
+val write_mem_bytesS : forall 'regs 'e. write_kind -> nat -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
 let write_mem_bytesS _ addr sz v t =
-  maybe_failS "unsigned" (unsigned addr) >>$= (fun addr ->
   updateS (put_mem_bytes addr sz v t) >>$
-  returnS true)
+  returnS true
 
 val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
   write_kind -> 'a -> nat -> 'b -> bitU -> monadS 'regs bool 'e
-let write_memS wk addr sz v t = match mem_bytes_of_bits v with
-  | Just v -> write_mem_bytesS wk addr sz v t
-  | Nothing -> failS "write_mem"
-end
+let write_memS wk addr sz v t =
+  match (nat_of_bv addr, mem_bytes_of_bits v) with
+    | (Just addr, Just v) -> write_mem_bytesS wk addr sz v t
+    | _ -> failS "write_mem"
+  end
 
 val read_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> monadS 'regs 'a 'e
 let read_regS reg = readS (fun s -> reg.read_from s.regstate)
diff --git a/src/gen_lib/sail2_values.lem b/src/gen_lib/sail2_values.lem
index 8957f0dd..fa1e8426 100644
--- a/src/gen_lib/sail2_values.lem
+++ b/src/gen_lib/sail2_values.lem
@@ -625,6 +625,9 @@ let extz_bv n v = extz_bits n (bits_of v)
 val exts_bv : forall 'a. Bitvector 'a => integer -> 'a -> list bitU
 let exts_bv n v = exts_bits n (bits_of v)
 
+val nat_of_bv : forall 'a. Bitvector 'a => 'a -> maybe nat
+let nat_of_bv v = Maybe.map nat_of_int (unsigned v)
+
 val string_of_bv : forall 'a. Bitvector 'a => 'a -> string
 let string_of_bv v = show_bitlist (bits_of v)
 
-- 
cgit v1.2.3


From c0f8dd2e676c4ce987c73392506dff8872a364ef Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 29 Nov 2018 15:13:50 +0000
Subject: Add some helper lemmas to Isabelle lib

---
 src/gen_lib/sail2_prompt_monad.lem  |  2 ++
 src/gen_lib/sail2_state_lifting.lem | 34 ++++++++++++++++++++--------------
 2 files changed, 22 insertions(+), 14 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index ae1f2cd8..7503ca22 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -258,6 +258,8 @@ let rec runTrace t m = match t with
   | e :: t' -> Maybe.bind (emitEvent m e) (runTrace t')
 end
 
+declare {isabelle} termination_argument runTrace = automatic
+
 val final : forall 'regval 'a 'e. monad 'regval 'a 'e -> bool
 let final = function
   | Done _ -> true
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 3cc396f2..0e7addbb 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -23,22 +23,28 @@ let rec liftState ra m = match m with
   | (Exception e)             -> throwS e
 end
 
-val runTraceS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> trace 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
-let rec runTraceS ra t s =
-  match t with
-  | [] -> Just s
-  | E_read_mem _ addr sz (v, tag) :: t' ->
+val emitEventS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> event 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
+let emitEventS ra e s = match e with
+  | E_read_mem _ addr sz (v, tag) ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
-     if v' = v && tag' = tag then runTraceS ra t' s else Nothing)
-  | E_write_mem _ addr sz v tag _ :: t' ->
-     runTraceS ra t' (put_mem_bytes addr sz v tag s)
-  | E_read_reg r v :: t' ->
+     if v' = v && tag' = tag then Just s else Nothing)
+  | E_write_mem _ addr sz v tag _ ->
+     Just (put_mem_bytes addr sz v tag s)
+  | E_read_reg r v ->
      let (read_reg, _) = ra in
      Maybe.bind (read_reg r s.regstate) (fun v' ->
-     if v' = v then runTraceS ra t' s else Nothing)
-  | E_write_reg r v :: t' ->
+     if v' = v then Just s else Nothing)
+  | E_write_reg r v ->
      let (_, write_reg) = ra in
-     Maybe.bind (write_reg r v s.regstate) (fun s' ->
-     runTraceS ra t' <| s with regstate = s' |>)
-  | _ :: t' -> runTraceS ra t' s
+     Maybe.bind (write_reg r v s.regstate) (fun rs' ->
+     Just <| s with regstate = rs' |>)
+  | _ -> Just s
 end
+
+val runTraceS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> trace 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
+let rec runTraceS ra t s = match t with
+  | [] -> Just s
+  | e :: t' -> Maybe.bind (emitEventS ra e s) (runTraceS ra t')
+end
+
+declare {isabelle} termination_argument runTraceS = automatic
-- 
cgit v1.2.3


From 17334803f125e3b839fdb7a780989d8eba555555 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 29 Nov 2018 17:58:15 +0000
Subject: Add separate outcome/event for tagged memory loads

Lets one distinguish in a trace whether an instruction tried to read
tagged memory or just read data without caring about the tag;  this is
useful for formulating predicates on traces.
---
 src/gen_lib/sail2_prompt_monad.lem  | 82 +++++++++++++++++++++++--------------
 src/gen_lib/sail2_state_lifting.lem | 36 ++++++++--------
 src/gen_lib/sail2_state_monad.lem   | 20 ++++++---
 3 files changed, 86 insertions(+), 52 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 7503ca22..079375a3 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -9,9 +9,10 @@ type address = list bitU
 type monad 'regval 'a 'e =
   | Done of 'a
   (* Read a number of bytes from memory, returned in little endian order,
-     together with a tag.  The first nat specifies the address, the second
+     with or without a tag.  The first nat specifies the address, the second
      the number of bytes. *)
-  | Read_mem of read_kind * nat * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
+  | Read_mem of read_kind * nat * nat * (list memory_byte -> monad 'regval 'a 'e)
+  | Read_tagged_mem of read_kind * nat * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
   (* Tell the system a write is imminent, at the given address and with the
      given size. *)
   | Write_ea of write_kind * nat * nat * monad 'regval 'a 'e
@@ -38,7 +39,8 @@ type monad 'regval 'a 'e =
   | Exception of 'e
 
 type event 'regval =
-  | E_read_mem of read_kind * nat * nat * (list memory_byte * bitU)
+  | E_read_mem of read_kind * nat * nat * list memory_byte
+  | E_read_tagged_mem of read_kind * nat * nat * (list memory_byte * bitU)
   | E_write_mem of write_kind * nat * nat * list memory_byte * bitU * bool
   | E_write_ea of write_kind * nat * nat
   | E_excl_res of bool
@@ -57,18 +59,19 @@ let return a = Done a
 val bind : forall 'rv 'a 'b 'e. monad 'rv 'a 'e -> ('a -> monad 'rv 'b 'e) -> monad 'rv 'b 'e
 let rec bind m f = match m with
   | Done a -> f a
-  | Read_mem rk a sz k ->      Read_mem rk a sz      (fun v -> bind (k v) f)
-  | Write_mem wk a sz v t k -> Write_mem wk a sz v t (fun v -> bind (k v) f)
-  | Read_reg descr k ->        Read_reg descr        (fun v -> bind (k v) f)
-  | Excl_res k ->              Excl_res              (fun v -> bind (k v) f)
-  | Undefined k ->             Undefined             (fun v -> bind (k v) f)
-  | Write_ea wk a sz k ->      Write_ea wk a sz      (bind k f)
-  | Footprint k ->             Footprint             (bind k f)
-  | Barrier bk k ->            Barrier bk            (bind k f)
-  | Write_reg r v k ->         Write_reg r v         (bind k f)
-  | Print msg k ->             Print msg             (bind k f)
-  | Fail descr ->              Fail descr
-  | Exception e ->             Exception e
+  | Read_mem rk a sz k ->        Read_mem rk a sz        (fun v -> bind (k v) f)
+  | Read_tagged_mem rk a sz k -> Read_tagged_mem rk a sz (fun v -> bind (k v) f)
+  | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> bind (k v) f)
+  | Read_reg descr k ->          Read_reg descr          (fun v -> bind (k v) f)
+  | Excl_res k ->                Excl_res                (fun v -> bind (k v) f)
+  | Undefined k ->               Undefined               (fun v -> bind (k v) f)
+  | Write_ea wk a sz k ->        Write_ea wk a sz        (bind k f)
+  | Footprint k ->               Footprint               (bind k f)
+  | Barrier bk k ->              Barrier bk              (bind k f)
+  | Write_reg r v k ->           Write_reg r v           (bind k f)
+  | Print msg k ->               Print msg               (bind k f)
+  | Fail descr ->                Fail descr
+  | Exception e ->               Exception e
 end
 
 val exit : forall 'rv 'a 'e. unit -> monad 'rv 'a 'e
@@ -86,18 +89,19 @@ let throw e = Exception e
 val try_catch : forall 'rv 'a 'e1 'e2. monad 'rv 'a 'e1 -> ('e1 -> monad 'rv 'a 'e2) -> monad 'rv 'a 'e2
 let rec try_catch m h = match m with
   | Done a -> Done a
-  | Read_mem rk a sz k ->      Read_mem rk a sz      (fun v -> try_catch (k v) h)
-  | Write_mem wk a sz v t k -> Write_mem wk a sz v t (fun v -> try_catch (k v) h)
-  | Read_reg descr k ->        Read_reg descr        (fun v -> try_catch (k v) h)
-  | Excl_res k ->              Excl_res              (fun v -> try_catch (k v) h)
-  | Undefined k ->             Undefined             (fun v -> try_catch (k v) h)
-  | Write_ea wk a sz k ->      Write_ea wk a sz      (try_catch k h)
-  | Footprint k ->             Footprint             (try_catch k h)
-  | Barrier bk k ->            Barrier bk            (try_catch k h)
-  | Write_reg r v k ->         Write_reg r v         (try_catch k h)
-  | Print msg k ->             Print msg             (try_catch k h)
-  | Fail descr ->              Fail descr
-  | Exception e ->             h e
+  | Read_mem rk a sz k ->        Read_mem rk a sz        (fun v -> try_catch (k v) h)
+  | Read_tagged_mem rk a sz k -> Read_tagged_mem rk a sz (fun v -> try_catch (k v) h)
+  | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> try_catch (k v) h)
+  | Read_reg descr k ->          Read_reg descr          (fun v -> try_catch (k v) h)
+  | Excl_res k ->                Excl_res                (fun v -> try_catch (k v) h)
+  | Undefined k ->               Undefined               (fun v -> try_catch (k v) h)
+  | Write_ea wk a sz k ->        Write_ea wk a sz        (try_catch k h)
+  | Footprint k ->               Footprint               (try_catch k h)
+  | Barrier bk k ->              Barrier bk              (try_catch k h)
+  | Write_reg r v k ->           Write_reg r v           (try_catch k h)
+  | Print msg k ->               Print msg               (try_catch k h)
+  | Fail descr ->                Fail descr
+  | Exception e ->               h e
 end
 
 (* For early return, we abuse exceptions by throwing and catching
@@ -135,19 +139,35 @@ let maybe_fail msg = function
   | Nothing -> Fail msg
 end
 
-val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
+val read_tagged_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
+let read_tagged_mem_bytes rk addr sz =
+  bind
+    (maybe_fail "nat_of_bv" (nat_of_bv addr))
+    (fun addr -> Read_tagged_mem rk addr (nat_of_int sz) return)
+
+val read_tagged_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
+let read_tagged_mem rk addr sz =
+  bind
+    (read_tagged_mem_bytes rk addr sz)
+    (fun (bytes, tag) ->
+       match of_bits (bits_of_mem_bytes bytes) with
+         | Just v -> return (v, tag)
+         | Nothing -> Fail "bits_of_mem_bytes"
+       end)
+
+val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte) 'e
 let read_mem_bytes rk addr sz =
   bind
     (maybe_fail "nat_of_bv" (nat_of_bv addr))
     (fun addr -> Read_mem rk addr (nat_of_int sz) return)
 
-val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
+val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e
 let read_mem rk addr sz =
   bind
     (read_mem_bytes rk addr sz)
-    (fun (bytes, tag) ->
+    (fun bytes ->
        match of_bits (bits_of_mem_bytes bytes) with
-         | Just v -> return (v, tag)
+         | Just v -> return v
          | Nothing -> Fail "bits_of_mem_bytes"
        end)
 
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 0e7addbb..07a6215b 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -8,28 +8,32 @@ open import {isabelle} `Sail2_state_monad_lemmas`
 (* Lifting from prompt monad to state monad *)
 val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e
 let rec liftState ra m = match m with
-  | (Done a)                  -> returnS a
-  | (Read_mem rk a sz k)      -> bindS (read_mem_bytesS rk a sz)      (fun v -> liftState ra (k v))
-  | (Write_mem wk a sz v t k) -> bindS (write_mem_bytesS wk a sz v t) (fun v -> liftState ra (k v))
-  | (Read_reg r k)            -> bindS (read_regvalS ra r)            (fun v -> liftState ra (k v))
-  | (Excl_res k)              -> bindS (excl_resultS ())              (fun v -> liftState ra (k v))
-  | (Undefined k)             -> bindS (undefined_boolS ())           (fun v -> liftState ra (k v))
-  | (Write_reg r v k)         -> seqS (write_regvalS ra r v)          (liftState ra k)
-  | (Write_ea _ _ _ k)        -> liftState ra k
-  | (Footprint k)             -> liftState ra k
-  | (Barrier _ k)             -> liftState ra k
-  | (Print _ k)               -> liftState ra k (* TODO *)
-  | (Fail descr)              -> failS descr
-  | (Exception e)             -> throwS e
+  | (Done a)                    -> returnS a
+  | (Read_mem rk a sz k)        -> bindS (read_mem_bytesS rk a sz)        (fun v -> liftState ra (k v))
+  | (Read_tagged_mem rk a sz k) -> bindS (read_tagged_mem_bytesS rk a sz) (fun v -> liftState ra (k v))
+  | (Write_mem wk a sz v t k)   -> bindS (write_mem_bytesS wk a sz v t)   (fun v -> liftState ra (k v))
+  | (Read_reg r k)              -> bindS (read_regvalS ra r)              (fun v -> liftState ra (k v))
+  | (Excl_res k)                -> bindS (excl_resultS ())                (fun v -> liftState ra (k v))
+  | (Undefined k)               -> bindS (undefined_boolS ())             (fun v -> liftState ra (k v))
+  | (Write_reg r v k)           -> seqS (write_regvalS ra r v)            (liftState ra k)
+  | (Write_ea _ _ _ k)          -> liftState ra k
+  | (Footprint k)               -> liftState ra k
+  | (Barrier _ k)               -> liftState ra k
+  | (Print _ k)                 -> liftState ra k (* TODO *)
+  | (Fail descr)                -> failS descr
+  | (Exception e)               -> throwS e
 end
 
 val emitEventS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> event 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
 let emitEventS ra e s = match e with
-  | E_read_mem _ addr sz (v, tag) ->
+  | E_read_mem _ addr sz v ->
+     Maybe.bind (get_mem_bytes addr sz s) (fun (v', _) ->
+     if v' = v then Just s else Nothing)
+  | E_read_tagged_mem _ addr sz (v, tag) ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
      if v' = v && tag' = tag then Just s else Nothing)
-  | E_write_mem _ addr sz v tag _ ->
-     Just (put_mem_bytes addr sz v tag s)
+  | E_write_mem _ addr sz v tag success ->
+     if success then Just (put_mem_bytes addr sz v tag s) else Nothing
   | E_read_reg r v ->
      let (read_reg, _) = ra in
      Maybe.bind (read_reg r s.regstate) (fun v' ->
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 6c1cd4bd..8626052f 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -129,18 +129,28 @@ let get_mem_bytes addr sz s =
     (fun mem_val -> (mem_val, List.foldl and_bit B1 (List.map (read_tag s) addrs)))
     (just_list (List.map (read_byte s) addrs))
 
-val read_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte * bitU) 'e
-let read_mem_bytesS _ addr sz =
+val read_tagged_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte * bitU) 'e
+let read_tagged_mem_bytesS _ addr sz =
   readS (get_mem_bytes addr sz) >>$=
   maybe_failS "read_memS"
 
-val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
-let read_memS rk a sz =
+val read_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte) 'e
+let read_mem_bytesS rk addr sz =
+  read_tagged_mem_bytesS rk addr sz >>$= (fun (bytes, _) ->
+  returnS bytes)
+
+val read_tagged_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
+let read_tagged_memS rk a sz =
   maybe_failS "nat_of_bv" (nat_of_bv a) >>$= (fun a ->
-  read_mem_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
+  read_tagged_mem_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
   maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val ->
   returnS (mem_val, tag))))
 
+val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e
+let read_memS rk a sz =
+  read_tagged_memS rk a sz >>$= (fun (bytes, _) ->
+  returnS bytes)
+
 val excl_resultS : forall 'regs 'e. unit -> monadS 'regs bool 'e
 let excl_resultS =
   (* TODO: This used to be more deterministic, checking a flag in the state
-- 
cgit v1.2.3


From 747999f5c9f9234d04ef9e574a415a88e2bcb52b Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Fri, 30 Nov 2018 18:28:32 +0000
Subject: Rename Undefined outcome to Choose

It is used for nondeterministic choice, so Undefined might be
misleading.
---
 src/gen_lib/sail2_prompt.lem        | 26 ++++++++++++++++++++------
 src/gen_lib/sail2_prompt_monad.lem  | 19 ++++++++++++-------
 src/gen_lib/sail2_state.lem         | 16 +++++++++++++---
 src/gen_lib/sail2_state_lifting.lem |  2 +-
 src/gen_lib/sail2_state_monad.lem   |  9 +++++----
 5 files changed, 51 insertions(+), 21 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt.lem b/src/gen_lib/sail2_prompt.lem
index e01cc051..3cde7ade 100644
--- a/src/gen_lib/sail2_prompt.lem
+++ b/src/gen_lib/sail2_prompt.lem
@@ -38,6 +38,11 @@ end
 
 declare {isabelle} termination_argument foreachM = automatic
 
+val genlistM : forall 'a 'rv 'e. (nat -> monad 'rv 'a 'e) -> nat -> monad 'rv (list 'a) 'e
+let genlistM f n =
+  let indices = genlist (fun n -> n) n in
+  foreachM indices [] (fun n xs -> (f n >>= (fun x -> return (xs ++ [x]))))
+
 val and_boolM : forall 'rv 'e. monad 'rv bool 'e -> monad 'rv bool 'e -> monad 'rv bool 'e
 let and_boolM l r = l >>= (fun l -> if l then r else return false)
 
@@ -55,7 +60,7 @@ val bool_of_bitU_nondet : forall 'rv 'e. bitU -> monad 'rv bool 'e
 let bool_of_bitU_nondet = function
   | B0 -> return false
   | B1 -> return true
-  | BU -> undefined_bool ()
+  | BU -> choose_bool "bool_of_bitU"
 end
 
 val bools_of_bits_nondet : forall 'rv 'e. list bitU -> monad 'rv (list bool) 'e
@@ -93,16 +98,25 @@ let rec untilM vars cond body =
   cond vars >>= fun cond_val ->
   if cond_val then return vars else untilM vars cond body
 
-val internal_pick : forall 'rv 'a 'e. list 'a -> monad 'rv 'a 'e
-let internal_pick xs =
-  (* Use sufficiently many undefined bits and convert into an index into the list *)
-  bools_of_bits_nondet (repeat [BU] (length_list xs)) >>= fun bs ->
+val choose_bools : forall 'rv 'e. string -> nat -> monad 'rv (list bool) 'e
+let choose_bools descr n = genlistM (fun _ -> choose_bool descr) n
+
+val choose : forall 'rv 'a 'e. string -> list 'a -> monad 'rv 'a 'e
+let choose descr xs =
+  (* Use sufficiently many nondeterministically chosen bits and convert into an
+     index into the list *)
+  choose_bools descr (List.length xs) >>= fun bs ->
   let idx = (natFromNatural (nat_of_bools bs)) mod List.length xs in
   match index xs idx with
     | Just x -> return x
-    | Nothing -> Fail "internal_pick"
+    | Nothing -> Fail ("choose " ^ descr)
   end
 
+declare {isabelle} rename function choose = chooseM
+
+val internal_pick : forall 'rv 'a 'e. list 'a -> monad 'rv 'a 'e
+let internal_pick xs = choose "internal_pick" xs
+
 (*let write_two_regs r1 r2 vec =
   let is_inc =
     let is_inc_r1 = is_inc_of_reg r1 in
diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 079375a3..c6249d7a 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -29,8 +29,10 @@ type monad 'regval 'a 'e =
   | Read_reg of register_name * ('regval -> monad 'regval 'a 'e)
   (* Request to write register *)
   | Write_reg of register_name * 'regval * monad 'regval 'a 'e
-  (* Request to choose a Boolean, e.g. to resolve an undefined bit *)
-  | Undefined of (bool -> monad 'regval 'a 'e)
+  (* Request to choose a Boolean, e.g. to resolve an undefined bit. The string
+     argument may be used to provide information to the system about what the
+     Boolean is going to be used for. *)
+  | Choose of string * (bool -> monad 'regval 'a 'e)
   (* Print debugging or tracing information *)
   | Print of string * monad 'regval 'a 'e
   (*Result of a failed assert with possible error message to report*)
@@ -48,7 +50,7 @@ type event 'regval =
   | E_footprint
   | E_read_reg of register_name * 'regval
   | E_write_reg of register_name * 'regval
-  | E_undefined of bool
+  | E_choose of string * bool
   | E_print of string
 
 type trace 'regval = list (event 'regval)
@@ -64,7 +66,7 @@ let rec bind m f = match m with
   | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> bind (k v) f)
   | Read_reg descr k ->          Read_reg descr          (fun v -> bind (k v) f)
   | Excl_res k ->                Excl_res                (fun v -> bind (k v) f)
-  | Undefined k ->               Undefined               (fun v -> bind (k v) f)
+  | Choose descr k ->            Choose descr            (fun v -> bind (k v) f)
   | Write_ea wk a sz k ->        Write_ea wk a sz        (bind k f)
   | Footprint k ->               Footprint               (bind k f)
   | Barrier bk k ->              Barrier bk              (bind k f)
@@ -77,8 +79,11 @@ end
 val exit : forall 'rv 'a 'e. unit -> monad 'rv 'a 'e
 let exit () = Fail "exit"
 
+val choose_bool : forall 'rv 'e. string -> monad 'rv bool 'e
+let choose_bool descr = Choose descr return
+
 val undefined_bool : forall 'rv 'e. unit -> monad 'rv bool 'e
-let undefined_bool () = Undefined return
+let undefined_bool () = choose_bool "undefined_bool"
 
 val assert_exp : forall 'rv 'e. bool -> string -> monad 'rv unit 'e
 let assert_exp exp msg = if exp then Done () else Fail msg
@@ -94,7 +99,7 @@ let rec try_catch m h = match m with
   | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> try_catch (k v) h)
   | Read_reg descr k ->          Read_reg descr          (fun v -> try_catch (k v) h)
   | Excl_res k ->                Excl_res                (fun v -> try_catch (k v) h)
-  | Undefined k ->               Undefined               (fun v -> try_catch (k v) h)
+  | Choose descr k ->            Choose descr            (fun v -> try_catch (k v) h)
   | Write_ea wk a sz k ->        Write_ea wk a sz        (try_catch k h)
   | Footprint k ->               Footprint               (try_catch k h)
   | Barrier bk k ->              Barrier bk              (try_catch k h)
@@ -267,7 +272,7 @@ let emitEvent m e = match (e, m) with
   | (E_print m, Print m' k) ->
      if m' = m then Just k else Nothing
   | (E_excl_res v, Excl_res k) -> Just (k v)
-  | (E_undefined v, Undefined k) -> Just (k v)
+  | (E_choose descr v, Choose descr' k) -> if descr' = descr then Just (k v) else Nothing
   | (E_footprint, Footprint k) -> Just k
   | _ -> Nothing
 end
diff --git a/src/gen_lib/sail2_state.lem b/src/gen_lib/sail2_state.lem
index f703dead..ec787764 100644
--- a/src/gen_lib/sail2_state.lem
+++ b/src/gen_lib/sail2_state.lem
@@ -28,6 +28,11 @@ end
 
 declare {isabelle} termination_argument foreachS = automatic
 
+val genlistS : forall 'a 'rv 'e. (nat -> monadS 'rv 'a 'e) -> nat -> monadS 'rv (list 'a) 'e
+let genlistS f n =
+  let indices = genlist (fun n -> n) n in
+  foreachS indices [] (fun n xs -> (f n >>$= (fun x -> returnS (xs ++ [x]))))
+
 val and_boolS : forall 'rv 'e. monadS 'rv bool 'e -> monadS 'rv bool 'e -> monadS 'rv bool 'e
 let and_boolS l r = l >>$= (fun l -> if l then r else returnS false)
 
@@ -84,12 +89,17 @@ let rec untilS vars cond body s =
   (cond vars >>$= (fun cond_val s'' ->
   if cond_val then returnS vars s'' else untilS vars cond body s'')) s')) s
 
+val choose_boolsS : forall 'rv 'e. nat -> monadS 'rv (list bool) 'e
+let choose_boolsS n = genlistS (fun _ -> choose_boolS ()) n
+
+(* TODO: Replace by chooseS and prove equivalence to prompt monad version *)
 val internal_pickS : forall 'rv 'a 'e. list 'a -> monadS 'rv 'a 'e
 let internal_pickS xs =
-  (* Use sufficiently many undefined bits and convert into an index into the list *)
-  bools_of_bits_nondetS (repeat [BU] (length_list xs)) >>$= fun bs ->
+  (* Use sufficiently many nondeterministically chosen bits and convert into an
+     index into the list *)
+  choose_boolsS (List.length xs) >>$= fun bs ->
   let idx = (natFromNatural (nat_of_bools bs)) mod List.length xs in
   match index xs idx with
     | Just x -> returnS x
-    | Nothing -> failS "internal_pick"
+    | Nothing -> failS "choose internal_pick"
   end
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index 07a6215b..c227e89b 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -14,7 +14,7 @@ let rec liftState ra m = match m with
   | (Write_mem wk a sz v t k)   -> bindS (write_mem_bytesS wk a sz v t)   (fun v -> liftState ra (k v))
   | (Read_reg r k)              -> bindS (read_regvalS ra r)              (fun v -> liftState ra (k v))
   | (Excl_res k)                -> bindS (excl_resultS ())                (fun v -> liftState ra (k v))
-  | (Undefined k)               -> bindS (undefined_boolS ())             (fun v -> liftState ra (k v))
+  | (Choose _ k)                -> bindS (choose_boolS ())                (fun v -> liftState ra (k v))
   | (Write_reg r v k)           -> seqS (write_regvalS ra r v)            (liftState ra k)
   | (Write_ea _ _ _ k)          -> liftState ra k
   | (Footprint k)               -> liftState ra k
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 8626052f..b2a7bb31 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -47,8 +47,8 @@ let seqS m n = bindS m (fun (_ : unit) -> n)
 let inline (>>$=) = bindS
 let inline (>>$) = seqS
 
-val chooseS : forall 'regs 'a 'e. SetType 'a => set 'a -> monadS 'regs 'a 'e
-let chooseS xs s = Set.map (fun x -> (Value x, s)) xs
+val chooseS : forall 'regs 'a 'e. SetType 'a => list 'a -> monadS 'regs 'a 'e
+let chooseS xs s = Set.fromList (List.map (fun x -> (Value x, s)) xs)
 
 val readS : forall 'regs 'a 'e. (sequential_state 'regs -> 'a) -> monadS 'regs 'a 'e
 let readS f = (fun s -> returnS (f s) s)
@@ -59,8 +59,9 @@ let updateS f = (fun s -> returnS () (f s))
 val failS : forall 'regs 'a 'e. string -> monadS 'regs 'a 'e
 let failS msg s = {(Ex (Failure msg), s)}
 
-val undefined_boolS : forall 'regval 'regs 'a 'e. unit -> monadS 'regs bool 'e
-let undefined_boolS () = chooseS {false; true}
+val choose_boolS : forall 'regval 'regs 'a 'e. unit -> monadS 'regs bool 'e
+let choose_boolS () = chooseS [false; true]
+let undefined_boolS = choose_boolS
 
 val exitS : forall 'regs 'e 'a. unit -> monadS 'regs 'a 'e
 let exitS () = failS "exit"
-- 
cgit v1.2.3


From b4495040178bc7552acc76c14de7151583456ee6 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Mon, 3 Dec 2018 12:42:32 +0000
Subject: Make names of memory r/w events more consistent

Use E_read_memt for reading tagged memory, as in sail2_impl_base.lem,
and rename E_write_mem to E_write_memt, since it always writes a tag.
---
 src/gen_lib/sail2_prompt_monad.lem  | 76 ++++++++++++++++++-------------------
 src/gen_lib/sail2_state_lifting.lem | 32 ++++++++--------
 src/gen_lib/sail2_state_monad.lem   | 14 +++----
 3 files changed, 61 insertions(+), 61 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index c6249d7a..cf2fd151 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -12,7 +12,7 @@ type monad 'regval 'a 'e =
      with or without a tag.  The first nat specifies the address, the second
      the number of bytes. *)
   | Read_mem of read_kind * nat * nat * (list memory_byte -> monad 'regval 'a 'e)
-  | Read_tagged_mem of read_kind * nat * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
+  | Read_memt of read_kind * nat * nat * ((list memory_byte * bitU) -> monad 'regval 'a 'e)
   (* Tell the system a write is imminent, at the given address and with the
      given size. *)
   | Write_ea of write_kind * nat * nat * monad 'regval 'a 'e
@@ -20,7 +20,7 @@ type monad 'regval 'a 'e =
   | Excl_res of (bool -> monad 'regval 'a 'e)
   (* Request to write a memory value of the given size together with a tag
      at the given address. *)
-  | Write_mem of write_kind * nat * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
+  | Write_memt of write_kind * nat * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
   (* Tell the system to dynamically recalculate dependency footprint *)
   | Footprint of monad 'regval 'a 'e
   (* Request a memory barrier *)
@@ -42,8 +42,8 @@ type monad 'regval 'a 'e =
 
 type event 'regval =
   | E_read_mem of read_kind * nat * nat * list memory_byte
-  | E_read_tagged_mem of read_kind * nat * nat * (list memory_byte * bitU)
-  | E_write_mem of write_kind * nat * nat * list memory_byte * bitU * bool
+  | E_read_memt of read_kind * nat * nat * (list memory_byte * bitU)
+  | E_write_memt of write_kind * nat * nat * list memory_byte * bitU * bool
   | E_write_ea of write_kind * nat * nat
   | E_excl_res of bool
   | E_barrier of barrier_kind
@@ -61,19 +61,19 @@ let return a = Done a
 val bind : forall 'rv 'a 'b 'e. monad 'rv 'a 'e -> ('a -> monad 'rv 'b 'e) -> monad 'rv 'b 'e
 let rec bind m f = match m with
   | Done a -> f a
-  | Read_mem rk a sz k ->        Read_mem rk a sz        (fun v -> bind (k v) f)
-  | Read_tagged_mem rk a sz k -> Read_tagged_mem rk a sz (fun v -> bind (k v) f)
-  | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> bind (k v) f)
-  | Read_reg descr k ->          Read_reg descr          (fun v -> bind (k v) f)
-  | Excl_res k ->                Excl_res                (fun v -> bind (k v) f)
-  | Choose descr k ->            Choose descr            (fun v -> bind (k v) f)
-  | Write_ea wk a sz k ->        Write_ea wk a sz        (bind k f)
-  | Footprint k ->               Footprint               (bind k f)
-  | Barrier bk k ->              Barrier bk              (bind k f)
-  | Write_reg r v k ->           Write_reg r v           (bind k f)
-  | Print msg k ->               Print msg               (bind k f)
-  | Fail descr ->                Fail descr
-  | Exception e ->               Exception e
+  | Read_mem rk a sz k ->       Read_mem rk a sz       (fun v -> bind (k v) f)
+  | Read_memt rk a sz k ->      Read_memt rk a sz      (fun v -> bind (k v) f)
+  | Write_memt wk a sz v t k -> Write_memt wk a sz v t (fun v -> bind (k v) f)
+  | Read_reg descr k ->         Read_reg descr         (fun v -> bind (k v) f)
+  | Excl_res k ->               Excl_res               (fun v -> bind (k v) f)
+  | Choose descr k ->           Choose descr           (fun v -> bind (k v) f)
+  | Write_ea wk a sz k ->       Write_ea wk a sz       (bind k f)
+  | Footprint k ->              Footprint              (bind k f)
+  | Barrier bk k ->             Barrier bk             (bind k f)
+  | Write_reg r v k ->          Write_reg r v          (bind k f)
+  | Print msg k ->              Print msg              (bind k f)
+  | Fail descr ->               Fail descr
+  | Exception e ->              Exception e
 end
 
 val exit : forall 'rv 'a 'e. unit -> monad 'rv 'a 'e
@@ -94,19 +94,19 @@ let throw e = Exception e
 val try_catch : forall 'rv 'a 'e1 'e2. monad 'rv 'a 'e1 -> ('e1 -> monad 'rv 'a 'e2) -> monad 'rv 'a 'e2
 let rec try_catch m h = match m with
   | Done a -> Done a
-  | Read_mem rk a sz k ->        Read_mem rk a sz        (fun v -> try_catch (k v) h)
-  | Read_tagged_mem rk a sz k -> Read_tagged_mem rk a sz (fun v -> try_catch (k v) h)
-  | Write_mem wk a sz v t k ->   Write_mem wk a sz v t   (fun v -> try_catch (k v) h)
-  | Read_reg descr k ->          Read_reg descr          (fun v -> try_catch (k v) h)
-  | Excl_res k ->                Excl_res                (fun v -> try_catch (k v) h)
-  | Choose descr k ->            Choose descr            (fun v -> try_catch (k v) h)
-  | Write_ea wk a sz k ->        Write_ea wk a sz        (try_catch k h)
-  | Footprint k ->               Footprint               (try_catch k h)
-  | Barrier bk k ->              Barrier bk              (try_catch k h)
-  | Write_reg r v k ->           Write_reg r v           (try_catch k h)
-  | Print msg k ->               Print msg               (try_catch k h)
-  | Fail descr ->                Fail descr
-  | Exception e ->               h e
+  | Read_mem rk a sz k ->       Read_mem rk a sz       (fun v -> try_catch (k v) h)
+  | Read_memt rk a sz k ->      Read_memt rk a sz      (fun v -> try_catch (k v) h)
+  | Write_memt wk a sz v t k -> Write_memt wk a sz v t (fun v -> try_catch (k v) h)
+  | Read_reg descr k ->         Read_reg descr         (fun v -> try_catch (k v) h)
+  | Excl_res k ->               Excl_res               (fun v -> try_catch (k v) h)
+  | Choose descr k ->           Choose descr           (fun v -> try_catch (k v) h)
+  | Write_ea wk a sz k ->       Write_ea wk a sz       (try_catch k h)
+  | Footprint k ->              Footprint              (try_catch k h)
+  | Barrier bk k ->             Barrier bk             (try_catch k h)
+  | Write_reg r v k ->          Write_reg r v          (try_catch k h)
+  | Print msg k ->              Print msg              (try_catch k h)
+  | Fail descr ->               Fail descr
+  | Exception e ->              h e
 end
 
 (* For early return, we abuse exceptions by throwing and catching
@@ -144,16 +144,16 @@ let maybe_fail msg = function
   | Nothing -> Fail msg
 end
 
-val read_tagged_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
-let read_tagged_mem_bytes rk addr sz =
+val read_memt_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e
+let read_memt_bytes rk addr sz =
   bind
     (maybe_fail "nat_of_bv" (nat_of_bv addr))
-    (fun addr -> Read_tagged_mem rk addr (nat_of_int sz) return)
+    (fun addr -> Read_memt rk addr (nat_of_int sz) return)
 
-val read_tagged_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
-let read_tagged_mem rk addr sz =
+val read_memt : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e
+let read_memt rk addr sz =
   bind
-    (read_tagged_mem_bytes rk addr sz)
+    (read_memt_bytes rk addr sz)
     (fun (bytes, tag) ->
        match of_bits (bits_of_mem_bytes bytes) with
          | Just v -> return (v, tag)
@@ -192,7 +192,7 @@ val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
 let write_mem wk addr sz v tag =
   match (mem_bytes_of_bits v, nat_of_bv addr) with
     | (Just v, Just addr) ->
-       Write_mem wk addr (nat_of_int sz) v tag return
+       Write_memt wk addr (nat_of_int sz) v tag return
     | _ -> Fail "write_mem"
   end
 
@@ -259,7 +259,7 @@ val emitEvent : forall 'regval 'a 'e. Eq 'regval => monad 'regval 'a 'e -> event
 let emitEvent m e = match (e, m) with
   | (E_read_mem rk a sz v, Read_mem rk' a' sz' k) ->
      if rk' = rk && a' = a && sz' = sz then Just (k v) else Nothing
-  | (E_write_mem wk a sz v tag r, Write_mem wk' a' sz' v' tag' k) ->
+  | (E_write_memt wk a sz v tag r, Write_memt wk' a' sz' v' tag' k) ->
      if wk' = wk && a' = a && sz' = sz && v' = v && tag' = tag then Just (k r) else Nothing
   | (E_read_reg r v, Read_reg r' k) ->
      if r' = r then Just (k v) else Nothing
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index c227e89b..a055bfe0 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -8,20 +8,20 @@ open import {isabelle} `Sail2_state_monad_lemmas`
 (* Lifting from prompt monad to state monad *)
 val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e
 let rec liftState ra m = match m with
-  | (Done a)                    -> returnS a
-  | (Read_mem rk a sz k)        -> bindS (read_mem_bytesS rk a sz)        (fun v -> liftState ra (k v))
-  | (Read_tagged_mem rk a sz k) -> bindS (read_tagged_mem_bytesS rk a sz) (fun v -> liftState ra (k v))
-  | (Write_mem wk a sz v t k)   -> bindS (write_mem_bytesS wk a sz v t)   (fun v -> liftState ra (k v))
-  | (Read_reg r k)              -> bindS (read_regvalS ra r)              (fun v -> liftState ra (k v))
-  | (Excl_res k)                -> bindS (excl_resultS ())                (fun v -> liftState ra (k v))
-  | (Choose _ k)                -> bindS (choose_boolS ())                (fun v -> liftState ra (k v))
-  | (Write_reg r v k)           -> seqS (write_regvalS ra r v)            (liftState ra k)
-  | (Write_ea _ _ _ k)          -> liftState ra k
-  | (Footprint k)               -> liftState ra k
-  | (Barrier _ k)               -> liftState ra k
-  | (Print _ k)                 -> liftState ra k (* TODO *)
-  | (Fail descr)                -> failS descr
-  | (Exception e)               -> throwS e
+  | (Done a)                   -> returnS a
+  | (Read_mem rk a sz k)       -> bindS (read_mem_bytesS rk a sz)      (fun v -> liftState ra (k v))
+  | (Read_memt rk a sz k)      -> bindS (read_memt_bytesS rk a sz)     (fun v -> liftState ra (k v))
+  | (Write_memt wk a sz v t k) -> bindS (write_mem_bytesS wk a sz v t) (fun v -> liftState ra (k v))
+  | (Read_reg r k)             -> bindS (read_regvalS ra r)            (fun v -> liftState ra (k v))
+  | (Excl_res k)               -> bindS (excl_resultS ())              (fun v -> liftState ra (k v))
+  | (Choose _ k)               -> bindS (choose_boolS ())              (fun v -> liftState ra (k v))
+  | (Write_reg r v k)          -> seqS (write_regvalS ra r v)          (liftState ra k)
+  | (Write_ea _ _ _ k)         -> liftState ra k
+  | (Footprint k)              -> liftState ra k
+  | (Barrier _ k)              -> liftState ra k
+  | (Print _ k)                -> liftState ra k (* TODO *)
+  | (Fail descr)               -> failS descr
+  | (Exception e)              -> throwS e
 end
 
 val emitEventS : forall 'regval 'regs 'a 'e. Eq 'regval => register_accessors 'regs 'regval -> event 'regval -> sequential_state 'regs -> maybe (sequential_state 'regs)
@@ -29,10 +29,10 @@ let emitEventS ra e s = match e with
   | E_read_mem _ addr sz v ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', _) ->
      if v' = v then Just s else Nothing)
-  | E_read_tagged_mem _ addr sz (v, tag) ->
+  | E_read_memt _ addr sz (v, tag) ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
      if v' = v && tag' = tag then Just s else Nothing)
-  | E_write_mem _ addr sz v tag success ->
+  | E_write_memt _ addr sz v tag success ->
      if success then Just (put_mem_bytes addr sz v tag s) else Nothing
   | E_read_reg r v ->
      let (read_reg, _) = ra in
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index b2a7bb31..18e57b30 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -130,26 +130,26 @@ let get_mem_bytes addr sz s =
     (fun mem_val -> (mem_val, List.foldl and_bit B1 (List.map (read_tag s) addrs)))
     (just_list (List.map (read_byte s) addrs))
 
-val read_tagged_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte * bitU) 'e
-let read_tagged_mem_bytesS _ addr sz =
+val read_memt_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte * bitU) 'e
+let read_memt_bytesS _ addr sz =
   readS (get_mem_bytes addr sz) >>$=
   maybe_failS "read_memS"
 
 val read_mem_bytesS : forall 'regs 'e. read_kind -> nat -> nat -> monadS 'regs (list memory_byte) 'e
 let read_mem_bytesS rk addr sz =
-  read_tagged_mem_bytesS rk addr sz >>$= (fun (bytes, _) ->
+  read_memt_bytesS rk addr sz >>$= (fun (bytes, _) ->
   returnS bytes)
 
-val read_tagged_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
-let read_tagged_memS rk a sz =
+val read_memtS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs ('b * bitU) 'e
+let read_memtS rk a sz =
   maybe_failS "nat_of_bv" (nat_of_bv a) >>$= (fun a ->
-  read_tagged_mem_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
+  read_memt_bytesS rk a (nat_of_int sz) >>$= (fun (bytes, tag) ->
   maybe_failS "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes)) >>$= (fun mem_val ->
   returnS (mem_val, tag))))
 
 val read_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monadS 'regs 'b 'e
 let read_memS rk a sz =
-  read_tagged_memS rk a sz >>$= (fun (bytes, _) ->
+  read_memtS rk a sz >>$= (fun (bytes, _) ->
   returnS bytes)
 
 val excl_resultS : forall 'regs 'e. unit -> monadS 'regs bool 'e
-- 
cgit v1.2.3


From df0e02bc0c8259962f25d4c175fa950391695ab6 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Mon, 3 Dec 2018 16:03:24 +0000
Subject: Add Write_mem event/outcome without tag

The inter-instruction semantics is responsible for correctly handling memory
writes without tags; the lifting to the state monad handles it as writing a
value with a zero tag bit.
---
 src/gen_lib/sail2_prompt_monad.lem  | 21 ++++++++++++++++++---
 src/gen_lib/sail2_state_lifting.lem | 17 ++++++++++-------
 src/gen_lib/sail2_state_monad.lem   | 23 +++++++++++++++--------
 3 files changed, 43 insertions(+), 18 deletions(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index cf2fd151..7a55056c 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -18,8 +18,9 @@ type monad 'regval 'a 'e =
   | Write_ea of write_kind * nat * nat * monad 'regval 'a 'e
   (* Request the result of store-exclusive *)
   | Excl_res of (bool -> monad 'regval 'a 'e)
-  (* Request to write a memory value of the given size together with a tag
-     at the given address. *)
+  (* Request to write a memory value of the given size at the given address,
+     with or without a tag. *)
+  | Write_mem of write_kind * nat * nat * list memory_byte * (bool -> monad 'regval 'a 'e)
   | Write_memt of write_kind * nat * nat * list memory_byte * bitU * (bool -> monad 'regval 'a 'e)
   (* Tell the system to dynamically recalculate dependency footprint *)
   | Footprint of monad 'regval 'a 'e
@@ -43,6 +44,7 @@ type monad 'regval 'a 'e =
 type event 'regval =
   | E_read_mem of read_kind * nat * nat * list memory_byte
   | E_read_memt of read_kind * nat * nat * (list memory_byte * bitU)
+  | E_write_mem of write_kind * nat * nat * list memory_byte * bool
   | E_write_memt of write_kind * nat * nat * list memory_byte * bitU * bool
   | E_write_ea of write_kind * nat * nat
   | E_excl_res of bool
@@ -63,6 +65,7 @@ let rec bind m f = match m with
   | Done a -> f a
   | Read_mem rk a sz k ->       Read_mem rk a sz       (fun v -> bind (k v) f)
   | Read_memt rk a sz k ->      Read_memt rk a sz      (fun v -> bind (k v) f)
+  | Write_mem wk a sz v k ->    Write_mem wk a sz v    (fun v -> bind (k v) f)
   | Write_memt wk a sz v t k -> Write_memt wk a sz v t (fun v -> bind (k v) f)
   | Read_reg descr k ->         Read_reg descr         (fun v -> bind (k v) f)
   | Excl_res k ->               Excl_res               (fun v -> bind (k v) f)
@@ -96,6 +99,7 @@ let rec try_catch m h = match m with
   | Done a -> Done a
   | Read_mem rk a sz k ->       Read_mem rk a sz       (fun v -> try_catch (k v) h)
   | Read_memt rk a sz k ->      Read_memt rk a sz      (fun v -> try_catch (k v) h)
+  | Write_mem wk a sz v k ->    Write_mem wk a sz v    (fun v -> try_catch (k v) h)
   | Write_memt wk a sz v t k -> Write_memt wk a sz v t (fun v -> try_catch (k v) h)
   | Read_reg descr k ->         Read_reg descr         (fun v -> try_catch (k v) h)
   | Excl_res k ->               Excl_res               (fun v -> try_catch (k v) h)
@@ -188,8 +192,17 @@ let write_mem_ea wk addr sz =
     (fun addr -> Write_ea wk addr (nat_of_int sz) (Done ()))
 
 val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
+  write_kind -> 'a -> integer -> 'b -> monad 'rv bool 'e
+let write_mem wk addr sz v =
+  match (mem_bytes_of_bits v, nat_of_bv addr) with
+    | (Just v, Just addr) ->
+       Write_mem wk addr (nat_of_int sz) v return
+    | _ -> Fail "write_mem"
+  end
+
+val write_memt : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
   write_kind -> 'a -> integer -> 'b -> bitU -> monad 'rv bool 'e
-let write_mem wk addr sz v tag =
+let write_memt wk addr sz v tag =
   match (mem_bytes_of_bits v, nat_of_bv addr) with
     | (Just v, Just addr) ->
        Write_memt wk addr (nat_of_int sz) v tag return
@@ -259,6 +272,8 @@ val emitEvent : forall 'regval 'a 'e. Eq 'regval => monad 'regval 'a 'e -> event
 let emitEvent m e = match (e, m) with
   | (E_read_mem rk a sz v, Read_mem rk' a' sz' k) ->
      if rk' = rk && a' = a && sz' = sz then Just (k v) else Nothing
+  | (E_write_mem wk a sz v r, Write_mem wk' a' sz' v' k) ->
+     if wk' = wk && a' = a && sz' = sz && v' = v then Just (k r) else Nothing
   | (E_write_memt wk a sz v tag r, Write_memt wk' a' sz' v' tag' k) ->
      if wk' = wk && a' = a && sz' = sz && v' = v && tag' = tag then Just (k r) else Nothing
   | (E_read_reg r v, Read_reg r' k) ->
diff --git a/src/gen_lib/sail2_state_lifting.lem b/src/gen_lib/sail2_state_lifting.lem
index a055bfe0..98a5390d 100644
--- a/src/gen_lib/sail2_state_lifting.lem
+++ b/src/gen_lib/sail2_state_lifting.lem
@@ -9,13 +9,14 @@ open import {isabelle} `Sail2_state_monad_lemmas`
 val liftState : forall 'regval 'regs 'a 'e. register_accessors 'regs 'regval -> monad 'regval 'a 'e -> monadS 'regs 'a 'e
 let rec liftState ra m = match m with
   | (Done a)                   -> returnS a
-  | (Read_mem rk a sz k)       -> bindS (read_mem_bytesS rk a sz)      (fun v -> liftState ra (k v))
-  | (Read_memt rk a sz k)      -> bindS (read_memt_bytesS rk a sz)     (fun v -> liftState ra (k v))
-  | (Write_memt wk a sz v t k) -> bindS (write_mem_bytesS wk a sz v t) (fun v -> liftState ra (k v))
-  | (Read_reg r k)             -> bindS (read_regvalS ra r)            (fun v -> liftState ra (k v))
-  | (Excl_res k)               -> bindS (excl_resultS ())              (fun v -> liftState ra (k v))
-  | (Choose _ k)               -> bindS (choose_boolS ())              (fun v -> liftState ra (k v))
-  | (Write_reg r v k)          -> seqS (write_regvalS ra r v)          (liftState ra k)
+  | (Read_mem rk a sz k)       -> bindS (read_mem_bytesS rk a sz)       (fun v -> liftState ra (k v))
+  | (Read_memt rk a sz k)      -> bindS (read_memt_bytesS rk a sz)      (fun v -> liftState ra (k v))
+  | (Write_mem wk a sz v k)    -> bindS (write_mem_bytesS wk a sz v)    (fun v -> liftState ra (k v))
+  | (Write_memt wk a sz v t k) -> bindS (write_memt_bytesS wk a sz v t) (fun v -> liftState ra (k v))
+  | (Read_reg r k)             -> bindS (read_regvalS ra r)             (fun v -> liftState ra (k v))
+  | (Excl_res k)               -> bindS (excl_resultS ())               (fun v -> liftState ra (k v))
+  | (Choose _ k)               -> bindS (choose_boolS ())               (fun v -> liftState ra (k v))
+  | (Write_reg r v k)          -> seqS (write_regvalS ra r v)           (liftState ra k)
   | (Write_ea _ _ _ k)         -> liftState ra k
   | (Footprint k)              -> liftState ra k
   | (Barrier _ k)              -> liftState ra k
@@ -32,6 +33,8 @@ let emitEventS ra e s = match e with
   | E_read_memt _ addr sz (v, tag) ->
      Maybe.bind (get_mem_bytes addr sz s) (fun (v', tag') ->
      if v' = v && tag' = tag then Just s else Nothing)
+  | E_write_mem _ addr sz v success ->
+     if success then Just (put_mem_bytes addr sz v B0 s) else Nothing
   | E_write_memt _ addr sz v tag success ->
      if success then Just (put_mem_bytes addr sz v tag s) else Nothing
   | E_read_reg r v ->
diff --git a/src/gen_lib/sail2_state_monad.lem b/src/gen_lib/sail2_state_monad.lem
index 18e57b30..3042700c 100644
--- a/src/gen_lib/sail2_state_monad.lem
+++ b/src/gen_lib/sail2_state_monad.lem
@@ -162,27 +162,34 @@ let excl_resultS =
 
 (* Write little-endian list of bytes to given address *)
 val put_mem_bytes : forall 'regs. nat -> nat -> list memory_byte -> bitU -> sequential_state 'regs -> sequential_state 'regs
-let put_mem_bytes addr sz v t s =
+let put_mem_bytes addr sz v tag s =
   let addrs = genlist (fun n -> addr + n) sz in
   let a_v = List.zip addrs v in
   let write_byte mem (addr, v) = Map.insert addr v mem in
-  let write_tag mem addr = Map.insert addr t mem in
+  let write_tag mem addr = Map.insert addr tag mem in
   <| s with memstate = List.foldl write_byte s.memstate a_v;
             tagstate = List.foldl write_tag s.tagstate addrs |>
 
-val write_mem_bytesS : forall 'regs 'e. write_kind -> nat -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
-let write_mem_bytesS _ addr sz v t =
+val write_memt_bytesS : forall 'regs 'e. write_kind -> nat -> nat -> list memory_byte -> bitU -> monadS 'regs bool 'e
+let write_memt_bytesS _ addr sz v t =
   updateS (put_mem_bytes addr sz v t) >>$
   returnS true
 
-val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
-  write_kind -> 'a -> nat -> 'b -> bitU -> monadS 'regs bool 'e
-let write_memS wk addr sz v t =
+val write_mem_bytesS : forall 'regs 'e. write_kind -> nat -> nat -> list memory_byte -> monadS 'regs bool 'e
+let write_mem_bytesS wk addr sz v = write_memt_bytesS wk addr sz v B0
+
+val write_memtS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
+  write_kind -> 'a -> integer -> 'b -> bitU -> monadS 'regs bool 'e
+let write_memtS wk addr sz v t =
   match (nat_of_bv addr, mem_bytes_of_bits v) with
-    | (Just addr, Just v) -> write_mem_bytesS wk addr sz v t
+    | (Just addr, Just v) -> write_memt_bytesS wk addr (nat_of_int sz) v t
     | _ -> failS "write_mem"
   end
 
+val write_memS : forall 'regs 'e 'a 'b. Bitvector 'a, Bitvector 'b =>
+  write_kind -> 'a -> integer -> 'b -> monadS 'regs bool 'e
+let write_memS wk addr sz v = write_memtS wk addr sz v B0
+
 val read_regS : forall 'regs 'rv 'a 'e. register_ref 'regs 'rv 'a -> monadS 'regs 'a 'e
 let read_regS reg = readS (fun s -> reg.read_from s.regstate)
 
-- 
cgit v1.2.3


From 586b5f5c27bef271a9a013cad8d5b132df354c23 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 17 Dec 2018 20:29:11 +0000
Subject: Changes for ASL parser

---
 src/ast_util.ml   |  1 +
 src/ast_util.mli  |  5 +++--
 src/nl_flow.ml    |  2 +-
 src/type_check.ml | 54 +++++++++++++++++++++++++++++++++++++++++-------------
 src/type_error.ml | 49 ++++++++++++-------------------------------------
 5 files changed, 58 insertions(+), 53 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index a771291e..795a41fe 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -365,6 +365,7 @@ let range_typ nexp1 nexp2 =
   mk_typ (Typ_app (mk_id "range", [mk_typ_arg (A_nexp (nexp_simp nexp1));
                                    mk_typ_arg (A_nexp (nexp_simp nexp2))]))
 let bool_typ = mk_id_typ (mk_id "bool")
+let atom_bool_typ nc = mk_typ (Typ_app (mk_id "atom_bool", [mk_typ_arg (A_bool nc)]))
 let string_typ = mk_id_typ (mk_id "string")
 let list_typ typ = mk_typ (Typ_app (mk_id "list", [mk_typ_arg (A_typ typ)]))
 let tuple_typ typs = mk_typ (Typ_tup typs)
diff --git a/src/ast_util.mli b/src/ast_util.mli
index ca3a9598..7a44322d 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -113,7 +113,7 @@ val is_nat_kopt : kinded_id -> bool
 val is_order_kopt : kinded_id -> bool
 val is_typ_kopt : kinded_id -> bool
 val is_bool_kopt : kinded_id -> bool
-  
+
 (* Some handy utility functions for constructing types. *)
 val mk_typ : typ_aux -> typ
 val mk_typ_arg : typ_arg_aux -> typ_arg
@@ -127,6 +127,7 @@ val atom_typ : nexp -> typ
 val range_typ : nexp -> nexp -> typ
 val bit_typ : typ
 val bool_typ : typ
+val atom_bool_typ : n_constraint -> typ
 val app_typ : id -> typ_arg list -> typ
 val register_typ : typ -> typ
 val unit_typ : typ
@@ -191,7 +192,7 @@ val quant_map_items : (quant_item -> quant_item) -> typquant -> typquant
 
 val is_quant_kopt : quant_item -> bool
 val is_quant_constraint : quant_item -> bool
-  
+
 (* Functions to map over the annotations in sub-expressions *)
 val map_exp_annot : ('a annot -> 'b annot) -> 'a exp -> 'b exp
 val map_pat_annot : ('a annot -> 'b annot) -> 'a pat -> 'b pat
diff --git a/src/nl_flow.ml b/src/nl_flow.ml
index e38e5fa5..6196f23b 100644
--- a/src/nl_flow.ml
+++ b/src/nl_flow.ml
@@ -91,7 +91,7 @@ let add_assert cond (E_aux (aux, (l, ())) as exp) =
 let modify_unsigned id value (E_aux (aux, annot) as exp) =
   match aux with
   | E_let (LB_aux (LB_val (pat, E_aux (E_app (f, [E_aux (E_id id', _)]), _)), _) as lb, exp')
-       when string_of_id f = "unsigned" && Id.compare id id' = 0 ->
+       when (string_of_id f = "unsigned" || string_of_id f = "UInt") && Id.compare id id' = 0 ->
      begin match pat_id pat with
      | None -> exp
      | Some uid ->
diff --git a/src/type_check.ml b/src/type_check.ml
index 53d87a05..09ee3380 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -259,10 +259,19 @@ let destruct_numeric typ =
      Some ([kid], nc_true, nvar kid)
   | _, _ -> None
 
+let destruct_boolean = function
+  | Typ_aux (Typ_id (Id_aux (Id "bool", _)), _) ->
+     let kid = kopt_kid (fresh_existential K_bool) in
+     Some (kid, nc_var kid)
+  | _ -> None
+
 let destruct_exist typ =
   match destruct_numeric typ with
   | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp)
-  | None -> destruct_exist_plain typ
+  | None ->
+     match destruct_boolean typ with
+     | Some (kid, nc) -> Some ([mk_kopt K_bool kid], nc_true, atom_bool_typ nc)
+     | None -> destruct_exist_plain typ
 
 let adding = Util.("Adding " |> darkgray |> clear)
 
@@ -700,8 +709,7 @@ end = struct
     | NC_var kid ->
        begin match get_typ_var kid env with
        | K_bool -> ()
-       | kind -> typ_error l ("Set constraint is badly formed, "
-                              ^ string_of_kid kid ^ " has kind "
+       | kind -> typ_error l (string_of_kid kid ^ " has kind "
                               ^ string_of_kind_aux kind ^ " but should have kind Bool")
        end
     | NC_true | NC_false -> ()
@@ -1243,7 +1251,7 @@ let prove_z3 env (NC_aux (_, l) as nc) =
   | Constraint.Sat -> typ_debug (lazy "sat"); false
   | Constraint.Unknown -> typ_debug (lazy "unknown"); false
 
-let solve env (Nexp_aux (_, l) as nexp) = 
+let solve env (Nexp_aux (_, l) as nexp) =
   typ_print (lazy (Util.("Solve " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env)
                    ^ " |- " ^ string_of_nexp nexp ^ " = ?"));
   match nexp with
@@ -1621,10 +1629,21 @@ and kid_order_arg kind_map (A_aux (aux, l) as arg) =
   | A_order _ -> ([], kind_map)
 and kid_order_constraint kind_map (NC_aux (aux, l) as nc) =
   match aux with
-  | NC_var kid when KBindings.mem kid kind_map ->
+  | NC_var kid | NC_set (kid, _) when KBindings.mem kid kind_map ->
      ([mk_kopt (unaux_kind (KBindings.find kid kind_map)) kid], KBindings.remove kid kind_map)
-  | NC_var _ -> ([], kind_map)
-  | _ -> unreachable l __POS__ "bad constraint type"
+  | NC_var _ | NC_set _ -> ([], kind_map)
+  | NC_true | NC_false -> ([], kind_map)
+  | NC_equal (n1, n2) | NC_not_equal (n1, n2) | NC_bounded_le (n1, n2) | NC_bounded_ge (n1, n2) ->
+     let ord1, kind_map = kid_order_nexp kind_map n1 in
+     let ord2, kind_map = kid_order_nexp kind_map n2 in
+     (ord1 @ ord2, kind_map)
+  | NC_app (_, args) ->
+     List.fold_left (fun (ord, kind_map) arg -> let  ord', kind_map = kid_order_arg kind_map arg in (ord @ ord', kind_map))
+                    ([], kind_map) args
+  | NC_and (nc1, nc2) | NC_or (nc1, nc2) ->
+     let ord1, kind_map = kid_order_constraint kind_map nc1 in
+     let ord2, kind_map = kid_order_constraint kind_map nc2 in
+     (ord1 @ ord2, kind_map)
 
 let rec alpha_equivalent env typ1 typ2 =
   let counter = ref 0 in
@@ -1779,7 +1798,7 @@ and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) =
   | A_nexp n1, A_nexp n2 when prove env (nc_eq n1 n2) -> ()
   | A_typ typ1, A_typ typ2 -> subtyp l env typ1 typ2
   | A_order ord1, A_order ord2 when ord_identical ord1 ord2 -> ()
-  | A_bool nc1, A_bool nc2 when nc_identical nc1 nc2 -> ()
+  | A_bool nc1, A_bool nc2 when prove env (nc_and (nc_or (nc_not nc1) nc2) (nc_or (nc_not nc2) nc1)) -> ()
   | _, _ -> typ_error l "Mismatched argument types in subtype check"
 
 let typ_equality l env typ1 typ2 =
@@ -1827,8 +1846,8 @@ let infer_lit env (L_aux (lit_aux, l) as lit) =
   | L_zero -> bit_typ
   | L_one -> bit_typ
   | L_num n -> atom_typ (nconstant n)
-  | L_true -> bool_typ
-  | L_false -> bool_typ
+  | L_true -> atom_bool_typ nc_true
+  | L_false -> atom_bool_typ nc_false
   | L_string _ -> string_typ
   | L_real _ -> real_typ
   | L_bin str ->
@@ -2256,16 +2275,25 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      end
   | E_app_infix (x, op, y), _ ->
      check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ
-  | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_prove") = 0 ->
+  | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_prove" ->
      Env.wf_constraint env nc;
      if prove env nc
      then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
      else typ_error l ("Cannot prove " ^ string_of_n_constraint nc)
-  | E_app (f, [E_aux (E_constraint nc, _)]), _ when Id.compare f (mk_id "_not_prove") = 0 ->
+  | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_not_prove" ->
      Env.wf_constraint env nc;
      if prove env nc
      then typ_error l ("Can prove " ^ string_of_n_constraint nc)
      else annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
+  | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_check" ->
+     Env.wf_typ env typ;
+     let _ = crule check_exp env exp typ in
+     annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
+  | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_not_check" ->
+     Env.wf_typ env typ;
+     if (try (ignore (crule check_exp env exp typ); false) with Type_error _ -> true)
+     then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
+     else typ_error l (Printf.sprintf "Expected _not_check(%s : %s) to fail" (string_of_exp exp) (string_of_typ typ))
   (* All constructors and mappings are treated as having one argument
      so Ctor(x, y) is checked as Ctor((x, y)) *)
   | E_app (f, x :: y :: zs), _ when Env.is_union_constructor f env || Env.is_mapping f env ->
@@ -3060,7 +3088,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
   | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp nexp)])))
   | E_constraint nc ->
      Env.wf_constraint env nc;
-     annot_exp (E_constraint nc) bool_typ
+     annot_exp (E_constraint nc) (atom_bool_typ nc)
   | E_field (exp, field) ->
      begin
        let inferred_exp = irule infer_exp env exp in
diff --git a/src/type_error.ml b/src/type_error.ml
index 9144e993..f28e4de8 100644
--- a/src/type_error.ml
+++ b/src/type_error.ml
@@ -67,38 +67,6 @@ let pp_nexp, pp_n_constraint =
   in
   pp_nexp', pp_n_constraint'
 
-let rec nexp_subst sv subst (Nexp_aux (nexp, l)) = Nexp_aux (nexp_subst_aux sv subst nexp, l)
-and nexp_subst_aux sv subst = function
-  | Nexp_id v -> Nexp_id v
-  | Nexp_var kid -> if Kid.compare kid sv = 0 then subst else Nexp_var kid
-  | Nexp_constant c -> Nexp_constant c
-  | Nexp_times (nexp1, nexp2) -> Nexp_times (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
-  | Nexp_sum (nexp1, nexp2) -> Nexp_sum (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
-  | Nexp_minus (nexp1, nexp2) -> Nexp_minus (nexp_subst sv subst nexp1, nexp_subst sv subst nexp2)
-  | Nexp_app (id, nexps) -> Nexp_app (id, List.map (nexp_subst sv subst) nexps)
-  | Nexp_exp nexp -> Nexp_exp (nexp_subst sv subst nexp)
-  | Nexp_neg nexp -> Nexp_neg (nexp_subst sv subst nexp)
-
-let rec nexp_set_to_or l subst = function
-  | [] -> typ_error l "Cannot substitute into empty nexp set"
-  | [int] -> NC_equal (subst, nconstant int)
-  | (int :: ints) -> NC_or (mk_nc (NC_equal (subst, nconstant int)), mk_nc (nexp_set_to_or l subst ints))
-
-let rec nc_subst_nexp sv subst (NC_aux (nc, l)) = NC_aux (nc_subst_nexp_aux l sv subst nc, l)
-and nc_subst_nexp_aux l sv subst = function
-  | NC_equal (n1, n2) -> NC_equal (nexp_subst sv subst n1, nexp_subst sv subst n2)
-  | NC_bounded_ge (n1, n2) -> NC_bounded_ge (nexp_subst sv subst n1, nexp_subst sv subst n2)
-  | NC_bounded_le (n1, n2) -> NC_bounded_le (nexp_subst sv subst n1, nexp_subst sv subst n2)
-  | NC_not_equal (n1, n2) -> NC_not_equal (nexp_subst sv subst n1, nexp_subst sv subst n2)
-  | NC_set (kid, ints) as set_nc ->
-     if Kid.compare kid sv = 0
-     then nexp_set_to_or l (mk_nexp subst) ints
-     else set_nc
-  | NC_or (nc1, nc2) -> NC_or (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
-  | NC_and (nc1, nc2) -> NC_and (nc_subst_nexp sv subst nc1, nc_subst_nexp sv subst nc2)
-  | NC_false -> NC_false
-  | NC_true -> NC_true
-
 type suggestion =
   | Suggest_add_constraint of n_constraint
   | Suggest_none
@@ -126,7 +94,7 @@ let rec analyze_unresolved_quant2 locals ncs = function
          | _ -> []
        in
        let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_subst v nc) ncs)) gen_kids) in
-       let nc = List.fold_left (fun nc (v, nexp) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in
+       let nc = List.fold_left (fun nc (v, nexp) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
        if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
          Suggest_add_constraint nc
        else
@@ -140,7 +108,7 @@ let rec analyze_unresolved_quant2 locals ncs = function
               []
          in
          let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_linked v nc) (Bindings.bindings locals))) gen_kids) in
-         let nc = List.fold_left (fun nc (v, nexp, _) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in
+         let nc = List.fold_left (fun nc (v, nexp, _) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
          if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
            Suggest_none
          else
@@ -171,7 +139,7 @@ let rec analyze_unresolved_quant locals ncs = function
          | _ -> []
        in
        let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_subst v nc) ncs)) gen_kids) in
-       let nc = List.fold_left (fun nc (v, nexp) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in
+       let nc = List.fold_left (fun nc (v, nexp) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
        if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
          string ("Try adding the constraint " ^ string_of_n_constraint nc)
        else
@@ -188,7 +156,7 @@ let rec analyze_unresolved_quant locals ncs = function
          (string "Try adding named type variables for"
           ^//^ string (Util.string_of_list ", " (fun (_, nexp, typ) -> string_of_nexp nexp ^ " : " ^ string_of_typ typ) substs))
          ^^ twice hardline ^^
-         let nc = List.fold_left (fun nc (v, nexp, _) -> nc_subst_nexp v (unaux_nexp nexp) nc) nc substs in
+         let nc = List.fold_left (fun nc (v, nexp, _) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
          if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
            string ("The property " ^ string_of_n_constraint nc ^ " must hold")
          else
@@ -239,7 +207,7 @@ let rec pp_type_error = function
      pp_type_error err
      ^^ hardline ^^ string "This error occured because of a previous error:"
      ^//^ pp_type_error err'
-    
+
   | Err_other str -> string str
 
 let rec string_of_type_error err =
@@ -264,6 +232,13 @@ let rec collapse_errors = function
       | Some _ -> err
       | None -> no_collapse
       end
+  | Err_because (err1, err2) as no_collapse ->
+     let err1 = collapse_errors err1 in
+     let err2 = collapse_errors err2 in
+     if string_of_type_error err1 = string_of_type_error err2 then
+       err1
+     else
+       Err_because (err1, err2)
   | err -> err
 
 let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t =
-- 
cgit v1.2.3


From 3da039c72efa210b7b162c4571925504f275a978 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Tue, 18 Dec 2018 01:56:51 +0000
Subject: Store function instantiation information within annotations, so we
 don't have to recompute it, which can be very expensive for very large
 specifications

Also additional flow typing and fixes for boolean type variables
---
 src/rewrites.ml   |   2 +
 src/type_check.ml | 297 ++++++++++++++++++++++++++++++++----------------------
 2 files changed, 179 insertions(+), 120 deletions(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 0ad4c56e..ec0ebaa7 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2365,6 +2365,8 @@ and simple_typ_aux = function
      Typ_id (mk_id "int")
   | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 ->
      Typ_id (mk_id "int")
+  | Typ_app (id, [_]) when Id.compare id (mk_id "atom_bool") = 0 ->
+     Typ_id (mk_id "bool")
   | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args))
   | Typ_fn (arg_typs, ret_typ, effs) -> Typ_fn (List.map simple_typ arg_typs, simple_typ ret_typ, effs)
   | Typ_tup typs -> Typ_tup (List.map simple_typ typs)
diff --git a/src/type_check.ml b/src/type_check.ml
index 09ee3380..dedb7015 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -139,6 +139,11 @@ let is_atom (Typ_aux (typ_aux, _)) =
   | Typ_app (f, [_]) when string_of_id f = "atom" -> true
   | _ -> false
 
+let is_atom_bool (Typ_aux (typ_aux, _)) =
+  match typ_aux with
+  | Typ_app (f, [_]) when string_of_id f = "atom_bool" -> true
+  | _ -> false
+       
 let rec strip_id = function
   | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown)
   | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown)
@@ -1590,6 +1595,12 @@ let destruct_atom_kid env typ =
        when string_of_id f = "range" && Kid.compare kid1 kid2 = 0 -> Some kid1
   | _ -> None
 
+let destruct_atom_bool env typ =
+  match Env.expand_synonyms env typ with
+  | Typ_aux (Typ_app (f, [A_aux (A_bool nc, _)]), _) when string_of_id f = "atom_bool" ->
+     Some nc
+  | _ -> None
+
 (* The kid_order function takes a set of Int-kinded kids, and returns
    a list of those kids in the order they appear in a type, as well as
    a set containing all the kids that did not occur in the type. We
@@ -1755,24 +1766,6 @@ let rec subtyp l env typ1 typ2 =
      if prove env nc2 then ()
      else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | _, _ ->
-  match destruct_exist_plain typ1, destruct_exist (canonicalize env typ2) with
-  | Some (kopts, nc, typ1), _ ->
-     let env = add_existential l kopts nc env in subtyp l env typ1 typ2
-  | None, Some (kopts, nc, typ2) ->
-     typ_debug (lazy "Subtype check with unification");
-     let typ1 = canonicalize env typ1 in
-     let env = add_typ_vars l kopts env in
-     let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (typ_frees typ2)) in
-     if not (kids' = []) then typ_error l "Universally quantified constraint generated" else ();
-     let unifiers =
-       try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with
-       | Unification_error (_, m) -> typ_error l m
-     in
-     let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in
-     let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in
-     if prove env nc then ()
-     else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
-  | None, None ->
   match typ_aux1, typ_aux2 with
   | _, Typ_internal_unknown when Env.allow_unknowns env -> ()
 
@@ -1790,7 +1783,25 @@ let rec subtyp l env typ1 typ2 =
   | Typ_id id1, Typ_app (id2, []) when Id.compare id1 id2 = 0 -> ()
   | Typ_app (id1, []), Typ_id id2 when Id.compare id1 id2 = 0 -> ()
 
-  | _, _ -> typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+  | _, _ ->
+  match destruct_exist_plain typ1, destruct_exist (canonicalize env typ2) with
+  | Some (kopts, nc, typ1), _ ->
+     let env = add_existential l kopts nc env in subtyp l env typ1 typ2
+  | None, Some (kopts, nc, typ2) ->
+     typ_debug (lazy "Subtype check with unification");
+     let typ1 = canonicalize env typ1 in
+     let env = add_typ_vars l kopts env in
+     let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (typ_frees typ2)) in
+     if not (kids' = []) then typ_error l "Universally quantified constraint generated" else ();
+     let unifiers =
+       try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with
+       | Unification_error (_, m) -> typ_error l m
+     in
+     let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in
+     let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in
+     if prove env nc then ()
+     else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+  | None, None -> typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
 
 and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) =
   typ_print (lazy (("Subtype arg " |> Util.green |> Util.clear) ^ string_of_typ_arg arg1 ^ " and " ^ string_of_typ_arg arg2));
@@ -1815,16 +1826,41 @@ let subtype_check env typ1 typ2 =
 (* The type checker produces a fully annoted AST - tannot is the type
    of these type annotations.  The extra typ option is the expected type,
    that is, the type that the AST node was checked against, if there was one. *)
-type tannot = ((Env.t * typ * effect) * typ option) option
+type tannot' = {
+    env : Env.t;
+    typ : typ;
+    effect : effect;
+    expected : typ option;
+    instantiation : typ_arg KBindings.t option
+  }
+
+type tannot = tannot' option
+
+let mk_tannot env typ effect : tannot =
+  Some {
+      env = env;
+      typ = Env.expand_synonyms env typ;
+      effect = effect;
+      expected = None;
+      instantiation = None
+    }
 
-let mk_tannot env typ effect : tannot = Some ((env, typ, effect), None)
+let mk_expected_tannot env typ effect expected : tannot =
+  Some {
+      env = env;
+      typ = Env.expand_synonyms env typ;
+      effect = effect;
+      expected = expected;
+      instantiation = None
+    }
 
 let empty_tannot = None
+
 let is_empty_tannot = function
   | None -> true
   | Some _ -> false
 
-let destruct_tannot tannot = Util.option_map fst tannot
+let destruct_tannot tannot = Util.option_map (fun t -> (t.env, t.typ, t.effect)) tannot
 
 let string_of_tannot tannot =
   match destruct_tannot tannot with
@@ -1833,11 +1869,11 @@ let string_of_tannot tannot =
   | None -> "None"
 
 let replace_typ typ = function
-  | Some ((env, _, eff), _) -> Some ((env, typ, eff), None)
+  | Some t -> Some { t with typ = typ }
   | None -> None
 
 let replace_env env = function
-  | Some ((_, typ, eff), _) -> Some ((env, typ, eff), None)
+  | Some t -> Some { t with env = env }
   | None -> None
 
 let infer_lit env (L_aux (lit_aux, l) as lit) =
@@ -1920,17 +1956,13 @@ let destruct_vec_typ l env typ =
 
 
 let env_of_annot (l, tannot) = match tannot with
-  | Some ((env, _, _),_) -> env
+  | Some t -> t.env
   | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation")
 
 let env_of (E_aux (_, (l, tannot))) = env_of_annot (l, tannot)
 
 let typ_of_annot (l, tannot) = match tannot with
-  | Some ((_, typ, _), _) -> typ
-  | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation")
-
-let env_of_annot (l, tannot) = match tannot with
-  | Some ((env, _, _), _) -> env
+  | Some t -> t.typ
   | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation")
 
 let typ_of (E_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
@@ -1958,7 +1990,7 @@ let lexp_typ_of (LEXP_aux (_, (l, tannot))) = typ_of_annot (l, tannot)
 let lexp_env_of (LEXP_aux (_, (l, tannot))) = env_of_annot (l, tannot)
 
 let expected_typ_of (l, tannot) = match tannot with
-  | Some ((_, _, _), exp_typ) -> exp_typ
+  | Some t -> t.expected
   | None -> raise (Reporting.err_unreachable l __POS__ "no type annotation")
 
 (* Flow typing *)
@@ -2096,6 +2128,8 @@ let rec match_typ env typ1 typ2 =
   | Typ_id v, Typ_app (f, _) when string_of_id v = "int" &&  string_of_id f = "atom" -> true
   | Typ_id v, Typ_app (f, _) when string_of_id v = "nat" &&  string_of_id f = "range" -> true
   | Typ_id v, Typ_app (f, _) when string_of_id v = "int" &&  string_of_id f = "range" -> true
+  | Typ_id v, Typ_app (f, _) when string_of_id v = "bool" &&  string_of_id f = "atom_bool" -> true
+  | Typ_app (f, _), Typ_id v when string_of_id v = "bool" &&  string_of_id f = "atom_bool" -> true
   | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "range" && string_of_id f2 = "atom" -> true
   | Typ_app (f1, _), Typ_app (f2, _) when string_of_id f1 = "atom" && string_of_id f2 = "range" -> true
   | Typ_app (f1, _), Typ_app (f2, _) when Id.compare f1 f2 = 0 -> true
@@ -2163,47 +2197,15 @@ let fresh_var =
             mk_id ("v#" ^ string_of_int n)
 
 let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ_aux, _) as typ) : tannot exp =
-  let annot_exp_effect exp typ' eff = E_aux (exp, (l, Some ((env, Env.expand_synonyms env typ', eff),Some typ))) in
+  let annot_exp_effect exp typ' eff = E_aux (exp, (l, mk_expected_tannot env typ' eff (Some typ))) in
   let add_effect exp eff = match exp with
-    | (E_aux (exp, (l, Some ((env, typ, _), otyp)))) -> E_aux (exp, (l, Some ((env, typ, eff),otyp)))
+    | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with effect = eff }))
     | _ -> failwith "Tried to add effect to unannoted expression"
   in
   let annot_exp exp typ = annot_exp_effect exp typ no_effect in
   match (exp_aux, typ_aux) with
   | E_block exps, _ ->
-     begin
-       let rec check_block l env exps typ =
-         let annot_exp_effect exp typ eff exp_typ = E_aux (exp, (l, Some ((env, typ, eff), exp_typ))) in
-         let annot_exp exp typ exp_typ = annot_exp_effect exp typ no_effect exp_typ in
-         match Nl_flow.analyze exps with
-         | [] -> typ_equality l env typ unit_typ; []
-         | [exp] -> [crule check_exp env exp typ]
-         | (E_aux (E_assign (lexp, bind), _) :: exps) ->
-            let texp, env = bind_assignment env lexp bind in
-            texp :: check_block l env exps typ
-         | ((E_aux (E_assert (constr_exp, msg), _) as exp) :: exps) ->
-            let msg = assert_msg constr_exp msg in
-            let constr_exp = crule check_exp env constr_exp bool_typ in
-            let checked_msg = crule check_exp env msg string_typ in
-            let env = match assert_constraint env true constr_exp with
-              | Some nc ->
-                 typ_print (lazy (adding ^ "constraint " ^ string_of_n_constraint nc ^ " for assert"));
-                 Env.add_constraint nc env
-              | None -> env
-            in
-            let texp = annot_exp_effect (E_assert (constr_exp, checked_msg)) unit_typ (mk_effect [BE_escape]) (Some unit_typ) in
-            texp :: check_block l env exps typ
-         | ((E_aux (E_if (cond, (E_aux (E_throw _, _) | E_aux (E_block [E_aux (E_throw _, _)], _)), _), _) as exp) :: exps) ->
-            let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
-            let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
-            let env = add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env in
-            texp :: check_block l env exps typ
-         | (exp :: exps) ->
-            let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
-            texp :: check_block l env exps typ
-       in
-       annot_exp (E_block (check_block l env exps typ)) typ
-     end
+     annot_exp (E_block (check_block l env exps (Some typ))) typ
   | E_case (exp, cases), _ ->
      Pattern_completeness.check l (Env.pattern_completeness_ctx env) cases;
      let inferred_exp = irule infer_exp env exp in
@@ -2403,6 +2405,40 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      let inferred_exp = irule infer_exp env exp in
      type_coercion env inferred_exp typ
 
+and check_block l env exps ret_typ =
+  let final env exp = match ret_typ with
+    | Some typ -> crule check_exp env exp typ
+    | None -> irule infer_exp env exp
+  in
+  let annot_exp_effect exp typ eff exp_typ = E_aux (exp, (l, mk_expected_tannot env typ eff exp_typ)) in
+  let annot_exp exp typ exp_typ = annot_exp_effect exp typ no_effect exp_typ in
+  match Nl_flow.analyze exps with
+  | [] -> (match ret_typ with Some typ -> typ_equality l env typ unit_typ; [] | None -> [])
+  | [exp] -> [final env exp]
+  | (E_aux (E_assign (lexp, bind), _) :: exps) ->
+     let texp, env = bind_assignment env lexp bind in
+     texp :: check_block l env exps ret_typ
+  | ((E_aux (E_assert (constr_exp, msg), _) as exp) :: exps) ->
+     let msg = assert_msg constr_exp msg in
+     let constr_exp = crule check_exp env constr_exp bool_typ in
+     let checked_msg = crule check_exp env msg string_typ in
+     let env = match assert_constraint env true constr_exp with
+       | Some nc ->
+          typ_print (lazy (adding ^ "constraint " ^ string_of_n_constraint nc ^ " for assert"));
+          Env.add_constraint nc env
+       | None -> env
+     in
+     let texp = annot_exp_effect (E_assert (constr_exp, checked_msg)) unit_typ (mk_effect [BE_escape]) (Some unit_typ) in
+     texp :: check_block l env exps ret_typ
+  | ((E_aux (E_if (cond, (E_aux (E_throw _, _) | E_aux (E_block [E_aux (E_throw _, _)], _)), _), _) as exp) :: exps) ->
+     let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
+     let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
+     let env = add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env in
+     texp :: check_block l env exps ret_typ
+  | (exp :: exps) ->
+     let texp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
+     texp :: check_block l env exps ret_typ
+
 and check_case env pat_typ pexp typ =
   let pat,guard,case,((l,_) as annot) = destruct_pexp pexp in
   match bind_pat env pat pat_typ with
@@ -2467,9 +2503,9 @@ and check_mpexp other_env env mpexp typ =
    or throws a type error if the coercion cannot be performed. *)
 and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
   let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
-  let annot_exp exp typ' = E_aux (exp, (l, Some ((env, typ', no_effect), Some typ))) in
+  let annot_exp exp typ' = E_aux (exp, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_exp_typ exp = match exp with
-    | (E_aux (exp, (l, Some ((env, typ', eff), _)))) -> E_aux (exp, (l, Some ((env, typ', eff), Some typ)))
+    | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with expected = Some typ }))
     | _ -> failwith "Cannot switch type for unannotated function"
   in
   let rec try_casts trigger errs = function
@@ -2501,9 +2537,9 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
    throws a unification error *)
 and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
   let strip exp_aux = strip_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))) in
-  let annot_exp exp typ' = E_aux (exp, (l, Some ((env, typ', no_effect), Some typ))) in
+  let annot_exp exp typ' = E_aux (exp, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ exp typ = match exp with
-    | (E_aux (exp, (l, Some (env, _, eff)))) -> E_aux (exp, (l, Some (env, typ, eff)))
+    | E_aux (exp, (l, Some tannot)) -> E_aux (exp, (l, Some { tannot with typ = typ }))
     | _ -> failwith "Cannot switch type for unannotated expression"
   in
   let rec try_casts = function
@@ -2538,9 +2574,9 @@ and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ =
 and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
   let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
   typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_pat pat ^  " to " ^ string_of_typ typ));
-  let annot_pat pat typ' = P_aux (pat, (l, Some ((env, typ', no_effect), Some typ))) in
+  let annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ pat typ = match pat with
-    | P_aux (pat_aux, (l, Some ((env, _, eff), exp_typ))) -> P_aux (pat_aux, (l, Some ((env, typ, eff), exp_typ)))
+    | P_aux (pat_aux, (l, Some tannot)) -> P_aux (pat_aux, (l, Some { tannot with typ = typ }))
     | _ -> typ_error l "Cannot switch type for unannotated pattern"
   in
   let bind_tuple_pat (tpats, env, guards) pat typ =
@@ -2725,6 +2761,12 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
   | P_lit (L_aux (L_num n, _) as lit) when is_atom typ ->
      let nexp = match destruct_atom_nexp env typ with Some n -> n | None -> assert false in
      annot_pat (P_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, []
+  | P_lit (L_aux (L_true, _) as lit) when is_atom_bool typ ->
+     let nc = match destruct_atom_bool env typ with Some nc -> nc | None -> assert false in
+     annot_pat (P_lit lit) (atom_bool_typ nc_true), Env.add_constraint nc env, []
+  | P_lit (L_aux (L_false, _) as lit) when is_atom_bool typ ->
+     let nc = match destruct_atom_bool env typ with Some nc -> nc | None -> assert false in
+     annot_pat (P_lit lit) (atom_bool_typ nc_false), Env.add_constraint (nc_not nc) env, []
   | _ ->
      let (inferred_pat, env, guards) = infer_pat env pat in
      match subtyp l env typ (typ_of_pat inferred_pat) with
@@ -2739,7 +2781,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
         | _ -> raise typ_exn
 
 and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
-  let annot_pat pat typ = P_aux (pat, (l, Some ((env, typ, no_effect), None))) in
+  let annot_pat pat typ = P_aux (pat, (l, mk_tannot env typ no_effect)) in
   match pat_aux with
   | P_id v ->
      begin
@@ -2846,8 +2888,8 @@ and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_au
   | _, _ -> typ_error l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat)
 
 and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) =
-  let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, Some ((env, mk_typ (Typ_id (mk_id "unit")), no_effect), None))) in
-  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff), None))) in
+  let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, mk_tannot env (mk_typ (Typ_id (mk_id "unit"))) no_effect)) in
+  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in
   let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
   let has_typ v env =
     match Env.lookup_id v env with
@@ -2928,7 +2970,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
 
 and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
   typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^  " to " ^ string_of_typ typ));
-  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff),None))) in
+  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in
   let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
   match lexp_aux with
   | LEXP_cast (typ_annot, v) ->
@@ -2985,7 +3027,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
      inferred_lexp, env
 
 and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
-  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, Some ((env, typ, eff), None))) in
+  let annot_lexp_effect lexp typ eff = LEXP_aux (lexp, (l, mk_tannot env typ eff)) in
   let annot_lexp lexp typ = annot_lexp_effect lexp typ no_effect in
   match lexp_aux with
   | LEXP_id v ->
@@ -3072,9 +3114,13 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
   | _ -> typ_error l ("Could not infer the type of " ^ string_of_lexp lexp)
 
 and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
-  let annot_exp_effect exp typ eff = E_aux (exp, (l, Some ((env, typ, eff),None))) in
+  let annot_exp_effect exp typ eff = E_aux (exp, (l, mk_tannot env typ eff)) in
   let annot_exp exp typ = annot_exp_effect exp typ no_effect in
   match exp_aux with
+  | E_block exps ->
+     let rec last_typ = function [exp] -> typ_of exp | _ :: exps -> last_typ exps | [] -> unit_typ in
+     let inferred_block = check_block l env exps None in
+     annot_exp (E_block inferred_block) (last_typ inferred_block)
   | E_nondet exps ->
      annot_exp (E_nondet (List.map (fun exp -> crule check_exp env exp unit_typ) exps)) unit_typ
   | E_id v ->
@@ -3096,7 +3142,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
        (* Accessing a field of a record *)
        | Typ_aux (Typ_id rectyp, _) as typ when Env.is_record rectyp env ->
           begin
-            let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in
+            let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in
             match inferred_acc with
             | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc)
             | _ -> assert false (* Unreachable *)
@@ -3104,7 +3150,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
        (* Not sure if we need to do anything different with args here. *)
        | Typ_aux (Typ_app (rectyp, args), _) as typ when Env.is_record rectyp env ->
           begin
-            let inferred_acc, _ = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in
+            let inferred_acc = infer_funapp' l (Env.no_casts env) field (Env.get_accessor_fn rectyp field env) [strip_exp inferred_exp] None in
             match inferred_acc with
             | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc)
             | _ -> assert false (* Unreachable *)
@@ -3273,23 +3319,29 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      annot_exp (E_ref id) (register_typ typ)
   | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp)
 
-and infer_funapp l env f xs ret_ctx_typ = fst (infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ)
+and infer_funapp l env f xs ret_ctx_typ = infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ
 
-and instantiation_of (E_aux (exp_aux, (l, _)) as exp) =
-  let env = env_of exp in
-  match exp_aux with
-  | E_app (f, xs) -> snd (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) (Some (typ_of exp)))
+and instantiation_of (E_aux (exp_aux, (l, tannot)) as exp) =
+  match tannot with
+  | Some t ->
+     begin match t.instantiation with
+     | Some inst -> inst
+     | None ->
+        raise (Reporting.err_unreachable l __POS__ "Passed non type-checked function to instantiation_of")
+     end
   | _ -> invalid_arg ("instantiation_of expected application,  got " ^ string_of_exp exp)
 
 and instantiation_of_without_type (E_aux (exp_aux, (l, _)) as exp) =
   let env = env_of exp in
   match exp_aux with
-  | E_app (f, xs) -> snd (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) None)
+  | E_app (f, xs) -> instantiation_of (infer_funapp' l (Env.no_casts env) f (Env.get_val_spec f env) (List.map strip_exp xs) None)
   | _ -> invalid_arg ("instantiation_of expected application,  got " ^ string_of_exp exp)
 
 and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   typ_print (lazy (Util.("Function " |> cyan |> clear) ^ string_of_id f));
-  let annot_exp exp typ eff = E_aux (exp, (l, Some ((env, typ, eff), expected_ret_typ))) in
+  let annot_exp exp typ eff inst =
+    E_aux (exp, (l, Some { env = env; typ = typ; effect = eff; expected = expected_ret_typ; instantiation = Some inst }))
+  in
   let is_bound env kid = KBindings.mem kid (Env.get_typ_vars env) in
 
   (* First we record all the type variables when we start checking the
@@ -3402,17 +3454,16 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
     else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, !typ_ret))
   in
   let typ_ret = simp_typ typ_ret in
-  let exp = annot_exp (E_app (f, xs)) typ_ret eff in
+  let exp = annot_exp (E_app (f, xs)) typ_ret eff !all_unifiers in
   typ_debug (lazy ("Returning: " ^ string_of_exp exp));
-
-  exp, !all_unifiers
+  exp
 
 and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) =
   let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
-  typ_print (lazy ("Binding " ^ string_of_mpat mpat ^  " to " ^ string_of_typ typ));
-  let annot_mpat mpat typ' = MP_aux (mpat, (l, Some ((env, typ', no_effect), Some typ))) in
+  typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_mpat mpat ^  " to " ^ string_of_typ typ));
+  let annot_mpat mpat typ' = MP_aux (mpat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ mpat typ = match mpat with
-    | MP_aux (pat_aux, (l, Some ((env, _, eff), exp_typ))) -> MP_aux (pat_aux, (l, Some ((env, typ, eff), exp_typ)))
+    | MP_aux (pat_aux, (l, Some tannot)) -> MP_aux (pat_aux, (l, Some { tannot with typ = typ }))
     | _ -> typ_error l "Cannot switch type for unannotated mapping-pattern"
   in
   let bind_tuple_mpat (tpats, env, guards) mpat typ =
@@ -3580,6 +3631,13 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
   | MP_lit (L_aux (L_num n, _) as lit) when is_atom typ ->
      let nexp = match destruct_atom_nexp env typ with Some n -> n | None -> assert false in
      annot_mpat (MP_lit lit) (atom_typ (nconstant n)), Env.add_constraint (nc_eq nexp (nconstant n)) env, []
+  (* Similarly, for boolean literals *)
+  | MP_lit (L_aux (L_true, _) as lit) when is_atom_bool typ ->
+     let nc = match destruct_atom_bool env typ with Some n -> n | None -> assert false in
+     annot_mpat (MP_lit lit) (atom_bool_typ nc_true), Env.add_constraint nc env, []
+  | MP_lit (L_aux (L_false, _) as lit) when is_atom_bool typ ->
+     let nc = match destruct_atom_bool env typ with Some n -> n | None -> assert false in
+     annot_mpat (MP_lit lit) (atom_bool_typ nc_false), Env.add_constraint (nc_not nc) env, []
   | _ ->
      let (inferred_mpat, env, guards) = infer_mpat allow_unknown other_env env mpat in
      match subtyp l env typ (typ_of_mpat inferred_mpat) with
@@ -3593,7 +3651,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
            typed_mpat, env, guard::guards
         | _ -> raise typ_exn
 and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) =
-  let annot_mpat mpat typ = MP_aux (mpat, (l, Some ((env, typ, no_effect), None))) in
+  let annot_mpat mpat typ = MP_aux (mpat, (l, mk_tannot env typ no_effect)) in
   match mpat_aux with
   | MP_id v ->
      begin
@@ -3690,13 +3748,13 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
 (**************************************************************************)
 
 let effect_of_annot = function
-| Some ((_, _, eff), _) -> eff
+| Some t -> t.effect
 | None -> no_effect
 
 let effect_of (E_aux (exp, (l, annot))) = effect_of_annot annot
 
 let add_effect_annot annot eff = match annot with
-  | Some ((env, typ, eff'), exp_typ) -> Some ((env, typ, union_effects eff eff'), exp_typ)
+  | Some tannot -> Some { tannot with effect = union_effects eff tannot.effect }
   | None -> None
 
 let add_effect (E_aux (exp, (l, annot))) eff =
@@ -3871,9 +3929,9 @@ and propagate_pexp_effect = function
        let p_exp = propagate_exp_effect exp in
        let p_eff = union_effects (effect_of_pat p_pat) (effect_of p_exp) in
        match annot with
-       | Some ((typq, typ, eff), exp_typ) ->
-          Pat_aux (Pat_exp (p_pat, p_exp), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))),
-         union_effects eff p_eff
+       | Some tannot ->
+          Pat_aux (Pat_exp (p_pat, p_exp), (l, Some { tannot with effect = union_effects tannot.effect p_eff })),
+          union_effects tannot.effect p_eff
        | None -> Pat_aux (Pat_exp (p_pat, p_exp), (l, None)), p_eff
      end
   | Pat_aux (Pat_when (pat, guard, exp), (l, annot)) ->
@@ -3885,9 +3943,9 @@ and propagate_pexp_effect = function
                                           (union_effects (effect_of p_guard) (effect_of p_exp))
        in
        match annot with
-       | Some ((typq, typ, eff), exp_typ) ->
-          Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))),
-          union_effects eff p_eff
+       | Some tannot ->
+          Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, Some { tannot with effect = union_effects tannot.effect p_eff })),
+          union_effects tannot.effect p_eff
        | None -> Pat_aux (Pat_when (p_pat, p_guard, p_exp), (l, None)), p_eff
      end
 
@@ -3897,9 +3955,9 @@ and propagate_mpexp_effect = function
        let p_mpat = propagate_mpat_effect mpat in
        let p_eff = effect_of_mpat p_mpat in
        match annot with
-       | Some ((typq, typ, eff), exp_typ) ->
-          MPat_aux (MPat_pat p_mpat, (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))),
-         union_effects eff p_eff
+       | Some tannot ->
+          MPat_aux (MPat_pat p_mpat, (l, Some { tannot with effect = union_effects tannot.effect p_eff })),
+         union_effects tannot.effect p_eff
        | None -> MPat_aux (MPat_pat p_mpat, (l, None)), p_eff
      end
   | MPat_aux (MPat_when (mpat, guard), (l, annot)) ->
@@ -3909,9 +3967,9 @@ and propagate_mpexp_effect = function
        let p_eff = union_effects (effect_of_mpat p_mpat) (effect_of p_guard)
        in
        match annot with
-       | Some ((typq, typ, eff), exp_typ) ->
-          MPat_aux (MPat_when (p_mpat, p_guard), (l, Some ((typq, typ, union_effects eff p_eff), exp_typ))),
-          union_effects eff p_eff
+       | Some tannot ->
+          MPat_aux (MPat_when (p_mpat, p_guard), (l, Some { tannot with effect = union_effects tannot.effect p_eff })),
+          union_effects tannot.effect p_eff
        | None -> MPat_aux (MPat_when (p_mpat, p_guard), (l, None)), p_eff
      end
 
@@ -4001,7 +4059,7 @@ and propagate_mpat_effect_aux = function
 and propagate_letbind_effect (LB_aux (lb, (l, annot))) =
   let p_lb, eff = propagate_letbind_effect_aux lb in
   match annot with
-  | Some ((typq, typ, eff), exp_typ) -> LB_aux (p_lb, (l, Some ((typq, typ, eff), exp_typ))), eff
+  | Some tannot -> LB_aux (p_lb, (l, Some { tannot with effect = eff })), eff
   | None -> LB_aux (p_lb, (l, None)), eff
 and propagate_letbind_effect_aux = function
   | LB_val (pat, exp) ->
@@ -4092,7 +4150,7 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ =
          | _ ->
             propagate_pexp_effect (check_case env (Typ_aux (Typ_tup typ_args, l)) (strip_pexp pexp) typ_ret)
        in
-       FCL_aux (FCL_Funcl (id, typed_pexp), (l, Some ((env, typ, prop_eff), Some typ)))
+       FCL_aux (FCL_Funcl (id, typed_pexp), (l, mk_expected_tannot env typ prop_eff (Some typ)))
      end
   | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")
 
@@ -4111,7 +4169,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl =
 
             let typed_mpexp1, prop_eff1 = propagate_mpexp_effect (check_mpexp right_id_env env (strip_mpexp mpexp1) typ1) in
             let typed_mpexp2, prop_eff2 = propagate_mpexp_effect (check_mpexp left_id_env env (strip_mpexp mpexp2) typ2) in
-            MCL_aux (MCL_bidir (typed_mpexp1, typed_mpexp2), (l, Some ((env, typ, union_effects prop_eff1 prop_eff2), Some typ)))
+            MCL_aux (MCL_bidir (typed_mpexp1, typed_mpexp2), (l, mk_expected_tannot env typ (union_effects prop_eff1 prop_eff2) (Some typ)))
           end
         | MCL_forwards (mpexp, exp) -> begin
             let mpat, _, _ = destruct_mpexp mpexp in
@@ -4119,7 +4177,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl =
             let typed_mpexp, prop_eff1 = propagate_mpexp_effect (check_mpexp Env.empty env (strip_mpexp mpexp) typ1) in
             let typed_exp = propagate_exp_effect (check_exp mpat_env (strip_exp exp) typ2) in
             let prop_effs = union_effects prop_eff1 (effect_of typed_exp) in
-            MCL_aux (MCL_forwards (typed_mpexp, typed_exp), (l, Some ((env, typ, prop_effs), Some typ)))
+            MCL_aux (MCL_forwards (typed_mpexp, typed_exp), (l, mk_expected_tannot env typ prop_effs (Some typ)))
           end
         | MCL_backwards (mpexp, exp) -> begin
             let mpat, _, _ = destruct_mpexp mpexp in
@@ -4127,20 +4185,19 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl =
             let typed_mpexp, prop_eff1 = propagate_mpexp_effect (check_mpexp Env.empty env (strip_mpexp mpexp) typ2) in
             let typed_exp = propagate_exp_effect (check_exp mpat_env (strip_exp exp) typ1) in
             let prop_effs = union_effects prop_eff1 (effect_of typed_exp) in
-            MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, Some ((env, typ, prop_effs), Some typ)))
+            MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, mk_expected_tannot env typ prop_effs (Some typ)))
           end
       end
     | _ -> typ_error l ("Mapping clause must have mapping type: " ^ string_of_typ typ ^ " is not a mapping type")
 
 let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pexp), (l, annot))) =
   match annot with
-  | Some ((_, _, eff), _) -> eff
+  | Some t -> t.effect
   | None -> no_effect (* Maybe could be assert false. This should never happen *)
 
-
 let mapcl_effect (MCL_aux (_, (l, annot))) =
   match annot with
-  | Some ((_, _, eff), _) -> eff
+  | Some t -> t.effect
   | None -> no_effect (* Maybe could be assert false. This should never happen *)
 
 let infer_funtyp l env tannotopt funcls =
@@ -4177,7 +4234,7 @@ let mk_val_spec env typq typ id =
     | Typ_aux (Typ_fn (_,_,eff),_) -> eff
     | _ -> no_effect
   in
-  DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, (fun _ -> None), false), (Parse_ast.Unknown, Some ((env,typ,eff),None))))
+  DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), Parse_ast.Unknown), id, (fun _ -> None), false), (Parse_ast.Unknown, mk_tannot env typ eff)))
 
 let check_tannotopt env typq ret_typ = function
   | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> ()
@@ -4280,7 +4337,7 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md
    context. We have to destructure the various kinds of val specs, but
    the difference is irrelevant for the typechecker. *)
 let check_val_spec env (VS_aux (vs, (l, _))) =
-  let annotate vs typ eff = DEF_spec (VS_aux (vs, (l, Some ((env, typ, eff), None)))) in
+  let annotate vs typ eff = DEF_spec (VS_aux (vs, (l, mk_tannot env typ eff))) in
   let vs, id, typq, typ, env = match vs with
     | VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), ts_l) as typschm, id, ext_opt, is_cast) ->
        typ_print (lazy (Util.("Check val spec " |> cyan |> clear) ^ string_of_id id ^ " : " ^ string_of_typschm typschm));
@@ -4458,11 +4515,11 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
   | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) ->
      let env = Env.add_register id (mk_effect [BE_rreg]) (mk_effect [BE_wreg]) typ env in
-     [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, Some ((env, typ, no_effect), Some typ))))], env
+     [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, mk_expected_tannot env typ no_effect (Some typ))))], env
   | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), (l, _))) ->
      let checked_exp = crule check_exp env (strip_exp exp) typ in
      let env = Env.add_register id no_effect (mk_effect [BE_config]) typ env in
-     [DEF_reg_dec (DEC_aux (DEC_config (id, typ, checked_exp), (l, Some ((env, typ, no_effect), Some typ))))], env
+     [DEF_reg_dec (DEC_aux (DEC_config (id, typ, checked_exp), (l, mk_expected_tannot env typ no_effect (Some typ))))], env
   | DEF_pragma (pragma, arg, l) -> [DEF_pragma (pragma, arg, l)], env
   | DEF_reg_dec (DEC_aux (DEC_alias (id, aspec), (l, annot))) -> cd_err ()
   | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err ()
-- 
cgit v1.2.3


From 24c2f4c5d9224d094083e2b4859b39c2ca0b1071 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 18 Dec 2018 18:06:55 +0000
Subject: Fix rewriter issues

Fixes some re-writer issues that was preventing RISC-V from building
with new flow-typing constraints. Unfortunately because the flow
typing now understands slightly more about boolean variables, the very
large nested case statements with matches predicates produced by the
string-matching end up causing a huge blowup in the overall
compilation time.
---
 src/ast_util.ml   | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/ast_util.mli  |  7 +++++++
 src/rewrites.ml   | 49 +++++++++++++++++++++++++++++---------------
 src/type_check.ml | 39 ++++++++++-------------------------
 4 files changed, 112 insertions(+), 44 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 795a41fe..55f8c61c 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -1173,6 +1173,67 @@ let equal_effects e1 e2 =
   | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
      BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0
 
+let rec kopts_of_nexp (Nexp_aux (nexp,_)) =
+  match nexp with
+  | Nexp_id _
+  | Nexp_constant _ -> KOptSet.empty
+  | Nexp_var kid -> KOptSet.singleton (mk_kopt K_int kid)
+  | Nexp_times (n1,n2)
+  | Nexp_sum (n1,n2)
+  | Nexp_minus (n1,n2) -> KOptSet.union (kopts_of_nexp n1) (kopts_of_nexp n2)
+  | Nexp_exp n
+  | Nexp_neg n -> kopts_of_nexp n
+  | Nexp_app (_, nexps) -> List.fold_left KOptSet.union KOptSet.empty (List.map kopts_of_nexp nexps)
+
+let kopts_of_order (Ord_aux (ord, _)) =
+  match ord with
+  | Ord_var kid -> KOptSet.singleton (mk_kopt K_order kid)
+  | Ord_inc | Ord_dec -> KOptSet.empty
+
+let rec kopts_of_constraint (NC_aux (nc, _)) =
+  match nc with
+  | NC_equal (nexp1, nexp2)
+  | NC_bounded_ge (nexp1, nexp2)
+  | NC_bounded_le (nexp1, nexp2)
+  | NC_not_equal (nexp1, nexp2) ->
+     KOptSet.union (kopts_of_nexp nexp1) (kopts_of_nexp nexp2)
+  | NC_set (kid, _) -> KOptSet.singleton (mk_kopt K_int kid)
+  | NC_or (nc1, nc2)
+  | NC_and (nc1, nc2) ->
+     KOptSet.union (kopts_of_constraint nc1) (kopts_of_constraint nc2)
+  | NC_app (id, args) ->
+     List.fold_left (fun s t -> KOptSet.union s (kopts_of_typ_arg t)) KOptSet.empty args
+  | NC_var kid -> KOptSet.singleton (mk_kopt K_bool kid)
+  | NC_true | NC_false -> KOptSet.empty
+
+and kopts_of_typ (Typ_aux (t,_)) =
+  match t with
+  | Typ_internal_unknown -> KOptSet.empty
+  | Typ_id _ -> KOptSet.empty
+  | Typ_var kid -> KOptSet.singleton (mk_kopt K_type kid)
+  | Typ_fn (ts, t, _) -> List.fold_left KOptSet.union (kopts_of_typ t) (List.map kopts_of_typ ts)
+  | Typ_bidir (t1, t2) -> KOptSet.union (kopts_of_typ t1) (kopts_of_typ t2)
+  | Typ_tup ts ->
+     List.fold_left (fun s t -> KOptSet.union s (kopts_of_typ t))
+       KOptSet.empty ts
+  | Typ_app (_,tas) ->
+     List.fold_left (fun s ta -> KOptSet.union s (kopts_of_typ_arg ta))
+       KOptSet.empty tas
+  | Typ_exist (kopts, nc, t) ->
+     let s = KOptSet.union (kopts_of_typ t) (kopts_of_constraint nc) in
+     KOptSet.diff s (KOptSet.of_list kopts)
+and kopts_of_typ_arg (A_aux (ta,_)) =
+  match ta with
+  | A_nexp nexp -> kopts_of_nexp nexp
+  | A_typ typ -> kopts_of_typ typ
+  | A_order ord -> kopts_of_order ord
+  | A_bool nc -> kopts_of_constraint nc
+
+let kopts_of_quant_item (QI_aux (qi, _)) = match qi with
+  | QI_id kopt ->
+     KOptSet.singleton kopt
+  | QI_const nc -> kopts_of_constraint nc
+
 let rec tyvars_of_nexp (Nexp_aux (nexp,_)) =
   match nexp with
   | Nexp_id _
diff --git a/src/ast_util.mli b/src/ast_util.mli
index 7a44322d..df7f7efb 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -354,6 +354,13 @@ val effect_set : effect -> BESet.t
 val equal_effects : effect -> effect -> bool
 val union_effects : effect -> effect -> effect
 
+val kopts_of_order : order -> KOptSet.t
+val kopts_of_nexp : nexp -> KOptSet.t
+val kopts_of_typ : typ -> KOptSet.t
+val kopts_of_typ_arg : typ_arg -> KOptSet.t
+val kopts_of_constraint : n_constraint -> KOptSet.t
+val kopts_of_quant_item : quant_item -> KOptSet.t
+
 val tyvars_of_nexp : nexp -> KidSet.t
 val tyvars_of_typ : typ -> KidSet.t
 val tyvars_of_constraint : n_constraint -> KidSet.t
diff --git a/src/rewrites.ml b/src/rewrites.ml
index ec0ebaa7..e87847bd 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -1325,7 +1325,7 @@ let contains_bitvector_pexp = function
 
 let remove_bitvector_pat (P_aux (_, (l, _)) as pat) =
 
-  let env = try env_of_pat pat with _ -> Env.empty in
+  let env = try env_of_pat pat with _ -> raise (Reporting.err_unreachable l __POS__ "Pattern without annotation found") in
 
   (* first introduce names for bitvector patterns *)
   let name_bitvector_roots =
@@ -2092,23 +2092,23 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) =
         | _ ->
            function_typ [args_typ] ret_typ eff
       in
-      let quant_new_tyvars qis =
-        let quant_tyvars = List.fold_left KidSet.union KidSet.empty (List.map tyvars_of_quant_item qis) in
-        let typ_tyvars = tyvars_of_typ fun_typ in
-        let new_tyvars = KidSet.diff typ_tyvars quant_tyvars in
-        List.map (mk_qi_id K_int) (KidSet.elements new_tyvars)
+      let quant_new_kopts qis =
+        let quant_kopts = List.fold_left KOptSet.union KOptSet.empty (List.map kopts_of_quant_item qis) in
+        let typ_kopts = kopts_of_typ fun_typ in
+        let new_kopts = KOptSet.diff typ_kopts quant_kopts in
+        List.map mk_qi_kopt (KOptSet.elements new_kopts)
       in
       let typquant = match typquant with
         | TypQ_aux (TypQ_tq qis, l) ->
            let qis =
              List.filter
-               (fun qi -> KidSet.subset (tyvars_of_quant_item qi) (tyvars_of_typ fun_typ))
+               (fun qi -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ fun_typ))
                qis
-             @ quant_new_tyvars qis
+             @ quant_new_kopts qis
            in
            TypQ_aux (TypQ_tq qis, l)
         | _ ->
-           TypQ_aux (TypQ_tq (List.map (mk_qi_id K_int) (KidSet.elements (tyvars_of_typ fun_typ))), l)
+           TypQ_aux (TypQ_tq (List.map mk_qi_kopt (KOptSet.elements (kopts_of_typ fun_typ))), l)
       in
       let val_spec =
         VS_aux (VS_val_spec
@@ -3016,10 +3016,16 @@ let rec binding_typs_of_pat (P_aux (p_aux, p_annot) as pat) =
 let construct_toplevel_string_append_call env f_id bindings binding_typs guard expr =
   (* s# if match f#(s#) { Some (bindings) => guard, _ => false) } => let Some(bindings) = f#(s#) in expr *)
   let s_id = fresh_stringappend_id () in
+  let hack_typ (Typ_aux (aux, _) as typ) =
+    match aux with
+    | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> bool_typ
+    | Typ_app (Id_aux (Id "atom", _), [_]) -> int_typ
+    | _ -> typ
+  in
   let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with
                                                                          | [] -> unit_typ
-                                                                         | [typ] -> typ
-                                                                         | typs -> tuple_typ typs
+                                                                         | [typ] -> hack_typ typ
+                                                                         | typs -> tuple_typ (List.map hack_typ typs)
                                                               ), unk)]
   in
   let bindings = if bindings = [] then
@@ -3048,11 +3054,22 @@ let construct_toplevel_string_append_func env f_id pat =
                  else
                    bindings
   in
+  (* AA: Pulling the types out of a pattern with binding_typs_of_pat
+     is broken here because they might contain type variables that
+     were bound locally to the pattern, so we can't lift them out to
+     the top-level. As a hacky fix we can generalise types where this
+     is likely to happen. *)
+  let hack_typ (Typ_aux (aux, _) as typ) =
+    match aux with
+    | Typ_app (Id_aux (Id "atom_bool", _), [_]) -> bool_typ
+    | Typ_app (Id_aux (Id "atom", _), [_]) -> int_typ
+    | _ -> typ
+  in
   let option_typ = app_typ (mk_id "option") [A_aux (A_typ (match binding_typs with
                                                                        | [] -> unit_typ
-                                                                       | [typ] -> typ
-                                                                       | typs -> tuple_typ typs
-                                                            ), unk)]
+                                                                       | [typ] -> hack_typ typ
+                                                                       | typs -> tuple_typ (List.map hack_typ typs)
+                                                          ), unk)]
   in
   let fun_typ = (mk_typ (Typ_fn ([string_typ], option_typ, no_effect))) in
   let new_val_spec = VS_aux (VS_val_spec (mk_typschm (TypQ_aux (TypQ_no_forall, unk)) fun_typ, f_id, (fun _ -> None), false), unkt) in
@@ -3135,7 +3152,7 @@ let construct_toplevel_string_append_func env f_id pat =
        let some_pat = annot_pat (P_app (mk_id "Some",
                                         [tup_arg_pat;
                                          annot_pat (P_id len_id) unk env nat_typ]))
-                        unk env opt_typ in
+                                unk env opt_typ in
        let some_pat, some_pat_env, _ = bind_pat env (strip_pat some_pat) opt_typ in
 
        (* need to add the Some(...) env to tup_arg_pats for pat_to_exp below as it calls the typechecker *)
@@ -3520,7 +3537,7 @@ let rewrite_defs_mapping_patterns =
 
        let false_exp = annot_exp (E_lit (L_aux (L_false, unk))) unk env bool_typ in
        let new_other_guards = annot_exp (E_if (new_guard,
-                                               (annot_exp (E_let (new_letbind, fold_typed_guards env guards)) unk env bool_typ),
+                                               (annot_exp (E_let (new_letbind, annot_exp (E_cast (bool_typ, fold_typed_guards env guards)) unk env bool_typ)) unk env bool_typ),
                                                false_exp)) unk env bool_typ in
 
        annot_pat (P_typ (mapping_in_typ, annot_pat (P_id s_id) unk env mapping_in_typ)) unk env mapping_in_typ, [new_guard; new_other_guards], new_let
diff --git a/src/type_check.ml b/src/type_check.ml
index dedb7015..6ddc31a7 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1300,11 +1300,6 @@ let rec nexp_frees ?exs:(exs=KidSet.empty) (Nexp_aux (nexp, l)) =
   | Nexp_exp n -> nexp_frees ~exs:exs n
   | Nexp_neg n -> nexp_frees ~exs:exs n
 
-let order_frees (Ord_aux (ord_aux, l)) =
-  match ord_aux with
-  | Ord_var kid -> KidSet.singleton kid
-  | _ -> KidSet.empty
-
 let rec typ_nexps (Typ_aux (typ_aux, l)) =
   match typ_aux with
   | Typ_internal_unknown -> []
@@ -1323,24 +1318,6 @@ and typ_arg_nexps (A_aux (typ_arg_aux, l)) =
   | A_typ typ -> typ_nexps typ
   | A_order ord -> []
 
-let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) =
-  match typ_aux with
-  | Typ_internal_unknown -> KidSet.empty
-  | Typ_id v -> KidSet.empty
-  | Typ_var kid when KidSet.mem kid exs -> KidSet.empty
-  | Typ_var kid -> KidSet.singleton kid
-  | Typ_tup typs -> List.fold_left KidSet.union KidSet.empty (List.map (typ_frees ~exs:exs) typs)
-  | Typ_app (f, args) -> List.fold_left KidSet.union KidSet.empty (List.map (typ_arg_frees ~exs:exs) args)
-  | Typ_exist (kopts, nc, typ) -> typ_frees ~exs:(KidSet.of_list (List.map kopt_kid kopts)) typ
-  | Typ_fn (arg_typs, ret_typ, _) -> List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs)
-  | Typ_bidir (typ1, typ2) -> KidSet.union (typ_frees ~exs:exs typ1) (typ_frees ~exs:exs typ2)
-and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) =
-  match typ_arg_aux with
-  | A_nexp n -> nexp_frees ~exs:exs n
-  | A_typ typ -> typ_frees ~exs:exs typ
-  | A_order ord -> order_frees ord
-  | A_bool nc -> tyvars_of_constraint nc
-
 let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) =
   match nexp1, nexp2 with
   | Nexp_id v1, Nexp_id v2 -> Id.compare v1 v2 = 0
@@ -1791,7 +1768,7 @@ let rec subtyp l env typ1 typ2 =
      typ_debug (lazy "Subtype check with unification");
      let typ1 = canonicalize env typ1 in
      let env = add_typ_vars l kopts env in
-     let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (typ_frees typ2)) in
+     let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (tyvars_of_typ typ2)) in
      if not (kids' = []) then typ_error l "Universally quantified constraint generated" else ();
      let unifiers =
        try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with
@@ -3256,8 +3233,14 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
         | None -> typ_error l ("Could not infer type of " ^ string_of_exp else_branch)
         end
      | None ->
-        let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in
-        annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch')
+        begin match typ_of then_branch' with
+        | Typ_aux (Typ_app (f, [_]), _) when string_of_id f = "atom_bool" ->
+           let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch bool_typ in
+           annot_exp (E_if (cond', then_branch', else_branch')) bool_typ
+        | _ ->
+           let else_branch' = crule check_exp (add_opt_constraint (option_map nc_not (assert_constraint env false cond')) env) else_branch (typ_of then_branch') in
+           annot_exp (E_if (cond', then_branch', else_branch')) (typ_of then_branch')
+        end
      end
   | E_vector_access (v, n) -> infer_exp env (E_aux (E_app (mk_id "vector_access", [v; n]), (l, ())))
   | E_vector_update (v, n, exp) -> infer_exp env (E_aux (E_app (mk_id "vector_update", [v; n; exp]), (l, ())))
@@ -3449,7 +3432,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
 
   let universals = KBindings.bindings universals |> List.map fst |> KidSet.of_list in
   let typ_ret =
-    if KidSet.is_empty (KidSet.of_list (List.map kopt_kid existentials)) || KidSet.is_empty (KidSet.diff (typ_frees !typ_ret) universals)
+    if KidSet.is_empty (KidSet.of_list (List.map kopt_kid existentials)) || KidSet.is_empty (KidSet.diff (tyvars_of_typ !typ_ret) universals)
     then !typ_ret
     else mk_typ (Typ_exist (existentials, List.fold_left nc_and nc_true ex_constraints, !typ_ret))
   in
@@ -4386,7 +4369,7 @@ let check_type_union env variant typq (Tu_aux (tu, l)) =
   let ret_typ = app_typ variant (List.fold_left fold_union_quant [] (quant_items typq)) in
   match tu with
   | Tu_ty_id (Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) as typ, v) ->
-     let typq = mk_typquant (List.map (mk_qi_id K_type) (KidSet.elements (typ_frees typ))) in
+     let typq = mk_typquant (List.map (mk_qi_id K_type) (KidSet.elements (tyvars_of_typ typ))) in
      env
      |> Env.add_union_id v (typq, typ)
      |> Env.add_val_spec v (typq, typ)
-- 
cgit v1.2.3


From 4d8a4078990a00ffdc018bc8f5d4d5e3dcf6527d Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 18 Dec 2018 19:45:02 +0000
Subject: Experiment with generating type variable names in a repeatable way

This results in much better error messages, as we can pick readable
names that make sense, and should hopefully make the re-writer more
robust.
---
 src/type_check.ml  | 79 +++++++++++++++++++++++++++++++++++-------------------
 src/type_check.mli |  6 ++---
 2 files changed, 54 insertions(+), 31 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 6ddc31a7..839a12e5 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -143,7 +143,7 @@ let is_atom_bool (Typ_aux (typ_aux, _)) =
   match typ_aux with
   | Typ_app (f, [_]) when string_of_id f = "atom_bool" -> true
   | _ -> false
-       
+
 let rec strip_id = function
   | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown)
   | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown)
@@ -220,18 +220,36 @@ and strip_kinded_id_aux = function
 and strip_kind = function
   | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown)
 
-let ex_counter = ref 0
+module StringMap = Map.Make(String);;
+
+let ex_global = ref false
+let ex_counters = ref StringMap.empty
 
-let fresh_existential ?name:(n="") k =
-  let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in
-  incr ex_counter; mk_kopt k fresh
+let fresh_existential ?name:(name=None) k =
+  let name = match name with None -> "" | Some str -> str in
+  let count = match StringMap.find_opt name !ex_counters with Some c -> c | None -> 0 in
+  let global = if !ex_global then "global#" else "" in
+  ex_counters := StringMap.add name (count + 1) !ex_counters;
+  let fresh = Kid_aux (Var ("'" ^ global ^ name ^ "#" ^ string_of_int count), Parse_ast.Unknown) in
+  mk_kopt k fresh
 
-let destruct_exist_plain typ =
+let rec pat_name (P_aux (aux, _)) =
+  match aux with
+  | P_wild -> "_"
+  | P_id id | P_as (_, id) -> string_of_id id
+  | P_var (pat, _) | P_typ (_, pat) -> pat_name pat
+  | _ -> "ex"
+
+let destruct_exist_plain ?name:(name=None) typ =
+  let gen_name kopt = match name with
+    | None -> Some (string_of_id (id_of_kid (kopt_kid kopt)))
+    | Some str -> Some str
+  in
   match typ with
   | Typ_aux (Typ_exist (kopts, nc, typ), _) ->
      let fresh_kopts =
        List.map (fun kopt -> (kopt_kid kopt,
-                              fresh_existential ~name:(string_of_id (id_of_kid (kopt_kid kopt))) (unaux_kind (kopt_kind kopt))))
+                              fresh_existential ~name:(gen_name kopt) (unaux_kind (kopt_kind kopt))))
          kopts
      in
      let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_kopt fresh) nc) nc fresh_kopts in
@@ -247,36 +265,36 @@ let destruct_exist_plain typ =
    - int => ['n], true, 'n (where x is fresh)
    - atom('n) => [], true, 'n
 **)
-let destruct_numeric typ =
-  match destruct_exist_plain typ, typ with
+let destruct_numeric ?name:(name=None) typ =
+  match destruct_exist_plain ~name:name typ, typ with
   | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" ->
      Some (List.map kopt_kid kids, nc, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" ->
      Some ([], nc_true, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (fresh_existential ~name:name K_int) in
      Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (fresh_existential ~name:name K_int) in
      Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (fresh_existential ~name:name K_int) in
      Some ([kid], nc_true, nvar kid)
   | _, _ -> None
 
-let destruct_boolean = function
+let destruct_boolean ?name:(name=None) = function
   | Typ_aux (Typ_id (Id_aux (Id "bool", _)), _) ->
-     let kid = kopt_kid (fresh_existential K_bool) in
+     let kid = kopt_kid (fresh_existential ~name:name K_bool) in
      Some (kid, nc_var kid)
   | _ -> None
 
-let destruct_exist typ =
-  match destruct_numeric typ with
+let destruct_exist ?name:(name=None) typ =
+  match destruct_numeric ~name:name typ with
   | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp)
   | None ->
-     match destruct_boolean typ with
+     match destruct_boolean ~name:name typ with
      | Some (kid, nc) -> Some ([mk_kopt K_bool kid], nc_true, atom_bool_typ nc)
-     | None -> destruct_exist_plain typ
+     | None -> destruct_exist_plain ~name:name typ
 
 let adding = Util.("Adding " |> darkgray |> clear)
 
@@ -772,13 +790,13 @@ end = struct
           forall 'n, 'n >= 2. (int('n), foo) -> bar
           this enforces the invariant that all things on the left of functions are 'base types' (i.e. without existentials)
         *)
-       let base_args = List.map (fun typ -> destruct_exist (expand_synonyms env typ)) arg_typs in
+       let base_args = List.map (fun typ -> destruct_exist ~name:(Some "#") (expand_synonyms env typ)) arg_typs in
        let existential_arg typq = function
          | None -> typq
          | Some (exs, nc, _) ->
             List.fold_left (fun typq kopt -> quant_add (mk_qi_kopt kopt) typq) (quant_add (mk_qi_nc nc) typq) exs
        in
-       let typq = List.fold_left existential_arg typq base_args in
+       let typq = List.fold_left existential_arg typq (List.rev base_args) in
        let arg_typs = List.map2 (fun typ -> function Some (_, _, typ) -> typ | None -> typ) arg_typs base_args in
        let typ = Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) in
        typ_print (lazy (adding ^ "val " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ)));
@@ -1053,7 +1071,7 @@ end = struct
 
   let add_constraint constr env =
     wf_constraint env constr;
-    let (NC_aux (nc_aux, l) as constr) = expand_constraint_synonyms env constr in
+    let (NC_aux (nc_aux, l) as constr) = constraint_simp (expand_constraint_synonyms env constr) in
     match nc_aux with
     | NC_true -> env
     | _ ->
@@ -1174,8 +1192,8 @@ let bind_numeric l typ env =
 
 (** Pull an (potentially)-existentially qualified type into the global
    typing environment **)
-let bind_existential l typ env =
-  match destruct_exist (Env.expand_synonyms env typ) with
+let bind_existential ?name:(name=None) l typ env =
+  match destruct_exist ~name:name (Env.expand_synonyms env typ) with
   | Some (kids, nc, typ) -> typ, add_existential l kids nc env
   | None -> typ, env
 
@@ -1270,7 +1288,7 @@ let solve env (Nexp_aux (_, l) as nexp) =
 
 let prove env nc =
   typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
-  let (NC_aux (nc_aux, _) as nc) = Env.expand_constraint_synonyms env nc in
+  let (NC_aux (nc_aux, _) as nc) = constraint_simp (Env.expand_constraint_synonyms env nc) in
   typ_debug ~level:2 (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
   let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) =
     match n1, n2 with
@@ -2525,7 +2543,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
         typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification"));
         try
           let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
-          let ityp, env = bind_existential l (typ_of inferred_cast) env in
+          let ityp, env = bind_existential ~name:(Some "arg") l (typ_of inferred_cast) env in
           inferred_cast, unify l env goals typ ityp, env
         with
         | Type_error (_, err) -> try_casts casts
@@ -2535,7 +2553,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
   begin
     try
       typ_debug (lazy ("Coercing unification: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ));
-      let atyp, env = bind_existential l (typ_of annotated_exp) env in
+      let atyp, env = bind_existential ~name:(Some "arg") l (typ_of annotated_exp) env in
       annotated_exp, unify l env goals typ atyp, env
     with
     | Unification_error (_, m) when Env.allow_casts env ->
@@ -2549,7 +2567,7 @@ and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ =
   | tpat, env, [] -> tpat, env
 
 and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
-  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
+  let (Typ_aux (typ_aux, _) as typ), env = bind_existential ~name:(Some (pat_name pat)) l typ env in
   typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_pat pat ^  " to " ^ string_of_typ typ));
   let annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ pat typ = match pat with
@@ -4478,6 +4496,7 @@ and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t
 
 and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   fun env def ->
+  ex_counters := StringMap.empty;
   let cd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in
   match def with
   | DEF_kind kdef -> check_kinddef env kdef
@@ -4492,7 +4511,11 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
        | _ -> (defs @ [def], fdefs) in
      let (defs, fdefs) = List.fold_left split_fundef ([], []) defs in
      (defs @ [DEF_internal_mutrec fdefs]), env
-  | DEF_val letdef -> check_letdef env letdef
+  | DEF_val letdef ->
+     ex_global := true;
+     let defs, env = check_letdef env letdef in
+     ex_global := false;
+     defs, env
   | DEF_spec vs -> check_val_spec env vs
   | DEF_default default -> check_default env default
   | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
diff --git a/src/type_check.mli b/src/type_check.mli
index 81682606..c470e9c4 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -212,8 +212,8 @@ val add_typquant : Ast.l -> typquant -> Env.t -> Env.t
    is not existential. This function will pick a fresh name for the
    existential to ensure that no name-clashes occur. The "plain"
    version does not treat numeric types as existentials. *)
-val destruct_exist_plain : typ -> (kinded_id list * n_constraint * typ) option
-val destruct_exist : typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
 
 val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t
 
@@ -356,7 +356,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option
 
 val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option
 
-val destruct_numeric : typ -> (kid list * n_constraint * nexp) option
+val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * nexp) option
 
 val destruct_vector : Env.t -> typ -> (nexp * order * typ) option
 
-- 
cgit v1.2.3


From 213bb81b452bbe43b616f5f9bb853ff30c2543a5 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Tue, 18 Dec 2018 20:39:27 +0000
Subject: Revert "Experiment with generating type variable names in a
 repeatable way"

This reverts commit 4d8a4078990a00ffdc018bc8f5d4d5e3dcf6527d.
---
 src/type_check.ml  | 79 +++++++++++++++++++-----------------------------------
 src/type_check.mli |  6 ++---
 2 files changed, 31 insertions(+), 54 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 839a12e5..6ddc31a7 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -143,7 +143,7 @@ let is_atom_bool (Typ_aux (typ_aux, _)) =
   match typ_aux with
   | Typ_app (f, [_]) when string_of_id f = "atom_bool" -> true
   | _ -> false
-
+       
 let rec strip_id = function
   | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown)
   | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown)
@@ -220,36 +220,18 @@ and strip_kinded_id_aux = function
 and strip_kind = function
   | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown)
 
-module StringMap = Map.Make(String);;
-
-let ex_global = ref false
-let ex_counters = ref StringMap.empty
+let ex_counter = ref 0
 
-let fresh_existential ?name:(name=None) k =
-  let name = match name with None -> "" | Some str -> str in
-  let count = match StringMap.find_opt name !ex_counters with Some c -> c | None -> 0 in
-  let global = if !ex_global then "global#" else "" in
-  ex_counters := StringMap.add name (count + 1) !ex_counters;
-  let fresh = Kid_aux (Var ("'" ^ global ^ name ^ "#" ^ string_of_int count), Parse_ast.Unknown) in
-  mk_kopt k fresh
+let fresh_existential ?name:(n="") k =
+  let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in
+  incr ex_counter; mk_kopt k fresh
 
-let rec pat_name (P_aux (aux, _)) =
-  match aux with
-  | P_wild -> "_"
-  | P_id id | P_as (_, id) -> string_of_id id
-  | P_var (pat, _) | P_typ (_, pat) -> pat_name pat
-  | _ -> "ex"
-
-let destruct_exist_plain ?name:(name=None) typ =
-  let gen_name kopt = match name with
-    | None -> Some (string_of_id (id_of_kid (kopt_kid kopt)))
-    | Some str -> Some str
-  in
+let destruct_exist_plain typ =
   match typ with
   | Typ_aux (Typ_exist (kopts, nc, typ), _) ->
      let fresh_kopts =
        List.map (fun kopt -> (kopt_kid kopt,
-                              fresh_existential ~name:(gen_name kopt) (unaux_kind (kopt_kind kopt))))
+                              fresh_existential ~name:(string_of_id (id_of_kid (kopt_kid kopt))) (unaux_kind (kopt_kind kopt))))
          kopts
      in
      let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_kopt fresh) nc) nc fresh_kopts in
@@ -265,36 +247,36 @@ let destruct_exist_plain ?name:(name=None) typ =
    - int => ['n], true, 'n (where x is fresh)
    - atom('n) => [], true, 'n
 **)
-let destruct_numeric ?name:(name=None) typ =
-  match destruct_exist_plain ~name:name typ, typ with
+let destruct_numeric typ =
+  match destruct_exist_plain typ, typ with
   | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" ->
      Some (List.map kopt_kid kids, nc, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" ->
      Some ([], nc_true, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" ->
-     let kid = kopt_kid (fresh_existential ~name:name K_int) in
+     let kid = kopt_kid (fresh_existential K_int) in
      Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" ->
-     let kid = kopt_kid (fresh_existential ~name:name K_int) in
+     let kid = kopt_kid (fresh_existential K_int) in
      Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" ->
-     let kid = kopt_kid (fresh_existential ~name:name K_int) in
+     let kid = kopt_kid (fresh_existential K_int) in
      Some ([kid], nc_true, nvar kid)
   | _, _ -> None
 
-let destruct_boolean ?name:(name=None) = function
+let destruct_boolean = function
   | Typ_aux (Typ_id (Id_aux (Id "bool", _)), _) ->
-     let kid = kopt_kid (fresh_existential ~name:name K_bool) in
+     let kid = kopt_kid (fresh_existential K_bool) in
      Some (kid, nc_var kid)
   | _ -> None
 
-let destruct_exist ?name:(name=None) typ =
-  match destruct_numeric ~name:name typ with
+let destruct_exist typ =
+  match destruct_numeric typ with
   | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp)
   | None ->
-     match destruct_boolean ~name:name typ with
+     match destruct_boolean typ with
      | Some (kid, nc) -> Some ([mk_kopt K_bool kid], nc_true, atom_bool_typ nc)
-     | None -> destruct_exist_plain ~name:name typ
+     | None -> destruct_exist_plain typ
 
 let adding = Util.("Adding " |> darkgray |> clear)
 
@@ -790,13 +772,13 @@ end = struct
           forall 'n, 'n >= 2. (int('n), foo) -> bar
           this enforces the invariant that all things on the left of functions are 'base types' (i.e. without existentials)
         *)
-       let base_args = List.map (fun typ -> destruct_exist ~name:(Some "#") (expand_synonyms env typ)) arg_typs in
+       let base_args = List.map (fun typ -> destruct_exist (expand_synonyms env typ)) arg_typs in
        let existential_arg typq = function
          | None -> typq
          | Some (exs, nc, _) ->
             List.fold_left (fun typq kopt -> quant_add (mk_qi_kopt kopt) typq) (quant_add (mk_qi_nc nc) typq) exs
        in
-       let typq = List.fold_left existential_arg typq (List.rev base_args) in
+       let typq = List.fold_left existential_arg typq base_args in
        let arg_typs = List.map2 (fun typ -> function Some (_, _, typ) -> typ | None -> typ) arg_typs base_args in
        let typ = Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) in
        typ_print (lazy (adding ^ "val " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ)));
@@ -1071,7 +1053,7 @@ end = struct
 
   let add_constraint constr env =
     wf_constraint env constr;
-    let (NC_aux (nc_aux, l) as constr) = constraint_simp (expand_constraint_synonyms env constr) in
+    let (NC_aux (nc_aux, l) as constr) = expand_constraint_synonyms env constr in
     match nc_aux with
     | NC_true -> env
     | _ ->
@@ -1192,8 +1174,8 @@ let bind_numeric l typ env =
 
 (** Pull an (potentially)-existentially qualified type into the global
    typing environment **)
-let bind_existential ?name:(name=None) l typ env =
-  match destruct_exist ~name:name (Env.expand_synonyms env typ) with
+let bind_existential l typ env =
+  match destruct_exist (Env.expand_synonyms env typ) with
   | Some (kids, nc, typ) -> typ, add_existential l kids nc env
   | None -> typ, env
 
@@ -1288,7 +1270,7 @@ let solve env (Nexp_aux (_, l) as nexp) =
 
 let prove env nc =
   typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
-  let (NC_aux (nc_aux, _) as nc) = constraint_simp (Env.expand_constraint_synonyms env nc) in
+  let (NC_aux (nc_aux, _) as nc) = Env.expand_constraint_synonyms env nc in
   typ_debug ~level:2 (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
   let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) =
     match n1, n2 with
@@ -2543,7 +2525,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
         typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification"));
         try
           let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
-          let ityp, env = bind_existential ~name:(Some "arg") l (typ_of inferred_cast) env in
+          let ityp, env = bind_existential l (typ_of inferred_cast) env in
           inferred_cast, unify l env goals typ ityp, env
         with
         | Type_error (_, err) -> try_casts casts
@@ -2553,7 +2535,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
   begin
     try
       typ_debug (lazy ("Coercing unification: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ));
-      let atyp, env = bind_existential ~name:(Some "arg") l (typ_of annotated_exp) env in
+      let atyp, env = bind_existential l (typ_of annotated_exp) env in
       annotated_exp, unify l env goals typ atyp, env
     with
     | Unification_error (_, m) when Env.allow_casts env ->
@@ -2567,7 +2549,7 @@ and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ =
   | tpat, env, [] -> tpat, env
 
 and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
-  let (Typ_aux (typ_aux, _) as typ), env = bind_existential ~name:(Some (pat_name pat)) l typ env in
+  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
   typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_pat pat ^  " to " ^ string_of_typ typ));
   let annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ pat typ = match pat with
@@ -4496,7 +4478,6 @@ and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t
 
 and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   fun env def ->
-  ex_counters := StringMap.empty;
   let cd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in
   match def with
   | DEF_kind kdef -> check_kinddef env kdef
@@ -4511,11 +4492,7 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
        | _ -> (defs @ [def], fdefs) in
      let (defs, fdefs) = List.fold_left split_fundef ([], []) defs in
      (defs @ [DEF_internal_mutrec fdefs]), env
-  | DEF_val letdef ->
-     ex_global := true;
-     let defs, env = check_letdef env letdef in
-     ex_global := false;
-     defs, env
+  | DEF_val letdef -> check_letdef env letdef
   | DEF_spec vs -> check_val_spec env vs
   | DEF_default default -> check_default env default
   | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
diff --git a/src/type_check.mli b/src/type_check.mli
index c470e9c4..81682606 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -212,8 +212,8 @@ val add_typquant : Ast.l -> typquant -> Env.t -> Env.t
    is not existential. This function will pick a fresh name for the
    existential to ensure that no name-clashes occur. The "plain"
    version does not treat numeric types as existentials. *)
-val destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
-val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist_plain : typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist : typ -> (kinded_id list * n_constraint * typ) option
 
 val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t
 
@@ -356,7 +356,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option
 
 val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option
 
-val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * nexp) option
+val destruct_numeric : typ -> (kid list * n_constraint * nexp) option
 
 val destruct_vector : Env.t -> typ -> (nexp * order * typ) option
 
-- 
cgit v1.2.3


From 52c604b1f8f70bf5ad1ce6a5495b926b1372faa0 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Tue, 18 Dec 2018 23:35:16 +0000
Subject: Ensure type-variables have consistent names

Type variables can now be lexically scoped and shadow each other like normal variables,
rather than being required to be unique. This means we can use identifier names to
choose names for type variables in a way where we can assume they remain consistent
between type-checker runs. This means that re-writer steps can lift types out of
annotations in E_aux constructors and put them directly as syntactic annotations in the
AST - this should enable more robust rewrite steps.

Also fix RISC-V lem build w/ flow typing changes
---
 src/pretty_print_lem.ml |  3 ++
 src/type_check.ml       | 92 ++++++++++++++++++++++++++++++++-----------------
 src/type_check.mli      |  6 ++--
 3 files changed, 66 insertions(+), 35 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 9d169108..ea34ef3d 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -327,6 +327,9 @@ let doc_typ_lem, doc_atomic_typ_lem =
                                String.concat ", " (List.map string_of_kid bad) ^
                                " escape into Lem"))
         end
+      (* AA: I think the correct thing is likely to filter out
+         non-integer kinded_id's, then use the above code. *)
+      | Typ_exist (_,_,Typ_aux(Typ_app(id,[_]),_)) when string_of_id id = "atom_bool" -> string "bool"
       | Typ_exist _ -> unreachable l __POS__ "Non-integer existentials currently unsupported in Lem" (* TODO *)
       | Typ_bidir _ -> unreachable l __POS__ "Lem doesn't support bidir types"
       | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
diff --git a/src/type_check.ml b/src/type_check.ml
index 6ddc31a7..ba7b2acb 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -220,19 +220,33 @@ and strip_kinded_id_aux = function
 and strip_kind = function
   | K_aux (k_aux, _) -> K_aux (k_aux, Parse_ast.Unknown)
 
+let rec name_pat (P_aux (aux, _)) =
+  match aux with
+  | P_id id | P_as (_, id) -> Some ("_" ^ string_of_id id)
+  | P_typ (_, pat) | P_var (pat, _) -> name_pat pat
+  | _ -> None
+                      
 let ex_counter = ref 0
 
-let fresh_existential ?name:(n="") k =
-  let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#" ^ n), Parse_ast.Unknown) in
+let fresh_existential k =
+  let fresh = Kid_aux (Var ("'ex" ^ string_of_int !ex_counter ^ "#"), Parse_ast.Unknown) in
   incr ex_counter; mk_kopt k fresh
 
-let destruct_exist_plain typ =
+let named_existential k = function
+  | Some n -> mk_kopt k (mk_kid n)
+  | None -> fresh_existential k
+ 
+let destruct_exist_plain ?name:(name=None) typ =
   match typ with
+  | Typ_aux (Typ_exist ([kopt], nc, typ), _) ->
+     let kid, fresh = kopt_kid kopt, named_existential (unaux_kind (kopt_kind kopt)) name in
+     let nc = constraint_subst kid (arg_kopt fresh) nc in
+     let typ = typ_subst kid (arg_kopt fresh) typ in
+     Some ([fresh], nc, typ)
   | Typ_aux (Typ_exist (kopts, nc, typ), _) ->
+     let add_num i = match name with Some n -> Some (n ^ string_of_int i) | None -> None in 
      let fresh_kopts =
-       List.map (fun kopt -> (kopt_kid kopt,
-                              fresh_existential ~name:(string_of_id (id_of_kid (kopt_kid kopt))) (unaux_kind (kopt_kind kopt))))
-         kopts
+       List.mapi (fun i kopt -> (kopt_kid kopt, named_existential (unaux_kind (kopt_kind kopt)) (add_num i))) kopts
      in
      let nc = List.fold_left (fun nc (kid, fresh) -> constraint_subst kid (arg_kopt fresh) nc) nc fresh_kopts in
      let typ = List.fold_left (fun typ (kid, fresh) -> typ_subst kid (arg_kopt fresh) typ) typ fresh_kopts in
@@ -247,36 +261,36 @@ let destruct_exist_plain typ =
    - int => ['n], true, 'n (where x is fresh)
    - atom('n) => [], true, 'n
 **)
-let destruct_numeric typ =
-  match destruct_exist_plain typ, typ with
+let destruct_numeric ?name:(name=None) typ =
+  match destruct_exist_plain ~name:name typ, typ with
   | Some (kids, nc, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _)), _ when string_of_id id = "atom" ->
      Some (List.map kopt_kid kids, nc, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp nexp, _)]), _) when string_of_id id = "atom" ->
      Some ([], nc_true, nexp)
   | None, Typ_aux (Typ_app (id, [A_aux (A_nexp lo, _); A_aux (A_nexp hi, _)]), _) when string_of_id id = "range" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (named_existential K_int name) in
      Some ([kid], nc_and (nc_lteq lo (nvar kid)) (nc_lteq (nvar kid) hi), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "nat" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (named_existential K_int name) in
      Some ([kid], nc_lteq (nint 0) (nvar kid), nvar kid)
   | None, Typ_aux (Typ_id id, _) when string_of_id id = "int" ->
-     let kid = kopt_kid (fresh_existential K_int) in
+     let kid = kopt_kid (named_existential K_int name) in
      Some ([kid], nc_true, nvar kid)
   | _, _ -> None
 
-let destruct_boolean = function
+let destruct_boolean ?name:(name=None) = function
   | Typ_aux (Typ_id (Id_aux (Id "bool", _)), _) ->
      let kid = kopt_kid (fresh_existential K_bool) in
      Some (kid, nc_var kid)
   | _ -> None
 
-let destruct_exist typ =
-  match destruct_numeric typ with
+let destruct_exist ?name:(name=None) typ =
+  match destruct_numeric ~name:name typ with
   | Some (kids, nc, nexp) -> Some (List.map (mk_kopt K_int) kids, nc, atom_typ nexp)
   | None ->
-     match destruct_boolean typ with
+     match destruct_boolean ~name:name typ with
      | Some (kid, nc) -> Some ([mk_kopt K_bool kid], nc_true, atom_bool_typ nc)
-     | None -> destruct_exist_plain typ
+     | None -> destruct_exist_plain ~name:name typ
 
 let adding = Util.("Adding " |> darkgray |> clear)
 
@@ -384,6 +398,7 @@ end = struct
       variants : (typquant * type_union list) Bindings.t;
       mappings : (typquant * typ * typ) Bindings.t;
       typ_vars : (Ast.l * kind_aux) KBindings.t;
+      shadow_vars : int KBindings.t;
       typ_synonyms : (t -> typ_arg list -> typ_arg) Bindings.t;
       num_defs : nexp Bindings.t;
       overloads : (id list) Bindings.t;
@@ -412,6 +427,7 @@ end = struct
       variants = Bindings.empty;
       mappings = Bindings.empty;
       typ_vars = KBindings.empty;
+      shadow_vars = KBindings.empty;
       typ_synonyms = Bindings.empty;
       num_defs = Bindings.empty;
       overloads = Bindings.empty;
@@ -1027,13 +1043,21 @@ end = struct
     with
     | Not_found -> Unbound
 
-  let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), kid), _) as kopt) env =
-    if KBindings.mem kid env.typ_vars
-    then typ_error (kid_loc kid) ("type variable " ^ string_of_kinded_id kopt ^ " is already bound")
-    else
-      begin
-        typ_print (lazy (adding ^ "type variable " ^ string_of_kid kid ^ " : " ^ string_of_kind_aux k));
-        { env with typ_vars = KBindings.add kid (l, k) env.typ_vars }
+  let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env =
+    if KBindings.mem v env.typ_vars then begin
+        let n = match KBindings.find_opt v env.shadow_vars with Some n -> n | None -> 0 in
+        let s_l, s_k = KBindings.find v env.typ_vars in 
+        let s_v = Kid_aux (Var (string_of_kid v ^ "#" ^ string_of_int n), l) in
+        typ_print (lazy (Printf.sprintf "%stype variable (shadowing %s) %s : %s" adding (string_of_kid s_v) (string_of_kid v) (string_of_kind_aux k)));
+        { env with
+          constraints = List.map (constraint_subst v (arg_kopt (mk_kopt s_k s_v))) env.constraints;
+          typ_vars = KBindings.add v (l, k) (KBindings.add s_v (s_l, s_k) env.typ_vars);
+          shadow_vars = KBindings.add v (n + 1) env.shadow_vars
+        }
+      end
+    else begin
+        typ_print (lazy (adding ^ "type variable " ^ string_of_kid v ^ " : " ^ string_of_kind_aux k));
+        { env with typ_vars = KBindings.add v (l, k) env.typ_vars }
       end
 
   let add_num_def id nexp env =
@@ -1174,8 +1198,8 @@ let bind_numeric l typ env =
 
 (** Pull an (potentially)-existentially qualified type into the global
    typing environment **)
-let bind_existential l typ env =
-  match destruct_exist (Env.expand_synonyms env typ) with
+let bind_existential l name typ env =
+  match destruct_exist ~name:name (Env.expand_synonyms env typ) with
   | Some (kids, nc, typ) -> typ, add_existential l kids nc env
   | None -> typ, env
 
@@ -1439,13 +1463,17 @@ and unify_typ_arg l env goals (A_aux (aux1, _) as typ_arg1) (A_aux (aux2, _) as
   | A_typ typ1, A_typ typ2 -> unify_typ l env goals typ1 typ2
   | A_nexp nexp1, A_nexp nexp2 -> unify_nexp l env goals nexp1 nexp2
   | A_order ord1, A_order ord2 -> unify_order l goals ord1 ord2
-  | A_bool nc1, A_bool nc2 -> unify_constraint l goals nc1 nc2
+  | A_bool nc1, A_bool nc2 -> unify_constraint l env goals nc1 nc2
   | _, _ -> unify_error l ("Could not unify type arguments " ^ string_of_typ_arg typ_arg1 ^ " and " ^ string_of_typ_arg typ_arg2)
 
-and unify_constraint l goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as nc2) =
+and unify_constraint l env goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as nc2) =
   typ_debug (lazy (Util.("Unify constraint " |> magenta |> clear) ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2));
   match aux1, aux2 with
   | NC_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_bool nc2)
+  | NC_and (nc1a, nc2a), NC_and (nc1b, nc2b) | NC_or (nc1a, nc2a), NC_or (nc1b, nc2b) ->
+     merge_uvars l (unify_constraint l env goals nc1a nc1b) (unify_constraint l env goals nc2a nc2b)
+  | NC_app (f1, args1), NC_app (f2, args2) when Id.compare f1 f2 = 0 && List.length args1 = List.length args2 ->
+     List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2)
   | _, _ -> unify_error l ("Could not unify constraints " ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2)
 
 and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) =
@@ -1489,7 +1517,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
        then unify_nexp l env goals n1a (nsum nexp2 n1b)
        else unify_error l ("Cannot unify minus Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
     | Nexp_times (n1a, n1b) ->
-       (* f we have SMT operations div and mod, then we can use the
+       (* If we have SMT operations div and mod, then we can use the
           property that
 
           mod(m, C) = 0 && C != 0 --> (C * n = m <--> n = m / C)
@@ -2525,7 +2553,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
         typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " for unification"));
         try
           let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
-          let ityp, env = bind_existential l (typ_of inferred_cast) env in
+          let ityp, env = bind_existential l None (typ_of inferred_cast) env in
           inferred_cast, unify l env goals typ ityp, env
         with
         | Type_error (_, err) -> try_casts casts
@@ -2535,7 +2563,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
   begin
     try
       typ_debug (lazy ("Coercing unification: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ));
-      let atyp, env = bind_existential l (typ_of annotated_exp) env in
+      let atyp, env = bind_existential l None (typ_of annotated_exp) env in
       annotated_exp, unify l env goals typ atyp, env
     with
     | Unification_error (_, m) when Env.allow_casts env ->
@@ -2549,7 +2577,7 @@ and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ =
   | tpat, env, [] -> tpat, env
 
 and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
-  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
+  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l (name_pat pat) typ env in
   typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_pat pat ^  " to " ^ string_of_typ typ));
   let annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ pat typ = match pat with
@@ -3442,7 +3470,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   exp
 
 and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (Typ_aux (typ_aux, _) as typ) =
-  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l typ env in
+  let (Typ_aux (typ_aux, _) as typ), env = bind_existential l None typ env in
   typ_print (lazy (Util.("Binding " |> yellow |> clear) ^ string_of_mpat mpat ^  " to " ^ string_of_typ typ));
   let annot_mpat mpat typ' = MP_aux (mpat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ mpat typ = match mpat with
diff --git a/src/type_check.mli b/src/type_check.mli
index 81682606..c470e9c4 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -212,8 +212,8 @@ val add_typquant : Ast.l -> typquant -> Env.t -> Env.t
    is not existential. This function will pick a fresh name for the
    existential to ensure that no name-clashes occur. The "plain"
    version does not treat numeric types as existentials. *)
-val destruct_exist_plain : typ -> (kinded_id list * n_constraint * typ) option
-val destruct_exist : typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist_plain : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
+val destruct_exist : ?name:string option -> typ -> (kinded_id list * n_constraint * typ) option
 
 val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t
 
@@ -356,7 +356,7 @@ val destruct_atom_nexp : Env.t -> typ -> nexp option
 
 val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option
 
-val destruct_numeric : typ -> (kid list * n_constraint * nexp) option
+val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * nexp) option
 
 val destruct_vector : Env.t -> typ -> (nexp * order * typ) option
 
-- 
cgit v1.2.3


From 40f7f5d00a9afff27f1d2329ab525705e57c6d6f Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 19 Dec 2018 20:18:04 +0000
Subject: Improve sizeof rewriting performance

Simply constraints further before calling Z3 to improve performance of
sizeof re-writing.
---
 src/ast_util.ml       | 17 +++++++++++++++--
 src/constraint.ml     |  6 +++++-
 src/constraint.mli    |  2 ++
 src/initial_check.ml  |  4 ++++
 src/initial_check.mli |  1 +
 src/isail.ml          |  3 +++
 src/sail.ml           |  3 +++
 src/type_check.ml     | 32 +++++++++++---------------------
 8 files changed, 44 insertions(+), 24 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 55f8c61c..36263615 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -321,10 +321,23 @@ let rec constraint_simp (NC_aux (nc_aux, l)) =
        | NC_aux (nc, _), NC_aux (NC_true, _) -> NC_true
        | _, _ -> NC_or (nc1, nc2)
        end
+
     | NC_bounded_ge (nexp1, nexp2) ->
-       NC_bounded_ge (nexp_simp nexp1, nexp_simp nexp2)
+       let nexp1, nexp2 = nexp_simp nexp1, nexp_simp nexp2 in
+       begin match nexp1, nexp2 with
+       | Nexp_aux (Nexp_constant c1, _), Nexp_aux (Nexp_constant c2, _) ->
+          if Big_int.greater_equal c1 c2 then NC_true else NC_false
+       | _, _ -> NC_bounded_ge (nexp1, nexp2)
+       end
+
     | NC_bounded_le (nexp1, nexp2) ->
-       NC_bounded_le (nexp_simp nexp1, nexp_simp nexp2)
+       let nexp1, nexp2 = nexp_simp nexp1, nexp_simp nexp2 in
+       begin match nexp1, nexp2 with
+       | Nexp_aux (Nexp_constant c1, _), Nexp_aux (Nexp_constant c2, _) ->
+          if Big_int.less_equal c1 c2 then NC_true else NC_false
+       | _, _ -> NC_bounded_le (nexp1, nexp2)
+       end
+
     | _ -> nc_aux
   in
   NC_aux (nc_aux, l)
diff --git a/src/constraint.ml b/src/constraint.ml
index 7ead0cc8..b00c0a4e 100644
--- a/src/constraint.ml
+++ b/src/constraint.ml
@@ -53,6 +53,8 @@ open Ast
 open Ast_util
 open Util
 
+let opt_smt_verbose = ref false
+
 (* SMTLIB v2.0 format is based on S-expressions so we have a
    lightweight representation of those here. *)
 type sexpr = List of (sexpr list) | Atom of string
@@ -185,7 +187,9 @@ let call_z3' l vars constraints : smt_result =
   let problems = [constraints] in
   let z3_file = smtlib_of_constraints l vars constraints in
 
-  (* prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file); *)
+  if !opt_smt_verbose then
+    prerr_endline (Printf.sprintf "SMTLIB2 constraints are: \n%s%!" z3_file)
+  else ();
 
   let rec input_lines chan = function
     | 0 -> []
diff --git a/src/constraint.mli b/src/constraint.mli
index 51088245..fa318c35 100644
--- a/src/constraint.mli
+++ b/src/constraint.mli
@@ -52,6 +52,8 @@ module Big_int = Nat_big_num
 open Ast
 open Ast_util
 
+val opt_smt_verbose : bool ref
+
 type smt_result = Unknown | Sat | Unsat
 
 val load_digests : unit -> unit
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 17b4b515..16597b3a 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -795,6 +795,10 @@ let typ_of_string str =
   let typ = to_ast_typ initial_ctx typ in
   typ
 
+let constraint_of_string str =
+  let atyp = Parser.typ_eof Lexer.token (Lexing.from_string str) in
+  to_ast_constraint initial_ctx atyp
+
 let extern_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> Some (string_of_id id)), false))
 let val_spec_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, (fun _ -> None), false))
 
diff --git a/src/initial_check.mli b/src/initial_check.mli
index 25187e4c..9d2beab2 100644
--- a/src/initial_check.mli
+++ b/src/initial_check.mli
@@ -92,3 +92,4 @@ val val_spec_of_string : id -> string -> unit def
 
 val exp_of_string : string -> unit exp
 val typ_of_string : string -> typ
+val constraint_of_string : string -> n_constraint
diff --git a/src/isail.ml b/src/isail.ml
index 18c59e0b..baeacdb5 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -273,6 +273,9 @@ let handle_input' input =
          | ":canon" ->
             let typ = Initial_check.typ_of_string arg in
             print_endline (string_of_typ (Type_check.canonicalize !interactive_env typ))
+         | ":prove" ->
+            let nc = Initial_check.constraint_of_string arg in
+            print_endline (string_of_bool (Type_check.prove !interactive_env nc))
          | ":v" | ":verbose" ->
             Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3;
             print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug)
diff --git a/src/sail.ml b/src/sail.ml
index 59190d15..f88fff5a 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -239,6 +239,9 @@ let options = Arg.align ([
   ( "-dtc_verbose",
     Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity),
     "<verbosity> (debug) verbose typechecker output: 0 is silent");
+  ( "-dsmt_verbose",
+    Arg.Set Constraint.opt_smt_verbose,
+    " (debug) print SMTLIB constraints sent to Z3");
   ( "-dno_cast",
     Arg.Set opt_dno_cast,
     " (debug) typecheck without any implicit casting");
diff --git a/src/type_check.ml b/src/type_check.ml
index ba7b2acb..97979b8c 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -682,12 +682,11 @@ end = struct
     | Nexp_id _ -> ()
     | Nexp_var kid when KidSet.mem kid exs -> ()
     | Nexp_var kid ->
-       begin
-         match get_typ_var kid env with
-         | K_int -> ()
-         | kind -> typ_error l ("Constraint is badly formed, "
-                                ^ string_of_kid kid ^ " has kind "
-                                ^ string_of_kind_aux kind ^ " but should have kind Int")
+       begin match get_typ_var kid env with
+       | K_int -> ()
+       | kind -> typ_error l ("Constraint is badly formed, "
+                              ^ string_of_kid kid ^ " has kind "
+                              ^ string_of_kind_aux kind ^ " but should have kind Int")
        end
     | Nexp_constant _ -> ()
     | Nexp_app (id, nexps) ->
@@ -700,12 +699,11 @@ end = struct
   and wf_order env (Ord_aux (ord_aux, l) as ord) =
     match ord_aux with
     | Ord_var kid ->
-       begin
-         match get_typ_var kid env with
-         | K_order -> ()
-         | kind -> typ_error l ("Order is badly formed, "
-                                ^ string_of_kid kid ^ " has kind "
-                                ^ string_of_kind_aux kind ^ " but should have kind Order")
+       begin match get_typ_var kid env with
+       | K_order -> ()
+       | kind -> typ_error l ("Order is badly formed, "
+                              ^ string_of_kid kid ^ " has kind "
+                              ^ string_of_kind_aux kind ^ " but should have kind Order")
        end
     | Ord_inc | Ord_dec -> ()
   and wf_constraint ?exs:(exs=KidSet.empty) env (NC_aux (nc_aux, l) as nc) =
@@ -1294,17 +1292,9 @@ let solve env (Nexp_aux (_, l) as nexp) =
 
 let prove env nc =
   typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
-  let (NC_aux (nc_aux, _) as nc) = Env.expand_constraint_synonyms env nc in
+  let (NC_aux (nc_aux, _) as nc) = constraint_simp (Env.expand_constraint_synonyms env nc) in
   typ_debug ~level:2 (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
-  let compare_const f (Nexp_aux (n1, _)) (Nexp_aux (n2, _)) =
-    match n1, n2 with
-    | Nexp_constant c1, Nexp_constant c2 when f c1 c2 -> true
-    | _, _ -> false
-  in
   match nc_aux with
-  | NC_equal (nexp1, nexp2) when compare_const Big_int.equal (nexp_simp nexp1) (nexp_simp nexp2) -> true
-  | NC_bounded_le (nexp1, nexp2) when compare_const Big_int.less_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true
-  | NC_bounded_ge (nexp1, nexp2) when compare_const Big_int.greater_equal (nexp_simp nexp1) (nexp_simp nexp2) -> true
   | NC_true -> true
   | _ -> prove_z3 env nc
 
-- 
cgit v1.2.3


From 0a9200153430f5e727b3ebe1fa272d4842069530 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 20 Dec 2018 22:00:40 +0000
Subject: Fix monomorpisation tests with typechecker changes

Add an extra argument for Type_check.prove for the location of the prove
call (as prove __POS__) to help debug SMT related issues
---
 src/c_backend.ml        |   6 +--
 src/constraint.ml       |  30 ++++++++++----
 src/isail.ml            |   2 +-
 src/monomorphise.ml     | 103 +++++++++++++++++++++++++++---------------------
 src/pretty_print_coq.ml |   6 +--
 src/pretty_print_lem.ml |   2 +-
 src/rewrites.ml         |   6 +--
 src/type_check.ml       |  48 ++++++++++++----------
 src/type_check.mli      |   2 +-
 9 files changed, 119 insertions(+), 86 deletions(-)

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index 65702764..79d4693a 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -150,7 +150,7 @@ let rec ctyp_of_typ ctx typ =
              when Big_int.less_equal min_int64 n && Big_int.less_equal m max_int64 ->
            CT_int64
         | n, m when ctx.optimize_z3 ->
-           if prove ctx.local_env (nc_lteq (nconstant min_int64) n) && prove ctx.local_env (nc_lteq m (nconstant max_int64)) then
+           if prove __POS__ ctx.local_env (nc_lteq (nconstant min_int64) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant max_int64)) then
              CT_int64
            else
              CT_int
@@ -171,7 +171,7 @@ let rec ctyp_of_typ ctx typ =
      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_z3 && prove ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction
+     | n when ctx.optimize_z3 && prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction
      | _ -> CT_lbits direction
      end
 
@@ -541,7 +541,7 @@ let analyze_primop' ctx id args typ =
         | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _)
                when Big_int.less_equal min_int64 n && Big_int.less_equal m max_int64 ->
            AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_int64))
-        | n, m when prove ctx.local_env (nc_lteq (nconstant min_int64) n) && prove ctx.local_env (nc_lteq m (nconstant max_int64)) ->
+        | n, m when prove __POS__ ctx.local_env (nc_lteq (nconstant min_int64) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant max_int64)) ->
            AE_val (AV_C_fragment (F_op (op1, "+", op2), typ, CT_int64))
         | _ -> no_change
      end
diff --git a/src/constraint.ml b/src/constraint.ml
index b00c0a4e..af024ce3 100644
--- a/src/constraint.ml
+++ b/src/constraint.ml
@@ -208,12 +208,21 @@ let call_z3' l vars constraints : smt_result =
   with
   | Not_found ->
     begin
-      let (input_file, tmp_chan) = Filename.open_temp_file "constraint_" ".sat" in
+      let (input_file, tmp_chan) =
+        try Filename.open_temp_file "constraint_" ".sat" with
+        | Sys_error msg -> raise (Reporting.err_general l ("Could not open temp file when calling Z3: " ^ msg))
+      in
       output_string tmp_chan z3_file;
       close_out tmp_chan;
-      let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in
-      let z3_output = List.combine problems (input_lines z3_chan (List.length problems)) in
-      let _ = Unix.close_process_in z3_chan in
+      let z3_output =
+        try
+          let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in
+          let z3_output = List.combine problems (input_lines z3_chan (List.length problems)) in
+          let _ = Unix.close_process_in z3_chan in
+          z3_output
+        with
+        | exn -> raise (Reporting.err_general l ("Error when calling z3: " ^ Printexc.to_string exn))
+      in
       Sys.remove input_file;
       try
         let (problem, _) = List.find (fun (_, result) -> result = "unsat") z3_output in
@@ -250,9 +259,16 @@ let rec solve_z3 l vars constraints var =
   let (input_file, tmp_chan) = Filename.open_temp_file "constraint_" ".sat" in
   output_string tmp_chan z3_file;
   close_out tmp_chan;
-  let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in
-  let z3_output = String.concat " " (input_all z3_chan) in
-  let _ = Unix.close_process_in z3_chan in
+  let z3_output =
+    try
+      let z3_chan = Unix.open_process_in ("z3 -t:1000 -T:10 " ^ input_file) in
+      let z3_output = String.concat " " (input_all z3_chan) in
+      let _ = Unix.close_process_in z3_chan in
+      z3_output
+    with
+    | exn ->
+       raise (Reporting.err_general l ("Got error when calling z3: " ^ Printexc.to_string exn))
+  in
   Sys.remove input_file;
   let regexp = {|(define-fun v|} ^ Util.zencode_string (string_of_kid var) ^ {| () Int[ ]+\([0-9]+\))|} in
   try
diff --git a/src/isail.ml b/src/isail.ml
index baeacdb5..d8876cf0 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -275,7 +275,7 @@ let handle_input' input =
             print_endline (string_of_typ (Type_check.canonicalize !interactive_env typ))
          | ":prove" ->
             let nc = Initial_check.constraint_of_string arg in
-            print_endline (string_of_bool (Type_check.prove !interactive_env nc))
+            print_endline (string_of_bool (Type_check.prove __POS__ !interactive_env nc))
          | ":v" | ":verbose" ->
             Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3;
             print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug)
diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 4bb1876c..fc2a9de6 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -100,36 +100,36 @@ let subst_nexp substs nexp =
     | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args))
   in s_snexp substs nexp
 
-let rec subst_nc substs (NC_aux (nc,l) as n_constraint) =
-  let snexp nexp = subst_nexp substs nexp in
-  let snc nc = subst_nc substs nc in
-  let re nc = NC_aux (nc,l) in
-  match nc with
-  | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2))
-  | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2))
-  | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2))
-  | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2))
-  | NC_set (kid,is) ->
-     begin
-       match KBindings.find kid substs with
-       | Nexp_aux (Nexp_constant i,_) ->
-          if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false
-       | nexp -> 
-          raise (Reporting.err_general l
-                   ("Unable to substitute " ^ string_of_nexp nexp ^
-                       " into set constraint " ^ string_of_n_constraint n_constraint))
-       | exception Not_found -> n_constraint
-     end
-  | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2))
-  | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2))
-  | NC_true
-  | NC_false
+let subst_nc, subst_src_typ, subst_src_typ_arg =
+  let rec subst_nc substs (NC_aux (nc,l) as n_constraint) =
+    let snexp nexp = subst_nexp substs nexp in
+    let snc nc = subst_nc substs nc in
+    let re nc = NC_aux (nc,l) in
+    match nc with
+    | NC_equal (n1,n2) -> re (NC_equal (snexp n1, snexp n2))
+    | NC_bounded_ge (n1,n2) -> re (NC_bounded_ge (snexp n1, snexp n2))
+    | NC_bounded_le (n1,n2) -> re (NC_bounded_le (snexp n1, snexp n2))
+    | NC_not_equal (n1,n2) -> re (NC_not_equal (snexp n1, snexp n2))
+    | NC_set (kid,is) ->
+       begin
+         match KBindings.find kid substs with
+         | Nexp_aux (Nexp_constant i,_) ->
+            if List.exists (fun j -> Big_int.equal i j) is then re NC_true else re NC_false
+         | nexp -> 
+            raise (Reporting.err_general l
+                     ("Unable to substitute " ^ string_of_nexp nexp ^
+                        " into set constraint " ^ string_of_n_constraint n_constraint))
+         | exception Not_found -> n_constraint
+       end
+    | NC_or (nc1,nc2) -> re (NC_or (snc nc1, snc nc2))
+    | NC_and (nc1,nc2) -> re (NC_and (snc nc1, snc nc2))
+    | NC_true
+      | NC_false
       -> n_constraint
-
-
-
-let subst_src_typ substs t =
-  let rec s_styp substs ((Typ_aux (t,l)) as ty) =
+    | NC_var kid -> re (NC_var kid)
+    | NC_app (f, args) ->
+       re (NC_app (f, List.map (s_starg substs) args))
+  and  s_styp substs ((Typ_aux (t,l)) as ty) =
     let re t = Typ_aux (t,l) in
     match t with
     | Typ_id _
@@ -148,7 +148,8 @@ let subst_src_typ substs t =
     | A_nexp ne -> A_aux (A_nexp (subst_nexp substs ne),l)
     | A_typ t -> A_aux (A_typ (s_styp substs t),l)
     | A_order _ -> targ
-  in s_styp substs t
+    | A_bool nc -> A_aux (A_bool (subst_nc substs nc), l)
+  in subst_nc, s_styp, s_starg
 
 let make_vector_lit sz i =
   let f j = if Big_int.equal (Big_int.modulus (Big_int.shift_right i (sz-j-1)) (Big_int.of_int 2)) Big_int.zero then '0' else '1' in
@@ -727,8 +728,10 @@ let fabricate_nexp_exist env l typ kids nc typ' =
       when Kid.compare kid kid'' = 0 &&
         Kid.compare kid kid''' = 0 ->
      nint 32
-  | _ -> raise (Reporting.err_general l
-                  ("Undefined value at unsupported type " ^ string_of_typ typ))
+  | ([], _, typ) -> nint 32
+  | (kids, nc, typ) ->
+     raise (Reporting.err_general l
+              ("Undefined value at unsupported type " ^ string_of_typ typ ^ " with " ^ Util.string_of_list ", " string_of_kid kids))
 
 let fabricate_nexp l tannot =
   match destruct_tannot tannot with
@@ -756,7 +759,7 @@ let reduce_cast typ exp l annot =
   | E_aux (E_lit (L_aux (L_num n,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' ->
      let nc_env = Env.add_typ_var l kopt env in
      let nc_env = Env.add_constraint (nc_eq (nvar (kopt_kid kopt)) (nconstant n)) nc_env in
-     if prove nc_env nc
+     if prove __POS__ nc_env nc
      then exp
      else raise (Reporting.err_unreachable l __POS__
                    ("Constant propagation error: literal " ^ Big_int.to_string n ^
@@ -1176,7 +1179,7 @@ let apply_pat_choices choices =
 let is_env_inconsistent env ksubsts =
   let env = KBindings.fold (fun k nexp env ->
     Env.add_constraint (nc_eq (nvar k) nexp) env) ksubsts env in
-  prove env nc_false
+  prove __POS__ env nc_false
 
 let split_defs all_errors splits defs =
   let no_errors_happened = ref true in
@@ -1663,7 +1666,7 @@ let split_defs all_errors splits defs =
     let substs = bindings_from_list substs, ksubsts in
     fst (const_prop_exp ref_vars substs Bindings.empty exp)
   in
-    
+
   (* Split a variable pattern into every possible value *)
 
   let split var pat_l annot =
@@ -1686,7 +1689,7 @@ let split_defs all_errors splits defs =
         else raise (Fatal_error error)
     in
     match ty with
-    | Typ_id (Id_aux (Id "bool",_)) ->
+    | Typ_id (Id_aux (Id "bool",_)) | Typ_app (Id_aux (Id "atom_bool", _), [_]) ->
        [P_aux (P_lit (L_aux (L_true,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_true,new_l)),(new_l,annot))],[],[];
         P_aux (P_lit (L_aux (L_false,new_l)),(l,annot)),[var, E_aux (E_lit (L_aux (L_false,new_l)),(new_l,annot))],[],[]]
 
@@ -2259,7 +2262,7 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) =
   let replace_size size = 
     (* TODO: pick simpler nexp when there's a choice (also in pretty printer) *)
     let is_equal nexp =
-      prove env (NC_aux (NC_equal (size,nexp), Parse_ast.Unknown))
+      prove __POS__ env (NC_aux (NC_equal (size,nexp), Parse_ast.Unknown))
     in
     if is_nexp_constant size then size else
       match List.find is_equal bound_nexps with
@@ -2345,9 +2348,9 @@ in *)
               | i -> IntSet.singleton i
               | exception Not_found ->
                  (* Look for equivalent nexps, but only in consistent type env *)
-                 if prove env (NC_aux (NC_false,Unknown)) then IntSet.empty else
+                 if prove __POS__ env (NC_aux (NC_false,Unknown)) then IntSet.empty else
                    match List.find (fun (nexp,i) -> 
-                     prove env (NC_aux (NC_equal (nexp,size),Unknown))) nexp_list with
+                     prove __POS__ env (NC_aux (NC_equal (nexp,size),Unknown))) nexp_list with
                    | _, i -> IntSet.singleton i
                    | exception Not_found -> IntSet.empty
           end
@@ -2848,11 +2851,15 @@ let rec deps_of_nc kid_deps (NC_aux (nc,l)) =
   | NC_true
   | NC_false
     -> dempty
+  | NC_app (Id_aux (Id "mod", _), [A_aux (A_nexp nexp1, _); A_aux (A_nexp nexp2, _)])
+    -> dmerge (deps_of_nexp l kid_deps [] nexp1) (deps_of_nexp l kid_deps [] nexp2)
+  | NC_var _ | NC_app _
+    -> dempty
 
-let deps_of_typ l kid_deps arg_deps typ =
+and deps_of_typ l kid_deps arg_deps typ =
   deps_of_tyvars l kid_deps arg_deps (tyvars_of_typ typ)
 
-let deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) =
+and deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) =
   match aux with
   | A_nexp (Nexp_aux (Nexp_var kid,_))
       when List.exists (fun k -> Kid.compare kid k == 0) env.top_kids ->
@@ -2861,7 +2868,7 @@ let deps_of_typ_arg l fn_id env arg_deps (A_aux (aux, _)) =
   | A_order _ -> InFun dempty
   | A_typ typ -> InFun (deps_of_typ l env.kid_deps arg_deps typ)
   | A_bool nc -> InFun (deps_of_nc env.kid_deps nc)
-                     
+
 let mk_subrange_pattern vannot vstart vend =
   let (len,ord,typ) = vector_typ_args_of (Env.base_typ_of (env_of_annot vannot) (typ_of_annot vannot)) in
   match ord with
@@ -2936,7 +2943,11 @@ let simplify_size_nexp env typ_env (Nexp_aux (ne,l) as nexp) =
   | Some n -> nconstant n
   | None ->
      let is_equal kid =
-       prove typ_env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown))
+       (* AA: top_kids should be changed to top_kopts so we don't end
+          up trying to prove v == nexp for a non-Int v. *)
+       try
+         prove __POS__ typ_env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown))
+       with _ -> false
      in
      match ne with
      | Nexp_var _
@@ -3935,7 +3946,7 @@ let simplify_size_nexp env quant_kids (Nexp_aux (_,l) as nexp) =
   | Some n -> Some (nconstant n)
   | None ->
      let is_equal kid =
-       prove env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown))
+       prove __POS__ env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown))
      in
      match List.find is_equal quant_kids with
      | kid -> Some (Nexp_aux (Nexp_var kid,Generated l))
@@ -4198,7 +4209,7 @@ let replace_nexp_in_typ env typ orig new_nexp =
   and aux_targ (A_aux (ta,l) as typ_arg) =
     match ta with
     | A_nexp nexp ->
-       if prove env (nc_eq nexp orig)
+       if prove __POS__ env (nc_eq nexp orig)
        then true, A_aux (A_nexp new_nexp,l)
        else false, typ_arg
     | A_typ typ ->
@@ -4227,7 +4238,7 @@ let fresh_nexp_kid nexp =
 
 let rewrite_toplevel_nexps (Defs defs) =
   let find_nexp env nexp_map nexp =
-    let is_equal (kid,nexp') = prove env (nc_eq nexp nexp') in
+    let is_equal (kid,nexp') = prove __POS__ env (nc_eq nexp nexp') in
     List.find is_equal nexp_map
   in
   let rec rewrite_typ_in_spec env nexp_map (Typ_aux (t,ann) as typ_full) =
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index 18e288dd..b408c6eb 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -542,7 +542,7 @@ let replace_typ_size ctxt env (Typ_aux (t,a)) =
        | Some n -> mk_typ (nconstant n)
        | None ->
           let is_equal nexp =
-            prove env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown))
+            prove __POS__ env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown))
           in match List.find is_equal (NexpSet.elements ctxt.bound_nexps) with
           | nexp -> mk_typ nexp
           | exception Not_found -> None
@@ -837,7 +837,7 @@ let similar_nexps ctxt env n1 n2 =
        by tracking which existential kids are equal to bound kids. *)
     | Nexp_var k1, Nexp_var k2 ->
        Kid.compare k1 k2 == 0 ||
-         (prove env (nc_eq (nvar k1) (nvar k2)) && (
+         (prove __POS__ env (nc_eq (nvar k1) (nvar k2)) && (
             not (KidSet.mem k1 ctxt.bound_nvars) ||
               not (KidSet.mem k2 ctxt.bound_nvars)))
     | Nexp_constant c1, Nexp_constant c2 -> Nat_big_num.equal c1 c2
@@ -895,7 +895,7 @@ let is_range_from_atom env (Typ_aux (argty,_)) (Typ_aux (fnty,_)) =
   | Typ_app(Id_aux (Id "atom", _), [A_aux (A_nexp nexp,_)]),
     Typ_app(Id_aux (Id "range", _), [A_aux(A_nexp low,_);
                                      A_aux(A_nexp high,_)]) ->
-     Type_check.prove env (nc_and (nc_eq nexp low) (nc_eq nexp high))
+     Type_check.prove __POS__ env (nc_and (nc_eq nexp low) (nc_eq nexp high))
   | _ -> false
 
 (* Get a more general type for an annotation/expression - i.e.,
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index ea34ef3d..90ae2dba 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -356,7 +356,7 @@ let replace_typ_size ctxt env (Typ_aux (t,a)) =
        | Some n -> mk_typ (nconstant n)
        | None ->
           let is_equal nexp =
-            prove env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown))
+            prove __POS__ env (NC_aux (NC_equal (size,nexp),Parse_ast.Unknown))
           in match List.find is_equal (NexpSet.elements ctxt.bound_nexps) with
           | nexp -> mk_typ nexp
           | exception Not_found -> None
diff --git a/src/rewrites.ml b/src/rewrites.ml
index e87847bd..ea8ccaf9 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -332,18 +332,18 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
   let extract_typ_var l env nexp (id, (_, typ)) =
     let var = E_aux (E_id id, (l, mk_tannot env typ no_effect)) in
     match destruct_atom_nexp env typ with
-    | Some size when prove env (nc_eq size nexp) -> Some var
+    | Some size when prove __POS__ env (nc_eq size nexp) -> Some var
     (* AA: This next case is a bit of a hack... is there a more
        general way to deal with trivial nexps that are offset by
        constants? This will resolve a 'n - 1 sizeof when 'n is in
        scope. *)
-    | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) ->
+    | Some size when prove __POS__ env (nc_eq (nsum size (nint 1)) nexp) ->
        let one_exp = infer_exp env (mk_lit_exp (L_num (Big_int.of_int 1))) in
        Some (E_aux (E_app (mk_id "add_atom", [var; one_exp]), (gen_loc l, mk_tannot env (atom_typ (nsum size (nint 1))) no_effect)))
     | _ ->
        begin
          match destruct_vector env typ with
-         | Some (len, _, _) when prove env (nc_eq len nexp) ->
+         | Some (len, _, _) when prove __POS__ env (nc_eq len nexp) ->
             Some (E_aux (E_app (mk_id "length", [var]), (l, mk_tannot env (atom_typ len) no_effect)))
          | _ -> None
        end
diff --git a/src/type_check.ml b/src/type_check.ml
index 97979b8c..cb20ae2e 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1290,10 +1290,15 @@ let solve env (Nexp_aux (_, l) as nexp) =
     let constr = List.fold_left nc_and (nc_eq (nvar (mk_kid "solve#")) nexp) (Env.get_constraints env) in
     Constraint.solve_z3 l vars constr (mk_kid "solve#")
 
-let prove env nc =
+let debug_pos (file, line, _, _) =
+  "(" ^ file ^ "/" ^ string_of_int line ^ ") "
+
+let prove pos env nc =
   typ_print (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
   let (NC_aux (nc_aux, _) as nc) = constraint_simp (Env.expand_constraint_synonyms env nc) in
-  typ_debug ~level:2 (lazy (Util.("Prove " |> red |> clear) ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc));
+  if !Constraint.opt_smt_verbose then
+    prerr_endline (Util.("Prove " |> red |> clear) ^ debug_pos pos ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env) ^ " |- " ^ string_of_n_constraint nc)
+  else ();
   match nc_aux with
   | NC_true -> true
   | _ -> prove_z3 env nc
@@ -1480,7 +1485,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
   if KidSet.is_empty (KidSet.inter (nexp_frees nexp1) goals)
   then
     begin
-      if prove env (NC_aux (NC_equal (nexp1, nexp2), Parse_ast.Unknown))
+      if prove __POS__ env (NC_aux (NC_equal (nexp1, nexp2), Parse_ast.Unknown))
       then KBindings.empty
       else unify_error l ("Nexp " ^ string_of_nexp nexp1 ^ " and " ^ string_of_nexp nexp2 ^ " are not equal")
     end
@@ -1513,7 +1518,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
           mod(m, C) = 0 && C != 0 --> (C * n = m <--> n = m / C)
 
           to help us unify multiplications and divisions. 
-       let valid n c = prove env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove env (nc_neq c (nint 0)) in
+       let valid n c = prove __POS__ env (nc_eq (napp (mk_id "mod") [n; c]) (nint 0)) && prove __POS__ env (nc_neq c (nint 0)) in
        if KidSet.is_empty (nexp_frees n1b) && valid nexp2 n1b then
          unify_nexp l env goals n1a (napp (mk_id "div") [nexp2; n1b])
        else if KidSet.is_empty (nexp_frees n1a) && valid nexp2 n1a then
@@ -1521,7 +1526,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
        if KidSet.is_empty (nexp_frees n1a) then
          begin
            match nexp_aux2 with
-           | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1a, n2a), Parse_ast.Unknown)) ->
+           | Nexp_times (n2a, n2b) when prove __POS__ env (NC_aux (NC_equal (n1a, n2a), Parse_ast.Unknown)) ->
               unify_nexp l env goals n1b n2b
            | Nexp_constant c2 ->
               begin
@@ -1535,7 +1540,7 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
        else if KidSet.is_empty (nexp_frees n1b) then
          begin
            match nexp_aux2 with
-           | Nexp_times (n2a, n2b) when prove env (NC_aux (NC_equal (n1b, n2b), Parse_ast.Unknown)) ->
+           | Nexp_times (n2a, n2b) when prove __POS__ env (NC_aux (NC_equal (n1b, n2b), Parse_ast.Unknown)) ->
               unify_nexp l env goals n1a n2a
            | _ -> unify_error l ("Cannot unify Int expression " ^ string_of_nexp nexp1 ^ " with " ^ string_of_nexp nexp2)
          end
@@ -1751,14 +1756,14 @@ let rec subtyp l env typ1 typ2 =
   (* Special cases for two numeric (atom) types *)
   | Some (kids1, nc1, nexp1), Some ([], _, nexp2) ->
      let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in
-     if prove env (nc_eq nexp1 nexp2) then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     if prove __POS__ env (nc_eq nexp1 nexp2) then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) ->
      let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in
      let env = add_typ_vars l (List.map (mk_kopt K_int) (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2)))) env in
      let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in
      if not (kids2 = []) then typ_error l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else ();
      let env = Env.add_constraint (nc_eq nexp1 nexp2) env in
-     if prove env nc2 then ()
+     if prove __POS__ env nc2 then ()
      else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | _, _ ->
   match typ_aux1, typ_aux2 with
@@ -1794,17 +1799,17 @@ let rec subtyp l env typ1 typ2 =
      in
      let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in
      let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in
-     if prove env nc then ()
+     if prove __POS__ env nc then ()
      else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | None, None -> typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
 
 and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) =
   typ_print (lazy (("Subtype arg " |> Util.green |> Util.clear) ^ string_of_typ_arg arg1 ^ " and " ^ string_of_typ_arg arg2));
   match aux1, aux2 with
-  | A_nexp n1, A_nexp n2 when prove env (nc_eq n1 n2) -> ()
+  | A_nexp n1, A_nexp n2 when prove __POS__ env (nc_eq n1 n2) -> ()
   | A_typ typ1, A_typ typ2 -> subtyp l env typ1 typ2
   | A_order ord1, A_order ord2 when ord_identical ord1 ord2 -> ()
-  | A_bool nc1, A_bool nc2 when prove env (nc_and (nc_or (nc_not nc1) nc2) (nc_or (nc_not nc2) nc1)) -> ()
+  | A_bool nc1, A_bool nc2 when prove __POS__ env (nc_and (nc_or (nc_not nc1) nc2) (nc_or (nc_not nc2) nc1)) -> ()
   | _, _ -> typ_error l "Mismatched argument types in subtype check"
 
 let typ_equality l env typ1 typ2 =
@@ -2101,7 +2106,7 @@ let rec add_constraints constrs env =
 
 let solve_quant env = function
   | QI_aux (QI_id _, _) -> false
-  | QI_aux (QI_const nc, _) -> prove env nc
+  | QI_aux (QI_const nc, _) -> prove __POS__ env nc
 
 (* When doing implicit type coercion, for performance reasons we want
    to filter out the possible casts to only those that could
@@ -2274,12 +2279,12 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      check_exp env (E_aux (E_app (deinfix op, [x; y]), (l, ()))) typ
   | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_prove" ->
      Env.wf_constraint env nc;
-     if prove env nc
+     if prove __POS__ env nc
      then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
      else typ_error l ("Cannot prove " ^ string_of_n_constraint nc)
   | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_not_prove" ->
      Env.wf_constraint env nc;
-     if prove env nc
+     if prove __POS__ env nc
      then typ_error l ("Can prove " ^ string_of_n_constraint nc)
      else annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
   | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_check" ->
@@ -2390,7 +2395,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
   | E_vector vec, _ ->
      let (len, ord, vtyp) = destruct_vec_typ l env typ in
      let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in
-     if prove env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ
+     if prove __POS__ env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ
      else typ_error l "List length didn't match" (* FIXME: improve error message *)
   | E_lit (L_aux (L_undef, _) as lit), _ ->
      if is_typ_monomorphic typ || Env.polymorphic_undefineds env
@@ -3047,10 +3052,10 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
           let nexp1, env = bind_numeric l (typ_of inferred_exp1) env in
           let nexp2, env = bind_numeric l (typ_of inferred_exp2) env in
           begin match ord with
-          | Ord_aux (Ord_inc, _) when !opt_no_lexp_bounds_check || prove env (nc_lteq nexp1 nexp2) ->
+          | Ord_aux (Ord_inc, _) when !opt_no_lexp_bounds_check || prove __POS__ env (nc_lteq nexp1 nexp2) ->
              let len = nexp_simp (nsum (nminus nexp2 nexp1) (nint 1)) in
              annot_lexp (LEXP_vector_range (inferred_v_lexp, inferred_exp1, inferred_exp2)) (vector_typ len ord elem_typ)
-          | Ord_aux (Ord_dec, _) when !opt_no_lexp_bounds_check || prove env (nc_gteq nexp1 nexp2) ->
+          | Ord_aux (Ord_dec, _) when !opt_no_lexp_bounds_check || prove __POS__ env (nc_gteq nexp1 nexp2) ->
              let len = nexp_simp (nsum (nminus nexp1 nexp2) (nint 1)) in
              annot_lexp (LEXP_vector_range (inferred_v_lexp, inferred_exp1, inferred_exp2)) (vector_typ len ord elem_typ)
           | _ -> typ_error l ("Could not infer length of vector slice assignment " ^ string_of_lexp lexp)
@@ -3066,7 +3071,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
             when Id.compare id (mk_id "vector") = 0 ->
           let inferred_exp = infer_exp env exp in
           let nexp, env = bind_numeric l (typ_of inferred_exp) env in
-          if !opt_no_lexp_bounds_check || prove env (nc_and (nc_lteq (nint 0) nexp) (nc_lteq nexp (nexp_simp (nminus len (nint 1))))) then
+          if !opt_no_lexp_bounds_check || prove __POS__ env (nc_and (nc_lteq (nint 0) nexp) (nc_lteq nexp (nexp_simp (nminus len (nint 1))))) then
             annot_lexp (LEXP_vector (inferred_v_lexp, inferred_exp)) elem_typ
           else
             typ_error l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp)
@@ -3126,7 +3131,8 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
        | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound")
      end
   | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
-  | E_sizeof nexp -> annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp nexp)])))
+  | E_sizeof nexp ->
+     annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp nexp)])))
   | E_constraint nc ->
      Env.wf_constraint env nc;
      annot_exp (E_constraint nc) (atom_bool_typ nc)
@@ -4425,7 +4431,7 @@ let mk_synonym typq typ_arg =
   in
   fun env args ->
     let typ_arg, ncs = subst_args kopts args in
-    if List.for_all (prove env) ncs
+    if List.for_all (prove __POS__ env) ncs
     then typ_arg
     else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs
                                       ^ " in type synonym " ^ string_of_typ_arg typ_arg
@@ -4537,7 +4543,7 @@ and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t =
 
 let initial_env =
   Env.empty
-  |> Env.add_prover prove
+  |> Env.add_prover (prove __POS__)
   (* |> Env.add_typ_synonym (mk_id "atom") (fun _ args -> mk_typ (Typ_app (mk_id "range", args @ args))) *)
 
   (* Internal functions for Monomorphise.AtomToItself *)
diff --git a/src/type_check.mli b/src/type_check.mli
index c470e9c4..d1061826 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -301,7 +301,7 @@ val check_fundef : Env.t -> 'a fundef -> tannot def list * Env.t
 
 val check_val_spec : Env.t -> 'a val_spec -> tannot def list * Env.t
 
-val prove : Env.t -> n_constraint -> bool
+val prove : (string * int * int * int) -> Env.t -> n_constraint -> bool
 
 val solve : Env.t -> nexp -> Big_int.num option
 
-- 
cgit v1.2.3


From 367f72900fd24bf51b135f04f6fd301f3e8efb15 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 20 Dec 2018 22:58:44 +0000
Subject: Make sure sail -v prints useful version info

---
 src/Makefile         | 19 +++++++++++--------
 src/ocaml_backend.ml |  2 +-
 src/process_file.ml  |  2 +-
 src/sail.ml          | 15 ++++++++++++++-
 4 files changed, 27 insertions(+), 11 deletions(-)

(limited to 'src')

diff --git a/src/Makefile b/src/Makefile
index 3e9d6f63..b658d90d 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -62,7 +62,7 @@ endif
 endif
 
 
-.PHONY: all sail sail.native sail.byte test clean doc lib power test_power test_idempotence
+.PHONY: all sail sail.native sail.byte manifest.ml test clean doc lib power test_power test_idempotence
 
 # set to -p on command line to enable gprof profiling
 OCAML_OPTS?=
@@ -90,19 +90,22 @@ bytecode.ml: bytecode.lem
 lem_interp/interp_ast.lem: ../language/l2.ott
 	ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott
 
-share_directory.ml:
-	echo "(* Generated file -- do not edit. *)" > share_directory.ml
-	echo let d=\"$(SHARE_DIR)\" >> share_directory.ml
+manifest.ml:
+	echo "(* Generated file -- do not edit. *)" > manifest.ml
+	echo let dir=\"$(SHARE_DIR)\" >> manifest.ml
+	echo let commit=\"$(shell git rev-parse HEAD)\" >> manifest.ml
+	echo let branch=\"$(shell  git rev-parse --abbrev-ref HEAD)\" >> manifest.ml
+	echo let version=\"$(shell git describe)\" >> manifest.ml
 
-sail: ast.ml bytecode.ml share_directory.ml
+sail: ast.ml bytecode.ml manifest.ml
 	ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa
 
-isail: ast.ml bytecode.ml share_directory.ml
+isail: ast.ml bytecode.ml manifest.ml
 	ocamlbuild -use-ocamlfind isail.native
 
 sail.native: sail
 
-sail.byte: ast.ml bytecode.ml share_directory.ml
+sail.byte: ast.ml bytecode.ml manifest.ml
 	ocamlbuild -use-ocamlfind -cflag -g sail.byte
 
 interpreter: lem_interp/interp_ast.lem
@@ -148,7 +151,7 @@ clean:
 	-rm -f bytecode.ml
 	-rm -f bytecode.lem
 	-rm -f bytecode.ml.bak
-	-rm -f share_directory.ml
+	-rm -f manifest.ml
 
 doc:
 	ocamlbuild -use-ocamlfind sail.docdir/index.html
diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index d075e693..ad2c198e 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -963,7 +963,7 @@ let ocaml_compile spec defs generator_types =
   let sail_dir =
     try Sys.getenv "SAIL_DIR" with
     | Not_found ->
-       let share_dir = Share_directory.d in
+       let share_dir = Manifest.dir in
        if Sys.file_exists share_dir then
          share_dir
        else
diff --git a/src/process_file.ml b/src/process_file.ml
index ca013077..0194baa8 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -191,7 +191,7 @@ let rec preprocess opts = function
        let sail_dir =
          try Sys.getenv "SAIL_DIR" with
          | Not_found ->
-            let share_dir = Share_directory.d in
+            let share_dir = Manifest.dir in
             if Sys.file_exists share_dir then
               share_dir
             else
diff --git a/src/sail.ml b/src/sail.ml
index f88fff5a..247cae25 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -304,9 +304,22 @@ let load_files type_envs files =
 
   (out_name, ast, type_envs)
 
+let print_version () =
+  let open Manifest in
+  let default = Printf.sprintf "Sail %s @ %s" branch commit in
+  (* version is the output of git describe *)
+  match String.split_on_char '-' version with
+  | [vnum; _; _] ->
+     (try
+        let vnum = float_of_string vnum +. 2.0 in
+        Printf.printf "Sail %.1f (%s @ %s)\n" vnum branch commit
+      with
+      | Failure _ -> print_endline default)
+  | _ -> print_endline default
+
 let main() =
   if !opt_print_version
-  then Printf.printf "Sail 2.0\n"
+  then print_version ()
   else
     let out_name, ast, type_envs = load_files Type_check.initial_env !opt_file_arguments in
     Util.opt_warnings := false; (* Don't show warnings during re-writing for now *)
-- 
cgit v1.2.3


From 06a6c63388bfdb0b31363a5fc09b7ead5d32d1cf Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Fri, 21 Dec 2018 12:33:21 +0000
Subject: Expand synonyms in generated mapping val-specs

This ensures that mappings round-trip through the pretty-printer and
parser unchanged

Remove guarded_pats rewrite from C compilation. It causes a large
increase in compilation time due to how it interacts with flow
typing/pattern literal re-writing/and sizeof-rewriting
---
 src/rewrites.ml   | 1 -
 src/type_check.ml | 2 +-
 2 files changed, 1 insertion(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index ea8ccaf9..8df5ce02 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -5108,7 +5108,6 @@ let rewrite_defs_c = [
   ("simple_assignments", rewrite_simple_assignments);
   ("remove_vector_concat", rewrite_defs_remove_vector_concat);
   ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats);
-  ("guarded_pats", rewrite_defs_guarded_pats);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
   ("constraint", rewrite_constraint);
   ("trivial_sizeof", rewrite_trivial_sizeof);
diff --git a/src/type_check.ml b/src/type_check.ml
index cb20ae2e..4d8c3bcf 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -4327,7 +4327,7 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md
   typ_debug (lazy ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)));
   let vs_def, env =
     if not have_val_spec then
-      [mk_val_spec env quant typ id], Env.add_val_spec id (quant, typ) env
+      [mk_val_spec env quant (Env.expand_synonyms env typ) id], Env.add_val_spec id (quant, typ) env
     else
       [], env
   in
-- 
cgit v1.2.3


From c745a9a8d8d7d2b04e72bbb8bda9d9f0a7aabbfb Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Fri, 21 Dec 2018 15:15:03 +0000
Subject: Simplify boolean existentials

Remove redundant variables in boolean existentials. A situation can occur
during re-writing when patterns are re-written into simpler guarded
patterns, with the guard containing a large conjunction. Often those
individual conjuncts have no meaning for flow typing, but we'll still
generate a large conjunct bool('p & 'q & 'r & 's ...) for the guard. Now
we can simplify that return type by combining all the type variables
that don't give us any information into a single one, which improves
performance as we can avoid passing all those variables to the
constraint solver.
---
 src/type_check.ml | 49 +++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 47 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 4d8c3bcf..1dfc5957 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -143,7 +143,7 @@ let is_atom_bool (Typ_aux (typ_aux, _)) =
   match typ_aux with
   | Typ_app (f, [_]) when string_of_id f = "atom_bool" -> true
   | _ -> false
-       
+
 let rec strip_id = function
   | Id_aux (Id x, _) -> Id_aux (Id x, Parse_ast.Unknown)
   | Id_aux (DeIid x, _) -> Id_aux (DeIid x, Parse_ast.Unknown)
@@ -1242,10 +1242,55 @@ and is_typ_arg_monomorphic (A_aux (arg, _)) =
 (* 2. Subtyping and constraint solving                                    *)
 (**************************************************************************)
 
+type ('a, 'b) filter =
+  | Keep of 'a
+  | Remove of 'b
+
+let rec filter_keep = function
+  | Keep x :: xs -> x :: filter_keep xs
+  | Remove _ :: xs -> filter_keep xs
+  | [] -> []
+
+let rec filter_remove = function
+  | Keep _ :: xs -> filter_remove xs
+  | Remove x :: xs -> x :: filter_remove xs
+  | [] -> []
+
+let filter_split f g xs =
+  let xs = List.map f xs in
+  filter_keep xs, g (filter_remove xs)
+
 let rec simp_typ (Typ_aux (typ_aux, l)) = Typ_aux (simp_typ_aux typ_aux, l)
 and simp_typ_aux = function
   | Typ_exist (kids1, nc1, Typ_aux (Typ_exist (kids2, nc2, typ), _)) ->
-     Typ_exist (kids1 @ kids2, nc_and nc1 nc2, typ)
+     simp_typ_aux (Typ_exist (kids1 @ kids2, nc_and nc1 nc2, typ))
+
+  (* This removes redundant boolean variables in existentials, such
+     that {('p: Bool) ('q:Bool) ('r: Bool), nc('r). bool('p & 'q & 'r)}
+     would become {('s:Bool) ('r: Bool), nc('r). bool('s & 'r)},
+     wherein all the redundant boolean variables have been combined
+     into a single one. Making this simplification allows us to avoid
+     having to pass large numbers of pointless variables to Z3 if we
+     ever bind this existential. *)
+  | Typ_exist (vars, nc, Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool b, _)]), _)) ->
+     let kids = KidSet.of_list (List.map kopt_kid vars) in
+     let constrained = tyvars_of_constraint nc in
+     let conjs = constraint_conj b in
+     let is_redundant = function
+       | NC_aux (NC_var v, _) when KidSet.mem v kids && not (KidSet.mem v constrained) -> Remove v
+       | nc -> Keep nc
+     in
+     let conjs, redundant = filter_split is_redundant KidSet.of_list conjs in
+     begin match conjs with
+     | [] -> Typ_id (mk_id "bool")
+     | conj :: conjs when KidSet.is_empty redundant ->
+        Typ_exist (vars, nc, atom_bool_typ (List.fold_left nc_and conj conjs))
+     | conjs ->
+        let vars = List.filter (fun v -> not (KidSet.mem (kopt_kid v) redundant)) vars in
+        let var = fresh_existential K_bool in
+        Typ_exist (var :: vars, nc, atom_bool_typ (List.fold_left nc_and (nc_var (kopt_kid var)) conjs))
+     end
+
   | typ_aux -> typ_aux
 
 (* Here's how the constraint generation works for subtyping
-- 
cgit v1.2.3


From 0a65347ed2868b815dee532acfebb463f8be644b Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Sat, 22 Dec 2018 00:20:08 +0000
Subject: Improve error messages and debugging

Work on improving the formatting and quality of error messages

When sail is invoked with sail -i, any type errors now drop the user
down to the interactive prompt, with the interactive environment being
the environment at the point the type error occurred, this means the
typechecker state can be interactively queried in the interpreter to help
diagnose type errors.
---
 src/c_backend.ml        |   2 +-
 src/constant_fold.ml    |   2 +-
 src/error_format.ml     |  95 ++++++++++
 src/interactive.ml      |   7 +
 src/interactive.mli     |   9 +
 src/interpreter.ml      |   2 +-
 src/isail.ml            |  74 ++++----
 src/pretty_print_coq.ml |   2 +-
 src/process_file.ml     |   2 +-
 src/reporting.ml        |  24 +--
 src/reporting.mli       |   8 +-
 src/rewrites.ml         |  18 +-
 src/sail.ml             |  20 +-
 src/type_check.ml       | 486 ++++++++++++++++++++++++------------------------
 src/type_check.mli      |  10 +-
 src/type_error.ml       | 150 +++++----------
 16 files changed, 476 insertions(+), 435 deletions(-)
 create mode 100644 src/error_format.ml
 create mode 100644 src/interactive.ml
 create mode 100644 src/interactive.mli

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index 79d4693a..53e7dc88 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -3460,4 +3460,4 @@ let compile_ast ctx c_includes (Defs defs) =
                                  ^^ model_main)
     |> print_endline
   with
-    Type_error (l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err)
+    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/constant_fold.ml b/src/constant_fold.ml
index 9e474912..7321a801 100644
--- a/src/constant_fold.ml
+++ b/src/constant_fold.ml
@@ -161,7 +161,7 @@ let rec rewrite_constant_function_calls' ast =
         let v = run (Interpreter.Step (lazy "", (lstate, gstate), initial_monad, [])) in
         let exp = exp_of_value v in
         try (ok (); Type_check.check_exp (env_of_annot annot) exp (typ_of_annot annot)) with
-        | Type_error (l, err) ->
+        | Type_error (env, l, err) ->
            (* A type error here would be unexpected, so don't ignore it! *)
            Util.warn ("Type error when folding constants in "
                       ^ string_of_exp (E_aux (e_aux, annot))
diff --git a/src/error_format.ml b/src/error_format.ml
new file mode 100644
index 00000000..3e91f065
--- /dev/null
+++ b/src/error_format.ml
@@ -0,0 +1,95 @@
+
+let rec skip_lines in_chan = function
+  | n when n <= 0 -> ()
+  | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1)
+
+let rec read_lines in_chan = function
+  | n when n <= 0 -> []
+  | n ->
+     let l = input_line in_chan in
+     let ls = read_lines in_chan (n - 1) in
+     l :: ls
+
+type formatter = {
+    indent : string;
+    endline : string -> unit;
+    loc_color : string -> string
+  }
+
+let err_formatter = {
+    indent = "";
+    endline = prerr_endline;
+    loc_color = Util.red
+  }
+
+let buffer_formatter b = {
+    indent = "";
+    endline = (fun str -> Buffer.add_string b (str ^ "\n"));
+    loc_color = Util.red
+  }
+
+let format_endline str ppf = ppf.endline (ppf.indent ^ (Str.global_replace (Str.regexp_string "\n") ("\n" ^ ppf.indent) str))
+
+let underline_single color cnum_from cnum_to =
+  if (cnum_from + 1) >= cnum_to then
+    Util.(String.make cnum_from ' ' ^ clear (color "^"))
+  else
+    Util.(String.make cnum_from ' ' ^ clear (color ("^" ^ String.make (cnum_to - cnum_from - 2) '-' ^ "^")))
+
+let format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf =
+  skip_lines in_chan (lnum - 1);
+  let line = input_line in_chan in
+  let line_prefix = string_of_int lnum ^ Util.(clear (cyan " |")) in
+  let blank_prefix = String.make (String.length (string_of_int lnum)) ' ' ^ Util.(clear (ppf.loc_color " |")) in
+  format_endline (Printf.sprintf "[%s]:%d:%d-%d" Util.(fname |> cyan |> clear) lnum cnum_from cnum_to) ppf;
+  format_endline (line_prefix ^ line) ppf;
+  format_endline (blank_prefix ^ underline_single ppf.loc_color cnum_from cnum_to) ppf;
+  contents { ppf with indent = blank_prefix ^ " " }
+
+let format_code_single fname lnum cnum_from cnum_to contents ppf =
+  try
+    let in_chan = open_in fname in
+    begin
+      try format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf
+      with
+      | _ -> close_in_noerr in_chan; ()
+    end
+  with
+  | _ -> ()
+
+let format_pos p1 p2 contents ppf =
+  let open Lexing in
+  if p1.pos_lnum == p2.pos_lnum
+  then format_code_single p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) contents ppf
+  else failwith "Range"
+
+let format_loc l contents =
+  match l with
+  | Parse_ast.Unknown -> failwith "No location"
+  | Parse_ast.Range (p1, p2) -> format_pos p1 p2 contents
+  | _ -> failwith "not range"
+
+type message =
+  | Location of Parse_ast.l * message
+  | Line of string
+  | List of (string * message) list
+  | Seq of message list
+  | With of (formatter -> formatter) * message
+
+let bullet = Util.(clear (blue "*"))
+
+let rec format_message msg =
+  match msg with
+  | Location (l, msg) ->
+     format_loc l (format_message msg)
+  | Line str ->
+     format_endline str
+  | Seq messages ->
+     fun ppf -> List.iter (fun msg -> format_message msg ppf) messages
+  | List list ->
+     let format_list_item ppf (header, msg) =
+       format_endline (Util.(clear (blue "*")) ^ " " ^ header) ppf;
+       format_message msg { ppf with indent = ppf.indent ^ "   " }
+     in
+     fun ppf -> List.iter (format_list_item ppf) list
+  | With (f, msg) -> fun ppf -> format_message msg (f ppf)
diff --git a/src/interactive.ml b/src/interactive.ml
new file mode 100644
index 00000000..3c4619a0
--- /dev/null
+++ b/src/interactive.ml
@@ -0,0 +1,7 @@
+
+let opt_interactive = ref false
+let opt_suppress_banner = ref false
+
+let env = ref Type_check.initial_env
+
+let ast = ref (Ast.Defs [])
diff --git a/src/interactive.mli b/src/interactive.mli
new file mode 100644
index 00000000..7782f646
--- /dev/null
+++ b/src/interactive.mli
@@ -0,0 +1,9 @@
+open Ast
+open Type_check
+
+val opt_interactive : bool ref
+val opt_suppress_banner : bool ref
+
+val ast : tannot defs ref
+
+val env : Env.t ref
diff --git a/src/interpreter.ml b/src/interpreter.ml
index 194812ca..40ee251d 100644
--- a/src/interpreter.ml
+++ b/src/interpreter.ml
@@ -673,7 +673,7 @@ let rec eval_frame' = function
 
 let eval_frame frame =
   try eval_frame' frame with
-  | Type_check.Type_error (l, err) ->
+  | Type_check.Type_error (env, l, err) ->
      raise (Reporting.err_typ l (Type_error.string_of_type_error err))
 
 let rec run_frame frame =
diff --git a/src/isail.ml b/src/isail.ml
index d8876cf0..a3dfe680 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -90,13 +90,15 @@ let rec user_input callback =
 let sail_logo =
   let banner str = str |> Util.bold |> Util.red |> Util.clear in
   let logo =
-    [ {|    ___       ___       ___       ___ |};
-      {|   /\  \     /\  \     /\  \     /\__\|};
-      {|  /::\  \   /::\  \   _\:\  \   /:/  /|};
-      {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |};
-      {| \:\:\/__/ \/\::/  / \::/\/__/ \:\  \ |};
-      {|  \::/  /    /:/  /   \:\__\    \:\__\|};
-      {|   \/__/     \/__/     \/__/     \/__/|} ]
+    if !Interactive.opt_suppress_banner then []
+    else
+      [ {|    ___       ___       ___       ___ |};
+        {|   /\  \     /\  \     /\  \     /\__\|};
+        {|  /::\  \   /::\  \   _\:\  \   /:/  /|};
+        {| /\:\:\__\ /::\:\__\ /\/::\__\ /:/__/ |};
+        {| \:\:\/__/ \/\::/  / \::/\/__/ \:\  \ |};
+        {|  \::/  /    /:/  /   \:\__\    \:\__\|};
+        {|   \/__/     \/__/     \/__/     \/__/|} ]
   in
   let help =
     [ "Type :commands for a list of commands, and :help <command> for help.";
@@ -104,9 +106,9 @@ let sail_logo =
   in
   List.map banner logo @ [""] @ help @ [""]
 
-let vs_ids = ref (Initial_check.val_spec_ids !interactive_ast)
+let vs_ids = ref (Initial_check.val_spec_ids !Interactive.ast)
 
-let interactive_state = ref (initial_state !interactive_ast Value.primops)
+let interactive_state = ref (initial_state !Interactive.ast Value.primops)
 
 let interactive_bytecode = ref []
 
@@ -259,7 +261,7 @@ let handle_input' input =
          | ":n" | ":normal" ->
             current_mode := Normal
          | ":t" | ":type" ->
-            let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !interactive_env in
+            let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !Interactive.env in
             pretty_sail stdout (doc_binding (typq, typ));
             print_newline ();
          | ":q" | ":quit" ->
@@ -267,15 +269,15 @@ let handle_input' input =
             exit 0
          | ":i" | ":infer" ->
             let exp = Initial_check.exp_of_string arg in
-            let exp = Type_check.infer_exp !interactive_env exp in
+            let exp = Type_check.infer_exp !Interactive.env exp in
             pretty_sail stdout (doc_typ (Type_check.typ_of exp));
             print_newline ()
          | ":canon" ->
             let typ = Initial_check.typ_of_string arg in
-            print_endline (string_of_typ (Type_check.canonicalize !interactive_env typ))
+            print_endline (string_of_typ (Type_check.canonicalize !Interactive.env typ))
          | ":prove" ->
             let nc = Initial_check.constraint_of_string arg in
-            print_endline (string_of_bool (Type_check.prove __POS__ !interactive_env nc))
+            print_endline (string_of_bool (Type_check.prove __POS__ !Interactive.env nc))
          | ":v" | ":verbose" ->
             Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3;
             print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug)
@@ -301,7 +303,7 @@ let handle_input' input =
               | "Order" -> is_order_kopt
               | _ -> failwith "Invalid kind"
             in
-            let ids = Specialize.polymorphic_functions is_kopt !interactive_ast in
+            let ids = Specialize.polymorphic_functions is_kopt !Interactive.ast in
             List.iter (fun id -> print_endline (string_of_id id)) (IdSet.elements ids)
          | ":option" ->
             begin
@@ -312,17 +314,17 @@ let handle_input' input =
               | Arg.Bad message | Arg.Help message -> print_endline message
             end;
          | ":spec" ->
-            let ast, env = Specialize.specialize !interactive_ast !interactive_env in
-            interactive_ast := ast;
-            interactive_env := env;
-            interactive_state := initial_state !interactive_ast Value.primops
+            let ast, env = Specialize.specialize !Interactive.ast !Interactive.env in
+            Interactive.ast := ast;
+            Interactive.env := env;
+            interactive_state := initial_state !Interactive.ast Value.primops
          | ":pretty" ->
-            print_endline (Pretty_print_sail.to_string (Latex.defs !interactive_ast))
+            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_ast in
-            let ast, env = Specialize.specialize ast !interactive_env in
+            let ast = Process_file.rewrite_ast_c !Interactive.ast in
+            let ast, env = Specialize.specialize ast !Interactive.env in
             let ctx = initial_ctx env in
             interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast
          | ":ir" ->
@@ -339,7 +341,7 @@ let handle_input' input =
             print_endline (Pretty_print_sail.to_string (separate_map hardline pp_cdef cdefs))
          | ":ast" ->
             let chan = open_out arg in
-            Pretty_print_sail.pp_defs chan !interactive_ast;
+            Pretty_print_sail.pp_defs chan !Interactive.ast;
             close_out chan
          | ":output" ->
             let chan = open_out arg in
@@ -361,24 +363,24 @@ let handle_input' input =
             | ":elf" -> Elf_loader.load_elf arg
             | ":l" | ":load" ->
                let files = Util.split_on_char ' ' arg in
-               let (_, ast, env) = load_files !interactive_env files in
+               let (_, ast, env) = load_files !Interactive.env files in
                let ast = Process_file.rewrite_ast_interpreter ast in
-               interactive_ast := append_ast !interactive_ast ast;
-               interactive_state := initial_state !interactive_ast Value.primops;
-               interactive_env := env;
-               vs_ids := Initial_check.val_spec_ids !interactive_ast
+               Interactive.ast := append_ast !Interactive.ast ast;
+               interactive_state := initial_state !Interactive.ast Value.primops;
+               Interactive.env := env;
+               vs_ids := Initial_check.val_spec_ids !Interactive.ast
             | ":u" | ":unload" ->
-               interactive_ast := Ast.Defs [];
-               interactive_env := Type_check.initial_env;
-               interactive_state := initial_state !interactive_ast Value.primops;
-               vs_ids := Initial_check.val_spec_ids !interactive_ast;
+               Interactive.ast := Ast.Defs [];
+               Interactive.env := Type_check.initial_env;
+               interactive_state := initial_state !Interactive.ast Value.primops;
+               vs_ids := Initial_check.val_spec_ids !Interactive.ast;
                (* See initial_check.mli for an explanation of why we need this. *)
                Initial_check.have_undefined_builtins := false
             | ":exec" ->
                let open Bytecode_interpreter in
-               let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string arg) 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 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
@@ -389,7 +391,7 @@ let handle_input' input =
        | Expression str ->
           (* An expression in normal mode is type checked, then puts
              us in evaluation mode. *)
-          let exp = Type_check.infer_exp !interactive_env (Initial_check.exp_of_string str) in
+          let exp = Type_check.infer_exp !Interactive.env (Initial_check.exp_of_string str) in
           current_mode := Evaluation (eval_frame (Step (lazy "", !interactive_state, return exp, [])));
           print_program ()
        | Empty -> ()
@@ -444,7 +446,7 @@ let handle_input' input =
 
 let handle_input input =
   try handle_input' input with
-  | Type_check.Type_error (l, err) ->
+  | Type_check.Type_error (env, l, err) ->
      print_endline (Type_error.string_of_type_error err)
   | Reporting.Fatal_error err ->
      Reporting.print_error err
@@ -491,7 +493,7 @@ let () =
   LNoise.history_load ~filename:"sail_history" |> ignore;
   LNoise.history_set ~max_length:100 |> ignore;
 
-  if !opt_interactive then
+  if !Interactive.opt_interactive then
     begin
       List.iter print_endline sail_logo;
       user_input handle_input
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index b408c6eb..a5478c31 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -2457,7 +2457,7 @@ try
         hardline;
         string "End Content.";
         hardline])
-with Type_check.Type_error (l,err) ->
+with Type_check.Type_error (env,l,err) ->
   let extra =
     "\nError during Coq printing\n" ^
     if Printexc.backtrace_status ()
diff --git a/src/process_file.ml b/src/process_file.ml
index 0194baa8..03fc36a2 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -384,7 +384,7 @@ let rewrite_step defs (name, rewriter) =
 
 let rewrite rewriters defs =
   try List.fold_left rewrite_step defs rewriters with
-  | Type_check.Type_error (l, err) ->
+  | Type_check.Type_error (_, l, err) ->
      raise (Reporting.err_typ l (Type_error.string_of_type_error err))
 
 let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)]
diff --git a/src/reporting.ml b/src/reporting.ml
index 858e5c41..f27e4c03 100644
--- a/src/reporting.ml
+++ b/src/reporting.ml
@@ -238,20 +238,15 @@ let loc_to_string ?code:(code=true) l =
   let s = Format.flush_str_formatter () in
   s
 
-type pos_or_loc = Loc of Parse_ast.l | LocD of Parse_ast.l * Parse_ast.l | Pos of Lexing.position
+type pos_or_loc = Loc of Parse_ast.l | Pos of Lexing.position
 
 let print_err_internal fatal verb_loc p_l m1 m2 =
-  Format.eprintf "%s at " m1;
-  let _ = (match p_l with Pos p -> print_err_pos p
-                        | Loc l -> print_err_loc l
-                        | LocD (l1,l2) ->
-                          print_err_loc l1; Format.fprintf Format.err_formatter " and "; print_err_loc l2) in
-  Format.eprintf "%s\n" m2;
-  if verb_loc then (match p_l with Loc l ->
-      format_loc_source Format.err_formatter l;
-      Format.pp_print_newline Format.err_formatter (); | _ -> ());
-  Format.pp_print_flush Format.err_formatter ();
-  if fatal then (exit 1) else ()
+  let open Error_format in
+  begin match p_l with
+  | Loc l -> format_message (Location (l, Line m2)) err_formatter
+  | _ -> failwith "Pos"
+  end;
+  if fatal then exit 1 else ()
 
 let print_err fatal verb_loc l m1 m2 =
   print_err_internal fatal verb_loc (Loc l) m1 m2
@@ -264,7 +259,6 @@ type error =
   | Err_syntax_locn of Parse_ast.l * string
   | Err_lex of Lexing.position * string
   | Err_type of Parse_ast.l * string
-  | Err_type_dual of Parse_ast.l * Parse_ast.l * string
 
 let issues = "\n\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues"
 
@@ -277,7 +271,6 @@ let dest_err = function
   | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m)
   | Err_lex (p, s) -> ("Lexical error", false, Pos p, s)
   | Err_type (l, m) -> ("Type error", false, Loc l, m)
-  | Err_type_dual(l1,l2,m) -> ("Type error", false, LocD (l1,l2), m)
 
 exception Fatal_error of error
 
@@ -286,11 +279,10 @@ let err_todo l m = Fatal_error (Err_todo (l, m))
 let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos, m))
 let err_general l m = Fatal_error (Err_general (l, m))
 let err_typ l m = Fatal_error (Err_type (l,m))
-let err_typ_dual l1 l2 m = Fatal_error (Err_type_dual (l1,l2,m))
 
 let report_error e =
   let (m1, verb_pos, pos_l, m2) = dest_err e in
-  (print_err_internal verb_pos false pos_l m1 m2; exit 1)
+  print_err_internal verb_pos false pos_l m1 m2
 
 let print_error e =
   let (m1, verb_pos, pos_l, m2) = dest_err e in
diff --git a/src/reporting.mli b/src/reporting.mli
index 63ed3eee..4ce0ced8 100644
--- a/src/reporting.mli
+++ b/src/reporting.mli
@@ -90,8 +90,7 @@ type error =
   | Err_syntax_locn of Parse_ast.l * string
   | Err_lex of Lexing.position * string
   | Err_type of Parse_ast.l * string
-  | Err_type_dual of Parse_ast.l * Parse_ast.l * string
-  
+
 exception Fatal_error of error
 
 (** [err_todo l m] is an abreviatiation for [Fatal_error (Err_todo (l, m))] *)
@@ -106,11 +105,8 @@ val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn
 (** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *)
 val err_typ : Parse_ast.l -> string -> exn
 
-(** [err_typ_dual l1 l2 m] is an abreviatiation for [Fatal_error (Err_type_dual (l1, l2, m))] *)
-val err_typ_dual : Parse_ast.l ->  Parse_ast.l -> string -> exn
-
 (** Report error should only be used by main to print the error in the end. Everywhere else,
     raising a [Fatal_error] exception is recommended. *)
-val report_error : error -> 'a
+val report_error : error -> unit
 
 val print_error : error -> unit
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 8df5ce02..1e3d319a 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -462,7 +462,7 @@ let rewrite_sizeof (Defs defs) =
            for the given parameters in the original environment *)
          let inst =
            try instantiation_of orig_exp with
-           | Type_error (l, err) ->
+           | Type_error (_, l, err) ->
              raise (Reporting.err_typ l (Type_error.string_of_type_error err)) in
          (* Rewrite the inst using orig_kid so that each type variable has it's
             original name rather than a mangled typechecker name *)
@@ -475,7 +475,7 @@ let rewrite_sizeof (Defs defs) =
              | Some (A_aux (A_nexp nexp, _)) ->
                 let sizeof = E_aux (E_sizeof nexp, (l, mk_tannot env (atom_typ nexp) no_effect)) in
                 (try rewrite_trivial_sizeof_exp sizeof with
-                | Type_error (l, err) ->
+                | Type_error (_, l, err) ->
                   raise (Reporting.err_typ l (Type_error.string_of_type_error err)))
              (* If the type variable is Not_found then it was probably
                 introduced by a P_var pattern, so it likely exists as
@@ -2474,7 +2474,7 @@ let rewrite_vector_concat_assignments defs =
                mk_exp (E_assign (lexp, tup)))) in
          begin
            try check_exp env e_aux unit_typ with
-           | Type_error (l, err) ->
+           | Type_error (_, l, err) ->
              raise (Reporting.err_typ l (Type_error.string_of_type_error err))
          end
        else E_aux (e_aux, annot)
@@ -2503,7 +2503,7 @@ let rewrite_tuple_assignments defs =
        let let_exp = mk_exp (E_let (letbind, block)) in
        begin
          try check_exp env let_exp unit_typ with
-         | Type_error (l, err) ->
+         | Type_error (_, l, err) ->
            raise (Reporting.err_typ l (Type_error.string_of_type_error err))
        end
     | _ -> E_aux (e_aux, annot)
@@ -3126,7 +3126,7 @@ let construct_toplevel_string_append_func env f_id pat =
        let mapping_inner_typ =
          match Env.get_val_spec (mk_id mapping_prefix_func) env with
          | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [A_aux (A_typ typ, _)]), _), _), _)) -> typ
-         | _ -> typ_error Parse_ast.Unknown "mapping prefix func without correct function type?"
+         | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "mapping prefix func without correct function type?")
        in
 
        let s_id = fresh_stringappend_id () in
@@ -3302,7 +3302,7 @@ let rec rewrite_defs_pat_string_append =
        let mapping_inner_typ =
          match Env.get_val_spec (mk_id mapping_prefix_func) env with
          | (_, Typ_aux (Typ_fn (_, Typ_aux (Typ_app (_, [A_aux (A_typ typ, _)]), _), _), _)) -> typ
-         | _ -> typ_error Parse_ast.Unknown "mapping prefix func without correct function type?"
+         | _ -> typ_error env Parse_ast.Unknown "mapping prefix func without correct function type?"
        in
 
        let s_id = fresh_stringappend_id () in
@@ -4304,12 +4304,12 @@ let rewrite_defs_realise_mappings (Defs defs) =
     (* We need to make sure we get the environment for the last mapping clause *)
     let env = match List.rev mapcls with
       | MCL_aux (_, mapcl_annot) :: _ -> env_of_annot mapcl_annot
-      | _ -> Type_check.typ_error l "mapping with no clauses?"
+      | _ -> raise (Reporting.err_unreachable l __POS__ "mapping with no clauses?")
     in
     let (typq, bidir_typ) = Env.get_val_spec id env in
     let (typ1, typ2, l) = match bidir_typ with
       | Typ_aux (Typ_bidir (typ1, typ2), l) -> typ1, typ2, l
-      | _ -> Type_check.typ_error l "non-bidir type of mapping?"
+      | _ -> raise (Reporting.err_unreachable l __POS__ "non-bidir type of mapping?")
     in
     let forwards_typ = Typ_aux (Typ_fn ([typ1], typ2, no_effect), l) in
     let forwards_matches_typ = Typ_aux (Typ_fn ([typ1], bool_typ, no_effect), l) in
@@ -5144,7 +5144,7 @@ let rewrite_check_annot =
        else ());
       exp
     with
-      Type_error (l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err))
+      Type_error (_, l, err) -> raise (Reporting.err_typ l (Type_error.string_of_type_error err))
   in
   let check_pat pat =
     prerr_endline ("CHECKING PAT: " ^ string_of_pat pat ^ " : " ^ string_of_typ (typ_of_pat pat));
diff --git a/src/sail.ml b/src/sail.ml
index 247cae25..2777b7a5 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -54,7 +54,6 @@ module Big_int = Nat_big_num
 
 let lib = ref ([] : string list)
 let opt_file_out : string option ref = ref None
-let opt_interactive = ref false
 let opt_interactive_script : string option ref = ref None
 let opt_print_version = ref false
 let opt_print_initial_env = ref false
@@ -79,10 +78,10 @@ let options = Arg.align ([
     Arg.String (fun f -> opt_file_out := Some f),
     "<prefix> select output filename prefix");
   ( "-i",
-    Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen],
+    Arg.Tuple [Arg.Set Interactive.opt_interactive; Arg.Set Initial_check.opt_undefined_gen],
     " start interactive interpreter");
   ( "-is",
-    Arg.Tuple [Arg.Set opt_interactive; Arg.Set Initial_check.opt_undefined_gen;
+    Arg.Tuple [Arg.Set Interactive.opt_interactive; Arg.Set Initial_check.opt_undefined_gen;
                Arg.String (fun s -> opt_interactive_script := Some s)],
     "<filename> start interactive interpreter and execute commands in script");
   ( "-iout",
@@ -273,8 +272,6 @@ let _ =
       opt_file_arguments := (!opt_file_arguments) @ [s])
     usage_msg
 
-let interactive_ast = ref (Ast.Defs [])
-let interactive_env = ref Type_check.initial_env
 
 let load_files type_envs files =
   if !opt_memo_z3 then Constraint.load_digests () else ();
@@ -349,9 +346,9 @@ let main() =
 
     (*let _ = Printf.eprintf "Type checked, next to pretty print" in*)
     begin
-      (if !(opt_interactive)
+      (if !(Interactive.opt_interactive)
        then
-         (interactive_ast := Process_file.rewrite_ast_interpreter ast; interactive_env := type_envs)
+         (Interactive.ast := Process_file.rewrite_ast_interpreter ast; Interactive.env := type_envs)
        else ());
       (if !(opt_sanity)
        then
@@ -414,7 +411,10 @@ let main() =
 
 let _ =  try
     begin
-      try ignore(main ())
-      with  Failure(s) -> raise (Reporting.err_general Parse_ast.Unknown ("Failure "^s))
+      try ignore (main ())
+      with Failure s -> raise (Reporting.err_general Parse_ast.Unknown ("Failure " ^ s))
     end
-  with Reporting.Fatal_error e -> Reporting.report_error e
+  with Reporting.Fatal_error e ->
+    Reporting.report_error e;
+    Interactive.opt_suppress_banner := true;
+    if !Interactive.opt_interactive then () else exit 1
diff --git a/src/type_check.ml b/src/type_check.ml
index 1dfc5957..b362e813 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -96,13 +96,42 @@ type type_error =
   | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t
   | Err_no_num_ident of id
   | Err_other of string
-  | Err_because of type_error * type_error
+  | Err_because of type_error * Parse_ast.l * type_error
+
+type env =
+  { top_val_specs : (typquant * typ) Bindings.t;
+    defined_val_specs : IdSet.t;
+    locals : (mut * typ) Bindings.t;
+    union_ids : (typquant * typ) Bindings.t;
+    registers : (effect * effect * typ) Bindings.t;
+    variants : (typquant * type_union list) Bindings.t;
+    mappings : (typquant * typ * typ) Bindings.t;
+    typ_vars : (Ast.l * kind_aux) KBindings.t;
+    shadow_vars : int KBindings.t;
+    typ_synonyms : (env -> typ_arg list -> typ_arg) Bindings.t;
+    num_defs : nexp Bindings.t;
+    overloads : (id list) Bindings.t;
+    flow : (typ -> typ) Bindings.t;
+    enums : IdSet.t Bindings.t;
+    records : (typquant * (typ * id) list) Bindings.t;
+    accessors : (typquant * typ) Bindings.t;
+    externs : (string -> string option) Bindings.t;
+    casts : id list;
+    allow_casts : bool;
+    allow_bindings : bool;
+    constraints : n_constraint list;
+    default_order : order option;
+    ret_typ : typ option;
+    poly_undefineds : bool;
+    prove : env -> n_constraint -> bool;
+    allow_unknowns : bool;
+  }
 
-exception Type_error of l * type_error;;
+exception Type_error of env * l * type_error;;
 
-let typ_error l m = raise (Type_error (l, Err_other m))
+let typ_error env l m = raise (Type_error (env, l, Err_other m))
 
-let typ_raise l err = raise (Type_error (l, err))
+let typ_raise env l err = raise (Type_error (env, l, err))
 
 let deinfix = function
   | Id_aux (Id v, l) -> Id_aux (DeIid v, l)
@@ -225,7 +254,7 @@ let rec name_pat (P_aux (aux, _)) =
   | P_id id | P_as (_, id) -> Some ("_" ^ string_of_id id)
   | P_typ (_, pat) | P_var (pat, _) -> name_pat pat
   | _ -> None
-                      
+
 let ex_counter = ref 0
 
 let fresh_existential k =
@@ -299,7 +328,7 @@ let adding = Util.("Adding " |> darkgray |> clear)
 (**************************************************************************)
 
 module Env : sig
-  type t
+  type t = env
   val add_val_spec : id -> typquant * typ -> t -> t
   val update_val_spec : id -> typquant * typ -> t -> t
   val define_val_spec : id -> t -> t
@@ -389,34 +418,7 @@ module Env : sig
 
   val builtin_typs : typquant Bindings.t
 end = struct
-  type t =
-    { top_val_specs : (typquant * typ) Bindings.t;
-      defined_val_specs : IdSet.t;
-      locals : (mut * typ) Bindings.t;
-      union_ids : (typquant * typ) Bindings.t;
-      registers : (effect * effect * typ) Bindings.t;
-      variants : (typquant * type_union list) Bindings.t;
-      mappings : (typquant * typ * typ) Bindings.t;
-      typ_vars : (Ast.l * kind_aux) KBindings.t;
-      shadow_vars : int KBindings.t;
-      typ_synonyms : (t -> typ_arg list -> typ_arg) Bindings.t;
-      num_defs : nexp Bindings.t;
-      overloads : (id list) Bindings.t;
-      flow : (typ -> typ) Bindings.t;
-      enums : IdSet.t Bindings.t;
-      records : (typquant * (typ * id) list) Bindings.t;
-      accessors : (typquant * typ) Bindings.t;
-      externs : (string -> string option) Bindings.t;
-      casts : id list;
-      allow_casts : bool;
-      allow_bindings : bool;
-      constraints : n_constraint list;
-      default_order : order option;
-      ret_typ : typ option;
-      poly_undefineds : bool;
-      prove : t -> n_constraint -> bool;
-      allow_unknowns : bool;
-    }
+  type t = env
 
   let empty =
     { top_val_specs = Bindings.empty;
@@ -454,11 +456,11 @@ end = struct
 
   let get_typ_var kid env =
     try snd (KBindings.find kid env.typ_vars) with
-    | Not_found -> typ_error (kid_loc kid) ("No type variable " ^ string_of_kid kid)
+    | Not_found -> typ_error env (kid_loc kid) ("No type variable " ^ string_of_kid kid)
 
   let get_typ_var_loc kid env =
     try fst (KBindings.find kid env.typ_vars) with
-    | Not_found -> typ_error (kid_loc kid) ("No type variable " ^ string_of_kid kid)
+    | Not_found -> typ_error env (kid_loc kid) ("No type variable " ^ string_of_kid kid)
 
   let get_typ_vars env = KBindings.map snd env.typ_vars
   let get_typ_var_locs env = KBindings.map fst env.typ_vars
@@ -519,9 +521,9 @@ end = struct
     else if Bindings.mem id env.enums then
       mk_typquant []
     else if Bindings.mem id env.typ_synonyms then
-      typ_error (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id)
+      typ_error env (id_loc id) ("Cannot infer kind of type synonym " ^ string_of_id id)
     else
-      typ_error (id_loc id) ("Cannot infer kind of " ^  string_of_id id)
+      typ_error env (id_loc id) ("Cannot infer kind of " ^  string_of_id id)
 
   let check_args_typquant id env args typq =
     let kopts, ncs = quant_split typq in
@@ -536,13 +538,13 @@ end = struct
       | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_bool_kopt kopt ->
          subst_args kopts args
       | [], [] -> ncs
-      | _, A_aux (_, l) :: _ -> typ_error l ("Error when processing type quantifer arguments " ^ string_of_typquant typq)
-      | _, _ -> typ_error Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq)
+      | _, A_aux (_, l) :: _ -> typ_error env l ("Error when processing type quantifer arguments " ^ string_of_typquant typq)
+      | _, _ -> typ_error env Parse_ast.Unknown ("Error when processing type quantifer arguments " ^ string_of_typquant typq)
     in
     let ncs = subst_args kopts args in
     if List.for_all (env.prove env) ncs
     then ()
-    else typ_error (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id)
+    else typ_error env (id_loc id) ("Could not prove " ^ string_of_list ", " string_of_n_constraint ncs ^ " for type constructor " ^ string_of_id id)
 
   let rec expand_constraint_synonyms env (NC_aux (aux, l) as nc) =
     typ_debug ~level:2 (lazy ("Expanding " ^ string_of_n_constraint nc));
@@ -553,7 +555,7 @@ end = struct
        (try
           begin match Bindings.find id env.typ_synonyms env args with
           | A_aux (A_bool nc, _) -> expand_constraint_synonyms env nc
-          | arg -> typ_error l ("Expected Bool when expanding synonym " ^ string_of_id id ^ " got " ^ string_of_typ_arg arg)
+          | arg -> typ_error env l ("Expected Bool when expanding synonym " ^ string_of_id id ^ " got " ^ string_of_typ_arg arg)
           end
         with Not_found -> NC_aux (NC_app (id, List.map (expand_synonyms_arg env) args), l))
     | NC_true | NC_false | NC_equal _ | NC_not_equal _ | NC_bounded_le _ | NC_bounded_ge _ | NC_var _ | NC_set _ -> nc
@@ -568,7 +570,7 @@ end = struct
        (try
           begin match Bindings.find id env.typ_synonyms env args with
           | A_aux (A_typ typ, _) -> expand_synonyms env typ
-          | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id)
+          | _ -> typ_error env l ("Expected Type when expanding synonym " ^ string_of_id id)
           end
         with
         | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l))
@@ -576,7 +578,7 @@ end = struct
        (try
           begin match Bindings.find id env.typ_synonyms env [] with
           | A_aux (A_typ typ, _) -> expand_synonyms env typ
-          | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id)
+          | _ -> typ_error env l ("Expected Type when expanding synonym " ^ string_of_id id)
           end
         with
         | Not_found -> Typ_aux (Typ_id id, l))
@@ -644,31 +646,31 @@ end = struct
     | Typ_id id when bound_typ_id env id ->
        let typq = infer_kind env id in
        if quant_kopts typq != []
-       then typ_error l ("Type constructor " ^ string_of_id id ^ " expected " ^ string_of_typquant typq)
+       then typ_error env l ("Type constructor " ^ string_of_id id ^ " expected " ^ string_of_typquant typq)
        else ()
-    | Typ_id id -> typ_error l ("Undefined type " ^ string_of_id id)
+    | Typ_id id -> typ_error env l ("Undefined type " ^ string_of_id id)
     | Typ_var kid -> begin
       match KBindings.find kid env.typ_vars with
       | (_, K_type) -> ()
-      | (_, k) -> typ_error l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ
+      | (_, k) -> typ_error env l ("Kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ
                                ^ " is " ^ string_of_kind_aux k ^ " rather than Type")
       | exception Not_found ->
-         typ_error l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ)
+         typ_error env l ("Unbound kind identifier " ^ string_of_kid kid ^ " in type " ^ string_of_typ typ)
     end
     | Typ_fn (arg_typs, ret_typ, effs) -> List.iter (wf_typ ~exs:exs env) arg_typs; wf_typ ~exs:exs env ret_typ
     | Typ_bidir (typ1, typ2) when strip_typ typ1 = strip_typ typ2 ->
-       typ_error l "Bidirectional types cannot be the same on both sides"
+       typ_error env l "Bidirectional types cannot be the same on both sides"
     | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2
     | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs
     | Typ_app (id, args) when bound_typ_id env id ->
        List.iter (wf_typ_arg ~exs:exs env) args;
        check_args_typquant id env args (infer_kind env id)
-    | Typ_app (id, _) -> typ_error l ("Undefined type " ^ string_of_id id)
-    | Typ_exist ([], _, _) -> typ_error l ("Existential must have some type variables")
+    | Typ_app (id, _) -> typ_error env l ("Undefined type " ^ string_of_id id)
+    | Typ_exist ([], _, _) -> typ_error env l ("Existential must have some type variables")
     | Typ_exist (kopts, nc, typ) when KidSet.is_empty exs ->
        wf_constraint ~exs:(KidSet.of_list (List.map kopt_kid kopts)) env nc;
        wf_typ ~exs:(KidSet.of_list (List.map kopt_kid kopts)) { env with constraints = nc :: env.constraints } typ
-    | Typ_exist (_, _, _) -> typ_error l ("Nested existentials are not allowed")
+    | Typ_exist (_, _, _) -> typ_error env l ("Nested existentials are not allowed")
     | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
   and wf_typ_arg ?exs:(exs=KidSet.empty) env (A_aux (typ_arg_aux, _)) =
     match typ_arg_aux with
@@ -684,7 +686,7 @@ end = struct
     | Nexp_var kid ->
        begin match get_typ_var kid env with
        | K_int -> ()
-       | kind -> typ_error l ("Constraint is badly formed, "
+       | kind -> typ_error env l ("Constraint is badly formed, "
                               ^ string_of_kid kid ^ " has kind "
                               ^ string_of_kind_aux kind ^ " but should have kind Int")
        end
@@ -701,7 +703,7 @@ end = struct
     | Ord_var kid ->
        begin match get_typ_var kid env with
        | K_order -> ()
-       | kind -> typ_error l ("Order is badly formed, "
+       | kind -> typ_error env l ("Order is badly formed, "
                               ^ string_of_kid kid ^ " has kind "
                               ^ string_of_kind_aux kind ^ " but should have kind Order")
        end
@@ -717,7 +719,7 @@ end = struct
     | NC_set (kid, _) ->
        begin match get_typ_var kid env with
        | K_int -> ()
-       | kind -> typ_error l ("Set constraint is badly formed, "
+       | kind -> typ_error env l ("Set constraint is badly formed, "
                               ^ string_of_kid kid ^ " has kind "
                               ^ string_of_kind_aux kind ^ " but should have kind Int")
        end
@@ -728,7 +730,7 @@ end = struct
     | NC_var kid ->
        begin match get_typ_var kid env with
        | K_bool -> ()
-       | kind -> typ_error l (string_of_kid kid ^ " has kind "
+       | kind -> typ_error env l (string_of_kid kid ^ " has kind "
                               ^ string_of_kind_aux kind ^ " but should have kind Bool")
        end
     | NC_true | NC_false -> ()
@@ -754,7 +756,7 @@ end = struct
     try
       Bindings.find id env.top_val_specs
     with
-    | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id)
+    | Not_found -> typ_error env (id_loc id) ("No val spec found for " ^ string_of_id id)
 
   let get_val_spec id env =
     try
@@ -764,7 +766,7 @@ end = struct
       typ_debug (lazy ("get_val_spec: freshened to " ^ string_of_bind bind'));
       bind'
     with
-    | Not_found -> typ_error (id_loc id) ("No val spec found for " ^ string_of_id id)
+    | Not_found -> typ_error env (id_loc id) ("No val spec found for " ^ string_of_id id)
 
   let add_union_id id bind env =
     typ_print (lazy (adding ^ "union identifier " ^ string_of_id id ^ " : " ^ string_of_bind bind));
@@ -775,7 +777,7 @@ end = struct
       let bind = Bindings.find id env.union_ids in
       List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars)
     with
-    | Not_found -> typ_error (id_loc id) ("No union constructor found for " ^ string_of_id id)
+    | Not_found -> typ_error env (id_loc id) ("No union constructor found for " ^ string_of_id id)
 
   let rec update_val_spec id (typq, typ) env =
     begin match expand_synonyms env typ with
@@ -803,7 +805,7 @@ end = struct
        typ_print (lazy (adding ^ "mapping " ^ string_of_id id ^ " : " ^ string_of_bind (typq, typ)));
        { env with top_val_specs = Bindings.add id (typq, typ) env.top_val_specs }
 
-    | _ -> typ_error (id_loc id) "val definition must have a mapping or function type"
+    | _ -> typ_error env (id_loc id) "val definition must have a mapping or function type"
     end
 
   and add_val_spec id (bind_typq, bind_typ) env =
@@ -816,7 +818,7 @@ end = struct
       let existing_cmp = (strip_typq existing_typq, strip_typ existing_typ) in
       let bind_cmp = (strip_typq bind_typq, strip_typ bind_typ) in
       if existing_cmp <> bind_cmp then
-        typ_error (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound as " ^ string_of_bind (existing_typq, existing_typ) ^ ", cannot rebind as " ^ string_of_bind (bind_typq, bind_typ))
+        typ_error env (id_loc id) ("Identifier " ^ string_of_id id ^ " is already bound as " ^ string_of_bind (existing_typq, existing_typ) ^ ", cannot rebind as " ^ string_of_bind (bind_typq, bind_typ))
       else
         env
          *)
@@ -850,7 +852,7 @@ end = struct
 
   let define_val_spec id env =
     if IdSet.mem id env.defined_val_specs
-    then typ_error (id_loc id) ("Function " ^ string_of_id id ^ " has already been declared")
+    then typ_error env (id_loc id) ("Function " ^ string_of_id id ^ " has already been declared")
     else { env with defined_val_specs = IdSet.add id env.defined_val_specs }
 
   let is_union_constructor id env =
@@ -875,7 +877,7 @@ end = struct
 
   let add_enum id ids env =
     if bound_typ_id env id
-    then typ_error (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound")
+    then typ_error env (id_loc id) ("Cannot create enum " ^ string_of_id id ^ ", type name is already bound")
     else
       begin
         typ_print (lazy (adding ^ "enum " ^ string_of_id id));
@@ -885,7 +887,7 @@ end = struct
   let get_enum id env =
     try IdSet.elements (Bindings.find id env.enums)
     with
-    | Not_found -> typ_error (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist")
+    | Not_found -> typ_error env (id_loc id) ("Enumeration " ^ string_of_id id ^ " does not exist")
 
   let is_record id env = Bindings.mem id env.records
 
@@ -893,7 +895,7 @@ end = struct
 
   let add_record id typq fields env =
     if bound_typ_id env id
-    then typ_error (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound")
+    then typ_error env (id_loc id) ("Cannot create record " ^ string_of_id id ^ ", type name is already bound")
     else
       begin
         typ_print (lazy (adding ^ "record " ^ string_of_id id));
@@ -924,14 +926,14 @@ end = struct
     let freshen_bind bind = List.fold_left (fun bind (kid, _) -> freshen_kid env kid bind) bind (KBindings.bindings env.typ_vars) in
     try freshen_bind (Bindings.find (field_name rec_id id) env.accessors)
     with
-    | Not_found -> typ_error (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id))
+    | Not_found -> typ_error env (id_loc id) ("No accessor found for " ^ string_of_id (field_name rec_id id))
 
   let get_accessor rec_id id env =
     match get_accessor_fn rec_id id env with
     (* All accessors should have a single argument (the record itself) *)
     | (typq, Typ_aux (Typ_fn ([rec_typ], field_typ, effect), _)) ->
        (typq, rec_typ, field_typ, effect)
-    | _ -> typ_error (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id))
+    | _ -> typ_error env (id_loc id) ("Accessor with non-function type found for " ^ string_of_id (field_name rec_id id))
 
   let is_mutable id env =
     try
@@ -948,10 +950,10 @@ end = struct
 
   let add_local id mtyp env =
     begin
-      if not env.allow_bindings then typ_error (id_loc id) "Bindings are not allowed in this context" else ();
+      if not env.allow_bindings then typ_error env (id_loc id) "Bindings are not allowed in this context" else ();
       wf_typ env (snd mtyp);
       if Bindings.mem id env.top_val_specs then
-        typ_error (id_loc id) ("Local variable " ^ string_of_id id ^ " is already bound as a function name")
+        typ_error env (id_loc id) ("Local variable " ^ string_of_id id ^ " is already bound as a function name")
       else ();
       typ_print (lazy (adding ^ "local binding " ^ string_of_id id ^ " : " ^ string_of_mtyp mtyp));
       { env with locals = Bindings.add id mtyp env.locals }
@@ -968,12 +970,12 @@ end = struct
   let add_variant_clause id tu env =
     match Bindings.find_opt id env.variants with
     | Some (typq, tus) -> { env with variants = Bindings.add id (typq, tus @ [tu]) env.variants }
-    | None -> typ_error (id_loc id) ("scattered union " ^ string_of_id id ^ " not found")
+    | None -> typ_error env (id_loc id) ("scattered union " ^ string_of_id id ^ " not found")
 
   let get_variant id env =
     match Bindings.find_opt id env.variants with
     | Some (typq, tus) -> typq, tus
-    | None -> typ_error (id_loc id) ("union " ^ string_of_id id ^ " not found")
+    | None -> typ_error env (id_loc id) ("union " ^ string_of_id id ^ " not found")
   let get_flow id env =
     try Bindings.find id env.flow with
     | Not_found -> fun typ -> typ
@@ -991,7 +993,7 @@ end = struct
 
   let get_register id env =
     try Bindings.find id env.registers with
-    | Not_found -> typ_error (id_loc id) ("No register binding found for " ^ string_of_id id)
+    | Not_found -> typ_error env (id_loc id) ("No register binding found for " ^ string_of_id id)
 
   let is_extern id env backend =
     try not (Bindings.find id env.externs backend = None) with
@@ -1005,16 +1007,16 @@ end = struct
     try
       match Bindings.find id env.externs backend with
       | Some ext -> ext
-      | None -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id)
+      | None -> typ_error env (id_loc id) ("No extern binding found for " ^ string_of_id id)
     with
-    | Not_found -> typ_error (id_loc id) ("No extern binding found for " ^ string_of_id id)
+    | Not_found -> typ_error env (id_loc id) ("No extern binding found for " ^ string_of_id id)
 
   let get_casts env = env.casts
 
   let add_register id reff weff typ env =
     wf_typ env typ;
     if Bindings.mem id env.registers
-    then typ_error (id_loc id) ("Register " ^ string_of_id id ^ " is already bound")
+    then typ_error env (id_loc id) ("Register " ^ string_of_id id ^ " is already bound")
     else
       begin
         typ_print (lazy (adding ^ "register binding " ^ string_of_id id ^ " :: " ^ string_of_typ typ));
@@ -1060,7 +1062,7 @@ end = struct
 
   let add_num_def id nexp env =
     if Bindings.mem id env.num_defs
-    then typ_error (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound")
+    then typ_error env (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound")
     else
       begin
         typ_print (lazy (adding ^ "Num identifier " ^ string_of_id id ^ " : " ^ string_of_nexp nexp));
@@ -1069,7 +1071,7 @@ end = struct
 
   let get_num_def id env =
     try Bindings.find id env.num_defs with
-    | Not_found -> typ_raise (id_loc id) (Err_no_num_ident id)
+    | Not_found -> typ_raise env (id_loc id) (Err_no_num_ident id)
 
   let get_constraints env = env.constraints
 
@@ -1099,7 +1101,7 @@ end = struct
 
   let add_typ_synonym id synonym env =
     if Bindings.mem id env.typ_synonyms
-    then typ_error (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists")
+    then typ_error env (id_loc id) ("Type synonym " ^ string_of_id id ^ " already exists")
     else
       begin
         typ_print (lazy (adding ^ "type synonym " ^ string_of_id id));
@@ -1110,13 +1112,13 @@ end = struct
 
   let get_default_order env =
     match env.default_order with
-    | None -> typ_error Parse_ast.Unknown ("No default order has been set")
+    | None -> typ_error env Parse_ast.Unknown ("No default order has been set")
     | Some ord -> ord
 
   let set_default_order o env =
     match env.default_order with
     | None -> { env with default_order = Some (Ord_aux (o, Parse_ast.Unknown)) }
-    | Some _ -> typ_error Parse_ast.Unknown ("Cannot change default order once already set")
+    | Some _ -> typ_error env Parse_ast.Unknown ("Cannot change default order once already set")
 
   let set_default_order_inc = set_default_order Ord_inc
   let set_default_order_dec = set_default_order Ord_dec
@@ -1192,7 +1194,7 @@ let bind_numeric l typ env =
   match destruct_numeric (Env.expand_synonyms env typ) with
   | Some (kids, nc, nexp) ->
      nexp, add_existential l (List.map (mk_kopt K_int) kids) nc env
-  | None -> typ_error l ("Expected " ^ string_of_typ typ ^ " to be numeric")
+  | None -> typ_error env l ("Expected " ^ string_of_typ typ ^ " to be numeric")
 
 (** Pull an (potentially)-existentially qualified type into the global
    typing environment **)
@@ -1597,7 +1599,7 @@ let unify l env goals typ1 typ2 =
                    ^ " for " ^ Util.string_of_list ", " string_of_kid (KidSet.elements goals)));
   let typ1, typ2 = Env.expand_synonyms env typ1, Env.expand_synonyms env typ2 in
   if not (KidSet.is_empty (KidSet.inter goals (tyvars_of_typ typ2))) then
-    typ_error l ("Occurs check failed: " ^ string_of_typ typ2 ^ " contains "
+    typ_error env l ("Occurs check failed: " ^ string_of_typ typ2 ^ " contains "
                  ^ Util.string_of_list ", " string_of_kid (KidSet.elements goals))
   else
     unify_typ l env goals typ1 typ2
@@ -1675,7 +1677,7 @@ let rec kid_order kind_map (Typ_aux (aux, l) as typ) =
      List.fold_left (fun (ord, kids) typ -> let (ord', kids) = kid_order kids typ in (ord @ ord', kids)) ([], kind_map) typs
   | Typ_app (_, args) ->
      List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kind_map) args
-  | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ)
+  | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error Env.empty l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ)
   | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
 and kid_order_arg kind_map (A_aux (aux, l) as arg) =
   match aux with
@@ -1801,15 +1803,15 @@ let rec subtyp l env typ1 typ2 =
   (* Special cases for two numeric (atom) types *)
   | Some (kids1, nc1, nexp1), Some ([], _, nexp2) ->
      let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in
-     if prove __POS__ env (nc_eq nexp1 nexp2) then () else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     if prove __POS__ env (nc_eq nexp1 nexp2) then () else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | Some (kids1, nc1, nexp1), Some (kids2, nc2, nexp2) ->
      let env = add_existential l (List.map (mk_kopt K_int) kids1) nc1 env in
      let env = add_typ_vars l (List.map (mk_kopt K_int) (KidSet.elements (KidSet.inter (nexp_frees nexp2) (KidSet.of_list kids2)))) env in
      let kids2 = KidSet.elements (KidSet.diff (KidSet.of_list kids2) (nexp_frees nexp2)) in
-     if not (kids2 = []) then typ_error l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else ();
+     if not (kids2 = []) then typ_error env l ("Universally quantified constraint generated: " ^ Util.string_of_list ", " string_of_kid kids2) else ();
      let env = Env.add_constraint (nc_eq nexp1 nexp2) env in
      if prove __POS__ env nc2 then ()
-     else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
   | _, _ ->
   match typ_aux1, typ_aux2 with
   | _, Typ_internal_unknown when Env.allow_unknowns env -> ()
@@ -1837,16 +1839,16 @@ let rec subtyp l env typ1 typ2 =
      let typ1 = canonicalize env typ1 in
      let env = add_typ_vars l kopts env in
      let kids' = KidSet.elements (KidSet.diff (KidSet.of_list (List.map kopt_kid kopts)) (tyvars_of_typ typ2)) in
-     if not (kids' = []) then typ_error l "Universally quantified constraint generated" else ();
+     if not (kids' = []) then typ_error env l "Universally quantified constraint generated" else ();
      let unifiers =
        try unify l env (KidSet.diff (tyvars_of_typ typ2) (tyvars_of_typ typ1)) typ2 typ1 with
-       | Unification_error (_, m) -> typ_error l m
+       | Unification_error (_, m) -> typ_error env l m
      in
      let nc = List.fold_left (fun nc (kid, uvar) -> constraint_subst kid uvar nc) nc (KBindings.bindings unifiers) in
      let env = List.fold_left unifier_constraint env (KBindings.bindings unifiers) in
      if prove __POS__ env nc then ()
-     else typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
-  | None, None -> typ_raise l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+     else typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
+  | None, None -> typ_raise env l (Err_subtype (typ1, typ2, Env.get_constraints env, Env.get_typ_var_locs env))
 
 and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) =
   typ_print (lazy (("Subtype arg " |> Util.green |> Util.clear) ^ string_of_typ_arg arg1 ^ " and " ^ string_of_typ_arg arg2));
@@ -1855,7 +1857,7 @@ and subtyp_arg l env (A_aux (aux1, _) as arg1) (A_aux (aux2, _) as arg2) =
   | A_typ typ1, A_typ typ2 -> subtyp l env typ1 typ2
   | A_order ord1, A_order ord2 when ord_identical ord1 ord2 -> ()
   | A_bool nc1, A_bool nc2 when prove __POS__ env (nc_and (nc_or (nc_not nc1) nc2) (nc_or (nc_not nc2) nc1)) -> ()
-  | _, _ -> typ_error l "Mismatched argument types in subtype check"
+  | _, _ -> typ_error env l "Mismatched argument types in subtype check"
 
 let typ_equality l env typ1 typ2 =
   subtyp l env typ1 typ2; subtyp l env typ2 typ1
@@ -1936,16 +1938,16 @@ let infer_lit env (L_aux (lit_aux, l) as lit) =
        match Env.get_default_order env with
        | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) ->
           dvector_typ env (nint (String.length str)) (mk_typ (Typ_id (mk_id "bit")))
-       | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string
+       | Ord_aux (Ord_var _, _) -> typ_error env l default_order_error_string
      end
   | L_hex str ->
      begin
        match Env.get_default_order env with
        | Ord_aux (Ord_inc, _) | Ord_aux (Ord_dec, _) ->
           dvector_typ env (nint (String.length str * 4)) (mk_typ (Typ_id (mk_id "bit")))
-       | Ord_aux (Ord_var _, _) -> typ_error l default_order_error_string
+       | Ord_aux (Ord_var _, _) -> typ_error env l default_order_error_string
      end
-  | L_undef -> typ_error l "Cannot infer the type of undefined"
+  | L_undef -> typ_error env l "Cannot infer the type of undefined"
 
 let is_nat_kid kid = function
   | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid'), _) -> Kid.compare kid kid' = 0
@@ -1995,7 +1997,7 @@ let destruct_vec_typ l env typ =
                              A_aux (A_order o, _);
                              A_aux (A_typ vtyp, _)]
                        ), _) when string_of_id id = "vector" -> (n1, o, vtyp)
-    | typ -> typ_error l ("Expected vector type, got " ^ string_of_typ typ)
+    | typ -> typ_error env l ("Expected vector type, got " ^ string_of_typ typ)
   in
   destruct_vec_typ' l (Env.expand_synonyms env typ)
 
@@ -2052,7 +2054,7 @@ let to_simple_numeric l kids nc (Nexp_aux (aux, _) as n) =
   | _, [] ->
      Equal n
   | _ ->
-     typ_error l "Numeric type is non-simple"
+     typ_error Env.empty l "Numeric type is non-simple"
 
 let union_simple_numeric ex1 ex2 =
   match ex1, ex2 with
@@ -2205,7 +2207,7 @@ let crule r env exp typ =
     Env.wf_typ env (typ_of checked_exp);
     decr depth; checked_exp
   with
-  | Type_error (l, err) -> decr depth; typ_raise l err
+  | Type_error (env, l, err) -> decr depth; typ_raise env l err
 
 let irule r env exp =
   incr depth;
@@ -2216,7 +2218,7 @@ let irule r env exp =
     decr depth;
     inferred_exp
   with
-  | Type_error (l, err) -> decr depth; typ_raise l err
+  | Type_error (env, l, err) -> decr depth; typ_raise env l err
 
 
 (* This function adds useful assertion messages to asserts missing them *)
@@ -2266,7 +2268,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
           let checked_xs = crule check_exp env xs typ in
           let checked_x = crule check_exp env x elem_typ in
           annot_exp (E_cons (checked_x, checked_xs)) typ
-       | None -> typ_error l ("Cons " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ)
+       | None -> typ_error env l ("Cons " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ)
      end
   | E_list xs, _ ->
      begin
@@ -2274,7 +2276,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
        | Some elem_typ ->
           let checked_xs = List.map (fun x -> crule check_exp env x elem_typ) xs in
           annot_exp (E_list checked_xs) typ
-       | None -> typ_error l ("List " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ)
+       | None -> typ_error env l ("List " ^ string_of_exp exp ^ " must have list type, got " ^ string_of_typ typ)
      end
   | E_record_update (exp, fexps), _ ->
      (* TODO: this could also infer exp - also fix code duplication with E_record below *)
@@ -2282,11 +2284,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      let rectyp_id = match Env.expand_synonyms env typ with
        | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env ->
           rectyp_id
-       | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record")
+       | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record")
      in
      let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) =
        let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in
-       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in
+       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in
        let field_typ' = subst_unifiers unifiers field_typ in
        let checked_exp = crule check_exp env exp field_typ' in
        FE_aux (FE_Fexp (field, checked_exp), (l, None))
@@ -2297,11 +2299,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      let rectyp_id = match Env.expand_synonyms env typ with
        | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env ->
           rectyp_id
-       | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record")
+       | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record")
      in
      let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) =
        let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in
-       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in
+       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in
        let field_typ' = subst_unifiers unifiers field_typ in
        let checked_exp = crule check_exp env exp field_typ' in
        FE_aux (FE_Fexp (field, checked_exp), (l, None))
@@ -2326,11 +2328,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      Env.wf_constraint env nc;
      if prove __POS__ env nc
      then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
-     else typ_error l ("Cannot prove " ^ string_of_n_constraint nc)
+     else typ_error env l ("Cannot prove " ^ string_of_n_constraint nc)
   | E_app (f, [E_aux (E_constraint nc, _)]), _ when string_of_id f = "_not_prove" ->
      Env.wf_constraint env nc;
      if prove __POS__ env nc
-     then typ_error l ("Can prove " ^ string_of_n_constraint nc)
+     then typ_error env l ("Can prove " ^ string_of_n_constraint nc)
      else annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
   | E_app (f, [E_aux (E_cast (typ, exp), _)]), _ when string_of_id f = "_check" ->
      Env.wf_typ env typ;
@@ -2340,7 +2342,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      Env.wf_typ env typ;
      if (try (ignore (crule check_exp env exp typ); false) with Type_error _ -> true)
      then annot_exp (E_lit (L_aux (L_unit, Parse_ast.Unknown))) unit_typ
-     else typ_error l (Printf.sprintf "Expected _not_check(%s : %s) to fail" (string_of_exp exp) (string_of_typ typ))
+     else typ_error env l (Printf.sprintf "Expected _not_check(%s : %s) to fail" (string_of_exp exp) (string_of_typ typ))
   (* All constructors and mappings are treated as having one argument
      so Ctor(x, y) is checked as Ctor((x, y)) *)
   | E_app (f, x :: y :: zs), _ when Env.is_union_constructor f env || Env.is_mapping f env ->
@@ -2351,22 +2353,22 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in
      typ_print (lazy("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
      begin try crule check_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) typ with
-           | Type_error (_, err1) ->
+           | Type_error (_, _, err1) ->
               (* typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); *)
               typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
               begin try crule check_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) typ with
-                    | Type_error (_, err2) ->
+                    | Type_error (_, _, err2) ->
                        (* typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); *)
-                       typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)]))
+                       typ_raise env l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)]))
               end
      end
   | E_app (f, xs), _ when List.length (Env.get_overloads f env) > 0 ->
      let rec try_overload = function
-       | (errs, []) -> typ_raise l (Err_no_overloading (f, errs))
+       | (errs, []) -> typ_raise env l (Err_no_overloading (f, errs))
        | (errs, (f :: fs)) -> begin
            typ_print (lazy ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
            try crule check_exp env (E_aux (E_app (f, xs), (l, ()))) typ with
-           | Type_error (_, err) ->
+           | Type_error (_, _, err) ->
               typ_debug (lazy "Error");
               try_overload (errs @ [(f, err)], fs)
          end
@@ -2375,7 +2377,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
   | E_return exp, _ ->
      let checked_exp = match Env.get_ret_typ env with
        | Some ret_typ -> crule check_exp env exp ret_typ
-       | None -> typ_error l "Cannot use return outside a function"
+       | None -> typ_error env l "Cannot use return outside a function"
      in
      annot_exp (E_return checked_exp) typ
   | E_tuple exps, Typ_tup typs when List.length exps = List.length typs ->
@@ -2441,11 +2443,11 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
      let (len, ord, vtyp) = destruct_vec_typ l env typ in
      let checked_items = List.map (fun i -> crule check_exp env i vtyp) vec in
      if prove __POS__ env (nc_eq (nint (List.length vec)) (nexp_simp len)) then annot_exp (E_vector checked_items) typ
-     else typ_error l "List length didn't match" (* FIXME: improve error message *)
+     else typ_error env l "List length didn't match" (* FIXME: improve error message *)
   | E_lit (L_aux (L_undef, _) as lit), _ ->
      if is_typ_monomorphic typ || Env.polymorphic_undefineds env
      then annot_exp_effect (E_lit lit) typ (mk_effect [BE_undef])
-     else typ_error l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction")
+     else typ_error env l ("Type " ^ string_of_typ typ ^ " failed undefined monomorphism restriction")
   | _, _ ->
      let inferred_exp = irule infer_exp env exp in
      type_coercion env inferred_exp typ
@@ -2554,14 +2556,14 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
     | _ -> failwith "Cannot switch type for unannotated function"
   in
   let rec try_casts trigger errs = function
-    | [] -> typ_raise l (Err_no_casts (strip_exp annotated_exp, typ_of annotated_exp, typ, trigger, errs))
+    | [] -> typ_raise env l (Err_no_casts (strip_exp annotated_exp, typ_of annotated_exp, typ, trigger, errs))
     | (cast :: casts) -> begin
         typ_print (lazy ("Casting with " ^ string_of_id cast ^ " expression " ^ string_of_exp annotated_exp ^ " to " ^ string_of_typ typ));
         try
           let checked_cast = crule check_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) typ in
           annot_exp (E_cast (typ, checked_cast)) typ
         with
-        | Type_error (_, err) -> try_casts trigger (err :: errs) casts
+        | Type_error (_, _, err) -> try_casts trigger (err :: errs) casts
       end
   in
   begin
@@ -2569,10 +2571,10 @@ and type_coercion env (E_aux (_, (l, _)) as annotated_exp) typ =
       typ_debug (lazy ("Performing type coercion: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ));
       subtyp l env (typ_of annotated_exp) typ; switch_exp_typ annotated_exp
     with
-    | Type_error (_, trigger) when Env.allow_casts env ->
+    | Type_error (_, _, trigger) when Env.allow_casts env ->
        let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
        try_casts trigger [] casts
-    | Type_error (l, err) -> typ_raise l err
+    | Type_error (env, l, err) -> typ_raise env l err
   end
 
 (* type_coercion_unify env exp typ attempts to coerce exp to a type
@@ -2596,7 +2598,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
           let ityp, env = bind_existential l None (typ_of inferred_cast) env in
           inferred_cast, unify l env goals typ ityp, env
         with
-        | Type_error (_, err) -> try_casts casts
+        | Type_error (_, _, err) -> try_casts casts
         | Unification_error (_, err) -> try_casts casts
       end
   in
@@ -2613,7 +2615,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
 
 and bind_pat_no_guard env (P_aux (_,(l,_)) as pat) typ =
   match bind_pat env pat typ with
-  | _, _, _::_ -> typ_error l "Literal patterns not supported here"
+  | _, _, _::_ -> typ_error env l "Literal patterns not supported here"
   | tpat, env, [] -> tpat, env
 
 and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ) =
@@ -2622,7 +2624,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
   let annot_pat pat typ' = P_aux (pat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ pat typ = match pat with
     | P_aux (pat_aux, (l, Some tannot)) -> P_aux (pat_aux, (l, Some { tannot with typ = typ }))
-    | _ -> typ_error l "Cannot switch type for unannotated pattern"
+    | _ -> typ_error env l "Cannot switch type for unannotated pattern"
   in
   let bind_tuple_pat (tpats, env, guards) pat typ =
     let tpat, env, guards' = bind_pat env pat typ in tpat :: tpats, env, guards' @ guards
@@ -2640,7 +2642,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
        match Env.lookup_id v env with
        | Local _ | Unbound -> annot_pat (P_id v) typ, Env.add_local v (Immutable, typ) env, []
        | Register _ ->
-          typ_error l ("Cannot shadow register in pattern " ^ string_of_pat pat)
+          typ_error env l ("Cannot shadow register in pattern " ^ string_of_pat pat)
        | Enum enum -> subtyp l env enum typ; annot_pat (P_id v) typ, env, []
      end
   | P_var (pat, typ_pat) ->
@@ -2662,7 +2664,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
           let hd_pat, env, hd_guards = bind_pat env hd_pat ltyp in
           let tl_pat, env, tl_guards = bind_pat env tl_pat typ in
           annot_pat (P_cons (hd_pat, tl_pat)) typ, env, hd_guards @ tl_guards
-       | _ -> typ_error l "Cannot match cons pattern against non-list type"
+       | _ -> typ_error env l "Cannot match cons pattern against non-list type"
      end
   | P_string_append pats ->
      begin
@@ -2677,7 +2679,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
           in
           let pats, env, guards = process_pats env pats in
           annot_pat (P_string_append pats) typ, env, guards
-       | _ -> typ_error l "Cannot match string-append pattern against non-string type"
+       | _ -> typ_error env l "Cannot match string-append pattern against non-string type"
      end
   | P_list pats ->
      begin
@@ -2692,14 +2694,14 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
           in
           let pats, env, guards = process_pats env pats in
           annot_pat (P_list pats) typ, env, guards
-       | _ -> typ_error l ("Cannot match list pattern " ^ string_of_pat pat ^ "  against non-list type " ^ string_of_typ typ)
+       | _ -> typ_error env l ("Cannot match list pattern " ^ string_of_pat pat ^ "  against non-list type " ^ string_of_typ typ)
      end
   | P_tup [] ->
      begin
        match Env.expand_synonyms env typ with
        | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" ->
           annot_pat (P_tup []) typ, env, []
-       | _ -> typ_error l "Cannot match unit pattern against non-unit type"
+       | _ -> typ_error env l "Cannot match unit pattern against non-unit type"
      end
   | P_tup pats ->
      begin
@@ -2707,11 +2709,11 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
        | Typ_aux (Typ_tup typs, _) ->
           let tpats, env, guards =
             try List.fold_left2 bind_tuple_pat ([], env, []) pats typs with
-            | Invalid_argument _ -> typ_error l "Tuple pattern and tuple type have different length"
+            | Invalid_argument _ -> typ_error env l "Tuple pattern and tuple type have different length"
           in
           annot_pat (P_tup (List.rev tpats)) typ, env, guards
        | _ ->
-          typ_error l (Printf.sprintf "Cannot bind tuple pattern %s against non tuple type %s"
+          typ_error env l (Printf.sprintf "Cannot bind tuple pattern %s against non tuple type %s"
                          (string_of_pat pat) (string_of_typ typ))
      end
   | P_app (f, pats) when Env.is_union_constructor f env ->
@@ -2732,18 +2734,18 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
               let arg_typ' = subst_unifiers unifiers arg_typ in
               let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
               if not (List.for_all (solve_quant env) quants') then
-                typ_raise l (Err_unresolved_quants (f, quants', Env.get_locals env, Env.get_constraints env))
+                typ_raise env l (Err_unresolved_quants (f, quants', Env.get_locals env, Env.get_constraints env))
               else ();
               let ret_typ' = subst_unifiers unifiers ret_typ in
               let tpats, env, guards =
                 try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with
-                | Invalid_argument _ -> typ_error l "Union constructor pattern arguments have incorrect length"
+                | Invalid_argument _ -> typ_error env l "Union constructor pattern arguments have incorrect length"
               in
               annot_pat (P_app (f, List.rev tpats)) typ, env, guards
             with
-            | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against union constructor: " ^ m)
+            | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against union constructor: " ^ m)
           end
-       | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
+       | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
      end
 
   | P_app (f, pats) when Env.is_mapping f env ->
@@ -2765,13 +2767,13 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
               let arg_typ' = subst_unifiers unifiers typ1 in
               let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
               if (match quants' with [] -> false | _ -> true)
-              then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
+              then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
               else ();
 
               let ret_typ' = subst_unifiers unifiers typ2 in
               let tpats, env, guards =
                 try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with
-                | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length"
+                | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length"
               in
               annot_pat (P_app (f, List.rev tpats)) typ, env, guards
             with
@@ -2783,22 +2785,22 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
                  let arg_typ' = subst_unifiers unifiers typ2 in
                  let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
                  if (match quants' with [] -> false | _ -> true)
-                 then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
+                 then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in pattern " ^ string_of_pat pat)
                  else ();
                  let ret_typ' = subst_unifiers unifiers typ1 in
                  let tpats, env, guards =
                    try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with
-                   | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length"
+                   | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length"
                  in
                  annot_pat (P_app (f, List.rev tpats)) typ, env, guards
                with
-               | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m)
+               | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against mapping constructor: " ^ m)
           end
-       | _ -> typ_error l ("Mal-formed mapping " ^ string_of_id f)
+       | _ -> typ_error env l ("Mal-formed mapping " ^ string_of_id f)
      end
 
   | P_app (f, _) when (not (Env.is_union_constructor f env) && not (Env.is_mapping f env)) ->
-     typ_error l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat)
+     typ_error env l (string_of_id f ^ " is not a union constructor or mapping in pattern " ^ string_of_pat pat)
   | P_as (pat, id) ->
      let (typed_pat, env, guards) = bind_pat env pat typ in
      annot_pat (P_as (typed_pat, id)) (typ_of_pat typed_pat), Env.add_local id (Immutable, typ_of_pat typed_pat) env, guards
@@ -2832,9 +2834,9 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
      begin
        match Env.lookup_id v env with
        | Local (Immutable, _) | Unbound ->
-          typ_error l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation")
+          typ_error env l ("Cannot infer identifier in pattern " ^ string_of_pat pat ^ " - try adding a type annotation")
        | Local (Mutable, _) | Register _ ->
-          typ_error l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
+          typ_error env l ("Cannot shadow mutable local or register in switch statement pattern " ^ string_of_pat pat)
        | Enum enum -> annot_pat (P_id v) enum, env, []
      end
   | P_app (f, mpats) when Env.is_union_constructor f env ->
@@ -2843,7 +2845,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
        match Env.expand_synonyms env ctor_typ with
        | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) ->
           bind_pat env pat ret_typ
-       | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f)
+       | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f)
      end
   | P_app (f, mpats) when Env.is_mapping f env ->
      begin
@@ -2857,7 +2859,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
             | Type_error _ ->
                bind_pat env pat typ1
           end
-       | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f)
+       | _ -> typ_error env l ("Malformed mapping type " ^ string_of_id f)
      end
   | P_typ (typ_annot, pat) ->
      Env.wf_typ env typ_annot;
@@ -2905,7 +2907,7 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as pat) =
      annot_pat (P_as (typed_pat, id)) (typ_of_pat typed_pat),
      Env.add_local id (Immutable, typ_of_pat typed_pat) env,
      guards
-  | _ -> typ_error l ("Couldn't infer type of pattern " ^ string_of_pat pat)
+  | _ -> typ_error env l ("Couldn't infer type of pattern " ^ string_of_pat pat)
 
 and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _) as typ) =
   match typ_pat_aux, typ_aux with
@@ -2916,21 +2918,21 @@ and bind_typ_pat env (TP_aux (typ_pat_aux, l) as typ_pat) (Typ_aux (typ_aux, _)
        | [nexp] ->
           Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env)
        | [] ->
-          typ_error l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to")
+          typ_error env l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to")
        | nexps ->
-          typ_error l ("Type " ^ string_of_typ typ ^ " has multiple numeric expressions. Cannot bind " ^ string_of_kid kid)
+          typ_error env l ("Type " ^ string_of_typ typ ^ " has multiple numeric expressions. Cannot bind " ^ string_of_kid kid)
      end
   | TP_app (f1, tpats), Typ_app (f2, typs) when Id.compare f1 f2 = 0 ->
      List.fold_left2 bind_typ_pat_arg env tpats typs
-  | _, _ -> typ_error l ("Couldn't bind type " ^ string_of_typ typ ^ " with " ^ string_of_typ_pat typ_pat)
+  | _, _ -> typ_error env l ("Couldn't bind type " ^ string_of_typ typ ^ " with " ^ string_of_typ_pat typ_pat)
 and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_aux, _) as typ_arg) =
   match typ_pat_aux, typ_arg_aux with
   | TP_wild, _ -> env
   | TP_var kid, A_nexp nexp ->
      Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env)
   | _, A_typ typ -> bind_typ_pat env typ_pat typ
-  | _, A_order _ -> typ_error l "Cannot bind type pattern against order"
-  | _, _ -> typ_error l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat)
+  | _, A_order _ -> typ_error env l "Cannot bind type pattern against order"
+  | _, _ -> typ_error env l ("Couldn't bind type argument " ^ string_of_typ_arg typ_arg ^ " with " ^ string_of_typ_pat typ_pat)
 
 and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as exp) =
   let annot_assign lexp exp = E_aux (E_assign (lexp, exp), (l, mk_tannot env (mk_typ (Typ_id (mk_id "unit"))) no_effect)) in
@@ -2949,14 +2951,14 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
             begin match Env.lookup_id v env with
             | Register (_, _, typ) -> typ, LEXP_id v, true
             | Local (Mutable, typ) -> typ, LEXP_id v, false
-            | _ -> typ_error l "l-expression field is not a register or a local mutable type"
+            | _ -> typ_error env l "l-expression field is not a register or a local mutable type"
             end
          | LEXP_vector (LEXP_aux (LEXP_id v, _), exp) ->
             begin
               (* Check: is this ok if the vector is immutable? *)
               let is_immutable, vtyp, is_register = match Env.lookup_id v env with
-                | Unbound -> typ_error l "Cannot assign to element of unbound vector"
-                | Enum _ -> typ_error l "Cannot vector assign to enumeration element"
+                | Unbound -> typ_error env l "Cannot assign to element of unbound vector"
+                | Enum _ -> typ_error env l "Cannot vector assign to enumeration element"
                 | Local (Immutable, vtyp) -> true, vtyp, false
                 | Local (Mutable, vtyp) -> false, vtyp, false
                 | Register (_, _, vtyp) -> false, vtyp, true
@@ -2968,7 +2970,7 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
               in
               typ_of access, LEXP_vector (annot_lexp (LEXP_id v) vtyp, inferred_exp), is_register
             end
-         | _ -> typ_error l "Field l-expression must be either a vector or an identifier"
+         | _ -> typ_error env l "Field l-expression must be either a vector or an identifier"
        in
        let regtyp, inferred_flexp, is_register = infer_flexp flexp in
        typ_debug (lazy ("REGTYP: " ^ string_of_typ regtyp ^ " / " ^ string_of_typ (Env.expand_synonyms env regtyp)));
@@ -2976,11 +2978,11 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
        | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env ->
           let eff = if is_register then mk_effect [BE_wreg] else no_effect in
           let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in
-          let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q regtyp with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in
+          let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q regtyp with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in
           let field_typ' = subst_unifiers unifiers field_typ in
           let checked_exp = crule check_exp env exp field_typ' in
           annot_assign (annot_lexp (LEXP_field (annot_lexp_effect inferred_flexp regtyp eff, field)) field_typ') checked_exp, env
-       | _ ->  typ_error l "Field l-expression has invalid type"
+       | _ ->  typ_error env l "Field l-expression has invalid type"
      end
   | LEXP_memory (f, xs) ->
      check_exp env (E_aux (E_app (f, xs @ [exp]), (l, ()))) unit_typ, env
@@ -3006,12 +3008,12 @@ and bind_assignment env (LEXP_aux (lexp_aux, _) as lexp) (E_aux (_, (l, ())) as
        let tlexp, env' = bind_lexp env lexp (typ_of inferred_exp) in
        annot_assign tlexp inferred_exp, env'
      with
-     | Type_error (l, err) ->
+     | Type_error (_, l, err) ->
         try
           let inferred_lexp = infer_lexp env lexp in
           let checked_exp = crule check_exp env exp (lexp_typ_of inferred_lexp) in
           annot_assign inferred_lexp checked_exp, env
-        with Type_error (l, err') -> typ_raise l (Err_because (err', err))
+        with Type_error (env, l', err') -> typ_raise env l' (Err_because (err', l, err))
 
 and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
   typ_print (lazy ("Binding mutable " ^ string_of_lexp lexp ^  " to " ^ string_of_typ typ));
@@ -3021,7 +3023,7 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
   | LEXP_cast (typ_annot, v) ->
      begin match Env.lookup_id ~raw:true v env with
        | Local (Immutable, _) | Enum _ ->
-          typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
+          typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
        | Local (Mutable, vtyp) ->
           subtyp l env typ typ_annot;
           subtyp l env typ_annot vtyp;
@@ -3040,12 +3042,12 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
      | Typ_aux (Typ_app (r, [A_aux (A_typ vtyp, _)]), _) when string_of_id r = "register" ->
         subtyp l env typ vtyp; annot_lexp_effect (LEXP_deref inferred_exp) typ (mk_effect [BE_wreg]), env
      | _ ->
-        typ_error l (string_of_typ typ  ^ " must be a register type in " ^ string_of_exp exp ^ ")")
+        typ_error env l (string_of_typ typ  ^ " must be a register type in " ^ string_of_exp exp ^ ")")
      end
   | LEXP_id v ->
      begin match Env.lookup_id ~raw:true v env with
      | Local (Immutable, _) | Enum _ ->
-        typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
+        typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
      | Local (Mutable, vtyp) -> subtyp l env typ vtyp; annot_lexp (LEXP_id v) typ, Env.remove_flow v env
      | Register (_, weff, vtyp) -> subtyp l env typ vtyp; annot_lexp_effect (LEXP_id v) typ weff, env
      | Unbound -> annot_lexp (LEXP_id v) typ, Env.add_local v (Mutable, typ) env
@@ -3061,10 +3063,10 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
           in
           let tlexps, env =
             try List.fold_right2 bind_tuple_lexp lexps typs ([], env) with
-            | Invalid_argument _ -> typ_error l "Tuple l-expression and tuple type have different length"
+            | Invalid_argument _ -> typ_error env l "Tuple l-expression and tuple type have different length"
           in
           annot_lexp (LEXP_tup tlexps) typ, env
-       | _ -> typ_error l ("Cannot bind tuple l-expression against non tuple type " ^ string_of_typ typ)
+       | _ -> typ_error env l ("Cannot bind tuple l-expression against non tuple type " ^ string_of_typ typ)
      end
   | _ ->
      let inferred_lexp = infer_lexp env lexp in
@@ -3081,9 +3083,9 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
      (* Probably need to remove flows here *)
      | Register (_, weff, typ) -> annot_lexp_effect (LEXP_id v) typ weff
      | Local (Immutable, _) | Enum _ ->
-        typ_error l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
+        typ_error env l ("Cannot modify let-bound constant or enumeration constructor " ^ string_of_id v)
      | Unbound ->
-        typ_error l ("Cannot create a new identifier in this l-expression " ^ string_of_lexp lexp)
+        typ_error env l ("Cannot create a new identifier in this l-expression " ^ string_of_lexp lexp)
      end
   | LEXP_vector_range (v_lexp, exp1, exp2) ->
      begin
@@ -3103,9 +3105,9 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
           | Ord_aux (Ord_dec, _) when !opt_no_lexp_bounds_check || prove __POS__ env (nc_gteq nexp1 nexp2) ->
              let len = nexp_simp (nsum (nminus nexp1 nexp2) (nint 1)) in
              annot_lexp (LEXP_vector_range (inferred_v_lexp, inferred_exp1, inferred_exp2)) (vector_typ len ord elem_typ)
-          | _ -> typ_error l ("Could not infer length of vector slice assignment " ^ string_of_lexp lexp)
+          | _ -> typ_error env l ("Could not infer length of vector slice assignment " ^ string_of_lexp lexp)
           end
-       | _ -> typ_error l "Cannot assign slice of non vector type"
+       | _ -> typ_error env l "Cannot assign slice of non vector type"
      end
   | LEXP_vector (v_lexp, exp) ->
      begin
@@ -3119,10 +3121,10 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
           if !opt_no_lexp_bounds_check || prove __POS__ env (nc_and (nc_lteq (nint 0) nexp) (nc_lteq nexp (nexp_simp (nminus len (nint 1))))) then
             annot_lexp (LEXP_vector (inferred_v_lexp, inferred_exp)) elem_typ
           else
-            typ_error l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp)
-       | _ -> typ_error l "Cannot assign vector element of non vector type"
+            typ_error env l ("Vector assignment not provably in bounds " ^ string_of_lexp lexp)
+       | _ -> typ_error env l "Cannot assign vector element of non vector type"
      end
-  | LEXP_vector_concat [] -> typ_error l "Cannot have empty vector concatenation l-expression"
+  | LEXP_vector_concat [] -> typ_error env l "Cannot have empty vector concatenation l-expression"
   | LEXP_vector_concat (v_lexp :: v_lexps) ->
      begin
        let sum_lengths first_ord first_elem_typ acc (Typ_aux (v_typ_aux, _) as v_typ) =
@@ -3131,7 +3133,7 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
               when Id.compare id (mk_id "vector") = 0 && ord_identical ord first_ord ->
             typ_equality l env elem_typ first_elem_typ;
             nsum acc len
-         | _ -> typ_error l "Vector concatentation l-expression must only contain vector types of the same order"
+         | _ -> typ_error env l "Vector concatentation l-expression must only contain vector types of the same order"
        in
        let inferred_v_lexp = infer_lexp env v_lexp in
        let inferred_v_lexps = List.map (infer_lexp env) v_lexps in
@@ -3142,21 +3144,21 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
             when Id.compare id (mk_id "vector") = 0 ->
           let len = List.fold_left (sum_lengths ord elem_typ) len v_typs in
           annot_lexp (LEXP_vector_concat (inferred_v_lexp :: inferred_v_lexps)) (vector_typ (nexp_simp len) ord elem_typ)
-       | _ -> typ_error l ("Vector concatentation l-expression must only contain vector types, found " ^ string_of_typ v_typ)
+       | _ -> typ_error env l ("Vector concatentation l-expression must only contain vector types, found " ^ string_of_typ v_typ)
      end
   | LEXP_field (LEXP_aux (LEXP_id v, _), fid) ->
      (* FIXME: will only work for ASL *)
      let rec_id, weff =
        match Env.lookup_id v env with
        | Register (_, weff, Typ_aux (Typ_id rec_id, _)) -> rec_id, weff
-       | _ -> typ_error l (string_of_lexp lexp ^ " must be a record register here")
+       | _ -> typ_error env l (string_of_lexp lexp ^ " must be a record register here")
      in
      let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in
      annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ weff
   | LEXP_tup lexps ->
      let inferred_lexps = List.map (infer_lexp env) lexps in
      annot_lexp (LEXP_tup inferred_lexps) (tuple_typ (List.map lexp_typ_of inferred_lexps))
-  | _ -> typ_error l ("Could not infer the type of " ^ string_of_lexp lexp)
+  | _ -> typ_error env l ("Could not infer the type of " ^ string_of_lexp lexp)
 
 and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
   let annot_exp_effect exp typ eff = E_aux (exp, (l, mk_tannot env typ eff)) in
@@ -3173,7 +3175,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
        match Env.lookup_id v env with
        | Local (_, typ) | Enum typ -> annot_exp (E_id v) typ
        | Register (reff, _, typ) -> annot_exp_effect (E_id v) typ reff
-       | Unbound -> typ_error l ("Identifier " ^ string_of_id v ^ " is unbound")
+       | Unbound -> typ_error env l ("Identifier " ^ string_of_id v ^ " is unbound")
      end
   | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
   | E_sizeof nexp ->
@@ -3201,7 +3203,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
             | E_aux (E_app (field, [inferred_exp]) ,_) -> annot_exp (E_field (inferred_exp, field)) (typ_of inferred_acc)
             | _ -> assert false (* Unreachable *)
           end
-       | _ ->  typ_error l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid")
+       | _ ->  typ_error env l ("Field expression " ^ string_of_exp exp ^ " :: " ^ string_of_typ (typ_of inferred_exp) ^ " is not valid")
      end
   | E_tuple exps ->
      let inferred_exps = List.map (irule infer_exp env) exps in
@@ -3214,11 +3216,11 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      let rectyp_id = match Env.expand_synonyms env typ with
        | Typ_aux (Typ_id rectyp_id, _) | Typ_aux (Typ_app (rectyp_id, _), _) when Env.is_record rectyp_id env ->
           rectyp_id
-       | _ -> typ_error l ("The type " ^ string_of_typ typ ^ " is not a record")
+       | _ -> typ_error env l ("The type " ^ string_of_typ typ ^ " is not a record")
      in
      let check_fexp (FE_aux (FE_Fexp (field, exp), (l, ()))) =
        let (typq, rectyp_q, field_typ, _) = Env.get_accessor rectyp_id field env in
-       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error l ("Unification error: " ^ m) in
+       let unifiers = try unify l env (tyvars_of_typ rectyp_q) rectyp_q typ with Unification_error (l, m) -> typ_error env l ("Unification error: " ^ m) in
        let field_typ' = subst_unifiers unifiers field_typ in
        let inferred_exp = crule check_exp env exp field_typ' in
        FE_aux (FE_Fexp (field, inferred_exp), (l, None))
@@ -3237,22 +3239,22 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      let backwards_id = mk_id (string_of_id mapping ^ "_backwards") in
      typ_print (lazy ("Trying forwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
      begin try irule infer_exp env (E_aux (E_app (forwards_id, xs), (l, ()))) with
-           | Type_error (_, err1) ->
+           | Type_error (_, _, err1) ->
               (* typ_print (lazy ("Error in forwards direction: " ^ string_of_type_error err1)); *)
               typ_print (lazy ("Trying backwards direction for mapping " ^ string_of_id mapping ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
               begin try irule infer_exp env (E_aux (E_app (backwards_id, xs), (l, ()))) with
-                    | Type_error (_, err2) ->
+                    | Type_error (env, _, err2) ->
                        (* typ_print (lazy ("Error in backwards direction: " ^ string_of_type_error err2)); *)
-                       typ_raise l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)]))
+                       typ_raise env l (Err_no_overloading (mapping, [(forwards_id, err1); (backwards_id, err2)]))
               end
      end
   | E_app (f, xs) when List.length (Env.get_overloads f env) > 0 ->
      let rec try_overload = function
-       | (errs, []) -> typ_raise l (Err_no_overloading (f, errs))
+       | (errs, []) -> typ_raise env l (Err_no_overloading (f, errs))
        | (errs, (f :: fs)) -> begin
            typ_print (lazy ("Overload: " ^ string_of_id f ^ "(" ^ string_of_list ", " string_of_exp xs ^ ")"));
            try irule infer_exp env (E_aux (E_app (f, xs), (l, ()))) with
-           | Type_error (_, err) ->
+           | Type_error (_, _, err) ->
               typ_debug (lazy "Error");
               try_overload (errs @ [(f, err)], fs)
          end
@@ -3268,7 +3270,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
        let f, t, is_dec = match ord with
          | Ord_aux (Ord_inc, _) -> f, t, false
          | Ord_aux (Ord_dec, _) -> t, f, true (* reverse direction to typechecking downto as upto loop *)
-         | Ord_aux (Ord_var _, _) -> typ_error l "Cannot check a loop with variable direction!" (* This should never happen *)
+         | Ord_aux (Ord_var _, _) -> typ_error env l "Cannot check a loop with variable direction!" (* This should never happen *)
        in
        let inferred_f = irule infer_exp env f in
        let inferred_t = irule infer_exp env t in
@@ -3284,7 +3286,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
           if not is_dec (* undo reverse direction in annotated ast for downto loop *)
           then annot_exp (E_for (v, inferred_f, inferred_t, checked_step, ord, checked_body)) unit_typ
           else annot_exp (E_for (v, inferred_t, inferred_f, checked_step, ord, checked_body)) unit_typ
-       | _, _ -> typ_error l "Ranges in foreach overlap"
+       | _, _ -> typ_error env l "Ranges in foreach overlap"
      end
   | E_if (cond, then_branch, else_branch) ->
      let cond' = crule check_exp env cond (mk_typ (Typ_id (mk_id "bool"))) in
@@ -3299,7 +3301,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
            let else_sn = to_simple_numeric l kids nc else_nexp in
            let typ = typ_of_simple_numeric (union_simple_numeric then_sn else_sn) in
            annot_exp (E_if (cond', then_branch', else_branch')) typ
-        | None -> typ_error l ("Could not infer type of " ^ string_of_exp else_branch)
+        | None -> typ_error env l ("Could not infer type of " ^ string_of_exp else_branch)
         end
      | None ->
         begin match typ_of then_branch' with
@@ -3317,7 +3319,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
   | E_vector_append (v1, E_aux (E_vector [], _)) -> infer_exp env v1
   | E_vector_append (v1, v2) -> infer_exp env (E_aux (E_app (mk_id "append", [v1; v2]), (l, ())))
   | E_vector_subrange (v, n, m) -> infer_exp env (E_aux (E_app (mk_id "vector_subrange", [v; n; m]), (l, ())))
-  | E_vector [] -> typ_error l "Cannot infer type of empty vector"
+  | E_vector [] -> typ_error env l "Cannot infer type of empty vector"
   | E_vector ((item :: items) as vec) ->
      let inferred_item = irule infer_exp env item in
      let checked_items = List.map (fun i -> crule check_exp env i (typ_of inferred_item)) items in
@@ -3369,7 +3371,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
   | E_ref id when Env.is_register id env ->
      let _, _, typ = Env.get_register id env in
      annot_exp (E_ref id) (register_typ typ)
-  | _ -> typ_error l ("Cannot infer type of: " ^ string_of_exp exp)
+  | _ -> typ_error env l ("Cannot infer type of: " ^ string_of_exp exp)
 
 and infer_funapp l env f xs ret_ctx_typ = infer_funapp' l env f (Env.get_val_spec f env) xs ret_ctx_typ
 
@@ -3412,7 +3414,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   let quants, typ_args, typ_ret, eff =
     match Env.expand_synonyms env f_typ with
     | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) -> ref (quant_items typq), typ_args, ref typ_ret, eff
-    | _ -> typ_error l (string_of_typ f_typ ^ " is not a function type")
+    | _ -> typ_error env l (string_of_typ f_typ ^ " is not a function type")
   in
 
   let unifiers = instantiate_simple_equations !quants in
@@ -3426,7 +3428,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants));
 
   if not (List.length typ_args = List.length xs) then
-    typ_error l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args))
+    typ_error env l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args))
   else ();
 
   let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) =
@@ -3464,7 +3466,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
       let inferred_arg = irule infer_exp env arg in
       let inferred_arg, unifiers, env =
         try type_coercion_unify env goals inferred_arg typ with
-        | Unification_error (l, m) -> typ_error l m
+        | Unification_error (l, m) -> typ_error env l m
       in
       record_unifiers unifiers;
       let unifiers = KBindings.bindings unifiers in
@@ -3488,7 +3490,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   let xs = List.rev xs in
 
   if not (List.for_all (solve_quant env) !quants) then
-    typ_raise l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env))
+    typ_raise env l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env))
   else ();
 
   let ty_vars = KBindings.bindings (Env.get_typ_vars env) |> List.map (fun (v, k) -> mk_kopt k v) in
@@ -3516,7 +3518,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
   let annot_mpat mpat typ' = MP_aux (mpat, (l, mk_expected_tannot env typ' no_effect (Some typ))) in
   let switch_typ mpat typ = match mpat with
     | MP_aux (pat_aux, (l, Some tannot)) -> MP_aux (pat_aux, (l, Some { tannot with typ = typ }))
-    | _ -> typ_error l "Cannot switch type for unannotated mapping-pattern"
+    | _ -> typ_error env l "Cannot switch type for unannotated mapping-pattern"
   in
   let bind_tuple_mpat (tpats, env, guards) mpat typ =
     let tpat, env, guards' = bind_mpat allow_unknown other_env env mpat typ in tpat :: tpats, env, guards' @ guards
@@ -3534,7 +3536,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
        match Env.lookup_id v env with
        | Local (Immutable, _) | Unbound -> annot_mpat (MP_id v) typ, Env.add_local v (Immutable, typ) env, []
        | Local (Mutable, _) | Register _ ->
-          typ_error l ("Cannot shadow mutable local or register in switch statement mapping-pattern " ^ string_of_mpat mpat)
+          typ_error env l ("Cannot shadow mutable local or register in switch statement mapping-pattern " ^ string_of_mpat mpat)
        | Enum enum -> subtyp l env enum typ; annot_mpat (MP_id v) typ, env, []
      end
   | MP_cons (hd_mpat, tl_mpat) ->
@@ -3544,7 +3546,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
           let hd_mpat, env, hd_guards = bind_mpat allow_unknown other_env env hd_mpat ltyp in
           let tl_mpat, env, tl_guards = bind_mpat allow_unknown other_env env tl_mpat typ in
           annot_mpat (MP_cons (hd_mpat, tl_mpat)) typ, env, hd_guards @ tl_guards
-       | _ -> typ_error l "Cannot match cons mapping-pattern against non-list type"
+       | _ -> typ_error env l "Cannot match cons mapping-pattern against non-list type"
      end
   | MP_string_append mpats ->
      begin
@@ -3559,7 +3561,7 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
           in
           let pats, env, guards = process_mpats env mpats in
           annot_mpat (MP_string_append pats) typ, env, guards
-       | _ -> typ_error l "Cannot match string-append pattern against non-string type"
+       | _ -> typ_error env l "Cannot match string-append pattern against non-string type"
      end
   | MP_list mpats ->
      begin
@@ -3574,14 +3576,14 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
           in
           let mpats, env, guards = process_mpats env mpats in
           annot_mpat (MP_list mpats) typ, env, guards
-       | _ -> typ_error l ("Cannot match list mapping-pattern " ^ string_of_mpat mpat ^ "  against non-list type " ^ string_of_typ typ)
+       | _ -> typ_error env l ("Cannot match list mapping-pattern " ^ string_of_mpat mpat ^ "  against non-list type " ^ string_of_typ typ)
      end
   | MP_tup [] ->
      begin
        match Env.expand_synonyms env typ with
        | Typ_aux (Typ_id typ_id, _) when string_of_id typ_id = "unit" ->
           annot_mpat (MP_tup []) typ, env, []
-       | _ -> typ_error l "Cannot match unit mapping-pattern against non-unit type"
+       | _ -> typ_error env l "Cannot match unit mapping-pattern against non-unit type"
      end
   | MP_tup mpats ->
      begin
@@ -3589,10 +3591,10 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
        | Typ_aux (Typ_tup typs, _) ->
           let tpats, env, guards =
             try List.fold_left2 bind_tuple_mpat ([], env, []) mpats typs with
-            | Invalid_argument _ -> typ_error l "Tuple mapping-pattern and tuple type have different length"
+            | Invalid_argument _ -> typ_error env l "Tuple mapping-pattern and tuple type have different length"
           in
           annot_mpat (MP_tup (List.rev tpats)) typ, env, guards
-       | _ -> typ_error l "Cannot bind tuple mapping-pattern against non tuple type"
+       | _ -> typ_error env l "Cannot bind tuple mapping-pattern against non tuple type"
      end
   | MP_app (f, mpats) when Env.is_union_constructor f env ->
      begin
@@ -3611,18 +3613,18 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
               let arg_typ' = subst_unifiers unifiers arg_typ in
               let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
               if (match quants' with [] -> false | _ -> true)
-              then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
+              then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
               else ();
               let ret_typ' = subst_unifiers unifiers ret_typ in
               let tpats, env, guards =
                 try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with
-                | Invalid_argument _ -> typ_error l "Union constructor mapping-pattern arguments have incorrect length"
+                | Invalid_argument _ -> typ_error env l "Union constructor mapping-pattern arguments have incorrect length"
               in
               annot_mpat (MP_app (f, List.rev tpats)) typ, env, guards
             with
-            | Unification_error (l, m) -> typ_error l ("Unification error when mapping-pattern matching against union constructor: " ^ m)
+            | Unification_error (l, m) -> typ_error env l ("Unification error when mapping-pattern matching against union constructor: " ^ m)
           end
-       | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
+       | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
      end
   | MP_app (other, mpats) when Env.is_mapping other env ->
      begin
@@ -3641,12 +3643,12 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
               let arg_typ' = subst_unifiers unifiers typ1 in
               let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
               if (match quants' with [] -> false | _ -> true)
-              then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
+              then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
               else ();
               let ret_typ' = subst_unifiers unifiers typ2 in
               let tpats, env, guards =
                 try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with
-                | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length"
+                | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length"
               in
               annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards
             with
@@ -3658,22 +3660,22 @@ and bind_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat) (
                  let arg_typ' = subst_unifiers unifiers typ2 in
                  let quants' = List.fold_left instantiate_quants quants (KBindings.bindings unifiers) in
                  if (match quants' with [] -> false | _ -> true)
-                 then typ_error l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
+                 then typ_error env l ("Quantifiers " ^ string_of_list ", " string_of_quant_item quants' ^ " not resolved in mapping-pattern " ^ string_of_mpat mpat)
                  else ();
                  let ret_typ' = subst_unifiers unifiers typ1 in
                  let tpats, env, guards =
                    try List.fold_left2 bind_tuple_mpat ([], env, []) mpats (untuple arg_typ') with
-                   | Invalid_argument _ -> typ_error l "Mapping pattern arguments have incorrect length"
+                   | Invalid_argument _ -> typ_error env l "Mapping pattern arguments have incorrect length"
                  in
                  annot_mpat (MP_app (other, List.rev tpats)) typ, env, guards
                with
-               | Unification_error (l, m) -> typ_error l ("Unification error when pattern matching against mapping constructor: " ^ m)
+               | Unification_error (l, m) -> typ_error env l ("Unification error when pattern matching against mapping constructor: " ^ m)
           end
        | Typ_aux (typ, _) ->
-          typ_error l ("unifying mapping type, expanded synonyms to non-mapping type??")
+          typ_error env l ("unifying mapping type, expanded synonyms to non-mapping type??")
      end
   | MP_app (f, _) when not (Env.is_union_constructor f env || Env.is_mapping f env) ->
-     typ_error l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat)
+     typ_error env l (string_of_id f ^ " is not a union constructor or mapping in mapping-pattern " ^ string_of_mpat mpat)
   | MP_as (mpat, id) ->
      let (typed_mpat, env, guards) = bind_mpat allow_unknown other_env env mpat typ in
      (annot_mpat (MP_as (typed_mpat, id)) (typ_of_mpat typed_mpat),
@@ -3713,11 +3715,11 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
           | Local (Immutable, typ) -> bind_mpat allow_unknown other_env env (mk_mpat (MP_typ (mk_mpat (MP_id v), typ))) typ
           | Unbound ->
              if allow_unknown then annot_mpat (MP_id v) unknown_typ, env, [] else
-               typ_error l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation")
+               typ_error env l ("Cannot infer identifier in mapping-pattern " ^ string_of_mpat mpat ^ " - try adding a type annotation")
           | _ -> assert false
           end
        | Local (Mutable, _) | Register _ ->
-          typ_error l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat)
+          typ_error env l ("Cannot shadow mutable local or register in mapping-pattern " ^ string_of_mpat mpat)
        | Enum enum -> annot_mpat (MP_id v) enum, env, []
      end
   | MP_app (f, mpats) when Env.is_union_constructor f env ->
@@ -3726,7 +3728,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
        match Env.expand_synonyms env ctor_typ with
        | Typ_aux (Typ_fn (arg_typ, ret_typ, _), _) ->
           bind_mpat allow_unknown other_env env mpat ret_typ
-       | _ -> typ_error l ("Mal-formed constructor " ^ string_of_id f)
+       | _ -> typ_error env l ("Mal-formed constructor " ^ string_of_id f)
      end
   | MP_app (f, mpats) when Env.is_mapping f env ->
      begin
@@ -3740,7 +3742,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
             | Type_error _ ->
                bind_mpat allow_unknown other_env env mpat typ1
           end
-       | _ -> typ_error l ("Malformed mapping type " ^ string_of_id f)
+       | _ -> typ_error env l ("Malformed mapping type " ^ string_of_id f)
      end
   | MP_lit lit ->
      annot_mpat (MP_lit lit) (infer_lit env lit), env, []
@@ -3793,7 +3795,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
       guards)
 
   | _ ->
-     typ_error l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat)
+     typ_error env l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat)
 
 (**************************************************************************)
 (* 5. Effect system                                                       *)
@@ -3967,8 +3969,8 @@ and propagate_exp_effect_aux = function
   | E_internal_return exp ->
      let p_exp = propagate_exp_effect exp in
      E_internal_return p_exp, effect_of p_exp
-  | exp_aux -> typ_error Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression "
-                                            ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))))
+  | exp_aux -> typ_error Env.empty Parse_ast.Unknown ("Unimplemented: Cannot propagate effect in expression "
+                                                      ^ string_of_exp (E_aux (exp_aux, (Parse_ast.Unknown, None))))
 
 and propagate_fexp_effect (FE_aux (FE_Fexp (id, exp), (l, _))) =
   let p_exp = propagate_exp_effect exp in
@@ -4070,7 +4072,7 @@ and propagate_pat_effect_aux = function
   | P_vector pats ->
      let p_pats = List.map propagate_pat_effect pats in
      P_vector p_pats, collect_effects_pat p_pats
-  | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in pat"
+  | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented: Cannot propagate effect in pat")
 
 and propagate_mpat_effect (MP_aux (mpat, annot)) =
   let p_mpat, eff = propagate_mpat_effect_aux mpat in
@@ -4106,7 +4108,7 @@ and propagate_mpat_effect_aux = function
   | MP_as (mpat, id) ->
      let p_mpat = propagate_mpat_effect mpat in
      MP_as (p_mpat, id), effect_of_mpat mpat
-  | _ -> typ_error Parse_ast.Unknown "Unimplemented: Cannot propagate effect in mpat"
+  | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented: Cannot propagate effect in mpat")
 
 and propagate_letbind_effect (LB_aux (lb, (l, annot))) =
   let p_lb, eff = propagate_letbind_effect_aux lb in
@@ -4166,14 +4168,14 @@ let check_letdef orig_env (LB_aux (letbind, (l, _))) =
        if (BESet.is_empty (effect_set (effect_of checked_bind)) || !opt_no_effects)
        then
          [DEF_val (LB_aux (LB_val (tpat, checked_bind), (l, None)))], env
-       else typ_error l ("Top-level definition with effects " ^ string_of_effect (effect_of checked_bind))
+       else typ_error env l ("Top-level definition with effects " ^ string_of_effect (effect_of checked_bind))
     | LB_val (pat, bind) ->
        let inferred_bind = propagate_exp_effect (irule infer_exp orig_env (strip_exp bind)) in
        let tpat, env = bind_pat_no_guard orig_env (strip_pat pat) (typ_of inferred_bind) in
        if (BESet.is_empty (effect_set (effect_of inferred_bind)) || !opt_no_effects)
        then
          [DEF_val (LB_aux (LB_val (tpat, inferred_bind), (l, None)))], env
-       else typ_error l ("Top-level definition with effects " ^ string_of_effect (effect_of inferred_bind))
+       else typ_error env l ("Top-level definition with effects " ^ string_of_effect (effect_of inferred_bind))
   end
 
 let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ =
@@ -4204,7 +4206,7 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ =
        in
        FCL_aux (FCL_Funcl (id, typed_pexp), (l, mk_expected_tannot env typ prop_eff (Some typ)))
      end
-  | _ -> typ_error l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")
+  | _ -> typ_error env l ("Function clause must have function type: " ^ string_of_typ typ ^ " is not a function type")
 
 
 let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl =
@@ -4240,7 +4242,7 @@ let check_mapcl : 'a. Env.t -> 'a mapcl -> typ -> tannot mapcl =
             MCL_aux (MCL_backwards (typed_mpexp, typed_exp), (l, mk_expected_tannot env typ prop_effs (Some typ)))
           end
       end
-    | _ -> typ_error l ("Mapping clause must have mapping type: " ^ string_of_typ typ ^ " is not a mapping type")
+    | _ -> typ_error env l ("Mapping clause must have mapping type: " ^ string_of_typ typ ^ " is not a mapping type")
 
 let funcl_effect (FCL_aux (FCL_Funcl (id, typed_pexp), (l, annot))) =
   match annot with
@@ -4261,7 +4263,7 @@ let infer_funtyp l env tannotopt funcls =
          | P_lit lit -> infer_lit env lit
          | P_typ (typ, _) -> typ
          | P_tup pats -> mk_typ (Typ_tup (List.map typ_from_pat pats))
-         | _ -> typ_error l ("Cannot infer type from pattern " ^ string_of_pat pat)
+         | _ -> typ_error env l ("Cannot infer type from pattern " ^ string_of_pat pat)
        in
        match funcls with
        | [FCL_aux (FCL_Funcl (_, Pat_aux (pexp,_)), _)] ->
@@ -4276,9 +4278,9 @@ let infer_funtyp l env tannotopt funcls =
           in
           let fn_typ = mk_typ (Typ_fn (arg_typs, ret_typ, Effect_aux (Effect_set [], Parse_ast.Unknown))) in
           (quant, fn_typ)
-       | _ -> typ_error l "Cannot infer function type for function with multiple clauses"
+       | _ -> typ_error env l "Cannot infer function type for function with multiple clauses"
      end
-  | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error l "Cannot infer function type for unannotated function"
+  | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> typ_error env l "Cannot infer function type for unannotated function"
 
 let mk_val_spec env typq typ id =
   let eff =
@@ -4293,7 +4295,7 @@ let check_tannotopt env typq ret_typ = function
   | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_ret_typ), l) ->
      if typ_identical env ret_typ annot_ret_typ
      then ()
-     else typ_error l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec")
+     else typ_error env l (string_of_bind (typq, ret_typ) ^ " and " ^ string_of_bind (annot_typq, annot_ret_typ) ^ " do not match between function and val spec")
 
 let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, _)) as fd_aux) =
   let id =
@@ -4301,23 +4303,23 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls)
              (fun (FCL_aux (FCL_Funcl (id, _), _)) id' ->
                match id' with
                | Some id' -> if string_of_id id' = string_of_id id then Some id'
-                             else typ_error l ("Function declaration expects all definitions to have the same name, "
+                             else typ_error env l ("Function declaration expects all definitions to have the same name, "
                                                ^ string_of_id id ^ " differs from other definitions of " ^ string_of_id id')
                | None -> Some id) funcls None)
     with
     | Some id -> id
-    | None -> typ_error l "funcl list is empty"
+    | None -> typ_error env l "funcl list is empty"
   in
   typ_print (lazy ("\n" ^ Util.("Check function " |> cyan |> clear) ^ string_of_id id));
   let have_val_spec, (quant, typ), env =
     try true, Env.get_val_spec id env, env with
-    | Type_error (l, _) ->
+    | Type_error (_, l, _) ->
        let (quant, typ) = infer_funtyp l env tannotopt funcls in
        false, (quant, typ), env
   in
   let vtyp_args, vtyp_ret, declared_eff, vl = match typ with
     | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) -> vtyp_args, vtyp_ret, declared_eff, vl
-    | _ -> typ_error l "Function val spec is not a function type"
+    | _ -> typ_error env l "Function val spec is not a function type"
   in
   check_tannotopt env quant vtyp_ret tannotopt;
   typ_debug (lazy ("Checking fundef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)));
@@ -4345,14 +4347,14 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls)
   if (equal_effects eff declared_eff || !opt_no_effects)
   then
     vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env
-  else typ_error l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found")
+  else typ_error env l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found")
 
 
 let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md_aux) =
   typ_print (lazy ("\nChecking mapping " ^ string_of_id id));
   let have_val_spec, (quant, typ), env =
     try true, Env.get_val_spec id env, env with
-    | Type_error (l, _) as err ->
+    | Type_error (_, l, _) as err ->
        match tannot_opt with
        | Typ_annot_opt_aux (Typ_annot_opt_some (quant, typ), _) ->
           false, (quant, typ), env
@@ -4361,13 +4363,13 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md
   in
   let vtyp1, vtyp2, vl = match typ with
     | Typ_aux (Typ_bidir (vtyp1, vtyp2), vl) -> vtyp1, vtyp2, vl
-    | _ -> typ_error l "Mapping val spec was not a mapping type"
+    | _ -> typ_error env l "Mapping val spec was not a mapping type"
   in
   begin match tannot_opt with
   | Typ_annot_opt_aux (Typ_annot_opt_none, _) -> ()
   | Typ_annot_opt_aux (Typ_annot_opt_some (annot_typq, annot_typ), l) ->
      if typ_identical env typ annot_typ then ()
-     else typ_error l (string_of_bind (quant, typ) ^ " and " ^ string_of_bind (annot_typq, annot_typ) ^ " do not match between mapping and val spec")
+     else typ_error env l (string_of_bind (quant, typ) ^ " and " ^ string_of_bind (annot_typq, annot_typ) ^ " do not match between mapping and val spec")
   end;
   typ_debug (lazy ("Checking mapdef " ^ string_of_id id ^ " has type " ^ string_of_bind (quant, typ)));
   let vs_def, env =
@@ -4383,7 +4385,7 @@ let check_mapdef env (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, _)) as md
   if equal_effects eff no_effect || equal_effects eff (mk_effect [BE_escape]) || !opt_no_effects then
     vs_def @ [DEF_mapdef (MD_aux (MD_mapping (id, tannot_opt, mapcls), (l, None)))], env
   else
-    typ_error l ("Mapping not pure (or escape only): " ^ string_of_effect eff ^ " found")
+    typ_error env l ("Mapping not pure (or escape only): " ^ string_of_effect eff ^ " found")
 
 (* Checking a val spec simply adds the type as a binding in the
    context. We have to destructure the various kinds of val specs, but
@@ -4415,7 +4417,7 @@ let check_default env (DT_aux (ds, l)) =
   match ds with
   | DT_order (Ord_aux (Ord_inc, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_inc env
   | DT_order (Ord_aux (Ord_dec, _)) -> [DEF_default (DT_aux (ds, l))], Env.set_default_order_dec env
-  | DT_order (Ord_aux (Ord_var _, _)) -> typ_error l "Cannot have variable default order"
+  | DT_order (Ord_aux (Ord_var _, _)) -> typ_error env l "Cannot have variable default order"
 
 let kinded_id_arg kind_id =
   let typ_arg arg = A_aux (arg, Parse_ast.Unknown) in
@@ -4471,14 +4473,14 @@ let mk_synonym typq typ_arg =
        let typ_arg, ncs = subst_args kopts args in
        typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs
     | [], [] -> typ_arg, ncs
-    | _, A_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments"
-    | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments"
+    | _, A_aux (_, l) :: _ -> typ_error Env.empty l "Synonym applied to bad arguments"
+    | _, _ -> typ_error Env.empty Parse_ast.Unknown "Synonym applied to bad arguments"
   in
   fun env args ->
     let typ_arg, ncs = subst_args kopts args in
     if List.for_all (prove __POS__ env) ncs
     then typ_arg
-    else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs
+    else typ_error env Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs
                                       ^ " in type synonym " ^ string_of_typ_arg typ_arg
                                       ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env))
 
@@ -4520,7 +4522,7 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t =
           let (Defs defs), env = check env (Bitfield.macro id size order ranges) in
           defs, env
        | _ ->
-          typ_error l "Bad bitfield type"
+          typ_error env l "Bad bitfield type"
      end
 
 and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t =
diff --git a/src/type_check.mli b/src/type_check.mli
index d1061826..e3a22c8d 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -80,9 +80,11 @@ type type_error =
   | Err_subtype of typ * typ * n_constraint list * Ast.l KBindings.t
   | Err_no_num_ident of id
   | Err_other of string
-  | Err_because of type_error * type_error
+  | Err_because of type_error * Ast.l * type_error
 
-exception Type_error of l * type_error;;
+type env
+
+exception Type_error of env * l * type_error;;
 
 val typ_debug : ?level:int -> string Lazy.t -> unit
 val typ_print : string Lazy.t -> unit
@@ -93,7 +95,7 @@ val typ_print : string Lazy.t -> unit
    contains functions that operate on that state. *)
 module Env : sig
   (** Env.t is the type of environments *)
-  type t
+  type t = env
 
   (** Note: Most get_ functions assume the identifiers exist, and throw
      type errors if they don't. *)
@@ -316,7 +318,7 @@ val bind_pat : Env.t -> unit pat -> typ -> tannot pat * Env.t * unit Ast.exp lis
    on patterns that have previously been type checked. *)
 val bind_pat_no_guard : Env.t -> unit pat -> typ -> tannot pat * Env.t
 
-val typ_error : Ast.l -> string -> 'a
+val typ_error : Env.t -> Ast.l -> string -> 'a
 
 (** {2 Destructuring type annotations} Partial functions: The
    expressions and patterns passed to these functions must be
diff --git a/src/type_error.ml b/src/type_error.ml
index f28e4de8..6f856480 100644
--- a/src/type_error.ml
+++ b/src/type_error.ml
@@ -48,31 +48,16 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
-open PPrint
 open Util
 open Ast
 open Ast_util
 open Type_check
 
-let bullet f xs =
-  group (separate_map hardline (fun x -> string "* " ^^ nest 2 (f x)) xs)
-
-let pp_nexp, pp_n_constraint =
-  let pp_nexp' nexp =
-    string (string_of_nexp nexp)
-  in
-
-  let pp_n_constraint' nc =
-    string (string_of_n_constraint nc)
-  in
-  pp_nexp', pp_n_constraint'
-
 type suggestion =
   | Suggest_add_constraint of n_constraint
   | Suggest_none
 
-(* Temporary hack while I work on using these suggestions in asl_parser *)
-let rec analyze_unresolved_quant2 locals ncs = function
+let rec analyze_unresolved_quant locals ncs = function
   | QI_aux (QI_const nc, _) ->
      let gen_kids = List.filter is_kid_generated (KidSet.elements (tyvars_of_constraint nc)) in
      if gen_kids = [] then
@@ -117,104 +102,53 @@ let rec analyze_unresolved_quant2 locals ncs = function
   | QI_aux (QI_id kopt, _) ->
      Suggest_none
 
-let rec analyze_unresolved_quant locals ncs = function
-  | QI_aux (QI_const nc, _) ->
-     let gen_kids = List.filter is_kid_generated (KidSet.elements (tyvars_of_constraint nc)) in
-     if gen_kids = [] then
-       string ("Try adding the constraint: " ^ string_of_n_constraint nc)
-     else
-       (* If there are generated kind-identifiers in the constraint,
-          we don't want to make a suggestion based on them, so try to
-          look for generated kid free nexps in the set of constraints
-          that are equal to the generated identifier. This often
-          occurs due to how the type-checker introduces new type
-          variables. *)
-       let is_subst v = function
-         | NC_aux (NC_equal (Nexp_aux (Nexp_var v', _), nexp), _)
-              when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) ->
-            [(v, nexp)]
-         | NC_aux (NC_equal (nexp, Nexp_aux (Nexp_var v', _)), _)
-              when Kid.compare v v' = 0 && not (KidSet.exists is_kid_generated (tyvars_of_nexp nexp)) ->
-            [(v, nexp)]
-         | _ -> []
-       in
-       let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_subst v nc) ncs)) gen_kids) in
-       let nc = List.fold_left (fun nc (v, nexp) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
-       if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
-         string ("Try adding the constraint " ^ string_of_n_constraint nc)
-       else
-         (* If we have a really anonymous type-variable, try to find a
-            regular variable that corresponds to it. *)
-         let is_linked v = function
-           | (id, (Immutable, (Typ_aux (Typ_app (ty_id, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _) as typ)))
-                when Id.compare ty_id (mk_id "atom") = 0 && Kid.compare v v' = 0 ->
-              [(v, nid id, typ)]
-           | (id, (mut, typ)) ->
-              []
-         in
-         let substs = List.concat (List.map (fun v -> List.concat (List.map (fun nc -> is_linked v nc) (Bindings.bindings locals))) gen_kids) in
-         (string "Try adding named type variables for"
-          ^//^ string (Util.string_of_list ", " (fun (_, nexp, typ) -> string_of_nexp nexp ^ " : " ^ string_of_typ typ) substs))
-         ^^ twice hardline ^^
-         let nc = List.fold_left (fun nc (v, nexp, _) -> constraint_subst v (arg_nexp nexp) nc) nc substs in
-         if not (KidSet.exists is_kid_generated (tyvars_of_constraint nc)) then
-           string ("The property " ^ string_of_n_constraint nc ^ " must hold")
-         else
-           empty
+let message_of_type_error =
+  let open Error_format in
+  let rec msg = function
+    | Err_because (err, l', err') ->
+       Seq [msg err;
+            Line "This error occured because of a previous error:";
+            Location (l', msg err')]
 
-  | QI_aux (QI_id kopt, _) ->
-     empty
+    | Err_other str -> Line str
 
-let rec pp_type_error = function
-  | Err_no_casts (exp, typ_from, typ_to, trigger, reasons) ->
-     let coercion =
-       group (string "Tried performing type coercion from" ^/^ Pretty_print_sail.doc_typ typ_from
-              ^/^ string "to" ^/^ Pretty_print_sail.doc_typ typ_to
-              ^/^ string "on" ^/^ Pretty_print_sail.doc_exp exp)
-     in
-     coercion ^^ hardline
-     ^^ (string "Coercion failed because:" ^//^ pp_type_error trigger)
-     ^^ if not (reasons = []) then
-          hardline
-          ^^ (string "Possible reasons:" ^//^ separate_map hardline pp_type_error reasons)
-        else
-          empty
+    | Err_no_overloading (id, errs) ->
+       Seq [Line ("No overloading for " ^ string_of_id id ^ ", tried:");
+            List (List.map (fun (id, err) -> string_of_id id, msg err) errs)]
 
-  | Err_no_overloading (id, errs) ->
-     string ("No overloadings for " ^ string_of_id id ^ ", tried:") ^//^
-       group (separate_map hardline (fun (id, err) -> string (string_of_id id) ^^ colon ^//^ pp_type_error err) errs)
+    | Err_unresolved_quants (id, quants, locals, ncs) ->
+       Seq [Line ("Could not resolve quantifiers for " ^ string_of_id id);
+            Line (bullet ^ " " ^ Util.string_of_list ("\n" ^ bullet ^ " ") string_of_quant_item quants)]
 
-  | Err_subtype (typ1, typ2, constrs, locs) ->
-     (separate space [ string (string_of_typ typ1);
-                       string "is not a subtype of";
-                       string (string_of_typ typ2) ])
-     ^/^ string "in context"
-     ^/^ bullet pp_n_constraint constrs
-     ^/^ string "where"
-     ^/^ bullet (fun (kid, l) -> string (string_of_kid kid ^ " bound at " ^ Reporting.loc_to_string l ^ "\n")) (KBindings.bindings locs)
+    | Err_subtype (typ1, typ2, _, vars) ->
+       let vars = KBindings.bindings vars in
+       let vars = List.filter (fun (v, _) -> KidSet.mem v (KidSet.union (tyvars_of_typ typ1) (tyvars_of_typ typ2))) vars in
+       With ((fun ppf -> { ppf with loc_color = Util.yellow }),
+             Seq (Line (string_of_typ typ1 ^ " is not a subtype of " ^ string_of_typ typ2)
+                  :: List.map (fun (kid, l) -> Location (l, Line (string_of_kid kid ^ " bound here"))) vars))
 
   | Err_no_num_ident id ->
-     string "No num identifier" ^^ space ^^ string (string_of_id id)
+     Line ("No num identifier " ^ string_of_id id)
 
-  | Err_unresolved_quants (id, quants, locals, ncs) ->
-     (string "Could not resolve quantifiers for" ^^ space ^^ string (string_of_id id)
-      ^//^ group (separate_map hardline (fun quant -> string (string_of_quant_item quant)) quants))
-     ^^ twice hardline
-     ^^ group (separate_map hardline (analyze_unresolved_quant locals ncs) quants)
-
-  (* We only got err, because of previous error, err' *)
-  | Err_because (err, err') ->
-     pp_type_error err
-     ^^ hardline ^^ string "This error occured because of a previous error:"
-     ^//^ pp_type_error err'
-
-  | Err_other str -> string str
+  | Err_no_casts (exp, typ_from, typ_to, trigger, reasons) ->
+     let coercion =
+       Line ("Tried performing type coercion from " ^ string_of_typ typ_from
+             ^ " to " ^ string_of_typ typ_to
+             ^ " on " ^ string_of_exp exp)
+     in
+     Seq ([coercion; Line "Coercion failed because:"; msg trigger]
+          @ if not (reasons = []) then
+              Line "Possible reasons:" :: List.map msg reasons
+            else
+              [])
+  in
+  msg
 
 let rec string_of_type_error err =
-  let open PPrint in
+  let open Error_format in
   let b = Buffer.create 20 in
-  ToBuffer.pretty 1. 400 b (pp_type_error err);
-  "\n" ^ Buffer.contents b
+  format_message (message_of_type_error err) (buffer_formatter b);
+  Buffer.contents b
 
 let rec collapse_errors = function
   | (Err_no_overloading (_, (err :: errs)) as no_collapse) ->
@@ -232,16 +166,18 @@ let rec collapse_errors = function
       | Some _ -> err
       | None -> no_collapse
       end
-  | Err_because (err1, err2) as no_collapse ->
+  | Err_because (err1, l, err2) as no_collapse ->
      let err1 = collapse_errors err1 in
      let err2 = collapse_errors err2 in
      if string_of_type_error err1 = string_of_type_error err2 then
        err1
      else
-       Err_because (err1, err2)
+       Err_because (err1, l, err2)
   | err -> err
 
 let check : 'a. Env.t -> 'a defs -> tannot defs * Env.t =
   fun env defs ->
   try Type_check.check env defs with
-  | Type_error (l, err) -> raise (Reporting.err_typ l (string_of_type_error err))
+  | Type_error (env, l, err) ->
+     Interactive.env := env;
+     raise (Reporting.err_typ l (string_of_type_error err))
-- 
cgit v1.2.3


From 0a293f2e7ca72e1dc422f0035d271d7dc39cfcb2 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 26 Dec 2018 00:41:43 +0000
Subject: More error messages improvments

---
 src/error_format.ml |  44 +++++++++++++--
 src/reporting.ml    | 155 ++++------------------------------------------------
 2 files changed, 51 insertions(+), 148 deletions(-)

(limited to 'src')

diff --git a/src/error_format.ml b/src/error_format.ml
index 3e91f065..9e125efa 100644
--- a/src/error_format.ml
+++ b/src/error_format.ml
@@ -46,6 +46,28 @@ let format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf =
   format_endline (blank_prefix ^ underline_single ppf.loc_color cnum_from cnum_to) ppf;
   contents { ppf with indent = blank_prefix ^ " " }
 
+let underline_double_from color cnum_from eol =
+  Util.(String.make cnum_from ' ' ^ clear (color ("^" ^ String.make (eol - cnum_from - 1) '-')))
+
+let underline_double_to color cnum_to =
+  Util.(clear (color (String.make (cnum_to - 1) '-' ^ "^")))
+
+let format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf =
+  skip_lines in_chan (lnum_from - 1);
+  let line_from = input_line in_chan in
+  skip_lines in_chan (lnum_to - lnum_from - 1);
+  let line_to = input_line in_chan in
+  let line_to_prefix = string_of_int lnum_to ^ Util.(clear (cyan " |")) in
+  let line_from_padding = String.make (String.length (string_of_int lnum_to) - String.length (string_of_int lnum_from)) ' ' in
+  let line_from_prefix = string_of_int lnum_from ^ line_from_padding ^ Util.(clear (cyan " |")) in
+  let blank_prefix = String.make (String.length (string_of_int lnum_to)) ' ' ^ Util.(clear (ppf.loc_color " |")) in
+  format_endline (Printf.sprintf "[%s]:%d:%d-%d:%d" Util.(fname |> cyan |> clear) lnum_from cnum_from lnum_to cnum_to) ppf;
+  format_endline (line_from_prefix ^ line_from) ppf;
+  format_endline (blank_prefix ^ underline_double_from ppf.loc_color cnum_from (String.length line_from)) ppf;
+  format_endline (line_to_prefix ^ line_to) ppf;
+  format_endline (blank_prefix ^ underline_double_to ppf.loc_color cnum_to) ppf;
+  contents { ppf with indent = blank_prefix ^ " " }
+
 let format_code_single fname lnum cnum_from cnum_to contents ppf =
   try
     let in_chan = open_in fname in
@@ -57,17 +79,31 @@ let format_code_single fname lnum cnum_from cnum_to contents ppf =
   with
   | _ -> ()
 
+let format_code_double fname lnum_from cnum_from lnum_to cnum_to contents ppf =
+  try
+    let in_chan = open_in fname in
+    begin
+      try format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf
+      with
+      | _ -> close_in_noerr in_chan; ()
+    end
+  with
+  | _ -> ()
+
 let format_pos p1 p2 contents ppf =
   let open Lexing in
   if p1.pos_lnum == p2.pos_lnum
   then format_code_single p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol) contents ppf
-  else failwith "Range"
+  else format_code_double p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol) contents ppf
 
-let format_loc l contents =
+let rec format_loc l contents =
   match l with
-  | Parse_ast.Unknown -> failwith "No location"
+  | Parse_ast.Unknown -> contents
   | Parse_ast.Range (p1, p2) -> format_pos p1 p2 contents
-  | _ -> failwith "not range"
+  | Parse_ast.Unique (_, l) -> format_loc l contents
+  | Parse_ast.Documented (_, l) -> format_loc l contents
+  | Parse_ast.Generated l ->
+     fun ppf -> (format_endline "Code generated nearby:" ppf; format_loc l contents ppf)
 
 type message =
   | Location of Parse_ast.l * message
diff --git a/src/reporting.ml b/src/reporting.ml
index f27e4c03..7aa68296 100644
--- a/src/reporting.ml
+++ b/src/reporting.ml
@@ -95,159 +95,26 @@
 (*  IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                         *)
 (**************************************************************************)
 
-let rec skip_lines in_chan = function
-  | n when n <= 0 -> ()
-  | n -> ignore (input_line in_chan); skip_lines in_chan (n - 1)
-
-let rec read_lines in_chan = function
-  | n when n <= 0 -> []
-  | n ->
-     let l = input_line in_chan in
-     let ls = read_lines in_chan (n - 1) in
-     l :: ls
-
-let termcode n = "\x1B[" ^ string_of_int n ^ "m"
-
-let print_code1 ff fname lnum1 cnum1 cnum2 =
-  try
-    let in_chan = open_in fname in
-    begin
-      try
-        skip_lines in_chan (lnum1 - 1);
-        let line = input_line in_chan in
-        Format.fprintf ff "%s%s%s"
-                       (Str.string_before line cnum1)
-                       Util.(Str.string_before (Str.string_after line cnum1) (cnum2 - cnum1) |> red_bg |> clear)
-                       (Str.string_after line cnum2);
-        close_in in_chan
-      with e -> (close_in_noerr in_chan;
-                 prerr_endline (Printf.sprintf "print_code1: %s %d %d %d %s" fname lnum1 cnum1 cnum2 (Printexc.to_string e)))
-    end
-  with _ -> ()
-
-let format_pos ff p =
-  let open Lexing in
-  begin
-    Format.fprintf ff "file \"%s\", line %d, character %d:\n\n"
-                   p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol);
-    print_code1 ff p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) (p.pos_cnum - p.pos_bol + 1);
-    Format.fprintf ff "\n\n";
-    Format.pp_print_flush ff ()
-  end
-
-let print_code2 ff fname lnum1 cnum1 lnum2 cnum2 =
-  try
-    let in_chan = open_in fname in
-    begin
-      try
-        skip_lines in_chan (lnum1 - 1);
-        let line = input_line in_chan in
-        Format.fprintf ff "%s%s\n"
-                       (Str.string_before line cnum1)
-                       Util.(Str.string_after line cnum1 |> red_bg |> clear);
-        let lines = read_lines in_chan (lnum2 - lnum1 - 1) in
-        List.iter (fun l -> Format.fprintf ff "%s\n" Util.(l |> red_bg |> clear)) lines;
-        let line = input_line in_chan in
-        Format.fprintf ff "%s%s"
-                       Util.(Str.string_before line cnum2 |> red_bg |> clear)
-                       (Str.string_after line cnum2);
-        close_in in_chan
-      with e -> (close_in_noerr in_chan; prerr_endline (Printexc.to_string e))
-    end
-  with _ -> ()
-
-let format_pos2 ff p1 p2 =
-  let open Lexing in
-  begin
-    Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d\n\n"
-                   p1.pos_fname
-                   p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1)
-                   p2.pos_lnum (p2.pos_cnum - p2.pos_bol);
-    if p1.pos_lnum == p2.pos_lnum
-    then print_code1 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) (p2.pos_cnum - p2.pos_bol)
-    else print_code2 ff p1.pos_fname p1.pos_lnum (p1.pos_cnum - p1.pos_bol) p2.pos_lnum (p2.pos_cnum - p2.pos_bol);
-    Format.pp_print_flush ff ()
-  end
-
-let format_just_pos ff p1 p2 =
-  let open Lexing in
-  Format.fprintf ff "file \"%s\", line %d, character %d to line %d, character %d"
-                 p1.pos_fname
-                 p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1)
-                 p2.pos_lnum (p2.pos_cnum - p2.pos_bol);
-  Format.pp_print_flush ff ()
-
-(* reads the part between p1 and p2 from the file *)
-
-let read_from_file_pos2 p1 p2 =
-  let (s, e, multi) = if p1.Lexing.pos_lnum = p2.Lexing.pos_lnum then
-                  (* everything in the same line, so really only read this small part*)
-                  (p1.Lexing.pos_cnum, p2.Lexing.pos_cnum, None) 
-               else (*multiline, so start reading at beginning of line *)
-                  (p1.Lexing.pos_bol, p2.Lexing.pos_cnum, Some (p1.Lexing.pos_cnum - p1.Lexing.pos_bol)) in
-
-  let ic = open_in p1.Lexing.pos_fname in
-  let _ = seek_in ic s in
-  let l = (e - s) in
-  let buf = Bytes.create l in
-  let _ = input ic buf 0 l in
-  let _ = match multi with None -> () | Some sk -> Bytes.fill buf 0 sk ' ' in
-  let _ = close_in ic in
-  (buf, not (multi = None))
-
-let rec format_loc_aux ?code:(code=true) ff = function
-  | Parse_ast.Unknown ->
-     Format.fprintf ff "no location information available"
-  | Parse_ast.Generated l ->
-     Format.fprintf ff "code generated: original nearby source is ";
-     format_loc_aux ~code:code ff l
-  | Parse_ast.Unique (n, l) ->
-     Format.fprintf ff "code unique (%d): original nearby source is " n;
-     format_loc_aux ~code:code ff l
-  | Parse_ast.Range (p1, p2) when code ->
-     format_pos2 ff p1 p2
-  | Parse_ast.Range (p1, p2) ->
-     format_just_pos ff p1 p2
-  | Parse_ast.Documented (_, l) ->
-     format_loc_aux ~code:code ff l
-
-let format_loc_source ff = function
-  | Parse_ast.Range (p1, p2) ->
-     let (s, multi_line) = read_from_file_pos2 p1 p2 in
-     if multi_line then
-       Format.fprintf ff "  original input:\n%s\n" (Bytes.to_string s)
-     else
-       Format.fprintf ff "  original input: \"%s\"\n" (Bytes.to_string s)
-  | _ -> ()
-
-let format_loc ff l =
- (format_loc_aux ff l;
-  Format.pp_print_newline ff ();
-  Format.pp_print_flush ff ()
-);;
-
-let print_err_loc l = 
-   (format_loc Format.err_formatter l)
-
-let print_pos p = format_pos Format.std_formatter p
-let print_err_pos p = format_pos Format.err_formatter p
-
-let loc_to_string ?code:(code=true) l =
-  let _ = Format.flush_str_formatter () in
-  let _ = format_loc_aux ~code:code Format.str_formatter l in
-  let s = Format.flush_str_formatter () in
-  s
-
 type pos_or_loc = Loc of Parse_ast.l | Pos of Lexing.position
 
 let print_err_internal fatal verb_loc p_l m1 m2 =
   let open Error_format in
+  prerr_endline (m1 ^ ":");
   begin match p_l with
   | Loc l -> format_message (Location (l, Line m2)) err_formatter
-  | _ -> failwith "Pos"
+  | Pos p -> format_message (Location (Parse_ast.Range (p, p), Line m2)) err_formatter
   end;
   if fatal then exit 1 else ()
 
+let loc_to_string ?code:(code=true) l =
+  let open Error_format in
+  if code then
+    let b = Buffer.create 160 in
+    format_message (Location (l, Line "")) (buffer_formatter b);
+    Buffer.contents b
+  else
+    "LOC"
+
 let print_err fatal verb_loc l m1 m2 =
   print_err_internal fatal verb_loc (Loc l) m1 m2
 
-- 
cgit v1.2.3


From e0479ea3c479547c093ade9f675e5a0a652e8a34 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 26 Dec 2018 15:24:55 +0000
Subject: Add makefile target for building with Bisect coverage

---
 src/Makefile        | 5 ++++-
 src/_tags           | 5 +++--
 src/myocamlbuild.ml | 2 ++
 3 files changed, 9 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/Makefile b/src/Makefile
index b658d90d..aeb23b9e 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -62,7 +62,7 @@ endif
 endif
 
 
-.PHONY: all sail sail.native sail.byte manifest.ml test clean doc lib power test_power test_idempotence
+.PHONY: all sail coverage sail.native sail.byte manifest.ml test clean doc lib power test_power test_idempotence
 
 # set to -p on command line to enable gprof profiling
 OCAML_OPTS?=
@@ -103,6 +103,9 @@ sail: ast.ml bytecode.ml manifest.ml
 isail: ast.ml bytecode.ml manifest.ml
 	ocamlbuild -use-ocamlfind isail.native
 
+coverage: ast.ml bytecode.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
diff --git a/src/_tags b/src/_tags
index 826e87a5..6747424d 100644
--- a/src/_tags
+++ b/src/_tags
@@ -1,8 +1,9 @@
 true: -traverse, debug, use_menhir
-<**/*.ml>: bin_annot, annot
+<**/parser.ml>: bin_annot, annot
+<**/*.ml> and not <**/parser.ml>: bin_annot, annot, coverage
 
 <sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), use_pprint
-<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint
+<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint, coverage
 
 <isail.ml>: package(linenoise)
 <elf_loader.ml>: package(linksem)
diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml
index f408703f..b1f95339 100644
--- a/src/myocamlbuild.ml
+++ b/src/myocamlbuild.ml
@@ -79,6 +79,8 @@ let lem_opts = [A "-lib"; P "../gen_lib";
 
 dispatch begin function
 | After_rules ->
+    Bisect_ppx_plugin.handle_coverage ();
+
     (* ocaml_lib "lem_interp/interp"; *)
     ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib";
 
-- 
cgit v1.2.3


From bd6c099d7b541c7850e98347c6bfce743ca11434 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 26 Dec 2018 15:54:04 +0000
Subject: Some cleanup

---
 src/extra_pervasives.ml |  52 ------------
 src/finite_map.ml       | 216 ------------------------------------------------
 src/isail.ml            |   2 +-
 src/monomorphise.ml     |  41 +++++----
 src/pp.ml               |  80 ------------------
 src/pretty_print_coq.ml |   8 +-
 src/pretty_print_lem.ml |   2 +-
 src/reporting.ml        |  41 ++++-----
 src/reporting.mli       |   8 +-
 src/rewriter.ml         |  23 ------
 src/rewrites.ml         |  10 +--
 src/sail.ml             |   2 +-
 src/spec_analysis.ml    |   5 +-
 src/specialize.ml       |   7 +-
 src/type_check.ml       |   7 +-
 15 files changed, 60 insertions(+), 444 deletions(-)
 delete mode 100644 src/extra_pervasives.ml
 delete mode 100644 src/finite_map.ml
 delete mode 100644 src/pp.ml

(limited to 'src')

diff --git a/src/extra_pervasives.ml b/src/extra_pervasives.ml
deleted file mode 100644
index 8001c647..00000000
--- a/src/extra_pervasives.ml
+++ /dev/null
@@ -1,52 +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.                                                          *)
-(**************************************************************************)
-
-let unreachable l pos msg =
-  raise (Reporting.err_unreachable l pos msg)
diff --git a/src/finite_map.ml b/src/finite_map.ml
deleted file mode 100644
index 444e3790..00000000
--- a/src/finite_map.ml
+++ /dev/null
@@ -1,216 +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.                                                          *)
-(**************************************************************************)
-
-
-(**************************************************************************)
-(*                        Lem                                             *)
-(*                                                                        *)
-(*          Dominic Mulligan, University of Cambridge                     *)
-(*          Francesco Zappa Nardelli, INRIA Paris-Rocquencourt            *)
-(*          Gabriel Kerneis, University of Cambridge                      *)
-(*          Kathy Gray, University of Cambridge                           *)
-(*          Peter Boehm, University of Cambridge (while working on Lem)   *)
-(*          Peter Sewell, University of Cambridge                         *)
-(*          Scott Owens, University of Kent                               *)
-(*          Thomas Tuerk, University of Cambridge                         *)
-(*                                                                        *)
-(*  The Lem sources are copyright 2010-2013                               *)
-(*  by the UK authors above and Institut National de Recherche en         *)
-(*  Informatique et en Automatique (INRIA).                               *)
-(*                                                                        *)
-(*  All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli}   *)
-(*  are distributed under the license below.  The former are distributed  *)
-(*  under the LGPLv2, as in the LICENSE file.                             *)
-(*                                                                        *)
-(*                                                                        *)
-(*  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.  *)
-(*  3. The names of the authors may not be used to endorse or promote     *)
-(*  products derived from this software without specific prior written    *)
-(*  permission.                                                           *)
-(*                                                                        *)
-(*  THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.                         *)
-(**************************************************************************)
-
-
-(** finite map library *)
-
-module type Fmap = sig
-  type k
-  module S : Set.S with type elt = k
-  type 'a t
-  val empty : 'a t
-  val is_empty : 'a t -> bool
-  val from_list : (k * 'a) list -> 'a t
-  val to_list : 'a t -> (k * 'a) list 
-  val from_list2 : k list -> 'a list -> 'a t
-  val insert : 'a t -> (k * 'a) -> 'a t
-  (* Keys from the right argument replace those from the left *)
-  val union : 'a t -> 'a t -> 'a t
-  (* Function merges the stored value when a key is in the right and the left map *)
-  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
-  val intersect : 'a t -> 'a t -> 'a t
-  (* Function merges the stored values for shared keys *)
-  val intersect_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
-  val big_union : 'a t list -> 'a t
-  val big_union_merge : ('a -> 'a -> 'a) -> 'a t list -> 'a t
-  val difference : 'a t -> 'a t -> 'a t
-  val merge : (k -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
-  val apply : 'a t -> k -> 'a option
-  val in_dom : k -> 'a t -> bool
-  val map : (k -> 'a -> 'b) -> 'a t -> 'b t
-  val domains_overlap : 'a t -> 'b t -> k option
-  val domains_disjoint : 'a t list -> bool
-  val iter : (k -> 'a -> unit) -> 'a t -> unit
-  val fold : ('b -> k -> 'a -> 'b) -> 'b -> 'a t -> 'b
-  val remove : 'a t -> k -> 'a t
-  val pp_map : (Format.formatter -> k -> unit) -> 
-               (Format.formatter -> 'a -> unit) -> 
-               Format.formatter -> 
-               'a t ->
-               unit
-  val domain : 'a t -> S.t
-end
-
-module Fmap_map(Key : Set.OrderedType) : Fmap 
-                  with type k = Key.t and module S = Set.Make(Key) = struct
-
-  type k = Key.t
-  module S = Set.Make(Key)
-
-  module M = Map.Make(Key)
-  module D = Util.Duplicate(S)
-
-  type 'a t = 'a M.t
-  let empty = M.empty
-  let is_empty m = M.is_empty m
-  let from_list l = List.fold_left (fun m (k,v) -> M.add k v m) M.empty l
-  let from_list2 l1 l2 = List.fold_left2 (fun m k v -> M.add k v m) M.empty l1 l2
-  let insert m (k,v) = M.add k v m
-  let union m1 m2 = 
-    M.merge (fun k v1 v2 -> match v2 with | None -> v1 | Some _ -> v2) m1 m2
-  let union_merge f m1 m2 =
-    M.merge (fun k v1 v2 -> 
-      match v1,v2 with 
-	| None,None -> None
-	| None,Some v | Some v,None -> Some v
-	| Some v1, Some v2 -> Some (f v1 v2)) m1 m2
-  let merge f m1 m2 = M.merge f m1 m2
-  let apply m k = 
-    try
-      Some(M.find k m)
-    with
-      | Not_found -> None
-  let in_dom k m = M.mem k m
-  let map f m = M.mapi f m
-  let rec domains_overlap m1 m2 = 
-    M.fold 
-      (fun k _ res ->
-         if M.mem k m1 then
-           Some(k)
-         else
-           res)
-      m2
-      None
-  let iter f m = M.iter f m
-  let fold f m base = M.fold (fun k v res -> f res k v) base m
-  let difference m1 m2 = 
-    M.fold (fun k v res ->
-      if (M.mem k m2) 
-      then res
-      else M.add k v res) m1 M.empty
-  let intersect m1 m2 = 
-    M.fold (fun k v res -> 
-      if (M.mem k m2)
-      then M.add k v res
-      else res) m1 M.empty
-  let intersect_merge f m1 m2 = 
-    M.fold (fun k v res -> 
-      match (apply m2 k) with
-	| None -> res
-	| Some v2 -> M.add k (f v v2) res) m1 M.empty
-  let to_list m = M.fold (fun k v res -> (k,v)::res) m []
-  let remove m k = M.remove k m
-  let pp_map pp_key pp_val ppf m =
-    let l = M.fold (fun k v l -> (k,v)::l) m [] in
-      Format.fprintf ppf "@[%a@]"
-        (Pp.lst "@\n"
-           (fun ppf (k,v) -> 
-              Format.fprintf ppf "@[<2>%a@ |->@ %a@]"
-                pp_key k
-                pp_val v))
-        l
-  let big_union l = List.fold_left union empty l
-  let big_union_merge f l = List.fold_left (union_merge f) empty l
-  let domains_disjoint maps =
-    match D.duplicates (List.concat (List.map (fun m -> List.map fst (M.bindings m)) maps)) with
-      | D.No_dups _ -> true
-      | D.Has_dups _ -> false
-
-  let domain m =
-    M.fold (fun k _ s -> S.add k s) m S.empty
-end
-
diff --git a/src/isail.ml b/src/isail.ml
index a3dfe680..d8cc448a 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -83,7 +83,7 @@ let rec user_input callback =
      mode_clear ();
      begin
        try callback v with
-       | Reporting.Fatal_error e -> Reporting.report_error e
+       | Reporting.Fatal_error e -> Reporting.print_error e
      end;
      user_input callback
 
diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index fc2a9de6..eb50bac3 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -59,7 +59,6 @@ open Ast
 open Ast_util
 module Big_int = Nat_big_num
 open Type_check
-open Extra_pervasives
 
 let size_set_limit = 64
 
@@ -142,7 +141,7 @@ let subst_nc, subst_src_typ, subst_src_typ_arg =
     | Typ_exist (kopts,nc,t) ->
        let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in
        re (Typ_exist (kopts,nc,s_styp substs t))
-    | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+    | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   and s_starg substs (A_aux (ta,l) as targ) =
     match ta with
     | A_nexp ne -> A_aux (A_nexp (subst_nexp substs ne),l)
@@ -181,7 +180,7 @@ let rec is_value (E_aux (e,(l,annot))) =
   let is_constructor id =
     match destruct_tannot annot with
     | None ->
-       (Reporting.print_err false true l "Monomorphisation"
+       (Reporting.print_err l "Monomorphisation"
           ("Missing type information for identifier " ^ string_of_id id);
         false) (* Be conservative if we have no info *)
     | Some (env,_,_) ->
@@ -341,7 +340,7 @@ let rec inst_src_type insts (Typ_aux (ty,l) as typ) =
      | [] -> insts', t'
      | _ -> insts', Typ_aux (Typ_exist (List.map (mk_kopt K_int) kids', nc, t'), l)
     end
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and inst_src_typ_arg insts (A_aux (ta,l) as tyarg) =
   match ta with
   | A_nexp _
@@ -361,7 +360,7 @@ let rec contains_exist (Typ_aux (ty,l)) =
   | Typ_tup ts -> List.exists contains_exist ts
   | Typ_app (_,args) -> List.exists contains_exist_arg args
   | Typ_exist _ -> true
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and contains_exist_arg (A_aux (arg,_)) =
   match arg with
   | A_nexp _
@@ -437,7 +436,7 @@ let split_src_type id ty (TypQ_aux (q,ql)) =
        let tys = List.concat (List.map (fun instty -> List.map (ty_and_inst instty) insts) tys) in
        let free = List.fold_left (fun vars k -> KidSet.remove k vars) vars kids in
        (free,tys)
-    | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+    | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   in
   (* Only single-variable prenex-form for now *)
   let size_nvars_ty (Typ_aux (ty,l) as typ) =
@@ -546,7 +545,7 @@ let refine_constructor refinements l env id args =
           match List.find matches_refinement irefinements with
           | (_,new_id,_) -> Some (E_app (new_id,args))
           | exception Not_found ->
-             (Reporting.print_err false true l "Monomorphisation"
+             (Reporting.print_err l "Monomorphisation"
                 ("Unable to refine constructor " ^ string_of_id id);
               None)
     end
@@ -1536,7 +1535,7 @@ let split_defs all_errors splits defs =
 
   and can_match_with_env ref_vars env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns =
     let rec findpat_generic check_pat description assigns = function
-      | [] -> (Reporting.print_err false true l "Monomorphisation"
+      | [] -> (Reporting.print_err l "Monomorphisation"
                  ("Failed to find a case for " ^ description); None)
       | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[])
       | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl ->
@@ -1583,7 +1582,7 @@ let split_defs all_errors splits defs =
             | P_aux (P_app (id',[]),_) ->
                if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch
             | P_aux (_,(l',_)) ->
-               (Reporting.print_err false true l' "Monomorphisation"
+               (Reporting.print_err l' "Monomorphisation"
                   "Unexpected kind of pattern for enumeration"; GiveUp)
           in findpat_generic checkpat (string_of_id id) assigns cases
        | _ -> None)
@@ -1606,11 +1605,11 @@ let split_defs all_errors splits defs =
                  DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))],
                             [kid,nexp])
               | _ ->
-                 (Reporting.print_err false true lit_l "Monomorphisation"
+                 (Reporting.print_err lit_l "Monomorphisation"
                     "Unexpected kind of literal for var match"; GiveUp)
             end
          | P_aux (_,(l',_)) ->
-            (Reporting.print_err false true l' "Monomorphisation"
+            (Reporting.print_err l' "Monomorphisation"
                "Unexpected kind of pattern for literal"; GiveUp)
        in findpat_generic checkpat "literal" assigns cases
     | E_vector es when List.for_all (function (E_aux (E_lit _,_)) -> true | _ -> false) es ->
@@ -1630,11 +1629,11 @@ let split_defs all_errors splits defs =
               | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in
             (match final with
             | GiveUp ->
-               (Reporting.print_err false true l "Monomorphisation"
+               (Reporting.print_err l "Monomorphisation"
                   "Unexpected kind of pattern for vector literal"; GiveUp)
             | _ -> final)
          | _ ->
-            (Reporting.print_err false true l "Monomorphisation"
+            (Reporting.print_err l "Monomorphisation"
                "Unexpected kind of pattern for vector literal"; GiveUp)
        in findpat_generic checkpat "vector literal" assigns cases
 
@@ -1652,7 +1651,7 @@ let split_defs all_errors splits defs =
             DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))],
                        KBindings.bindings ksubst)
          | P_aux (_,(l',_)) ->
-            (Reporting.print_err false true l' "Monomorphisation"
+            (Reporting.print_err l' "Monomorphisation"
                "Unexpected kind of pattern for literal"; GiveUp)
        in findpat_generic checkpat "literal" assigns cases
     | _ -> None
@@ -1949,7 +1948,7 @@ let split_defs all_errors splits defs =
          let overlap = List.exists (fun (v,_) -> List.mem v pvs) lvs in
          let () =
            if overlap then
-             Reporting.print_err false true l "Monomorphisation"
+             Reporting.print_err l "Monomorphisation"
                "Splitting a singleton pattern is not possible"
          in p
     in
@@ -2123,7 +2122,7 @@ let split_defs all_errors splits defs =
       | DEF_internal_mutrec _
         -> [d]
       | DEF_fundef fd -> [DEF_fundef (map_fundef fd)]
-      | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "mappings should be gone by now"
+      | DEF_mapdef (MD_aux (_, (l, _))) -> Reporting.unreachable l __POS__ "mappings should be gone by now"
       | DEF_val lb -> [DEF_val (map_letbind lb)]
       | DEF_scattered sd -> List.map (fun x -> DEF_scattered x) (map_scattered_def sd)
     in
@@ -2203,7 +2202,7 @@ let rec sizes_of_typ (Typ_aux (t,l)) =
      KidSet.of_list (size_nvars_nexp size)
   | Typ_app (_,tas) ->
      kidset_bigunion (List.map sizes_of_typarg tas)
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and sizes_of_typarg (A_aux (ta,_)) =
   match ta with
     A_nexp _
@@ -3597,11 +3596,11 @@ let analyse_defs debug env (Defs defs) =
     else ()
   in
   let splits = argset_to_list splits in
-  if Failures.is_empty fails 
+  if Failures.is_empty fails
   then (true,splits,extras) else
     begin
       Failures.iter (fun l msgs ->
-        Reporting.print_err false false l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs)))
+        Reporting.print_err l "Monomorphisation" (String.concat "\n" (StringSet.elements msgs)))
         fails;
       (false, splits,extras)
     end
@@ -3626,7 +3625,7 @@ let add_extra_splits extras (Defs defs) =
          let loc = match Analysis.translate_loc l with
            | Some l -> l
            | None ->
-              (Reporting.print_err false false l "Monomorphisation"
+              (Reporting.print_err l "Monomorphisation"
                  "Internal error: bad location for added case";
                ("",0))
          in
@@ -4205,7 +4204,7 @@ let replace_nexp_in_typ env typ orig new_nexp =
     | Typ_app (id, targs) ->
        let fs, targs = List.split (List.map aux_targ targs) in
        List.exists (fun x -> x) fs, Typ_aux (Typ_app (id, targs),l)
-    | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+    | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   and aux_targ (A_aux (ta,l) as typ_arg) =
     match ta with
     | A_nexp nexp ->
diff --git a/src/pp.ml b/src/pp.ml
deleted file mode 100644
index b3eaf1fc..00000000
--- a/src/pp.ml
+++ /dev/null
@@ -1,80 +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.                                                          *)
-(**************************************************************************)
-
-(** pretty printing utilities *)
-
-open Format
-
-let pp_str ppf s =
-  fprintf ppf "%s" s
-
-let rec lst sep f ppf = function
-  | [] -> ()
-  | [x] ->
-      fprintf ppf "%a"
-        f x
-  | (h::t) -> 
-      f ppf h;
-      fprintf ppf sep;
-      lst sep f ppf t
-
-let opt f ppf = function
-  | None ->
-      fprintf ppf "None"
-  | Some(x) ->
-      fprintf ppf "Some(%a)"
-        f x
-
-let pp_to_string pp =
-  let b = Buffer.create 16 in
-  let f = formatter_of_buffer b in
-    pp f;
-    pp_print_flush f ();
-    Buffer.contents b
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index a5478c31..fa858eae 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -51,10 +51,10 @@
 open Type_check
 open Ast
 open Ast_util
+open Reporting
 open Rewriter
 open PPrint
 open Pretty_print_common
-open Extra_pervasives
 
 module StringSet = Set.Make(String)
 
@@ -2008,8 +2008,8 @@ let merge_kids_atoms pats =
       match Type_check.destruct_atom_nexp (env_of_annot ann) typ with
       | Some (Nexp_aux (Nexp_var kid,l)) ->
          if KidSet.mem kid seen then
-           let () = 
-             Reporting.print_err false true l "merge_kids_atoms"
+           let () =
+             Reporting.print_err l "merge_kids_atoms"
                ("want to merge tyvar and argument for " ^ string_of_kid kid ^
                    " but rearranging arguments isn't supported yet") in
            gone,map,seen
@@ -2420,7 +2420,7 @@ try
   let generic_eq_types = types_used_with_generic_eq defs in
   let doc_def = doc_def unimplemented generic_eq_types in
   let () = if !opt_undef_axioms || IdSet.is_empty unimplemented then () else
-      Reporting.print_err false false Parse_ast.Unknown "Warning"
+      Reporting.print_err Parse_ast.Unknown "Warning"
         ("The following functions were declared but are undefined:\n" ^
             String.concat "\n" (List.map string_of_id (IdSet.elements unimplemented)))
   in
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 90ae2dba..9281db31 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -51,10 +51,10 @@
 open Type_check
 open Ast
 open Ast_util
+open Reporting
 open Rewriter
 open PPrint
 open Pretty_print_common
-open Extra_pervasives
 
 (****************************************************************************
  * PPrint-based sail-to-lem pprinter
diff --git a/src/reporting.ml b/src/reporting.ml
index 7aa68296..0bc73ed6 100644
--- a/src/reporting.ml
+++ b/src/reporting.ml
@@ -97,26 +97,22 @@
 
 type pos_or_loc = Loc of Parse_ast.l | Pos of Lexing.position
 
-let print_err_internal fatal verb_loc p_l m1 m2 =
+let print_err_internal p_l m1 m2 =
   let open Error_format in
   prerr_endline (m1 ^ ":");
   begin match p_l with
   | Loc l -> format_message (Location (l, Line m2)) err_formatter
   | Pos p -> format_message (Location (Parse_ast.Range (p, p), Line m2)) err_formatter
-  end;
-  if fatal then exit 1 else ()
+  end
 
 let loc_to_string ?code:(code=true) l =
   let open Error_format in
-  if code then
-    let b = Buffer.create 160 in
-    format_message (Location (l, Line "")) (buffer_formatter b);
-    Buffer.contents b
-  else
-    "LOC"
+  let b = Buffer.create 160 in
+  format_message (Location (l, Line "")) (buffer_formatter b);
+  Buffer.contents b
 
-let print_err fatal verb_loc l m1 m2 =
-  print_err_internal fatal verb_loc (Loc l) m1 m2
+let print_err l m1 m2 =
+  print_err_internal (Loc l) m1 m2
 
 type error =
   | Err_general of Parse_ast.l * string
@@ -130,14 +126,14 @@ type error =
 let issues = "\n\nPlease report this as an issue on GitHub at https://github.com/rems-project/sail/issues"
 
 let dest_err = function
-  | Err_general (l, m) -> ("Error", false, Loc l, m)
+  | Err_general (l, m) -> ("Error", Loc l, m)
   | Err_unreachable (l, (file, line, _, _), m) ->
-     ((Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line), false, Loc l, m ^ issues)
-  | Err_todo (l, m) -> ("Todo" ^ m, false, Loc l, "")
-  | Err_syntax (p, m) -> ("Syntax error", false, Pos p, m)
-  | Err_syntax_locn (l, m) -> ("Syntax error", false, Loc l, m)
-  | Err_lex (p, s) -> ("Lexical error", false, Pos p, s)
-  | Err_type (l, m) -> ("Type error", false, Loc l, m)
+     (Printf.sprintf "Internal error: Unreachable code (at \"%s\" line %d)" file line, Loc l, m ^ issues)
+  | Err_todo (l, m) -> ("Todo" ^ m, Loc l, "")
+  | Err_syntax (p, m) -> ("Syntax error", Pos p, m)
+  | Err_syntax_locn (l, m) -> ("Syntax error", Loc l, m)
+  | Err_lex (p, s) -> ("Lexical error", Pos p, s)
+  | Err_type (l, m) -> ("Type error", Loc l, m)
 
 exception Fatal_error of error
 
@@ -147,10 +143,9 @@ let err_unreachable l ocaml_pos m = Fatal_error (Err_unreachable (l, ocaml_pos,
 let err_general l m = Fatal_error (Err_general (l, m))
 let err_typ l m = Fatal_error (Err_type (l,m))
 
-let report_error e =
-  let (m1, verb_pos, pos_l, m2) = dest_err e in
-  print_err_internal verb_pos false pos_l m1 m2
+let unreachable l pos msg =
+  raise (err_unreachable l pos msg)
 
 let print_error e =
-  let (m1, verb_pos, pos_l, m2) = dest_err e in
-  print_err_internal verb_pos false pos_l m1 m2
+  let (m1, pos_l, m2) = dest_err e in
+  print_err_internal pos_l m1 m2
diff --git a/src/reporting.mli b/src/reporting.mli
index 4ce0ced8..2d886111 100644
--- a/src/reporting.mli
+++ b/src/reporting.mli
@@ -69,13 +69,13 @@ val loc_to_string : ?code:bool -> Parse_ast.l -> string
     std-err. It starts with printing location information stored in [l]
     It then prints "head: mes". If [fatal] is set, the program exists with error-code 1 afterwards.
 *)
-val print_err : bool -> bool -> Parse_ast.l -> string -> string -> unit
+val print_err : Parse_ast.l -> string -> string -> unit
 
 (** {2 Errors } *)
 
 (** Errors stop execution and print a message; they typically have a location and message.
 *)
-type error = 
+type error =
   (** General errors, used for multi purpose. If you are unsure, use this one. *)
   | Err_general of Parse_ast.l * string
 
@@ -105,8 +105,6 @@ val err_unreachable : Parse_ast.l -> (string * int * int * int) -> string -> exn
 (** [err_typ l m] is an abreviatiation for [Fatal_error (Err_type (l, m))] *)
 val err_typ : Parse_ast.l -> string -> exn
 
-(** Report error should only be used by main to print the error in the end. Everywhere else,
-    raising a [Fatal_error] exception is recommended. *)
-val report_error : error -> unit
+val unreachable : Parse_ast.l -> (string * int * int * int) -> string -> 'a
 
 val print_error : error -> unit
diff --git a/src/rewriter.ml b/src/rewriter.ml
index a70f6fab..330a98f6 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -382,29 +382,6 @@ let rewriters_base =
 
 let rewrite_defs (Defs defs) = rewrite_defs_base rewriters_base (Defs defs)
 
-module Envmap = Finite_map.Fmap_map(String)
-
-(* TODO: This seems to only consider a single assignment (or possibly two, in
-   separate branches of an if-expression). Hence, it seems the result is always
-   at most one variable. Is this intended?
-   It is only used below when pulling out local variables inside if-expressions
-   into the outer scope, which seems dubious. I comment it out for now. *)
-(*let rec introduced_variables (E_aux (exp,(l,annot))) =
-  match exp with
-  | E_cast (typ, exp) -> introduced_variables exp
-  | E_if (c,t,e) -> Envmap.intersect (introduced_variables t) (introduced_variables e)
-  | E_assign (lexp,exp) -> introduced_vars_le lexp exp
-  | _ -> Envmap.empty
-
-and introduced_vars_le (LEXP_aux(lexp,annot)) exp =
-  match lexp with
-  | LEXP_id (Id_aux (Id id,_))  | LEXP_cast(_,(Id_aux (Id id,_))) ->
-    (match annot with
-     | Base((_,t),Emp_intro,_,_,_,_) ->
-       Envmap.insert Envmap.empty (id,(t,exp))
-     | _ -> Envmap.empty)
-  | _ -> Envmap.empty*)
-
 type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg =
   { p_lit            : lit -> 'pat_aux
   ; p_wild           : 'pat_aux
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 1e3d319a..16efcd55 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -54,7 +54,6 @@ open Ast_util
 open Type_check
 open Spec_analysis
 open Rewriter
-open Extra_pervasives
 
 let (>>) f g = fun x -> g(f(x))
 
@@ -4637,7 +4636,7 @@ let check_cases process is_wild loc_of cases =
   let rec aux rps acc = function
     | [] -> acc, rps
     | [p] when is_wild p && match rps with [] -> true | _ -> false ->
-      let () = Reporting.print_err false false
+      let () = Reporting.print_err
         (loc_of p) "Match checking" "Redundant wildcard clause" in
       acc, []
     | h::t -> aux (process rps h) (h::acc) t
@@ -4677,7 +4676,7 @@ let rewrite_case (e,ann) =
 
         let _ =
           if !opt_coq_warn_nonexhaustive
-          then Reporting.print_err false false
+          then Reporting.print_err
             (fst ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in
 
         let l = Parse_ast.Generated Parse_ast.Unknown in
@@ -4697,7 +4696,7 @@ let rewrite_case (e,ann) =
      | (example::_) ->
         let _ =
           if !opt_coq_warn_nonexhaustive
-          then Reporting.print_err false false
+          then Reporting.print_err
             (fst ann) "Non-exhaustive let" ("Example: " ^ string_of_rp example) in
         let l = Parse_ast.Generated Parse_ast.Unknown in
         let p = P_aux (P_wild, (l, empty_tannot)) in
@@ -4727,7 +4726,7 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) =
   | (example::_) ->
      let _ =
        if !opt_coq_warn_nonexhaustive
-       then Reporting.print_err false false
+       then Reporting.print_err
               (fst f_ann) "Non-exhaustive matching" ("Example: " ^ string_of_rp example) in
 
      let l = Parse_ast.Generated Parse_ast.Unknown in
@@ -4738,7 +4737,6 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) =
      let default = FCL_aux (FCL_Funcl (id,Pat_aux (Pat_exp (p,b),(l,empty_tannot))),fcl_ann) in
 
      FD_aux (FD_function (r,t,e,fcls'@[default]),f_ann)
-  
 
 let rewrite =
   let alg = { id_exp_alg with e_aux = rewrite_case } in
diff --git a/src/sail.ml b/src/sail.ml
index 2777b7a5..71bf4577 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -415,6 +415,6 @@ let _ =  try
       with Failure s -> raise (Reporting.err_general Parse_ast.Unknown ("Failure " ^ s))
     end
   with Reporting.Fatal_error e ->
-    Reporting.report_error e;
+    Reporting.print_error e;
     Interactive.opt_suppress_banner := true;
     if !Interactive.opt_interactive then () else exit 1
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index 940fbfe5..88e80dd2 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -51,7 +51,6 @@
 open Ast
 open Util
 open Ast_util
-open Extra_pervasives
 
 module Nameset = Set.Make(String)
 
@@ -95,7 +94,7 @@ let rec free_type_names_t consider_var (Typ_aux (t, l)) = match t with
   | Typ_tup ts -> free_type_names_ts consider_var ts
   | Typ_app (name,targs) -> Nameset.add (string_of_id name) (free_type_names_t_args consider_var targs)
   | Typ_exist (kopts,_,t') -> List.fold_left (fun s kopt -> Nameset.remove (string_of_kid (kopt_kid kopt)) s) (free_type_names_t consider_var t') kopts
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and free_type_names_ts consider_var ts = nameset_bigunion (List.map (free_type_names_t consider_var) ts)
 and free_type_names_maybe_t consider_var = function
   | Some t -> free_type_names_t consider_var t
@@ -130,7 +129,7 @@ let rec fv_of_typ consider_var bound used (Typ_aux (t,l)) : Nameset.t =
      fv_of_typ consider_var
        (List.fold_left (fun b (KOpt_aux (KOpt_kind (_, (Kid_aux (Var v,_))), _)) -> Nameset.add v b) bound kopts)
        used t'
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 
 and fv_of_targ consider_var bound used (Ast.A_aux(targ,_)) : Nameset.t = match targ with
   | A_typ t -> fv_of_typ consider_var bound used t
diff --git a/src/specialize.ml b/src/specialize.ml
index 1ba57bd0..1881de5b 100644
--- a/src/specialize.ml
+++ b/src/specialize.ml
@@ -51,7 +51,6 @@
 open Ast
 open Ast_util
 open Rewriter
-open Extra_pervasives
 
 let is_typ_ord_uvar = function
   | A_aux (A_typ _, _) -> true
@@ -68,7 +67,7 @@ let rec nexp_simp_typ (Typ_aux (typ_aux, l)) =
     | Typ_fn (arg_typs, ret_typ, effect) ->
        Typ_fn (List.map nexp_simp_typ arg_typs, nexp_simp_typ ret_typ, effect)
     | Typ_bidir (t1, t2) -> Typ_bidir (nexp_simp_typ t1, nexp_simp_typ t2)
-    | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+    | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   in
   Typ_aux (typ_aux, l)
 and nexp_simp_typ_arg (A_aux (typ_arg_aux, l)) =
@@ -253,7 +252,7 @@ let rec typ_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) =
   | Typ_fn (arg_typs, ret_typ, _) ->
      List.fold_left KidSet.union (typ_frees ~exs:exs ret_typ) (List.map (typ_frees ~exs:exs) arg_typs)
   | Typ_bidir (t1, t2) -> KidSet.union (typ_frees ~exs:exs t1) (typ_frees ~exs:exs t2)
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) =
   match typ_arg_aux with
   | A_nexp n -> KidSet.empty
@@ -270,7 +269,7 @@ let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) =
   | Typ_fn (arg_typs, ret_typ, _) ->
      List.fold_left KidSet.union (typ_int_frees ~exs:exs ret_typ) (List.map (typ_int_frees ~exs:exs) arg_typs)
   | Typ_bidir (t1, t2) -> KidSet.union (typ_int_frees ~exs:exs t1) (typ_int_frees ~exs:exs t2)
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and typ_arg_int_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) =
   match typ_arg_aux with
   | A_nexp n -> KidSet.diff (tyvars_of_nexp n) exs
diff --git a/src/type_check.ml b/src/type_check.ml
index b362e813..ad9fab34 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -52,7 +52,6 @@ open Ast
 open Util
 open Ast_util
 open Lazy
-open Extra_pervasives
 
 module Big_int = Nat_big_num
 
@@ -671,7 +670,7 @@ end = struct
        wf_constraint ~exs:(KidSet.of_list (List.map kopt_kid kopts)) env nc;
        wf_typ ~exs:(KidSet.of_list (List.map kopt_kid kopts)) { env with constraints = nc :: env.constraints } typ
     | Typ_exist (_, _, _) -> typ_error env l ("Nested existentials are not allowed")
-    | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+    | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   and wf_typ_arg ?exs:(exs=KidSet.empty) env (A_aux (typ_arg_aux, _)) =
     match typ_arg_aux with
     | A_nexp nexp -> wf_nexp ~exs:exs env nexp
@@ -1232,7 +1231,7 @@ let rec is_typ_monomorphic (Typ_aux (typ, l)) =
   | Typ_fn (arg_typs, ret_typ, _) -> List.for_all is_typ_monomorphic arg_typs && is_typ_monomorphic ret_typ
   | Typ_bidir (typ1, typ2) -> is_typ_monomorphic typ1 && is_typ_monomorphic typ2
   | Typ_exist _ | Typ_var _ -> false
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and is_typ_arg_monomorphic (A_aux (arg, _)) =
   match arg with
   | A_nexp _ -> true
@@ -1678,7 +1677,7 @@ let rec kid_order kind_map (Typ_aux (aux, l) as typ) =
   | Typ_app (_, args) ->
      List.fold_left (fun (ord, kids) arg -> let (ord', kids) = kid_order_arg kids arg in (ord @ ord', kids)) ([], kind_map) args
   | Typ_fn _ | Typ_bidir _ | Typ_exist _ -> typ_error Env.empty l ("Existential or function type cannot appear within existential type: " ^ string_of_typ typ)
-  | Typ_internal_unknown -> unreachable l __POS__ "escaped Typ_internal_unknown"
+  | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
 and kid_order_arg kind_map (A_aux (aux, l) as arg) =
   match aux with
   | A_typ typ -> kid_order kind_map typ
-- 
cgit v1.2.3


From 25a8a48142cc715c55f11fc80cf3dad6bec1b71d Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 26 Dec 2018 20:42:54 +0000
Subject: More cleanup

Remove unused name schemes and DEF_kind
---
 src/ast_util.ml          |  8 +++-----
 src/c_backend.ml         |  6 +++---
 src/initial_check.ml     | 41 ++++++++++++-----------------------------
 src/lexer.mll            |  1 -
 src/monomorphise.ml      |  5 ++---
 src/ocaml_backend.ml     | 22 +++++++++++-----------
 src/parse_ast.ml         | 35 +++++------------------------------
 src/parser.mly           | 26 +++++++++++---------------
 src/pretty_print_coq.ml  |  8 +++-----
 src/pretty_print_lem.ml  |  7 +++----
 src/pretty_print_sail.ml | 18 +++++++-----------
 src/process_file.ml      |  8 ++++----
 src/rewriter.ml          |  2 +-
 src/rewrites.ml          | 10 +++++-----
 src/scattered.ml         |  4 ++--
 src/spec_analysis.ml     | 12 ++++--------
 src/specialize.ml        |  2 +-
 src/state.ml             |  6 +++---
 src/type_check.ml        | 19 +++++--------------
 19 files changed, 85 insertions(+), 155 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 36263615..b04a07e3 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -623,7 +623,6 @@ let exp_loc = function
   | E_aux (_, (l, _)) -> l
 
 let def_loc = function
-  | DEF_kind (KD_aux (_, (l, _)))
   | DEF_type (TD_aux (_, (l, _)))
   | DEF_fundef (FD_aux (_, (l, _)))
   | DEF_mapdef (MD_aux (_, (l, _)))
@@ -948,9 +947,9 @@ let id_of_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) =
 
 let id_of_type_def_aux = function
   | TD_abbrev (id, _, _)
-  | TD_record (id, _, _, _, _)
-  | TD_variant (id, _, _, _, _)
-  | TD_enum (id, _, _, _)
+  | TD_record (id, _, _, _)
+  | TD_variant (id, _, _, _)
+  | TD_enum (id, _, _)
   | TD_bitfield (id, _, _) -> id
 let id_of_type_def (TD_aux (td_aux, _)) = id_of_type_def_aux td_aux
 
@@ -964,7 +963,6 @@ let id_of_dec_spec (DEC_aux (ds_aux, _)) =
   | DEC_typ_alias (_, id, _) -> id
 
 let ids_of_def = function
-  | DEF_kind (KD_aux (KD_nabbrev (_, id, _, _), _)) -> IdSet.singleton id
   | DEF_type td -> IdSet.singleton (id_of_type_def td)
   | DEF_fundef fd -> IdSet.singleton (id_of_fundef fd)
   | DEF_val (LB_aux (LB_val (pat, _), _)) -> pat_ids pat
diff --git a/src/c_backend.ml b/src/c_backend.ml
index 53e7dc88..458a5c45 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -1390,16 +1390,16 @@ and compile_block ctx = function
    it returns a ctypdef * ctx pair. **)
 let compile_type_def ctx (TD_aux (type_def, _)) =
   match type_def with
-  | TD_enum (id, _, ids, _) ->
+  | TD_enum (id, ids, _) ->
      CTD_enum (id, ids),
      { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums }
 
-  | TD_record (id, _, _, ctors, _) ->
+  | 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, _, _, tus, _) ->
+  | TD_variant (id, _, tus, _) ->
      let compile_tu = function
        | Tu_aux (Tu_ty_id (typ, id), _) -> ctyp_of_typ ctx typ, id
      in
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 16597b3a..99dd5f34 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -490,13 +490,6 @@ let to_ast_spec ctx (val_:P.val_spec) : (unit val_spec) ctx_out =
       let typschm, _ = to_ast_typschm ctx ts in
       VS_aux(VS_val_spec(typschm,to_ast_id id,ext,is_cast),(l,())),ctx)
 
-let to_ast_namescm (P.Name_sect_aux(ns,l)) =
-  Name_sect_aux(
-    (match ns with
-    | P.Name_sect_none -> Name_sect_none
-    | P.Name_sect_some(s) -> Name_sect_some(s)
-    ),l)
-
 let rec to_ast_range (P.BF_aux(r,l)) = (* TODO add check that ranges are sensible for some definition of sensible *)
   BF_aux(
     (match r with
@@ -523,24 +516,24 @@ let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out
        TD_abbrev (id, typq, typ_arg),
        add_constructor id typq ctx
 
-    | P.TD_record (id, namescm_opt, typq, fields, _) ->
+    | P.TD_record (id, typq, fields, _) ->
        let id = to_ast_id id in
        let typq, typq_ctx = to_ast_typquant ctx typq in
        let fields = List.map (fun (atyp, id) -> to_ast_typ typq_ctx atyp, to_ast_id id) fields in
-       TD_record (id, to_ast_namescm namescm_opt, typq, fields, false),
+       TD_record (id, typq, fields, false),
        add_constructor id typq ctx
 
-    | P.TD_variant (id, namescm_opt, typq, arms, _) ->
+    | P.TD_variant (id, typq, arms, _) ->
        let id = to_ast_id id in
        let typq, typq_ctx = to_ast_typquant ctx typq in
        let arms = List.map (to_ast_type_union typq_ctx) arms in
-       TD_variant (id, to_ast_namescm namescm_opt, typq, arms, false),
+       TD_variant (id, typq, arms, false),
        add_constructor id typq ctx
 
-    | P.TD_enum (id, namescm_opt, enums, _) ->
+    | P.TD_enum (id, enums, _) ->
        let id = to_ast_id id in
        let enums = List.map to_ast_id enums in
-       TD_enum (id, to_ast_namescm namescm_opt, enums, false),
+       TD_enum (id, enums, false),
        { ctx with type_constructors = Bindings.add id [] ctx.type_constructors }
 
     | P.TD_bitfield (id, typ, ranges) ->
@@ -552,13 +545,6 @@ let to_ast_typedef ctx (P.TD_aux (aux, l) : P.type_def) : unit type_def ctx_out
   in
   TD_aux (aux, (l, ())), ctx
 
-let to_ast_kdef ctx (td:P.kind_def) : unit kind_def =
-  match td with
-  | P.KD_aux (P.KD_nabbrev (kind, id, name_scm_opt, atyp), l) ->
-     let id = to_ast_id id in
-     let kind = to_ast_kind kind in
-     KD_aux (KD_nabbrev (kind, id, to_ast_namescm name_scm_opt, to_ast_nexp ctx atyp), (l, ()))
-
 let to_ast_rec ctx (P.Rec_aux(r,l): P.rec_opt) : unit rec_opt =
   Rec_aux((match r with
   | P.Rec_nonrec -> Rec_nonrec
@@ -674,10 +660,10 @@ let to_ast_scattered ctx (P.SD_aux (aux, l)) =
        SD_function (to_ast_rec ctx rec_opt, tannot_opt, effect_opt, to_ast_id id), ctx
     | P.SD_funcl funcl ->
        SD_funcl (to_ast_funcl ctx funcl), ctx
-    | P.SD_variant (id, namescm_opt, typq) ->
+    | P.SD_variant (id, typq) ->
        let id = to_ast_id id in
        let typq, typq_ctx = to_ast_typquant ctx typq in
-       SD_variant (id, to_ast_namescm namescm_opt, typq),
+       SD_variant (id, typq),
        add_constructor id typq { ctx with scattereds = Bindings.add id typq_ctx ctx.scattereds }
     | P.SD_unioncl (id, tu) ->
        let id = to_ast_id id in
@@ -710,9 +696,6 @@ let to_ast_def ctx def : unit def ctx_out =
      DEF_overload (to_ast_id id, List.map to_ast_id ids), ctx
   | P.DEF_fixity (prec, n, op) ->
      DEF_fixity (to_ast_prec prec, n, to_ast_id op), ctx
-  | P.DEF_kind k_def ->
-     let kd = to_ast_kdef ctx k_def in
-     DEF_kind kd, ctx
   | P.DEF_type(t_def) ->
      let td, ctx = to_ast_typedef ctx t_def in
      DEF_type td, ctx
@@ -873,7 +856,7 @@ let generate_undefineds vs_ids (Defs defs) =
     | pats -> mk_pat (P_tup pats)
   in
   let undefined_td = function
-    | TD_enum (id, _, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
+    | TD_enum (id, ids, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
        let typschm = typschm_of_string ("unit -> " ^ string_of_id id ^ " effect {undef}") in
        [mk_val_spec (VS_val_spec (typschm, prepend_id "undefined_" id, (fun _ -> None), false));
         mk_fundef [mk_funcl (prepend_id "undefined_" id)
@@ -883,13 +866,13 @@ let generate_undefineds vs_ids (Defs defs) =
                              else
                                mk_exp (E_app (mk_id "internal_pick",
                                               [mk_exp (E_list (List.map (fun id -> mk_exp (E_id id)) ids))])))]]
-    | TD_record (id, _, typq, fields, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
+    | TD_record (id, typq, fields, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
        let pat = p_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id))) in
        [mk_val_spec (VS_val_spec (undefined_typschm id typq, prepend_id "undefined_" id, (fun _ -> None), false));
         mk_fundef [mk_funcl (prepend_id "undefined_" id)
                             pat
                             (mk_exp (E_record (List.map (fun (_, id) -> mk_fexp id (mk_lit_exp L_undef)) fields)))]]
-    | TD_variant (id, _, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
+    | TD_variant (id, typq, tus, _) when not (IdSet.mem (prepend_id "undefined_" id) vs_ids) ->
        let pat = p_tup (quant_items typq |> List.map quant_item_param |> List.concat |> List.map (fun id -> mk_pat (P_id id))) in
        let body =
          if !opt_fast_undefined && List.length tus > 0 then
@@ -967,7 +950,7 @@ let generate_initialize_registers vs_ids (Defs defs) =
 
 let generate_enum_functions vs_ids (Defs defs) =
   let rec gen_enums = function
-    | DEF_type (TD_aux (TD_enum (id, _, elems, _), _)) as enum :: defs ->
+    | DEF_type (TD_aux (TD_enum (id, elems, _), _)) as enum :: defs ->
        let enum_val_spec name quants typ =
          mk_val_spec (VS_val_spec (mk_typschm (mk_typquant quants) typ, name, (fun _ -> None), !opt_enum_casts))
        in
diff --git a/src/lexer.mll b/src/lexer.mll
index 57580e7a..55e765d9 100644
--- a/src/lexer.mll
+++ b/src/lexer.mll
@@ -146,7 +146,6 @@ let kw_table =
      ("return",                  (fun x -> Return));
      ("scattered",               (fun x -> Scattered));
      ("sizeof",                  (fun x -> Sizeof));
-     ("constant",                (fun x -> Constant));
      ("constraint",              (fun x -> Constraint));
      ("struct",                  (fun x -> Struct));
      ("then",                    (fun x -> Then));
diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index eb50bac3..dbe0fafd 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -1192,9 +1192,9 @@ let split_defs all_errors splits defs =
     in
     let sc_type_def ((TD_aux (tda,annot)) as td) =
       match tda with
-      | TD_variant (id,nscm,quant,tus,flag) ->
+      | TD_variant (id,quant,tus,flag) ->
          let (refinements, tus') = List.split (List.map (sc_type_union quant) tus) in
-         (List.concat refinements, TD_aux (TD_variant (id,nscm,quant,List.concat tus',flag),annot))
+         (List.concat refinements, TD_aux (TD_variant (id,quant,List.concat tus',flag),annot))
       | _ -> ([],td)
     in
     let sc_def d =
@@ -2111,7 +2111,6 @@ let split_defs all_errors splits defs =
     in
     let map_def d =
       match d with
-      | DEF_kind _
       | DEF_type _
       | DEF_spec _
       | DEF_default _
diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index ad2c198e..7f5f49e0 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -584,20 +584,20 @@ let ocaml_string_of_variant ctx id typq cases =
 
 let ocaml_typedef ctx (TD_aux (td_aux, _)) =
   match td_aux with
-  | TD_record (id, _, typq, fields, _) ->
+  | TD_record (id, typq, fields, _) ->
      ((separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; lbrace]
        ^//^ ocaml_fields ctx fields)
       ^/^ rbrace)
      ^^ ocaml_def_end
      ^^ ocaml_string_of_struct ctx id typq fields
-  | TD_variant (id, _, _, cases, _) when string_of_id id = "exception" ->
+  | TD_variant (id, _, cases, _) when string_of_id id = "exception" ->
      ocaml_exceptions ctx cases
-  | TD_variant (id, _, typq, cases, _) ->
+  | TD_variant (id, typq, cases, _) ->
      (separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals]
       ^//^ ocaml_cases ctx cases)
      ^^ ocaml_def_end
      ^^ ocaml_string_of_variant ctx id typq cases
-  | TD_enum (id, _, ids, _) ->
+  | TD_enum (id, ids, _) ->
      (separate space [string "type"; zencode ctx id; equals]
       ^//^ (bar ^^ space ^^ ocaml_enum ctx ids))
      ^^ ocaml_def_end
@@ -708,9 +708,9 @@ let ocaml_pp_generators ctx defs orig_types required =
     match td with
     | TD_abbrev (_, _, A_aux (A_typ typ, _)) ->
        add_req_from_typ required typ
-    | TD_record (_, _, _, fields, _) ->
+    | TD_record (_, _, fields, _) ->
        List.fold_left (fun req (typ,_) -> add_req_from_typ req typ) required fields
-    | TD_variant (_, _, _, variants, _) ->
+    | TD_variant (_, _, variants, _) ->
        List.fold_left (fun req (Tu_aux (Tu_ty_id (typ,_),_)) ->
            add_req_from_typ req typ) required variants
     | TD_enum _ -> required
@@ -724,8 +724,8 @@ let ocaml_pp_generators ctx defs orig_types required =
       | TD_aux (td,_) ->
          (match td with
           | TD_abbrev (_,tqs,A_aux (A_typ _, _)) -> tqs
-          | TD_record (_,_,tqs,_,_) -> tqs
-          | TD_variant (_,_,tqs,_,_) -> tqs
+          | TD_record (_,tqs,_,_) -> tqs
+          | TD_variant (_,tqs,_,_) -> tqs
           | TD_enum _ -> TypQ_aux (TypQ_no_forall,Unknown)
           | TD_abbrev (_, _, _) -> assert false
           | TD_bitfield _ -> assert false)
@@ -847,7 +847,7 @@ let ocaml_pp_generators ctx defs orig_types required =
         match td with
         | TD_abbrev (_,tqs,A_aux (A_typ typ, _)) ->
            tqs, gen_type typ, None, None
-        | TD_variant (_,_,tqs,variants,_) ->
+        | TD_variant (_,tqs,variants,_) ->
            tqs,
            string "let c = rand_choice [" ^^ group (nest 2 (break 0 ^^
              separate_map (string ";" ^^ break 1) rand_variant variants) ^^
@@ -855,7 +855,7 @@ let ocaml_pp_generators ctx defs orig_types required =
              string "] in c g",
            Some (separate_map (string ";" ^^ break 1) variant_constructor variants),
            Some (separate_map (break 1) build_constructor variants)
-        | TD_enum (_,_,variants,_) ->
+        | TD_enum (_,variants,_) ->
            TypQ_aux (TypQ_no_forall, Parse_ast.Unknown),
            string "rand_choice [" ^^ group (nest 2 (break 0 ^^
              separate_map (string ";" ^^ break 1) (zencode_upper ctx) variants) ^^
@@ -863,7 +863,7 @@ let ocaml_pp_generators ctx defs orig_types required =
                string "]",
            Some (separate_map (string ";" ^^ break 1) enum_constructor variants),
            Some (separate_map (break 1) build_enum_constructor variants)
-        | TD_record (_,_,tqs,fields,_) ->
+        | TD_record (_,tqs,fields,_) ->
            tqs, braces (separate_map (string ";" ^^ break 1) rand_field fields), None, None
         | _ ->
            raise (Reporting.err_todo l "Generators for bitfields not yet supported")
diff --git a/src/parse_ast.ml b/src/parse_ast.ml
index 65b11373..00da5afb 100644
--- a/src/parse_ast.ml
+++ b/src/parse_ast.ml
@@ -343,13 +343,6 @@ type_union_aux =  (* Type union constructors *)
    Tu_ty_id of atyp * id
  | Tu_ty_anon_rec of (atyp * id) list * id
 
-
-type 
-name_scm_opt_aux =  (* Optional variable-naming-scheme specification for variables of defined type *)
-   Name_sect_none
- | Name_sect_some of string
-
-
 type 
 tannot_opt = 
    Typ_annot_opt_aux of tannot_opt_aux * l
@@ -383,12 +376,6 @@ index_range_aux =  (* index specification, for bitfields in register types *)
 and index_range = 
    BF_aux of index_range_aux * l
 
-
-type 
-name_scm_opt = 
-   Name_sect_aux of name_scm_opt_aux * l
-
-
 type 
 default_typing_spec_aux =  (* Default kinding or typing assumption, and default order for literal vectors and vector shorthands *)
    DT_order of kind * atyp
@@ -447,20 +434,15 @@ fundef_aux =  (* Function definition *)
 type 
 type_def_aux =  (* Type definition body *)
    TD_abbrev of id * typquant * kind * atyp (* type abbreviation *)
- | TD_record of id * name_scm_opt * typquant * ((atyp * id)) list * bool (* struct type definition *)
- | TD_variant of id * name_scm_opt * typquant * (type_union) list * bool (* union type definition *)
- | TD_enum of id * name_scm_opt * (id) list * bool (* enumeration type definition *)
+ | TD_record of id * typquant * ((atyp * id)) list * bool (* struct type definition *)
+ | TD_variant of id * typquant * (type_union) list * bool (* union type definition *)
+ | TD_enum of id * (id) list * bool (* enumeration type definition *)
  | TD_bitfield of id * atyp * (id * index_range) list (* register mutable bitfield type definition *)
 
 type 
 val_spec_aux =  (* Value type specification *)
    VS_val_spec of typschm * id * (string -> string option) * bool
 
-
-type 
-kind_def_aux =  (* Definition body for elements of kind; many are shorthands for type\_defs *)
-   KD_nabbrev of kind * id * name_scm_opt * atyp (* type abbreviation *)
-
 type 
 dec_spec_aux =  (* Register declarations *)
    DEC_reg of atyp * id
@@ -474,7 +456,7 @@ scattered_def_aux =  (* Function and type union definitions that can be spread a
          a file. Each one must end in $_$ *)
    SD_function of rec_opt * tannot_opt * effect_opt * id (* scattered function definition header *)
  | SD_funcl of funcl (* scattered function definition clause *)
- | SD_variant of id * name_scm_opt * typquant (* scattered union definition header *)
+ | SD_variant of id * typquant (* scattered union definition header *)
  | SD_unioncl of id * type_union (* scattered union definition member *)
  | SD_mapping of id * tannot_opt
  | SD_mapcl of id * mapcl
@@ -500,12 +482,6 @@ type
 val_spec = 
    VS_aux of val_spec_aux * l
 
-
-type 
-kind_def = 
-   KD_aux of kind_def_aux * l
-
-
 type 
 dec_spec = 
    DEC_aux of dec_spec_aux * l
@@ -521,8 +497,7 @@ type fixity_token = (prec * Big_int.num * string)
 
 type
 def =  (* Top-level definition *)
-   DEF_kind of kind_def (* definition of named kind identifiers *)
- | DEF_type of type_def (* type definition *)
+   DEF_type of type_def (* type definition *)
  | DEF_fundef of fundef (* function definition *)
  | DEF_mapdef of mapdef (* mapping definition *)
  | DEF_val of letbind (* value definition *)
diff --git a/src/parser.mly b/src/parser.mly
index 66902953..ef30991f 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -134,7 +134,6 @@ let mk_typqn = (TypQ_aux(TypQ_no_forall,Unknown))
 let mk_tannotn = Typ_annot_opt_aux(Typ_annot_opt_none,Unknown)
 let mk_tannot typq typ n m = Typ_annot_opt_aux(Typ_annot_opt_some (typq, typ), loc n m)
 let mk_eannotn = Effect_opt_aux(Effect_opt_pure,Unknown)
-let mk_namesectn = Name_sect_aux(Name_sect_none,Unknown)
 
 let mk_typq kopts nc n m = TypQ_aux (TypQ_tq (List.map qi_id_of_kopt kopts @ nc), loc n m)
 
@@ -181,7 +180,7 @@ let rec desugar_rchain chain s e =
 %token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Where
 %token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Bool Cast
 %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef
-%token Undefined Union Newtype With Val Constant Constraint Throw Try Catch Exit Bitfield
+%token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield
 %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape
 %token Repeat Until While Do Mutual Var Ref Configuration
 
@@ -1170,21 +1169,21 @@ type_def:
   | Typedef id Colon kind Eq typ
     { mk_td (TD_abbrev ($2, mk_typqn, $4, $6)) $startpos $endpos }
   | Struct id Eq Lcurly struct_fields Rcurly
-    { mk_td (TD_record ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos }
+    { mk_td (TD_record ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos }
   | Struct id typaram Eq Lcurly struct_fields Rcurly
-    { mk_td (TD_record ($2, mk_namesectn, $3, $6, false)) $startpos $endpos }
+    { mk_td (TD_record ($2, $3, $6, false)) $startpos $endpos }
   | Enum id Eq enum_bar
-    { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos }
+    { mk_td (TD_enum ($2, $4, false)) $startpos $endpos }
   | Enum id Eq Lcurly enum Rcurly
-    { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos }
+    { mk_td (TD_enum ($2, $5, false)) $startpos $endpos }
   | Newtype id Eq type_union
-    { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos }
+    { mk_td (TD_variant ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), [$4], false)) $startpos $endpos }
   | Newtype id typaram Eq type_union
-    { mk_td (TD_variant ($2, mk_namesectn, $3, [$5], false)) $startpos $endpos }
+    { mk_td (TD_variant ($2, $3, [$5], false)) $startpos $endpos }
   | Union id Eq Lcurly type_unions Rcurly
-    { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos }
+    { mk_td (TD_variant ($2, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos }
   | Union id typaram Eq Lcurly type_unions Rcurly
-    { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos }
+    { mk_td (TD_variant ($2, $3, $6, false)) $startpos $endpos }
   | Bitfield id Colon typ Eq Lcurly r_def_body Rcurly
     { mk_td (TD_bitfield ($2, $4, $7)) $startpos $endpos }
 
@@ -1375,9 +1374,9 @@ default_def:
 
 scattered_def:
   | Union id typaram
-    { mk_sd (SD_variant($2, mk_namesectn, $3)) $startpos $endpos }
+    { mk_sd (SD_variant($2, $3)) $startpos $endpos }
   | Union id
-    { mk_sd (SD_variant($2, mk_namesectn, mk_typqn)) $startpos $endpos }
+    { mk_sd (SD_variant($2, mk_typqn)) $startpos $endpos }
   | Function_ id
     { mk_sd (SD_function(mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos }
   | Mapping id
@@ -1423,9 +1422,6 @@ def:
     { DEF_scattered (mk_sd (SD_end $2) $startpos $endpos) }
   | default_def
     { DEF_default $1 }
-  | Constant id Eq typ
-    { DEF_kind (KD_aux (KD_nabbrev (K_aux (K_int, loc $startpos($1) $endpos($1)), $2, mk_namesectn, $4),
-			loc $startpos $endpos)) }
   | Mutual Lcurly fun_def_list Rcurly
     { DEF_internal_mutrec $3 }
   | Pragma
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index fa858eae..a8631886 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -1720,7 +1720,6 @@ let types_used_with_generic_eq defs =
     fst (Rewriter.fold_pexp alg pexp)
   in
   let typs_req_def = function
-    | DEF_kind _
     | DEF_type _
     | DEF_spec _
     | DEF_fixity _
@@ -1758,7 +1757,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
                         doc_typquant_items empty_ctxt parens typq;
                         colon; string "Type"])
        (doc_typschm empty_ctxt false typschm) ^^ dot
-  | TD_record(id,nm,typq,fs,_) ->
+  | TD_record(id,typq,fs,_) ->
     let fname fid = if prefix_recordtype && string_of_id id <> "regstate"
                     then concat [doc_id id;string "_";doc_id_type fid;]
                     else doc_id_type fid in
@@ -1811,7 +1810,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
            (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq])
            ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^
       dot ^^ hardline ^^ eq_pp ^^ updates_pp
-  | TD_variant(id,nm,typq,ar,_) ->
+  | TD_variant(id,typq,ar,_) ->
      (match id with
       | Id_aux ((Id "read_kind"),_) -> empty
       | Id_aux ((Id "write_kind"),_) -> empty
@@ -1835,7 +1834,7 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
             type, so undo that here. *)
          let resetimplicit = separate space [string "Arguments"; id_pp; colon; string "clear implicits."] in
          typ_pp ^^ dot ^^ hardline ^^ resetimplicit ^^ hardline ^^ hardline)
-  | TD_enum(id,nm,enums,_) ->
+  | TD_enum(id,enums,_) ->
      (match id with
       | Id_aux ((Id "read_kind"),_) -> empty
       | Id_aux ((Id "write_kind"),_) -> empty
@@ -2370,7 +2369,6 @@ let rec doc_def unimplemented generic_eq_types def =
   | DEF_val (LB_aux (LB_val (pat, exp), _)) -> doc_val pat exp
   | DEF_scattered sdef -> failwith "doc_def: shoulnd't have DEF_scattered at this point"
   | DEF_mapdef (MD_aux (_, (l,_))) -> unreachable l __POS__ "Coq doesn't support mappings"
-  | DEF_kind _ -> empty
   | DEF_pragma _ -> empty
 
 let find_exc_typ defs =
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 9281db31..6c0c3272 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1021,7 +1021,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with
        (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq])
        (doc_typschm_lem false typschm)
   | TD_abbrev _ -> empty
-  | TD_record(id,nm,typq,fs,_) ->
+  | TD_record(id,typq,fs,_) ->
     let fname fid = if prefix_recordtype && string_of_id id <> "regstate"
                     then concat [doc_id_lem id;string "_";doc_id_lem_type fid;]
                     else doc_id_lem_type fid in
@@ -1073,7 +1073,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with
            ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline
     (* if !opt_sequential && string_of_id id = "regstate" then empty
     else separate_map hardline doc_field fs *)
-  | TD_variant(id,nm,typq,ar,_) ->
+  | TD_variant(id,typq,ar,_) ->
      (match id with
       | Id_aux ((Id "read_kind"),_) -> empty
       | Id_aux ((Id "write_kind"),_) -> empty
@@ -1145,7 +1145,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with
              fromInterpValuePP ^^ hardline ^^ hardline ^^
                fromToInterpValuePP ^^ hardline
            else empty)
-  | TD_enum(id,nm,enums,_) ->
+  | TD_enum(id,enums,_) ->
      (match id with
       | Id_aux ((Id "read_kind"),_) -> empty
       | Id_aux ((Id "write_kind"),_) -> empty
@@ -1428,7 +1428,6 @@ let rec doc_def_lem def =
      group (doc_let_lem empty_ctxt lbind) ^/^ hardline
   | DEF_scattered sdef -> failwith "doc_def_lem: shoulnd't have DEF_scattered at this point"
 
-  | DEF_kind _ -> empty
   | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "Lem doesn't support mappings"
   | DEF_pragma _ -> empty
 
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index 345312f7..df494036 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -594,16 +594,16 @@ let doc_typdef (TD_aux(td,_)) = match td with
        | None ->
           doc_op equals (concat [string "type"; space; doc_id id; doc_typ_arg_kind typ_arg]) (doc_typ_arg typ_arg)
      end
-  | TD_enum (id, _, ids, _) ->
+  | TD_enum (id, ids, _) ->
      separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace]
-  | TD_record (id, _, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, _, TypQ_aux (TypQ_tq [], _), fields, _) ->
+  | TD_record (id, TypQ_aux (TypQ_no_forall, _), fields, _) | TD_record (id, TypQ_aux (TypQ_tq [], _), fields, _) ->
      separate space [string "struct"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace]
-  | TD_record (id, _, TypQ_aux (TypQ_tq qs, _), fields, _) ->
+  | TD_record (id, TypQ_aux (TypQ_tq qs, _), fields, _) ->
      separate space [string "struct"; doc_id id; doc_param_quants qs; equals;
                      surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_field fields) rbrace]
-  | TD_variant (id, _, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, _, TypQ_aux (TypQ_tq [], _), unions, _) ->
+  | TD_variant (id, TypQ_aux (TypQ_no_forall, _), unions, _) | TD_variant (id, TypQ_aux (TypQ_tq [], _), unions, _) ->
      separate space [string "union"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace]
-  | TD_variant (id, _, TypQ_aux (TypQ_tq qs, _), unions, _) ->
+  | TD_variant (id, TypQ_aux (TypQ_tq qs, _), unions, _) ->
      separate space [string "union"; doc_id id; doc_param_quants qs; equals;
                      surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_union unions) rbrace]
   | _ -> string "TYPEDEF"
@@ -631,9 +631,6 @@ let doc_prec = function
   | InfixL -> string "infixl"
   | InfixR -> string "infixr"
 
-let doc_kind_def (KD_aux (KD_nabbrev (_, id, _, nexp), _)) =
-  separate space [string "integer"; doc_id id; equals; doc_nexp nexp]
-
 let rec doc_scattered (SD_aux (sd_aux, _)) =
   match sd_aux with
   | SD_function (_, _, _, id) ->
@@ -642,9 +639,9 @@ let rec doc_scattered (SD_aux (sd_aux, _)) =
      string "function" ^^ space ^^ string "clause" ^^ space ^^ doc_funcl funcl
   | SD_end id ->
      string "end" ^^ space ^^ doc_id id
-  | SD_variant (id, _, TypQ_aux (TypQ_no_forall, _)) ->
+  | SD_variant (id, TypQ_aux (TypQ_no_forall, _)) ->
      string "scattered" ^^ space ^^ string "union" ^^ space ^^ doc_id id
-  | SD_variant (id, _, TypQ_aux (TypQ_tq quants, _)) ->
+  | SD_variant (id, TypQ_aux (TypQ_tq quants, _)) ->
      string "scattered" ^^ space ^^ string "union" ^^ space ^^ doc_id id ^^ doc_param_quants quants
   | SD_unioncl (id, tu) ->
      separate space [string "union clause"; doc_id id; equals; doc_union tu]
@@ -653,7 +650,6 @@ let rec doc_def def = group (match def with
   | DEF_default df -> doc_default df
   | DEF_spec v_spec -> doc_spec v_spec
   | DEF_type t_def -> doc_typdef t_def
-  | DEF_kind k_def -> doc_kind_def k_def
   | DEF_fundef f_def -> doc_fundef f_def
   | DEF_mapdef m_def -> doc_mapdef m_def
   | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind
diff --git a/src/process_file.ml b/src/process_file.ml
index 03fc36a2..12f2b7c0 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -126,7 +126,7 @@ let parseid_to_string (Parse_ast.Id_aux (id, _)) =
 
 let rec realise_union_anon_rec_types orig_union arms =
   match orig_union with
-  | Parse_ast.TD_variant (union_id, name_scm_opt, typq, _, flag) ->
+  | Parse_ast.TD_variant (union_id, typq, _, flag) ->
      begin match arms with
      | [] -> []
      | arm :: arms ->
@@ -137,7 +137,7 @@ let rec realise_union_anon_rec_types orig_union arms =
            let record_str = "_" ^ parseid_to_string union_id ^ "_" ^ parseid_to_string id ^ "_record" in
            let record_id = Id_aux (Id record_str, Generated l) in
            let new_arm = Tu_aux ((Tu_ty_id ((ATyp_aux (ATyp_id record_id, Generated l)), id)), Generated l) in
-           let new_rec_def = DEF_type (TD_aux (TD_record (record_id, name_scm_opt, typq, fields, flag), Generated l)) in
+           let new_rec_def = DEF_type (TD_aux (TD_record (record_id, typq, fields, flag), Generated l)) in
            (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms)
      end
   | _ ->
@@ -210,7 +210,7 @@ let rec preprocess opts = function
 
   (* realise any anonymous record arms of variants *)
   | Parse_ast.DEF_type (Parse_ast.TD_aux
-                          (Parse_ast.TD_variant (id, name_scm_opt, typq, arms, flag) as union, l)
+                          (Parse_ast.TD_variant (id, typq, arms, flag) as union, l)
                        ) :: defs ->
      let records_and_arms = realise_union_anon_rec_types union arms in
      let rec filter_records = function [] -> []
@@ -219,7 +219,7 @@ let rec preprocess opts = function
      in
      let generated_records = filter_records (List.map fst records_and_arms) in
      let rewritten_arms = List.map snd records_and_arms in
-     let rewritten_union = Parse_ast.TD_variant (id, name_scm_opt, typq, rewritten_arms, flag) in
+     let rewritten_union = Parse_ast.TD_variant (id, typq, rewritten_arms, flag) in
      generated_records @ (Parse_ast.DEF_type (Parse_ast.TD_aux (rewritten_union, l))) :: preprocess opts defs
 
   | (Parse_ast.DEF_default (Parse_ast.DT_aux (Parse_ast.DT_order (_, Parse_ast.ATyp_aux (atyp, _)), _)) as def) :: defs ->
diff --git a/src/rewriter.ml b/src/rewriter.ml
index 330a98f6..ae19e447 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -358,7 +358,7 @@ let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls
 let rewrite_def rewriters d = match d with
   | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) ->
      DEF_reg_dec (DEC_aux (DEC_config (id, typ, rewriters.rewrite_exp rewriters exp), annot))
-  | DEF_type _ | DEF_mapdef _ | DEF_kind _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_overload _ | DEF_fixity _ -> d
+  | DEF_type _ | DEF_mapdef _ | DEF_spec _ | DEF_default _ | DEF_reg_dec _ | DEF_overload _ | DEF_fixity _ -> d
   | DEF_fundef fdef -> DEF_fundef (rewriters.rewrite_fun rewriters fdef)
   | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs)
   | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind)
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 16efcd55..9f082f49 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2307,11 +2307,11 @@ let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) =
   match td with
   | TD_abbrev (id, typq, A_aux (A_typ typ, l)) ->
      TD_aux (TD_abbrev (id, rw_typquant typq, A_aux (A_typ (rw_typ typ), l)), annot)
-  | TD_record (id, nso, typq, typ_ids, flag) ->
-     TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot)
-  | TD_variant (id, nso, typq, tus, flag) ->
-     TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot)
-  | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot)
+  | TD_record (id, typq, typ_ids, flag) ->
+     TD_aux (TD_record (id, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot)
+  | TD_variant (id, typq, tus, flag) ->
+     TD_aux (TD_variant (id, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot)
+  | TD_enum (id, ids, flag) -> TD_aux (TD_enum (id, ids, flag), annot)
   | TD_bitfield _ -> assert false (* Processed before re-writing *)
 
 (* FIXME: other reg_dec types *)
diff --git a/src/scattered.ml b/src/scattered.ml
index be304dc8..de286e3f 100644
--- a/src/scattered.ml
+++ b/src/scattered.ml
@@ -126,9 +126,9 @@ let rec descatter' funcls mapcls = function
   (* For scattered unions, when we find a union declaration we
      immediately grab all the future clauses and turn it into a
      regular union declaration. *)
-  | DEF_scattered (SD_aux (SD_variant (id, namescm, typq), (l, _))) :: defs ->
+  | DEF_scattered (SD_aux (SD_variant (id, typq), (l, _))) :: defs ->
      let tus = get_union_clauses id defs in
-     DEF_type (TD_aux (TD_variant (id, namescm, typq, tus, false), (gen_loc l, Type_check.empty_tannot)))
+     DEF_type (TD_aux (TD_variant (id, typq, tus, false), (gen_loc l, Type_check.empty_tannot)))
      :: descatter' funcls mapcls (filter_union_clauses id defs)
 
   (* Therefore we should never see SD_unioncl... *)
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index 88e80dd2..c7b93dbe 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -306,9 +306,6 @@ let typ_variants consider_var bound tunions =
     tunions
     (bound,mt)
 
-let fv_of_kind_def consider_var (KD_aux(k,_)) = match k with
-  | KD_nabbrev(_,id,_,nexp) -> init_env (string_of_id id), fv_of_nexp consider_var mt mt nexp
-
 let fv_of_abbrev consider_var bound used typq typ_arg =
   let ts_bound = if consider_var then typq_bindings typq else mt in
   ts_bound, fv_of_targ consider_var (Nameset.union bound ts_bound) used typ_arg
@@ -316,14 +313,14 @@ let fv_of_abbrev consider_var bound used typq typ_arg =
 let fv_of_type_def consider_var (TD_aux(t,_)) = match t with
   | TD_abbrev(id,typq,typ_arg) ->
      init_env (string_of_id id), snd (fv_of_abbrev consider_var mt mt typq typ_arg)
-  | TD_record(id,_,typq,tids,_) ->
+  | TD_record(id,typq,tids,_) ->
     let binds = init_env (string_of_id id) in
     let bounds = if consider_var then typq_bindings typq else mt in
     binds, List.fold_right (fun (t,_) n -> fv_of_typ consider_var bounds n t) tids mt
-  | TD_variant(id,_,typq,tunions,_) ->
+  | TD_variant(id,typq,tunions,_) ->
     let bindings = Nameset.add (string_of_id id) (if consider_var then typq_bindings typq else mt) in
     typ_variants consider_var bindings tunions
-  | TD_enum(id,_,ids,_) ->
+  | TD_enum(id,ids,_) ->
     Nameset.of_list (List.map string_of_id (id::ids)),mt
   | TD_bitfield(id,typ,_) ->
     init_env (string_of_id id), Nameset.empty (* fv_of_typ consider_var mt typ *)
@@ -429,7 +426,7 @@ let rec fv_of_scattered consider_var consider_scatter_as_one all_defs (SD_aux(sd
             | _ -> mt in
           scattered_binds, exp_ns
      end
-  | SD_variant (id,_,_) ->
+  | SD_variant (id,_) ->
     let name = string_of_id id in
     let uses =
       if consider_scatter_as_one
@@ -480,7 +477,6 @@ let fv_of_rd consider_var (DEC_aux (d, annot)) =
      init_env (string_of_id id), mt
 
 let fv_of_def consider_var consider_scatter_as_one all_defs = function
-  | DEF_kind kdef -> fv_of_kind_def consider_var kdef
   | DEF_type tdef -> fv_of_type_def consider_var tdef
   | DEF_fundef fdef -> fv_of_fun consider_var fdef
   | DEF_mapdef mdef -> mt,mt (* fv_of_map consider_var mdef *)
diff --git a/src/specialize.ml b/src/specialize.ml
index 1881de5b..b619edde 100644
--- a/src/specialize.ml
+++ b/src/specialize.ml
@@ -171,7 +171,7 @@ let id_of_instantiation id instantiation =
 
 let rec variant_generic_typ id (Defs defs) =
   match defs with
-  | DEF_type (TD_aux (TD_variant (id', _, typq, _, _), _)) :: _ when Id.compare id id' = 0 ->
+  | DEF_type (TD_aux (TD_variant (id', typq, _, _), _)) :: _ when Id.compare id id' = 0 ->
      mk_typ (Typ_app (id', List.map (fun kopt -> mk_typ_arg (A_typ (mk_typ (Typ_var (kopt_kid kopt))))) (quant_kopts typq)))
   | _ :: defs -> variant_generic_typ id (Defs defs)
   | [] -> failwith ("No variant with id " ^ string_of_id id)
diff --git a/src/state.ml b/src/state.ml
index c9a47b06..63a07c0e 100644
--- a/src/state.ml
+++ b/src/state.ml
@@ -136,10 +136,10 @@ let generate_initial_regstate defs =
       List.fold_left2 typ_subst_quant_item typ (quant_items tq) args
     in
     let add_typ_init_val vals = function
-      | TD_enum (id, _, id1 :: _, _) ->
+      | TD_enum (id, id1 :: _, _) ->
          (* Choose the first value of an enumeration type as default *)
          Bindings.add id (fun _ -> string_of_id id1) vals
-      | TD_variant (id, _, tq, (Tu_aux (Tu_ty_id (typ1, id1), _)) :: _, _) ->
+      | TD_variant (id, tq, (Tu_aux (Tu_ty_id (typ1, id1), _)) :: _, _) ->
          (* Choose the first variant of a union type as default *)
          let init_val args =
            let typ1 = typ_subst_typquant tq args typ1 in
@@ -149,7 +149,7 @@ let generate_initial_regstate defs =
       | TD_abbrev (id, tq, A_aux (A_typ typ, _)) ->
          let init_val args = lookup_init_val vals (typ_subst_typquant tq args typ) in
          Bindings.add id init_val vals
-      | TD_record (id, _, tq, fields, _) ->
+      | TD_record (id, tq, fields, _) ->
          let init_val args =
            let init_field (typ, id) =
              let typ = typ_subst_typquant tq args typ in
diff --git a/src/type_check.ml b/src/type_check.ml
index ad9fab34..b891f4c7 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -4483,30 +4483,22 @@ let mk_synonym typq typ_arg =
                                       ^ " in type synonym " ^ string_of_typ_arg typ_arg
                                       ^ " with " ^ string_of_list ", " string_of_n_constraint (Env.get_constraints env))
 
-let check_kinddef env (KD_aux (kdef, (l, _))) =
-  let kd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented kind def") in
-  match kdef with
-  | KD_nabbrev (K_aux (K_int, _) as kind, id, nmscm, nexp) ->
-     [DEF_kind (KD_aux (KD_nabbrev (kind, id, nmscm, nexp), (l, None)))],
-     Env.add_num_def id nexp env
-  | _ -> kd_err ()
-
 let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t =
   fun env (TD_aux (tdef, (l, _))) ->
   let td_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Typedef") in
   match tdef with
   | TD_abbrev (id, typq, typ_arg) ->
      [DEF_type (TD_aux (tdef, (l, None)))], Env.add_typ_synonym id (mk_synonym typq typ_arg) env
-  | TD_record (id, nmscm, typq, fields, _) ->
+  | TD_record (id, typq, fields, _) ->
      [DEF_type (TD_aux (tdef, (l, None)))], Env.add_record id typq fields env
-  | TD_variant (id, nmscm, typq, arms, _) ->
+  | TD_variant (id, typq, arms, _) ->
      let env =
        env
        |> Env.add_variant id (typq, arms)
        |> (fun env -> List.fold_left (fun env tu -> check_type_union env id typq tu) env arms)
      in
      [DEF_type (TD_aux (tdef, (l, None)))], env
-  | TD_enum (id, nmscm, ids, _) ->
+  | TD_enum (id, ids, _) ->
      [DEF_type (TD_aux (tdef, (l, None)))], Env.add_enum id ids env
   | TD_bitfield (id, typ, ranges) ->
      let typ = Env.expand_synonyms env typ in
@@ -4528,8 +4520,8 @@ and check_scattered : 'a. Env.t -> 'a scattered_def -> (tannot def) list * Env.t
   fun env (SD_aux (sdef, (l, _))) ->
   match sdef with
   | SD_function _ | SD_end _ | SD_mapping _ -> [], env
-  | SD_variant (id, namescm, typq) ->
-     [DEF_scattered (SD_aux (SD_variant (id, namescm, typq), (l, None)))], Env.add_scattered_variant id typq env
+  | SD_variant (id, typq) ->
+     [DEF_scattered (SD_aux (SD_variant (id, typq), (l, None)))], Env.add_scattered_variant id typq env
   | SD_unioncl (id, tu) ->
      [DEF_scattered (SD_aux (SD_unioncl (id, tu), (l, None)))],
      let env = Env.add_variant_clause id tu env in
@@ -4550,7 +4542,6 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   fun env def ->
   let cd_err () = raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "Unimplemented Case") in
   match def with
-  | DEF_kind kdef -> check_kinddef env kdef
   | DEF_type tdef -> check_typedef env tdef
   | DEF_fixity (prec, n, op) -> [DEF_fixity (prec, n, op)], env
   | DEF_fundef fdef -> check_fundef env fdef
-- 
cgit v1.2.3


From dfbbb4f111082008f26c34986244222d4c869e25 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 3 Jan 2019 15:58:31 +0000
Subject: Comment out bisect coverage in ocamlbuild files

---
 src/_tags           | 4 ++--
 src/myocamlbuild.ml | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/_tags b/src/_tags
index 6747424d..4630bea8 100644
--- a/src/_tags
+++ b/src/_tags
@@ -1,9 +1,9 @@
 true: -traverse, debug, use_menhir
 <**/parser.ml>: bin_annot, annot
-<**/*.ml> and not <**/parser.ml>: bin_annot, annot, coverage
+<**/*.ml> and not <**/parser.ml>: bin_annot, annot
 
 <sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), use_pprint
-<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint, coverage
+<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint
 
 <isail.ml>: package(linenoise)
 <elf_loader.ml>: package(linksem)
diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml
index b1f95339..ae45857d 100644
--- a/src/myocamlbuild.ml
+++ b/src/myocamlbuild.ml
@@ -79,7 +79,7 @@ let lem_opts = [A "-lib"; P "../gen_lib";
 
 dispatch begin function
 | After_rules ->
-    Bisect_ppx_plugin.handle_coverage ();
+    (* Bisect_ppx_plugin.handle_coverage (); *)
 
     (* ocaml_lib "lem_interp/interp"; *)
     ocaml_lib ~extern:false ~dir:"pprint/src" ~tag_name:"use_pprint" "pprint/src/PPrintLib";
-- 
cgit v1.2.3


From 3225079cfe3250465c97ca7308d45d1f09cf07f8 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 3 Jan 2019 18:14:50 +0000
Subject: Make sure to close file handles when printing error messages

---
 src/error_format.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/error_format.ml b/src/error_format.ml
index 9e125efa..f152f0ae 100644
--- a/src/error_format.ml
+++ b/src/error_format.ml
@@ -72,7 +72,7 @@ let format_code_single fname lnum cnum_from cnum_to contents ppf =
   try
     let in_chan = open_in fname in
     begin
-      try format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf
+      try format_code_single' fname in_chan lnum cnum_from cnum_to contents ppf; close_in in_chan
       with
       | _ -> close_in_noerr in_chan; ()
     end
@@ -83,7 +83,7 @@ let format_code_double fname lnum_from cnum_from lnum_to cnum_to contents ppf =
   try
     let in_chan = open_in fname in
     begin
-      try format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf
+      try format_code_double' fname in_chan lnum_from cnum_from lnum_to cnum_to contents ppf; close_in in_chan
       with
       | _ -> close_in_noerr in_chan; ()
     end
-- 
cgit v1.2.3


From 886cff213039c034bc78408ea52689514e0c9a69 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 3 Jan 2019 18:31:04 +0000
Subject: Add a few helper lemmas

---
 src/gen_lib/sail2_prompt_monad.lem | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'src')

diff --git a/src/gen_lib/sail2_prompt_monad.lem b/src/gen_lib/sail2_prompt_monad.lem
index 7a55056c..e0ac09f6 100644
--- a/src/gen_lib/sail2_prompt_monad.lem
+++ b/src/gen_lib/sail2_prompt_monad.lem
@@ -272,6 +272,8 @@ val emitEvent : forall 'regval 'a 'e. Eq 'regval => monad 'regval 'a 'e -> event
 let emitEvent m e = match (e, m) with
   | (E_read_mem rk a sz v, Read_mem rk' a' sz' k) ->
      if rk' = rk && a' = a && sz' = sz then Just (k v) else Nothing
+  | (E_read_memt rk a sz vt, Read_memt rk' a' sz' k) ->
+     if rk' = rk && a' = a && sz' = sz then Just (k vt) else Nothing
   | (E_write_mem wk a sz v r, Write_mem wk' a' sz' v' k) ->
      if wk' = wk && a' = a && sz' = sz && v' = v then Just (k r) else Nothing
   | (E_write_memt wk a sz v tag r, Write_memt wk' a' sz' v' tag' k) ->
-- 
cgit v1.2.3


From eb837a0ae70ef5dc8a2a3a28d59a736c57a952b3 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 8 Jan 2019 17:08:34 +0000
Subject: Improvements for v85

---
 src/ast_util.ml          |  2 +-
 src/error_format.ml      | 12 ++++++------
 src/lexer.mll            |  1 -
 src/parser.mly           |  2 +-
 src/pretty_print_sail.ml |  2 ++
 src/rewrites.ml          | 16 ++++++++++------
 src/sail.ml              | 20 +++++++++++++++-----
 src/specialize.ml        |  2 ++
 src/type_check.ml        |  2 +-
 src/type_check.mli       |  2 ++
 src/type_error.ml        | 37 ++++++++++++++++++++++---------------
 11 files changed, 62 insertions(+), 36 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index b04a07e3..14f3346a 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -128,7 +128,7 @@ let mk_val_spec vs_aux =
 
 let kopt_kid (KOpt_aux (KOpt_kind (_, kid), _)) = kid
 let kopt_kind (KOpt_aux (KOpt_kind (k, _), _)) = k
-                                               
+
 let is_nat_kopt = function
   | KOpt_aux (KOpt_kind (K_aux (K_int, _), _), _) -> true
   | _ -> false
diff --git a/src/error_format.ml b/src/error_format.ml
index f152f0ae..8e00c2b7 100644
--- a/src/error_format.ml
+++ b/src/error_format.ml
@@ -114,18 +114,18 @@ type message =
 
 let bullet = Util.(clear (blue "*"))
 
-let rec format_message msg =
+let rec format_message msg ppf =
   match msg with
   | Location (l, msg) ->
-     format_loc l (format_message msg)
+     format_loc l (format_message msg) ppf
   | Line str ->
-     format_endline str
+     format_endline str ppf
   | Seq messages ->
-     fun ppf -> List.iter (fun msg -> format_message msg ppf) messages
+     List.iter (fun msg -> format_message msg ppf) messages
   | List list ->
      let format_list_item ppf (header, msg) =
        format_endline (Util.(clear (blue "*")) ^ " " ^ header) ppf;
        format_message msg { ppf with indent = ppf.indent ^ "   " }
      in
-     fun ppf -> List.iter (format_list_item ppf) list
-  | With (f, msg) -> fun ppf -> format_message msg (f ppf)
+     List.iter (format_list_item ppf) list
+  | With (f, msg) -> format_message msg (f ppf)
diff --git a/src/lexer.mll b/src/lexer.mll
index 55e765d9..8df728e2 100644
--- a/src/lexer.mll
+++ b/src/lexer.mll
@@ -163,7 +163,6 @@ let kw_table =
      ("do",                      (fun _ -> Do));
      ("mutual",                  (fun _ -> Mutual));
      ("bitfield",                (fun _ -> Bitfield));
-     ("where",                   (fun _ -> Where));
 
      ("barr",                    (fun x -> Barr));
      ("depend",                  (fun x -> Depend));
diff --git a/src/parser.mly b/src/parser.mly
index ef30991f..3b42d498 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -177,7 +177,7 @@ let rec desugar_rchain chain s e =
 
 /*Terminals with no content*/
 
-%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op Where
+%token And As Assert Bitzero Bitone By Match Clause Dec Default Effect End Op
 %token Enum Else False Forall Foreach Overload Function_ Mapping If_ In Inc Let_ Int Order Bool Cast
 %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef
 %token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index df494036..75a7e4f9 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -371,6 +371,8 @@ let rec doc_exp (E_aux (e_aux, _) as exp) =
   | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp ->
      (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp)
      ^/^ (string "else" ^^ space ^^ doc_exp else_exp)
+  | E_if (if_exp, then_exp, E_aux ((E_lit (L_aux (L_unit, _)) | E_block []), _)) ->
+     group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp])
   | E_if (if_exp, then_exp, else_exp) ->
      group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp])
 
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 9f082f49..7536edf4 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2274,25 +2274,29 @@ let rewrite_fix_val_specs (Defs defs) =
 
 (* Turn constraints into numeric expressions with sizeof *)
 let rewrite_constraint =
-  let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux)
-  and rewrite_nc_aux = function
+  let rec rewrite_nc env (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux l env nc_aux)
+  and rewrite_nc_aux l env = function
     | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2))
     | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2))
     | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2))
     | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2))
-    | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2)
-    | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2)
+    | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "&", rewrite_nc env nc2)
+    | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "|", rewrite_nc env nc2)
     | NC_false -> E_lit (mk_lit L_false)
     | NC_true -> E_lit (mk_lit L_true)
     | NC_set (kid, []) -> E_lit (mk_lit (L_false))
     | NC_set (kid, int :: ints) ->
        let kid_eq kid int = nc_eq (nvar kid) (nconstant int) in
-       unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints))
+       unaux_exp (rewrite_nc env (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints))
+    | NC_app (f, args) ->
+       unaux_exp (rewrite_nc env (Env.expand_constraint_synonyms env (mk_nc (NC_app (f, args)))))
+    | NC_var v ->
+       Reporting.unreachable l __POS__ "Cannot rewrite this constraint"
   in
   let rewrite_e_aux (E_aux (e_aux, _) as exp) =
     match e_aux with
     | E_constraint nc ->
-       check_exp (env_of exp) (rewrite_nc nc) bool_typ
+       check_exp (env_of exp) (rewrite_nc (env_of exp) nc) bool_typ
     | _ -> exp
   in
 
diff --git a/src/sail.ml b/src/sail.ml
index 71bf4577..7bf7d135 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -261,10 +261,22 @@ let options = Arg.align ([
     " print version");
 ] )
 
+let version =
+  let open Manifest in
+  let default = Printf.sprintf "Sail %s @ %s" branch commit in
+  (* version is parsed from the output of git describe *)
+  match String.split_on_char '-' version with
+  | [vnum; _; _] ->
+     (try
+        let vnum = float_of_string vnum +. 2.0 in
+        Printf.sprintf "Sail %.1f (%s @ %s)" vnum branch commit
+      with
+      | Failure _ -> default)
+  | _ -> default
+
 let usage_msg =
-    ("Sail 2.0\n"
-     ^ "usage: sail <options> <file1.sail> ... <fileN.sail>\n"
-    )
+  version
+  ^ "\nusage: sail <options> <file1.sail> ... <fileN.sail>\n"
 
 let _ =
   Arg.parse options
@@ -272,7 +284,6 @@ let _ =
       opt_file_arguments := (!opt_file_arguments) @ [s])
     usage_msg
 
-
 let load_files type_envs files =
   if !opt_memo_z3 then Constraint.load_digests () else ();
 
@@ -344,7 +355,6 @@ let main() =
       | _ -> Some (Ocaml_backend.orig_types_for_ocaml_generator ast, !opt_ocaml_generators)
     in
 
-    (*let _ = Printf.eprintf "Type checked, next to pretty print" in*)
     begin
       (if !(Interactive.opt_interactive)
        then
diff --git a/src/specialize.ml b/src/specialize.ml
index b619edde..e7f686d8 100644
--- a/src/specialize.ml
+++ b/src/specialize.ml
@@ -258,6 +258,7 @@ and typ_arg_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) =
   | A_nexp n -> KidSet.empty
   | A_typ typ -> typ_frees ~exs:exs typ
   | A_order ord -> KidSet.empty
+  | A_bool _ -> KidSet.empty
 
 let rec typ_int_frees ?exs:(exs=KidSet.empty) (Typ_aux (typ_aux, l)) =
   match typ_aux with
@@ -275,6 +276,7 @@ and typ_arg_int_frees ?exs:(exs=KidSet.empty) (A_aux (typ_arg_aux, l)) =
   | A_nexp n -> KidSet.diff (tyvars_of_nexp n) exs
   | A_typ typ -> typ_int_frees ~exs:exs typ
   | A_order ord -> KidSet.empty
+  | A_bool _ -> KidSet.empty
 
 let specialize_id_valspec instantiations id ast =
   match split_defs (is_valspec id) ast with
diff --git a/src/type_check.ml b/src/type_check.ml
index b891f4c7..4ed234f2 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1076,7 +1076,7 @@ end = struct
 
   let add_constraint constr env =
     wf_constraint env constr;
-    let (NC_aux (nc_aux, l) as constr) = expand_constraint_synonyms env constr in
+    let (NC_aux (nc_aux, l) as constr) = constraint_simp (expand_constraint_synonyms env constr) in
     match nc_aux with
     | NC_true -> env
     | _ ->
diff --git a/src/type_check.mli b/src/type_check.mli
index e3a22c8d..7a5a3446 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -184,6 +184,8 @@ module Env : sig
      old one. *)
   val fresh_kid : ?kid:kid -> t -> kid
 
+  val expand_constraint_synonyms : t -> n_constraint -> n_constraint
+
   val expand_synonyms : t -> typ -> typ
 
   (** Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *)
diff --git a/src/type_error.ml b/src/type_error.ml
index 6f856480..e75d2cd4 100644
--- a/src/type_error.ml
+++ b/src/type_error.ml
@@ -151,21 +151,28 @@ let rec string_of_type_error err =
   Buffer.contents b
 
 let rec collapse_errors = function
-  | (Err_no_overloading (_, (err :: errs)) as no_collapse) ->
-      let err = collapse_errors (snd err) in
-      let errs = List.map (fun (_, err) -> collapse_errors err) errs in
-      let fold_equal msg err =
-        match msg, err with
-        | Some msg, Err_no_overloading _ -> Some msg
-        | Some msg, Err_other _ -> Some msg
-        | Some msg, Err_no_casts _ -> Some msg
-        | Some msg, err when msg = string_of_type_error err -> Some msg
-        | _, _ -> None
-      in
-      begin match List.fold_left fold_equal (Some (string_of_type_error err)) errs with
-      | Some _ -> err
-      | None -> no_collapse
-      end
+  | (Err_no_overloading (_, errs) as no_collapse) ->
+     let errs = List.map (fun (_, err) -> collapse_errors err) errs in
+     let interesting = function
+       | Err_other _ -> false
+       | Err_no_casts _ -> false
+       | _ -> true
+     in
+     begin match List.filter interesting errs with
+     | err :: errs ->
+        let fold_equal msg err =
+          match msg, err with
+          | Some msg, Err_no_overloading _ -> Some msg
+          | Some msg, Err_no_casts _ -> Some msg
+          | Some msg, err when msg = string_of_type_error err -> Some msg
+          | _, _ -> None
+        in
+        begin match List.fold_left fold_equal (Some (string_of_type_error err)) errs with
+        | Some _ -> err
+        | None -> no_collapse
+        end
+     | [] -> no_collapse
+     end
   | Err_because (err1, l, err2) as no_collapse ->
      let err1 = collapse_errors err1 in
      let err2 = collapse_errors err2 in
-- 
cgit v1.2.3


From 05e6058795e71cf1543e282752cbf95e471894cc Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 10 Jan 2019 17:10:19 +0000
Subject: Fixes so 8.5 with vector instructions compiles to C

---
 src/anf.ml      |  8 ++++++--
 src/profile.ml  |  2 +-
 src/rewriter.ml | 15 ++++++++++-----
 src/rewrites.ml | 34 ++++++++++++++++++++++++++--------
 src/util.ml     | 11 +++++++++++
 src/util.mli    |  2 ++
 6 files changed, 56 insertions(+), 16 deletions(-)

(limited to 'src')

diff --git a/src/anf.ml b/src/anf.ml
index 915ab738..38c77e0b 100644
--- a/src/anf.ml
+++ b/src/anf.ml
@@ -699,9 +699,13 @@ let rec anf (E_aux (e_aux, ((l, _) as exp_annot)) as exp) =
      (* Interpreter specific *)
      raise (Reporting.err_unreachable l __POS__ "encountered E_internal_value when converting to ANF")
 
-  | E_sizeof _ | E_constraint _ ->
+  | E_sizeof nexp ->
      (* Sizeof nodes removed by sizeof rewriting pass *)
-     raise (Reporting.err_unreachable l __POS__ "encountered E_sizeof or E_constraint node when converting to ANF")
+     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 *)
diff --git a/src/profile.ml b/src/profile.ml
index cb374403..1a8bd30b 100644
--- a/src/profile.ml
+++ b/src/profile.ml
@@ -83,7 +83,7 @@ let finish msg t =
   if !opt_profile then
     begin match !profile_stack with
     | p :: ps ->
-       prerr_endline (Printf.sprintf "%s %s: %fs" Util.("Profile" |> magenta |> clear) msg (Sys.time () -. t));
+       prerr_endline (Printf.sprintf "%s %s: %fs" Util.("Profiled" |> magenta |> clear) msg (Sys.time () -. t));
        prerr_endline (Printf.sprintf "  Z3 calls: %d, Z3 time: %fs" p.z3_calls p.z3_time);
        profile_stack := ps
     | [] -> ()
diff --git a/src/rewriter.ml b/src/rewriter.ml
index ae19e447..39b437f4 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -336,7 +336,7 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) =
   | LEXP_memory (id,exps) -> rewrap (LEXP_memory(id,List.map (rewriters.rewrite_exp rewriters) exps))
   | LEXP_vector (lexp,exp) ->
     rewrap (LEXP_vector (rewriters.rewrite_lexp rewriters lexp,rewriters.rewrite_exp rewriters exp))
-  | LEXP_vector_range (lexp,exp1,exp2) -> 
+  | LEXP_vector_range (lexp,exp1,exp2) ->
     rewrap (LEXP_vector_range (rewriters.rewrite_lexp rewriters lexp,
                                rewriters.rewrite_exp rewriters exp1,
                                rewriters.rewrite_exp rewriters exp2))
@@ -363,13 +363,18 @@ let rewrite_def rewriters d = match d with
   | DEF_internal_mutrec fdefs -> DEF_internal_mutrec (List.map (rewriters.rewrite_fun rewriters) fdefs)
   | DEF_val letbind -> DEF_val (rewriters.rewrite_let rewriters letbind)
   | DEF_pragma (pragma, arg, l) -> DEF_pragma (pragma, arg, l)
-  | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewritter")
+  | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewriter")
 
 let rewrite_defs_base rewriters (Defs defs) =
-  let rec rewrite ds = match ds with
+  let total = List.length defs in
+  let rec rewrite n = function
     | [] -> []
-    | d::ds -> (rewriters.rewrite_def rewriters d)::(rewrite ds) in
-  Defs (rewrite defs)
+    | d :: ds ->
+       if !Profile.opt_profile then Util.progress n total else ();
+       let d = rewriters.rewrite_def rewriters d in
+       d :: rewrite (n + 1) ds
+  in
+  Defs (rewrite 1 defs)
 
 let rewriters_base =
   {rewrite_exp = rewrite_exp;
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 7536edf4..88ea5304 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -350,13 +350,24 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
   let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) =
     match nexp_aux with
     | Nexp_sum (n1, n2) ->
-       mk_exp (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2]))
+       mk_exp ~loc:l (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2]))
     | Nexp_minus (n1, n2) ->
-       mk_exp (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2]))
+       mk_exp ~loc:l (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2]))
     | Nexp_times (n1, n2) ->
-       mk_exp (E_app (mk_id "mult_atom", [split_nexp n1; split_nexp n2]))
-    | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_atom", [split_nexp nexp]))
-    | _ -> mk_exp (E_sizeof nexp)
+       mk_exp ~loc:l (E_app (mk_id "mult_atom", [split_nexp n1; split_nexp n2]))
+    | Nexp_neg nexp ->
+       mk_exp ~loc:l (E_app (mk_id "negate_atom", [split_nexp nexp]))
+    | Nexp_app (f, [n1; n2]) when string_of_id f = "div" ->
+       (* We should be more careful about the right division here *)
+       mk_exp ~loc:l (E_app (mk_id "div", [split_nexp n1; split_nexp n2]))
+    | _ ->
+       mk_exp ~loc:l (E_sizeof nexp)
+  in
+  let is_int_typ env v _ = function
+    | (_, Typ_aux (Typ_app (f, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)]), _))
+         when Kid.compare v v' = 0 && string_of_id f = "atom" ->
+       true
+    | _ -> false
   in
   let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) =
     let env = env_of orig_exp in
@@ -365,9 +376,13 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
        E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect))
     | E_sizeof nexp ->
        begin
+         let locals = Env.get_locals env in
          match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with
          | Nexp_aux (Nexp_constant c, _) ->
             E_aux (E_lit (L_aux (L_num c, l)), (l, mk_tannot env (atom_typ nexp) no_effect))
+         | Nexp_aux (Nexp_var v, _) when Bindings.exists (is_int_typ env v) locals ->
+            let id = fst (Bindings.choose (Bindings.filter (is_int_typ env v) locals)) in
+            E_aux (E_id id, (l, mk_tannot env (atom_typ nexp) no_effect))
          | _ ->
             let locals = Env.get_locals env in
             let exps = Bindings.bindings locals
@@ -2288,15 +2303,18 @@ let rewrite_constraint =
     | NC_set (kid, int :: ints) ->
        let kid_eq kid int = nc_eq (nvar kid) (nconstant int) in
        unaux_exp (rewrite_nc env (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints))
+    | NC_app (f, [A_aux (A_bool nc, _)]) when string_of_id f = "not" ->
+       E_app (mk_id "not_bool", [rewrite_nc env nc])
     | NC_app (f, args) ->
        unaux_exp (rewrite_nc env (Env.expand_constraint_synonyms env (mk_nc (NC_app (f, args)))))
     | NC_var v ->
-       Reporting.unreachable l __POS__ "Cannot rewrite this constraint"
+       (* Would be better to translate change E_sizeof to take a kid, then rewrite to E_sizeof *)
+       E_id (id_of_kid v)
   in
-  let rewrite_e_aux (E_aux (e_aux, _) as exp) =
+  let rewrite_e_aux (E_aux (e_aux, (l, _)) as exp) =
     match e_aux with
     | E_constraint nc ->
-       check_exp (env_of exp) (rewrite_nc (env_of exp) nc) bool_typ
+       locate (fun _ -> gen_loc l) (check_exp (env_of exp) (rewrite_nc (env_of exp) nc) (atom_bool_typ nc))
     | _ -> exp
   in
 
diff --git a/src/util.ml b/src/util.ml
index 5e5654d1..f9603f8e 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -465,3 +465,14 @@ let log_line str line msg =
   "\n[" ^ (str ^ ":" ^ string_of_int line |> blue |> clear) ^ "] " ^ msg
 
 let header str n = "\n" ^ str ^ "\n" ^ String.make (String.length str - 9 * n) '='
+
+let progress n total =
+  let len = truncate ((float n /. float total) *. 50.0) in
+  let percent = truncate ((float n /. float total) *. 100.0) in
+  let str = "[" ^ String.make len '=' ^ String.make (50 - len) ' ' ^ "] " ^ string_of_int percent ^ "%" in
+  prerr_string str;
+  if n = total then
+    prerr_char '\n'
+  else
+    prerr_string ("\x1B[" ^ string_of_int (String.length str) ^ "D");
+  flush stderr
diff --git a/src/util.mli b/src/util.mli
index fd0242a3..591cf47b 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -263,3 +263,5 @@ val file_encode_string : string -> string
 
 val log_line : string -> int -> string -> string
 val header : string -> int -> string
+
+val progress : int -> int -> unit
-- 
cgit v1.2.3


From 9cfa575245a0427a0d35504086de182bd80b7df8 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Fri, 11 Jan 2019 21:00:36 +0000
Subject: Updates for sail-arm release

We want to ensure that no_devices.sail and devices.sail have the same
effect footprint, because with a snapshot-type release in sail-arm, we
can't rebuild the spec with asl_to_sail every time we switch from
running elf binaries to booting OS's. This commit allows registers to
have arbitrary effects, so registers that are really representing
memory-mapped devices don't have to have the wmem/rmem effect.
---
 src/ast_util.ml          |  4 ++--
 src/c_backend.ml         | 20 +++++++++++++++-----
 src/initial_check.ml     |  6 +++---
 src/ocaml_backend.ml     |  2 +-
 src/parse_ast.ml         |  2 +-
 src/parser.mly           |  6 +++++-
 src/pretty_print_coq.ml  |  2 +-
 src/pretty_print_lem.ml  |  2 +-
 src/pretty_print_sail.ml | 11 ++++++++++-
 src/process_file.ml      |  6 ++++--
 src/rewriter.ml          | 11 ++++++++++-
 src/rewriter.mli         |  3 +++
 src/rewrites.ml          |  2 +-
 src/sail.ml              |  4 ++--
 src/spec_analysis.ml     |  2 +-
 src/state.ml             |  2 +-
 src/type_check.ml        | 31 +++++++++++++++++++++++--------
 src/util.ml              | 37 ++++++++++++++++++++++++++++---------
 src/util.mli             |  3 ++-
 19 files changed, 114 insertions(+), 42 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 14f3346a..c0e9fe02 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -957,7 +957,7 @@ let id_of_val_spec (VS_aux (VS_val_spec (_, id, _, _), _)) = id
 
 let id_of_dec_spec (DEC_aux (ds_aux, _)) =
   match ds_aux with
-  | DEC_reg (_, id) -> id
+  | DEC_reg (_, _, _, id) -> id
   | DEC_config (id, _, _) -> id
   | DEC_alias (id, _) -> id
   | DEC_typ_alias (_, id, _) -> id
@@ -966,7 +966,7 @@ let ids_of_def = function
   | DEF_type td -> IdSet.singleton (id_of_type_def td)
   | DEF_fundef fd -> IdSet.singleton (id_of_fundef fd)
   | DEF_val (LB_aux (LB_val (pat, _), _)) -> pat_ids pat
-  | DEF_reg_dec (DEC_aux (DEC_reg (_, id), _)) -> IdSet.singleton id
+  | DEF_reg_dec (DEC_aux (DEC_reg (_, _, _, id), _)) -> IdSet.singleton id
   | DEF_spec vs -> IdSet.singleton (id_of_val_spec vs)
   | DEF_internal_mutrec fds -> IdSet.of_list (List.map id_of_fundef fds)
   | _ -> IdSet.empty
diff --git a/src/c_backend.ml b/src/c_backend.ml
index 458a5c45..6e21dab6 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -1623,8 +1623,8 @@ let fix_destructure fail_label = function
 let letdef_count = ref 0
 
 (** Compile a Sail toplevel definition into an IR definition **)
-let rec compile_def ctx = function
-  | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), _)) ->
+let rec 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
@@ -1645,6 +1645,8 @@ let rec compile_def ctx = function
 
   | 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
@@ -1763,7 +1765,7 @@ let rec compile_def ctx = function
 
   | 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 ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs
+     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))
@@ -3321,7 +3323,10 @@ let bytecode_ast ctx rewrites (Defs defs) =
   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 chunks, ctx = List.fold_left (fun (chunks, ctx) def -> let defs, ctx = compile_def ctx def in defs :: chunks, ctx) ([], ctx) defs 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
   rewrites cdefs
 
@@ -3362,8 +3367,13 @@ let compile_ast ctx c_includes (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 chunks, ctx = List.fold_left (fun (chunks, ctx) def -> let defs, ctx = compile_def ctx def in defs :: chunks, ctx) ([], ctx) defs 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
     let cdefs = sort_ctype_defs cdefs in
     let cdefs = optimize ctx cdefs in
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 99dd5f34..30b8bc96 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -642,8 +642,8 @@ let to_ast_alias_spec ctx (P.E_aux(e, l)) =
 
 let to_ast_dec ctx (P.DEC_aux(regdec,l)) =
   DEC_aux((match regdec with
-           | P.DEC_reg (typ, id) ->
-              DEC_reg (to_ast_typ ctx typ, to_ast_id id)
+           | P.DEC_reg (reffect, weffect, typ, id) ->
+              DEC_reg (to_ast_effects reffect, to_ast_effects weffect, to_ast_typ ctx typ, to_ast_id id)
            | P.DEC_config (id, typ, exp) ->
               DEC_config (to_ast_id id, to_ast_typ ctx typ, to_ast_exp ctx exp)
            | P.DEC_alias (id,e) ->
@@ -932,7 +932,7 @@ let generate_undefineds vs_ids (Defs defs) =
   Defs (undefined_builtins @ undefined_defs defs)
 
 let rec get_registers = function
-  | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), _)) :: defs -> (typ, id) :: get_registers defs
+  | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) :: defs -> (typ, id) :: get_registers defs
   | _ :: defs -> get_registers defs
   | [] -> []
 
diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index 7f5f49e0..75887b4e 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -393,7 +393,7 @@ let initial_value_for id inits =
 
 let ocaml_dec_spec ctx (DEC_aux (reg, _)) =
   match reg with
-  | DEC_reg (typ, id) ->
+  | DEC_reg (_, _, typ, id) ->
      separate space [string "let"; zencode ctx id; colon;
                      parens (ocaml_typ ctx typ); string "ref"; equals;
                      string "ref"; parens (ocaml_exp ctx (initial_value_for id ctx.register_inits))]
diff --git a/src/parse_ast.ml b/src/parse_ast.ml
index 00da5afb..cbd2a8c5 100644
--- a/src/parse_ast.ml
+++ b/src/parse_ast.ml
@@ -445,7 +445,7 @@ val_spec_aux =  (* Value type specification *)
 
 type 
 dec_spec_aux =  (* Register declarations *)
-   DEC_reg of atyp * id
+   DEC_reg of atyp * atyp * atyp * id
  | DEC_config of id * atyp * exp
  | DEC_alias of id * exp
  | DEC_typ_alias of atyp * id * exp
diff --git a/src/parser.mly b/src/parser.mly
index 3b42d498..68720048 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -1362,7 +1362,11 @@ val_spec_def:
 
 register_def:
   | Register id Colon typ
-    { mk_reg_dec (DEC_reg ($4, $2)) $startpos $endpos }
+    { let rreg = mk_typ (ATyp_set [mk_effect BE_rreg $startpos($1) $endpos($1)]) $startpos($1) $endpos($1) in
+      let wreg = mk_typ (ATyp_set [mk_effect BE_wreg $startpos($1) $endpos($1)]) $startpos($1) $endpos($1) in
+      mk_reg_dec (DEC_reg (rreg, wreg, $4, $2)) $startpos $endpos }
+  | Register effect_set effect_set id Colon typ
+    { mk_reg_dec (DEC_reg ($2, $3, $6, $4)) $startpos $endpos }
   | Register Configuration id Colon typ Eq exp
     { mk_reg_dec (DEC_config ($3, $5, $7)) $startpos $endpos }
 
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index a8631886..5a122557 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -2203,7 +2203,7 @@ let rec doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),fannot)) =
 
 let doc_dec (DEC_aux (reg, ((l, _) as annot))) =
   match reg with
-  | DEC_reg(typ,id) -> empty
+  | DEC_reg(_,_,typ,id) -> empty
      (*
        let env = env_of_annot annot in
        let rt = Env.base_typ_of env typ in
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 6c0c3272..0a1b38f9 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1336,7 +1336,7 @@ let rec doc_fundef_lem (FD_aux(FD_function(r, typa, efa, fcls),fannot) as fd) =
 
 let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) =
   match reg with
-  | DEC_reg(typ,id) -> empty
+  | DEC_reg(_,_,typ,id) -> empty
      (* if !opt_sequential then empty
      else
        let env = env_of_annot annot in
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index 75a7e4f9..becdccc0 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -119,6 +119,12 @@ let rec doc_nexp =
   in
   nexp0
 
+let doc_effect (Effect_aux (aux, _)) =
+  match aux with
+  | Effect_set [] -> string "pure"
+  | Effect_set effs ->
+     braces (separate (comma ^^ space) (List.map (fun be -> string (string_of_base_effect be)) effs))
+
 let rec doc_nc nc =
   let nc_op op n1 n2 = separate space [doc_nexp n1; string op; doc_nexp n2] in
   let rec atomic_nc (NC_aux (nc_aux, _) as nc) =
@@ -570,7 +576,10 @@ let doc_mapdef (MD_aux (MD_mapping (id, typa, mapcls), _)) =
 
 let doc_dec (DEC_aux (reg,_)) =
   match reg with
-  | DEC_reg (typ, id) -> separate space [string "register"; doc_id id; colon; doc_typ typ]
+  | DEC_reg (Effect_aux (Effect_set [BE_aux (BE_rreg, _)], _), Effect_aux (Effect_set [BE_aux (BE_wreg, _)], _), typ, id) ->
+     separate space [string "register"; doc_id id; colon; doc_typ typ]
+  | DEC_reg (reffect, weffect, typ, id) ->
+     separate space [string "register"; doc_effect reffect; doc_effect weffect; doc_id id; colon; doc_typ typ]
   | DEC_config (id, typ, exp) -> separate space [string "register configuration"; doc_id id; colon; doc_typ typ; equals; doc_exp exp]
   | DEC_alias(id,alspec) -> string "ALIAS"
   | DEC_typ_alias(typ,id,alspec) -> string "ALIAS"
diff --git a/src/process_file.ml b/src/process_file.ml
index 12f2b7c0..785d7a18 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -365,7 +365,7 @@ let output libpath out_arg files =
       output1 libpath out_arg f defs)
     files
 
-let rewrite_step defs (name, rewriter) =
+let rewrite_step n total defs (name, rewriter) =
   let t = Profile.start () in
   let defs = rewriter defs in
   Profile.finish ("rewrite " ^ name) t;
@@ -380,10 +380,12 @@ let rewrite_step defs (name, rewriter) =
         opt_ddump_rewrite_ast := Some (f, i + 1)
       end
     | _ -> () in
+  Util.progress "Rewrite " name n total;
   defs
 
 let rewrite rewriters defs =
-  try List.fold_left rewrite_step defs rewriters with
+  let total = List.length rewriters in
+  try snd (List.fold_left (fun (n, defs) rw -> n + 1, rewrite_step n total defs rw) (1, defs) rewriters) with
   | Type_check.Type_error (_, l, err) ->
      raise (Reporting.err_typ l (Type_error.string_of_type_error err))
 
diff --git a/src/rewriter.ml b/src/rewriter.ml
index 39b437f4..03c0e074 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -366,11 +366,20 @@ let rewrite_def rewriters d = match d with
   | DEF_scattered _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__ "DEF_scattered survived to rewriter")
 
 let rewrite_defs_base rewriters (Defs defs) =
+  let rec rewrite = function
+    | [] -> []
+    | d :: ds ->
+       let d = rewriters.rewrite_def rewriters d in
+       d :: rewrite ds
+  in
+  Defs (rewrite defs)
+
+let rewrite_defs_base_progress prefix rewriters (Defs defs) =
   let total = List.length defs in
   let rec rewrite n = function
     | [] -> []
     | d :: ds ->
-       if !Profile.opt_profile then Util.progress n total else ();
+       Util.progress (prefix ^ " ") (string_of_int n ^ "/" ^ string_of_int total) n total;
        let d = rewriters.rewrite_def rewriters d in
        d :: rewrite (n + 1) ds
   in
diff --git a/src/rewriter.mli b/src/rewriter.mli
index 9da94a99..53b892d4 100644
--- a/src/rewriter.mli
+++ b/src/rewriter.mli
@@ -70,6 +70,9 @@ val rewrite_defs : tannot defs -> tannot defs
 
 val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs
 
+(* Same as rewrite_defs base but display a progress bar when verbosity >= 1 *)
+val rewrite_defs_base_progress : string -> tannot rewriters -> tannot defs -> tannot defs
+
 val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp
 
 val rewrite_pat : tannot rewriters -> tannot pat -> tannot pat
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 88ea5304..be02a63f 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2339,7 +2339,7 @@ let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) =
 (* FIXME: other reg_dec types *)
 let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) =
   match ds with
-  | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot)
+  | DEC_reg (reffect, weffect, typ, id) -> DEC_aux (DEC_reg (reffect, weffect, rw_typ typ, id), annot)
   | DEC_config (id, typ, exp) -> DEC_aux (DEC_config (id, rw_typ typ, exp), annot)
   | _ -> assert false
 
diff --git a/src/sail.ml b/src/sail.ml
index 7bf7d135..8d095451 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -224,8 +224,8 @@ let options = Arg.align ([
     Arg.Set Rewrites.opt_dmono_continue,
     " continue despite monomorphisation errors");
   ( "-verbose",
-    Arg.Set opt_print_verbose,
-    " (debug) pretty-print the input to standard output");
+    Arg.Int (fun verbosity -> Util.opt_verbosity := verbosity),
+    " produce verbose output");
   ( "-ddump_tc_ast",
     Arg.Set opt_ddump_tc_ast,
     " (debug) dump the typechecked ast to stdout");
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index c7b93dbe..e57b1988 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -463,7 +463,7 @@ let fv_of_rd consider_var (DEC_aux (d, annot)) =
   let open Type_check in
   let env = env_of_annot annot in
   match d with
-  | DEC_reg(t, id) ->
+  | DEC_reg(_, _, t, id) ->
      let t' = Env.expand_synonyms env t in
      init_env (string_of_id id),
      Nameset.union (fv_of_typ consider_var mt mt t) (fv_of_typ consider_var mt mt t')
diff --git a/src/state.ml b/src/state.ml
index 63a07c0e..fb065440 100644
--- a/src/state.ml
+++ b/src/state.ml
@@ -69,7 +69,7 @@ let find_registers defs =
   List.fold_left
     (fun acc def ->
       match def with
-      | DEF_reg_dec (DEC_aux(DEC_reg (typ, id), (_, tannot))) ->
+      | DEF_reg_dec (DEC_aux(DEC_reg (_, _, typ, id), (_, tannot))) ->
          let env = match destruct_tannot tannot with
            | Some (env, _, _) -> env
            | _ -> Env.empty
diff --git a/src/type_check.ml b/src/type_check.ml
index 4ed234f2..7746ffee 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1511,10 +1511,21 @@ and unify_constraint l env goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as
   typ_debug (lazy (Util.("Unify constraint " |> magenta |> clear) ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2));
   match aux1, aux2 with
   | NC_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_bool nc2)
+  | NC_var v, NC_var v' when Kid.compare v v' = 0 -> KBindings.empty
   | NC_and (nc1a, nc2a), NC_and (nc1b, nc2b) | NC_or (nc1a, nc2a), NC_or (nc1b, nc2b) ->
      merge_uvars l (unify_constraint l env goals nc1a nc1b) (unify_constraint l env goals nc2a nc2b)
   | NC_app (f1, args1), NC_app (f2, args2) when Id.compare f1 f2 = 0 && List.length args1 = List.length args2 ->
      List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2)
+  | NC_equal (n1a, n2a), NC_equal (n1b, n2b) ->
+     merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
+  | NC_not_equal (n1a, n2a), NC_equal (n1b, n2b) ->
+     merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
+  | NC_bounded_ge (n1a, n2a), NC_equal (n1b, n2b) ->
+     merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
+  | NC_bounded_le (n1a, n2a), NC_equal (n1b, n2b) ->
+     merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
+  | NC_true, NC_true -> KBindings.empty
+  | NC_false, NC_false -> KBindings.empty
   | _, _ -> unify_error l ("Could not unify constraints " ^ string_of_n_constraint nc1 ^ " and " ^ string_of_n_constraint nc2)
 
 and unify_order l goals (Ord_aux (aux1, _) as ord1) (Ord_aux (aux2, _) as ord2) =
@@ -4557,9 +4568,9 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   | DEF_spec vs -> check_val_spec env vs
   | DEF_default default -> check_default env default
   | DEF_overload (id, ids) -> [DEF_overload (id, ids)], Env.add_overloads id ids env
-  | DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, _))) ->
-     let env = Env.add_register id (mk_effect [BE_rreg]) (mk_effect [BE_wreg]) typ env in
-     [DEF_reg_dec (DEC_aux (DEC_reg (typ, id), (l, mk_expected_tannot env typ no_effect (Some typ))))], env
+  | DEF_reg_dec (DEC_aux (DEC_reg (reffect, weffect, typ, id), (l, _))) ->
+     let env = Env.add_register id reffect weffect typ env in
+     [DEF_reg_dec (DEC_aux (DEC_reg (reffect, weffect, typ, id), (l, mk_expected_tannot env typ no_effect (Some typ))))], env
   | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), (l, _))) ->
      let checked_exp = crule check_exp env (strip_exp exp) typ in
      let env = Env.add_register id no_effect (mk_effect [BE_config]) typ env in
@@ -4569,14 +4580,18 @@ and check_def : 'a. Env.t -> 'a def -> (tannot def) list * Env.t =
   | DEF_reg_dec (DEC_aux (DEC_typ_alias (typ, id, aspec), (l, tannot))) -> cd_err ()
   | DEF_scattered sdef -> check_scattered env sdef
 
-and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t =
-  fun env (Defs defs) ->
+and check_defs : 'a. int -> int -> Env.t -> 'a def list -> tannot defs * Env.t =
+  fun n total env defs ->
   match defs with
-  | [] -> (Defs []), env
+  | [] -> Defs [], env
   | def :: defs ->
+     Util.progress "Type check " (string_of_int n ^ "/" ^ string_of_int total) n total;
      let (def, env) = check_def env def in
-     let (Defs defs, env) = check env (Defs defs) in
-     (Defs (def @ defs)), env
+     let Defs defs, env = check_defs (n + 1) total env defs in
+     Defs (def @ defs), env
+
+and check : 'a. Env.t -> 'a defs -> tannot defs * Env.t =
+  fun env (Defs defs) -> let total = List.length defs in check_defs 1 total env defs
 
 let initial_env =
   Env.empty
diff --git a/src/util.ml b/src/util.ml
index f9603f8e..0ff00df1 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -96,6 +96,7 @@
 
 let opt_warnings = ref true
 let opt_colors = ref true
+let opt_verbosity = ref 0
 
 let rec last = function
   | [x] -> x
@@ -466,13 +467,31 @@ let log_line str line msg =
 
 let header str n = "\n" ^ str ^ "\n" ^ String.make (String.length str - 9 * n) '='
 
-let progress n total =
-  let len = truncate ((float n /. float total) *. 50.0) in
-  let percent = truncate ((float n /. float total) *. 100.0) in
-  let str = "[" ^ String.make len '=' ^ String.make (50 - len) ' ' ^ "] " ^ string_of_int percent ^ "%" in
-  prerr_string str;
-  if n = total then
-    prerr_char '\n'
+let verbose_endline level str =
+  if level >= !opt_verbosity then
+    prerr_endline str
   else
-    prerr_string ("\x1B[" ^ string_of_int (String.length str) ^ "D");
-  flush stderr
+    ()
+
+let progress prefix msg n total =
+  if !opt_verbosity > 0 then
+    let len = truncate ((float n /. float total) *. 50.0) in
+    let percent = truncate ((float n /. float total) *. 100.0) in
+    let msg =
+      if String.length msg <= 20 then
+        msg ^ ")" ^ String.make (20 - String.length msg) ' '
+      else
+        String.sub msg 0 17 ^ "...)"
+    in
+    let str = prefix ^ "[" ^ String.make len '=' ^ String.make (50 - len) ' ' ^ "] "
+              ^ string_of_int percent ^ "%"
+              ^ " (" ^ msg
+    in
+    prerr_string str;
+    if n = total then
+      prerr_char '\n'
+    else
+      prerr_string ("\x1B[" ^ string_of_int (String.length str) ^ "D");
+    flush stderr
+  else
+    ()
diff --git a/src/util.mli b/src/util.mli
index 591cf47b..51504941 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -53,6 +53,7 @@ val last : 'a list -> 'a
 
 val opt_warnings : bool ref
 val opt_colors : bool ref
+val opt_verbosity : int ref
 
 val butlast : 'a list -> 'a list
 
@@ -264,4 +265,4 @@ val file_encode_string : string -> string
 val log_line : string -> int -> string -> string
 val header : string -> int -> string
 
-val progress : int -> int -> unit
+val progress : string -> string -> int -> int -> unit
-- 
cgit v1.2.3


From 0c94428957c9ec1d78ac0d9974253be3c750b1b1 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Mon, 14 Jan 2019 14:37:49 +0000
Subject: Make rewriting of foreach loops for Lem more robust

Bind loop bounds to type variables, and don't pull existential variables
out of context
---
 src/pretty_print_lem.ml |  6 ++----
 src/rewrites.ml         | 42 +++++++++++++++++++-----------------------
 src/type_check.ml       |  6 +++---
 3 files changed, 24 insertions(+), 30 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 1b91bb5d..822cc7b6 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -664,14 +664,12 @@ let doc_exp_lem, doc_let_lem =
             match args with
             | [exp1; exp2; exp3; ord_exp; vartuple; body] ->
                let loopvar, body = match body with
-                 | E_aux (E_let (LB_aux (LB_val (_, _), _),
-                   E_aux (E_let (LB_aux (LB_val (_, _), _),
-                   E_aux (E_if (_,
+                 | E_aux (E_if (_,
                    E_aux (E_let (LB_aux (LB_val (
                      ((P_aux (P_typ (_, P_aux (P_var (P_aux (P_id id, _), _), _)), _))
                      | (P_aux (P_var (P_aux (P_id id, _), _), _))
                      | (P_aux (P_id id, _))), _), _),
-                     body), _), _), _)), _)), _) -> id, body
+                     body), _), _), _) -> id, body
                  | _ -> raise (Reporting.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in
                let step = match ord_exp with
                  | E_aux (E_lit (L_aux (L_false, _)), _) ->
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 1ca39998..5fb1962e 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -3772,24 +3772,22 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) =
          |> mk_var_exps_pats pl env
        in
        let exp4 = rewrite_var_updates (add_vars overwrite exp4 vars) in
-       let ord_exp, kids, constr, lower, upper, lower_exp, upper_exp =
-         match destruct_numeric (Env.expand_synonyms env (typ_of exp1)), destruct_numeric (Env.expand_synonyms env (typ_of exp2)) with
-           | None, _ | _, None ->
-              raise (Reporting.err_unreachable el __POS__ "Could not determine loop bounds")
-           | Some (kids1, constr1, n1), Some (kids2, constr2, n2) ->
-              let kids = kids1 @ kids2 in
-              let constr = nc_and constr1 constr2 in
-              let ord_exp, lower, upper, lower_exp, upper_exp =
-                if is_order_inc order
-                then (annot_exp (E_lit (mk_lit L_true)) el env bool_typ, n1, n2, exp1, exp2)
-                else (annot_exp (E_lit (mk_lit L_false)) el env bool_typ, n2, n1, exp2, exp1)
-              in
-              ord_exp, kids, constr, lower, upper, lower_exp, upper_exp
-       in
        (* Bind the loop variable in the body, annotated with constraints *)
        let lvar_kid = mk_kid ("loop_" ^ string_of_id id) in
-       let lvar_nc = nc_and constr (nc_and (nc_lteq lower (nvar lvar_kid)) (nc_lteq (nvar lvar_kid) upper)) in
-       let lvar_typ = mk_typ (Typ_exist (List.map (mk_kopt K_int) (lvar_kid :: kids), lvar_nc, atom_typ (nvar lvar_kid))) in
+       let lower_id = mk_id ("loop_" ^ string_of_id id ^ "_lower") in
+       let upper_id = mk_id ("loop_" ^ string_of_id id ^ "_upper") in
+       let lower_kid = mk_kid ("loop_" ^ string_of_id id ^ "_lower") in
+       let upper_kid = mk_kid ("loop_" ^ string_of_id id ^ "_upper") in
+       let lower_id_exp = annot_exp (E_id lower_id) el env (atom_typ (nvar lower_kid)) in
+       let upper_id_exp = annot_exp (E_id upper_id) el env (atom_typ (nvar upper_kid)) in
+       let annot_bool_lit lit = annot_exp (E_lit lit) el env bool_typ in
+       let ord_exp, lower_exp, upper_exp, exp1, exp2 =
+         if is_order_inc order
+         then annot_bool_lit (mk_lit L_true),  exp1, exp2, lower_id_exp, upper_id_exp
+         else annot_bool_lit (mk_lit L_false), exp2, exp1, upper_id_exp, lower_id_exp
+       in
+       let lvar_nc = nc_and (nc_lteq (nvar lower_kid) (nvar lvar_kid)) (nc_lteq (nvar lvar_kid) (nvar upper_kid)) in
+       let lvar_typ = mk_typ (Typ_exist (List.map (mk_kopt K_int) [lvar_kid], lvar_nc, atom_typ (nvar lvar_kid))) in
        let lvar_pat = unaux_pat (add_p_typ lvar_typ (annot_pat (P_var (
          annot_pat (P_id id) el env (atom_typ (nvar lvar_kid)),
          TP_aux (TP_var lvar_kid, gen_loc el))) el env lvar_typ)) in
@@ -3805,23 +3803,21 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) =
           that would force the loop to be effectful, so we use an if-expression
           instead.  This code assumes that the loop bounds have (possibly
           existential) atom types, and the loop body has type unit. *)
-       let lower_kid = mk_kid ("loop_" ^ string_of_id id ^ "_lower") in
-       let lower_pat = P_var (annot_pat P_wild el env (typ_of lower_exp), mk_typ_pat (TP_app (mk_id "atom", [mk_typ_pat (TP_var lower_kid)]))) in
+       let lower_pat = P_var (annot_pat (P_id lower_id) el env (typ_of lower_exp), mk_typ_pat (TP_app (mk_id "atom", [mk_typ_pat (TP_var lower_kid)]))) in
        let lb_lower = annot_letbind (lower_pat, lower_exp) el env (typ_of lower_exp) in
-       let upper_kid = mk_kid ("loop_" ^ string_of_id id ^ "_upper") in
-       let upper_pat = P_var (annot_pat P_wild el env (typ_of upper_exp), mk_typ_pat (TP_app (mk_id "atom", [mk_typ_pat (TP_var upper_kid)]))) in
+       let upper_pat = P_var (annot_pat (P_id upper_id) el env (typ_of upper_exp), mk_typ_pat (TP_app (mk_id "atom", [mk_typ_pat (TP_var upper_kid)]))) in
        let lb_upper = annot_letbind (upper_pat, upper_exp) el env (typ_of upper_exp) in
        let guard = annot_exp (E_constraint (nc_lteq (nvar lower_kid) (nvar upper_kid))) el env bool_typ in
        let unit_exp = annot_exp (E_lit (mk_lit L_unit)) el env unit_typ in
        let skip_val = tuple_exp (if overwrite then vars else unit_exp :: vars) in
-       let guarded_body =
+       let guarded_body = fix_eff_exp (annot_exp (E_if (guard, body, skip_val)) el env (typ_of exp4)) in
+       let v =
          fix_eff_exp (annot_exp (E_let (lb_lower,
            fix_eff_exp (annot_exp (E_let (lb_upper,
-             fix_eff_exp (annot_exp (E_if (guard, body, skip_val))
+             fix_eff_exp (annot_exp (E_app (mk_id "foreach", [exp1; exp2; exp3; ord_exp; tuple_exp vars; guarded_body]))
                el env (typ_of exp4))))
              el env (typ_of exp4))))
            el env (typ_of exp4)) in
-       let v = fix_eff_exp (annot_exp (E_app (mk_id "foreach", [exp1; exp2; exp3; ord_exp; tuple_exp vars; guarded_body])) el env (typ_of body)) in
        Added_vars (v, tuple_pat (if overwrite then varpats else pat :: varpats))
      | E_loop(loop,cond,body) ->
         (* Find variables that might be updated in the loop body and are used
diff --git a/src/type_check.ml b/src/type_check.ml
index 9ece1e25..4ac81528 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1518,11 +1518,11 @@ and unify_constraint l env goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as
      List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2)
   | NC_equal (n1a, n2a), NC_equal (n1b, n2b) ->
      merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
-  | NC_not_equal (n1a, n2a), NC_equal (n1b, n2b) ->
+  | NC_not_equal (n1a, n2a), NC_not_equal (n1b, n2b) ->
      merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
-  | NC_bounded_ge (n1a, n2a), NC_equal (n1b, n2b) ->
+  | NC_bounded_ge (n1a, n2a), NC_bounded_ge (n1b, n2b) ->
      merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
-  | NC_bounded_le (n1a, n2a), NC_equal (n1b, n2b) ->
+  | NC_bounded_le (n1a, n2a), NC_bounded_le (n1b, n2b) ->
      merge_uvars l (unify_nexp l env goals n1a n1b) (unify_nexp l env goals n2a n2b)
   | NC_true, NC_true -> KBindings.empty
   | NC_false, NC_false -> KBindings.empty
-- 
cgit v1.2.3


From 154e822f482c63b067bfe62dbbbffc565c1cc6ba Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Mon, 14 Jan 2019 16:06:57 +0000
Subject: Support some more unification cases

---
 src/ast_util.mli  |  5 +++++
 src/type_check.ml | 26 +++++++++++++++++++++++---
 2 files changed, 28 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.mli b/src/ast_util.mli
index df7f7efb..8787dbff 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -282,6 +282,11 @@ module BE : sig
   val compare : base_effect -> base_effect -> int
 end
 
+module NC : sig
+  type t = n_constraint
+  val compare : n_constraint -> n_constraint -> int
+end
+
 (* NB: the comparison function does not expand synonyms *)
 module Typ : sig
   type t = typ
diff --git a/src/type_check.ml b/src/type_check.ml
index 4ac81528..ddd16eef 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1512,7 +1512,17 @@ and unify_constraint l env goals (NC_aux (aux1, _) as nc1) (NC_aux (aux2, _) as
   match aux1, aux2 with
   | NC_var v, _ when KidSet.mem v goals -> KBindings.singleton v (arg_bool nc2)
   | NC_var v, NC_var v' when Kid.compare v v' = 0 -> KBindings.empty
-  | NC_and (nc1a, nc2a), NC_and (nc1b, nc2b) | NC_or (nc1a, nc2a), NC_or (nc1b, nc2b) ->
+  | NC_and (nc1a, nc2a), NC_and (nc1b, nc2b) ->
+     begin
+       try
+         let conjs1 = List.sort NC.compare (constraint_conj nc1) in
+         let conjs2 = List.sort NC.compare (constraint_conj nc2) in
+         let unify_merge uv nc1 nc2 = merge_uvars l uv (unify_constraint l env goals nc1 nc2) in
+         List.fold_left2 unify_merge KBindings.empty conjs1 conjs2
+       with
+       | _ -> merge_uvars l (unify_constraint l env goals nc1a nc1b) (unify_constraint l env goals nc2a nc2b)
+     end
+  | NC_or (nc1a, nc2a), NC_or (nc1b, nc2b) ->
      merge_uvars l (unify_constraint l env goals nc1a nc1b) (unify_constraint l env goals nc2a nc2b)
   | NC_app (f1, args1), NC_app (f2, args2) when Id.compare f1 f2 = 0 && List.length args1 = List.length args2 ->
      List.fold_left (merge_uvars l) KBindings.empty (List.map2 (unify_typ_arg l env goals) args1 args2)
@@ -1562,8 +1572,18 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
        else
          if KidSet.is_empty (nexp_frees n1a)
          then unify_nexp l env goals n1b (nminus nexp2 n1a)
-         else unify_error l ("Both sides of Int expression " ^ string_of_nexp nexp1
-                             ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2)
+         else begin
+           match nexp_aux2 with
+           | Nexp_sum (n2a, n2b) ->
+              if nexp_identical n1a n2a
+              then unify_nexp l env goals n1b n2b
+              else
+                if nexp_identical n1b n2b
+                then unify_nexp l env goals n1a n2a
+                else unify_error l "Unification error"
+           | _ -> unify_error l ("Both sides of Int expression " ^ string_of_nexp nexp1
+                               ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2)
+         end
     | Nexp_minus (n1a, n1b) ->
        if KidSet.is_empty (nexp_frees n1b)
        then unify_nexp l env goals n1a (nsum nexp2 n1b)
-- 
cgit v1.2.3


From ef61b884cecc2c8ab11d7db1c1c593005be865e6 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Mon, 14 Jan 2019 21:06:01 +0000
Subject: Add a function to perform re-writes in parallel

rewrite_defs_base_parallel j is the same as rewrite_defs_base
except it performs the re-writes in j parallel processes. Currently
only the trivial_sizeof re-write is parallelised this way with a
default of 4. This works on my machine (TM) but may fail elsewhere.
Because 2019 OCaml concurrency support is lacking, we use Unix.fork
and Marshal.to_channel to send the info from the child processes
performing the re-write back to the parent.

Also fix a missing case in pretty_print_lem
---
 src/pretty_print_lem.ml |  1 +
 src/rewriter.ml         | 58 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/rewriter.mli        |  2 ++
 src/rewrites.ml         |  2 +-
 src/sail.ml             |  2 ++
 5 files changed, 64 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 822cc7b6..73c1fe8b 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1362,6 +1362,7 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) =
        else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *)
   | DEC_alias(id,alspec) -> empty
   | DEC_typ_alias(typ,id,alspec) -> empty
+  | DEC_config _ -> empty
 
 let doc_spec_lem (VS_aux (valspec,annot)) =
   match valspec with
diff --git a/src/rewriter.ml b/src/rewriter.ml
index 81fa7c29..89f64401 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -383,6 +383,64 @@ let rewrite_defs_base_progress prefix rewriters (Defs defs) =
   in
   Defs (rewrite 1 defs)
 
+let rec takedrop n xs =
+  match n, xs with
+  | 0, _ -> [], xs
+  | n, [] -> [], []
+  | n, x :: xs ->
+     let ys, xs = takedrop (n - 1) xs in
+     x :: ys, xs
+
+let rewrite_defs_base_parallel j rewriters (Defs defs) =
+  let module IntMap = Map.Make(struct type t = int let compare = compare end) in
+  let total = List.length defs in
+  let defs = ref defs in
+
+  (* We have a list of child processes in pids, and a mapping from pid
+     to result location in results. *)
+  let pids = ref [] in
+  let results = ref IntMap.empty in
+  for i = 1 to j do
+    let work = if i = 1 then total / j + total mod j else total / j in
+    let work, rest = takedrop work !defs in
+    (* Create a temporary file where the child process will return it's result *)
+    let result = Filename.temp_file "sail" ".rewrite" in
+    let pid = Unix.fork () in
+    begin
+      if pid = 0 then
+        let Defs work = rewrite_defs_base rewriters (Defs work) in
+        let out_chan = open_out result in
+        Marshal.to_channel out_chan work [Marshal.Closures];
+        close_out out_chan;
+        exit 0
+      else
+        (pids := pid :: !pids; results := IntMap.add pid result !results)
+    end;
+    defs := rest
+  done;
+  (* Make sure we haven't left any definitions behind! *)
+  assert(List.length !defs = 0);
+
+  let rewritten = ref [] in
+
+  (* Now we wait for all our child processes *)
+  while List.compare_length_with !pids 0 > 0 do
+    let child = List.hd !pids in
+    pids := List.tl !pids;
+    let _, status = Unix.waitpid [] child in
+    match status with
+    | WEXITED 0 ->
+       let result = IntMap.find child !results in
+       let in_chan = open_in result in
+       rewritten := Marshal.from_channel in_chan :: !rewritten;
+       close_in in_chan;
+       Sys.remove result
+    | _ ->
+       prerr_endline "Child process exited abnormally in parallel rewrite";
+       exit 1
+  done;
+  Defs (List.concat !rewritten)
+  
 let rewriters_base =
   {rewrite_exp = rewrite_exp;
    rewrite_pat = rewrite_pat;
diff --git a/src/rewriter.mli b/src/rewriter.mli
index 53b892d4..ec4e381c 100644
--- a/src/rewriter.mli
+++ b/src/rewriter.mli
@@ -70,6 +70,8 @@ val rewrite_defs : tannot defs -> tannot defs
 
 val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs
 
+val rewrite_defs_base_parallel : int -> tannot rewriters -> tannot defs -> tannot defs
+  
 (* Same as rewrite_defs base but display a progress bar when verbosity >= 1 *)
 val rewrite_defs_base_progress : string -> tannot rewriters -> tannot defs -> tannot defs
 
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 5fb1962e..79e8792d 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -400,7 +400,7 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
   and rewrite_e_sizeof split_sizeof =
     { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) }
   in
-  rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true
+  rewrite_defs_base_parallel 4 { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true
 
 (* Rewrite sizeof expressions with type-level variables to
    term-level expressions
diff --git a/src/sail.ml b/src/sail.ml
index 8d095451..9336dfb2 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -417,6 +417,8 @@ let main() =
            close_out chan
          end
        else ());
+
+      if !opt_memo_z3 then Constraint.save_digests () else ()
     end
 
 let _ =  try
-- 
cgit v1.2.3


From 783d4d217387274a397f7c667d368461601d3891 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 17 Jan 2019 01:06:48 +0000
Subject: Fix bug in letbind_effects rewrite

Don't wrap effectful expressions in E_internal_return
---
 src/rewrites.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 79e8792d..fdcfb71c 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2836,7 +2836,7 @@ let rewrite_defs_letbind_effects =
        rewrap (E_var (lexp,exp1,n_exp exp2 k))))
     | E_internal_return exp1 ->
        n_exp_name exp1 (fun exp1 ->
-       k (rewrap (E_internal_return exp1)))
+       k (if effectful (propagate_exp_effect exp1) then exp1 else rewrap (E_internal_return exp1)))
     | E_internal_value v ->
        k (rewrap (E_internal_value v))
     | E_return exp' ->
-- 
cgit v1.2.3


From 63fa9e0e2807e4b5fc3f825e6914a2fab5de37e3 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 17 Jan 2019 01:10:54 +0000
Subject: Output configuration registers for Lem

Treat them as constants for now (with their initial value); in order to
support updates, we would have to embed them properly into the monads.
---
 src/pretty_print_lem.ml | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 73c1fe8b..69c9b9e8 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -581,6 +581,8 @@ let doc_exp_lem, doc_let_lem =
       then wrap_parens (separate space [string "liftR"; parens (doc)])
       else wrap_parens doc in
     match e with
+    | E_assign(_, _) when has_effect (effect_of full_exp) BE_config ->
+       string "return ()" (* TODO *)
     | E_assign((LEXP_aux(le_act,tannot) as le), e) ->
        (* can only be register writes *)
        let t = typ_of_annot tannot in
@@ -825,7 +827,7 @@ let doc_exp_lem, doc_let_lem =
          if is_bitvector_typ base_typ
          then liftR (parens (align (group (prefix 0 1 epp (doc_tannot_lem ctxt env true base_typ)))))
          else liftR epp
-       else if Env.is_register id env then doc_id_lem (append_id id "_ref")
+       else if Env.is_register id env && is_regtyp (typ_of full_exp) env then doc_id_lem (append_id id "_ref")
        else if is_ctor env id then doc_id_lem_ctor id
        else doc_id_lem id
     | E_lit lit -> doc_lit_lem lit
@@ -1360,9 +1362,9 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) =
            ^/^ hardline
          else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ))
        else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *)
+  | DEC_config(id, typ, exp) -> separate space [string "let"; doc_id_lem id; equals; doc_exp_lem empty_ctxt false exp] ^^ hardline
   | DEC_alias(id,alspec) -> empty
   | DEC_typ_alias(typ,id,alspec) -> empty
-  | DEC_config _ -> empty
 
 let doc_spec_lem (VS_aux (valspec,annot)) =
   match valspec with
-- 
cgit v1.2.3


From 7ebe7fe5a37959b9004548b4287dbfc1f6faa087 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 17 Jan 2019 01:20:33 +0000
Subject: Work around an issue with type abbreviations in HOL

If we use the bitlist representation of bitvectors, the type argument in
type abbreviations such as "bits('n)" becomes dead, which confuses HOL;
as a workaround, expand type synonyms in this case.
---
 src/pretty_print.mli    |  2 +-
 src/pretty_print_lem.ml | 55 ++++++++++++++++++++++++++++---------------------
 src/process_file.ml     | 12 +++++------
 src/process_file.mli    |  2 +-
 src/sail.ml             |  4 ++--
 5 files changed, 41 insertions(+), 34 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print.mli b/src/pretty_print.mli
index 2aaf5318..5537f42c 100644
--- a/src/pretty_print.mli
+++ b/src/pretty_print.mli
@@ -52,4 +52,4 @@ open Ast
 open Type_check
 
 (* Prints on formatter the defs as Lem Ast nodes *)
-val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit
+val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> Env.t -> tannot defs -> string -> unit
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 69c9b9e8..169bd824 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -338,7 +338,14 @@ let doc_typ_lem, doc_atomic_typ_lem =
       | A_nexp n -> doc_nexp_lem (nexp_simp n)
       | A_order o -> empty
       | A_bool _ -> empty
-  in typ', atomic_typ
+  in
+  let top env ty =
+    (* If we use the bitlist representation of bitvectors, the type argument in
+       type abbreviations such as "bits('n)" becomes dead, which confuses HOL; as a
+       workaround, we expand type synonyms in this case. *)
+    let ty' = if !opt_mwords then ty else Env.expand_synonyms env ty in
+    typ' ty'
+  in top, atomic_typ
 
 (* Check for variables in types that would be pretty-printed. *)
 let contains_t_pp_var ctxt (Typ_aux (t,a) as typ) =
@@ -375,7 +382,7 @@ let doc_tannot_lem ctxt env eff typ =
   match make_printable_type ctxt env typ with
   | None -> empty
   | Some typ ->
-     let ta = doc_typ_lem typ in
+     let ta = doc_typ_lem env typ in
      if eff then string " : M " ^^ parens ta
      else string " : " ^^ ta
 
@@ -475,8 +482,8 @@ let doc_typclasses_lem t =
   if NexpSet.is_empty nexps then (empty, NexpSet.empty) else
   (separate_map comma_sp (fun nexp -> string "Size " ^^ doc_nexp_lem nexp) (NexpSet.elements nexps) ^^ string " => ", nexps)
 
-let doc_typschm_lem quants (TypSchm_aux(TypSchm_ts(tq,t),_)) =
-  let pt = doc_typ_lem t in
+let doc_typschm_lem env quants (TypSchm_aux(TypSchm_ts(tq,t),_)) =
+  let pt = doc_typ_lem env t in
   if quants
   then
     let nexps_used = lem_nexps_of_typ t in
@@ -516,7 +523,7 @@ let rec doc_pat_lem ctxt apat_needed (P_aux (p,(l,annot)) as pa) = match p with
     let doc_p = doc_pat_lem ctxt true p in
     (match make_printable_type ctxt (env_of_annot (l,annot)) typ with
     | None -> doc_p
-    | Some typ -> parens (doc_op colon doc_p (doc_typ_lem typ)))
+    | Some typ -> parens (doc_op colon doc_p (doc_typ_lem (env_of_annot (l,annot)) typ)))
   | P_vector pats ->
      let ppp = brackets (separate_map semi (doc_pat_lem ctxt true) pats) in
      if apat_needed then parens ppp else ppp
@@ -950,8 +957,8 @@ let doc_exp_lem, doc_let_lem =
        | Some full_typ, Some r_typ ->
           separate space
             [string ": MR";
-            parens (doc_typ_lem full_typ);
-            parens (doc_typ_lem r_typ)]
+            parens (doc_typ_lem (env_of full_exp) full_typ);
+            parens (doc_typ_lem (env_of r) r_typ)]
        | _ -> empty
       in
       align (parens (string "early_return" ^//^ expV true r ^//^ ta))
@@ -1005,28 +1012,28 @@ let doc_exp_lem, doc_let_lem =
   in top_exp, let_exp
 
 (*TODO Upcase and downcase type and constructors as needed*)
-let doc_type_union_lem (Tu_aux(Tu_ty_id(typ,id),_)) =
+let doc_type_union_lem env (Tu_aux(Tu_ty_id(typ,id),_)) =
   separate space [pipe; doc_id_lem_ctor id; string "of";
-                  parens (doc_typ_lem typ)]
+                  parens (doc_typ_lem env typ)]
 
 let rec doc_range_lem (BF_aux(r,_)) = match r with
   | BF_single i -> parens (doc_op comma (doc_int i) (doc_int i))
   | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2))
   | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2)
 
-let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with
+let doc_typdef_lem env (TD_aux(td, (l, annot))) = match td with
   | TD_abbrev(id,typq,A_aux (A_typ typ, _)) ->
      let typschm = TypSchm_aux (TypSchm_ts (typq, typ), l) in
      doc_op equals
        (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq])
-       (doc_typschm_lem false typschm)
+       (doc_typschm_lem env false typschm)
   | TD_abbrev _ -> empty
   | TD_record(id,typq,fs,_) ->
     let fname fid = if prefix_recordtype && string_of_id id <> "regstate"
                     then concat [doc_id_lem id;string "_";doc_id_lem_type fid;]
                     else doc_id_lem_type fid in
     let f_pp (typ,fid) =
-      concat [fname fid;space;colon;space;doc_typ_lem typ; semi] in
+      concat [fname fid;space;colon;space;doc_typ_lem env typ; semi] in
     let rectyp = match typq with
       | TypQ_aux (TypQ_tq qs, _) ->
         let quant_item = function
@@ -1085,7 +1092,7 @@ let doc_typdef_lem (TD_aux(td, (l, annot))) = match td with
       | Id_aux ((Id "diafp"),_) -> empty *)
       | Id_aux ((Id "option"),_) -> empty
       | _ ->
-         let ar_doc = group (separate_map (break 1) doc_type_union_lem ar) in
+         let ar_doc = group (separate_map (break 1) (doc_type_union_lem env) ar) in
          let typ_pp =
            (doc_op equals)
              (concat [string "type"; space; doc_id_lem_type id; space; doc_typquant_items_lem None typq])
@@ -1270,8 +1277,8 @@ let rec untuple_args_pat (P_aux (paux, ((l, _) as annot)) as pat) arg_typs =
   | _, _ ->
      [pat], identity
 
-let doc_tannot_opt_lem (Typ_annot_opt_aux(t,_)) = match t with
-  | Typ_annot_opt_some(tq,typ) -> (*doc_typquant_lem tq*) (doc_typ_lem typ)
+let doc_tannot_opt_lem env (Typ_annot_opt_aux(t,_)) = match t with
+  | Typ_annot_opt_some(tq,typ) -> (*doc_typquant_lem tq*) (doc_typ_lem env typ)
   | Typ_annot_opt_none -> empty
 
 let doc_fun_body_lem ctxt exp =
@@ -1366,13 +1373,13 @@ let doc_dec_lem (DEC_aux (reg, ((l, _) as annot))) =
   | DEC_alias(id,alspec) -> empty
   | DEC_typ_alias(typ,id,alspec) -> empty
 
-let doc_spec_lem (VS_aux (valspec,annot)) =
+let doc_spec_lem env (VS_aux (valspec,annot)) =
   match valspec with
   | VS_val_spec (typschm,id,ext,_) when ext "lem" = None ->
      (* let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in
      if contains_t_pp_var typ then empty else *)
      doc_docstring_lem annot ^^
-     separate space [string "val"; doc_id_lem id; string ":";doc_typschm_lem true typschm] ^/^ hardline 
+     separate space [string "val"; doc_id_lem id; string ":";doc_typschm_lem env true typschm] ^/^ hardline
   (* | VS_val_spec (_,_,Some _,_) -> empty *)
   | _ -> empty
 
@@ -1419,13 +1426,13 @@ let doc_regtype_fields (tname, (n1, n2, fields)) =
   in
   separate_map hardline doc_field fields
 
-let rec doc_def_lem def =
+let rec doc_def_lem type_env def =
   (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *)
   match def with
-  | DEF_spec v_spec -> doc_spec_lem v_spec
+  | DEF_spec v_spec -> doc_spec_lem type_env v_spec
   | DEF_fixity _ -> empty
   | DEF_overload _ -> empty
-  | DEF_type t_def -> group (doc_typdef_lem t_def) ^/^ hardline
+  | DEF_type t_def -> group (doc_typdef_lem type_env t_def) ^/^ hardline
   | DEF_reg_dec dec -> group (doc_dec_lem dec)
 
   | DEF_default df -> empty
@@ -1444,7 +1451,7 @@ let find_exc_typ defs =
     | _ -> false in
   if List.exists is_exc_typ_def defs then "exception" else "unit"
 
-let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) (Defs defs) top_line =
+let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) type_env (Defs defs) top_line =
   (* let regtypes = find_regtypes d in *)
   let state_ids =
     State.generate_regstate_defs !opt_mwords defs
@@ -1480,9 +1487,9 @@ let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) (Defs defs)
              string "module SIA = Interp_ast"; hardline;
              hardline]
         else empty;
-        separate empty (List.map doc_def_lem typdefs); hardline;
+        separate empty (List.map (doc_def_lem type_env) typdefs); hardline;
         hardline;
-        separate empty (List.map doc_def_lem statedefs); hardline;
+        separate empty (List.map (doc_def_lem type_env) statedefs); hardline;
         hardline;
         register_refs; hardline;
         concat [
@@ -1496,5 +1503,5 @@ let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) (Defs defs)
         (separate_map hardline)
           (fun lib -> separate space [string "open import";string lib]) defs_modules;hardline;
         hardline;
-        separate empty (List.map doc_def_lem defs);
+        separate empty (List.map (doc_def_lem type_env) defs);
         hardline]);
diff --git a/src/process_file.ml b/src/process_file.ml
index 785d7a18..ed34238b 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -275,7 +275,7 @@ let close_output_with_check (o, temp_file_name, file_name) =
 let generated_line f =
   Printf.sprintf "Generated by Sail from %s." f
 
-let output_lem filename libs defs =
+let output_lem filename libs type_env defs =
   let generated_line = generated_line filename in
   (* let seq_suffix = if !Pretty_print_lem.opt_sequential then "_sequential" else "" in *)
   let types_module = (filename ^ "_types") in
@@ -315,7 +315,7 @@ let output_lem filename libs defs =
   (Pretty_print.pp_defs_lem
      (ot, base_imports)
      (o, base_imports @ (String.capitalize_ascii types_module :: libs))
-     defs generated_line);
+     type_env defs generated_line);
   close_output_with_check ext_ot;
   close_output_with_check ext_o;
   let ((ol, _, _) as ext_ol) =
@@ -351,18 +351,18 @@ let rec iterate (f : int -> unit) (n : int) : unit =
   if n = 0 then ()
   else (f n; iterate f (n - 1))
 
-let output1 libpath out_arg filename defs  =
+let output1 libpath out_arg filename type_env defs  =
   let f' = Filename.basename (Filename.chop_extension filename) in
   match out_arg with
   | Lem_out libs ->
-     output_lem f' libs defs
+     output_lem f' libs type_env defs
   | Coq_out libs ->
      output_coq f' libs defs
 
 let output libpath out_arg files =
   List.iter
-    (fun (f, defs) ->
-      output1 libpath out_arg f defs)
+    (fun (f, type_env, defs) ->
+      output1 libpath out_arg f type_env defs)
     files
 
 let rewrite_step n total defs (name, rewriter) =
diff --git a/src/process_file.mli b/src/process_file.mli
index 1d4d629a..181443fb 100644
--- a/src/process_file.mli
+++ b/src/process_file.mli
@@ -78,7 +78,7 @@ type out_type =
 val output :
   string ->                           (* The path to the library *)
   out_type ->                         (* Backend kind *)
-  (string * Type_check.tannot Ast.defs) list -> (*File names paired with definitions *)
+  (string * Type_check.Env.t * Type_check.tannot Ast.defs) list -> (*File names paired with definitions *)
   unit
 
 (** [always_replace_files] determines whether Sail only updates modified files.
diff --git a/src/sail.ml b/src/sail.ml
index 9336dfb2..6e5e7556 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -390,13 +390,13 @@ let main() =
          let mwords = !Pretty_print_lem.opt_mwords in
          let type_envs, ast_lem = State.add_regstate_defs mwords type_envs ast in
          let ast_lem = rewrite_ast_lem ast_lem in
-         output "" (Lem_out (!opt_libs_lem)) [out_name,ast_lem]
+         output "" (Lem_out (!opt_libs_lem)) [out_name,type_envs,ast_lem]
        else ());
       (if !(opt_print_coq)
        then
          let type_envs, ast_coq = State.add_regstate_defs true type_envs ast in
          let ast_coq = rewrite_ast_coq ast_coq in
-         output "" (Coq_out (!opt_libs_coq)) [out_name,ast_coq]
+         output "" (Coq_out (!opt_libs_coq)) [out_name,type_envs,ast_coq]
        else ());
       (if !(opt_print_latex)
        then
-- 
cgit v1.2.3


From 8883d3a5a516e65825ad844a8b985f8be79f4f89 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Wed, 23 Jan 2019 14:28:31 +0000
Subject: Add another flow-typing case for E_internal_plet

Copied from a corresponding case for E_block, so that this flow typing
still gets picked up after E_block has been rewritten away.
---
 src/type_check.ml | 7 +++++++
 1 file changed, 7 insertions(+)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index ddd16eef..11d5e6a0 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2466,6 +2466,13 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
                Env.add_constraint nc env
             | None -> env
           end
+       | E_aux (E_if (cond, e_t, e_e), _) ->
+          begin
+            match unaux_exp (fst (uncast_exp e_t)) with
+            | E_throw _ | E_block [E_aux (E_throw _, _)] ->
+               add_opt_constraint (option_map nc_not (assert_constraint env false cond)) env
+            | _ -> env
+          end
        | _ -> env in
      let checked_body = crule check_exp env body typ in
      annot_exp (E_internal_plet (tpat, bind_exp, checked_body)) typ
-- 
cgit v1.2.3


From 69fec085c3c35f4834c28b92f418afa7960ca969 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Wed, 23 Jan 2019 14:49:05 +0000
Subject: Make rewriting of E_assign a bit more robust

---
 src/rewrites.ml | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index fdcfb71c..39f753ef 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -3887,12 +3887,10 @@ let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) =
          let v = fix_eff_exp (annot_exp expaux pl env typ) in
          Added_vars (v, tuple_pat (if overwrite then varpats else pat :: varpats))
     | E_assign (lexp,vexp) ->
-       let mk_id_pat id = match Env.lookup_id id env with
-         | Local (_, typ) ->
-            add_p_typ typ (annot_pat (P_id id) pl env typ)
-         | _ ->
-            raise (Reporting.err_unreachable pl __POS__
-              ("Failed to look up type of variable " ^ string_of_id id)) in
+       let mk_id_pat id =
+         let typ = lvar_typ (Env.lookup_id id env) in
+         add_p_typ typ (annot_pat (P_id id) pl env typ)
+       in
        if effectful exp then
          Same_vars (E_aux (E_assign (lexp,vexp),annot))
        else 
-- 
cgit v1.2.3


From 04f95f5bac9401c84fd401bd130d9e19b34c2a5c Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Thu, 24 Jan 2019 14:48:31 +0000
Subject: Make recheck_defs_without_effects restore old flag properly

---
 src/rewrites.ml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 39f753ef..19ec6db7 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -4966,9 +4966,10 @@ let rewrite_explicit_measure (Defs defs) =
 
 let recheck_defs defs = fst (Type_error.check initial_env defs)
 let recheck_defs_without_effects defs =
+  let old = !opt_no_effects in
   let () = opt_no_effects := true in
   let result,_ = Type_error.check initial_env defs in
-  let () = opt_no_effects := false in
+  let () = opt_no_effects := old in
   result
 
 let remove_mapping_valspecs (Defs defs) =
-- 
cgit v1.2.3


From 9fffbae81148b2e4c65017d79fde20102c19a3b5 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Thu, 24 Jan 2019 14:57:28 +0000
Subject: Start supporting informative bool types in Coq backend

---
 src/pretty_print_coq.ml | 318 ++++++++++++++++++++++++++++++------------------
 src/type_check.mli      |   2 +
 2 files changed, 201 insertions(+), 119 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index 802957c6..d54b2264 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -84,7 +84,7 @@ type context = {
   kid_renames : kid KBindings.t; (* Plain tyvar -> tyvar renames *)
   kid_id_renames : id KBindings.t; (* tyvar -> argument renames *)
   bound_nvars : KidSet.t;
-  build_ex_return : bool;
+  build_at_return : string option;
   recursive_ids : IdSet.t;
   debug : bool;
 }
@@ -93,7 +93,7 @@ let empty_ctxt = {
   kid_renames = KBindings.empty;
   kid_id_renames = KBindings.empty;
   bound_nvars = KidSet.empty;
-  build_ex_return = false;
+  build_at_return = None;
   recursive_ids = IdSet.empty;
   debug = false;
 }
@@ -272,6 +272,27 @@ let rec orig_nexp (Nexp_aux (nexp, l)) =
   | Nexp_neg n -> rewrap (Nexp_neg (orig_nexp n))
   | _ -> rewrap nexp
 
+let rec orig_nc (NC_aux (nc, l) as full_nc) =
+  let rewrap nc = NC_aux (nc, l) in
+  match nc with
+  | NC_equal (nexp1, nexp2) -> rewrap (NC_equal (orig_nexp nexp1, orig_nexp nexp2))
+  | NC_bounded_ge (nexp1, nexp2) -> rewrap (NC_bounded_ge (orig_nexp nexp1, orig_nexp nexp2))
+  | NC_bounded_le (nexp1, nexp2) -> rewrap (NC_bounded_le (orig_nexp nexp1, orig_nexp nexp2))
+  | NC_not_equal (nexp1, nexp2) -> rewrap (NC_not_equal (orig_nexp nexp1, orig_nexp nexp2))
+  | NC_set (kid,s) -> rewrap (NC_set (orig_kid kid, s))
+  | NC_or (nc1, nc2) -> rewrap (NC_or (orig_nc nc1, orig_nc nc2))
+  | NC_and (nc1, nc2) -> rewrap (NC_and (orig_nc nc1, orig_nc nc2))
+  | NC_app (f,args) -> rewrap (NC_app (f,List.map orig_typ_arg args))
+  | NC_var kid -> rewrap (NC_var (orig_kid kid))
+  | NC_true | NC_false -> full_nc
+and orig_typ_arg (A_aux (arg,l)) =
+  let rewrap a = (A_aux (a,l)) in
+  match arg with
+  | A_nexp nexp -> rewrap (A_nexp (orig_nexp nexp))
+  | A_bool nc -> rewrap (A_bool (orig_nc nc))
+  | A_order _ | A_typ _ ->
+       raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function")
+
 (* Returns the set of type variables that will appear in the Coq output,
    which may be smaller than those in the Sail type.  May need to be
    updated with doc_typ *)
@@ -289,6 +310,7 @@ let rec coq_nvars_of_typ (Typ_aux (t,l)) =
   | Typ_app(Id_aux (Id "implicit", _),_)
   (* TODO: update when complex atom types are sorted out *)
   | Typ_app(Id_aux (Id "atom", _), _) -> KidSet.empty
+  | Typ_app(Id_aux (Id "atom_bool", _), _) -> KidSet.empty
   | Typ_app (_,tas) ->
      List.fold_left (fun s ta -> KidSet.union s (coq_nvars_of_typ_arg ta))
        KidSet.empty tas
@@ -301,71 +323,7 @@ and coq_nvars_of_typ_arg (A_aux (ta,_)) =
   | A_nexp nexp -> tyvars_of_nexp (orig_nexp nexp)
   | A_typ typ -> coq_nvars_of_typ typ
   | A_order _ -> KidSet.empty
-
-(* Follows Coq precedence levels *)
-let rec doc_nc_prop ctx nc =
-  let rec l85 (NC_aux (nc,_) as nc_full) =
-  match nc with
-  | NC_or (nc1, nc2) -> doc_op (string "\\/") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2)
-  | _ -> l80 nc_full
-  and l80 (NC_aux (nc,_) as nc_full) =
-  match nc with
-  | NC_and (nc1, nc2) -> doc_op (string "/\\") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2)
-  | _ -> l70 nc_full
-  and l70 (NC_aux (nc,_) as nc_full) =
-  match nc with
-  | NC_equal (ne1, ne2) -> doc_op equals (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-  | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-  | NC_bounded_le (ne1, ne2) -> doc_op (string "<=") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-  | NC_not_equal (ne1, ne2) -> doc_op (string "<>") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-  | _ -> l10 nc_full
-  and l10 (NC_aux (nc,_) as nc_full) =
-  match nc with
-  | NC_set (kid, is) ->
-     separate space [string "In"; doc_var ctx kid;
-                     brackets (separate (string "; ")
-                                 (List.map (fun i -> string (Nat_big_num.to_string i)) is))]
-  | NC_true -> string "True"
-  | NC_false -> string "False"
-  | NC_or _
-  | NC_and _
-  | NC_equal _
-  | NC_bounded_ge _
-  | NC_bounded_le _
-  | NC_not_equal _ -> parens (l85 nc_full)
-  in l85 nc
-
-(* Follows Coq precedence levels *)
-let doc_nc_exp ctx nc =
-  let rec l70 (NC_aux (nc,_) as nc_full) =
-    match nc with
-    | NC_equal (ne1, ne2) -> doc_op (string "=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-    | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-    | NC_bounded_le (ne1, ne2) -> doc_op (string "<=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
-    | _ -> l50 nc_full
-  and l50 (NC_aux (nc,_) as nc_full) =
-    match nc with
-    | NC_or (nc1, nc2) -> doc_op (string "||") (l50 nc1) (l40 nc2)
-    | _ -> l40 nc_full
-  and l40 (NC_aux (nc,_) as nc_full) =
-    match nc with
-    | NC_and (nc1, nc2) -> doc_op (string "&&") (l40 nc1) (l10 nc2)
-    | _ -> l10 nc_full
-  and l10 (NC_aux (nc,_) as nc_full) =
-    match nc with
-    | NC_not_equal (ne1, ne2) -> string "negb" ^^ space ^^ parens (doc_op (string "=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2))
-    | NC_set (kid, is) ->
-       separate space [string "member_Z_list"; doc_var ctx kid;
-                       brackets (separate (string "; ")
-                                   (List.map (fun i -> string (Nat_big_num.to_string i)) is))]
-    | NC_true -> string "true"
-    | NC_false -> string "false"
-    | NC_equal _
-    | NC_bounded_ge _
-    | NC_bounded_le _
-    | NC_or _
-    | NC_and _ -> parens (l70 nc_full)
-  in l70 nc
+  | A_bool nc -> tyvars_of_constraint (orig_nc nc)
 
 let maybe_expand_range_type (Typ_aux (typ,l) as full_typ) =
   match typ with
@@ -385,18 +343,6 @@ let maybe_expand_range_type (Typ_aux (typ,l) as full_typ) =
 
 let expand_range_type typ = Util.option_default typ (maybe_expand_range_type typ)
 
-let doc_arithfact ctxt ?(exists = []) ?extra nc =
-  let prop = doc_nc_prop ctxt nc in
-  let prop = match extra with
-    | None -> prop
-    | Some pp -> separate space [pp; string "/\\"; prop]
-  in
-  let prop =
-    match exists with
-    | [] -> prop
-    | _ -> separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop])
-  in
-  string "ArithFact" ^^ space ^^ parens prop
 
 let nice_and nc1 nc2 =
 match nc1, nc2 with
@@ -404,9 +350,20 @@ match nc1, nc2 with
 | _, NC_aux (NC_true,_) -> nc1
 | _,_ -> nc_and nc1 nc2
 
+(* n_constraint functions are currently just Z3 functions *)
+let doc_nc_fn_prop id =
+  match string_of_id id with
+  | "not" -> string "not"
+  | s -> string s
+
+(* n_constraint functions are currently just Z3 functions *)
+let doc_nc_fn id =
+  match string_of_id id with
+  | "not" -> string "negb"
+  | s -> string s
+
 (* When making changes here, check whether they affect coq_nvars_of_typ *)
-let doc_typ, doc_atomic_typ =
-  let fns ctx =
+let rec doc_typ_fns ctx =
   (* following the structure of parser for precedence *)
   let rec typ ty = fn_typ true ty
     and typ' ty = fn_typ false ty
@@ -448,6 +405,10 @@ let doc_typ, doc_atomic_typ =
          (string "Z")
       | Typ_app(Id_aux (Id "atom", _), [A_aux(A_nexp n,_)]) ->
          (string "Z")
+      | Typ_app(Id_aux (Id "atom_bool", _), [_]) -> string "bool"
+      | Typ_app (Id_aux (Id "atom#bool",_), [A_aux (A_bool nc,_)]) ->
+         let tpp = string "Bool" ^^ space ^^ doc_nc_prop ~top:false ctx nc in
+         if atyp_needed then parens tpp else tpp
       | Typ_app(id,args) ->
          let tpp = (doc_id_type id) ^^ space ^^ (separate_map space doc_typ_arg args) in
          if atyp_needed then parens tpp else tpp
@@ -536,8 +497,106 @@ let doc_typ, doc_atomic_typ =
       | A_typ t -> app_typ true t
       | A_nexp n -> doc_nexp ctx n
       | A_order o -> empty
-  in typ', atomic_typ
-  in (fun ctx -> (fst (fns ctx))), (fun ctx -> (snd (fns ctx)))
+      | A_bool nc -> doc_nc_prop ~top:false ctx nc
+  in typ', atomic_typ, doc_typ_arg
+and doc_typ ctx = let f,_,_ = doc_typ_fns ctx in f
+and doc_atomic_typ ctx = let _,f,_ = doc_typ_fns ctx in f
+and doc_typ_arg ctx = let _,_,f = doc_typ_fns ctx in f
+
+and doc_arithfact ctxt ?(exists = []) ?extra nc =
+  let prop = doc_nc_prop ctxt nc in
+  let prop = match extra with
+    | None -> prop
+    | Some pp -> separate space [pp; string "/\\"; prop]
+  in
+  let prop =
+    match exists with
+    | [] -> prop
+    | _ -> separate space ([string "exists"]@(List.map (doc_var ctxt) exists)@[comma; prop])
+  in
+  string "ArithFact" ^^ space ^^ parens prop
+
+(* Follows Coq precedence levels *)
+and doc_nc_prop ?(top = true) ctx nc =
+  let rec l85 (NC_aux (nc,_) as nc_full) =
+  match nc with
+  | NC_or (nc1, nc2) -> doc_op (string "\\/") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2)
+  | _ -> l80 nc_full
+  and l80 (NC_aux (nc,_) as nc_full) =
+  match nc with
+  | NC_and (nc1, nc2) -> doc_op (string "/\\") (doc_nc_prop ctx nc1) (doc_nc_prop ctx nc2)
+  | _ -> l70 nc_full
+  and l70 (NC_aux (nc,_) as nc_full) =
+  match nc with
+  | NC_equal (ne1, ne2) -> doc_op equals (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+  | NC_var kid -> doc_op equals (doc_nexp ctx (nvar kid)) (string "true")
+  | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+  | NC_bounded_le (ne1, ne2) -> doc_op (string "<=") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+  | NC_not_equal (ne1, ne2) -> doc_op (string "<>") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+  | _ -> l10 nc_full
+  and l10 (NC_aux (nc,_) as nc_full) =
+  match nc with
+  | NC_set (kid, is) ->
+     separate space [string "In"; doc_var ctx kid;
+                     brackets (separate (string "; ")
+                                 (List.map (fun i -> string (Nat_big_num.to_string i)) is))]
+  | NC_app (f,args) -> separate space (doc_nc_fn_prop f::List.map (doc_typ_arg ctx) args)
+  | _ -> l0 nc_full
+  and l0 (NC_aux (nc,_) as nc_full) =
+  match nc with
+  | NC_true -> string "True"
+  | NC_false -> string "False"
+  | NC_set _
+  | NC_app _
+  | NC_var _
+  | NC_or _
+  | NC_and _
+  | NC_equal _
+  | NC_bounded_ge _
+  | NC_bounded_le _
+  | NC_not_equal _ -> parens (l85 nc_full)
+  in if top then l85 nc else l0 nc
+
+(* Follows Coq precedence levels *)
+let rec doc_nc_exp ctx env nc =
+  let nc = Env.expand_constraint_synonyms env nc in
+  let rec l70 (NC_aux (nc,_) as nc_full) =
+    match nc with
+    | NC_equal (ne1, ne2) -> doc_op (string "=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+    | NC_bounded_ge (ne1, ne2) -> doc_op (string ">=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+    | NC_bounded_le (ne1, ne2) -> doc_op (string "<=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2)
+    | _ -> l50 nc_full
+  and l50 (NC_aux (nc,_) as nc_full) =
+    match nc with
+    | NC_or (nc1, nc2) -> doc_op (string "||") (l50 nc1) (l40 nc2)
+    | _ -> l40 nc_full
+  and l40 (NC_aux (nc,_) as nc_full) =
+    match nc with
+    | NC_and (nc1, nc2) -> doc_op (string "&&") (l40 nc1) (l10 nc2)
+    | _ -> l10 nc_full
+  and l10 (NC_aux (nc,_) as nc_full) =
+    match nc with
+    | NC_not_equal (ne1, ne2) -> string "negb" ^^ space ^^ parens (doc_op (string "=?") (doc_nexp ctx ne1) (doc_nexp ctx ne2))
+    | NC_set (kid, is) ->
+       separate space [string "member_Z_list"; doc_var ctx kid;
+                       brackets (separate (string "; ")
+                                   (List.map (fun i -> string (Nat_big_num.to_string i)) is))]
+    | NC_true -> string "true"
+    | NC_false -> string "false"
+    | NC_app (f,args) -> separate space (doc_nc_fn f::List.map (doc_typ_arg_exp ctx env) args)
+    | NC_var kid -> doc_nexp ctx (nvar kid)
+    | NC_equal _
+    | NC_bounded_ge _
+    | NC_bounded_le _
+    | NC_or _
+    | NC_and _ -> parens (l70 nc_full)
+  in l70 nc
+and doc_typ_arg_exp ctx env (A_aux (arg,l)) =
+  match arg with
+  | A_nexp nexp -> doc_nexp ctx nexp
+  | A_bool nc -> doc_nc_exp ctx env nc
+  | A_order _ | A_typ _ ->
+       raise (Reporting.err_unreachable l __POS__ "Tried to pass Type or Order kind to SMT function")
 
 (* Check for variables in types that would be pretty-printed and are not
    bound in the val spec of the function. *)
@@ -619,6 +678,7 @@ let doc_quant_item_id ctx delimit (QI_aux (qi,_)) =
     | K_type -> Some (delimit (separate space [doc_var ctx kid; colon; string "Type"]))
     | K_int -> Some (delimit (separate space [doc_var ctx kid; colon; string "Z"]))
     | K_order -> None
+    | K_bool -> Some (delimit (separate space [doc_var ctx kid; colon; string "bool"]))
   end
   | QI_const nc -> None
 
@@ -630,6 +690,7 @@ let quant_item_id_name ctx (QI_aux (qi,_)) =
     | K_type -> Some (doc_var ctx kid)
     | K_int -> Some (doc_var ctx kid)
     | K_order -> None
+    | K_bool -> Some (doc_var ctx kid)
   end
   | QI_const nc -> None
 
@@ -888,13 +949,15 @@ let condition_produces_constraint exp =
    dependent pair with a proof that the result is the expected integer.  This
    is redundant for basic arithmetic functions and functions which we unfold
    in the constraint solver. *)
-let no_Z_proof_fns = ["Z.add"; "Z.sub"; "Z.opp"; "Z.mul"; "length_mword"; "length"]
+let no_proof_fns = ["Z.add"; "Z.sub"; "Z.opp"; "Z.mul"; "length_mword"; "length";
+                      "negb"; "andb"; "orb";
+                      "Z.leb"; "Z.geb"; "Z.ltb"; "Z.gtb"; "Z.eqb"]
 
-let is_no_Z_proof_fn env id =
+let is_no_proof_fn env id =
   if Env.is_extern id env "coq"
   then
     let s = Env.get_extern id env "coq" in
-    List.exists (fun x -> String.compare x s == 0) no_Z_proof_fns
+    List.exists (fun x -> String.compare x s == 0) no_proof_fns
   else false
 
 let replace_atom_return_type ret_typ =
@@ -902,8 +965,12 @@ let replace_atom_return_type ret_typ =
   match ret_typ with
   | Typ_aux (Typ_app (Id_aux (Id "atom",_), [A_aux (A_nexp nexp,_)]),l) ->
      let kid = mk_kid "_retval" in (* TODO: collision avoidance *)
-     true, Typ_aux (Typ_exist ([mk_kopt K_int kid], nc_eq (nvar kid) nexp, atom_typ (nvar kid)),Parse_ast.Generated l)
-  | _ -> false, ret_typ
+     Some "build_ex", Typ_aux (Typ_exist ([mk_kopt K_int kid], nc_eq (nvar kid) nexp, atom_typ (nvar kid)),Parse_ast.Generated l)
+  (* For informative booleans tweak the type name so that doc_typ knows that the
+     constraint should be output. *)
+  | Typ_aux (Typ_app (Id_aux (Id "atom_bool",il), ([A_aux (A_bool _,_)] as args)),l) ->
+     Some "build_Bool", Typ_aux (Typ_app (Id_aux (Id "atom#bool",il), args),l)
+  | _ -> None, ret_typ
 
 let is_range_from_atom env (Typ_aux (argty,_)) (Typ_aux (fnty,_)) =
   match argty, fnty with
@@ -1083,14 +1150,12 @@ let doc_exp, doc_let =
             match args with
             | [from_exp; to_exp; step_exp; ord_exp; vartuple; body] ->
                let loopvar, body = match body with
-                 | E_aux (E_let (LB_aux (LB_val (_, _), _),
-                   E_aux (E_let (LB_aux (LB_val (_, _), _),
-                   E_aux (E_if (_,
+                 | E_aux (E_if (_,
                    E_aux (E_let (LB_aux (LB_val (
                      ((P_aux (P_typ (_, P_aux (P_var (P_aux (P_id id, _), _), _)), _))
                      | (P_aux (P_var (P_aux (P_id id, _), _), _))
                      | (P_aux (P_id id, _))), _), _),
-                     body), _), _), _)), _)), _) -> id, body
+                     body), _), _), _) -> id, body
                  | _ -> raise (Reporting.err_unreachable l __POS__ ("Unable to find loop variable in " ^ string_of_exp body)) in
                let dir = match ord_exp with
                  | E_aux (E_lit (L_aux (L_false, _)), _) -> "_down"
@@ -1169,9 +1234,9 @@ let doc_exp, doc_let =
             match args with
             | [exp] ->
                let exp_pp =
-                 if ctxt.build_ex_return
-                 then parens (string "build_ex" ^/^ expY exp)
-                 else expY exp
+                 match ctxt.build_at_return with
+                 | Some s -> parens (string s ^/^ expY exp)
+                 | None -> expY exp
                in
                let epp = separate space [string "early_return"; exp_pp] in
                let aexp_needed, tepp =
@@ -1307,12 +1372,12 @@ let doc_exp, doc_let =
           let ret_typ_inst =
                subst_unifiers inst ret_typ
           in
-          let packeff,unpack,autocast =
+          let packeff,unpack,autocast,projbool =
             let ann_typ = Env.expand_synonyms env (general_typ_of_annot (l,annot)) in
             let ann_typ = expand_range_type ann_typ in
             let ret_typ_inst = expand_range_type (Env.expand_synonyms env ret_typ_inst) in
             let ret_typ_inst =
-              if is_no_Z_proof_fn env f then ret_typ_inst
+              if is_no_proof_fn env f then ret_typ_inst
               else snd (replace_atom_return_type ret_typ_inst) in
             let () = 
               debug ctxt (lazy (" type returned " ^ string_of_typ ret_typ_inst));
@@ -1336,13 +1401,19 @@ let doc_exp, doc_let =
                 Typ_aux (Typ_app (_,[A_aux (A_nexp n2,_);_;_]),_) ->
                  not (similar_nexps ctxt env n1 n2)
               | _ -> false
-            in pack,unpack,autocast
+            in
+            let projbool =
+              match in_typ with
+              | Typ_aux (Typ_app (Id_aux (Id "atom#bool",_),_),_) -> true
+              | _ -> false
+            in pack,unpack,autocast,projbool
           in
           let autocast_id, proj_id =
             if effectful eff
             then "autocast_m", "projT1_m"
             else "autocast",   "projT1" in
           let epp = if unpack && not (effectful eff) then string proj_id ^^ space ^^ parens epp else epp in
+          let epp = if projbool && not (effectful eff) then string "projBool" ^^ space ^^ parens epp else epp in
           let epp = if autocast then string autocast_id ^^ space ^^ parens epp else epp in
           let epp =
             if effectful eff && packeff && not unpack
@@ -1665,9 +1736,9 @@ let doc_exp, doc_let =
     | E_return r ->
       let ret_monad = " : MR" in
       let exp_pp =
-        if ctxt.build_ex_return
-        then parens (string "build_ex" ^/^ expY r)
-        else expY r
+        match ctxt.build_at_return with
+        | Some s -> parens (string s ^/^ expY r)
+        | None -> expY r
       in
       let ta =
         if contains_t_pp_var ctxt (typ_of full_exp) || contains_t_pp_var ctxt (typ_of r)
@@ -1677,7 +1748,7 @@ let doc_exp, doc_let =
           parens (doc_typ ctxt (typ_of full_exp));
           parens (doc_typ ctxt (typ_of r))] in
       align (parens (string "early_return" ^//^ exp_pp ^//^ ta))
-    | E_constraint nc -> wrap_parens (doc_nc_exp ctxt nc)
+    | E_constraint nc -> wrap_parens (doc_nc_exp ctxt (env_of full_exp) nc)
     | E_internal_value _ ->
       raise (Reporting.err_unreachable l __POS__
         "unsupported internal expression encountered while pretty-printing")
@@ -1818,6 +1889,8 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
                         doc_typquant_items empty_ctxt parens typq;
                         colon; string "Type"])
        (doc_typschm empty_ctxt false typschm) ^^ dot
+  | TD_abbrev _ -> empty (* TODO? *)
+  | TD_bitfield _ -> empty (* TODO? *)
   | TD_record(id,typq,fs,_) ->
     let fname fid = if prefix_recordtype && string_of_id id <> "regstate"
                     then concat [doc_id id;string "_";doc_id_type fid;]
@@ -1916,7 +1989,6 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
            string "forall (x y : " ^^ id_pp ^^ string "), Decidable (x = y) :=" ^/^
            string "Decidable_eq_from_dec " ^^ id_pp ^^ string "_eq_dec." in
           typ_pp ^^ dot ^^ hardline ^^ eq1_pp ^^ hardline ^^ eq2_pp ^^ hardline)
-    | _ -> raise (Reporting.err_unreachable l __POS__ "register with non-constant indices")
 
 let args_of_typ l env typs =
   let arg i typ =
@@ -2065,18 +2137,23 @@ let merge_kids_atoms pats =
   let try_eliminate (gone,map,seen) = function
     | P_aux (P_id id, ann), typ
     | P_aux (P_typ (_,P_aux (P_id id, ann)),_), typ -> begin
-      match Type_check.destruct_atom_nexp (env_of_annot ann) typ with
-      | Some (Nexp_aux (Nexp_var kid,l)) ->
-         if KidSet.mem kid seen then
-           let () =
-             Reporting.print_err l "merge_kids_atoms"
-               ("want to merge tyvar and argument for " ^ string_of_kid kid ^
+        let merge kid l =
+          if KidSet.mem kid seen then
+            let () =
+              Reporting.print_err l "merge_kids_atoms"
+                ("want to merge tyvar and argument for " ^ string_of_kid kid ^
                    " but rearranging arguments isn't supported yet") in
-           gone,map,seen
-         else
-           KidSet.add kid gone, KBindings.add kid id map, KidSet.add kid seen
-      | _ -> gone,map,KidSet.union seen (tyvars_of_typ typ)
-    end
+            gone,map,seen
+          else
+            KidSet.add kid gone, KBindings.add kid id map, KidSet.add kid seen
+        in
+        match Type_check.destruct_atom_nexp (env_of_annot ann) typ with
+        | Some (Nexp_aux (Nexp_var kid,l)) -> merge kid l
+        | _ ->
+           match Type_check.destruct_atom_bool (env_of_annot ann) typ with
+           | Some (NC_aux (NC_var kid,l)) -> merge kid l
+           | _ -> gone,map,KidSet.union seen (tyvars_of_typ typ)
+      end
     | _, typ -> gone,map,KidSet.union seen (tyvars_of_typ typ)
   in
   let gone,map,_ = List.fold_left try_eliminate (KidSet.empty, KBindings.empty, KidSet.empty) pats in
@@ -2100,7 +2177,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
   in
   let build_ex, ret_typ = replace_atom_return_type ret_typ in
   let build_ex = match destruct_exist_plain (Env.expand_synonyms env (expand_range_type ret_typ)) with
-    | Some _ -> true
+    | Some _ -> Some "build_ex"
     | _ -> build_ex
   in
   let ids_to_avoid = all_ids pexp in
@@ -2129,15 +2206,18 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
       kid_renames = mk_kid_renames ids_to_avoid kids_used;
       kid_id_renames = kid_to_arg_rename;
       bound_nvars = bound_kids;
-      build_ex_return = effectful eff && build_ex;
+      build_at_return = if effectful eff then build_ex else None;
       recursive_ids = recursive_ids;
       debug = List.mem (string_of_id id) (!opt_debug_on)
     } in
   let () =
     debug ctxt (lazy ("Function " ^ string_of_id id));
     debug ctxt (lazy (" return type " ^ string_of_typ ret_typ));
-    debug ctxt (lazy (" build_ex " ^ if build_ex then "needed" else "not needed"));
-    debug ctxt (lazy (if effectful eff then " effectful" else " pure"))
+    debug ctxt (lazy (" build_ex " ^ match build_ex with Some s -> s ^ " needed" | _ -> "not needed"));
+    debug ctxt (lazy (if effectful eff then " effectful" else " pure"));
+    debug ctxt (lazy (" kid_id_renames " ^ String.concat ", " (List.map
+                        (fun (kid,id) -> string_of_kid kid ^ " |-> " ^ string_of_id id)
+                        (KBindings.bindings kid_to_arg_rename))))
   in
   (* Put the constraints after pattern matching so that any type variable that's
      been replaced by one of the term-level arguments is bound. *)
@@ -2228,7 +2308,7 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
        raise (Reporting.err_unreachable l __POS__
                "guarded pattern expression should have been rewritten before pretty-printing") in
   let bodypp = doc_fun_body ctxt exp in
-  let bodypp = if effectful eff || not build_ex then bodypp else string "build_ex" ^^ parens bodypp in
+  let bodypp = if effectful eff then bodypp else match build_ex with Some s -> string s ^^ parens bodypp | None -> bodypp in
   let bodypp = separate (break 1) fixupspp ^/^ bodypp in
   group (prefix 3 1
     (flow (break 1) ([intropp; idpp] @ quantspp @ [patspp] @ constrspp @ [atom_constr_pp] @ accpp) ^/^
diff --git a/src/type_check.mli b/src/type_check.mli
index 7a5a3446..522074b3 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -358,6 +358,8 @@ val expected_typ_of : Ast.l * tannot -> typ option
 
 val destruct_atom_nexp : Env.t -> typ -> nexp option
 
+val destruct_atom_bool : Env.t -> typ -> n_constraint option
+
 val destruct_range : Env.t -> typ -> (kid list * n_constraint * nexp * nexp) option
 
 val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint * nexp) option
-- 
cgit v1.2.3


From 5682dd34fce64869a611ba1aee5e1e73b2f2fd0f Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Fri, 25 Jan 2019 14:23:26 +0000
Subject: Coq: add enough to generate some output for arm-v8.5-a Now supports
 mutual recursion, configuration registers (in the same way as Lem), boolean
 constraints (but produces some ugly stuff that the solver can't handle).

---
 src/pretty_print_coq.ml | 83 +++++++++++++++++++++++++++++++++++--------------
 1 file changed, 59 insertions(+), 24 deletions(-)

(limited to 'src')

diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index d54b2264..bb6a3d6a 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -350,6 +350,14 @@ match nc1, nc2 with
 | _, NC_aux (NC_true,_) -> nc1
 | _,_ -> nc_and nc1 nc2
 
+let nice_iff nc1 nc2 =
+match nc1, nc2 with
+| NC_aux (NC_true,_), _ -> nc2
+| _, NC_aux (NC_true,_) -> nc1
+| NC_aux (NC_false,_), _ -> nc_not nc2
+| _, NC_aux (NC_false,_) -> nc_not nc1
+| _,_ -> nc_or (nc_and nc1 nc2) (nc_and (nc_not nc1) (nc_not nc2))
+
 (* n_constraint functions are currently just Z3 functions *)
 let doc_nc_fn_prop id =
   match string_of_id id with
@@ -468,6 +476,13 @@ let rec doc_typ_fns ctx =
                        [doc_var ctx var; colon; tpp;
                         ampersand;
                         doc_arithfact ctx ~exists:(List.map kopt_kid kopts) ?extra:length_constraint_pp nc])
+          | Typ_aux (Typ_app (Id_aux (Id "atom_bool",_), [A_aux (A_bool atom_nc,_)]),_) ->
+             let var = mk_kid "_bool" in (* TODO collision avoid *)
+             let nc = nice_and (nice_iff (nc_var var) atom_nc) nc in
+             braces (separate space
+                       [doc_var ctx var; colon; string "bool";
+                        ampersand;
+                        doc_arithfact ctx ~exists:(List.map kopt_kid kopts) nc])
           | _ ->
              raise (Reporting.err_todo l
                   ("Non-atom existential type not yet supported in Coq: " ^
@@ -1065,6 +1080,8 @@ let doc_exp, doc_let =
       then separate space [string "liftR"; parens (doc)]
       else doc in
     match e with
+    | E_assign(_, _) when has_effect (effect_of full_exp) BE_config ->
+       string "returnm tt" (* TODO *)
     | E_assign((LEXP_aux(le_act,tannot) as le), e) ->
        (* can only be register writes *)
        (match le_act (*, t, tag*) with
@@ -1453,7 +1470,7 @@ let doc_exp, doc_let =
          if is_bitvector_typ base_typ
          then wrap_parens (align (group (prefix 0 1 (parens (liftR epp)) (doc_tannot ctxt env true base_typ))))
          else liftR epp
-       else if Env.is_register id env then doc_id (append_id id "_ref")
+       else if Env.is_register id env && is_regtyp typ env then doc_id (append_id id "_ref")
        else if is_ctor env id then doc_id_ctor id
        else begin
          match Env.lookup_id id env with
@@ -1851,7 +1868,10 @@ let types_used_with_generic_eq defs =
   let typs_req_funcl (FCL_aux (FCL_Funcl (_,pexp), _)) =
     fst (Rewriter.fold_pexp alg pexp)
   in
-  let typs_req_def = function
+  let typs_req_fundef (FD_aux (FD_function (_,_,_,fcls),_)) =
+    List.fold_left IdSet.union IdSet.empty (List.map typs_req_funcl fcls)
+  in
+  let rec typs_req_def = function
     | DEF_type _
     | DEF_spec _
     | DEF_fixity _
@@ -1860,13 +1880,13 @@ let types_used_with_generic_eq defs =
     | DEF_pragma _
     | DEF_reg_dec _
       -> IdSet.empty
-    | DEF_fundef (FD_aux (FD_function (_,_,_,fcls),_)) ->
-       List.fold_left IdSet.union IdSet.empty (List.map typs_req_funcl fcls)
+    | DEF_fundef fd -> typs_req_fundef fd
     | DEF_mapdef (MD_aux (_,(l,_)))
     | DEF_scattered (SD_aux (_,(l,_)))
+    | DEF_measure (Id_aux (_,l),_,_)
       -> unreachable l __POS__ "Internal definition found in the Coq back-end"
-    | DEF_internal_mutrec _
-      -> unreachable Unknown __POS__ "Internal definition found in the Coq back-end"
+    | DEF_internal_mutrec fds ->
+       List.fold_left IdSet.union IdSet.empty (List.map typs_req_fundef fds)
     | DEF_val lb ->
        fst (Rewriter.fold_letbind alg lb)
   in
@@ -2168,7 +2188,9 @@ let merge_var_patterns map pats =
     | _ -> map, (pat,typ)::pats) (map,[]) pats
   in map, List.rev pats
 
-let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
+type mutrec_pos = NotMutrec | FirstFn | LaterFn
+
+let doc_funcl mutrec rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
   let env = env_of_annot annot in
   let (tq,typ) = Env.get_val_spec_orig id env in
   let (arg_typs, ret_typ, eff) = match typ with
@@ -2290,6 +2312,13 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
        let d = match r with Rec_nonrec -> "Definition" | _ -> "Fixpoint" in
        string d, [], [], []
   in
+  let intropp =
+    match mutrec with
+    | NotMutrec -> intropp
+    | FirstFn -> string "Fixpoint"
+    | LaterFn -> string "with"
+  in
+  let terminalpp = match mutrec with NotMutrec -> dot | _ -> empty in
   (* Work around Coq bug 7975 about pattern binders followed by implicit arguments *)
   let implicitargs =
     if !used_a_pattern && List.length constrspp + List.length atom_constrs > 0 then
@@ -2313,30 +2342,33 @@ let doc_funcl rec_opt (FCL_aux(FCL_Funcl(id, pexp), annot)) =
   group (prefix 3 1
     (flow (break 1) ([intropp; idpp] @ quantspp @ [patspp] @ constrspp @ [atom_constr_pp] @ accpp) ^/^
        flow (break 1) (measurepp @ [colon; retpp; coloneq]))
-    (bodypp ^^ dot)) ^^ implicitargs
+    (bodypp ^^ terminalpp)) ^^ implicitargs
 
 let get_id = function
   | [] -> failwith "FD_function with empty list"
   | (FCL_aux (FCL_Funcl (id,_),_))::_ -> id
 
-(* Strictly speaking, Lem doesn't support multiple clauses for a single function
-   joined by "and", although it has worked for Isabelle before.  However, all
-   the funcls should have been merged by the merge_funcls rewrite now. *)   
-let doc_fundef_rhs (FD_aux(FD_function(r, typa, efa, funcls),fannot)) =
-  separate_map (hardline ^^ string "and ") (doc_funcl r) funcls
+(* Coq doesn't support multiple clauses for a single function joined
+   by "and".  However, all the funcls should have been merged by the
+   merge_funcls rewrite now. *)
+let doc_fundef_rhs ?(mutrec=NotMutrec) (FD_aux(FD_function(r, typa, efa, funcls),(l,_))) =
+  match funcls with
+  | [] -> unreachable l __POS__ "function with no clauses"
+  | [funcl] -> doc_funcl mutrec r funcl
+  | (FCL_aux (FCL_Funcl (id,_),_))::_ -> unreachable l __POS__ ("function " ^ string_of_id id ^ " has multiple clauses in backend")
 
 let doc_mutrec = function
   | [] -> failwith "DEF_internal_mutrec with empty function list"
-  | fundefs ->
-     string "let rec " ^^
-     separate_map (hardline ^^ string "and ") doc_fundef_rhs fundefs
+  | fundef::fundefs ->
+     doc_fundef_rhs ~mutrec:FirstFn fundef ^^ hardline ^^
+     separate_map hardline (doc_fundef_rhs ~mutrec:LaterFn) fundefs ^^ dot
 
 let rec doc_fundef (FD_aux(FD_function(r, typa, efa, fcls),fannot)) =
   match fcls with
   | [] -> failwith "FD_function with empty function list"
   | [FCL_aux (FCL_Funcl(id,_),annot) as funcl]
     when not (Env.is_extern id (env_of_annot annot) "coq") ->
-     doc_funcl r funcl
+     doc_funcl NotMutrec r funcl
   | [_] -> empty (* extern *)
   | _ -> failwith "FD_function with more than one clause"
 
@@ -2363,7 +2395,7 @@ let doc_dec (DEC_aux (reg, ((l, _) as annot))) =
            ^/^ hardline
          else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ))
        else raise (Reporting.err_unreachable l __POS__ ("can't deal with register type " ^ string_of_typ typ)) *)
-  | DEC_config _ -> empty
+  | DEC_config(id, typ, exp) -> separate space [string "Definition"; doc_id id; coloneq; doc_exp empty_ctxt false exp] ^^ dot ^^ hardline
   | DEC_alias(id,alspec) -> empty
   | DEC_typ_alias(typ,id,alspec) -> empty
 
@@ -2519,18 +2551,21 @@ let find_exc_typ defs =
   if List.exists is_exc_typ_def defs then "exception" else "unit"
 
 let find_unimplemented defs =
+  let adjust_fundef unimplemented (FD_aux (FD_function (_,_,_,funcls),_)) =
+    match funcls with
+    | [] -> unimplemented
+    | (FCL_aux (FCL_Funcl (id,_),_))::_ ->
+       IdSet.remove id unimplemented
+  in
   let adjust_def unimplemented = function
     | DEF_spec (VS_aux (VS_val_spec (_,id,ext,_),_)) -> begin
       match ext "coq" with
       | Some _ -> unimplemented
       | None -> IdSet.add id unimplemented
     end
-    | DEF_fundef (FD_aux (FD_function (_,_,_,funcls),_)) -> begin
-      match funcls with
-      | [] -> unimplemented
-      | (FCL_aux (FCL_Funcl (id,_),_))::_ ->
-         IdSet.remove id unimplemented
-    end
+    | DEF_internal_mutrec fds ->
+       List.fold_left adjust_fundef unimplemented fds
+    | DEF_fundef fd -> adjust_fundef unimplemented fd
     | _ -> unimplemented
   in
   List.fold_left adjust_def IdSet.empty defs
-- 
cgit v1.2.3


From 1f2c21b684be664e8ffffda2fd3c8d34edaba807 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 29 Jan 2019 16:25:45 +0000
Subject: Monomorphisation: restrict our attention to Int kids

---
 src/monomorphise.ml | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index dbe0fafd..1b7fb3b4 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -2733,7 +2733,7 @@ let merge rs rs' = {
 }
 
 type env = {
-  top_kids : kid list;
+  top_kids : kid list; (* Int kids bound by the function type *)
   var_deps : dependencies Bindings.t;
   kid_deps : dependencies KBindings.t;
   referenced_vars : IdSet.t
@@ -2941,8 +2941,6 @@ let simplify_size_nexp env typ_env (Nexp_aux (ne,l) as nexp) =
   | Some n -> nconstant n
   | None ->
      let is_equal kid =
-       (* AA: top_kids should be changed to top_kopts so we don't end
-          up trying to prove v == nexp for a non-Int v. *)
        try
          prove __POS__ typ_env (NC_aux (NC_equal (Nexp_aux (Nexp_var kid,Unknown), nexp),Unknown))
        with _ -> false
@@ -3373,12 +3371,11 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions =
       | P_cons (p1,p2) -> of_list [p1;p2]
     in aux pat
   in
-  let quant = function
-    | QI_aux (QI_id (KOpt_aux (KOpt_kind (_,kid),_)),_) ->
-       Some kid
-    | QI_aux (QI_const _,_) -> None
+  let int_quant = function
+    | QI_aux (QI_id (KOpt_aux (KOpt_kind (K_aux (K_int,_),kid),_)),_) -> Some kid
+    | _ -> None
   in
-  let top_kids = Util.map_filter quant qs in
+  let top_kids = Util.map_filter int_quant qs in
   let _,var_deps,kid_deps = split3 (List.mapi arg pats) in
   let var_deps = List.fold_left dep_bindings_merge Bindings.empty var_deps in
   let kid_deps = List.fold_left dep_kbindings_merge KBindings.empty kid_deps in
-- 
cgit v1.2.3


From 0b3273e99772d426b8f9843228cf295d7716eea0 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Tue, 29 Jan 2019 17:10:32 +0000
Subject: Add a few more type annotations after mono rewrites

---
 src/monomorphise.ml | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 2124c11e..51de5a25 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -3687,6 +3687,7 @@ let rewrite_app env typ (id,args) =
       | Some c -> E_cast (vector_typ (nconstant c) order bittyp, exp)
       | None -> e
   in
+  let rewrap e = E_aux (e, (Unknown, empty_tannot)) in
   if is_append id then
     let is_subrange = is_id env (Id "vector_subrange") in
     let is_slice = is_id env (Id "slice") in
@@ -3846,36 +3847,34 @@ let rewrite_app env typ (id,args) =
                       E_aux (E_app (zeros1, [len1]),_)]),_))::
         ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
         when is_subrange subrange1 && is_zeros zeros1 && is_append append1
-      -> E_app (mk_id "place_subrange",
-                [vector1; start1; end1; len1])
+      -> try_cast_to_typ (rewrap (E_app (mk_id "place_subrange", [vector1; start1; end1; len1])))
 
     | (E_aux (E_app (append1,
                      [E_aux (E_app (slice1, [vector1; start1; length1]), _);
                       E_aux (E_app (zeros1, [length2]),_)]),_))::
         ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
         when is_slice slice1 && is_zeros zeros1 && is_append append1
-      -> E_app (mk_id "place_slice",
-                [vector1; start1; length1; length2])
+      -> try_cast_to_typ (rewrap (E_app (mk_id "place_slice", [vector1; start1; length1; length2])))
 
     (* If we've already rewritten to slice_slice_concat or subrange_subrange_concat,
        we can just drop the zero extension because those functions can do it
        themselves *)
     | (E_aux (E_cast (_, (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_))),_))::
         ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
-      -> E_app (op, args)
+      -> try_cast_to_typ (rewrap (E_app (op, args)))
 
     | (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_))::
         ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
-      -> E_app (op, args)
+      -> try_cast_to_typ (rewrap (E_app (op, args)))
 
     | [E_aux (E_app (slice1, [vector1; start1; length1]),_)]
         when is_slice slice1 && not (is_constant length1) ->
-       E_app (mk_id "zext_slice", [vector1; start1; length1])
+       try_cast_to_typ (rewrap (E_app (mk_id "zext_slice", [vector1; start1; length1])))
 
     | [E_aux (E_app (ones, [len1]),_);
        _ (* unnecessary ZeroExtend length *)]
         when is_ones ones ->
-       E_app (mk_id "zext_ones", [len1])
+       try_cast_to_typ (rewrap (E_app (mk_id "zext_ones", [len1])))
 
     | _ -> E_app (id,args)
 
@@ -4308,9 +4307,10 @@ let rewrite_toplevel_nexps (Defs defs) =
       | A_typ typ -> A_aux (A_typ (aux typ),l)
       | A_order _ -> ta_full
       | A_nexp nexp ->
-         match find_nexp env nexp_map nexp with
+         (match find_nexp env nexp_map nexp with
          | (kid,_) -> A_aux (A_nexp (nvar kid),l)
-         | exception Not_found -> ta_full
+         | exception Not_found -> ta_full)
+      | _ -> ta_full
     in aux typ
   in
   let rewrite_one_exp nexp_map (e,ann) =
-- 
cgit v1.2.3


From 29ce01be165b8ed46cb2f8edacfc91b653efb869 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 29 Jan 2019 18:45:03 +0000
Subject: Monomorphisation: add missing tyvar substitution during constrant
 propagation

---
 src/monomorphise.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 51de5a25..ceb8d85a 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -140,7 +140,7 @@ let subst_nc, subst_src_typ, subst_src_typ_arg =
     | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas))
     | Typ_exist (kopts,nc,t) ->
        let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in
-       re (Typ_exist (kopts,nc,s_styp substs t))
+       re (Typ_exist (kopts,subst_nc substs nc,s_styp substs t))
     | Typ_internal_unknown -> Reporting.unreachable l __POS__ "escaped Typ_internal_unknown"
   and s_starg substs (A_aux (ta,l) as targ) =
     match ta with
-- 
cgit v1.2.3


From 36fd3c158c08af5b48d9801a607f3be812d2ecc7 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 29 Jan 2019 18:46:58 +0000
Subject: Add an option to crudely slice a function out of a Sail model Not
 ideal because it keeps everything that's not a function, but good enough for
 quick tests extracted from arm.

---
 src/sail.ml        | 10 ++++++++++
 src/specialize.ml  | 15 +++++++++++++--
 src/specialize.mli |  3 +++
 3 files changed, 26 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/sail.ml b/src/sail.ml
index be2a6198..41aee119 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -72,6 +72,7 @@ let opt_libs_coq = ref ([]:string list)
 let opt_file_arguments = ref ([]:string list)
 let opt_process_elf : string option ref = ref None
 let opt_ocaml_generators = ref ([]:string list)
+let opt_slice = ref ([]:string list)
 
 let options = Arg.align ([
   ( "-o",
@@ -268,6 +269,9 @@ let options = Arg.align ([
   ( "-dprofile",
     Arg.Set Profile.opt_profile,
     " (debug) provides basic profiling information for rewriting passes within Sail");
+  ( "-slice",
+    Arg.String (fun s -> opt_slice := s::!opt_slice),
+    "<id> produce version of input restricted to the given function");
   ( "-v",
     Arg.Set opt_print_version,
     " print version");
@@ -380,6 +384,12 @@ let main() =
       (if !(opt_print_verbose)
        then ((Pretty_print_sail.pp_defs stdout) ast)
        else ());
+      (match !opt_slice with
+       | [] -> ()
+       | ids ->
+          let ids = List.map Ast_util.mk_id ids in
+          let ids = Ast_util.IdSet.of_list ids in
+          Pretty_print_sail.pp_defs stdout (Specialize.slice_defs type_envs ast ids));
       (if !(opt_print_ocaml)
        then
          let ast_ocaml = rewrite_ast_ocaml ast in
diff --git a/src/specialize.ml b/src/specialize.ml
index e7f686d8..00357557 100644
--- a/src/specialize.ml
+++ b/src/specialize.ml
@@ -379,8 +379,11 @@ let specialize_id_overloads instantiations id (Defs defs) =
    therefore remove all unused valspecs. Remaining polymorphic
    valspecs are then re-specialized. This process is iterated until
    the whole spec is specialized. *)
-let remove_unused_valspecs env ast =
-  let calls = ref (IdSet.of_list [mk_id "main"; mk_id "__SetConfig"; mk_id "__ListConfig"; mk_id "execute"; mk_id "decode"; mk_id "initialize_registers"; mk_id "append_64"]) in
+
+let initial_calls = (IdSet.of_list [mk_id "main"; mk_id "__SetConfig"; mk_id "__ListConfig"; mk_id "execute"; mk_id "decode"; mk_id "initialize_registers"; mk_id "append_64"])
+
+let remove_unused_valspecs ?(initial_calls=initial_calls) env ast =
+  let calls = ref initial_calls in
   let vs_ids = Initial_check.val_spec_ids ast in
 
   let inspect_exp = function
@@ -413,6 +416,14 @@ let remove_unused_valspecs env ast =
 
   List.fold_left (fun ast id -> Defs (remove_unused ast id)) ast (IdSet.elements unused)
 
+let slice_defs env (Defs defs) keep_ids =
+  let keep = function
+    | DEF_fundef fd -> IdSet.mem (id_of_fundef fd) keep_ids
+    | _ -> true
+  in
+  let defs = List.filter keep defs in
+  remove_unused_valspecs env (Defs defs) ~initial_calls:keep_ids
+
 let specialize_id id ast =
   let instantiations = instantiations_of id ast in
   let ast = specialize_id_valspec instantiations id ast in
diff --git a/src/specialize.mli b/src/specialize.mli
index f2c94a48..28029747 100644
--- a/src/specialize.mli
+++ b/src/specialize.mli
@@ -71,3 +71,6 @@ val specialize : tannot defs -> Env.t -> tannot defs * Env.t
 val instantiations_of : id -> tannot defs -> typ_arg KBindings.t list
 
 val string_of_instantiation : typ_arg KBindings.t -> string
+
+(* Remove all function definitions except for the given set *)
+val slice_defs : Env.t -> tannot defs -> IdSet.t -> tannot defs
-- 
cgit v1.2.3


From cca2016b7a339da00fcf8ffdf8e5e758234a0234 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 29 Jan 2019 19:24:11 +0000
Subject: Fixes for full v8.5

---
 src/sail.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/sail.ml b/src/sail.ml
index 41aee119..58b224f2 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -400,7 +400,7 @@ let main() =
        then
          let ast_c = rewrite_ast_c ast in
          let ast_c, type_envs = Specialize.specialize ast_c type_envs in
-         let ast_c = Spec_analysis.top_sort_defs ast_c in
+         (* let ast_c = Spec_analysis.top_sort_defs ast_c in *)
          Util.opt_warnings := true;
          C_backend.compile_ast (C_backend.initial_ctx type_envs) (!opt_includes_c) ast_c
        else ());
-- 
cgit v1.2.3


From b3b3c6c37566459f9b185b7e7ef608423a3ed973 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Wed, 30 Jan 2019 02:23:10 +0000
Subject: Cache compilation results to improve build times for repeated builds

---
 src/c_backend.ml  | 47 ++++++++++++++++++++++++++++++++++++++++++++++-
 src/c_backend.mli |  9 +++++++++
 src/sail.ml       |  3 +++
 3 files changed, 58 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index 5e600918..a8063740 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -66,6 +66,7 @@ let opt_debug_function = ref ""
 let opt_trace = ref false
 let opt_static = ref false
 let opt_no_main = ref false
+let opt_memo_cache = ref false
 
 (* Optimization flags *)
 let optimize_primops = ref false
@@ -1625,7 +1626,41 @@ let fix_destructure fail_label = function
 let letdef_count = ref 0
 
 (** Compile a Sail toplevel definition into an IR definition **)
-let rec compile_def n total ctx = function
+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), _)) ->
@@ -3373,6 +3408,16 @@ let compile_ast ctx c_includes (Defs defs) =
     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
diff --git a/src/c_backend.mli b/src/c_backend.mli
index 24f6e03b..9782f24f 100644
--- a/src/c_backend.mli
+++ b/src/c_backend.mli
@@ -59,6 +59,15 @@ val opt_trace : bool ref
 val opt_static : bool ref
 val opt_no_main : bool ref
 
+(** [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
diff --git a/src/sail.ml b/src/sail.ml
index 58b224f2..de394457 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -200,6 +200,9 @@ let options = Arg.align ([
   ( "-memo_z3",
     Arg.Set opt_memo_z3,
     " memoize calls to z3, improving performance when typechecking repeatedly");
+  ( "-memo",
+    Arg.Tuple [Arg.Set opt_memo_z3; Arg.Set C_backend.opt_memo_cache],
+    " memoize calls to z3, and intermediate compilation results");
   ( "-undefined_gen",
     Arg.Set Initial_check.opt_undefined_gen,
     " generate undefined_type functions for types in the specification");
-- 
cgit v1.2.3


From 3d375ec372aa25405beaddbef68a5eeeffcc66a2 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 31 Jan 2019 13:41:03 +0000
Subject: Further restrict attention to Int kids

---
 src/monomorphise.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index ceb8d85a..e16431b8 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -4150,7 +4150,7 @@ let add_bitvector_casts (Defs defs) =
   let rewrite_funcl (FCL_aux (FCL_Funcl (id,pexp),fcl_ann)) =
     let fcl_env = env_of_annot fcl_ann in
     let (tq,typ) = Env.get_val_spec_orig id fcl_env in
-    let quant_kids = List.map kopt_kid (quant_kopts tq) in
+    let quant_kids = List.map kopt_kid (List.filter is_nat_kopt (quant_kopts tq)) in
     let ret_typ =
       match typ with
       | Typ_aux (Typ_fn (_,ret,_),_) -> ret
-- 
cgit v1.2.3


From f1e01368711ffd8f0d5b8f33c0be6af69b1bf81b Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Fri, 1 Feb 2019 17:15:06 +0000
Subject: Add tracing instrumention for SMT

Fix pretty printer bug
---
 src/c_backend.ml         | 86 +++++++++++++++++++++++++++++++++++++++++++++---
 src/c_backend.mli        |  1 +
 src/pretty_print_sail.ml | 12 +++----
 src/sail.ml              |  3 ++
 4 files changed, 92 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index a8063740..41970184 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -64,6 +64,7 @@ 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
@@ -1659,7 +1660,7 @@ let rec compile_def n total ctx def =
      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
@@ -1973,6 +1974,7 @@ let flatten_cdef =
 
   | cdef -> cdef
 
+
 let rec specialize_variants ctx prior =
   let unifications = ref (Bindings.empty) in
 
@@ -2606,9 +2608,9 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) =
        empty
      else if fname = "reg_deref" then
        if is_stack_ctyp ctyp then
-         string (Printf.sprintf  " %s = *(%s);" (sgen_clexp_pure x) c_args)
+         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)
+         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);" (sgen_clexp_pure x) fname c_args)
@@ -3397,6 +3399,79 @@ let rec 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 c_includes (Defs defs) =
   try
     c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions"));
@@ -3417,7 +3492,7 @@ let compile_ast ctx c_includes (Defs defs) =
        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
@@ -3428,6 +3503,9 @@ let compile_ast ctx c_includes (Defs defs) =
     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
diff --git a/src/c_backend.mli b/src/c_backend.mli
index 9782f24f..10bf9f40 100644
--- a/src/c_backend.mli
+++ b/src/c_backend.mli
@@ -56,6 +56,7 @@ open Type_check
 val opt_debug_flow_graphs : bool ref
 val opt_debug_function : string ref
 val opt_trace : bool ref
+val opt_smt_trace : bool ref
 val opt_static : bool ref
 val opt_no_main : bool ref
 
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index 5430b284..3d5bd479 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -589,11 +589,11 @@ let doc_field (typ, id) =
 
 let doc_union (Tu_aux (Tu_ty_id (typ, id), l)) = separate space [doc_id id; colon; doc_typ typ]
 
-let doc_typ_arg_kind (A_aux (aux, _)) =
+let doc_typ_arg_kind sep (A_aux (aux, _)) =
   match aux with
-  | A_nexp _ -> space ^^ string "->" ^^ space ^^string "Int"
-  | A_bool _ -> space ^^ string "->" ^^ space ^^ string "Bool"
-  | A_order  _ -> space ^^ string "->" ^^ space ^^ string "Order"
+  | A_nexp _ -> space ^^ string sep ^^ space ^^string "Int"
+  | A_bool _ -> space ^^ string sep ^^ space ^^ string "Bool"
+  | A_order  _ -> space ^^ string sep ^^ space ^^ string "Order"
   | A_typ _ -> empty
 
 let doc_typdef (TD_aux(td,_)) = match td with
@@ -601,9 +601,9 @@ let doc_typdef (TD_aux(td,_)) = match td with
      begin
        match doc_typquant typq with
        | Some qdoc ->
-          doc_op equals (concat [string "type"; space; doc_id id; qdoc; doc_typ_arg_kind typ_arg]) (doc_typ_arg typ_arg)
+          doc_op equals (concat [string "type"; space; doc_id id; qdoc; doc_typ_arg_kind "->" typ_arg]) (doc_typ_arg typ_arg)
        | None ->
-          doc_op equals (concat [string "type"; space; doc_id id; doc_typ_arg_kind typ_arg]) (doc_typ_arg typ_arg)
+          doc_op equals (concat [string "type"; space; doc_id id; doc_typ_arg_kind ":" typ_arg]) (doc_typ_arg typ_arg)
      end
   | TD_enum (id, ids, _) ->
      separate space [string "enum"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace]
diff --git a/src/sail.ml b/src/sail.ml
index de394457..fdf4f5b9 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -147,6 +147,9 @@ let options = Arg.align ([
   ( "-trace",
     Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml],
     " Instrument ouput with tracing");
+  ( "-smt_trace",
+    Arg.Tuple [Arg.Set C_backend.opt_smt_trace],
+    " Instrument ouput with tracing for SMT");
   ( "-cgen",
     Arg.Set opt_print_cgen,
     " Generate CGEN source");
-- 
cgit v1.2.3


From 049eeeb22321552f8aa73285cfb92bf50933e3a3 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Fri, 1 Feb 2019 18:21:40 +0000
Subject: Expand integer synonyms

---
 src/type_check.ml | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 0da7bb8e..ad6b48b3 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -559,6 +559,32 @@ end = struct
         with Not_found -> NC_aux (NC_app (id, List.map (expand_synonyms_arg env) args), l))
     | NC_true | NC_false | NC_equal _ | NC_not_equal _ | NC_bounded_le _ | NC_bounded_ge _ | NC_var _ | NC_set _ -> nc
 
+  and expand_nexp_synonyms env (Nexp_aux (aux, l) as nexp) =
+    typ_debug ~level:2 (lazy ("Expanding " ^ string_of_nexp nexp));
+    match aux with
+    | Nexp_app (id, args) ->
+       (try
+          begin match Bindings.find id env.typ_synonyms env [] with
+          | A_aux (A_nexp nexp, _) -> expand_nexp_synonyms env nexp
+          | _ -> typ_error env l ("Expected Int when expanding synonym " ^ string_of_id id)
+          end
+        with
+        | Not_found -> Nexp_aux (Nexp_app (id, List.map (expand_nexp_synonyms env) args), l))
+    | Nexp_id id ->
+       (try
+          begin match Bindings.find id env.typ_synonyms env [] with
+          | A_aux (A_nexp nexp, _) -> expand_nexp_synonyms env nexp
+          | _ -> typ_error env l ("Expected Int when expanding synonym " ^ string_of_id id)
+          end
+        with Not_found -> nexp)
+    | Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (expand_nexp_synonyms env nexp1, expand_nexp_synonyms env nexp2), l)
+    | Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (expand_nexp_synonyms env nexp1, expand_nexp_synonyms env nexp2), l)
+    | Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (expand_nexp_synonyms env nexp1, expand_nexp_synonyms env nexp2), l)
+    | Nexp_exp nexp -> Nexp_aux (Nexp_exp (expand_nexp_synonyms env nexp), l)
+    | Nexp_neg nexp -> Nexp_aux (Nexp_neg (expand_nexp_synonyms env nexp), l)
+    | Nexp_var kid -> Nexp_aux (Nexp_var kid, l)
+    | Nexp_constant n -> Nexp_aux (Nexp_constant n, l)
+
   and expand_synonyms env (Typ_aux (typ, l) as t) =
     match typ with
     | Typ_internal_unknown -> Typ_aux (Typ_internal_unknown, l)
@@ -616,6 +642,7 @@ end = struct
     match typ_arg with
     | A_typ typ -> A_aux (A_typ (expand_synonyms env typ), l)
     | A_bool nc -> A_aux (A_bool (expand_constraint_synonyms env nc), l)
+    | A_nexp nexp -> A_aux (A_nexp (expand_nexp_synonyms env nexp), l)
     | arg -> A_aux (arg, l)
 
   (** Map over all nexps in a type - excluding those in existential constraints **)
-- 
cgit v1.2.3


From 2f8dd66dcaec500561f8736c98bebf65938fa608 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Fri, 1 Feb 2019 22:09:37 +0000
Subject: Fix missing typedef cases in OCaml output

---
 src/ocaml_backend.ml | 7 +++++--
 src/rewrites.ml      | 2 ++
 2 files changed, 7 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index 75887b4e..31c3e093 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -582,7 +582,7 @@ let ocaml_string_of_abbrev ctx id typq typ =
 let ocaml_string_of_variant ctx id typq cases =
   separate space [string "let"; ocaml_string_of id; string "_"; equals; string "\"VARIANT\""]
 
-let ocaml_typedef ctx (TD_aux (td_aux, _)) =
+let ocaml_typedef ctx (TD_aux (td_aux, (l, _))) =
   match td_aux with
   | TD_record (id, typq, fields, _) ->
      ((separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; lbrace]
@@ -606,7 +606,10 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) =
      separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; ocaml_typ ctx typ]
      ^^ ocaml_def_end
      ^^ ocaml_string_of_abbrev ctx id typq typ
- | _ -> failwith "Unsupported typedef"
+  | TD_abbrev _ ->
+     empty
+  | TD_bitfield _ ->
+     Reporting.unreachable l __POS__ "Bitfield should be re-written"
 
 let get_externs (Defs defs) =
   let extern_id (VS_aux (VS_val_spec (typschm, id, ext, _), _)) =
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 67b6518f..f8146a72 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2329,6 +2329,8 @@ let rewrite_type_def_typs rw_typ rw_typquant (TD_aux (td, annot)) =
   match td with
   | TD_abbrev (id, typq, A_aux (A_typ typ, l)) ->
      TD_aux (TD_abbrev (id, rw_typquant typq, A_aux (A_typ (rw_typ typ), l)), annot)
+  | TD_abbrev (id, typq, typ_arg) ->
+     TD_aux (TD_abbrev (id, rw_typquant typq, typ_arg), annot)
   | TD_record (id, typq, typ_ids, flag) ->
      TD_aux (TD_record (id, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot)
   | TD_variant (id, typq, tus, flag) ->
-- 
cgit v1.2.3


From 4eed419ed4999a1e092b14c5e81154c97d1ec89c Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Sat, 2 Feb 2019 00:11:47 +0000
Subject: Monomorphisation tests all pass so add them to standard regression
 tests

---
 src/monomorphise.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index ab1a2f82..3243bf20 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -4076,7 +4076,7 @@ let make_bitvector_cast_exp cast_name cast_env quant_kids typ target_typ exp =
            let arg_typ' = subst_unifiers unifiers arg_typ in
            arg_typ'
        end
-    | _ -> typ_error l ("Malformed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
+    | _ -> typ_error env l ("Malformed constructor " ^ string_of_id f ^ " with type " ^ string_of_typ ctor_typ)
 
   in
   (* Push the cast down, including through constructors *)
-- 
cgit v1.2.3


From ebfed17b57993f034d1a334014a8b9c9a542c0d5 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Sat, 2 Feb 2019 01:22:39 +0000
Subject: Avoid unification on ambiguous return types

Usually we want to unify on return types, but in the case of
constraint unification (especially during rewriting) we can find
ourselves in the situation where unifying too eagerly on a return
type like bool('p & 'q) can cause us to instantiate 'p and 'q in the
wrong order (as & should really respect commutativity and
associativity during typechecking to avoid being overly brittle).

Originally I simply avoided adding cases for unify on NC_and/NC_or
and similar to avoid these cases, but this lead to the undesirable
situation where identical types wouldn't unify with each other for
an empty set of goals, which should be a trivial property of the
unification functions.

The solution is therefore to identify type variables in ambiguous
positions, and remove them from the list of goals during
unification. All type variables still have to be resolved by the
time we finish checking each application, but this has the added
bonus of making order much less important when it comes to
instantiating type variables.

Currently I am overly conservative about what qualifies as
ambigious, but this set should be expanded
---
 src/type_check.ml | 35 ++++++++++++++++++++++++++++++++++-
 1 file changed, 34 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index ad6b48b3..a5ffff43 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1678,6 +1678,39 @@ let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) =
 let instantiate_quants quants unifier =
   List.map (instantiate_quant unifier) quants |> Util.option_these
 
+(* During typechecking, we can run into the following issue, where we
+   have a function like
+
+   val and_bool : forall ('p : Bool) ('q : Bool). (bool('p), bool('q)) -> bool('p & 'q)
+
+   and we want to check something like Q & P <= bool(X & Y)
+
+   where Q => bool(Y) & P => bool(X)
+
+   if we instantiate using the return type (which is usually good)
+   we'll run into the situtation where we have to check bool(Y)
+   subtype bool(X) because the quantifiers will get instantiated in
+   the wrong order, despite the expression being otherwise well-typed
+   the trick here is to recognise that we shouldn't unify on goals in
+   certain ambiguous positions in types. In this case with and_bool,
+   they'll be unambigiously unified with the argument types so it's
+   better to just not bother with the return type.
+*)
+let rec ambiguous_vars (Typ_aux (aux, _)) =
+  match aux with
+  | Typ_app (_, args) -> List.fold_left KidSet.union KidSet.empty (List.map ambiguous_arg_vars args)
+  | _ -> KidSet.empty
+  
+and ambiguous_arg_vars (A_aux (aux, _)) =
+  match aux with
+  | A_bool nc -> ambiguous_nc_vars nc
+  | _ -> KidSet.empty
+               
+and ambiguous_nc_vars (NC_aux (aux, _)) =
+  match aux with
+  | NC_and (nc1, nc2) -> KidSet.union (tyvars_of_constraint nc1) (tyvars_of_constraint nc2)
+  | _ -> KidSet.empty
+               
 (**************************************************************************)
 (* 3.5. Subtyping with existentials                                       *)
 (**************************************************************************)
@@ -3508,7 +3541,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
     | Some expect ->
        let goals = quant_kopts (mk_typquant !quants) |> List.map kopt_kid |> KidSet.of_list in
        try
-         let unifiers = unify l env goals !typ_ret expect in
+         let unifiers = unify l env (KidSet.diff goals (ambiguous_vars !typ_ret)) !typ_ret expect in
          record_unifiers unifiers;
          let unifiers = KBindings.bindings unifiers in
          typ_debug (lazy (Util.("Unifiers " |> magenta |> clear)
-- 
cgit v1.2.3


From 4910e06ae9cf8f479c76fea39b4334407942da4e Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 4 Feb 2019 16:43:32 +0000
Subject: Fix behavior for fallthrough cases in catch blocks

Make all backends behave the same when a catch block does not catch a
specific exception.
---
 src/c_backend.ml   |  9 +++++----
 src/interpreter.ml | 11 ++++++++++-
 src/type_check.mli |  2 ++
 3 files changed, 17 insertions(+), 5 deletions(-)

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index 41970184..ee900569 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -1121,6 +1121,7 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) =
      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, _), _)), _, _)
@@ -1146,14 +1147,14 @@ let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) =
        [iblock case_instrs; ilabel try_label]
      in
      assert (ctyp_equal ctyp (ctyp_of_typ ctx typ));
-     [icomment "begin try catch";
-      idecl ctyp try_return_id;
+     [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)
-     @ [imatch_failure ();
+     @ [igoto fallthrough_label;
         ilabel handled_exception_label;
-        icopy l CL_have_exception (F_lit (V_bool false), CT_bool)],
+        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)),
      []
 
diff --git a/src/interpreter.ml b/src/interpreter.ml
index 40ee251d..1e1bb816 100644
--- a/src/interpreter.ml
+++ b/src/interpreter.ml
@@ -110,6 +110,15 @@ let value_of_exp = function
   | (E_aux (E_internal_value v, _)) -> v
   | _ -> failwith "value_of_exp coerction failed"
 
+let fallthrough =
+  let open Type_check in
+  try
+    let env = initial_env |> Env.add_scattered_variant (mk_id "exception") (mk_typquant []) in
+    check_case env exc_typ (mk_pexp (Pat_exp (mk_pat (P_id (mk_id "exn")), mk_exp (E_throw (mk_exp (E_id (mk_id "exn"))))))) unit_typ
+  with
+  | Type_error (_, l, err) ->
+     Reporting.unreachable l __POS__ (Type_error.string_of_type_error err);
+
 (**************************************************************************)
 (* 1. Interpreter Monad                                                   *)
 (**************************************************************************)
@@ -491,7 +500,7 @@ let rec step (E_aux (e_aux, annot) as orig_exp) =
      begin
        catch (step exp) >>= fun exp' ->
        match exp' with
-       | Left exn -> wrap (E_case (exp_of_value exn, pexps))
+       | Left exn -> wrap (E_case (exp_of_value exn, pexps @ [fallthrough]))
        | Right exp' -> wrap (E_try (exp', pexps))
      end
 
diff --git a/src/type_check.mli b/src/type_check.mli
index 82e9ebc1..801a07ec 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -120,6 +120,8 @@ module Env : sig
 
   val add_local : id -> mut * typ -> t -> t
 
+  val add_scattered_variant : id -> typquant -> t -> t
+
   (** Check if a local variable is mutable. Throws Type_error if it
      isn't a local variable. Probably best to use Env.lookup_id
      instead *)
-- 
cgit v1.2.3


From a92a6573ea2d7cf88c1c7ac8dcc79a241aea0df7 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 4 Feb 2019 20:06:49 +0000
Subject: Test lem output by running end-to-end tests using ocaml via lem

---
 src/gen_lib/sail2_values.lem | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/gen_lib/sail2_values.lem b/src/gen_lib/sail2_values.lem
index fa1e8426..f21a4772 100644
--- a/src/gen_lib/sail2_values.lem
+++ b/src/gen_lib/sail2_values.lem
@@ -47,7 +47,11 @@ let power_real b e = realPowInteger b e*)
 
 val print_endline : string -> unit
 let print_endline _ = ()
-(* declare ocaml target_rep function print_endline = `print_endline` *)
+declare ocaml target_rep function print_endline = `print_endline`
+
+val print : string -> unit
+let print _ = ()
+declare ocaml target_rep function print = `print_string`
 
 val prerr_endline : string -> unit
 let prerr_endline _ = ()
@@ -631,6 +635,12 @@ let nat_of_bv v = Maybe.map nat_of_int (unsigned v)
 val string_of_bv : forall 'a. Bitvector 'a => 'a -> string
 let string_of_bv v = show_bitlist (bits_of v)
 
+val print_bits : forall 'a. Bitvector 'a => string -> 'a -> unit
+let print_bits str v = print_endline (str ^ string_of_bv v)
+
+val concat_str : string -> string -> string
+let concat_str str1 str2 = str1 ^ str2
+
 val int_of_bit : bitU -> integer
 let int_of_bit b =
   match b with
-- 
cgit v1.2.3


From 8347e409564c19963a55e88358eeb88dab6b865c Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 4 Feb 2019 20:30:08 +0000
Subject: Add dec_str builtin to lem

---
 src/gen_lib/sail2_values.lem | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'src')

diff --git a/src/gen_lib/sail2_values.lem b/src/gen_lib/sail2_values.lem
index f21a4772..5e6537a8 100644
--- a/src/gen_lib/sail2_values.lem
+++ b/src/gen_lib/sail2_values.lem
@@ -638,6 +638,9 @@ let string_of_bv v = show_bitlist (bits_of v)
 val print_bits : forall 'a. Bitvector 'a => string -> 'a -> unit
 let print_bits str v = print_endline (str ^ string_of_bv v)
 
+val dec_str : integer -> string
+let dec_str bv = show bv
+
 val concat_str : string -> string -> string
 let concat_str str1 str2 = str1 ^ str2
 
-- 
cgit v1.2.3


From 84d30fd9dee6dd4f22a58b55f93ca39d30266c4f Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 4 Feb 2019 21:30:33 +0000
Subject: Fix some warnings

---
 src/ast_util.ml   | 1 +
 src/type_check.ml | 9 +++++++++
 2 files changed, 10 insertions(+)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 1fe4798f..63726304 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -635,6 +635,7 @@ let def_loc = function
   | DEF_overload (Id_aux (_, l), _) -> l
   | DEF_internal_mutrec _ -> Parse_ast.Unknown
   | DEF_pragma (_, _, l) -> l
+  | DEF_measure (id, _, _) -> id_loc id
 
 let string_of_id = function
   | Id_aux (Id v, _) -> v
diff --git a/src/type_check.ml b/src/type_check.ml
index a5ffff43..dbde7754 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1263,6 +1263,7 @@ and is_typ_arg_monomorphic (A_aux (arg, _)) =
   match arg with
   | A_nexp _ -> true
   | A_typ typ -> is_typ_monomorphic typ
+  | A_bool _ -> true
   | A_order (Ord_aux (Ord_dec, _)) | A_order (Ord_aux (Ord_inc, _)) -> true
   | A_order (Ord_aux (Ord_var _, _)) -> false
 
@@ -1408,7 +1409,15 @@ and typ_arg_nexps (A_aux (typ_arg_aux, l)) =
   match typ_arg_aux with
   | A_nexp n -> [n]
   | A_typ typ -> typ_nexps typ
+  | A_bool nc -> constraint_nexps nc
   | A_order ord -> []
+and constraint_nexps (NC_aux (nc_aux, l)) =
+  match nc_aux with
+  | NC_equal (n1, n2) | NC_bounded_ge (n1, n2) | NC_bounded_le (n1, n2) | NC_not_equal (n1, n2) ->
+     [n1; n2]
+  | NC_set _ | NC_true | NC_false | NC_var _ -> []
+  | NC_or (nc1, nc2) | NC_and (nc1, nc2) -> constraint_nexps nc1 @ constraint_nexps nc2
+  | NC_app (_, args) -> List.concat (List.map typ_arg_nexps args)
 
 let rec nexp_identical (Nexp_aux (nexp1, _)) (Nexp_aux (nexp2, _)) =
   match nexp1, nexp2 with
-- 
cgit v1.2.3


From 296c0ba8ad41c704ee25f362571910096a28a4f9 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Tue, 5 Feb 2019 14:28:57 +0000
Subject: Handle a few more cases in mono rewrites

---
 src/monomorphise.ml | 47 ++++++++++++++++++++++++-----------------------
 1 file changed, 24 insertions(+), 23 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 3243bf20..f458716b 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -2274,30 +2274,18 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) =
                    E_aux (E_app (Id_aux (Id "make_the_value",Generated Unknown),[exp]),(Generated l,empty_tannot))),
            (Generated l,empty_tannot))
   in
-  match typ with
-  | Typ_aux (Typ_app (Id_aux (Id "range",_),
-                      [A_aux (A_nexp nexp,l');A_aux (A_nexp nexp',_)]),_)
-    when nexp_identical nexp nexp' ->
-     mk_exp nexp l l'
-  | Typ_aux (Typ_app (Id_aux (Id "atom",_),
-                      [A_aux (A_nexp nexp,l')]),_) ->
-     mk_exp nexp l l'
+  match destruct_numeric typ with
+  | Some ([], nc, nexp) when prove __POS__ env nc -> mk_exp nexp l l
   | _ -> raise (Reporting.err_unreachable l __POS__
-                  "atom stopped being an atom?")
+                  ("replace_with_the_value: Unsupported type " ^ string_of_typ typ))
 
 let replace_type env typ =
   let Typ_aux (t,l) = Env.expand_synonyms env typ in
-  match t with
-  | Typ_app (Id_aux (Id "range",_),
-             [A_aux (A_nexp nexp,l');A_aux (A_nexp _,_)]) ->
-     Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown),
-                       [A_aux (A_nexp nexp,l')]),Generated l)
-  | Typ_app (Id_aux (Id "atom",_),
-                      [A_aux (A_nexp nexp,l')]) ->
-     Typ_aux (Typ_app (Id_aux (Id "itself",Generated Unknown),
-                       [A_aux (A_nexp nexp,l')]),Generated l)
+  match destruct_numeric typ with
+  | Some ([], nc, nexp) when prove __POS__ env nc ->
+     Typ_aux (Typ_app (mk_id "itself", [A_aux (A_nexp nexp, Generated l)]), Generated l)
   | _ -> raise (Reporting.err_unreachable l __POS__
-                  "atom stopped being an atom?")
+                  ("replace_type: Unsupported type " ^ string_of_typ typ))
 
 
 let rewrite_size_parameters env (Defs defs) =
@@ -4425,10 +4413,23 @@ let rewrite_toplevel_nexps (Defs defs) =
       match ta with
       | A_typ typ -> A_aux (A_typ (aux typ),l)
       | A_order _ -> ta_full
-      | A_nexp nexp ->
-         match find_nexp env nexp_map nexp with
-         | (kid,_) -> A_aux (A_nexp (nvar kid),l)
-         | exception Not_found -> ta_full
+      | A_nexp nexp -> A_aux (A_nexp (aux_nexp nexp), l)
+      | A_bool nc -> A_aux (A_bool (aux_nconstraint nc), l)
+    and aux_nexp nexp =
+      match find_nexp env nexp_map nexp with
+      | (kid,_) -> nvar kid
+      | exception Not_found -> nexp
+    and aux_nconstraint (NC_aux (nc, l)) =
+      let rewrap nc = NC_aux (nc, l) in
+      match nc with
+      | NC_equal (n1, n2) -> rewrap (NC_equal (aux_nexp n1, aux_nexp n2))
+      | NC_bounded_ge (n1, n2) -> rewrap (NC_bounded_ge (aux_nexp n1, aux_nexp n2))
+      | NC_bounded_le (n1, n2) -> rewrap (NC_bounded_le (aux_nexp n1, aux_nexp n2))
+      | NC_not_equal (n1, n2) -> rewrap (NC_not_equal (aux_nexp n1, aux_nexp n2))
+      | NC_or (nc1, nc2) -> rewrap (NC_or (aux_nconstraint nc1, aux_nconstraint nc2))
+      | NC_and (nc1, nc2) -> rewrap (NC_and (aux_nconstraint nc1, aux_nconstraint nc2))
+      | NC_app (id, args) -> rewrap (NC_app (id, List.map aux_targ args))
+      | _ -> rewrap nc
     in aux typ
   in
   let rewrite_one_exp nexp_map (e,ann) =
-- 
cgit v1.2.3


From f1af348146a5810d1a21ee272d1799adfe2d545b Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 5 Feb 2019 17:26:46 +0000
Subject: The alpha equivalence check should keep tyvars that only appear in
 constraints

---
 src/type_check.ml | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index dbde7754..776f9d78 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1816,7 +1816,9 @@ let rec alpha_equivalent env typ1 typ2 =
       | Typ_tup typs -> Typ_tup (List.map relabel typs)
       | Typ_exist (kopts, nc, typ) ->
          let kind_map = List.fold_left (fun m kopt -> KBindings.add (kopt_kid kopt) (kopt_kind kopt) m) KBindings.empty kopts in
-         let (kopts, _) = kid_order kind_map typ in
+         let (kopts1, kind_map) = kid_order_constraint kind_map nc in
+         let (kopts2, _) = kid_order kind_map typ in
+         let kopts = kopts1 @ kopts2 in
          let kopts = List.map (fun kopt -> (kopt_kid kopt, mk_kopt (unaux_kind (kopt_kind kopt)) (new_kid ()))) kopts in
          let nc = List.fold_left (fun nc (kid, nk) -> constraint_subst kid (arg_kopt nk) nc) nc kopts in
          let typ = List.fold_left (fun nc (kid, nk) -> typ_subst kid (arg_kopt nk) nc) typ kopts in
-- 
cgit v1.2.3


From 2e6b258fee6929e060a6c55c889fd479ee543fc3 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 5 Feb 2019 17:27:52 +0000
Subject: Use more general types for lexps in the internal lets rewriting pass
 This reduces the amount of unnecessary complex existentials that appear
 during rewriting.

---
 src/rewrites.ml | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 8fa90643..c6406639 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -2904,7 +2904,14 @@ let rewrite_defs_internal_lets =
        (* Rewrite assignments to local variables into let bindings *)
        let (lhs, rhs) = rewrite_lexp_to_rhs le in
        let (LEXP_aux (_, lannot)) = lhs in
-       let ltyp = typ_of_annot lannot in
+       let ltyp = typ_of_annot
+         (* The type in the lannot might come from exp rather than being the
+            type of the storage, so ask the type checker what it really is. *)
+         (match infer_lexp (env_of_annot lannot) (strip_lexp lhs) with
+         | LEXP_aux (_,lexp_annot') -> lexp_annot'
+         | _ -> lannot
+         | exception _ -> lannot)
+       in
        let rhs = add_e_cast ltyp (rhs exp) in
        E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs), annot), body)
     | LB_aux (LB_val (pat,exp'),annot') ->
-- 
cgit v1.2.3


From 078e0bb639e89d82e2bccd2e1f5c382409869ff7 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Tue, 5 Feb 2019 18:30:52 +0000
Subject: Ensure Lem output doesn't fail if there's a termination measure
 present

---
 src/pretty_print_lem.ml | 1 +
 src/spec_analysis.ml    | 9 ++++++++-
 2 files changed, 9 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 169bd824..7d2cc479 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1444,6 +1444,7 @@ let rec doc_def_lem type_env def =
 
   | DEF_mapdef (MD_aux (_, (l, _))) -> unreachable l __POS__ "Lem doesn't support mappings"
   | DEF_pragma _ -> empty
+  | DEF_measure _ -> empty (* we might use these in future *)
 
 let find_exc_typ defs =
   let is_exc_typ_def = function
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index 634b34b6..907a2f10 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -502,7 +502,14 @@ let fv_of_def consider_var consider_scatter_as_one all_defs = function
   | DEF_scattered sdef -> fv_of_scattered consider_var consider_scatter_as_one all_defs sdef
   | DEF_reg_dec rdec -> fv_of_rd consider_var rdec
   | DEF_pragma _ -> mt,mt
-  | DEF_measure _ -> mt,mt (* currently removed beforehand *)
+  (* removed beforehand for Coq, but may still be present otherwise *)
+  | DEF_measure(id,pat,exp) ->
+     let i = string_of_id id in
+     let used = Nameset.of_list [i; "val:"^i] in
+     ((fun (_,u,_) -> Nameset.singleton ("measure:"^i),u)
+        (fv_of_pes consider_var mt used mt
+           [Pat_aux(Pat_exp (pat,exp),(Unknown,Type_check.empty_tannot))]))
+
 
 let group_defs consider_scatter_as_one (Ast.Defs defs) =
   List.map (fun d -> (fv_of_def false consider_scatter_as_one defs d,d)) defs
-- 
cgit v1.2.3


From 18d9a16b1cfd442fb05039a326795bcd64cb6a79 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 5 Feb 2019 20:52:03 +0000
Subject: Simpler implicit arguments

Rather than using sizeof-rewriting which is slow and error-prone, just
make implicit function arguments explicit, so:

val ZeroExtend : forall 'n 'm, 'm >= 'n. (implicit('m), bits('n)) -> bits('m)
let x : bits(32) = ZeroExtend(0xFFFF)

would be re-written (by the typechecker itself) into

val ZeroExtend : forall 'n 'm, 'm >= 'n. (implicit('m), bits('n)) -> bits('m)
let x : bits(32) = ZeroExtend(32, 0xFFFF)

then all we need to do is map implicit -> int in a rewrite, and use
trivial sizeof-rewriting only. We pretty much never want to use the
form of sizeof-rewriting that propagates function arguments through
multiple functions because it's extremely error-prone. Anything that
isn't re-writable via trivial sizeof rewriting should be a type error,
so it would be good to re-write sizeof expressions within the
type-checker.
---
 src/type_check.ml | 38 +++++++++++++++++++++++++++++++++++---
 1 file changed, 35 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 776f9d78..ff56a8f0 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2024,6 +2024,24 @@ let replace_env env = function
   | Some t -> Some { t with env = env }
   | None -> None
 
+(* Helpers for implicit arguments in infer_funapp' *)
+let is_not_implicit (Typ_aux (aux, _)) =
+  match aux with
+  | Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var impl, _)), _)]) when string_of_id id = "implicit" -> false
+  | _ -> true
+
+let implicit_to_int (Typ_aux (aux, l)) =
+  match aux with
+  | Typ_app (id, args) when string_of_id id = "implicit" -> Typ_aux (Typ_app (mk_id "atom", args), l)
+  | _ -> Typ_aux (aux, l)
+
+let rec get_implicits typs =
+  match typs with
+  | Typ_aux (Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var impl, _)), _)]), _) :: typs when string_of_id id = "implicit" ->
+     impl :: get_implicits typs
+  | _ :: typs -> get_implicits typs
+  | [] -> []
+
 let infer_lit env (L_aux (lit_aux, l) as lit) =
   match lit_aux with
   | L_unit -> unit_typ
@@ -3535,9 +3553,16 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
 
   typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants));
 
-  if not (List.length typ_args = List.length xs) then
-    typ_error env l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args))
-  else ();
+  let implicits, typ_args =
+    if not (List.length typ_args = List.length xs) then
+      let typ_args' = List.filter is_not_implicit typ_args in
+      if not (List.length typ_args' = List.length xs) then
+        typ_error env l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args))
+      else
+        get_implicits typ_args, typ_args'
+    else
+      [], List.map implicit_to_int typ_args
+  in
 
   let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) =
     match aux with
@@ -3597,6 +3622,13 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   let xs, _, env = List.fold_left fold_instantiate ([], typ_args, env) xs in
   let xs = List.rev xs in
 
+  let solve_implicit impl = match KBindings.find_opt impl !all_unifiers with
+    | Some (A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _)) -> irule infer_exp env (mk_lit_exp (L_num c))
+    | Some (A_aux (A_nexp n, _)) -> irule infer_exp env (mk_exp (E_sizeof n))
+    | _ -> typ_error env l "bad"
+  in
+  let xs = List.map solve_implicit implicits @ xs in
+
   if not (List.for_all (solve_quant env) !quants) then
     typ_raise env l (Err_unresolved_quants (f, !quants, Env.get_locals env, Env.get_constraints env))
   else ();
-- 
cgit v1.2.3


From 0f736fcb7fd46d902dffa171d1458253b2070b79 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Wed, 6 Feb 2019 03:20:03 +0000
Subject: Remove all sizeof rewriting from C compilation

All sizeof expressions now removed by the type-checker, so it's now
properly a type error if they cannot be removed rather than a bizarre
re-write error. This also greatly improves compilation speed overall, at
the expense of the first type-checking pass.
---
 src/c_backend.ml  |   2 +-
 src/rewrites.ml   |   3 --
 src/type_check.ml | 132 +++++++++++++++++++++++++++++++++++++++++++++++++-----
 3 files changed, 122 insertions(+), 15 deletions(-)

(limited to 'src')

diff --git a/src/c_backend.ml b/src/c_backend.ml
index ee900569..a1050972 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -143,7 +143,7 @@ let rec ctyp_of_typ ctx typ =
 
   | Typ_app (id, _) when string_of_id id = "atom_bool" -> CT_bool
 
-  | Typ_app (id, _) when string_of_id id = "range" || string_of_id id = "atom" ->
+  | 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) ->
diff --git a/src/rewrites.ml b/src/rewrites.ml
index c6406639..19294698 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -5171,9 +5171,6 @@ let rewrite_defs_c = [
   ("remove_vector_concat", rewrite_defs_remove_vector_concat);
   ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
-  ("constraint", rewrite_constraint);
-  ("trivial_sizeof", rewrite_trivial_sizeof);
-  ("sizeof", rewrite_sizeof);
   ("merge_function_clauses", merge_funcls);
   ("recheck_defs", Optimize.recheck)
   ]
diff --git a/src/type_check.ml b/src/type_check.ml
index ff56a8f0..11fed096 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -1235,7 +1235,7 @@ let destruct_range env typ =
   in
   match typ_aux with
     | Typ_app (f, [A_aux (A_nexp n, _)])
-         when string_of_id f = "atom" -> Some (List.map kopt_kid kopts, constr, n, n)
+         when string_of_id f = "atom" || string_of_id f = "implicit" -> Some (List.map kopt_kid kopts, constr, n, n)
     | Typ_app (f, [A_aux (A_nexp n1, _); A_aux (A_nexp n2, _)])
          when string_of_id f = "range" -> Some (List.map kopt_kid kopts, constr, n1, n2)
     | _ -> None
@@ -1968,7 +1968,111 @@ let subtype_check env typ1 typ2 =
   | Type_error _ -> false
 
 (**************************************************************************)
-(* 4. Type checking expressions                                           *)
+(* 4. Removing sizeof expressions                                         *)
+(**************************************************************************)
+
+exception No_simple_rewrite;;
+
+let rec rewrite_sizeof' env (Nexp_aux (aux, l) as nexp) =
+  let mk_exp exp = mk_exp ~loc:l exp in
+  match aux with
+  | Nexp_var v ->
+     let locals = Env.get_locals env |> Bindings.bindings in
+     let same_size (local, (_, Typ_aux (aux, _))) =
+       match aux with
+       | Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _)])
+            when string_of_id id = "atom" && Kid.compare v v' = 0 -> true
+
+       | Typ_app (id, [A_aux (A_nexp n, _)]) when string_of_id id = "atom" ->
+          prove __POS__ env (nc_eq (nvar v) n)
+
+       | Typ_app (id, [A_aux (A_nexp (Nexp_aux (Nexp_var v', _)), _); _; _]) when string_of_id id = "vector" ->
+          Kid.compare v v' = 0
+
+       | _ ->
+          false
+     in
+     begin match List.find_opt same_size locals with
+     | Some (id, (_, typ)) -> mk_exp (E_app (mk_id "__size", [mk_exp (E_id id)]))
+     | None -> raise No_simple_rewrite
+     end
+
+  | Nexp_constant c ->
+     mk_lit_exp (L_num c)
+
+  | Nexp_neg nexp ->
+     let exp = rewrite_sizeof' env nexp in
+     mk_exp (E_app (mk_id "negate_atom", [exp]))
+
+  | Nexp_sum (nexp1, nexp2) ->
+     let exp1 = rewrite_sizeof' env nexp1 in
+     let exp2 = rewrite_sizeof' env nexp2 in
+     mk_exp (E_app (mk_id "add_atom", [exp1; exp2]))
+
+  | Nexp_minus (nexp1, nexp2) ->
+     let exp1 = rewrite_sizeof' env nexp1 in
+     let exp2 = rewrite_sizeof' env nexp2 in
+     mk_exp (E_app (mk_id "sub_atom", [exp1; exp2]))
+
+  | Nexp_times (nexp1, nexp2) ->
+     let exp1 = rewrite_sizeof' env nexp1 in
+     let exp2 = rewrite_sizeof' env nexp2 in
+     mk_exp (E_app (mk_id "mult_atom", [exp1; exp2]))
+
+  | Nexp_exp nexp ->
+     let exp = rewrite_sizeof' env nexp in
+     mk_exp (E_app (mk_id "pow2", [exp]))
+
+  | Nexp_app (id, [nexp1; nexp2]) when string_of_id id = "div" ->
+     let exp1 = rewrite_sizeof' env nexp1 in
+     let exp2 = rewrite_sizeof' env nexp2 in
+     mk_exp (E_app (mk_id "div", [exp1; exp2]))
+
+  | Nexp_app _ | Nexp_id _ ->
+     typ_error env l ("Cannot re-write sizeof(" ^ string_of_nexp nexp ^ ")")
+
+let rewrite_sizeof env nexp =
+  try rewrite_sizeof' env nexp with
+  | No_simple_rewrite ->
+     let locals = Env.get_locals env |> Bindings.bindings in
+     let same_size (local, (_, Typ_aux (aux, _))) =
+       match aux with
+       | Typ_app (id, [A_aux (A_nexp n, _)]) when string_of_id id = "atom" ->
+          prove __POS__ env (nc_eq nexp n)
+       | _ -> false
+     in
+     begin match List.find_opt same_size locals with
+     | Some (id, (_, typ)) -> mk_exp (E_app (mk_id "__size", [mk_exp (E_id id)]))
+     | None -> raise No_simple_rewrite
+     end
+
+let rec rewrite_nc env (NC_aux (nc_aux, l)) = mk_exp ~loc:l (rewrite_nc_aux l env nc_aux)
+and rewrite_nc_aux l env =
+  let mk_exp exp = mk_exp ~loc:l exp in
+  function
+  | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2))
+  | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2))
+  | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2))
+  | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2))
+  | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "&", rewrite_nc env nc2)
+  | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc env nc1, mk_id "|", rewrite_nc env nc2)
+  | NC_false -> E_lit (mk_lit L_false)
+  | NC_true -> E_lit (mk_lit L_true)
+  | NC_set (kid, []) -> E_lit (mk_lit (L_false))
+  | NC_set (kid, int :: ints) ->
+     let kid_eq kid int = nc_eq (nvar kid) (nconstant int) in
+     unaux_exp (rewrite_nc env (List.fold_left (fun nc int -> nc_or nc (kid_eq kid int)) (kid_eq kid int) ints))
+  | NC_app (f, [A_aux (A_bool nc, _)]) when string_of_id f = "not" ->
+     E_app (mk_id "not_bool", [rewrite_nc env nc])
+  | NC_app (f, args) ->
+     unaux_exp (rewrite_nc env (Env.expand_constraint_synonyms env (mk_nc (NC_app (f, args)))))
+  | NC_var v ->
+     (* Would be better to translate change E_sizeof to take a kid, then rewrite to E_sizeof *)
+     E_id (id_of_kid v)
+
+
+(**************************************************************************)
+(* 5. Type checking expressions                                           *)
 (**************************************************************************)
 
 (* The type checker produces a fully annoted AST - tannot is the type
@@ -2310,10 +2414,14 @@ let rec filter_casts env from_typ to_typ casts =
        let (quant, cast_typ) = Env.get_val_spec cast env in
        match cast_typ with
        (* A cast should be a function A -> B and have only a single argument type. *)
-       | Typ_aux (Typ_fn ([cast_from_typ], cast_to_typ, _), _)
-            when match_typ env from_typ cast_from_typ && match_typ env to_typ cast_to_typ ->
-          typ_print (lazy ("Considering cast " ^ string_of_typ cast_typ ^ " for " ^ string_of_typ from_typ ^ " to " ^ string_of_typ to_typ));
-          cast :: filter_casts env from_typ to_typ casts
+       | Typ_aux (Typ_fn (arg_typs, cast_to_typ, _), _) ->
+          begin match List.filter is_not_implicit arg_typs with
+          | [cast_from_typ] when match_typ env from_typ cast_from_typ && match_typ env to_typ cast_to_typ ->
+             typ_print (lazy ("Considering cast " ^ string_of_typ cast_typ
+                              ^ " for " ^ string_of_typ from_typ ^ " to " ^ string_of_typ to_typ));
+             cast :: filter_casts env from_typ to_typ casts
+          | _ -> filter_casts env from_typ to_typ casts
+          end
        | _ -> filter_casts env from_typ to_typ casts
      end
   | [] -> []
@@ -3305,10 +3413,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      end
   | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
   | E_sizeof nexp ->
-     annot_exp (E_sizeof nexp) (mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp nexp)])))
+     irule infer_exp env (rewrite_sizeof env nexp)
   | E_constraint nc ->
      Env.wf_constraint env nc;
-     annot_exp (E_constraint nc) (atom_bool_typ nc)
+     crule check_exp env (rewrite_nc env nc) (atom_bool_typ nc)
   | E_field (exp, field) ->
      begin
        let inferred_exp = irule infer_exp env exp in
@@ -3938,7 +4046,7 @@ and infer_mpat allow_unknown other_env env (MP_aux (mpat_aux, (l, ())) as mpat)
      typ_error env l ("Couldn't infer type of mapping-pattern " ^ string_of_mpat mpat)
 
 (**************************************************************************)
-(* 5. Effect system                                                       *)
+(* 6. Effect system                                                       *)
 (**************************************************************************)
 
 let effect_of_annot = function
@@ -4295,7 +4403,7 @@ and propagate_lexp_effect_aux = function
      LEXP_field (p_lexp, id),effect_of_lexp p_lexp
 
 (**************************************************************************)
-(* 6. Checking toplevel definitions                                       *)
+(* 7. Checking toplevel definitions                                       *)
 (**************************************************************************)
 
 let check_letdef orig_env (LB_aux (letbind, (l, _))) =
@@ -4322,6 +4430,7 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ =
   match typ with
   | Typ_aux (Typ_fn (typ_args, typ_ret, eff), _) ->
      begin
+       let typ_args = List.map implicit_to_int typ_args in
        let env = Env.add_ret_typ typ_ret env in
        (* We want to forbid polymorphic undefined values in all cases,
           except when type checking the specific undefined_(type)
@@ -4474,7 +4583,8 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls)
        false, (quant, typ), env
   in
   let vtyp_args, vtyp_ret, declared_eff, vl = match typ with
-    | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) -> vtyp_args, vtyp_ret, declared_eff, vl
+    | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) ->
+       vtyp_args, vtyp_ret, declared_eff, vl
     | _ -> typ_error env l "Function val spec is not a function type"
   in
   check_tannotopt env quant vtyp_ret tannotopt;
-- 
cgit v1.2.3


From 0c42ba405004f697a643135212d74a4369eb61df Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 6 Feb 2019 14:18:29 +0000
Subject: Make sure type synonym errors have correct location info

---
 src/type_check.ml  | 29 ++++++++++++++---------------
 src/type_check.mli |  2 --
 2 files changed, 14 insertions(+), 17 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 712b9944..ae7696a5 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -310,8 +310,8 @@ module Env : sig
   val add_typ_var : l -> kinded_id -> t -> t
   val get_ret_typ : t -> typ option
   val add_ret_typ : typ -> t -> t
-  val add_typ_synonym : id -> (t -> typ_arg list -> typ_arg) -> t -> t
-  val get_typ_synonym : id -> t -> t -> typ_arg list -> typ_arg
+  val add_typ_synonym : id -> (l -> t -> typ_arg list -> typ_arg) -> t -> t
+  val get_typ_synonym : id -> t -> l -> t -> typ_arg list -> typ_arg
   val add_num_def : id -> nexp -> t -> t
   val get_num_def : id -> t -> nexp
   val add_overloads : id -> id list -> t -> t
@@ -370,7 +370,7 @@ end = struct
       variants : (typquant * type_union list) Bindings.t;
       mappings : (typquant * typ * typ) Bindings.t;
       typ_vars : (Ast.l * kind_aux) KBindings.t;
-      typ_synonyms : (t -> typ_arg list -> typ_arg) Bindings.t;
+      typ_synonyms : (Ast.l -> t -> typ_arg list -> typ_arg) Bindings.t;
       num_defs : nexp Bindings.t;
       overloads : (id list) Bindings.t;
       flow : (typ -> typ) Bindings.t;
@@ -521,7 +521,7 @@ end = struct
     | NC_and (nc1, nc2) -> NC_aux (NC_and (expand_constraint_synonyms env nc1, expand_constraint_synonyms env nc2), l)
     | NC_app (id, args) ->
        (try
-          begin match Bindings.find id env.typ_synonyms env args with
+          begin match Bindings.find id env.typ_synonyms l env args with
           | A_aux (A_bool nc, _) -> expand_constraint_synonyms env nc
           | arg -> typ_error l ("Expected Bool when expanding synonym " ^ string_of_id id ^ " got " ^ string_of_typ_arg arg)
           end
@@ -536,7 +536,7 @@ end = struct
     | Typ_bidir (typ1, typ2) -> Typ_aux (Typ_bidir (expand_synonyms env typ1, expand_synonyms env typ2), l)
     | Typ_app (id, args) ->
        (try
-          begin match Bindings.find id env.typ_synonyms env args with
+          begin match Bindings.find id env.typ_synonyms l env args with
           | A_aux (A_typ typ, _) -> expand_synonyms env typ
           | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id)
           end
@@ -544,7 +544,7 @@ end = struct
         | Not_found -> Typ_aux (Typ_app (id, List.map (expand_synonyms_arg env) args), l))
     | Typ_id id ->
        (try
-          begin match Bindings.find id env.typ_synonyms env [] with
+          begin match Bindings.find id env.typ_synonyms l env [] with
           | A_aux (A_typ typ, _) -> expand_synonyms env typ
           | _ -> typ_error l ("Expected Type when expanding synonym " ^ string_of_id id)
           end
@@ -4338,27 +4338,26 @@ let mk_synonym typq typ_arg =
   let ncs = List.map (fun nc -> List.fold_left (fun nc (kopt, fresh) -> constraint_subst (kopt_kid kopt) (arg_kopt fresh) nc) nc kopts) ncs in
   let typ_arg = List.fold_left (fun typ_arg (kopt, fresh) -> typ_arg_subst (kopt_kid kopt) (arg_kopt fresh) typ_arg) typ_arg kopts in
   let kopts = List.map snd kopts in
-  let rec subst_args kopts args =
+  let rec subst_args l kopts args =
     match kopts, args with
     | kopt :: kopts, A_aux (A_nexp arg, _) :: args when is_nat_kopt kopt ->
-       let typ_arg, ncs = subst_args kopts args in
+       let typ_arg, ncs = subst_args l kopts args in
        typ_arg_subst (kopt_kid kopt) (arg_nexp arg) typ_arg,
        List.map (constraint_subst (kopt_kid kopt) (arg_nexp arg)) ncs
     | kopt :: kopts, A_aux (A_typ arg, _) :: args when is_typ_kopt kopt ->
-       let typ_arg, ncs = subst_args kopts args in
+       let typ_arg, ncs = subst_args l kopts args in
        typ_arg_subst (kopt_kid kopt) (arg_typ arg) typ_arg, ncs
     | kopt :: kopts, A_aux (A_order arg, _) :: args when is_order_kopt kopt ->
-       let typ_arg, ncs = subst_args kopts args in
+       let typ_arg, ncs = subst_args l kopts args in
        typ_arg_subst (kopt_kid kopt) (arg_order arg) typ_arg, ncs
     | kopt :: kopts, A_aux (A_bool arg, _) :: args when is_bool_kopt kopt ->
-       let typ_arg, ncs = subst_args kopts args in
+       let typ_arg, ncs = subst_args l kopts args in
        typ_arg_subst (kopt_kid kopt) (arg_bool arg) typ_arg, ncs
     | [], [] -> typ_arg, ncs
-    | _, A_aux (_, l) :: _ -> typ_error l "Synonym applied to bad arguments"
-    | _, _ -> typ_error Parse_ast.Unknown "Synonym applied to bad arguments"
+    | _, _ -> typ_error l "Synonym applied to bad arguments"
   in
-  fun env args ->
-    let typ_arg, ncs = subst_args kopts args in
+  fun l env args ->
+    let typ_arg, ncs = subst_args l kopts args in
     if List.for_all (prove env) ncs
     then typ_arg
     else typ_error Parse_ast.Unknown ("Could not prove constraints " ^ string_of_list ", " string_of_n_constraint ncs
diff --git a/src/type_check.mli b/src/type_check.mli
index f417c65d..aabf09d9 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -150,8 +150,6 @@ module Env : sig
      won't throw any exceptions. *)
   val get_ret_typ : t -> typ option
 
-  val get_typ_synonym : id -> t -> (t -> typ_arg list -> typ_arg)
-
   val get_overloads : id -> t -> id list
 
   val get_num_def : id -> t -> nexp
-- 
cgit v1.2.3


From 55f65f92812a6927d5661c2c25a09051630334b3 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 6 Feb 2019 15:26:32 +0000
Subject: Fix some tests

---
 src/ocaml_backend.ml | 1 +
 src/rewrites.ml      | 8 +-------
 src/sail.ml          | 7 +++++--
 src/type_check.ml    | 1 +
 4 files changed, 8 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index 31c3e093..3f34c422 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -128,6 +128,7 @@ let ocaml_typ_id ctx = function
   | id when Id.compare id (mk_id "list") = 0 -> string "list"
   | id when Id.compare id (mk_id "bit") = 0 -> string "bit"
   | id when Id.compare id (mk_id "int") = 0 -> string "Big_int.num"
+  | id when Id.compare id (mk_id "implicit") = 0 -> string "Big_int.num"
   | id when Id.compare id (mk_id "nat") = 0 -> string "Big_int.num"
   | id when Id.compare id (mk_id "bool") = 0 -> string "bool"
   | id when Id.compare id (mk_id "unit") = 0 -> string "unit"
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 19294698..4b147aee 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -5147,9 +5147,6 @@ let rewrite_defs_ocaml = [
   ("remove_numeral_pats", rewrite_defs_remove_numeral_pats);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
   ("top_sort_defs", top_sort_defs);
-  ("constraint", rewrite_constraint);
-  ("trivial_sizeof", rewrite_trivial_sizeof);
-  ("sizeof", rewrite_sizeof);
   ("simple_types", rewrite_simple_types);
   ("overload_cast", rewrite_overload_cast);
   (* ("separate_numbs", rewrite_defs_separate_numbs) *)
@@ -5184,10 +5181,7 @@ let rewrite_defs_interpreter = [
     ("rewrite_undefined", rewrite_undefined_if_gen false);
     ("vector_concat_assignments", rewrite_vector_concat_assignments);
     ("tuple_assignments", rewrite_tuple_assignments);
-    ("simple_assignments", rewrite_simple_assignments);
-    ("constraint", rewrite_constraint);
-    ("trivial_sizeof", rewrite_trivial_sizeof);
-    ("sizeof", rewrite_sizeof);
+    ("simple_assignments", rewrite_simple_assignments)
   ]
 
 let rewrite_check_annot =
diff --git a/src/sail.ml b/src/sail.ml
index fdf4f5b9..c63c3d19 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -64,7 +64,7 @@ let opt_print_c = ref false
 let opt_print_latex = ref false
 let opt_print_coq = ref false
 let opt_print_cgen = ref false
-let opt_memo_z3 = ref false
+let opt_memo_z3 = ref true
 let opt_sanity = ref false
 let opt_includes_c = ref ([]:string list)
 let opt_libs_lem = ref ([]:string list)
@@ -202,7 +202,10 @@ let options = Arg.align ([
       "<filename>:<line>:<variable> to case split for monomorphisation");
   ( "-memo_z3",
     Arg.Set opt_memo_z3,
-    " memoize calls to z3, improving performance when typechecking repeatedly");
+    " memoize calls to z3, improving performance when typechecking repeatedly (default)");
+  ( "-no_memo_z3",
+    Arg.Clear opt_memo_z3,
+    " do not memoize calls to z3");
   ( "-memo",
     Arg.Tuple [Arg.Set opt_memo_z3; Arg.Set C_backend.opt_memo_cache],
     " memoize calls to z3, and intermediate compilation results");
diff --git a/src/type_check.ml b/src/type_check.ml
index 11fed096..82286491 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -473,6 +473,7 @@ end = struct
     List.fold_left (fun m (name, kinds) -> Bindings.add (mk_id name) (kinds_typq kinds) m) Bindings.empty
       [ ("range", [K_int; K_int]);
         ("atom", [K_int]);
+        ("implicit", [K_int]);
         ("vector", [K_int; K_order; K_type]);
         ("register", [K_type]);
         ("bit", []);
-- 
cgit v1.2.3


From aadbe7ede88dc9bbbda6a09876baacd6797153fb Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Wed, 6 Feb 2019 19:44:22 +0000
Subject: Improve emacs mode

Can now use C-c C-s to start an interactive Sail process, C-c C-l to
load a file, and C-c C-q to kill the sail process. Type errors are
highlighted in the emacs buffer (like with merlin for OCaml) with a
tooltip for the type-error, as well as being displayed in the
minibuffer. Need to add a C-c C-x command like merlin to jump to the
error, and figure out how to handle multiple files nicely, as well as
hooking the save function like tuareg/merlin, but this is already
enough to make working with small examples quite a bit more pleasant.
---
 src/interactive.ml   |   1 +
 src/interactive.mli  |   1 +
 src/isail.ml         | 315 +++++++++++++++++++++++++++++----------------------
 src/process_file.ml  |   2 +
 src/process_file.mli |   2 +
 src/sail.ml          |   3 +
 6 files changed, 190 insertions(+), 134 deletions(-)

(limited to 'src')

diff --git a/src/interactive.ml b/src/interactive.ml
index 3c4619a0..e5fda4cf 100644
--- a/src/interactive.ml
+++ b/src/interactive.ml
@@ -1,5 +1,6 @@
 
 let opt_interactive = ref false
+let opt_emacs_mode = ref false
 let opt_suppress_banner = ref false
 
 let env = ref Type_check.initial_env
diff --git a/src/interactive.mli b/src/interactive.mli
index 7782f646..915193ec 100644
--- a/src/interactive.mli
+++ b/src/interactive.mli
@@ -2,6 +2,7 @@ open Ast
 open Type_check
 
 val opt_interactive : bool ref
+val opt_emacs_mode : bool ref
 val opt_suppress_banner : bool ref
 
 val ast : tannot defs ref
diff --git a/src/isail.ml b/src/isail.ml
index d8cc448a..944b14a2 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -59,6 +59,7 @@ type mode =
   | Evaluation of frame
   | Bytecode of Value2.vl Bytecode_interpreter.gstate * Value2.vl Bytecode_interpreter.stack
   | Normal
+  | Emacs
 
 let current_mode = ref Normal
 
@@ -67,6 +68,7 @@ let prompt () =
   | Normal -> "sail> "
   | Evaluation _ -> "eval> "
   | Bytecode _ -> "ir> "
+  | Emacs -> ""
 
 let eval_clear = ref true
 
@@ -75,6 +77,7 @@ let mode_clear () =
   | 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 =
   match LNoise.linenoise (prompt ()) with
@@ -116,7 +119,7 @@ let sep = "-----------------------------------------------------" |> Util.blue |
 
 let print_program () =
   match !current_mode with
-  | Normal -> ()
+  | Normal | Emacs -> ()
   | Evaluation (Step (out, _, _, stack)) ->
      List.map stack_string stack |> List.rev |> List.iter (fun code -> print_endline (Lazy.force code); print_endline sep);
      print_endline (Lazy.force out)
@@ -142,7 +145,7 @@ let print_program () =
 
 let rec run () =
   match !current_mode with
-  | Normal -> ()
+  | Normal | Emacs -> ()
   | Evaluation frame ->
      begin
        match frame with
@@ -168,7 +171,7 @@ let rec run_steps n =
   print_endline ("step " ^ string_of_int n);
   match !current_mode with
   | _ when n <= 0 -> ()
-  | Normal -> ()
+  | Normal | Emacs -> ()
   | Evaluation frame ->
      begin
        match frame with
@@ -225,6 +228,21 @@ let help = function
   | cmd ->
      "Either invalid command passed to help, or no documentation for " ^ cmd ^ ". Try :help :help."
 
+let format_pos_emacs p1 p2 contents =
+  let open Lexing in
+  let b = Buffer.create 160 in
+  Printf.sprintf "(sail-error %d %d %d %d \"%s\")"
+                 p1.pos_lnum (p1.pos_cnum - p1.pos_bol)
+                 p2.pos_lnum (p2.pos_cnum - p2.pos_bol)
+                 contents
+
+let rec emacs_error l contents =
+  match l with
+  | Parse_ast.Unknown -> "(error \"no location info\")"
+  | Parse_ast.Range (p1, p2) -> format_pos_emacs p1 p2 contents
+  | Parse_ast.Unique (_, l) -> emacs_error l contents
+  | Parse_ast.Documented (_, l) -> emacs_error l contents
+  | Parse_ast.Generated l -> emacs_error l contents
 
 type input = Command of string * string | Expression of string | Empty
 
@@ -253,149 +271,176 @@ let handle_input' input =
   in
 
   (* First handle commands that are mode-independent *)
-  begin
-    match input with
-    | Command (cmd, arg) ->
-       begin
-         match cmd with
-         | ":n" | ":normal" ->
-            current_mode := Normal
-         | ":t" | ":type" ->
-            let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !Interactive.env in
-            pretty_sail stdout (doc_binding (typq, typ));
-            print_newline ();
-         | ":q" | ":quit" ->
-            Value.output_close ();
-            exit 0
-         | ":i" | ":infer" ->
-            let exp = Initial_check.exp_of_string arg in
-            let exp = Type_check.infer_exp !Interactive.env exp in
-            pretty_sail stdout (doc_typ (Type_check.typ_of exp));
-            print_newline ()
-         | ":canon" ->
-            let typ = Initial_check.typ_of_string arg in
-            print_endline (string_of_typ (Type_check.canonicalize !Interactive.env typ))
-         | ":prove" ->
-            let nc = Initial_check.constraint_of_string arg in
-            print_endline (string_of_bool (Type_check.prove __POS__ !Interactive.env nc))
-         | ":v" | ":verbose" ->
+  begin match input with
+  | Command (cmd, arg) ->
+     begin match cmd with
+     | ":n" | ":normal" ->
+        current_mode := Normal
+     | ":t" | ":type" ->
+        let typq, typ = Type_check.Env.get_val_spec (mk_id arg) !Interactive.env in
+        pretty_sail stdout (doc_binding (typq, typ));
+        print_newline ();
+     | ":q" | ":quit" ->
+        Value.output_close ();
+        exit 0
+     | ":i" | ":infer" ->
+        let exp = Initial_check.exp_of_string arg in
+        let exp = Type_check.infer_exp !Interactive.env exp in
+        pretty_sail stdout (doc_typ (Type_check.typ_of exp));
+        print_newline ()
+     | ":canon" ->
+        let typ = Initial_check.typ_of_string arg in
+        print_endline (string_of_typ (Type_check.canonicalize !Interactive.env typ))
+     | ":prove" ->
+        let nc = Initial_check.constraint_of_string arg in
+        print_endline (string_of_bool (Type_check.prove __POS__ !Interactive.env nc))
+     | ":v" | ":verbose" ->
             Type_check.opt_tc_debug := (!Type_check.opt_tc_debug + 1) mod 3;
             print_endline ("Verbosity: " ^ string_of_int !Type_check.opt_tc_debug)
-         | ":clear" ->
-            if arg = "on" then
-              eval_clear := true
-            else if arg = "off" then
-              eval_clear := false
-            else print_endline "Invalid argument for :clear, expected either :clear on or :clear off"
-         | ":commands" ->
-            let commands =
-              [ "Universal commands - :(t)ype :(i)nfer :(q)uit :(v)erbose :clear :commands :help :output :option";
-                "Normal mode commands - :elf :(l)oad :(u)nload";
-                "Evaluation mode commands - :(r)un :(s)tep :(n)ormal";
-                "";
-                ":(c)ommand can be called as either :c or :command." ]
-            in
-            List.iter print_endline commands
-         | ":poly" ->
-            let is_kopt = match arg with
-              | "Int" -> is_nat_kopt
-              | "Type" -> is_typ_kopt
-              | "Order" -> is_order_kopt
-              | _ -> failwith "Invalid kind"
-            in
-            let ids = Specialize.polymorphic_functions is_kopt !Interactive.ast in
-            List.iter (fun id -> print_endline (string_of_id id)) (IdSet.elements ids)
-         | ":option" ->
-            begin
-              try
-                let args = Str.split (Str.regexp " +") arg in
-                Arg.parse_argv ~current:(ref 0) (Array.of_list ("sail" :: args)) Sail.options (fun _ -> ()) "";
-              with
-              | Arg.Bad message | Arg.Help message -> print_endline message
-            end;
-         | ":spec" ->
-            let ast, env = Specialize.specialize !Interactive.ast !Interactive.env in
-            Interactive.ast := ast;
-            Interactive.env := env;
-            interactive_state := initial_state !Interactive.ast Value.primops
-         | ":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.ast in
-            let ast, env = Specialize.specialize 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 PPrint in
-            let is_cdef = function
-              | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true
-              | CDEF_spec (id, _, _) when Id.compare id (mk_id arg) = 0 -> true
-              | _ -> false
-            in
-            let cdefs = List.filter is_cdef !interactive_bytecode in
-            print_endline (Pretty_print_sail.to_string (separate_map hardline pp_cdef cdefs))
-         | ":ast" ->
-            let chan = open_out arg in
-            Pretty_print_sail.pp_defs chan !Interactive.ast;
-            close_out chan
-         | ":output" ->
-            let chan = open_out arg in
-            Value.output_redirect chan
-         | ":help" -> print_endline (help arg)
-         | _ -> recognised := false
-       end
-    | _ -> ()
+     | ":clear" ->
+        if arg = "on" then
+          eval_clear := true
+        else if arg = "off" then
+          eval_clear := false
+        else print_endline "Invalid argument for :clear, expected either :clear on or :clear off"
+     | ":commands" ->
+        let commands =
+          [ "Universal commands - :(t)ype :(i)nfer :(q)uit :(v)erbose :clear :commands :help :output :option";
+            "Normal mode commands - :elf :(l)oad :(u)nload";
+            "Evaluation mode commands - :(r)un :(s)tep :(n)ormal";
+            "";
+            ":(c)ommand can be called as either :c or :command." ]
+        in
+        List.iter print_endline commands
+     | ":poly" ->
+        let is_kopt = match arg with
+          | "Int" -> is_nat_kopt
+          | "Type" -> is_typ_kopt
+          | "Order" -> is_order_kopt
+          | _ -> failwith "Invalid kind"
+        in
+        let ids = Specialize.polymorphic_functions is_kopt !Interactive.ast in
+        List.iter (fun id -> print_endline (string_of_id id)) (IdSet.elements ids)
+     | ":option" ->
+        begin
+          try
+            let args = Str.split (Str.regexp " +") arg in
+            Arg.parse_argv ~current:(ref 0) (Array.of_list ("sail" :: args)) Sail.options (fun _ -> ()) "";
+          with
+          | Arg.Bad message | Arg.Help message -> print_endline message
+        end;
+     | ":spec" ->
+        let ast, env = Specialize.specialize !Interactive.ast !Interactive.env in
+        Interactive.ast := ast;
+        Interactive.env := env;
+        interactive_state := initial_state !Interactive.ast Value.primops
+     | ":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.ast in
+        let ast, env = Specialize.specialize 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 PPrint in
+        let is_cdef = function
+          | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true
+          | CDEF_spec (id, _, _) when Id.compare id (mk_id arg) = 0 -> true
+          | _ -> false
+        in
+        let cdefs = List.filter is_cdef !interactive_bytecode in
+        print_endline (Pretty_print_sail.to_string (separate_map hardline pp_cdef cdefs))
+     | ":ast" ->
+        let chan = open_out arg in
+        Pretty_print_sail.pp_defs chan !Interactive.ast;
+        close_out chan
+     | ":output" ->
+        let chan = open_out arg in
+        Value.output_redirect chan
+     | ":help" -> print_endline (help arg)
+     | _ -> recognised := false
+     end
+  | _ -> ()
   end;
 
   match !current_mode with
   | Normal ->
-     begin
-       match input with
-       | Command (cmd, arg) ->
-          (* Normal mode commands *)
-          begin
-            match cmd with
-            | ":elf" -> Elf_loader.load_elf arg
-            | ":l" | ":load" ->
+     begin match input with
+     | Command (cmd, arg) ->
+        (* Normal mode commands *)
+        begin match cmd with
+        | ":elf" -> Elf_loader.load_elf arg
+        | ":l" | ":load" ->
+           let files = Util.split_on_char ' ' arg in
+           let (_, ast, env) = load_files !Interactive.env files in
+           let ast = Process_file.rewrite_ast_interpreter ast in
+           Interactive.ast := append_ast !Interactive.ast ast;
+           interactive_state := initial_state !Interactive.ast Value.primops;
+           Interactive.env := env;
+           vs_ids := Initial_check.val_spec_ids !Interactive.ast
+        | ":u" | ":unload" ->
+           Interactive.ast := Ast.Defs [];
+           Interactive.env := Type_check.initial_env;
+           interactive_state := initial_state !Interactive.ast Value.primops;
+           vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+           (* 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 ->
+        (* An expression in normal mode is type checked, then puts
+             us in evaluation mode. *)
+        let exp = Type_check.infer_exp !Interactive.env (Initial_check.exp_of_string str) in
+        current_mode := Evaluation (eval_frame (Step (lazy "", !interactive_state, return exp, [])));
+        print_program ()
+     | Empty -> ()
+     end
+
+  | Emacs ->
+     begin match input with
+     | Command (cmd, arg) ->
+        begin match cmd with
+        | ":load" ->
+           begin
+             try
                let files = Util.split_on_char ' ' arg in
                let (_, ast, env) = load_files !Interactive.env files in
-               let ast = Process_file.rewrite_ast_interpreter ast in
                Interactive.ast := append_ast !Interactive.ast ast;
                interactive_state := initial_state !Interactive.ast Value.primops;
                Interactive.env := env;
                vs_ids := Initial_check.val_spec_ids !Interactive.ast
-            | ":u" | ":unload" ->
-               Interactive.ast := Ast.Defs [];
-               Interactive.env := Type_check.initial_env;
-               interactive_state := initial_state !Interactive.ast Value.primops;
-               vs_ids := Initial_check.val_spec_ids !Interactive.ast;
-               (* See initial_check.mli for an explanation of why we need this. *)
-               Initial_check.have_undefined_builtins := false
-            | ":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 ->
-          (* An expression in normal mode is type checked, then puts
-             us in evaluation mode. *)
-          let exp = Type_check.infer_exp !Interactive.env (Initial_check.exp_of_string str) in
-          current_mode := Evaluation (eval_frame (Step (lazy "", !interactive_state, return exp, [])));
-          print_program ()
-       | Empty -> ()
+             with
+             | Reporting.Fatal_error (Err_type (l, msg)) ->
+                print_endline (emacs_error l (String.escaped msg))
+           end
+        | ":unload" ->
+           Interactive.ast := Ast.Defs [];
+           Interactive.env := Type_check.initial_env;
+           interactive_state := initial_state !Interactive.ast Value.primops;
+           vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+           Initial_check.have_undefined_builtins := false;
+           Process_file.clear_symbols ()
+        | _ -> ()
+        end
+     | Expression _ | Empty -> ()
      end
+
   | Evaluation frame ->
      begin match input with
      | Command (cmd, arg) ->
@@ -495,7 +540,9 @@ let () =
 
   if !Interactive.opt_interactive then
     begin
-      List.iter print_endline sail_logo;
+      if not !Interactive.opt_emacs_mode then
+        List.iter print_endline sail_logo
+      else (current_mode := Emacs; Util.opt_colors := false);
       user_input handle_input
     end
   else ()
diff --git a/src/process_file.ml b/src/process_file.ml
index 00013775..98dc725d 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -92,6 +92,8 @@ module StringSet = Set.Make(String)
 
 let symbols = ref StringSet.empty
 
+let clear_symbols () = symbols := StringSet.empty
+
 let cond_pragma l defs =
   let depth = ref 0 in
   let in_then = ref true in
diff --git a/src/process_file.mli b/src/process_file.mli
index 74d847a5..4496e046 100644
--- a/src/process_file.mli
+++ b/src/process_file.mli
@@ -52,6 +52,8 @@
    $include directive that is importing the file, if applicable. *)
 val parse_file : ?loc:Parse_ast.l -> string -> Parse_ast.defs
 
+val clear_symbols : unit -> unit
+
 val convert_ast : Ast.order -> Parse_ast.defs -> unit Ast.defs
 val preprocess_ast : (Arg.key * Arg.spec * Arg.doc) list -> Parse_ast.defs -> Parse_ast.defs
 val check_ast: Type_check.Env.t -> unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t
diff --git a/src/sail.ml b/src/sail.ml
index c63c3d19..3675cb76 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -88,6 +88,9 @@ let options = Arg.align ([
   ( "-iout",
     Arg.String (fun file -> Value.output_redirect (open_out file)),
     "<filename> print interpreter output to file");
+  ( "-emacs",
+    Arg.Set Interactive.opt_emacs_mode,
+    " run sail interactively as an emacs mode child process");
   ( "-no_warn",
     Arg.Clear Util.opt_warnings,
     " do not print warnings");
-- 
cgit v1.2.3


From ddaf05544d182bd75471ce307458daf417c9e17f Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Wed, 6 Feb 2019 23:08:48 +0000
Subject: Emacs mode understands relationships between Sail files

Allow a file sail.json in the same directory as the sail source file
which contains the ordering and options needed for sail files involved
in a specific ISA definition. I have an example for v8.5 in sail-arm.
The interactive Sail process running within emacs then knows about the
relationship between Sail files, so C-c C-l works for files in the ARM
spec. Also added a C-c C-x command to jump to a type error. Requires
yojson library to build interactive Sail.
---
 src/_tags             |  4 ++--
 src/bitfield.ml       | 12 ++++++------
 src/initial_check.ml  | 14 ++++++++------
 src/initial_check.mli |  7 +++++--
 src/isail.ml          | 53 +++++++++++++++++++++++++++++++++++++++++++++++----
 src/process_file.ml   |  6 ++----
 src/process_file.mli  |  1 -
 src/sail.ml           |  4 ++--
 src/state.ml          |  2 +-
 9 files changed, 75 insertions(+), 28 deletions(-)

(limited to 'src')

diff --git a/src/_tags b/src/_tags
index 4630bea8..aac18862 100644
--- a/src/_tags
+++ b/src/_tags
@@ -3,9 +3,9 @@ true: -traverse, debug, use_menhir
 <**/*.ml> and not <**/parser.ml>: bin_annot, annot
 
 <sail.{byte,native}>: package(zarith), package(linksem), package(lem), package(omd), use_pprint
-<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), use_pprint
+<isail.{byte,native}>: package(zarith), package(linenoise), package(linksem), package(lem), package(omd), package(yojson), use_pprint
 
-<isail.ml>: package(linenoise)
+<isail.ml>: package(linenoise), package(yojson)
 <elf_loader.ml>: package(linksem)
 <latex.ml>: package(omd)
 <**/*.m{l,li}>: package(lem)
diff --git a/src/bitfield.ml b/src/bitfield.ml
index afdd5baf..e8250598 100644
--- a/src/bitfield.ml
+++ b/src/bitfield.ml
@@ -75,7 +75,7 @@ let newtype name size order =
       chunk_rem :: List.rev chunks_64
   in
   let nt = Printf.sprintf "struct %s = {\n  %s }" name (Util.string_of_list ",\n  " (fun x -> x) chunks) in
-  ast_of_def_string order nt
+  ast_of_def_string nt
 
 let rec translate_indices hi lo =
   if hi / 64 = lo / 64 then
@@ -97,7 +97,7 @@ let constructor name order start stop =
                      "}"
     ]
   in
-  combine [ast_of_def_string order constructor_val; ast_of_def_string order constructor_function]
+  combine [ast_of_def_string constructor_val; ast_of_def_string constructor_function]
 
 (* For every index range, create a getter and setter *)
 let index_range_getter name field order start stop =
@@ -108,7 +108,7 @@ let index_range_getter name field order start stop =
     Printf.sprintf "v.%s_chunk_%i[%i .. %i]" name chunk start stop
   in
   let irg_function = Printf.sprintf "function _get_%s_%s v = %s" name field (Util.string_of_list " @ " body indices) in
-  combine [ast_of_def_string order irg_val; ast_of_def_string order irg_function]
+  combine [ast_of_def_string irg_val; ast_of_def_string irg_function]
 
 let index_range_setter name field order start stop =
   let indices = translate_indices start stop in
@@ -127,7 +127,7 @@ let index_range_setter name field order start stop =
                      "}"
     ]
   in
-  combine [ast_of_def_string order irs_val; ast_of_def_string order irs_function]
+  combine [ast_of_def_string irs_val; ast_of_def_string irs_function]
 
 let index_range_update name field order start stop =
   let indices = translate_indices start stop in
@@ -145,10 +145,10 @@ let index_range_update name field order start stop =
     ]
   in
   let iru_overload = Printf.sprintf "overload update_%s = {_update_%s_%s}" field name field in
-  combine [ast_of_def_string order iru_val; ast_of_def_string order iru_function; ast_of_def_string order iru_overload]
+  combine [ast_of_def_string iru_val; ast_of_def_string iru_function; ast_of_def_string iru_overload]
 
 let index_range_overload name field order =
-  ast_of_def_string order (Printf.sprintf "overload _mod_%s = {_get_%s_%s, _set_%s_%s}" field name field name field)
+  ast_of_def_string (Printf.sprintf "overload _mod_%s = {_get_%s_%s, _set_%s_%s}" field name field name field)
 
 let index_range_accessor name field order (BF_aux (bf_aux, l)) =
   let getter n m = index_range_getter name field order (Big_int.to_int n) (Big_int.to_int m) in
diff --git a/src/initial_check.ml b/src/initial_check.ml
index ae65f13d..d08ab8cf 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -1010,18 +1010,20 @@ let generate_enum_functions vs_ids (Defs defs) =
 
 let incremental_ctx = ref initial_ctx
 
-let process_ast order defs =
+let process_ast ?generate:(generate=true) defs =
   let ast, ctx = to_ast !incremental_ctx defs in
   incremental_ctx := ctx;
   let vs_ids = val_spec_ids ast in
-  if not !opt_undefined_gen then
+  if not !opt_undefined_gen && generate then
     generate_enum_functions vs_ids ast
-  else
+  else if generate then
     ast
     |> generate_undefineds vs_ids
     |> generate_enum_functions vs_ids
     |> generate_initialize_registers vs_ids
-
-let ast_of_def_string order str =
+  else
+    ast
+  
+let ast_of_def_string str =
   let def = Parser.def_eof Lexer.token (Lexing.from_string str) in
-  process_ast order (P.Defs [def])
+  process_ast (P.Defs [def])
diff --git a/src/initial_check.mli b/src/initial_check.mli
index 9d2beab2..a0bde482 100644
--- a/src/initial_check.mli
+++ b/src/initial_check.mli
@@ -82,8 +82,11 @@ val opt_enum_casts : bool ref
    all the loaded files. *)
 val have_undefined_builtins : bool ref
 
-val ast_of_def_string : order -> string -> unit defs
-val process_ast : order -> Parse_ast.defs -> unit defs
+val ast_of_def_string : string -> unit defs
+
+(** If the generate flag is false, then we won't generate any
+   auxilliary definitions, like the initialize_registers function *)
+val process_ast : ?generate:bool -> Parse_ast.defs -> unit defs
 
 val val_spec_ids : 'a defs -> IdSet.t
 
diff --git a/src/isail.ml b/src/isail.ml
index 944b14a2..d245ab14 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -238,12 +238,56 @@ let format_pos_emacs p1 p2 contents =
 
 let rec emacs_error l contents =
   match l with
-  | Parse_ast.Unknown -> "(error \"no location info\")"
+  | Parse_ast.Unknown -> "(error \"no location info: " ^ contents ^ "\")"
   | Parse_ast.Range (p1, p2) -> format_pos_emacs p1 p2 contents
   | Parse_ast.Unique (_, l) -> emacs_error l contents
   | Parse_ast.Documented (_, l) -> emacs_error l contents
   | Parse_ast.Generated l -> emacs_error l contents
 
+type session = {
+    id : string;
+    files : string list
+  }
+
+let default_session = {
+    id = "none";
+    files = []
+  }
+
+let session = ref default_session
+
+let parse_session file =
+  let open Yojson.Basic.Util in
+  if Sys.file_exists file then
+    let json = Yojson.Basic.from_file file in
+    let args = Str.split (Str.regexp " +") (json |> member "options" |> to_string) in
+    Arg.parse_argv ~current:(ref 0) (Array.of_list ("sail" :: args)) Sail.options (fun _ -> ()) "";
+    print_endline ("(message \"Using session " ^ file ^ "\")");
+    {
+      id = file;
+      files = json |> member "files" |> convert_each to_string
+    }
+  else
+    default_session
+
+let load_session upto file =
+  match upto with
+  | None -> None
+  | Some upto_file when Filename.basename upto_file = file -> None
+  | Some upto_file ->
+     let (_, ast, env) =
+       load_files ~generate:false !Interactive.env [Filename.concat (Filename.dirname upto_file) file]
+     in
+     Interactive.ast := append_ast !Interactive.ast ast;
+     Interactive.env := env;
+     print_endline ("(message \"Checked " ^ file ^ "...\")\n");
+     Some upto_file
+
+let load_into_session file =
+  let session_file = Filename.concat (Filename.dirname file) "sail.json" in
+  session := (if session_file = !session.id then !session else parse_session session_file);
+  ignore (List.fold_left load_session (Some file) !session.files)
+
 type input = Command of string * string | Expression of string | Empty
 
 (* This function is called on every line of input passed to the interpreter *)
@@ -419,12 +463,13 @@ let handle_input' input =
         | ":load" ->
            begin
              try
-               let files = Util.split_on_char ' ' arg in
-               let (_, ast, env) = load_files !Interactive.env files in
+               load_into_session arg;
+               let (_, ast, env) = load_files !Interactive.env [arg] in
                Interactive.ast := append_ast !Interactive.ast ast;
                interactive_state := initial_state !Interactive.ast Value.primops;
                Interactive.env := env;
-               vs_ids := Initial_check.val_spec_ids !Interactive.ast
+               vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+               print_endline ("(message \"Checked " ^ arg ^ " done\")\n");
              with
              | Reporting.Fatal_error (Err_type (l, msg)) ->
                 print_endline (emacs_error l (String.escaped msg))
diff --git a/src/process_file.ml b/src/process_file.ml
index 98dc725d..e8f255ff 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -239,12 +239,10 @@ let rec preprocess opts = function
 
 let preprocess_ast opts (Parse_ast.Defs defs) = Parse_ast.Defs (preprocess opts defs)
 
-let convert_ast (order : Ast.order) (defs : Parse_ast.defs) : unit Ast.defs = Initial_check.process_ast order defs
-
-let load_file_no_check opts order f = convert_ast order (preprocess_ast opts (parse_file f))
+let load_file_no_check opts order f = Initial_check.process_ast (preprocess_ast opts (parse_file f))
 
 let load_file opts order env f =
-  let ast = convert_ast order (preprocess_ast opts (parse_file f)) in
+  let ast = Initial_check.process_ast (preprocess_ast opts (parse_file f)) in
   Type_error.check env ast
 
 let opt_just_check = ref false
diff --git a/src/process_file.mli b/src/process_file.mli
index 4496e046..f75f6687 100644
--- a/src/process_file.mli
+++ b/src/process_file.mli
@@ -54,7 +54,6 @@ val parse_file : ?loc:Parse_ast.l -> string -> Parse_ast.defs
 
 val clear_symbols : unit -> unit
 
-val convert_ast : Ast.order -> Parse_ast.defs -> unit Ast.defs
 val preprocess_ast : (Arg.key * Arg.spec * Arg.doc) list -> Parse_ast.defs -> Parse_ast.defs
 val check_ast: Type_check.Env.t -> unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t
 val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
diff --git a/src/sail.ml b/src/sail.ml
index 3675cb76..286141ab 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -312,7 +312,7 @@ let _ =
       opt_file_arguments := (!opt_file_arguments) @ [s])
     usage_msg
 
-let load_files type_envs files =
+let load_files ?generate:(generate=true) type_envs files =
   if !opt_memo_z3 then Constraint.load_digests () else ();
 
   let t = Profile.start () in
@@ -321,7 +321,7 @@ let load_files type_envs files =
     List.fold_right (fun (_, Parse_ast.Defs ast_nodes) (Parse_ast.Defs later_nodes)
                      -> Parse_ast.Defs (ast_nodes@later_nodes)) parsed (Parse_ast.Defs []) in
   let ast = Process_file.preprocess_ast options ast in
-  let ast = convert_ast Ast_util.inc_ord ast in
+  let ast = Initial_check.process_ast ~generate:generate ast in
   Profile.finish "parsing" t;
 
   let t = Profile.start () in
diff --git a/src/state.ml b/src/state.ml
index 74bc97b2..86fd8395 100644
--- a/src/state.ml
+++ b/src/state.ml
@@ -58,7 +58,7 @@ open PPrint
 open Pretty_print_common
 open Pretty_print_sail
 
-let defs_of_string = ast_of_def_string Ast_util.inc_ord
+let defs_of_string = ast_of_def_string
 
 let is_defined defs name = IdSet.mem (mk_id name) (ids_of_defs (Defs defs))
 
-- 
cgit v1.2.3


From a0798a777d800f6255a1370806435a51d418a249 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 7 Feb 2019 15:06:05 +0000
Subject: Fix implicits in v8.2 public ARM spec

---
 src/sail.ml       | 25 ++++---------------------
 src/type_check.ml |  6 +++---
 2 files changed, 7 insertions(+), 24 deletions(-)

(limited to 'src')

diff --git a/src/sail.ml b/src/sail.ml
index 286141ab..2903e802 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -294,12 +294,8 @@ let version =
   let default = Printf.sprintf "Sail %s @ %s" branch commit in
   (* version is parsed from the output of git describe *)
   match String.split_on_char '-' version with
-  | [vnum; _; _] ->
-     (try
-        let vnum = float_of_string vnum +. 2.0 in
-        Printf.sprintf "Sail %.1f (%s @ %s)" vnum branch commit
-      with
-      | Failure _ -> default)
+  | (vnum :: _) ->
+     Printf.sprintf "Sail %s (%s @ %s)" vnum branch commit
   | _ -> default
 
 let usage_msg =
@@ -340,22 +336,9 @@ let load_files ?generate:(generate=true) type_envs files =
 
   (out_name, ast, type_envs)
 
-let print_version () =
-  let open Manifest in
-  let default = Printf.sprintf "Sail %s @ %s" branch commit in
-  (* version is the output of git describe *)
-  match String.split_on_char '-' version with
-  | [vnum; _; _] ->
-     (try
-        let vnum = float_of_string vnum +. 2.0 in
-        Printf.printf "Sail %.1f (%s @ %s)\n" vnum branch commit
-      with
-      | Failure _ -> print_endline default)
-  | _ -> print_endline default
-
 let main() =
-  if !opt_print_version
-  then print_version ()
+  if !opt_print_version then
+    print_endline version
   else
     let out_name, ast, type_envs = load_files Type_check.initial_env !opt_file_arguments in
     Util.opt_warnings := false; (* Don't show warnings during re-writing for now *)
diff --git a/src/type_check.ml b/src/type_check.ml
index 82286491..8fca2c7a 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2032,7 +2032,7 @@ let rec rewrite_sizeof' env (Nexp_aux (aux, l) as nexp) =
   | Nexp_app _ | Nexp_id _ ->
      typ_error env l ("Cannot re-write sizeof(" ^ string_of_nexp nexp ^ ")")
 
-let rewrite_sizeof env nexp =
+let rewrite_sizeof l env nexp =
   try rewrite_sizeof' env nexp with
   | No_simple_rewrite ->
      let locals = Env.get_locals env |> Bindings.bindings in
@@ -2044,7 +2044,7 @@ let rewrite_sizeof env nexp =
      in
      begin match List.find_opt same_size locals with
      | Some (id, (_, typ)) -> mk_exp (E_app (mk_id "__size", [mk_exp (E_id id)]))
-     | None -> raise No_simple_rewrite
+     | None -> typ_error env l ("Cannot re-write sizeof(" ^ string_of_nexp nexp ^ ")")
      end
 
 let rec rewrite_nc env (NC_aux (nc_aux, l)) = mk_exp ~loc:l (rewrite_nc_aux l env nc_aux)
@@ -3414,7 +3414,7 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      end
   | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
   | E_sizeof nexp ->
-     irule infer_exp env (rewrite_sizeof env nexp)
+     irule infer_exp env (rewrite_sizeof l env nexp)
   | E_constraint nc ->
      Env.wf_constraint env nc;
      crule check_exp env (rewrite_nc env nc) (atom_bool_typ nc)
-- 
cgit v1.2.3


From 79438c3822d86169680188280ddfabe77395de82 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 7 Feb 2019 15:54:07 +0000
Subject: Add a symbol for new implicit arguments for backwards compatability

Fix monomorphisation tests
---
 src/monomorphise.ml | 11 +++++++++++
 src/process_file.ml |  8 ++++++--
 2 files changed, 17 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index f458716b..2b6da219 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -3416,6 +3416,17 @@ let rec sets_from_assert e =
                [E_aux (E_sizeof (Nexp_aux (Nexp_var kid,_)),_);
                 E_aux (E_lit (L_aux (L_num i,_)),_)]) ->
          (check_kid kid; [i])
+      (* TODO: Now that E_constraint is re-written by the typechecker,
+         we'll end up with the following for the above - some of this
+         function is probably redundant now *)
+      | E_app (Id_aux (Id "eq_int",_),
+               [E_aux (E_app (Id_aux (Id "__id", _), [E_aux (E_id id, annot)]), _);
+                E_aux (E_lit (L_aux (L_num i,_)),_)]) ->
+         begin match typ_of_annot annot with
+         | Typ_aux (Typ_app (Id_aux (Id "atom", _), [A_aux (A_nexp (Nexp_aux (Nexp_var kid, _)), _)]), _) ->
+            check_kid kid; [i]
+         | _ -> raise Not_found
+         end
       | _ -> raise Not_found
     in try
          let is = aux e in
diff --git a/src/process_file.ml b/src/process_file.ml
index e8f255ff..94a6cd3e 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -90,9 +90,13 @@ let parse_file ?loc:(l=Parse_ast.Unknown) (f : string) : Parse_ast.defs =
 (* Simple preprocessor features for conditional file loading *)
 module StringSet = Set.Make(String)
 
-let symbols = ref StringSet.empty
+let default_symbols =
+  List.fold_left (fun set str -> StringSet.add str set) StringSet.empty
+    [ "FEATURE_IMPLICITS" ]
 
-let clear_symbols () = symbols := StringSet.empty
+let symbols = ref default_symbols
+
+let clear_symbols () = symbols := default_symbols
 
 let cond_pragma l defs =
   let depth = ref 0 in
-- 
cgit v1.2.3


From 6fffd6ef54ab33441d08f40f56f27daa9c5b333e Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 7 Feb 2019 18:59:48 +0000
Subject: Monomorphisation tweaks for v8.5

Various tweaks to the monomorphisation rewrites.  Disable old sizeof
rewriting for Lem backend and rely on the type checker rewriting
implicit arguments.  Also avoid unifying nexps with sums, as this can
easily fail due to commutativity and associativity.
---
 src/monomorphise.ml | 168 ++++++++++++++++++++++++++++++++++++----------------
 src/rewrites.ml     |  12 +++-
 src/type_check.ml   |  58 +++++++++++-------
 3 files changed, 166 insertions(+), 72 deletions(-)

(limited to 'src')

diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 2b6da219..8c52fce1 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -2263,9 +2263,12 @@ let replace_with_the_value bound_nexps (E_aux (_,(l,_)) as exp) =
       prove __POS__ env (NC_aux (NC_equal (size,nexp), Parse_ast.Unknown))
     in
     if is_nexp_constant size then size else
-      match List.find is_equal bound_nexps with
-      | nexp -> nexp
-      | exception Not_found -> size
+      match solve env size with
+      | Some n -> nconstant n
+      | None ->
+         match List.find is_equal bound_nexps with
+         | nexp -> nexp
+         | exception Not_found -> size
   in
   let mk_exp nexp l l' =
     let nexp = replace_size nexp in
@@ -2419,15 +2422,15 @@ in *)
       | Some exp -> Some (fold_exp { id_exp_alg with e_app = rewrite_e_app } exp) in
     FCL_aux (FCL_Funcl (id,construct_pexp (pat,guard,body,(pl,empty_tannot))),(l,empty_tannot))
   in
-  let rewrite_letbind lb =
-    let rewrite_e_app (id,args) =
-      match Bindings.find id fn_sizes with
-      | to_change,_ ->
-         let args' = mapat (replace_with_the_value []) to_change args in
-         E_app (id,args')
-      | exception Not_found -> E_app (id,args)
-    in fold_letbind { id_exp_alg with e_app = rewrite_e_app } lb
+  let rewrite_e_app (id,args) =
+    match Bindings.find id fn_sizes with
+    | to_change,_ ->
+       let args' = mapat (replace_with_the_value []) to_change args in
+       E_app (id,args')
+    | exception Not_found -> E_app (id,args)
   in
+  let rewrite_letbind = fold_letbind { id_exp_alg with e_app = rewrite_e_app } in
+  let rewrite_exp = fold_exp { id_exp_alg with e_app = rewrite_e_app } in
   let rewrite_def = function
     | DEF_fundef (FD_aux (FD_function (recopt,tannopt,effopt,funcls),(l,_))) ->
        (* TODO rewrite tannopt? *)
@@ -2449,6 +2452,8 @@ in *)
          | _ -> spec
          | exception Not_found -> spec
        end
+    | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), a)) ->
+       DEF_reg_dec (DEC_aux (DEC_config (id, typ, rewrite_exp exp), a))
     | def -> def
   in
 (*
@@ -3671,14 +3676,18 @@ let is_constant_vec_typ env typ =
 (* We have to add casts in here with appropriate length information so that the
    type checker knows the expected return types. *)
 
-let rewrite_app env typ (id,args) =
+let rec rewrite_app env typ (id,args) =
   let is_append = is_id env (Id "append") in
+  let is_subrange = is_id env (Id "vector_subrange") in
+  let is_slice = is_id env (Id "slice") in
+  let is_zeros = is_id env (Id "Zeros") in
   let is_zero_extend =
-    is_id env (Id "Extend") id || is_id env (Id "ZeroExtend") id ||
+    is_id env (Id "ZeroExtend") id ||
     is_id env (Id "zero_extend") id || is_id env (Id "sail_zero_extend") id ||
     is_id env (Id "mips_zero_extend") id
   in
-  let try_cast_to_typ (E_aux (e,_) as exp) =
+  let mk_exp e = E_aux (e, (Unknown, empty_tannot)) in
+  let try_cast_to_typ (E_aux (e,(l, _)) as exp) =
     let (size,order,bittyp) = vector_typ_args_of (Env.base_typ_of env typ) in
     match size with
     | Nexp_aux (Nexp_constant _,_) -> E_cast (typ,exp)
@@ -3688,9 +3697,6 @@ let rewrite_app env typ (id,args) =
   in
   let rewrap e = E_aux (e, (Unknown, empty_tannot)) in
   if is_append id then
-    let is_subrange = is_id env (Id "vector_subrange") in
-    let is_slice = is_id env (Id "slice") in
-    let is_zeros = is_id env (Id "Zeros") in
     match args with
       (* (known-size-vector @ variable-vector) @ variable-vector *)
     | [E_aux (E_app (append,
@@ -3750,6 +3756,14 @@ let rewrite_app env typ (id,args) =
                            (Unknown,empty_tannot))])
        end
 
+    (* variable-slice @ zeros *)
+    | [E_aux (E_app (slice1, [vector1; start1; len1]),_);
+       E_aux (E_app (zeros2, [len2]),_)]
+        when is_slice slice1 && is_zeros zeros2 &&
+          not (is_constant start1 && is_constant len1 && is_constant len2) ->
+       try_cast_to_typ
+         (mk_exp (E_app (mk_id "place_slice", [vector1; start1; len1; len2])))
+
     (* variable-range @ variable-range *)
     | [E_aux (E_app (subrange1,
                      [vector1; start1; end1]),_);
@@ -3803,9 +3817,14 @@ let rewrite_app env typ (id,args) =
        end
     | _ -> E_app (id,args)
 
-  else if is_id env (Id "eq_vec") id then
+  else if is_id env (Id "eq_vec") id || is_id env (Id "neq_vec") id then
     (* variable-range == variable_range *)
     let is_subrange = is_id env (Id "vector_subrange") in
+    let wrap e =
+      if is_id env (Id "neq_vec") id
+      then E_app (mk_id "not_bool", [mk_exp e])
+      else e
+    in
     match args with
     | [E_aux (E_app (subrange1,
                      [vector1; start1; end1]),_);
@@ -3813,17 +3832,37 @@ let rewrite_app env typ (id,args) =
                      [vector2; start2; end2]),_)]
         when is_subrange subrange1 && is_subrange subrange2 &&
           not (is_constant_range (start1, end1) || is_constant_range (start2, end2)) ->
-       E_app (mk_id "subrange_subrange_eq",
-              [vector1; start1; end1; vector2; start2; end2])
+       wrap (E_app (mk_id "subrange_subrange_eq",
+              [vector1; start1; end1; vector2; start2; end2]))
+    | [E_aux (E_app (slice1,
+                     [vector1; len1; start1]),_);
+       E_aux (E_app (slice2,
+                     [vector2; len2; start2]),_)]
+        when is_slice slice1 && is_slice slice2 &&
+          not (is_constant len1 && is_constant start1 && is_constant len2 && is_constant start2) ->
+       let upper start len =
+         mk_exp (E_app_infix (start, mk_id "+",
+                       mk_exp (E_app_infix (len, mk_id "-",
+                                     mk_exp (E_lit (mk_lit (L_num (Big_int.of_int 1))))))))
+       in
+       wrap (E_app (mk_id "subrange_subrange_eq",
+              [vector1; upper start1 len1; start1; vector2; upper start2 len2; start2]))
+    | [E_aux (E_app (slice1, [vector1; start1; len1]), _);
+       E_aux (E_app (zeros2, _), _)]
+      when is_slice slice1 && is_zeros zeros2 && not (is_constant len1) ->
+       wrap (E_app (mk_id "is_zeros_slice", [vector1; start1; len1]))
     | _ -> E_app (id,args)
 
   else if is_id env (Id "IsZero") id then
     match args with
     | [E_aux (E_app (subrange1, [vector1; start1; end1]),_)]
-        when is_id env (Id "vector_subrange") subrange1 &&
+        when (is_id env (Id "vector_subrange") subrange1) &&
           not (is_constant_range (start1,end1)) ->
-       E_app (mk_id "is_zero_subrange",
-              [vector1; start1; end1])
+       E_app (mk_id "is_zero_subrange", [vector1; start1; end1])
+    | [E_aux (E_app (slice1, [vector1; start1; len1]),_)]
+        when (is_slice slice1) &&
+          not (is_constant len1) ->
+       E_app (mk_id "is_zeros_slice", [vector1; start1; len1])
     | _ -> E_app (id,args)
 
   else if is_id env (Id "IsOnes") id then
@@ -3833,6 +3872,9 @@ let rewrite_app env typ (id,args) =
           not (is_constant_range (start1,end1)) ->
        E_app (mk_id "is_ones_subrange",
               [vector1; start1; end1])
+    | [E_aux (E_app (slice1, [vector1; start1; len1]),_)]
+        when is_slice slice1 && not (is_constant len1) ->
+       E_app (mk_id "is_ones_slice", [vector1; start1; len1])
     | _ -> E_app (id,args)
 
   else if is_zero_extend then
@@ -3840,52 +3882,59 @@ let rewrite_app env typ (id,args) =
     let is_slice = is_id env (Id "slice") in
     let is_zeros = is_id env (Id "Zeros") in
     let is_ones = is_id env (Id "Ones") in
-    match args with
-    | (E_aux (E_app (append1,
+    let length_arg = List.filter (fun arg -> is_number (typ_of arg)) args in
+    match List.filter (fun arg -> not (is_number (typ_of arg))) args with
+    | [E_aux (E_app (append1,
                      [E_aux (E_app (subrange1, [vector1; start1; end1]), _);
-                      E_aux (E_app (zeros1, [len1]),_)]),_))::
-        ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
+                      E_aux (E_app (zeros1, [len1]),_)]),_)]
         when is_subrange subrange1 && is_zeros zeros1 && is_append append1
-      -> try_cast_to_typ (rewrap (E_app (mk_id "place_subrange", [vector1; start1; end1; len1])))
+      -> try_cast_to_typ (rewrap (E_app (mk_id "place_subrange", length_arg @ [vector1; start1; end1; len1])))
 
-    | (E_aux (E_app (append1,
+    | [E_aux (E_app (append1,
                      [E_aux (E_app (slice1, [vector1; start1; length1]), _);
-                      E_aux (E_app (zeros1, [length2]),_)]),_))::
-        ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
+                      E_aux (E_app (zeros1, [length2]),_)]),_)]
         when is_slice slice1 && is_zeros zeros1 && is_append append1
-      -> try_cast_to_typ (rewrap (E_app (mk_id "place_slice", [vector1; start1; length1; length2])))
+      -> try_cast_to_typ (rewrap (E_app (mk_id "place_slice", length_arg @ [vector1; start1; length1; length2])))
 
     (* If we've already rewritten to slice_slice_concat or subrange_subrange_concat,
        we can just drop the zero extension because those functions can do it
        themselves *)
-    | (E_aux (E_cast (_, (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_))),_))::
-        ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
-      -> try_cast_to_typ (rewrap (E_app (op, args)))
+    | [E_aux (E_cast (_, (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat" | Id "place_slice"),_) as op, args),_))),_)]
+      -> try_cast_to_typ (rewrap (E_app (op, length_arg @ args)))
 
-    | (E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat"),_) as op, args),_))::
-        ([] | [_;E_aux (E_id (Id_aux (Id "unsigned",_)),_)])
-      -> try_cast_to_typ (rewrap (E_app (op, args)))
+    | [E_aux (E_app (Id_aux ((Id "slice_slice_concat" | Id "subrange_subrange_concat" | Id "place_slice"),_) as op, args),_)]
+      -> try_cast_to_typ (rewrap (E_app (op, length_arg @ args)))
 
     | [E_aux (E_app (slice1, [vector1; start1; length1]),_)]
         when is_slice slice1 && not (is_constant length1) ->
-       try_cast_to_typ (rewrap (E_app (mk_id "zext_slice", [vector1; start1; length1])))
+       try_cast_to_typ (rewrap (E_app (mk_id "zext_slice", length_arg @ [vector1; start1; length1])))
 
-    | [E_aux (E_app (ones, [len1]),_);
-       _ (* unnecessary ZeroExtend length *)]
-        when is_ones ones ->
-       try_cast_to_typ (rewrap (E_app (mk_id "zext_ones", [len1])))
+    | [E_aux (E_app (ones, [len1]),_)] when is_ones ones ->
+       try_cast_to_typ (rewrap (E_app (mk_id "zext_ones", length_arg @ [len1])))
 
     | _ -> E_app (id,args)
 
   else if is_id env (Id "SignExtend") id || is_id env (Id "sign_extend") id then
     let is_slice = is_id env (Id "slice") in
-    match args with
+    let length_arg = List.filter (fun arg -> is_number (typ_of arg)) args in
+    match List.filter (fun arg -> not (is_number (typ_of arg))) args with
     | [E_aux (E_app (slice1, [vector1; start1; length1]),_)]
         when is_slice slice1 && not (is_constant length1) ->
-       E_app (mk_id "sext_slice", [vector1; start1; length1])
+       try_cast_to_typ (rewrap (E_app (mk_id "sext_slice", length_arg @ [vector1; start1; length1])))
+
+    | [E_aux (E_app (append,
+         [E_aux (E_app (slice1, [vector1; start1; len1]), _);
+          E_aux (E_app (zeros2, [len2]), _)]), _)]
+      when is_append append && is_slice slice1 && is_zeros zeros2 &&
+           not (is_constant len1 && is_constant len2) ->
+       E_app (mk_id "place_slice_signed", length_arg @ [vector1; start1; len1; len2])
+
+    | [E_aux (E_cast (_, (E_aux (E_app (Id_aux ((Id "place_slice"),_), args),_))),_)]
+    | [E_aux (E_app (Id_aux ((Id "place_slice"),_), args),_)]
+      -> try_cast_to_typ (rewrap (E_app (mk_id "place_slice_signed", length_arg @ args)))
 
       (* If the original had a length, keep it *)
-    | [E_aux (E_app (slice1, [vector1; start1; length1]),_);length2]
+    (* | [E_aux (E_app (slice1, [vector1; start1; length1]),_);length2]
         when is_slice slice1 && not (is_constant length1) ->
        begin
          match Type_check.destruct_atom_nexp (env_of length2) (typ_of length2) with
@@ -3895,10 +3944,18 @@ let rewrite_app env typ (id,args) =
             E_cast (vector_typ nlen order bittyp,
                     E_aux (E_app (mk_id "sext_slice", [vector1; start1; length1]),
                            (Unknown,empty_tannot)))
-       end
+       end *)
 
     | _ -> E_app (id,args)
 
+  else if is_id env (Id "Extend") id then
+    match args with
+    | [vector; len; unsigned] ->
+       let extz = mk_exp (rewrite_app env typ (mk_id "ZeroExtend", [vector; len])) in
+       let exts = mk_exp (rewrite_app env typ (mk_id "SignExtend", [vector; len])) in
+       E_if (unsigned, extz, exts)
+    | _ -> E_app (id, args)
+
   else if is_id env (Id "UInt") id || is_id env (Id "unsigned") id then
     let is_slice = is_id env (Id "slice") in
     let is_subrange = is_id env (Id "vector_subrange") in
@@ -3912,6 +3969,13 @@ let rewrite_app env typ (id,args) =
 
     | _ -> E_app (id,args)
 
+  else if is_id env (Id "__SetSlice_bits") id then
+    match args with
+    | [len; slice_len; vector; pos; E_aux (E_app (zeros, _), _)]
+      when is_zeros zeros ->
+       E_app (mk_id "set_slice_zeros", [len; slice_len; vector; pos])
+    | _ -> E_app (id, args)
+
   else E_app (id,args)
 
 let rewrite_aux = function
@@ -4412,7 +4476,9 @@ let rewrite_toplevel_nexps (Defs defs) =
             VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (tqs,typ),ts_l),id,ext_opt,is_cast),ann) in
           Some (id, nexp_map, vs)
   in
-  let rewrite_typ_in_body env nexp_map typ =
+  (* Changing types in the body confuses simple sizeof rewriting, so turn it
+     off for now *)
+  (* let rewrite_typ_in_body env nexp_map typ =
     let rec aux (Typ_aux (t,l) as typ_full) =
     match t with
     | Typ_tup typs -> Typ_aux (Typ_tup (List.map aux typs),l)
@@ -4468,19 +4534,19 @@ let rewrite_toplevel_nexps (Defs defs) =
     match Bindings.find id spec_map with
     | nexp_map -> FCL_aux (FCL_Funcl (id,rewrite_body nexp_map pexp),ann)
     | exception Not_found -> funcl
-  in
+  in *)
   let rewrite_def spec_map def =
     match def with
     | DEF_spec vs -> (match rewrite_valspec vs with
       | None -> spec_map, def
       | Some (id, nexp_map, vs) -> Bindings.add id nexp_map spec_map, DEF_spec vs)
-    | DEF_fundef (FD_aux (FD_function (recopt,_,eff,funcls),ann)) ->
+    (* | DEF_fundef (FD_aux (FD_function (recopt,_,eff,funcls),ann)) ->
        (* Type annotations on function definitions will have been turned into
           valspecs by type checking, so it should be safe to drop them rather
           than updating them. *)
        let tann = Typ_annot_opt_aux (Typ_annot_opt_none,Generated Unknown) in
        spec_map,
-       DEF_fundef (FD_aux (FD_function (recopt,tann,eff,List.map (rewrite_funcl spec_map) funcls),ann))
+       DEF_fundef (FD_aux (FD_function (recopt,tann,eff,List.map (rewrite_funcl spec_map) funcls),ann)) *)
     | _ -> spec_map, def
   in
   let _, defs = List.fold_left (fun (spec_map,t) def ->
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 4b147aee..5cbc3545 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -4012,6 +4012,16 @@ let rewrite_defs_remove_superfluous_letbinds =
           E_aux (E_internal_return (exp1),e1annot)
        | _ -> E_aux (exp,annot)
        end
+    | E_internal_plet (_, E_aux (E_throw e, a), _) -> E_aux (E_throw e, a)
+    | E_internal_plet (_, E_aux (E_assert (c, msg), a), _) ->
+       begin match typ_of c with
+       | Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool nc, _)]), _)
+         when prove __POS__ (env_of c) (nc_not nc) ->
+          (* Drop rest of block after an 'assert(false)' *)
+          E_aux (E_exit (infer_exp (env_of c) (mk_lit_exp L_unit)), a)
+       | _ ->
+          E_aux (exp, annot)
+       end
     | _ -> E_aux (exp,annot) in
 
   let alg = { id_exp_alg with e_aux = e_aux } in
@@ -5064,7 +5074,7 @@ let rewrite_defs_lem = [
   (* ("remove_assert", rewrite_defs_remove_assert); *)
   ("top_sort_defs", top_sort_defs);
   ("trivial_sizeof", rewrite_trivial_sizeof);
-  ("sizeof", rewrite_sizeof);
+  (* ("sizeof", rewrite_sizeof); *)
   ("early_return", rewrite_defs_early_return);
   ("fix_val_specs", rewrite_fix_val_specs);
   (* early_return currently breaks the types *)
diff --git a/src/type_check.ml b/src/type_check.ml
index 8fca2c7a..7faa0234 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -689,6 +689,8 @@ end = struct
        typ_error env l "Bidirectional types cannot be the same on both sides"
     | Typ_bidir (typ1, typ2) -> wf_typ ~exs:exs env typ1; wf_typ ~exs:exs env typ2
     | Typ_tup typs -> List.iter (wf_typ ~exs:exs env) typs
+    | Typ_app (id, [A_aux (A_nexp _, _) as arg]) when string_of_id id = "implicit" ->
+       wf_typ_arg ~exs:exs env arg
     | Typ_app (id, args) when bound_typ_id env id ->
        List.iter (wf_typ_arg ~exs:exs env) args;
        check_args_typquant id env args (infer_kind env id)
@@ -1612,12 +1614,12 @@ and unify_nexp l env goals (Nexp_aux (nexp_aux1, _) as nexp1) (Nexp_aux (nexp_au
          else begin
            match nexp_aux2 with
            | Nexp_sum (n2a, n2b) ->
-              if nexp_identical n1a n2a
-              then unify_nexp l env goals n1b n2b
+              if KidSet.is_empty (nexp_frees n2a)
+              then unify_nexp l env goals n2b (nminus nexp1 n2a)
               else
-                if nexp_identical n1b n2b
-                then unify_nexp l env goals n1a n2a
-                else unify_error l "Unification error"
+                if KidSet.is_empty (nexp_frees n2a)
+                then unify_nexp l env goals n2a (nminus nexp1 n2b)
+                else merge_uvars l (unify_nexp l env goals n1a n2a) (unify_nexp l env goals n1b n2b)
            | _ -> unify_error l ("Both sides of Int expression " ^ string_of_nexp nexp1
                                ^ " contain free type variables so it cannot be unified with " ^ string_of_nexp nexp2)
          end
@@ -1714,13 +1716,23 @@ let rec ambiguous_vars (Typ_aux (aux, _)) =
 and ambiguous_arg_vars (A_aux (aux, _)) =
   match aux with
   | A_bool nc -> ambiguous_nc_vars nc
+  | A_nexp nexp -> ambiguous_nexp_vars nexp
   | _ -> KidSet.empty
                
 and ambiguous_nc_vars (NC_aux (aux, _)) =
   match aux with
   | NC_and (nc1, nc2) -> KidSet.union (tyvars_of_constraint nc1) (tyvars_of_constraint nc2)
+  | NC_bounded_le (n1, n2) -> KidSet.union (tyvars_of_nexp n1) (tyvars_of_nexp n2)
+  | NC_bounded_ge (n1, n2) -> KidSet.union (tyvars_of_nexp n1) (tyvars_of_nexp n2)
+  | NC_equal (n1, n2) | NC_not_equal (n1, n2) ->
+     KidSet.union (ambiguous_nexp_vars n1) (ambiguous_nexp_vars n2)
   | _ -> KidSet.empty
-               
+
+and ambiguous_nexp_vars (Nexp_aux (aux, _)) =
+  match aux with
+  | Nexp_sum (nexp1, nexp2) -> KidSet.union (tyvars_of_nexp nexp1) (tyvars_of_nexp nexp2)
+  | _ -> KidSet.empty
+
 (**************************************************************************)
 (* 3.5. Subtyping with existentials                                       *)
 (**************************************************************************)
@@ -2831,7 +2843,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
         try
           let inferred_cast = irule infer_exp (Env.no_casts env) (strip (E_app (cast, [annotated_exp]))) in
           let ityp, env = bind_existential l None (typ_of inferred_cast) env in
-          inferred_cast, unify l env goals typ ityp, env
+          inferred_cast, unify l env (KidSet.diff goals (ambiguous_vars typ)) typ ityp, env
         with
         | Type_error (_, _, err) -> try_casts casts
         | Unification_error (_, err) -> try_casts casts
@@ -2841,7 +2853,7 @@ and type_coercion_unify env goals (E_aux (_, (l, _)) as annotated_exp) typ =
     try
       typ_debug (lazy ("Coercing unification: from " ^ string_of_typ (typ_of annotated_exp) ^ " to " ^ string_of_typ typ));
       let atyp, env = bind_existential l None (typ_of annotated_exp) env in
-      annotated_exp, unify l env goals typ atyp, env
+      annotated_exp, unify l env (KidSet.diff goals (ambiguous_vars typ)) typ atyp, env
     with
     | Unification_error (_, m) when Env.allow_casts env ->
        let casts = filter_casts env (typ_of annotated_exp) typ (Env.get_casts env) in
@@ -3662,15 +3674,21 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
 
   typ_debug (lazy ("Quantifiers " ^ Util.string_of_list ", " string_of_quant_item !quants));
 
-  let implicits, typ_args =
-    if not (List.length typ_args = List.length xs) then
-      let typ_args' = List.filter is_not_implicit typ_args in
-      if not (List.length typ_args' = List.length xs) then
-        typ_error env l (Printf.sprintf "Function %s applied to %d args, expected %d" (string_of_id f) (List.length xs) (List.length typ_args))
-      else
-        get_implicits typ_args, typ_args'
-    else
-      [], List.map implicit_to_int typ_args
+  let implicits, typ_args, xs =
+    let typ_args' = List.filter is_not_implicit typ_args in
+    match xs, typ_args' with
+      (* Support the case where a function has only implicit arguments;
+         allow it to be called either as f() or f(i...) *)
+    | [E_aux (E_lit (L_aux (L_unit, _)), _)], [] ->
+       get_implicits typ_args, [], []
+    | _ ->
+       if not (List.length typ_args = List.length xs) then
+         if not (List.length typ_args' = List.length xs) then
+           typ_error env l (Printf.sprintf "Function %s applied to %d args, expected %d (%d explicit): %s" (string_of_id f) (List.length xs) (List.length typ_args) (List.length typ_args') (String.concat ", " (List.map string_of_typ typ_args)))
+         else
+           get_implicits typ_args, typ_args', xs
+       else
+         [], List.map implicit_to_int typ_args, xs
   in
 
   let instantiate_quant (v, arg) (QI_aux (aux, l) as qi) =
@@ -3734,7 +3752,7 @@ and infer_funapp' l env f (typq, f_typ) xs expected_ret_typ =
   let solve_implicit impl = match KBindings.find_opt impl !all_unifiers with
     | Some (A_aux (A_nexp (Nexp_aux (Nexp_constant c, _)), _)) -> irule infer_exp env (mk_lit_exp (L_num c))
     | Some (A_aux (A_nexp n, _)) -> irule infer_exp env (mk_exp (E_sizeof n))
-    | _ -> typ_error env l "bad"
+    | _ -> typ_error env l ("Cannot solve implicit " ^ string_of_kid impl ^ " in " ^ string_of_exp (mk_exp (E_app (f, List.map strip_exp xs))))
   in
   let xs = List.map solve_implicit implicits @ xs in
 
@@ -4448,10 +4466,10 @@ let check_funcl env (FCL_aux (FCL_Funcl (id, pexp), (l, _))) typ =
           function arguments as like a tuple, and maybe we
           shouldn't. *)
        let typed_pexp, prop_eff =
-         match typ_args with
+         match List.map implicit_to_int typ_args with
          | [typ_arg] ->
             propagate_pexp_effect (check_case env typ_arg (strip_pexp pexp) typ_ret)
-         | _ ->
+         | typ_args ->
             propagate_pexp_effect (check_case env (Typ_aux (Typ_tup typ_args, l)) (strip_pexp pexp) typ_ret)
        in
        FCL_aux (FCL_Funcl (id, typed_pexp), (l, mk_expected_tannot env typ prop_eff (Some typ)))
-- 
cgit v1.2.3


From f397a40e6cf98b685dd15dfcd4ea2c9524cbfad7 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Thu, 7 Feb 2019 21:05:41 +0000
Subject: Replace equality check for declared effects by subset check

---
 src/ast_util.ml   | 5 +++++
 src/ast_util.mli  | 1 +
 src/type_check.ml | 4 ++--
 3 files changed, 8 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 63726304..396d72a3 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -1196,6 +1196,11 @@ let equal_effects e1 e2 =
   | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
      BESet.compare (BESet.of_list base_effs1) (BESet.of_list base_effs2) = 0
 
+let subseteq_effects e1 e2 =
+  match e1, e2 with
+  | Effect_aux (Effect_set base_effs1, _), Effect_aux (Effect_set base_effs2, _) ->
+     BESet.subset (BESet.of_list base_effs1) (BESet.of_list base_effs2)
+
 let rec kopts_of_nexp (Nexp_aux (nexp,_)) =
   match nexp with
   | Nexp_id _
diff --git a/src/ast_util.mli b/src/ast_util.mli
index d9b0110a..7100cde7 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -357,6 +357,7 @@ val has_effect : effect -> base_effect_aux -> bool
 val effect_set : effect -> BESet.t
 
 val equal_effects : effect -> effect -> bool
+val subseteq_effects : effect -> effect -> bool
 val union_effects : effect -> effect -> effect
 
 val kopts_of_order : order -> KOptSet.t
diff --git a/src/type_check.ml b/src/type_check.ml
index 7faa0234..b2bf0f5b 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2641,7 +2641,7 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ
         annot_exp (E_if (cond', then_branch', else_branch')) typ
      end
   | E_exit exp, _ ->
-     let checked_exp = crule check_exp env exp (mk_typ (Typ_id (mk_id "unit"))) in
+     let checked_exp = crule check_exp env exp unit_typ in
      annot_exp_effect (E_exit checked_exp) typ (mk_effect [BE_escape])
   | E_throw exp, _ ->
      let checked_exp = crule check_exp env exp exc_typ in
@@ -4627,7 +4627,7 @@ let check_fundef env (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls)
     else [], env, declared_eff
   in
   let env = Env.define_val_spec id env in
-  if (equal_effects eff declared_eff || !opt_no_effects)
+  if (subseteq_effects eff declared_eff || !opt_no_effects)
   then
     vs_def @ [DEF_fundef (FD_aux (FD_function (recopt, tannotopt, effectopt, funcls), (l, None)))], env
   else typ_error env l ("Effects do not match: " ^ string_of_effect declared_eff ^ " declared and " ^ string_of_effect eff ^ " found")
-- 
cgit v1.2.3


From c2e69e8334cba2f0898c73bcb8ca6cce15858fbf Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Fri, 8 Feb 2019 00:51:27 +0000
Subject: Remove dead code from type-checker

add_num_def and get_num_def are no longer used. The rewrite pass that
used them would fail on Nexp_ids because of this, but seeing as that
never happened we can probably assume that particular line of code is
simply never touched by any of our models or test suite?
---
 src/rewrites.ml    |  3 +--
 src/type_check.ml  | 18 +-----------------
 src/type_check.mli |  4 ++--
 3 files changed, 4 insertions(+), 21 deletions(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index 5cbc3545..45b6fd6c 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -238,7 +238,7 @@ let lookup_constant_kid env kid =
   List.fold_left check_nc None (Env.get_constraints env)
 
 let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with
-  | Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env)
+  | Nexp_id id -> Env.expand_nexp_synonyms env nexp_aux
   | Nexp_var kid ->
      begin
        match lookup_constant_kid env kid with
@@ -2909,7 +2909,6 @@ let rewrite_defs_internal_lets =
             type of the storage, so ask the type checker what it really is. *)
          (match infer_lexp (env_of_annot lannot) (strip_lexp lhs) with
          | LEXP_aux (_,lexp_annot') -> lexp_annot'
-         | _ -> lannot
          | exception _ -> lannot)
        in
        let rhs = add_e_cast ltyp (rhs exp) in
diff --git a/src/type_check.ml b/src/type_check.ml
index b2bf0f5b..77e45752 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -108,7 +108,6 @@ type env =
     typ_vars : (Ast.l * kind_aux) KBindings.t;
     shadow_vars : int KBindings.t;
     typ_synonyms : (env -> typ_arg list -> typ_arg) Bindings.t;
-    num_defs : nexp Bindings.t;
     overloads : (id list) Bindings.t;
     flow : (typ -> typ) Bindings.t;
     enums : IdSet.t Bindings.t;
@@ -368,8 +367,6 @@ module Env : sig
   val add_ret_typ : typ -> t -> t
   val add_typ_synonym : id -> (t -> typ_arg list -> typ_arg) -> t -> t
   val get_typ_synonym : id -> t -> t -> typ_arg list -> typ_arg
-  val add_num_def : id -> nexp -> t -> t
-  val get_num_def : id -> t -> nexp
   val add_overloads : id -> id list -> t -> t
   val get_overloads : id -> t -> id list
   val is_extern : id -> t -> string -> bool
@@ -391,6 +388,7 @@ module Env : sig
   val lookup_id : ?raw:bool -> id -> t -> typ lvar
   val fresh_kid : ?kid:kid -> t -> kid
   val expand_synonyms : t -> typ -> typ
+  val expand_nexp_synonyms : t -> nexp -> nexp
   val expand_constraint_synonyms : t -> n_constraint -> n_constraint
   val base_typ_of : t -> typ -> typ
   val allow_unknowns : t -> bool
@@ -430,7 +428,6 @@ end = struct
       typ_vars = KBindings.empty;
       shadow_vars = KBindings.empty;
       typ_synonyms = Bindings.empty;
-      num_defs = Bindings.empty;
       overloads = Bindings.empty;
       flow = Bindings.empty;
       enums = Bindings.empty;
@@ -1089,19 +1086,6 @@ end = struct
         { env with typ_vars = KBindings.add v (l, k) env.typ_vars }
       end
 
-  let add_num_def id nexp env =
-    if Bindings.mem id env.num_defs
-    then typ_error env (id_loc id) ("Num identifier " ^ string_of_id id ^ " is already bound")
-    else
-      begin
-        typ_print (lazy (adding ^ "Num identifier " ^ string_of_id id ^ " : " ^ string_of_nexp nexp));
-        { env with num_defs = Bindings.add id nexp env.num_defs }
-      end
-
-  let get_num_def id env =
-    try Bindings.find id env.num_defs with
-    | Not_found -> typ_raise env (id_loc id) (Err_no_num_ident id)
-
   let get_constraints env = env.constraints
 
   let add_constraint constr env =
diff --git a/src/type_check.mli b/src/type_check.mli
index 801a07ec..81f769ba 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -158,8 +158,6 @@ module Env : sig
 
   val get_overloads : id -> t -> id list
 
-  val get_num_def : id -> t -> nexp
-
   val is_extern : id -> t -> string -> bool
 
   val get_extern : id -> t -> string -> string
@@ -188,6 +186,8 @@ module Env : sig
 
   val expand_constraint_synonyms : t -> n_constraint -> n_constraint
 
+  val expand_nexp_synonyms : t -> nexp -> nexp
+    
   val expand_synonyms : t -> typ -> typ
 
   (** Expand type synonyms and remove register annotations (i.e. register<t> -> t)) *)
-- 
cgit v1.2.3


From 0d12cebc11c5beb779209bd290647f6bf58fc3e3 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Fri, 8 Feb 2019 13:02:44 +0000
Subject: Rewrite type definitions in rewrite_nexp_ids

For example, in

  type xlen : Int = 64
  type xlenbits = bits(xlen)

rewrite the 'xlen' in the definition of 'xlenbits' to the constant 64 in
order to simplify Lem generation.  In order to facilitate this, pass
through the global typing environment to the rewriting steps (in the AST
itself, type definitions don't carry annotations with environments).
---
 src/isail.ml         |   4 +-
 src/process_file.ml  |  26 +++++-----
 src/process_file.mli |  14 +++---
 src/rewrites.ml      | 140 +++++++++++++++++++++++++--------------------------
 src/rewrites.mli     |  14 +++---
 src/sail.ml          |  14 +++---
 6 files changed, 106 insertions(+), 106 deletions(-)

(limited to 'src')

diff --git a/src/isail.ml b/src/isail.ml
index d245ab14..89feb305 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -383,7 +383,7 @@ let handle_input' input =
      | ":compile" ->
         let open PPrint in
         let open C_backend in
-        let ast = Process_file.rewrite_ast_c !Interactive.ast in
+        let ast = Process_file.rewrite_ast_c !Interactive.env !Interactive.ast in
         let ast, env = Specialize.specialize ast !Interactive.env in
         let ctx = initial_ctx env in
         interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast
@@ -422,7 +422,7 @@ let handle_input' input =
         | ":l" | ":load" ->
            let files = Util.split_on_char ' ' arg in
            let (_, ast, env) = load_files !Interactive.env files in
-           let ast = Process_file.rewrite_ast_interpreter ast in
+           let ast = Process_file.rewrite_ast_interpreter !Interactive.env ast in
            Interactive.ast := append_ast !Interactive.ast ast;
            interactive_state := initial_state !Interactive.ast Value.primops;
            Interactive.env := env;
diff --git a/src/process_file.ml b/src/process_file.ml
index 94a6cd3e..52e0cd08 100644
--- a/src/process_file.ml
+++ b/src/process_file.ml
@@ -378,9 +378,9 @@ let output libpath out_arg files =
       output1 libpath out_arg f type_env defs)
     files
 
-let rewrite_step n total defs (name, rewriter) =
+let rewrite_step n total env defs (name, rewriter) =
   let t = Profile.start () in
-  let defs = rewriter defs in
+  let defs = rewriter env defs in
   Profile.finish ("rewrite " ^ name) t;
   let _ = match !(opt_ddump_rewrite_ast) with
     | Some (f, i) ->
@@ -396,20 +396,20 @@ let rewrite_step n total defs (name, rewriter) =
   Util.progress "Rewrite " name n total;
   defs
 
-let rewrite rewriters defs =
+let rewrite env rewriters defs =
   let total = List.length rewriters in
-  try snd (List.fold_left (fun (n, defs) rw -> n + 1, rewrite_step n total defs rw) (1, defs) rewriters) with
+  try snd (List.fold_left (fun (n, defs) rw -> n + 1, rewrite_step n total env defs rw) (1, defs) rewriters) with
   | Type_check.Type_error (_, l, err) ->
      raise (Reporting.err_typ l (Type_error.string_of_type_error err))
 
-let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)]
-let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem
-let rewrite_ast_coq = rewrite Rewrites.rewrite_defs_coq
-let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml
-let rewrite_ast_c ast =
+let rewrite_ast env = rewrite env [("initial", fun _ -> Rewriter.rewrite_defs)]
+let rewrite_ast_lem env = rewrite env Rewrites.rewrite_defs_lem
+let rewrite_ast_coq env = rewrite env Rewrites.rewrite_defs_coq
+let rewrite_ast_ocaml env = rewrite env Rewrites.rewrite_defs_ocaml
+let rewrite_ast_c env ast =
   ast
-  |> rewrite Rewrites.rewrite_defs_c
-  |> rewrite [("constant_fold", Constant_fold.rewrite_constant_function_calls)]
+  |> rewrite env Rewrites.rewrite_defs_c
+  |> rewrite env [("constant_fold", fun _ -> Constant_fold.rewrite_constant_function_calls)]
 
-let rewrite_ast_interpreter = rewrite Rewrites.rewrite_defs_interpreter
-let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check
+let rewrite_ast_interpreter env = rewrite env Rewrites.rewrite_defs_interpreter
+let rewrite_ast_check env = rewrite env Rewrites.rewrite_defs_check
diff --git a/src/process_file.mli b/src/process_file.mli
index f75f6687..0411464b 100644
--- a/src/process_file.mli
+++ b/src/process_file.mli
@@ -56,13 +56,13 @@ val clear_symbols : unit -> unit
 
 val preprocess_ast : (Arg.key * Arg.spec * Arg.doc) list -> Parse_ast.defs -> Parse_ast.defs
 val check_ast: Type_check.Env.t -> unit Ast.defs -> Type_check.tannot Ast.defs * Type_check.Env.t
-val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_coq : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_c : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_interpreter : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
-val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast: Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_lem : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_coq : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_ocaml : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_c : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_interpreter : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
+val rewrite_ast_check : Type_check.Env.t -> Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs
 
 val load_file_no_check : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> string -> unit Ast.defs
 val load_file : (Arg.key * Arg.spec * Arg.doc) list -> Ast.order -> Type_check.Env.t -> string -> Type_check.tannot Ast.defs * Type_check.Env.t
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 45b6fd6c..b47650b7 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -280,27 +280,27 @@ let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids =
     | None -> l, empty_tannot
   in
 
-  let rewrite_def rewriters = function
-    | DEF_spec (VS_aux (VS_val_spec (typschm, id, exts, b), (l, tannot))) when not (is_empty_tannot tannot) ->
-       let env = env_of_annot (l, tannot) in
-       let typ = typ_of_annot (l, tannot) in
-       let eff = effect_of_annot tannot in
-       let typschm = match typschm with
-         | TypSchm_aux (TypSchm_ts (tq, typ), l) ->
-            TypSchm_aux (TypSchm_ts (tq, rewrite_typ env typ), l)
-       in
-       let a = rewrite_annot (l, mk_tannot env typ eff) in
+  let rewrite_typschm env (TypSchm_aux (TypSchm_ts (tq, typ), l)) =
+    TypSchm_aux (TypSchm_ts (tq, rewrite_typ env typ), l)
+  in
+
+  let rewrite_def env rewriters = function
+    | DEF_spec (VS_aux (VS_val_spec (typschm, id, exts, b), a)) ->
+       let typschm = rewrite_typschm env typschm in
+       let a = rewrite_annot a in
        DEF_spec (VS_aux (VS_val_spec (typschm, id, exts, b), a))
+    | DEF_type (TD_aux (TD_abbrev (id, typq, typ_arg), a)) ->
+       DEF_type (TD_aux (TD_abbrev (id, typq, rewrite_typ_arg env typ_arg), a))
     | d -> Rewriter.rewrite_def rewriters d
   in
 
-  rewrite_defs_base { rewriters_base with
-    rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); rewrite_def = rewrite_def
-    },
+  (fun env defs -> rewrite_defs_base { rewriters_base with
+    rewrite_exp = (fun _ -> map_exp_annot rewrite_annot); rewrite_def = rewrite_def env
+    } defs),
   rewrite_typ
 
 
-let rewrite_bitvector_exps defs =
+let rewrite_bitvector_exps env defs =
   let e_aux = function
     | (E_vector es, ((l, tannot) as a)) when not (is_empty_tannot tannot) ->
        let env = env_of_annot (l, tannot) in
@@ -400,7 +400,7 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
   and rewrite_e_sizeof split_sizeof =
     { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) }
   in
-  rewrite_defs_base_parallel 4 { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true
+  (fun env -> rewrite_defs_base_parallel 4 { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }), rewrite_e_aux true
 
 (* Rewrite sizeof expressions with type-level variables to
    term-level expressions
@@ -409,7 +409,7 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
    be directly extracted from existing parameters of the surrounding function,
    a further parameter is added; calls to the function are rewritten
    accordingly (possibly causing further rewriting in the calling function) *)
-let rewrite_sizeof (Defs defs) =
+let rewrite_sizeof env (Defs defs) =
   let sizeof_frees exp =
     fst (fold_exp
            { (compute_exp_alg KidSet.empty KidSet.union) with
@@ -1010,7 +1010,7 @@ let rewrite_fun_remove_vector_concat_pat
     (FCL_aux (FCL_Funcl (id,pexp'),(l,annot)))
   in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot))
 
-let rewrite_defs_remove_vector_concat (Defs defs) =
+let rewrite_defs_remove_vector_concat env (Defs defs) =
   let rewriters =
     {rewrite_exp = rewrite_exp_remove_vector_concat_pat;
      rewrite_pat = rewrite_pat;
@@ -1579,7 +1579,7 @@ let rewrite_fun_remove_bitvector_pat
     | _ -> funcls in
   FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))
 
-let rewrite_defs_remove_bitvector_pats (Defs defs) =
+let rewrite_defs_remove_bitvector_pats env (Defs defs) =
   let rewriters =
     {rewrite_exp = rewrite_exp_remove_bitvector_pat;
      rewrite_pat = rewrite_pat;
@@ -1604,7 +1604,7 @@ let rewrite_defs_remove_bitvector_pats (Defs defs) =
 (* Rewrite literal number patterns to guarded patterns
    Those numeral patterns are not handled very well by Lem (or Isabelle)
  *)
-let rewrite_defs_remove_numeral_pats =
+let rewrite_defs_remove_numeral_pats env =
   let p_lit outer_env = function
     | L_aux (L_num n, l) ->
        let id = fresh_id "l__" Parse_ast.Unknown in
@@ -1637,7 +1637,7 @@ let rewrite_defs_remove_numeral_pats =
   rewrite_defs_base
     { rewriters_base with rewrite_exp = rewrite_exp; rewrite_fun = rewrite_fun }
 
-let rewrite_defs_vector_string_pats_to_bit_list =
+let rewrite_defs_vector_string_pats_to_bit_list env =
   let rewrite_p_aux (pat, (annot : tannot annot)) =
     let env = env_of_annot annot in
     match pat with
@@ -1721,7 +1721,7 @@ let rewrite_fun_guarded_pats rewriters (FD_aux (FD_function (r,t,e,funcls),(l,fd
      | _ -> funcls (* TODO is the empty list possible here? *) in
    FD_aux (FD_function(r,t,e,funcls),(l,fdannot))
 
-let rewrite_defs_guarded_pats =
+let rewrite_defs_guarded_pats env =
   rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats;
                     rewrite_fun = rewrite_fun_guarded_pats }
 
@@ -1790,7 +1790,7 @@ let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as f
 
   | _ -> rewrite_base full_exp
 
-let rewrite_defs_exp_lift_assign defs = rewrite_defs_base
+let rewrite_defs_exp_lift_assign env defs = rewrite_defs_base
     {rewrite_exp = rewrite_exp_lift_assign_intro;
      rewrite_pat = rewrite_pat;
      rewrite_let = rewrite_let;
@@ -1838,7 +1838,7 @@ let rewrite_register_ref_writes (Defs defs) =
    TODO: Maybe separate generic removal of redundant returns, and Lem-specific
    rewriting of early returns
  *)
-let rewrite_defs_early_return (Defs defs) =
+let rewrite_defs_early_return env (Defs defs) =
   let is_unit (E_aux (exp, _)) = match exp with
   | E_lit (L_aux (L_unit, _)) -> true
   | _ -> false in
@@ -2036,7 +2036,7 @@ let pat_var (P_aux (paux, a)) =
 
 (* Split out function clauses for individual union constructor patterns
    (e.g. AST nodes) into auxiliary functions.  Used for the execute function. *)
-let rewrite_split_fun_constr_pats fun_name (Defs defs) =
+let rewrite_split_fun_constr_pats fun_name env (Defs defs) =
   let rewrite_fundef typquant (FD_aux (FD_function (r_o, t_o, e_o, clauses), ((l, _) as fdannot))) =
     let rec_clauses, clauses = List.partition is_funcl_rec clauses in
     let clauses, aux_funs =
@@ -2149,7 +2149,7 @@ let rewrite_split_fun_constr_pats fun_name (Defs defs) =
 
 (* Propagate effects of functions, if effect checking and propagation
    have not been performed already by the type checker. *)
-let rewrite_fix_val_specs (Defs defs) =
+let rewrite_fix_val_specs env (Defs defs) =
   let find_vs env val_specs id =
     try Bindings.find id val_specs with
     | Not_found ->
@@ -2347,7 +2347,7 @@ let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) =
 
 (* Remove overload definitions and cast val specs from the
    specification because the interpreter doesn't know about them.*)
-let rewrite_overload_cast (Defs defs) =
+let rewrite_overload_cast env (Defs defs) =
   let remove_cast_vs (VS_aux (vs_aux, annot)) =
     match vs_aux with
     | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot)
@@ -2364,7 +2364,7 @@ let rewrite_overload_cast (Defs defs) =
   Defs (List.filter (fun def -> not (is_overload def)) defs)
 
 
-let rewrite_undefined mwords =
+let rewrite_undefined mwords env =
   let rewrite_e_aux (E_aux (e_aux, _) as exp) =
     match e_aux with
     | E_lit (L_aux (L_undef, l)) ->
@@ -2374,9 +2374,9 @@ let rewrite_undefined mwords =
   let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in
   rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) }
 
-let rewrite_undefined_if_gen always_bitvector defs =
+let rewrite_undefined_if_gen always_bitvector env defs =
   if !Initial_check.opt_undefined_gen
-  then rewrite_undefined (always_bitvector || !Pretty_print_lem.opt_mwords) defs
+  then rewrite_undefined (always_bitvector || !Pretty_print_lem.opt_mwords) env defs
   else defs
 
 let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l)
@@ -2401,7 +2401,7 @@ and simple_typ_arg (A_aux (typ_arg_aux, l)) =
   | _ -> []
 
 (* This pass aims to remove all the Num quantifiers from the specification. *)
-let rewrite_simple_types (Defs defs) =
+let rewrite_simple_types env (Defs defs) =
   let is_simple = function
     | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true
     | _ -> false
@@ -2451,7 +2451,7 @@ let rewrite_simple_types (Defs defs) =
   let defs = Defs (List.map simple_def defs) in
   rewrite_defs_base simple_defs defs
 
-let rewrite_vector_concat_assignments defs =
+let rewrite_vector_concat_assignments env defs =
   let assign_tuple e_aux annot =
     let env = env_of_annot annot in
     match e_aux with
@@ -2510,7 +2510,7 @@ let rewrite_vector_concat_assignments defs =
   let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in
   rewrite_defs_base assign_defs defs
 
-let rewrite_tuple_assignments defs =
+let rewrite_tuple_assignments env defs =
   let assign_tuple e_aux annot =
     let env = env_of_annot annot in
     match e_aux with
@@ -2538,7 +2538,7 @@ let rewrite_tuple_assignments defs =
   let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in
   rewrite_defs_base assign_defs defs
 
-let rewrite_simple_assignments defs =
+let rewrite_simple_assignments env defs =
   let assign_e_aux e_aux annot =
     let env = env_of_annot annot in
     match e_aux with
@@ -2555,7 +2555,7 @@ let rewrite_simple_assignments defs =
   let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in
   rewrite_defs_base assign_defs defs
 
-let rewrite_defs_remove_blocks =
+let rewrite_defs_remove_blocks env =
   let letbind_wild v body =
     let l = get_loc_exp v in
     let env = env_of v in
@@ -2611,7 +2611,7 @@ let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list
   | [] -> k []
   | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps)))
 
-let rewrite_defs_letbind_effects =
+let rewrite_defs_letbind_effects env =
 
   let rec value ((E_aux (exp_aux,_)) as exp) =
     not (effectful exp || updates_vars exp)
@@ -2888,7 +2888,7 @@ let rewrite_defs_letbind_effects =
     ; rewrite_defs = rewrite_defs_base
     }
 
-let rewrite_defs_internal_lets =
+let rewrite_defs_internal_lets env =
 
   let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with
     | LEXP_id id -> P_aux (P_id id, annot)
@@ -3214,7 +3214,7 @@ let construct_toplevel_string_append_func env f_id pat =
   let new_fun_def, env = Type_check.check_fundef env new_fun_def in
   List.flatten [new_val_spec; new_fun_def]
 
-let rewrite_defs_toplevel_string_append (Defs defs) =
+let rewrite_defs_toplevel_string_append env (Defs defs) =
   let new_defs = ref ([] : tannot def list) in
   let rec rewrite_pexp (Pat_aux (pexp_aux, pexp_annot) as pexp) =
     (* merge cases of Pat_exp and Pat_when *)
@@ -3251,7 +3251,7 @@ let rewrite_defs_toplevel_string_append (Defs defs) =
   Defs (List.map rewrite defs |> List.flatten)
 
 
-let rec rewrite_defs_pat_string_append =
+let rec rewrite_defs_pat_string_append env =
   let rec rewrite_pat env ((pat : tannot pat), (guards : tannot exp list), (expr : tannot exp)) =
     let guards_ref = ref guards in
     let expr_ref = ref expr in
@@ -3501,7 +3501,7 @@ let fresh_mappingpatterns_id () =
   mappingpatterns_counter := !mappingpatterns_counter + 1;
   id
 
-let rewrite_defs_mapping_patterns =
+let rewrite_defs_mapping_patterns env =
   let rec rewrite_pat env (pat, guards, expr) =
     let guards_ref = ref guards in
     let expr_ref = ref expr in
@@ -3654,7 +3654,7 @@ let rewrite_lit_ocaml (L_aux (lit, _)) = match lit with
   | L_num _ | L_string _ | L_hex _ | L_bin _ | L_real _ | L_unit -> false
   | _ -> true
 
-let rewrite_defs_pat_lits rewrite_lit =
+let rewrite_defs_pat_lits rewrite_lit env =
   let rewrite_pexp (Pat_aux (pexp_aux, annot) as pexp) =
     let guards = ref [] in
     let counter = ref 0 in
@@ -3991,7 +3991,7 @@ let remove_reference_types exp =
 
 
 
-let rewrite_defs_remove_superfluous_letbinds =
+let rewrite_defs_remove_superfluous_letbinds env =
 
   let e_aux (exp,annot) = match exp with
     | E_let (LB_aux (LB_val (pat, exp1), _), exp2) ->
@@ -4035,7 +4035,7 @@ let rewrite_defs_remove_superfluous_letbinds =
     }
 
 (* FIXME: We shouldn't allow nested not-patterns *)
-let rewrite_defs_not_pats =
+let rewrite_defs_not_pats env =
   let rewrite_pexp (pexp_aux, annot) =
     let rewrite_pexp' pat exp orig_guard =
       let guards = ref [] in
@@ -4084,7 +4084,7 @@ let rewrite_defs_not_pats =
   let rw_exp = { id_exp_alg with pat_aux = rewrite_pexp } in
   rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rw_exp) }
 
-let rewrite_defs_remove_superfluous_returns =
+let rewrite_defs_remove_superfluous_returns env =
 
   let add_opt_cast typopt1 typopt2 annot exp =
     match typopt1, typopt2 with
@@ -4137,7 +4137,7 @@ let rewrite_defs_remove_superfluous_returns =
     }
 
 
-let rewrite_defs_remove_e_assign (Defs defs) =
+let rewrite_defs_remove_e_assign env (Defs defs) =
   let (Defs loop_specs) = fst (Type_error.check Env.empty (Defs (List.map gen_vs
     [("foreach", "forall ('vars : Type). (int, int, int, bool, 'vars, 'vars) -> 'vars");
      ("while", "forall ('vars : Type). (bool, 'vars, 'vars) -> 'vars");
@@ -4154,7 +4154,7 @@ let rewrite_defs_remove_e_assign (Defs defs) =
     ; rewrite_defs = rewrite_defs_base
     } (Defs (loop_specs @ defs))
 
-let merge_funcls (Defs defs) =
+let merge_funcls env (Defs defs) =
   let merge_function (FD_aux (FD_function (r,t,e,fcls),ann) as f) =
     match fcls with
     | [] | [_] -> f
@@ -4228,7 +4228,7 @@ and fpats_of_mfpats mfpats =
   in
   List.map fpat_of_mfpat mfpats
 
-let rewrite_defs_realise_mappings (Defs defs) =
+let rewrite_defs_realise_mappings _ (Defs defs) =
   let realise_mpexps forwards mpexp1 mpexp2 =
     let mpexp_pat, mpexp_exp =
       if forwards then mpexp1, mpexp2
@@ -4772,7 +4772,7 @@ let rewrite_fun rewriters (FD_aux (FD_function (r,t,e,fcls),f_ann)) =
 
      FD_aux (FD_function (r,t,e,fcls'@[default]),f_ann)
 
-let rewrite =
+let rewrite env =
   let alg = { id_exp_alg with e_aux = rewrite_case } in
   rewrite_defs_base
     { rewrite_exp = (fun _ -> fold_exp alg)
@@ -4791,7 +4791,7 @@ end
    new functions that appear to be recursive but are not.  This checks to
    see if the flag can be turned off.  Doesn't handle mutual recursion
    for now. *)
-let minimise_recursive_functions (Defs defs) =
+let minimise_recursive_functions env (Defs defs) =
   let funcl_is_rec (FCL_aux (FCL_Funcl (id,pexp),_)) =
     fold_pexp
       { (pure_exp_alg false (||)) with
@@ -4814,7 +4814,7 @@ let minimise_recursive_functions (Defs defs) =
     | d -> d
   in Defs (List.map rewrite_def defs)
 
-let move_termination_measures (Defs defs) =
+let move_termination_measures env (Defs defs) =
   let scan_for id defs =
     let rec aux = function
       | [] -> None
@@ -4845,7 +4845,7 @@ let move_termination_measures (Defs defs) =
 
 (* Make recursive functions with a measure use the measure as an
    explicit recursion limit, enforced by an assertion. *)
-let rewrite_explicit_measure (Defs defs) =
+let rewrite_explicit_measure env (Defs defs) =
   let scan_function measures = function
     | FD_aux (FD_function (Rec_aux (Rec_measure (mpat,mexp),rl),topt,effopt,
                            FCL_aux (FCL_Funcl (id,_),_)::_),ann) ->
@@ -4982,15 +4982,15 @@ let rewrite_explicit_measure (Defs defs) =
   in
   Defs (List.flatten (List.map rewrite_def defs))
 
-let recheck_defs defs = fst (Type_error.check initial_env defs)
-let recheck_defs_without_effects defs =
+let recheck_defs env defs = fst (Type_error.check initial_env defs)
+let recheck_defs_without_effects env defs =
   let old = !opt_no_effects in
   let () = opt_no_effects := true in
   let result,_ = Type_error.check initial_env defs in
   let () = opt_no_effects := old in
   result
 
-let remove_mapping_valspecs (Defs defs) =
+let remove_mapping_valspecs env (Defs defs) =
   let allowed_def def =
     match def with
     | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (_, Typ_aux (Typ_bidir _, _)), _), _, _, _), _)) -> false
@@ -5002,12 +5002,12 @@ let remove_mapping_valspecs (Defs defs) =
 let opt_mono_rewrites = ref false
 let opt_mono_complex_nexps = ref true
 
-let mono_rewrites defs =
+let mono_rewrites env defs =
   if !opt_mono_rewrites then
     Monomorphise.mono_rewrites defs
   else defs
 
-let rewrite_toplevel_nexps defs =
+let rewrite_toplevel_nexps env defs =
   if !opt_mono_complex_nexps then
     Monomorphise.rewrite_toplevel_nexps defs
   else defs
@@ -5018,7 +5018,7 @@ let opt_auto_mono = ref false
 let opt_dall_split_errors = ref false
 let opt_dmono_continue = ref false
 
-let monomorphise defs =
+let monomorphise env defs =
   let open Monomorphise in
   monomorphise
     { auto = !opt_auto_mono;
@@ -5028,14 +5028,14 @@ let monomorphise defs =
     !opt_mono_split
     defs
 
-let if_mono f defs =
+let if_mono f env defs =
   match !opt_mono_split, !opt_auto_mono with
   | [], false -> defs
-  | _, _ -> f defs
+  | _, _ -> f env defs
 
 (* Also turn mwords stages on when we're just trying out mono *)
-let if_mwords f defs =
-  if !Pretty_print_lem.opt_mwords then f defs else if_mono f defs
+let if_mwords f env defs =
+  if !Pretty_print_lem.opt_mwords then f env defs else if_mono f env defs
 
 let rewrite_defs_lem = [
   ("realise_mappings", rewrite_defs_realise_mappings);
@@ -5048,8 +5048,8 @@ let rewrite_defs_lem = [
   ("rewrite_toplevel_nexps", if_mono rewrite_toplevel_nexps);
   ("monomorphise", if_mono monomorphise);
   ("recheck_defs", if_mwords recheck_defs);
-  ("add_bitvector_casts", if_mwords Monomorphise.add_bitvector_casts);
-  ("rewrite_atoms_to_singletons", if_mono Monomorphise.rewrite_atoms_to_singletons);
+  ("add_bitvector_casts", if_mwords (fun _ -> Monomorphise.add_bitvector_casts));
+  ("rewrite_atoms_to_singletons", if_mono (fun _ -> Monomorphise.rewrite_atoms_to_singletons));
   ("recheck_defs", if_mwords recheck_defs);
   ("rewrite_undefined", rewrite_undefined_if_gen false);
   ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list);
@@ -5071,7 +5071,7 @@ let rewrite_defs_lem = [
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
   (* ("constraint", rewrite_constraint); *)
   (* ("remove_assert", rewrite_defs_remove_assert); *)
-  ("top_sort_defs", top_sort_defs);
+  ("top_sort_defs", fun _ -> top_sort_defs);
   ("trivial_sizeof", rewrite_trivial_sizeof);
   (* ("sizeof", rewrite_sizeof); *)
   ("early_return", rewrite_defs_early_return);
@@ -5116,7 +5116,7 @@ let rewrite_defs_coq = [
   (* ("constraint", rewrite_constraint); *)
   (* ("remove_assert", rewrite_defs_remove_assert); *)
   ("move_termination_measures", move_termination_measures);
-  ("top_sort_defs", top_sort_defs);
+  ("top_sort_defs", fun _ -> top_sort_defs);
   ("trivial_sizeof", rewrite_trivial_sizeof);
   ("sizeof", rewrite_sizeof);
   ("early_return", rewrite_defs_early_return);
@@ -5139,7 +5139,7 @@ let rewrite_defs_coq = [
 
 let rewrite_defs_ocaml = [
     (* ("undefined", rewrite_undefined); *)
-  ("no_effect_check", (fun defs -> opt_no_effects := true; defs));
+  ("no_effect_check", (fun _ defs -> opt_no_effects := true; defs));
   ("realise_mappings", rewrite_defs_realise_mappings);
   ("toplevel_string_append", rewrite_defs_toplevel_string_append);
   ("pat_string_append", rewrite_defs_pat_string_append);
@@ -5155,14 +5155,14 @@ let rewrite_defs_ocaml = [
   ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats);
   ("remove_numeral_pats", rewrite_defs_remove_numeral_pats);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
-  ("top_sort_defs", top_sort_defs);
+  ("top_sort_defs", fun _ -> top_sort_defs);
   ("simple_types", rewrite_simple_types);
   ("overload_cast", rewrite_overload_cast);
   (* ("separate_numbs", rewrite_defs_separate_numbs) *)
   ]
 
 let rewrite_defs_c = [
-  ("no_effect_check", (fun defs -> opt_no_effects := true; defs));
+  ("no_effect_check", (fun _ defs -> opt_no_effects := true; defs));
   ("realise_mappings", rewrite_defs_realise_mappings);
   ("toplevel_string_append", rewrite_defs_toplevel_string_append);
   ("pat_string_append", rewrite_defs_pat_string_append);
@@ -5178,11 +5178,11 @@ let rewrite_defs_c = [
   ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
   ("merge_function_clauses", merge_funcls);
-  ("recheck_defs", Optimize.recheck)
+  ("recheck_defs", fun _ -> Optimize.recheck)
   ]
 
 let rewrite_defs_interpreter = [
-    ("no_effect_check", (fun defs -> opt_no_effects := true; defs));
+    ("no_effect_check", (fun _ defs -> opt_no_effects := true; defs));
     ("realise_mappings", rewrite_defs_realise_mappings);
     ("toplevel_string_append", rewrite_defs_toplevel_string_append);
     ("pat_string_append", rewrite_defs_pat_string_append);
@@ -5221,5 +5221,5 @@ let rewrite_check_annot =
                                           rewrite_pat = (fun _ -> check_pat) }
 
 let rewrite_defs_check = [
-  ("check_annotations", rewrite_check_annot);
+  ("check_annotations", fun _ -> rewrite_check_annot);
   ]
diff --git a/src/rewrites.mli b/src/rewrites.mli
index aa793cb4..cea227a5 100644
--- a/src/rewrites.mli
+++ b/src/rewrites.mli
@@ -64,29 +64,29 @@ val opt_dmono_continue : bool ref
 val fresh_id : string -> l -> id
 
 (* Re-write undefined to functions created by -undefined_gen flag *)
-val rewrite_undefined : bool -> tannot defs -> tannot defs
+val rewrite_undefined : bool -> Env.t -> tannot defs -> tannot defs
 
 (* Perform rewrites to exclude AST nodes not supported for ocaml out*)
-val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_ocaml : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 (* Perform rewrites to exclude AST nodes not supported for interpreter *)
-val rewrite_defs_interpreter : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_interpreter : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 (* Perform rewrites to exclude AST nodes not supported for lem out*)
-val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_lem : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 (* Perform rewrites to exclude AST nodes not supported for coq out*)
-val rewrite_defs_coq : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_coq : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 (* Warn about matches where we add a default case for Coq because they're not
    exhaustive *)
 val opt_coq_warn_nonexhaustive : bool ref
 
 (* Perform rewrites to exclude AST nodes not supported for C compilation *)
-val rewrite_defs_c : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_c : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 (* This is a special rewriter pass that checks AST invariants without
    actually doing any re-writing *)
-val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list
+val rewrite_defs_check : (string * (Env.t -> tannot defs -> tannot defs)) list
 
 val simple_typ : typ -> typ
diff --git a/src/sail.ml b/src/sail.ml
index 2903e802..eeacbb2d 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -325,7 +325,7 @@ let load_files ?generate:(generate=true) type_envs files =
   Profile.finish "type checking" t;
 
   let ast = Scattered.descatter ast in
-  let ast = rewrite_ast ast in
+  let ast = rewrite_ast type_envs ast in
 
   let out_name = match !opt_file_out with
     | None when parsed = [] -> "out.sail"
@@ -369,11 +369,11 @@ let main() =
     begin
       (if !(Interactive.opt_interactive)
        then
-         (Interactive.ast := Process_file.rewrite_ast_interpreter ast; Interactive.env := type_envs)
+         (Interactive.ast := Process_file.rewrite_ast_interpreter type_envs ast; Interactive.env := type_envs)
        else ());
       (if !(opt_sanity)
        then
-         let _ = rewrite_ast_check ast in
+         let _ = rewrite_ast_check type_envs ast in
          ()
        else ());
       (if !(opt_print_verbose)
@@ -387,13 +387,13 @@ let main() =
           Pretty_print_sail.pp_defs stdout (Specialize.slice_defs type_envs ast ids));
       (if !(opt_print_ocaml)
        then
-         let ast_ocaml = rewrite_ast_ocaml ast in
+         let ast_ocaml = rewrite_ast_ocaml type_envs ast in
          let out = match !opt_file_out with None -> "out" | Some s -> s in
          Ocaml_backend.ocaml_compile out ast_ocaml ocaml_generator_info
        else ());
       (if !(opt_print_c)
        then
-         let ast_c = rewrite_ast_c ast in
+         let ast_c = rewrite_ast_c type_envs ast in
          let ast_c, type_envs = Specialize.specialize ast_c type_envs in
          (* let ast_c = Spec_analysis.top_sort_defs ast_c in *)
          Util.opt_warnings := true;
@@ -406,13 +406,13 @@ let main() =
        then
          let mwords = !Pretty_print_lem.opt_mwords in
          let type_envs, ast_lem = State.add_regstate_defs mwords type_envs ast in
-         let ast_lem = rewrite_ast_lem ast_lem in
+         let ast_lem = rewrite_ast_lem type_envs ast_lem in
          output "" (Lem_out (!opt_libs_lem)) [out_name,type_envs,ast_lem]
        else ());
       (if !(opt_print_coq)
        then
          let type_envs, ast_coq = State.add_regstate_defs true type_envs ast in
-         let ast_coq = rewrite_ast_coq ast_coq in
+         let ast_coq = rewrite_ast_coq type_envs ast_coq in
          output "" (Coq_out (!opt_libs_coq)) [out_name,type_envs,ast_coq]
        else ());
       (if !(opt_print_latex)
-- 
cgit v1.2.3


From 7835052c225a6fd1d6f3e05217ea4b583ec0831a Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Thu, 7 Feb 2019 18:29:43 +0000
Subject: Updates for asl_parser

Tweak colours of monomorphistion test output
---
 src/ast_util.ml          | 2 ++
 src/ast_util.mli         | 1 +
 src/pretty_print_sail.ml | 2 ++
 src/type_check.ml        | 5 +++++
 4 files changed, 10 insertions(+)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 396d72a3..03031767 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -374,6 +374,8 @@ let app_typ id args = mk_typ (Typ_app (id, args))
 let register_typ typ = mk_typ (Typ_app (mk_id "register", [mk_typ_arg (A_typ typ)]))
 let atom_typ nexp =
   mk_typ (Typ_app (mk_id "atom", [mk_typ_arg (A_nexp (nexp_simp nexp))]))
+let implicit_typ nexp =
+  mk_typ (Typ_app (mk_id "implicit", [mk_typ_arg (A_nexp (nexp_simp nexp))]))
 let range_typ nexp1 nexp2 =
   mk_typ (Typ_app (mk_id "range", [mk_typ_arg (A_nexp (nexp_simp nexp1));
                                    mk_typ_arg (A_nexp (nexp_simp nexp2))]))
diff --git a/src/ast_util.mli b/src/ast_util.mli
index 7100cde7..4cbea3dc 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -124,6 +124,7 @@ val unknown_typ : typ
 val int_typ : typ
 val nat_typ : typ
 val atom_typ : nexp -> typ
+val implicit_typ : nexp -> typ
 val range_typ : nexp -> nexp -> typ
 val bit_typ : typ
 val bool_typ : typ
diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml
index 3d5bd479..f30d5135 100644
--- a/src/pretty_print_sail.ml
+++ b/src/pretty_print_sail.ml
@@ -92,6 +92,8 @@ let rec doc_nexp =
   let rec atomic_nexp (Nexp_aux (n_aux, _) as nexp) =
     match n_aux with
     | Nexp_constant c -> string (Big_int.to_string c)
+    | Nexp_app (Id_aux (DeIid op, _), [n1; n2]) ->
+       separate space [atomic_nexp n1; string op; atomic_nexp n2]
     | Nexp_app (id, nexps) -> string (string_of_nexp nexp)
     (* This segfaults??!!!!
        doc_id id ^^ (parens (separate_map (comma ^^ space) doc_nexp nexps))
diff --git a/src/type_check.ml b/src/type_check.ml
index 77e45752..f31da5f4 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -2025,6 +2025,11 @@ let rec rewrite_sizeof' env (Nexp_aux (aux, l) as nexp) =
      let exp2 = rewrite_sizeof' env nexp2 in
      mk_exp (E_app (mk_id "div", [exp1; exp2]))
 
+  | Nexp_app (id, [nexp1; nexp2]) when string_of_id id = "mod" ->
+     let exp1 = rewrite_sizeof' env nexp1 in
+     let exp2 = rewrite_sizeof' env nexp2 in
+     mk_exp (E_app (mk_id "mod", [exp1; exp2]))
+
   | Nexp_app _ | Nexp_id _ ->
      typ_error env l ("Cannot re-write sizeof(" ^ string_of_nexp nexp ^ ")")
 
-- 
cgit v1.2.3


From 44e35e2384824f8f3b3cc65a61bbb76e08a6422c Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Fri, 8 Feb 2019 17:52:42 +0000
Subject: Allow internal AST nodes in input when -dmagic_hash is on

---
 src/initial_check.ml | 10 ++++++++++
 src/lexer.mll        |  2 ++
 src/parse_ast.ml     |  2 ++
 src/parser.mly       |  7 +++++++
 4 files changed, 21 insertions(+)

(limited to 'src')

diff --git a/src/initial_check.ml b/src/initial_check.ml
index d08ab8cf..108e04d0 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -387,6 +387,16 @@ and to_ast_exp ctx (P.E_aux(exp,l) : P.exp) =
     | P.E_throw exp -> E_throw (to_ast_exp ctx exp)
     | P.E_return exp -> E_return(to_ast_exp ctx exp)
     | P.E_assert(cond,msg) -> E_assert(to_ast_exp ctx cond, to_ast_exp ctx msg)
+    | P.E_internal_plet(pat,exp1,exp2) ->
+       if !opt_magic_hash then
+         E_internal_plet(to_ast_pat ctx pat, to_ast_exp ctx exp1, to_ast_exp ctx exp2)
+       else
+         raise (Reporting.err_general l "Internal plet construct found without -dmagic_hash")
+    | P.E_internal_return(exp) ->
+       if !opt_magic_hash then
+         E_internal_return(to_ast_exp ctx exp)
+       else
+         raise (Reporting.err_general l "Internal return construct found without -dmagic_hash")
     | _ -> raise (Reporting.err_unreachable l __POS__ "Unparsable construct in to_ast_exp")
     ), (l,()))
 
diff --git a/src/lexer.mll b/src/lexer.mll
index 604931ac..43426d77 100644
--- a/src/lexer.mll
+++ b/src/lexer.mll
@@ -181,6 +181,8 @@ let kw_table =
      ("escape",                  (fun x -> Escape));
      ("configuration",           (fun _ -> Configuration));
      ("termination_measure",     (fun _ -> TerminationMeasure));
+     ("internal_plet",           (fun _ -> InternalPLet));
+     ("internal_return",         (fun _ -> InternalReturn));
    ]
 
 
diff --git a/src/parse_ast.ml b/src/parse_ast.ml
index 2e78b825..6401331e 100644
--- a/src/parse_ast.ml
+++ b/src/parse_ast.ml
@@ -275,6 +275,8 @@ exp_aux =  (* Expression *)
  | E_return of exp
  | E_assert of exp * exp
  | E_var of exp * exp * exp
+ | E_internal_plet of pat * exp * exp
+ | E_internal_return of exp
 
 and exp = 
    E_aux of exp_aux * l
diff --git a/src/parser.mly b/src/parser.mly
index 7540d1f4..cbbc41e3 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -183,6 +183,7 @@ let rec desugar_rchain chain s e =
 %token Undefined Union Newtype With Val Constraint Throw Try Catch Exit Bitfield
 %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape
 %token Repeat Until While Do Mutual Var Ref Configuration TerminationMeasure
+%token InternalPLet InternalReturn
 
 %nonassoc Then
 %nonassoc Else
@@ -806,6 +807,12 @@ exp:
   | While exp Do exp
     { mk_exp (E_loop (While, $2, $4)) $startpos $endpos }
 
+  /* Debugging only, will be rejected in initial_check if debugging isn't on */
+  | InternalPLet pat Eq exp In exp
+    { mk_exp (E_internal_plet ($2,$4,$6)) $startpos $endpos }
+  | InternalReturn exp
+    { mk_exp (E_internal_return($2)) $startpos $endpos }
+
 /* The following implements all nine levels of user-defined precedence for
 operators in expressions, with both left, right and non-associative operators */
 
-- 
cgit v1.2.3


From 60897fea38949960d3f0e1370bbf73f157e099ec Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Fri, 8 Feb 2019 18:06:23 +0000
Subject: Prevent top_sort throwing away overloads (and other multiple
 definitions) Previously it would quietly throw away all definitions for an id
 except one. This usually doesn't matter, but some rewrites use overloaded
 identifiers and can break if the definition is lost.

---
 src/spec_analysis.ml | 15 ++++++++++++---
 1 file changed, 12 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index 907a2f10..a8ddaf68 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -582,6 +582,13 @@ let scc ?(original_order : string list option) (g : graph) =
   List.iter (fun v -> if not (Hashtbl.mem node_indices v) then visit_node v) nodes;
   List.rev !components
 
+let add_def_to_map id d defset =
+  Namemap.add id
+    (match Namemap.find id defset with
+     | t -> d::t
+     | exception Not_found -> [d])
+    defset
+
 let add_def_to_graph (prelude, original_order, defset, graph) d =
   let bound, used = fv_of_def false true [] d in
   let used = match d with
@@ -604,7 +611,7 @@ let add_def_to_graph (prelude, original_order, defset, graph) d =
     let add_other_node id' g = Namemap.add id' (Nameset.singleton id) g in
     prelude,
     original_order @ [id],
-    Namemap.add id d defset,
+    add_def_to_map id d defset,
     Nameset.fold add_other_node other_ids graph_id
   with
   | Not_found ->
@@ -633,11 +640,11 @@ let print_dot graph component : unit =
   | [] -> ()
 
 let def_of_component graph defset comp =
-  let get_def id = if Namemap.mem id defset then [Namemap.find id defset] else [] in
+  let get_def id = if Namemap.mem id defset then Namemap.find id defset else [] in
   match List.concat (List.map get_def comp) with
   | [] -> []
   | [def] -> [def]
-  | (def :: _) as defs ->
+  | (((DEF_fundef _ | DEF_internal_mutrec _) as def) :: _) as defs ->
      let get_fundefs = function
        | DEF_fundef fundef -> [fundef]
        | DEF_internal_mutrec fundefs -> fundefs
@@ -647,6 +654,8 @@ let def_of_component graph defset comp =
      let fundefs = List.concat (List.map get_fundefs defs) in
      print_dot graph (List.map (fun fd -> string_of_id (id_of_fundef fd)) fundefs);
      [DEF_internal_mutrec fundefs]
+  (* We could merge other stuff, in particular overloads, but don't need to just now *)
+  | defs -> defs
 
 let top_sort_defs (Defs defs) =
   let prelude, original_order, defset, graph =
-- 
cgit v1.2.3


From fc5558d2b62365ea65818947780081dad74d4526 Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Fri, 8 Feb 2019 18:14:08 +0000
Subject: Resurrect Sail output option (with new name: -output_sail)

---
 src/sail.ml | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'src')

diff --git a/src/sail.ml b/src/sail.ml
index eeacbb2d..b059ae08 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -251,6 +251,9 @@ let options = Arg.align ([
   ( "-verbose",
     Arg.Int (fun verbosity -> Util.opt_verbosity := verbosity),
     " produce verbose output");
+  ( "-output_sail",
+    Arg.Set opt_print_verbose,
+    " print Sail code after type checking and initial rewriting");
   ( "-ddump_tc_ast",
     Arg.Set opt_ddump_tc_ast,
     " (debug) dump the typechecked ast to stdout");
-- 
cgit v1.2.3


From ad868ef0ad22a78021a5de91073416f69e8163d3 Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Fri, 8 Feb 2019 18:04:51 +0000
Subject: Add missing functions to HOL monad wrapper

Also make the rewriter keep failed assertions in output when pruning
blocks.
---
 src/rewrites.ml | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/rewrites.ml b/src/rewrites.ml
index b47650b7..5a70a721 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -4012,12 +4012,13 @@ let rewrite_defs_remove_superfluous_letbinds env =
        | _ -> E_aux (exp,annot)
        end
     | E_internal_plet (_, E_aux (E_throw e, a), _) -> E_aux (E_throw e, a)
-    | E_internal_plet (_, E_aux (E_assert (c, msg), a), _) ->
+    | E_internal_plet (pat, (E_aux (E_assert (c, msg), a) as assert_exp), _) ->
        begin match typ_of c with
        | Typ_aux (Typ_app (Id_aux (Id "atom_bool", _), [A_aux (A_bool nc, _)]), _)
          when prove __POS__ (env_of c) (nc_not nc) ->
           (* Drop rest of block after an 'assert(false)' *)
-          E_aux (E_exit (infer_exp (env_of c) (mk_lit_exp L_unit)), a)
+          let exit_exp = E_aux (E_exit (infer_exp (env_of c) (mk_lit_exp L_unit)), a) in
+          E_aux (E_internal_plet (pat, assert_exp, exit_exp), annot)
        | _ ->
           E_aux (exp, annot)
        end
-- 
cgit v1.2.3


From 88c956dc0ee2e4e22c04d7a841d070cca7cca2a0 Mon Sep 17 00:00:00 2001
From: Prashanth Mundkur
Date: Thu, 7 Feb 2019 14:30:41 -0800
Subject: Add parameterization support for bitfields.

This supports the following syntax:

  type xlen : Int = 64
  type ylen : Int = 1

  type xlenbits = bits(xlen)

  bitfield Mstatus : xlenbits = {
    SD  : xlen - ylen,
    SXL : xlen - ylen - 1 .. xlen - ylen - 3
  }
---
 src/ast_util.ml            |  9 +++++++--
 src/ast_util.mli           |  1 +
 src/bitfield.ml            | 25 ++++++++++++++++++-------
 src/initial_check.ml       | 20 +++++++++++++++++---
 src/parse_ast.ml           |  4 ++--
 src/parser.mly             |  4 ++--
 src/pretty_print_common.ml |  2 ++
 src/pretty_print_coq.ml    | 22 ++++++++++++++++------
 src/pretty_print_lem.ml    | 13 +++++++++++--
 src/type_check.ml          |  5 ++++-
 10 files changed, 80 insertions(+), 25 deletions(-)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index 03031767..b3ab2cfd 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -236,6 +236,11 @@ let rec is_nexp_constant (Nexp_aux (nexp, _)) = match nexp with
   | Nexp_exp n | Nexp_neg n -> is_nexp_constant n
   | Nexp_app (_, nexps) -> List.for_all is_nexp_constant nexps
 
+let int_of_nexp_opt nexp =
+  match nexp with
+  | Nexp_aux(Nexp_constant i,_) -> Some i
+  | _ -> None
+
 let rec nexp_simp (Nexp_aux (nexp, l)) = Nexp_aux (nexp_simp_aux nexp, l)
 and nexp_simp_aux = function
   (* (n - (n - m)) often appears in foreach loops *)
@@ -911,8 +916,8 @@ and string_of_letbind (LB_aux (lb, l)) =
 
 let rec string_of_index_range (BF_aux (ir, _)) =
   match ir with
-  | BF_single n -> Big_int.to_string n
-  | BF_range (n, m) -> Big_int.to_string n ^ " .. " ^ Big_int.to_string m
+  | BF_single n -> string_of_nexp n
+  | BF_range (n, m) -> string_of_nexp n ^ " .. " ^ string_of_nexp m
   | BF_concat (ir1, ir2) -> "(" ^ string_of_index_range ir1 ^ ") : (" ^ string_of_index_range ir2 ^ ")"
 
 
diff --git a/src/ast_util.mli b/src/ast_util.mli
index 4cbea3dc..c4eb0b4b 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -337,6 +337,7 @@ end
 val nexp_frees : nexp -> KidSet.t
 val nexp_identical : nexp -> nexp -> bool
 val is_nexp_constant : nexp -> bool
+val int_of_nexp_opt : nexp -> Big_int.num option
 
 val lexp_to_exp : 'a lexp -> 'a exp
 
diff --git a/src/bitfield.ml b/src/bitfield.ml
index e8250598..1f64adbd 100644
--- a/src/bitfield.ml
+++ b/src/bitfield.ml
@@ -150,19 +150,30 @@ let index_range_update name field order start stop =
 let index_range_overload name field order =
   ast_of_def_string (Printf.sprintf "overload _mod_%s = {_get_%s_%s, _set_%s_%s}" field name field name field)
 
-let index_range_accessor name field order (BF_aux (bf_aux, l)) =
+let index_range_accessor (eval, typ_error) name field order (BF_aux (bf_aux, l)) =
   let getter n m = index_range_getter name field order (Big_int.to_int n) (Big_int.to_int m) in
   let setter n m = index_range_setter name field order (Big_int.to_int n) (Big_int.to_int m) in
   let update n m = index_range_update name field order (Big_int.to_int n) (Big_int.to_int m) in
   let overload = index_range_overload name field order in
+  let const_fold nexp = match eval nexp with
+      | Some v -> v
+      | None -> typ_error l (Printf.sprintf "Non-constant index for field %s" field) in
   match bf_aux with
-  | BF_single n -> combine [getter n n; setter n n; update n n; overload]
-  | BF_range (n, m) -> combine [getter n m; setter n m; update n m; overload]
+  | BF_single n ->
+        let n = const_fold n in
+        combine [getter n n; setter n n; update n n; overload]
+  | BF_range (n, m) ->
+        let n, m = const_fold n, const_fold m in
+        combine [getter n m; setter n m; update n m; overload]
   | BF_concat _ -> failwith "Unimplemented"
 
-let field_accessor name order (id, ir) = index_range_accessor name (string_of_id id) order ir
+let field_accessor (eval, typ_error) name order (id, ir) =
+  index_range_accessor (eval, typ_error) name (string_of_id id) order ir
 
-let macro id size order ranges =
+let macro (eval, typ_error) id size order ranges =
   let name = string_of_id id in
-  let ranges = (mk_id "bits", BF_aux (BF_range (Big_int.of_int (size - 1), Big_int.of_int 0), Parse_ast.Unknown)) :: ranges in
-  combine ([newtype name size order; constructor name order (size - 1) 0] @ List.map (field_accessor name order) ranges)
+  let ranges = (mk_id "bits", BF_aux (BF_range (nconstant (Big_int.of_int (size - 1)),
+                                                nconstant (Big_int.of_int 0)),
+                                      Parse_ast.Unknown)) :: ranges in
+  combine ([newtype name size order; constructor name order (size - 1) 0]
+           @ List.map (field_accessor (eval, typ_error) name order) ranges)
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 108e04d0..07316c6d 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -201,6 +201,20 @@ and to_ast_nexp ctx (P.ATyp_aux (aux, l)) =
   in
   Nexp_aux (aux, l)
 
+and to_ast_bitfield_index_nexp (P.ATyp_aux (aux, l)) =
+  let aux = match aux with
+    | P.ATyp_id id -> Nexp_id (to_ast_id id)
+    | P.ATyp_lit (P.L_aux (P.L_num c, _)) -> Nexp_constant c
+    | P.ATyp_sum (t1, t2) -> Nexp_sum (to_ast_bitfield_index_nexp t1, to_ast_bitfield_index_nexp t2)
+    | P.ATyp_exp t1 -> Nexp_exp (to_ast_bitfield_index_nexp t1)
+    | P.ATyp_neg t1 -> Nexp_neg (to_ast_bitfield_index_nexp t1)
+    | P.ATyp_times (t1, t2) -> Nexp_times (to_ast_bitfield_index_nexp t1, to_ast_bitfield_index_nexp t2)
+    | P.ATyp_minus (t1, t2) -> Nexp_minus (to_ast_bitfield_index_nexp t1, to_ast_bitfield_index_nexp t2)
+    | P.ATyp_app (id, ts) -> Nexp_app (to_ast_id id, List.map (to_ast_bitfield_index_nexp) ts)
+    | _ -> raise (Reporting.err_typ l "Invalid numeric expression in field index")
+  in
+  Nexp_aux (aux, l)
+
 and to_ast_order ctx (P.ATyp_aux (aux, l)) =
   match aux with
   | ATyp_var v -> Ord_aux (Ord_var (to_ast_var v), l)
@@ -503,9 +517,9 @@ let to_ast_spec ctx (val_:P.val_spec) : (unit val_spec) ctx_out =
 let rec to_ast_range (P.BF_aux(r,l)) = (* TODO add check that ranges are sensible for some definition of sensible *)
   BF_aux(
     (match r with
-    | P.BF_single(i) -> BF_single(i)
-    | P.BF_range(i1,i2) -> BF_range(i1,i2)
-    | P.BF_concat(ir1,ir2) -> BF_concat( to_ast_range ir1, to_ast_range ir2)),
+    | P.BF_single(i) -> BF_single(to_ast_bitfield_index_nexp i)
+    | P.BF_range(i1,i2) -> BF_range(to_ast_bitfield_index_nexp i1,to_ast_bitfield_index_nexp i2)
+    | P.BF_concat(ir1,ir2) -> BF_concat(to_ast_range ir1, to_ast_range ir2)),
     l)
 
 let to_ast_type_union ctx (P.Tu_aux (P.Tu_ty_id (atyp, id), l)) =
diff --git a/src/parse_ast.ml b/src/parse_ast.ml
index 6401331e..eb5c3dc6 100644
--- a/src/parse_ast.ml
+++ b/src/parse_ast.ml
@@ -371,8 +371,8 @@ type_union =
 
 type 
 index_range_aux =  (* index specification, for bitfields in register types *)
-   BF_single of Big_int.num (* single index *)
- | BF_range of Big_int.num * Big_int.num (* index range *)
+   BF_single of atyp       (* single index *)
+ | BF_range of atyp * atyp (* index range *)
  | BF_concat of index_range * index_range (* concatenation of index ranges *)
 
 and index_range = 
diff --git a/src/parser.mly b/src/parser.mly
index cbbc41e3..bd832d28 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -1130,9 +1130,9 @@ funcl_typ:
     { mk_tannot mk_typqn $1 $startpos $endpos }
 
 index_range:
-  | Num
+  | typ
     { mk_ir (BF_single $1) $startpos $endpos }
-  | Num DotDot Num
+  | typ DotDot typ
     { mk_ir (BF_range ($1, $3)) $startpos $endpos }
 
 r_id_def:
diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml
index c01896ac..3a1deed0 100644
--- a/src/pretty_print_common.ml
+++ b/src/pretty_print_common.ml
@@ -89,10 +89,12 @@ let doc_id (Id_aux(i,_)) =
        * token in case of x ending with star. *)
       parens (separate space [string "deinfix"; string x; empty])
 
+(*
 let rec doc_range (BF_aux(r,_)) = match r with
   | BF_single i -> doc_int i
   | BF_range(i1,i2) -> doc_op dotdot (doc_int i1) (doc_int i2)
   | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2)
+*)
 
 let print ?(len=100) channel doc = ToChannel.pretty 1. len channel doc
 let to_buf ?(len=100) buf doc = ToBuffer.pretty 1. len buf doc
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index bb6a3d6a..4596f23f 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -1896,10 +1896,12 @@ let doc_type_union ctxt typ_name (Tu_aux(Tu_ty_id(typ,id),_)) =
   separate space [doc_id_ctor id; colon;
                   doc_typ ctxt typ; arrow; typ_name]
 
-let rec doc_range (BF_aux(r,_)) = match r with
-  | BF_single i -> parens (doc_op comma (doc_int i) (doc_int i))
-  | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2))
-  | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2)
+(*
+let rec doc_range ctxt (BF_aux(r,_)) = match r with
+  | BF_single i -> parens (doc_op comma (doc_nexp ctxt i) (doc_nexp ctxt i))
+  | BF_range(i1,i2) -> parens (doc_op comma (doc_nexp ctxt i1) (doc_nexp ctxt i2))
+  | BF_concat(ir1,ir2) -> (doc_range ctxt ir1) ^^ comma ^^ (doc_range ctxt ir2)
+ *)
 
 let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
   | TD_abbrev(id,typq,A_aux (A_typ typ, _)) ->
@@ -2408,7 +2410,15 @@ let is_field_accessor regtypes fdef =
      (access = "get" || access = "set") && is_field_of regtyp field
   | _ -> false
 
+
+let int_of_field_index tname fid nexp =
+  match int_of_nexp_opt nexp with
+  | Some i -> i
+  | None -> raise (Reporting.err_typ Parse_ast.Unknown
+                   ("Non-constant bitfield index in field " ^ string_of_id fid ^ " of " ^ tname))
+
 let doc_regtype_fields (tname, (n1, n2, fields)) =
+  let const_int fid idx = int_of_field_index tname fid idx in
   let i1, i2 = match n1, n2 with
     | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> i1, i2
     | _ -> raise (Reporting.err_typ Parse_ast.Unknown
@@ -2417,8 +2427,8 @@ let doc_regtype_fields (tname, (n1, n2, fields)) =
   let dir = (if dir_b then "true" else "false") in
   let doc_field (fr, fid) =
     let i, j = match fr with
-    | BF_aux (BF_single i, _) -> (i, i)
-    | BF_aux (BF_range (i, j), _) -> (i, j)
+    | BF_aux (BF_single i, _) -> let i = const_int fid i in (i, i)
+    | BF_aux (BF_range (i, j), _) -> (const_int fid i, const_int fid j)
     | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__
         ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in
     let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 7d2cc479..dee0a29f 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1016,10 +1016,12 @@ let doc_type_union_lem env (Tu_aux(Tu_ty_id(typ,id),_)) =
   separate space [pipe; doc_id_lem_ctor id; string "of";
                   parens (doc_typ_lem env typ)]
 
+(*
 let rec doc_range_lem (BF_aux(r,_)) = match r with
   | BF_single i -> parens (doc_op comma (doc_int i) (doc_int i))
   | BF_range(i1,i2) -> parens (doc_op comma (doc_int i1) (doc_int i2))
   | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2)
+ *)
 
 let doc_typdef_lem env (TD_aux(td, (l, annot))) = match td with
   | TD_abbrev(id,typq,A_aux (A_typ typ, _)) ->
@@ -1392,7 +1394,14 @@ let is_field_accessor regtypes fdef =
      (access = "get" || access = "set") && is_field_of regtyp field
   | _ -> false
 
+let int_of_field_index tname fid nexp =
+  match int_of_nexp_opt nexp with
+  | Some i -> i
+  | None -> raise (Reporting.err_typ Parse_ast.Unknown
+                   ("Non-constant bitfield index in field " ^ string_of_id fid ^ " of " ^ tname))
+
 let doc_regtype_fields (tname, (n1, n2, fields)) =
+  let const_int fid idx = int_of_field_index tname fid idx in
   let i1, i2 = match n1, n2 with
     | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> i1, i2
     | _ -> raise (Reporting.err_typ Parse_ast.Unknown
@@ -1401,8 +1410,8 @@ let doc_regtype_fields (tname, (n1, n2, fields)) =
   let dir = (if dir_b then "true" else "false") in
   let doc_field (fr, fid) =
     let i, j = match fr with
-    | BF_aux (BF_single i, _) -> (i, i)
-    | BF_aux (BF_range (i, j), _) -> (i, j)
+    | BF_aux (BF_single i, _) -> let i = const_int fid i in (i, i)
+    | BF_aux (BF_range (i, j), _) -> (const_int fid i, const_int fid j)
     | _ -> raise (Reporting.err_unreachable Parse_ast.Unknown __POS__
        ("Unsupported type in field " ^ string_of_id fid ^ " of " ^ tname)) in
     let fsize = Big_int.succ (Big_int.abs (Big_int.sub i j)) in
diff --git a/src/type_check.ml b/src/type_check.ml
index f31da5f4..a19f77de 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -4787,7 +4787,10 @@ let rec check_typedef : 'a. Env.t -> 'a type_def -> (tannot def) list * Env.t =
                                A_aux (A_typ (Typ_aux (Typ_id b, _)), _)]), _)
             when string_of_id v = "vector" && string_of_id b = "bit" ->
           let size = Big_int.to_int size in
-          let (Defs defs), env = check env (Bitfield.macro id size order ranges) in
+          let eval_index_nexp env nexp =
+            int_of_nexp_opt (nexp_simp (Env.expand_nexp_synonyms env nexp)) in
+          let (Defs defs), env =
+            check env (Bitfield.macro (eval_index_nexp env, (typ_error env)) id size order ranges) in
           defs, env
        | _ ->
           typ_error env l "Bad bitfield type"
-- 
cgit v1.2.3


From ee7a00b1ede8ed991d5fac416f93b09b9a5b0d01 Mon Sep 17 00:00:00 2001
From: Prashanth Mundkur
Date: Wed, 30 Jan 2019 18:07:57 -0800
Subject: Slightly tweak the help message.

---
 src/sail.ml | 30 +++++++++++++++---------------
 1 file changed, 15 insertions(+), 15 deletions(-)

(limited to 'src')

diff --git a/src/sail.ml b/src/sail.ml
index b059ae08..06bd618e 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -99,7 +99,7 @@ let options = Arg.align ([
     " output an OCaml translated version of the input");
   ( "-ocaml-nobuild",
     Arg.Set Ocaml_backend.opt_ocaml_nobuild,
-    " do not build generated ocaml");
+    " do not build generated OCaml");
   ( "-ocaml_trace",
     Arg.Tuple [Arg.Set opt_print_ocaml; Arg.Set Initial_check.opt_undefined_gen; Arg.Set Ocaml_backend.opt_trace_ocaml],
     " output an OCaml translated version of the input with tracing instrumentation, implies -ocaml");
@@ -108,28 +108,31 @@ let options = Arg.align ([
     " set a custom directory to build generated OCaml");
   ( "-ocaml-coverage",
     Arg.Set Ocaml_backend.opt_ocaml_coverage,
-    " Build ocaml with bisect_ppx coverage reporting (requires opam packages bisect_ppx-ocamlbuild and bisect_ppx).");
+    " build OCaml with bisect_ppx coverage reporting (requires opam packages bisect_ppx-ocamlbuild and bisect_ppx).");
   ( "-ocaml_generators",
     Arg.String (fun s -> opt_ocaml_generators := s::!opt_ocaml_generators),
     "<types> produce random generators for the given types");
   ( "-latex",
     Arg.Tuple [Arg.Set opt_print_latex; Arg.Clear Type_check.opt_expand_valspec ],
-    " pretty print the input to latex");
+    " pretty print the input to LaTeX");
+  ( "-latex_prefix",
+    Arg.String (fun prefix -> Latex.opt_prefix := prefix),
+    " set a custom prefix for generated LaTeX macro command (default sail)");
   ( "-latex_full_valspecs",
     Arg.Clear Latex.opt_simple_val,
-    " print full valspecs in latex output latex");
+    " print full valspecs in LaTeX output");
   ( "-c",
     Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen],
     " output a C translated version of the input");
   ( "-c_include",
     Arg.String (fun i -> opt_includes_c := i::!opt_includes_c),
-    " <filename> provide additional include for C output");
+    "<filename> provide additional include for C output");
   ( "-c_no_main",
     Arg.Set C_backend.opt_no_main,
     " do not generate the main() function" );
   ( "-elf",
     Arg.String (fun elf -> opt_process_elf := Some elf),
-    " process an elf file so that it can be executed by compiled C code");
+    " process an ELF file so that it can be executed by compiled C code");
   ( "-O",
     Arg.Tuple [Arg.Set C_backend.optimize_primops;
                Arg.Set C_backend.optimize_hoist_allocations;
@@ -140,22 +143,22 @@ let options = Arg.align ([
     " turn on optimizations for C compilation");
   ( "-Oconstant_fold",
     Arg.Set Constant_fold.optimize_constant_fold,
-    " Apply constant folding optimizations");
+    " apply constant folding optimizations");
   ( "-Oexperimental",
     Arg.Set C_backend.optimize_experimental,
     " turn on additional, experimental optimisations");
   ( "-static",
     Arg.Set C_backend.opt_static,
-    " Make generated C functions static");
+    " make generated C functions static");
   ( "-trace",
     Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml],
-    " Instrument ouput with tracing");
+    " instrument output with tracing");
   ( "-smt_trace",
     Arg.Tuple [Arg.Set C_backend.opt_smt_trace],
-    " Instrument ouput with tracing for SMT");
+    " instrument output with tracing for SMT");
   ( "-cgen",
     Arg.Set opt_print_cgen,
-    " Generate CGEN source");
+    " generate CGEN source");
   ( "-lem",
     Arg.Set opt_print_lem,
     " output a Lem translated version of the input");
@@ -192,9 +195,6 @@ let options = Arg.align ([
   ( "-dcoq_debug_on",
     Arg.String (fun f -> Pretty_print_coq.opt_debug_on := f::!Pretty_print_coq.opt_debug_on),
     "<function> produce debug messages for Coq output on given function");
-  ( "-latex_prefix",
-    Arg.String (fun prefix -> Latex.opt_prefix := prefix),
-    " set a custom prefix for generated latex command (default sail)");
   ( "-mono_split",
     Arg.String (fun s ->
       let l = Util.split_on_char ':' s in
@@ -283,7 +283,7 @@ let options = Arg.align ([
     " (debug) print debugging output for a single function");
   ( "-dprofile",
     Arg.Set Profile.opt_profile,
-    " (debug) provides basic profiling information for rewriting passes within Sail");
+    " (debug) provide basic profiling information for rewriting passes within Sail");
   ( "-slice",
     Arg.String (fun s -> opt_slice := s::!opt_slice),
     "<id> produce version of input restricted to the given function");
-- 
cgit v1.2.3


From ee2eb2bad10ad8d7c730538f239474ce103efa16 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Fri, 8 Feb 2019 23:06:47 +0000
Subject: Cleanup src Makefile

When we are building from git, we put the git version info in manifest.ml, so
we'll get the following from sail -v

Sail $last_git_tag ($branch @ $commit_sha)

If we are be built from opam we can't assume we are in a git repository as
opam downloads specific tags as tarballs, so instead we check for the precense
of SHARE_DIR which is set by our opam build script, and instead output

Sail 0.8 (sail2 @ opam)

which is the next git tag (current is 0.7.1, this must be updated by hand),
the branch name from which opam releases are generated and then opam rather
than the commit SHA.

I also removed the Makefile-non-opam file as it's bitrotted and unused
---
 src/Makefile          |  39 +++------
 src/Makefile-non-opam | 217 --------------------------------------------------
 2 files changed, 10 insertions(+), 246 deletions(-)
 delete mode 100644 src/Makefile-non-opam

(limited to 'src')

diff --git a/src/Makefile b/src/Makefile
index aeb23b9e..b0b22f77 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -62,16 +62,14 @@ endif
 endif
 
 
-.PHONY: all sail coverage sail.native sail.byte manifest.ml test clean doc lib power test_power test_idempotence
+.PHONY: all sail isail coverage sail.native sail.byte manifest.ml clean doc lib
 
 # set to -p on command line to enable gprof profiling
 OCAML_OPTS?=
 
-SHARE_DIR?=$(realpath ..)
-
 all: sail lib doc
 
-full: sail lib power doc test
+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
@@ -87,15 +85,19 @@ bytecode.ml: bytecode.lem
 	lem -ocaml bytecode.lem -lib . -lib gen_lib/
 	sed -i.bak -f ast.sed bytecode.ml
 
-lem_interp/interp_ast.lem: ../language/l2.ott
-	ott -sort false -generate_aux_rules true -o lem_interp/interp_ast.lem -picky_multiple_parses true ../language/l2.ott
-
 manifest.ml:
 	echo "(* Generated file -- do not edit. *)" > manifest.ml
-	echo let dir=\"$(SHARE_DIR)\" >> manifest.ml
+ifndef SHARE_DIR
+	echo let dir=\"$(realpath ..)\" >> manifest.ml
 	echo let commit=\"$(shell git rev-parse HEAD)\" >> manifest.ml
 	echo let branch=\"$(shell  git rev-parse --abbrev-ref HEAD)\" >> manifest.ml
 	echo let version=\"$(shell git describe)\" >> manifest.ml
+else
+	echo let dir=\"$(SHARE_DIR)\" >> manifest.ml
+	echo let commit=\"opam\" >> manifest.ml
+	echo let branch=\"sail2\" >> manifest.ml
+	echo let version=\"0.8\" >> manifest.ml
+endif
 
 sail: ast.ml bytecode.ml manifest.ml
 	ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa
@@ -115,31 +117,10 @@ interpreter: lem_interp/interp_ast.lem
 	ocamlbuild -use-ocamlfind lem_interp/extract.cmxa
 	ocamlbuild -use-ocamlfind lem_interp/extract.cma
 
-test: sail interpreter
-	ocamlbuild -use-ocamlfind test/run_tests.native
-	./run_tests.native
-
 THIS_MAKEFILE := $(realpath $(lastword $(MAKEFILE_LIST)))
 SAIL_DIR:=$(realpath $(dir $(THIS_MAKEFILE))..)
 PROJECT_ROOT=$(realpath $(dir $(THIS_MAKEFILE))../..)
 
-_build/sail_values.ml: gen_lib/sail_values.ml
-	$(CP_TO_BUILD)
-
-_build/power.ml: $(SAIL_DIR)/src/test/power.sail sail.native
-	cd _build; \
-	./sail.native -lem_ast -ocaml $< -o $(basename $(@))
-
-_build/power.native: _build/sail_values.ml _build/power.ml
-	env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package zarith -package unix -I _build -linkpkg $^ -o $@
-
-_build/armv8_embed.ml: sail.native
-	make -C ../arm ocaml
-	cp ../arm/build/armv8_embed.ml $@
-
-_build/arm.native: _build/sail_values.ml _build/armv8_embed.ml
-	env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package zarith -package unix -I _build -linkpkg $^ -o $@
-
 clean:
 	-ocamlbuild -clean
 	-rm -rf _build *.native
diff --git a/src/Makefile-non-opam b/src/Makefile-non-opam
deleted file mode 100644
index ebd82c09..00000000
--- a/src/Makefile-non-opam
+++ /dev/null
@@ -1,217 +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.                                                          #
-##########################################################################
-
-THIS_MAKEFILE := $(lastword $(MAKEFILE_LIST))
-# NOTE: it matters that this path is *not* canonicalised (realpath'd).
-# If we realpath it, the ocaml deps files will include realpaths, and
-# make won't know they're the same CMX files that we're building. So
-# will not correctly merge dependency subgraphs, and we will not build
-# stuff in the right order.
-# In general, the lesson is that the whole system needs to use the same
-# path, whether absolute or relative, to name a given file.
-# Sometimes that's difficult. Rules which cd to another directory break
-# if we're using absolute paths. I have used $(realpath $(srcdir)) in
-# those cases. This is not ideal. We shouldn't cd unless we really have to.
-srcdir := $(dir $(THIS_MAKEFILE))
-$(warning srcdir is $(srcdir))
-
-BITSTRING ?= $(srcdir)/contrib/bitstring
-BATTERIES ?= $(srcdir)/contrib/batteries-included/_build/src
-UINT ?= $(srcdir)/contrib/ocaml-uint/_build/lib
-
-export CAML_LD_LIBRARY_PATH := $(BITSTRING) $(CAML_LD_LIBRARY_PATH)
-
-LEM ?= ~/bitbucket/lem/lem
-LEMLIB ?= ~/bitbucket/lem/ocaml-lib/_build/
-OCAMLFLAGS +=  -I $(LEMLIB) # FIXME
-
-.PHONY: all sail test clean doc lib power test_power test_idempotence contrib install_elf
-all: sail lib doc
-full: all power test test
-sail: sail.native sail_lib.cma sail_lib.cmxa
-interpreter: _build/lem_interp/extract.cmxa _build/lem_interp/extract.cma
-sail.native sail_lib.cma sail_lib.cmxa:
-	ocamlbuild sail.native sail_lib.cma sail_lib.cmxa
-_build/lem_interp/extract.cmxa:
-	ocamlbuild lem_interp/extract.cmxa
-_build/lem_interp/extract.cma:
-	ocamlbuild lem_interp/extract.cma
-test: sail interpreter
-	ocamlbuild test/run_tests.native
-	./run_tests.native
-contrib:
-	cd contrib && ./checkout.sh
-install_elf:
-	cp -p ../../system-v-abi/src/*.lem elf_model/
-	cp -p ../../system-v-abi/src/*.ml elf_model/
-
-%.ml: %.lem
-	$(LEM) -outdir $$(dirname "$<") -ocaml -only_changed_output "$<"
-# HACK: special case for bitstring_local
-elf_model/bitstring_local.ml: elf_model/bitstring.lem
-	$(LEM) -outdir $$(dirname "$<") -ocaml -only_changed_output "$<"
-
-ELF_LEM_SRC := $(addprefix elf_model/,missing_pervasives.lem show.lem endianness.lem bitstring.lem elf_types.lem elf_interpreted_segment.lem elf_header.lem elf_file1.lem elf_program_header_table.lem elf_executable_file2.lem elf_section_header_table.lem elf_executable_file3.lem string_table.lem elf_executable_file4.lem elf_executable_file5.lem sail_interface.lem main.lem)
-vpath _build/%.lem .
-vpath _build/%.cmx .
-
-CAMLP4FLAGS += -nolib 
-CAMLP4FLAGS += -I $(srcdir)/contrib/$(BITSTRING)
-CAMLP4FLAGS += -parser o -parser op -printer p
-CAMLP4FLAGS += unix.cma 
-CAMLP4FLAGS += bitstring.cma 
-CAMLP4FLAGS += bitstring_persistent.cma 
-CAMLP4FLAGS += pa_bitstring.cmo
-
-# HACK: rewrite for bitstring_local
-ELF_ML_LEM := $(filter-out elf_model/bitstring.ml,$(patsubst %.lem,%.ml,$(ELF_LEM_SRC))) elf_model/bitstring_local.ml
-ELF_ML_SRC := $(addprefix elf_model/,error.ml ml_bindings.ml)  
-ELF_ML := $(ELF_ML_SRC) $(ELF_ML_LEM)
-ELF_ML_DEPS := $(patsubst %.ml,%.d,$(ELF_ML))
-ELF_CMX := $(patsubst %.ml,%.cmx,$(ELF_ML))
-
-$(ELF_CMX): OCAMLFLAGS += \
--I $(BITSTRING) -pp 'env CAML_LD_LIBRARY_PATH=$(BITSTRING) camlp4o $(CAMLP4FLAGS)' \
--I $(BATTERIES) \
--I $(UINT) \
--I $(srcdir)/elf_model
-
-$(ELF_ML_DEPS): OCAMLFLAGS += \
--I $(BITSTRING) -pp 'env CAML_LD_LIBRARY_PATH=$(BITSTRING) camlp4o $(CAMLP4FLAGS)' \
--I $(BATTERIES) \
--I $(UINT) \
--I $(srcdir)/elf_model
-
-$(ELF_ML_DEPS): %.d: %.ml
-	ocamldep -native $(OCAMLFLAGS) "$<" > "$@" || (rm -f "$@"; false)
-
-ifneq ($(MAKECMDGOALS),clean)
-include $(ELF_ML_DEPS)
-endif
-
-elf_extract.cmxa: OCAMLFLAGS += \
--I $(BITSTRING) -package bitstring,bitstring.syntax -syntax bitstring \
--I $(BATTERIES) -package batteries \
--I $(UINT) -package bitstring \
--pp 'camlp4 $(CAMLP4FLAGS)' \
--I $(LEMLIB)/../ocaml-lib/_build
-
-LEM_CMX :=  $(addprefix $(LEMLIB)/../ocaml-lib/,nat_num.cmx lem.cmx lem_function.cmx lem_list.cmx)
-
-%.cmx: %.ml
-	echo CAML_LD_LIBRARY_PATH is $$CAML_LD_LIBRARY_PATH 
-	ocamlopt $(OCAMLFLAGS) -c "$<"
-
-elf_model/elf_extract.cmxa: $(ELF_CMX)
-	ocamlopt $(OCAMLFLAGS) -a -o "$@" $+
-
-elf: $(ELF_CMX) $(LEM_CMX) elf_model/elf_extract.cmxa
-
-_build/test/power.lem: sail.native test/power.sail
-	mkdir -p _build/test
-	cp -p test/* _build/test/
-	cd _build/test && \
-	../../sail.native -lem_ast power.sail
-
-pprint/src/_build/PPrintLib.cmxa:
-	$(MAKE) -C $(srcdir)/pprint/src
-
-_build/test/run_power.native: OCAMLFLAGS += \
--I $(LEMLIB) \
--I $(srcdir)/_build/lem_interp/ \
--I $(srcdir)/elf_model/ \
--I $(UINT) 
-
-_build/test/run_power.native: OCAMLLIBS += \
-$(LEMLIB)/extract.cmxa
-
-_build/test/power.ml: _build/test/power.lem
-	cd _build/test && $(LEM) -ocaml -only_changed_output -lib $(realpath $(srcdir))/lem_interp/ power.lem
-	touch "$@" # HACK HACK HACK! why didn't lem update the timestamp?
-
-_build/test/run_power.native: pprint/src/_build/PPrintLib.cmxa _build/lem_interp/extract.cmxa elf_model/elf_extract.cmxa _build/test/power.ml test/run_power.ml
-	cd _build/test && \
-	ocamlopt $(OCAMLFLAGS) $(OCAMLLIBS) -I $(realpath $(srcdir))/_build/lem_interp $(addprefix $(realpath $(srcdir))/,$+) -o run_power.native
-
-power: run_power.native
-
-run_power.native: _build/test/run_power.native
-	ln -fs _build/test/run_power.native run_power.native
-
-test_power: power
-	./run_power.native --file ../../../rsem/idl/power/binary/main.bin
-
-test_power_interactive: power
-	./run_power.native --interactive --file ../../../rsem/idl/power/binary/main.bin
-
-test_power_interactive_srcs:
-	ebig ~/rsem/idl/power/generated/power.sail ../../../rsem/idl/power/binary/hello.c  ../../../rsem/idl/power/binary/hello.s 
-
-# or test/power.sail for cut-down one
-
-test_idempotence: sail
-	@cd test; for file in *.sail; do \
-		./idempotence.sh $$file; echo ;\
-	done
-
-clean:
-	#-ocamlbuild -clean
-	-rm -rf _build *.native
-	-rm -rf $(srcdir)/elf_model/*.o $(srcdir)/elf_model/*.cmx $(srcdir)/elf_model/*.cmi $(ELF_ML_LEM) $(ELF_ML_DEPS)
-	-rm -rf html-doc
-	-rm -rf tex-doc
-	-rm -rf lem lib
-	-rm -rf sail.docdir
-
-doc:
-	ocamlbuild sail.docdir/index.html
-
-lib:
-	ocamlbuild pretty_print.cmxa pretty_print.cma
-- 
cgit v1.2.3


From 2d2d077599da6bbb035db5fd79dfb6b26a4ba73c Mon Sep 17 00:00:00 2001
From: Brian Campbell
Date: Mon, 11 Feb 2019 12:07:13 +0000
Subject: Get the order of overrides correct during topsort

---
 src/spec_analysis.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index a8ddaf68..e26ea8a2 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -585,7 +585,7 @@ let scc ?(original_order : string list option) (g : graph) =
 let add_def_to_map id d defset =
   Namemap.add id
     (match Namemap.find id defset with
-     | t -> d::t
+     | t -> t@[d]
      | exception Not_found -> [d])
     defset
 
-- 
cgit v1.2.3


From 9d86711a30ba93a1de7a5112dcfb58365cdbf3fd Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Mon, 11 Feb 2019 16:16:30 +0000
Subject: Add tests for implicit arguments

---
 src/type_check.ml | 13 +++++++++++++
 1 file changed, 13 insertions(+)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index a19f77de..a236323b 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -805,9 +805,22 @@ end = struct
     with
     | Not_found -> typ_error env (id_loc id) ("No union constructor found for " ^ string_of_id id)
 
+  let rec valid_implicits env start = function
+    | Typ_aux (Typ_app (Id_aux (Id "implicit", _), [A_aux (A_nexp (Nexp_aux (Nexp_var v, _)), _)]), l) :: rest ->
+       if start then
+         valid_implicits env true rest
+       else
+         typ_error env l "Arguments are invalid, implicit arguments must come before all other arguments"
+    | Typ_aux (Typ_app (Id_aux (Id "implicit", _), [A_aux (A_nexp _, l)]), _) :: rest ->
+       typ_error env l "Implicit argument must contain a single type variable"
+    | _ :: rest -> valid_implicits env false rest
+    | [] -> ()
+
   let rec update_val_spec id (typq, typ) env =
     begin match expand_synonyms env typ with
     | Typ_aux (Typ_fn (arg_typs, ret_typ, effect), l) ->
+       valid_implicits env true arg_typs;
+
        (* We perform some canonicalisation for function types where existentials appear on the left, so
           ({'n, 'n >= 2, int('n)}, foo) -> bar
           would become
-- 
cgit v1.2.3


From 8a2b660710af1635a0568b5b63acd30b57d3c343 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Mon, 11 Feb 2019 22:52:55 +0000
Subject: Expand type synonyms for E_constraint and E_sizeof

---
 src/type_check.ml | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index a236323b..8d532bb3 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -3428,10 +3428,10 @@ and infer_exp env (E_aux (exp_aux, (l, ())) as exp) =
      end
   | E_lit lit -> annot_exp (E_lit lit) (infer_lit env lit)
   | E_sizeof nexp ->
-     irule infer_exp env (rewrite_sizeof l env nexp)
+     irule infer_exp env (rewrite_sizeof l env (Env.expand_nexp_synonyms env nexp))
   | E_constraint nc ->
      Env.wf_constraint env nc;
-     crule check_exp env (rewrite_nc env nc) (atom_bool_typ nc)
+     crule check_exp env (rewrite_nc env (Env.expand_constraint_synonyms env nc)) (atom_bool_typ nc)
   | E_field (exp, field) ->
      begin
        let inferred_exp = irule infer_exp env exp in
-- 
cgit v1.2.3


From 37673365b346de684ecf5fe031603f51c0e8e7a9 Mon Sep 17 00:00:00 2001
From: Alasdair
Date: Mon, 11 Feb 2019 23:51:16 +0000
Subject: Add an additional test case

Make LEXP_deref an inference rule. This should allow strictly more programs to type-check.
---
 src/type_check.ml | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/type_check.ml b/src/type_check.ml
index 8d532bb3..c9953c57 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -3285,14 +3285,6 @@ and bind_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) typ =
           subtyp l env typ typ_annot;
           annot_lexp (LEXP_cast (typ_annot, v)) typ, Env.add_local v (Mutable, typ_annot) env
      end
-  | LEXP_deref exp ->
-     let inferred_exp = infer_exp env exp in
-     begin match typ_of inferred_exp with
-     | Typ_aux (Typ_app (r, [A_aux (A_typ vtyp, _)]), _) when string_of_id r = "register" ->
-        subtyp l env typ vtyp; annot_lexp_effect (LEXP_deref inferred_exp) typ (mk_effect [BE_wreg]), env
-     | _ ->
-        typ_error env l (string_of_typ typ  ^ " must be a register type in " ^ string_of_exp exp ^ ")")
-     end
   | LEXP_id v ->
      begin match Env.lookup_id ~raw:true v env with
      | Local (Immutable, _) | Enum _ ->
@@ -3404,6 +3396,14 @@ and infer_lexp env (LEXP_aux (lexp_aux, (l, ())) as lexp) =
      in
      let typq, _, ret_typ, _ = Env.get_accessor rec_id fid env in
      annot_lexp_effect (LEXP_field (annot_lexp (LEXP_id v) (mk_id_typ rec_id), fid)) ret_typ weff
+  | LEXP_deref exp ->
+     let inferred_exp = infer_exp env exp in
+     begin match typ_of inferred_exp with
+     | Typ_aux (Typ_app (r, [A_aux (A_typ vtyp, _)]), _) when string_of_id r = "register" ->
+        annot_lexp_effect (LEXP_deref inferred_exp) vtyp (mk_effect [BE_wreg])
+     | _ ->
+        typ_error env l (string_of_typ (typ_of inferred_exp)  ^ " must be a register type in " ^ string_of_exp exp ^ ")")
+     end
   | LEXP_tup lexps ->
      let inferred_lexps = List.map (infer_lexp env) lexps in
      annot_lexp (LEXP_tup inferred_lexps) (tuple_typ (List.map lexp_typ_of inferred_lexps))
-- 
cgit v1.2.3


From 53d1437599500d87eb355b1598ef965cf2f13483 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 12 Feb 2019 14:33:43 +0000
Subject: Improvements for emacs mode

---
 src/ast_util.ml  | 113 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/ast_util.mli |   4 ++
 src/isail.ml     |  25 ++++++++++++
 3 files changed, 142 insertions(+)

(limited to 'src')

diff --git a/src/ast_util.ml b/src/ast_util.ml
index b3ab2cfd..5746a242 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -1815,3 +1815,116 @@ let typquant_subst_kid_aux sv subst = function
   | TypQ_no_forall -> TypQ_no_forall
 
 let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l)
+
+let rec simp_loc = function
+  | Parse_ast.Unknown -> None
+  | Parse_ast.Unique (_, l) -> simp_loc l
+  | Parse_ast.Generated l -> simp_loc l
+  | Parse_ast.Range (p1, p2) -> Some (p1, p2)
+  | Parse_ast.Documented (_, l) -> simp_loc l
+
+let before p1 p2 =
+  let open Lexing in
+  p1.pos_fname = p2.pos_fname && p1.pos_cnum <= p2.pos_cnum
+
+let subloc sl l =
+  match sl, simp_loc l with
+  | _, None -> false
+  | None, _ -> false
+  | Some (p1a, p1b), Some (p2a, p2b) ->
+     before p2a p1a && before p1b p2b
+
+let rec option_mapm f = function
+  | [] -> None
+  | x :: xs ->
+     begin match f x with
+     | Some y -> Some y
+     | None -> option_mapm f xs
+     end
+
+let option_chain opt1 opt2 =
+  begin match opt1 with
+  | None -> opt2
+  | _ -> opt1
+  end
+
+let rec find_annot_exp sl (E_aux (aux, (l, annot)) as exp) =
+  if not (subloc sl l) then None else
+    let result = match aux with
+      | E_block exps | E_tuple exps ->
+         option_mapm (find_annot_exp sl) exps
+      | E_app (id, exps) ->
+         option_mapm (find_annot_exp sl) exps
+      | E_let (LB_aux (LB_val (pat, exp), _), body) ->
+         option_chain (find_annot_pat sl pat) (option_mapm (find_annot_exp sl) [exp; body])
+      | E_assign (lexp, exp) ->
+         option_chain (find_annot_lexp sl lexp) (find_annot_exp sl exp)
+      | E_var (lexp, exp1, exp2) ->
+         option_chain (find_annot_lexp sl lexp) (option_mapm (find_annot_exp sl) [exp1; exp2])
+      | _ -> None
+    in
+    match result with
+    | None -> Some (l, annot)
+    | _ -> result
+
+and find_annot_lexp sl (LEXP_aux (aux, (l, annot))) =
+  if not (subloc sl l) then None else
+    let result = match aux with
+      | LEXP_vector_range (lexp, exp1, exp2) ->
+         option_chain (find_annot_lexp sl lexp) (option_mapm (find_annot_exp sl) [exp1; exp2])
+      | LEXP_deref exp ->
+         find_annot_exp sl exp
+      | LEXP_tup lexps ->
+         option_mapm (find_annot_lexp sl) lexps
+      | LEXP_memory (id, exps) ->
+         option_mapm (find_annot_exp sl) exps
+      | _ -> None
+    in
+    match result with
+    | None -> Some (l, annot)
+    | _ -> result
+
+and find_annot_pat sl (P_aux (aux, (l, annot))) =
+  if not (subloc sl l) then None else
+    let result = match aux with
+      | _ -> None
+    in
+    match result with
+    | None -> Some (l, annot)
+    | _ -> result
+
+and find_annot_pexp sl (Pat_aux (aux, (l, annot))) =
+  if not (subloc sl l) then None else
+    match aux with
+    | Pat_exp (pat, exp) ->
+       find_annot_exp sl exp
+    | Pat_when (pat, guard, exp) ->
+       None
+
+let find_annot_funcl sl (FCL_aux (FCL_Funcl (id, pexp), (l, annot))) =
+  if not (subloc sl l) then
+    None
+  else
+    match find_annot_pexp sl pexp with
+    | None -> Some (l, annot)
+    | result -> result
+
+let find_annot_fundef sl (FD_aux (FD_function (_, _, _, funcls), (l, annot))) =
+  if not (subloc sl l) then
+    None
+  else
+    match option_mapm (find_annot_funcl sl) funcls with
+    | None -> Some (l, annot)
+    | result -> result
+
+let rec find_annot_defs sl = function
+  | DEF_fundef fdef :: defs ->
+     begin match find_annot_fundef sl fdef with
+     | None -> find_annot_defs sl defs
+     | result -> result
+     end
+  | _ :: defs ->
+     find_annot_defs sl defs
+  | [] -> None
+
+let rec find_annot_ast sl (Defs defs) = find_annot_defs sl defs
diff --git a/src/ast_util.mli b/src/ast_util.mli
index c4eb0b4b..fe722f5e 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -440,3 +440,7 @@ val subst_kid : (kid -> typ_arg -> 'a -> 'a) -> kid -> kid -> 'a -> 'a
 
 val quant_item_subst_kid : kid -> kid -> quant_item -> quant_item
 val typquant_subst_kid : kid -> kid -> typquant -> typquant
+
+val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option
+
+val find_annot_ast : (Lexing.position * Lexing.position) option -> 'a defs -> (Ast.l * 'a) option
diff --git a/src/isail.ml b/src/isail.ml
index 89feb305..7d009791 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -481,6 +481,31 @@ let handle_input' input =
            vs_ids := Initial_check.val_spec_ids !Interactive.ast;
            Initial_check.have_undefined_builtins := false;
            Process_file.clear_symbols ()
+        | ":typeat" ->
+           let args = Str.split (Str.regexp " +") arg in
+           begin match args with
+           | [file; pos] ->
+              let open Lexing in
+              let pos = int_of_string pos in
+              let pos = { dummy_pos with pos_fname = file; pos_cnum = pos - 1 } in
+              let sl = Some (pos, pos) in
+              begin match find_annot_ast sl !Interactive.ast with
+              | Some annot ->
+                 let msg = String.escaped (string_of_typ (Type_check.typ_of_annot annot)) in
+                 begin match simp_loc (fst annot) with
+                 | Some (p1, p2) ->
+                    print_endline ("(sail-highlight-region "
+                                   ^ string_of_int (p1.pos_cnum + 1) ^ " " ^ string_of_int (p2.pos_cnum + 1)
+                                   ^ " \"" ^ msg ^ "\")")
+                 | None ->
+                    print_endline ("(message \"" ^ msg ^ "\")")
+                 end
+              | None ->
+                 print_endline "(message \"No type here\")"
+              end
+           | _ ->
+              print_endline "(error \"Bad arguments for type at cursor\")"
+           end
         | _ -> ()
         end
      | Expression _ | Empty -> ()
-- 
cgit v1.2.3


From 25a84ea4594de693808564b78c49c4fbefd0a555 Mon Sep 17 00:00:00 2001
From: Alasdair Armstrong
Date: Tue, 12 Feb 2019 17:58:30 +0000
Subject: Add a CHANGELOG file

Fix a bug where we generated empty definitions which pre 4.07 versions
of OCaml don't appear to support.
---
 src/ocaml_backend.ml | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index 3f34c422..d51aba75 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -591,22 +591,27 @@ let ocaml_typedef ctx (TD_aux (td_aux, (l, _))) =
       ^/^ rbrace)
      ^^ ocaml_def_end
      ^^ ocaml_string_of_struct ctx id typq fields
+     ^^ ocaml_def_end
   | TD_variant (id, _, cases, _) when string_of_id id = "exception" ->
      ocaml_exceptions ctx cases
+     ^^ ocaml_def_end
   | TD_variant (id, typq, cases, _) ->
      (separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals]
       ^//^ ocaml_cases ctx cases)
      ^^ ocaml_def_end
      ^^ ocaml_string_of_variant ctx id typq cases
+     ^^ ocaml_def_end
   | TD_enum (id, ids, _) ->
      (separate space [string "type"; zencode ctx id; equals]
       ^//^ (bar ^^ space ^^ ocaml_enum ctx ids))
      ^^ ocaml_def_end
      ^^ ocaml_string_of_enum ctx id ids
+     ^^ ocaml_def_end
   | TD_abbrev (id, typq, A_aux (A_typ typ, _)) ->
      separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals; ocaml_typ ctx typ]
      ^^ ocaml_def_end
      ^^ ocaml_string_of_abbrev ctx id typq typ
+     ^^ ocaml_def_end
   | TD_abbrev _ ->
      empty
   | TD_bitfield _ ->
@@ -634,7 +639,7 @@ let ocaml_def ctx def = match def with
   | DEF_fundef fd -> group (ocaml_fundef ctx fd) ^^ twice hardline
   | DEF_internal_mutrec fds ->
      separate_map (twice hardline) (fun fd -> group (ocaml_fundef ctx fd)) fds ^^ twice hardline
-  | DEF_type td -> nf_group (ocaml_typedef ctx td) ^^ ocaml_def_end
+  | DEF_type td -> nf_group (ocaml_typedef ctx td)
   | DEF_val lb -> nf_group (string "let" ^^ space ^^ ocaml_letbind ctx lb) ^^ ocaml_def_end
   | _ -> empty
 
-- 
cgit v1.2.3