Merge branch 'sail2' into rmem_interpreter

89 files changed, 5549 insertions, 4085 deletions

diff --git a/.gitignore b/.gitignore
index 377314b0..74f79a07 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,6 +12,8 @@ a.out
 _build/
 _sbuild/
 
+z3_problems
+
 # HOL4
 
 .HOLMK
diff --git a/aarch64_small/Makefile b/aarch64_small/Makefile
index 3a5da685..b9abec80 100644
--- a/aarch64_small/Makefile
+++ b/aarch64_small/Makefile
@@ -24,7 +24,7 @@ armV8.ml: armV8.lem ../src/lem_interp/interp_ast.lem
 	$(LEM) -ocaml -lib ../src/lem_interp/ $<
 
 
-armV8_embed.lem: $(SOURCES) ../etc/regfp2.sail aarch64_regfp.sail
+armV8_embed.lem: $(SOURCES) ../lib/regfp.sail aarch64_regfp.sail
 # also generates armV8_embed_sequential.lem, armV8_embed_types.lem, armV8_toFromInterp.lem
 	$(SAIL) $(SAILFLAGS) -lem -lem_lib ArmV8_extras_embed -o armV8 $^
 
diff --git a/aarch64_small/aarch64_regfp.sail b/aarch64_small/aarch64_regfp.sail
index 55f4a16b..ce155f0a 100644
--- a/aarch64_small/aarch64_regfp.sail
+++ b/aarch64_small/aarch64_regfp.sail
@@ -240,6 +240,32 @@ function initial_analysis (instr:ast) -> (regfps,regfps,regfps,niafps,diafp,inst
           IK_barrier(Barrier_ISB)
       };
     },
+
+    (DataCache(t,dc_op)) => {
+      iR = appendL(iR,xFP(t));
+
+      ik = match dc_op {
+        IVAC  => not_implemented("DC IVAC"),
+        ISW   => not_implemented("DC ISW"),
+        CSW   => not_implemented("DC CSW"),
+        CISW  => not_implemented("DC CISW"),
+        ZVA   => not_implemented("DC ZVA"),
+        CVAC  => not_implemented("DC CVAC"),
+        CVAU  => IK_cache_op(Cache_op_D_CVAU),
+        CIVAC => not_implemented("DC CIVAC")
+      };
+    },
+
+    (InstructionCache(t,ic_op)) => {
+      iR = appendL(iR,xFP(t));
+
+      ik = match ic_op {
+        IALLUIS => not_implemented("IC IALLUIS"),
+        IALLU   => not_implemented("IC IALLU"),
+        IVAU    => IK_cache_op(Cache_op_I_IVAU)
+      };
+    },
+
     (System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result))  => {
       oR = appendL(oR,xFP(t));
       not_implemented("System"); /* because SysOp_R and SysOp_W */
diff --git a/aarch64_small/armV8.h.sail b/aarch64_small/armV8.h.sail
index d0278d9d..b1eac1e7 100644
--- a/aarch64_small/armV8.h.sail
+++ b/aarch64_small/armV8.h.sail
@@ -64,6 +64,10 @@ bitfield TMSTATUS_type : bits(64) =
 register TMAbortEffect : TMSTATUS_type /* we abuse the register write to pass out the status value */
 register TMStartEffect : TMSTATUS_type /* we abuse the register read to pass in the status value */
 
+/* abuse register write effect, instead of adding proper effects: */
+register data_cache_operation_CVAU : bits(64)
+register instruction_cache_operation_IVAU : bits(64)
+
 /* General purpose registers */
 
 register R30 : bits(64)
diff --git a/aarch64_small/armV8.sail b/aarch64_small/armV8.sail
index 8e893e4b..f125ec72 100644
--- a/aarch64_small/armV8.sail
+++ b/aarch64_small/armV8.sail
@@ -61,6 +61,8 @@ union ast =  {
   ClearExclusiveMonitor : (uinteger),
   Barrier : (MemBarrierOp,MBReqDomain,MBReqTypes),
   System : (reg_index,uinteger,uinteger,uinteger,uinteger,uinteger,boolean),
+  DataCache : (reg_index,DCOp),
+  InstructionCache : (reg_index,ICOp),
   MoveSystemRegister : (reg_index,uinteger,uinteger,uinteger,uinteger,uinteger,boolean),
   TestBitAndBranch : {'R 'bit_pos, RegisterSize('R) & 0 <= 'bit_pos < 'R. (reg_index,int('R),int('bit_pos),bit,bits(64))},
   BranchImmediate : (BranchType,bits(64)),
@@ -462,24 +464,84 @@ function clause execute ( Barrier(op,domain,types) ) = {
 
 /* SYS L=0b0 */
 /* SYSL L=0b1 */
+/* The following are actually aliases of SYS: */
+/* DC L=0b0,SysOp(op1,CRn,CRm,op2) = Sys_DC */
+/* IC L=0b0,SysOp(op1,CRn,CRm,op2) = Sys_IC */
 function clause decodeSystem (0b1101010100@[L]@0b01@(op1 : bits(3))@(CRn : bits(4))@(CRm : bits(4))@(op2 : bits(3))@(Rt:bits(5))) = {
   /* FIXME: we don't allow register reads in the decoding */
   /* ARM: CheckSystemAccess(0b01, op1, CRn, CRm, op2, Rt, L);*/
 
   t : reg_index = UInt_reg(Rt);
 
-  sys_op0 : uinteger = 1;
-  sys_op1 : uinteger = UInt(op1);
-  sys_op2 : uinteger = UInt(op2);
-  sys_crn : uinteger = UInt(CRn);
-  sys_crm : uinteger = UInt(CRm);
-  has_result : boolean = (L == b1);
+  sysop : SystemOp = Sys_SYS;
+  if L == b0 then
+    sysop = SysOp(op1,CRn,CRm,op2);
+
+  match sysop {
+    Sys_AT => not_implemented("AT"),
+
+    Sys_DC =>
+        match (op1, CRm, op2) {
+          (0b000, 0b0110, 0b001) => Some(DataCache(t,IVAC)),
+          (0b000, 0b0110, 0b010) => Some(DataCache(t,ISW)),
+          (0b000, 0b1010, 0b010) => Some(DataCache(t,CSW)),
+          (0b000, 0b1110, 0b010) => Some(DataCache(t,CISW)),
+          (0b011, 0b0100, 0b001) => Some(DataCache(t,ZVA)),
+          (0b011, 0b1010, 0b001) => Some(DataCache(t,CVAC)),
+          (0b011, 0b1011, 0b001) => Some(DataCache(t,CVAU)),
+          (0b011, 0b1110, 0b001) => Some(DataCache(t,CIVAC)),
+          _ => error("should never happen")
+        },
+
+    Sys_IC =>
+        match (op1, CRm, op2) {
+          (0b000, 0b0001, 0b000) => Some(InstructionCache(t,IALLUIS)),
+          (0b000, 0b0101, 0b000) => Some(InstructionCache(t,IALLU)),
+          (0b011, 0b0101, 0b001) => Some(InstructionCache(t,IVAU)),
+          _ => error("should never happen")
+        },
+
+    Sys_TLBI => not_implemented("TLBI"),
+
+    Sys_SYS => {
+      sys_op0 : uinteger = 1;
+      sys_op1 : uinteger = UInt(op1);
+      sys_op2 : uinteger = UInt(op2);
+      sys_crn : uinteger = UInt(CRn);
+      sys_crm : uinteger = UInt(CRm);
+      has_result : boolean = (L == b1);
+
+      Some(System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result));
+    }
+  };
+}
 
-  Some(System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result));
+function clause execute ( DataCache(t,dc_op) ) = {
+  addr : bits(64) = rX(t);
+
+  match dc_op {
+    IVAC  => not_implemented("DC IVAC"),
+    ISW   => not_implemented("DC ISW"),
+    CSW   => not_implemented("DC CSW"),
+    CISW  => not_implemented("DC CISW"),
+    ZVA   => not_implemented("DC ZVA"),
+    CVAC  => not_implemented("DC CVAC"),
+    CVAU  => data_cache_operation_CVAU = addr,
+    CIVAC => not_implemented("DC CIVAC")
+  };
 }
 
-function clause execute ( System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result) ) =
-{
+function clause execute ( InstructionCache(t,ic_op) ) = {
+  addr : bits(64) = rX(t);
+
+  match ic_op {
+    IALLUIS => not_implemented("IC IALLUIS"),
+    IALLU   => not_implemented("IC IALLU"),
+    IVAU    => instruction_cache_operation_IVAU = addr
+  };
+}
+
+function clause execute ( System(t,sys_op0,sys_op1,sys_op2,sys_crn,sys_crm,has_result) ) = {
   if has_result then
     wX(t) = SysOp_R(sys_op0, sys_op1, sys_crn, sys_crm, sys_op2)
   else
@@ -2443,6 +2505,7 @@ end execute
 val supported_instructions : ast -> option(ast) effect {escape}
 function supported_instructions (instr) = {
   match instr {
+    Unallocated () => None (),
     _  => Some(instr)
   }
 }
diff --git a/aarch64_small/armV8_A64_lib.sail b/aarch64_small/armV8_A64_lib.sail
index ee9eabc9..cc65a03e 100644
--- a/aarch64_small/armV8_A64_lib.sail
+++ b/aarch64_small/armV8_A64_lib.sail
@@ -898,6 +898,70 @@ function Prefetch(address : bits(64), prfop : bits(5)) -> unit = {
 /** ENUMERATE:aarch64/instrs/system/barriers/barrierop/MemBarrierOp */
 /** ENUMERATE:aarch64/instrs/system/hints/syshintop/SystemHintOp */
 /** ENUMERATE:aarch64/instrs/system/register/cpsr/pstatefield/PSTATEField */
+/** FUNCTION:aarch64/instrs/system/sysops/sysop/SysOp */
+
+function SysOp(op1 : bits(3), CRn : bits(4), CRm : bits(4), op2 : bits(3)) -> SystemOp = {
+  match (op1@CRn@CRm@op2) {
+    (0b000@0b0111@0b1000@0b000) => Sys_AT,   /* S1E1R        */
+    (0b100@0b0111@0b1000@0b000) => Sys_AT,   /* S1E2R        */
+    (0b110@0b0111@0b1000@0b000) => Sys_AT,   /* S1E3R        */
+    (0b000@0b0111@0b1000@0b001) => Sys_AT,   /* S1E1W        */
+    (0b100@0b0111@0b1000@0b001) => Sys_AT,   /* S1E2W        */
+    (0b110@0b0111@0b1000@0b001) => Sys_AT,   /* S1E3W        */
+    (0b000@0b0111@0b1000@0b010) => Sys_AT,   /* S1E0R        */
+    (0b000@0b0111@0b1000@0b011) => Sys_AT,   /* S1E0W        */
+    (0b100@0b0111@0b1000@0b100) => Sys_AT,   /* S12E1R       */
+    (0b100@0b0111@0b1000@0b101) => Sys_AT,   /* S12E1W       */
+    (0b100@0b0111@0b1000@0b110) => Sys_AT,   /* S12E0R       */
+    (0b100@0b0111@0b1000@0b111) => Sys_AT,   /* S12E0W       */
+    (0b011@0b0111@0b0100@0b001) => Sys_DC,   /* ZVA          */
+    (0b000@0b0111@0b0110@0b001) => Sys_DC,   /* IVAC         */
+    (0b000@0b0111@0b0110@0b010) => Sys_DC,   /* ISW          */
+    (0b011@0b0111@0b1010@0b001) => Sys_DC,   /* CVAC         */
+    (0b000@0b0111@0b1010@0b010) => Sys_DC,   /* CSW          */
+    (0b011@0b0111@0b1011@0b001) => Sys_DC,   /* CVAU         */
+    (0b011@0b0111@0b1110@0b001) => Sys_DC,   /* CIVAC        */
+    (0b000@0b0111@0b1110@0b010) => Sys_DC,   /* CISW         */
+    (0b000@0b0111@0b0001@0b000) => Sys_IC,   /* IALLUIS      */
+    (0b000@0b0111@0b0101@0b000) => Sys_IC,   /* IALLU        */
+    (0b011@0b0111@0b0101@0b001) => Sys_IC,   /* IVAU         */
+    (0b100@0b1000@0b0000@0b001) => Sys_TLBI, /* IPAS2E1IS    */
+    (0b100@0b1000@0b0000@0b101) => Sys_TLBI, /* IPAS2LE1IS   */
+    (0b000@0b1000@0b0011@0b000) => Sys_TLBI, /* VMALLE1IS    */
+    (0b100@0b1000@0b0011@0b000) => Sys_TLBI, /* ALLE2IS      */
+    (0b110@0b1000@0b0011@0b000) => Sys_TLBI, /* ALLE3IS      */
+    (0b000@0b1000@0b0011@0b001) => Sys_TLBI, /* VAE1IS       */
+    (0b100@0b1000@0b0011@0b001) => Sys_TLBI, /* VAE2IS       */
+    (0b110@0b1000@0b0011@0b001) => Sys_TLBI, /* VAE3IS       */
+    (0b000@0b1000@0b0011@0b010) => Sys_TLBI, /* ASIDE1IS     */
+    (0b000@0b1000@0b0011@0b011) => Sys_TLBI, /* VAAE1IS      */
+    (0b100@0b1000@0b0011@0b100) => Sys_TLBI, /* ALLE1IS      */
+    (0b000@0b1000@0b0011@0b101) => Sys_TLBI, /* VALE1IS      */
+    (0b100@0b1000@0b0011@0b101) => Sys_TLBI, /* VALE2IS      */
+    (0b110@0b1000@0b0011@0b101) => Sys_TLBI, /* VALE3IS      */
+    (0b100@0b1000@0b0011@0b110) => Sys_TLBI, /* VMALLS12E1IS */
+    (0b000@0b1000@0b0011@0b111) => Sys_TLBI, /* VAALE1IS     */
+    (0b100@0b1000@0b0100@0b001) => Sys_TLBI, /* IPAS2E1      */
+    (0b100@0b1000@0b0100@0b101) => Sys_TLBI, /* IPAS2LE1     */
+    (0b000@0b1000@0b0111@0b000) => Sys_TLBI, /* VMALLE1      */
+    (0b100@0b1000@0b0111@0b000) => Sys_TLBI, /* ALLE2        */
+    (0b110@0b1000@0b0111@0b000) => Sys_TLBI, /* ALLE3        */
+    (0b000@0b1000@0b0111@0b001) => Sys_TLBI, /* VAE1         */
+    (0b100@0b1000@0b0111@0b001) => Sys_TLBI, /* VAE2         */
+    (0b110@0b1000@0b0111@0b001) => Sys_TLBI, /* VAE3         */
+    (0b000@0b1000@0b0111@0b010) => Sys_TLBI, /* ASIDE1       */
+    (0b000@0b1000@0b0111@0b011) => Sys_TLBI, /* VAAE1        */
+    (0b100@0b1000@0b0111@0b100) => Sys_TLBI, /* ALLE1        */
+    (0b000@0b1000@0b0111@0b101) => Sys_TLBI, /* VALE1        */
+    (0b100@0b1000@0b0111@0b101) => Sys_TLBI, /* VALE2        */
+    (0b110@0b1000@0b0111@0b101) => Sys_TLBI, /* VALE3        */
+    (0b100@0b1000@0b0111@0b110) => Sys_TLBI, /* VMALLS12E1   */
+    (0b000@0b1000@0b0111@0b111) => Sys_TLBI, /* VAALE1       */
+    _ => Sys_SYS
+  };
+}
+
+/** ENUMERATE:aarch64/instrs/system/sysops/sysop/SystemOp */
 /** FUNCTION:aarch64/translation/faults/AArch64.AlignmentFault */
 
 function AArch64_AlignmentFault(acctype : AccType, iswrite : boolean, secondstage : boolean) -> FaultRecord = {
diff --git a/aarch64_small/armV8_lib.h.sail b/aarch64_small/armV8_lib.h.sail
index 66071b3a..332ad18c 100644
--- a/aarch64_small/armV8_lib.h.sail
+++ b/aarch64_small/armV8_lib.h.sail
@@ -210,6 +210,13 @@ enum SystemHintOp =
 enum PSTATEField = 
   {PSTATEField_DAIFSet, PSTATEField_DAIFClr, PSTATEField_SP}
 
+enum SystemOp = {Sys_AT, Sys_DC, Sys_IC, Sys_TLBI, Sys_SYS}
+
+enum DCOp = {IVAC, ISW, CSW, CISW, ZVA, CVAC, CVAU, CIVAC}
+
+enum ICOp = {IALLUIS, IALLU, IVAU}
+
+
 val rPC : unit -> bits(64) effect {rreg}
 val rSP : forall 'N, 'N in {8,16,32,64}. implicit('N) -> bits('N) effect {rreg,escape}
 val wX : forall 'N, 'N in {8,16,32,64}. (reg_index,bits('N)) -> unit effect {wreg}
diff --git a/aarch64_small/gen/ast.hgen b/aarch64_small/gen/ast.hgen
index 60f130d7..98148a5c 100644
--- a/aarch64_small/gen/ast.hgen
+++ b/aarch64_small/gen/ast.hgen
@@ -1,3 +1,4 @@
+  | `AArch64Unallocated
   | `AArch64TMStart of inst_reg (* t *)
   | `AArch64TMCommit
   | `AArch64TMAbort of boolean*bit5 (* retry,reason *)
diff --git a/aarch64_small/gen/fold.hgen b/aarch64_small/gen/fold.hgen
index 4062d8e6..fbe52794 100644
--- a/aarch64_small/gen/fold.hgen
+++ b/aarch64_small/gen/fold.hgen
@@ -1,3 +1,4 @@
+| `AArch64Unallocated -> (y_reg, y_sreg)
 | `AArch64TMStart t -> fold_reg t (y_reg, y_sreg)
 | `AArch64TMCommit -> (y_reg, y_sreg)
 | `AArch64TMAbort (retry,reason) -> (y_reg, y_sreg)
diff --git a/aarch64_small/gen/herdtools_ast_to_shallow_ast.hgen b/aarch64_small/gen/herdtools_ast_to_shallow_ast.hgen
index 6fbb3eb2..b8fe851c 100644
--- a/aarch64_small/gen/herdtools_ast_to_shallow_ast.hgen
+++ b/aarch64_small/gen/herdtools_ast_to_shallow_ast.hgen
@@ -1,3 +1,4 @@
+| `AArch64Unallocated -> Unallocated
 | `AArch64TMStart t -> TMStart (translate_reg "t" t)
 
 | `AArch64TMCommit -> TMCommit
diff --git a/aarch64_small/gen/map.hgen b/aarch64_small/gen/map.hgen
index 62899c91..3d5419b4 100644
--- a/aarch64_small/gen/map.hgen
+++ b/aarch64_small/gen/map.hgen
@@ -1,3 +1,4 @@
+| `AArch64Unallocated -> `AArch64Unallocated
 | `AArch64TMStart t -> `AArch64TMStart (map_reg t)
 | `AArch64TMCommit -> `AArch64TMCommit
 | `AArch64TMAbort (retry,reason) -> `AArch64TMAbort (retry,reason)
diff --git a/aarch64_small/gen/pretty.hgen b/aarch64_small/gen/pretty.hgen
index 2bbf7af7..b412fdda 100644
--- a/aarch64_small/gen/pretty.hgen
+++ b/aarch64_small/gen/pretty.hgen
@@ -1,3 +1,6 @@
+| `AArch64Unallocated ->
+      "UNALLOCATED"
+
 | `AArch64TMStart t ->
       sprintf "TSTART %s" (pp_regzr Set64 t)
 
diff --git a/aarch64_small/gen/regs_out_in.hgen b/aarch64_small/gen/regs_out_in.hgen
index 724a574b..bab53be7 100644
--- a/aarch64_small/gen/regs_out_in.hgen
+++ b/aarch64_small/gen/regs_out_in.hgen
@@ -1,6 +1,7 @@
 (* for each instruction instance, identify the role of the registers
    and possible branching: (outputs, inputs, voidstars, branch) *)
 
+| `AArch64Unallocated -> failwith "UNALLOCATED is not implemented"
 | `AArch64TMStart t -> failwith "TSTART is not implemented"
 | `AArch64TMCommit -> failwith "TCOMMIT is not implemented"
 | `AArch64TMAbort (retry,reason) -> failwith "TABORT is not implemented"
diff --git a/aarch64_small/gen/sail_trans_out.hgen b/aarch64_small/gen/sail_trans_out.hgen
index 84826c18..0399fa8b 100644
--- a/aarch64_small/gen/sail_trans_out.hgen
+++ b/aarch64_small/gen/sail_trans_out.hgen
@@ -1,3 +1,5 @@
+| ("Unallocated", []) -> `AArch64Unallocated
+
 | ("TMStart", [t]) ->
   `AArch64TMStart (translate_out_regzr Set64 t)
 
diff --git a/aarch64_small/gen/shallow_ast_to_herdtools_ast.hgen b/aarch64_small/gen/shallow_ast_to_herdtools_ast.hgen
index 7362304c..55179a97 100644
--- a/aarch64_small/gen/shallow_ast_to_herdtools_ast.hgen
+++ b/aarch64_small/gen/shallow_ast_to_herdtools_ast.hgen
@@ -1,3 +1,5 @@
+| Unallocated -> `AArch64Unallocated
+
 | TMStart t ->
   `AArch64TMStart (translate_out_regzr Set64 t)
 
diff --git a/aarch64_small/gen/trans_sail.hgen b/aarch64_small/gen/trans_sail.hgen
index 2b176308..df2ed81c 100644
--- a/aarch64_small/gen/trans_sail.hgen
+++ b/aarch64_small/gen/trans_sail.hgen
@@ -1,3 +1,5 @@
+| `AArch64Unallocated -> ("Unallocated", [], [])
+
 | `AArch64TMStart t ->
     ("TMStart", [translate_reg "t" t], [])
 
diff --git a/etc/regfp.sail b/etc/regfp.sail
deleted file mode 100644
index de842c5c..00000000
--- a/etc/regfp.sail
+++ /dev/null
@@ -1,95 +0,0 @@
-(* iR : input registers,
- * oR : output registers,
- * aR : registers feeding into the memory address *)
-
-(* branch instructions currently are not writing to NIA *)
-
-typedef regfp = const union {
-   (string) RFull;
-   (string,nat,nat) RSlice;
-   (string,nat) RSliceBit;
-   (string,string) RField;
-}
-
-typedef regfps = list <regfp>
-
-typedef niafp = const union {
-  NIAFP_successor;
-  (bit[64]) NIAFP_concrete_address;
-  NIAFP_indirect_address;
-}
-
-typedef niafps = list <niafp>
-
-(* only for MIPS *)
-typedef diafp = const union {
-  DIAFP_none;
-  (bit[64]) DIAFP_concrete;
-  (regfp) DIAFP_reg;
-}
-
-typedef read_kind = enumerate {
-  Read_plain;
-  Read_reserve;
-  Read_acquire;
-  Read_exclusive;
-  Read_exclusive_acquire;
-  Read_stream;
-  Read_RISCV_acquire;
-  Read_RISCV_strong_acquire;
-  Read_RISCV_reserved;
-  Read_RISCV_reserved_acquire;
-  Read_RISCV_reserved_strong_acquire;
-  Read_X86_locked;
-}
-
-typedef write_kind = enumerate {
-  Write_plain;
-  Write_conditional;
-  Write_release;
-  Write_exclusive;
-  Write_exclusive_release;
-  Write_RISCV_release;
-  Write_RISCV_strong_release;
-  Write_RISCV_conditional;
-  Write_RISCV_conditional_release;
-  Write_RISCV_conditional_strong_release;
-  Write_X86_locked;
-}
-
-typedef barrier_kind = enumerate {
-  Barrier_Sync;
-  Barrier_LwSync;
-  Barrier_Eieio;
-  Barrier_Isync;
-  Barrier_DMB;
-  Barrier_DMB_ST;
-  Barrier_DMB_LD;
-  Barrier_DSB;
-  Barrier_DSB_ST;
-  Barrier_DSB_LD;
-  Barrier_ISB;
-  Barrier_MIPS_SYNC;
-  Barrier_RISCV_rw_rw;
-  Barrier_RISCV_r_rw;
-  Barrier_RISCV_r_r;
-  Barrier_RISCV_rw_w;
-  Barrier_RISCV_w_w;
-  Barrier_RISCV_tso;
-  Barrier_RISCV_i;
-  Barrier_x86_MFENCE;
-}
-
-typedef trans_kind = enumerate {
-  Transaction_start; Transaction_commit; Transaction_abort;
-}
-
-typedef instruction_kind = const union {
-  (barrier_kind) IK_barrier;
-  (read_kind) IK_mem_read;
-  (write_kind) IK_mem_write;
-  (read_kind, write_kind) IK_mem_rmw;
-  IK_branch;
-  (trans_kind) IK_trans;
-  IK_simple
-}
diff --git a/etc/regfp2.sail b/etc/regfp2.sail
deleted file mode 100644
index 85141853..00000000
--- a/etc/regfp2.sail
+++ /dev/null
@@ -1,97 +0,0 @@
-/* iR : input registers,
- * oR : output registers,
- * aR : registers feeding into the memory address */
-
-/* branch instructions currently are not writing to NIA */
-
-union regfp = {
-   RFull : string,
-   RSlice : (string,nat,nat),
-   RSliceBit : (string,nat),
-   RField : (string,string),
-}
-
-type regfps = list(regfp)
-
-union niafp = {
-  NIAFP_successor : unit,
-  NIAFP_concrete_address : bits(64),
-  NIAFP_indirect_address : unit,
-}
-
-type niafps = list(niafp)
-
-/* only for MIPS */
-union diafp = {
-  DIAFP_none : unit,
-  DIAFP_concrete : bits(64),
-  DIAFP_reg : regfp,
-}
-
-enum read_kind = {
-  Read_plain,
-  Read_reserve,
-  Read_acquire,
-  Read_exclusive,
-  Read_exclusive_acquire,
-  Read_stream,
-  Read_RISCV_acquire,
-  Read_RISCV_strong_acquire,
-  Read_RISCV_reserved,
-  Read_RISCV_reserved_acquire,
-  Read_RISCV_reserved_strong_acquire,
-  Read_X86_locked
-}
-
-enum write_kind = {
-  Write_plain,
-  Write_conditional,
-  Write_release,
-  Write_exclusive,
-  Write_exclusive_release,
-  Write_RISCV_release,
-  Write_RISCV_strong_release,
-  Write_RISCV_conditional,
-  Write_RISCV_conditional_release,
-  Write_RISCV_conditional_strong_release,
-  Write_X86_locked
-}
-
-enum barrier_kind = {
-  Barrier_Sync,
-  Barrier_LwSync,
-  Barrier_Eieio,
-  Barrier_Isync,
-  Barrier_DMB,
-  Barrier_DMB_ST,
-  Barrier_DMB_LD,
-  Barrier_DSB,
-  Barrier_DSB_ST,
-  Barrier_DSB_LD,
-  Barrier_ISB,
-  Barrier_MIPS_SYNC,
-  Barrier_RISCV_rw_rw,
-  Barrier_RISCV_r_rw,
-  Barrier_RISCV_r_r,
-  Barrier_RISCV_rw_w,
-  Barrier_RISCV_w_w,
-  Barrier_RISCV_tso,
-  Barrier_RISCV_i,
-  Barrier_x86_MFENCE
-}
-
-enum trans_kind = {
-  Transaction_start, 
-  Transaction_commit, 
-  Transaction_abort
-}
-
-union instruction_kind = {
-  IK_barrier : barrier_kind,
-  IK_mem_read : read_kind,
-  IK_mem_write : write_kind,
-  IK_mem_rmw : (read_kind, write_kind),
-  IK_branch : unit,
-  IK_trans : trans_kind,
-  IK_simple : unit,
-}
diff --git a/etc/style.css b/etc/style.css
new file mode 100644
index 00000000..845a9998
--- /dev/null
+++ b/etc/style.css
@@ -0,0 +1,43 @@
+.keyword { font-weight : bold ; color : Red }
+.keywordsign { color : #C04600 }
+.comment { color : Green }
+.constructor { color : Blue }
+.type { color : #5C6585 }
+.string { color : Maroon }
+.warning { color : Red ; font-weight : bold }
+.info { margin-left : 3em; margin-right: 3em }
+.param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }
+.code { color : #465F91 ; }
+.typetable { border-style : hidden }
+.paramstable { border-style : hidden ; padding: 5pt 5pt}
+tr { background-color : White }
+td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}
+div.sig_block {margin-left: 2em}
+*:target { background: yellow; }
+body {font: 13px sans-serif; color: black; text-align: left; padding: 5px; margin: 0; width: 70pc; margin-left: 5pc; font-size: large}
+h1 { font-size : 20pt ; text-align: center; }
+h2 { font-size : 20pt ; text-align: center; }
+h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; border-radius: 20px }
+h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; border-radius: 20px }
+h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; border-radius: 20px }
+h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; border-radius: 20px }
+div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ; padding: 2px; border-radius: 20px }
+div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; border-radius: 20px }
+div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; border-radius: 20px }
+div.h10 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; border-radius: 20px }
+a {color: #416DFF; text-decoration: none}
+a:hover {background-color: #ddd; text-decoration: underline}
+pre { margin-bottom: 4px; font-family: monospace; }
+pre.verbatim, pre.codepre { }
+.indextable {border: 1px #ddd solid; border-collapse: collapse}
+.indextable td, .indextable th {border: 1px #ddd solid; min-width: 80px}
+.indextable td.module {background-color: #eee ;  padding-left: 2px; padding-right: 2px}
+.indextable td.module a {color: #4E6272; text-decoration: none; display: block; width: 100%}
+.indextable td.module a:hover {text-decoration: underline; background-color: transparent}
+.deprecated {color: #888; font-style: italic}
+.indextable tr td div.info { margin-left: 2px; margin-right: 2px }
+ul.indexlist { margin-left: 0; padding-left: 0;}
+ul.indexlist li { list-style-type: none ; margin-left: 0; padding-left: 0; }
+ul.info-attributes {list-style: none; margin: 0; padding: 0; }
+div.info > p:first-child { margin-top:0; }
+div.info-desc > p:first-child { margin-top:0; margin-bottom:0; }
\ No newline at end of file
diff --git a/language/bytecode.ott b/language/jib.ott
index cc329e02..e54e2ea5 100644
--- a/language/bytecode.ott
+++ b/language/jib.ott
@@ -49,6 +49,7 @@ grammar
 
 % Fragments are small pure snippets of (abstract) C code, mostly
 % expressions, used by the aval and cval types.
+
 fragment :: 'F_' ::=
   | id                                     :: :: id
   | '&' id                                 :: :: ref
@@ -62,45 +63,67 @@ fragment :: 'F_' ::=
   | string                                 :: :: raw
   | poly fragment                          :: :: poly
 
-% init / clear -> create / kill
+% Note that init / clear are sometimes refered to as create / kill
+
+%%% IR types
 
 ctyp :: 'CT_' ::=
   {{ com C type }}
-  | mpz_t                     :: :: lint
-% Arbitrary precision GMP integer, mpz_t in C.
-  | bv_t ( bool )             :: :: lbits
-% Variable length bitvector - flag represents direction, true - dec or false - inc
-  | sbv_t ( bool )            :: :: sbits
-% Small variable length bitvector - less than 64 bits
-  | 'uint64_t' ( nat , bool ) :: :: fbits
-% Fixed length bitvector that fits within a 64-bit word. - int
-% represents length, and flag is the same as CT_bv.
-  | 'int64_t' nat             :: :: fint
-% Used for (signed) integers that fit within 64-bits.
-  | unit_t                    :: :: unit
-% unit is a value in sail, so we represent it as a one element type
-% here too for clarity but we actually compile it to an int which is
-% always 0.
+% Integer types
+%
+% lint is a large (l) arbitrary precision integer, mpz_t in C.
+% fint(n) is a fixed precision signed integer that is representable in exactly n bits
+  | lint                      :: :: lint
+  | fint nat                  :: :: fint
+
+% Bitvector types - flag represents bit indexing direction, true - dec or false - inc
+%
+% lbits is a large (l) arbitrary precision bitvector
+% sbits is a small (s) bitvector, such that sbits(n, _) is guaranteed to have a length of at most n.
+% fbits is a fixed (f) bitvector, such that fbits(n, _) has a length of exactly n bits
+  | lbits ( bool )            :: :: lbits
+  | sbits ( nat , bool )      :: :: sbits
+  | fbits ( nat , bool )      :: :: fbits
+
+% Other Sail types
+  | unit                      :: :: unit
   | bool_t                    :: :: bool
-  | real_t                    :: :: real
-  | bit_t                     :: :: bit
-% The real type in sail. Abstract here, but implemented using either
-% GMP rationals or high-precision floating point.
-  | ( ctyp0 , ... , ctypn )   :: :: tup
+  | bit                       :: :: bit
   | string_t                  :: :: string
-  | enum id ( id0 , ... , idn )                    :: :: enum
-  | struct id ( id0 * ctyp0 , ... , idn * ctypn )  :: :: struct
-  | variant id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: variant
+
+% The real type in sail. Abstract here, so the code generator can
+% choose to implement it using either GMP rationals or high-precision
+% floating point.
+  | real                      :: :: real
+
+  | ( ctyp0 , ... , ctypn )   :: :: tup
+
 % Abstractly represent how all the Sail user defined types get mapped
 % into C. We don't fully worry about precise implementation details at
 % this point, as C doesn't have variants or tuples natively, but these
 % need to be encoded.
+  | enum id ( id0 , ... , idn )                    :: :: enum
+  | struct id ( id0 * ctyp0 , ... , idn * ctypn )  :: :: struct
+  | variant id ( id0 * ctyp0 , ... , idn * ctypn ) :: :: variant
+
+% A vector type for non-bit vectors, and a (linked) list type.
   | vector ( bool , ctyp )         :: :: vector
   | list ( ctyp )                  :: :: list
-% A vector type for non-bit vectors, and a list type.
+
   | ref ( ctyp )                   :: :: ref
+
+% We can still have a very limited amount of polymorphism in this IR
+% representation, as variants can have polymorphic constructors. The
+% reason is we can put more precise types into constructors and then
+% consume them as more general types meaning the underlying
+% representation (rather than the high-level sail types) are what we
+% need to specialise constructors, e.g. Some(0xFF) would be a Some
+% constructor containing a fbits(8, true), but this could be pattern
+% matched as Some(x) where the matching context expects x to have type
+% lbits, and this must work without compiling to type incorrect C.
   | poly                           :: :: poly
 
+
 cval :: 'CV_' ::=
   {{ ocaml fragment * ctyp }}
   {{ lem fragment * ctyp }}
@@ -112,6 +135,8 @@ clexp :: 'CL_' ::=
   | clexp . nat              :: :: tuple
   | current_exception : ctyp :: :: current_exception
   | have_exception           :: :: have_exception
+  | return : ctyp            :: :: return
+  | void                     :: :: void
 
 ctype_def :: 'CTD_' ::=
   {{ com C type definition }}
@@ -125,45 +150,72 @@ iannot :: 'IA_' ::=
 
 instr :: 'I_' ::=
   {{ aux _ iannot }}
+% The following are the minimal set of instructions output by
+% Jib_compile.ml.
   | ctyp id                                        :: :: decl
   | ctyp id = cval                                 :: :: init
-  | if ( cval ) { instr0 ; ... ; instrn }
-    else { instr0 ; ... ; instrm } : ctyp          :: :: if
   | jump ( cval ) string                           :: :: jump
+  | goto string                                    :: :: goto
+  | string :                                       :: :: label
   | clexp = bool id ( cval0 , ... , cvaln )        :: :: funcall
   | clexp = cval                                   :: :: copy
-  | alias clexp = cval                             :: :: alias
   | clear ctyp id                                  :: :: clear
-  | return cval                                    :: :: return
+  | undefined ctyp                                 :: :: undefined
+  | match_failure                                  :: :: match_failure
+  | end                                            :: :: end
+
+% All instructions containing nested instructions can be flattened
+% away. try and throw only exist for internal use within
+% Jib_compile.ml, as exceptional control flow is handled by a separate
+% Jib->Jib pass.
+  | if ( cval ) { instr0 ; ... ; instrn }
+    else { instr0 ; ... ; instrm } : ctyp          :: :: if
   | { instr0 ; ... ; instrn }                      :: :: block
   | try { instr0 ; ... ; instrn }                  :: :: try_block
   | throw cval                                     :: :: throw
+
+% We can embed either comments or pass raw-strings through to the
+% code-generator. The first is useful for annotating generated source,
+% the second for inserting instrumention. I_raw should be side-effect
+% free.
   | '//' string                                    :: :: comment
-  | C string                                       :: :: raw % only used for GCC attributes
-  | string :                                       :: :: label
-  | goto string                                    :: :: goto
-  | undefined ctyp                                 :: :: undefined
-  | match_failure                                  :: :: match_failure
+  | C string                                       :: :: raw
+
+% Jib_compile.ml will represent all returns as assigments to the clexp
+% CL_return, followed by end to signify the end of the
+% function.
+  | return cval                                    :: :: return
 
-% For optimising away allocations.
-  | reset ctyp id                             :: :: reset
-  | ctyp id = cval                            :: :: reinit
+% For optimising away allocations and copying.
+  | reset ctyp id                                  :: :: reset
+  | ctyp id = cval                                 :: :: reinit
+  | alias clexp = cval                             :: :: alias
 
 cdef :: 'CDEF_' ::=
   | register id : ctyp = {
       instr0 ; ... ; instrn
     } :: :: reg_dec
-  | ctype_def          :: :: type
+  | ctype_def :: :: type
+
+% The first list of instructions sets up the global letbinding, while
+% the second clears it.
   | let nat ( id0 : ctyp0 , ... , idn : ctypn ) = {
       instr0 ; ... ; instrm
     } :: :: let
-% The first list of instructions creates up the global letbinding, the
-% second kills it.
-  | val id ( ctyp0 , ... , ctypn ) -> ctyp
-      :: :: spec
+
+  | val id ( ctyp0 , ... , ctypn ) -> ctyp :: :: spec
+
+% If mid = Some id this indicates that the caller should allocate the
+% return type and passes a pointer to it as an extra argument id for
+% the function to fill in. This is only done via Jib->Jib rewrites
+% used when compiling to C.
   | function id mid ( id0 , ... , idn ) {
       instr0 ; ... ; instrm
     } :: :: fundef
+
+% Each function can have custom global state. In CDEF_startup and
+% CDEF_finish all I_decl and I_init nodes are treated as global and no
+% nested-instructions (if/block) are allowed.
   | startup id {
       instr0 ; ... ; instrn
     } :: :: startup
diff --git a/lib/coq/Sail2_string.v b/lib/coq/Sail2_string.v
index 543b0fad..a0a23933 100644
--- a/lib/coq/Sail2_string.v
+++ b/lib/coq/Sail2_string.v
@@ -1,4 +1,5 @@
 Require Import Sail2_values.
+Require Import Coq.Strings.Ascii.
 
 Definition string_sub (s : string) (start : Z) (len : Z) : string :=
   String.substring (Z.to_nat start) (Z.to_nat len) s.
diff --git a/lib/coq/Sail2_values.v b/lib/coq/Sail2_values.v
index e6c5e786..f11e057a 100644
--- a/lib/coq/Sail2_values.v
+++ b/lib/coq/Sail2_values.v
@@ -10,6 +10,7 @@ Require Export Sumbool.
 Require Export DecidableClass.
 Require Import Eqdep_dec.
 Require Export Zeuclid.
+Require Import Psatz.
 Import ListNotations.
 
 Open Scope Z.
@@ -1037,27 +1038,31 @@ Ltac unbool_comparisons :=
   | H:context [generic_eq _ _ = false] |- _ => apply generic_eq_false in H
   | H:context [generic_neq _ _ = true] |- _ => apply generic_neq_true in H
   | H:context [generic_neq _ _ = false] |- _ => apply generic_neq_false in H
+  | H:context [_ <> true] |- _ => rewrite Bool.not_true_iff_false in H
+  | H:context [_ <> false] |- _ => rewrite Bool.not_false_iff_true in H
   end.
 Ltac unbool_comparisons_goal :=
   repeat match goal with
-  | |- context [Z.geb _ _] => rewrite Z.geb_leb
-  | |- context [Z.gtb _ _] => rewrite Z.gtb_ltb
-  | |- context [Z.leb _ _ = true] => rewrite Z.leb_le
-  | |- context [Z.ltb _ _ = true] => rewrite Z.ltb_lt
-  | |- context [Z.eqb _ _ = true] => rewrite Z.eqb_eq
-  | |- context [Z.leb _ _ = false] => rewrite Z.leb_gt
-  | |- context [Z.ltb _ _ = false] => rewrite Z.ltb_ge
-  | |- context [Z.eqb _ _ = false] => rewrite Z.eqb_neq
-  | |- context [orb _ _ = true] => rewrite Bool.orb_true_iff
-  | |- context [orb _ _ = false] => rewrite Bool.orb_false_iff
-  | |- context [andb _ _ = true] => rewrite Bool.andb_true_iff
-  | |- context [andb _ _ = false] => rewrite Bool.andb_false_iff
-  | |- context [negb _ = true] => rewrite Bool.negb_true_iff
-  | |- context [negb _ = false] => rewrite Bool.negb_false_iff
+  | |- context [Z.geb _ _] => setoid_rewrite Z.geb_leb
+  | |- context [Z.gtb _ _] => setoid_rewrite Z.gtb_ltb
+  | |- context [Z.leb _ _ = true] => setoid_rewrite Z.leb_le
+  | |- context [Z.ltb _ _ = true] => setoid_rewrite Z.ltb_lt
+  | |- context [Z.eqb _ _ = true] => setoid_rewrite Z.eqb_eq
+  | |- context [Z.leb _ _ = false] => setoid_rewrite Z.leb_gt
+  | |- context [Z.ltb _ _ = false] => setoid_rewrite Z.ltb_ge
+  | |- context [Z.eqb _ _ = false] => setoid_rewrite Z.eqb_neq
+  | |- context [orb _ _ = true] => setoid_rewrite Bool.orb_true_iff
+  | |- context [orb _ _ = false] => setoid_rewrite Bool.orb_false_iff
+  | |- context [andb _ _ = true] => setoid_rewrite Bool.andb_true_iff
+  | |- context [andb _ _ = false] => setoid_rewrite Bool.andb_false_iff
+  | |- context [negb _ = true] => setoid_rewrite Bool.negb_true_iff
+  | |- context [negb _ = false] => setoid_rewrite Bool.negb_false_iff
   | |- context [generic_eq _ _ = true] => apply generic_eq_true
   | |- context [generic_eq _ _ = false] => apply generic_eq_false
   | |- context [generic_neq _ _ = true] => apply generic_neq_true
   | |- context [generic_neq _ _ = false] => apply generic_neq_false
+  | |- context [_ <> true] => rewrite Bool.not_true_iff_false
+  | |- context [_ <> false] => rewrite Bool.not_false_iff_true
   end.
 
 (* Split up dependent pairs to get at proofs of properties *)
@@ -1190,6 +1195,13 @@ Ltac fill_in_evar_eq :=
    let y := eval cbn in y in*)
    idtac "Warning: unknown equality constraint"; constructor; exact (eq_refl _ : x = y) end.
 
+Ltac bruteforce_bool_exists :=
+match goal with
+| |- exists _ : bool,_ => solve [ exists true; bruteforce_bool_exists
+                                | exists false; bruteforce_bool_exists ]
+| _ => tauto
+end.
+
 Ltac solve_arithfact :=
 (* Attempt a simple proof first to avoid lengthy preparation steps (especially
    as the large proof terms can upset subsequent proofs). *)
@@ -1208,13 +1220,17 @@ prepare_for_solver;
  | constructor; eauto 3 with zarith sail
    (* The datatypes hints give us some list handling, esp In *)
  | constructor; drop_exists; eauto 3 with datatypes zarith sail
+ | match goal with |- context [Z.mul] => constructor; nia end
    (* Booleans - and_boolMP *)
- | match goal with |- ArithFact (forall l r:bool, _ -> _ -> exists _, _) => 
-     constructor; intros l r H1 H2;
-     solve [exists l; destruct l; intuition | exists r; destruct l; intuition]
+ | match goal with |- ArithFact (forall l r:bool, _ -> _ -> exists _ : bool, _) => 
+     constructor; intros [|] [|] H1 H2;
+     repeat match goal with H:?X = ?X -> _ |- _ => specialize (H eq_refl) end;
+     repeat match goal with H:@ex _ _ |- _ => destruct H end;
+     bruteforce_bool_exists
    end
- | match goal with |- context [@eq _ _ _] =>
-     constructor; intuition
+ | match goal with |- context [@eq bool _ _] =>
+     (* Don't use auto for the fallback to keep runtime down *)
+     firstorder fail
    end
  | constructor; idtac "Unable to solve constraint"; dump_context; fail
  ].
diff --git a/lib/mono_rewrites.sail b/lib/mono_rewrites.sail
index 90d74149..9e4010a0 100644
--- a/lib/mono_rewrites.sail
+++ b/lib/mono_rewrites.sail
@@ -119,9 +119,9 @@ function place_slice(m,xs,i,l,shift) = {
 }
 
 val set_slice_zeros : forall 'n, 'n >= 0.
-  (atom('n), int, bits('n), int) -> bits('n) effect pure
+  (atom('n), bits('n), int, int) -> bits('n) effect pure
 
-function set_slice_zeros(n, i, xs, l) = {
+function set_slice_zeros(n, xs, i, l) = {
   let ys : bits('n) = slice_mask(n, i, l) in
   xs & ~(ys)
 }
diff --git a/lib/regfp.sail b/lib/regfp.sail
index b2ecaa10..c191d654 100644
--- a/lib/regfp.sail
+++ b/lib/regfp.sail
@@ -93,6 +93,16 @@ enum trans_kind = {
   Transaction_abort
 }
 
+/* cache maintenance instructions */
+enum cache_op_kind = {
+  /* AArch64 DC */
+  Cache_op_D_IVAC, Cache_op_D_ISW,  Cache_op_D_CSW,  Cache_op_D_CISW,
+  Cache_op_D_ZVA,  Cache_op_D_CVAC, Cache_op_D_CVAU, Cache_op_D_CIVAC,
+  /* AArch64 IC */
+  Cache_op_I_IALLUIS, Cache_op_I_IALLU, Cache_op_I_IVAU
+}
+
+
 union instruction_kind = {
   IK_barrier : barrier_kind,
   IK_mem_read : read_kind,
@@ -100,7 +110,8 @@ union instruction_kind = {
   IK_mem_rmw : (read_kind, write_kind),
   IK_branch : unit,
   IK_trans : trans_kind,
-  IK_simple : unit
+  IK_simple : unit,
+  IK_cache_op : cache_op_kind
 }
 
 val __read_mem
diff --git a/lib/sail.c b/lib/sail.c
index 5c83690d..6c71d7ae 100644
--- a/lib/sail.c
+++ b/lib/sail.c
@@ -680,6 +680,11 @@ void zero_extend(lbits *rop, const lbits op, const sail_int len)
   mpz_set(*rop->bits, *op.bits);
 }
 
+fbits fast_zero_extend(const sbits op, const uint64_t n)
+{
+  return op.bits;
+}
+
 void sign_extend(lbits *rop, const lbits op, const sail_int len)
 {
   assert(op.len <= mpz_get_ui(len));
@@ -694,6 +699,32 @@ void sign_extend(lbits *rop, const lbits op, const sail_int len)
   }
 }
 
+fbits fast_sign_extend(const fbits op, const uint64_t n, const uint64_t m)
+{
+  uint64_t rop = op;
+  if (op & (UINT64_C(1) << (n - 1))) {
+    for (uint64_t i = m - 1; i >= n; i--) {
+      rop = rop | (UINT64_C(1) << i);
+    }
+    return rop;
+  } else {
+    return rop;
+  }
+}
+
+fbits fast_sign_extend2(const sbits op, const uint64_t m)
+{
+  uint64_t rop = op.bits;
+  if (op.bits & (UINT64_C(1) << (op.len - 1))) {
+    for (uint64_t i = m - 1; i >= op.len; i--) {
+      rop = rop | (UINT64_C(1) << i);
+    }
+    return rop;
+  } else {
+    return rop;
+  }
+}
+
 void length_lbits(sail_int *rop, const lbits op)
 {
   mpz_set_ui(*rop, op.len);
@@ -783,12 +814,21 @@ void sail_signed(sail_int *rop, const lbits op)
   }
 }
 
-inline
 mach_int fast_unsigned(const fbits op)
 {
   return (mach_int) op;
 }
 
+mach_int fast_signed(const fbits op, const uint64_t n)
+{
+  if (op & (UINT64_C(1) << (n - 1))) {
+    uint64_t rop = op & ~(UINT64_C(1) << (n - 1));
+    return (mach_int) (rop - (UINT64_C(1) << (n - 1)));
+  } else {
+    return (mach_int) op;
+  }
+}
+
 void append(lbits *rop, const lbits op1, const lbits op2)
 {
   rop->len = op1.len + op2.len;
@@ -890,6 +930,20 @@ void set_slice_int(sail_int *rop,
   }
 }
 
+void update_lbits(lbits *rop, const lbits op, const sail_int n_mpz, const uint64_t bit)
+{
+  uint64_t n = mpz_get_ui(n_mpz);
+
+  mpz_set(*rop->bits, *op.bits);
+  rop->len = op.len;
+
+  if (bit == UINT64_C(0)) {
+    mpz_clrbit(*rop->bits, n);
+  } else {
+    mpz_setbit(*rop->bits, n);
+  }
+}
+
 void vector_update_subrange_lbits(lbits *rop,
 				 const lbits op,
 				 const sail_int n_mpz,
@@ -911,6 +965,23 @@ void vector_update_subrange_lbits(lbits *rop,
   }
 }
 
+fbits fast_update_subrange(const fbits op,
+			   const mach_int n,
+			   const mach_int m,
+			   const fbits slice)
+{
+  fbits rop = op;
+  for (mach_int i = 0; i < n - (m - UINT64_C(1)); i++) {
+    uint64_t bit = UINT64_C(1) << ((uint64_t) i);
+    if (slice & bit) {
+      rop |= (bit << m);
+    } else {
+      rop &= ~(bit << m);
+    }
+  }
+  return rop;
+}
+
 void slice(lbits *rop, const lbits op, const sail_int start_mpz, const sail_int len_mpz)
 {
   assert(mpz_get_ui(start_mpz) + mpz_get_ui(len_mpz) <= op.len);
diff --git a/lib/sail.h b/lib/sail.h
index 42f87294..e06629f0 100644
--- a/lib/sail.h
+++ b/lib/sail.h
@@ -246,7 +246,10 @@ void mult_vec(lbits *rop, const lbits op1, const lbits op2);
 void zeros(lbits *rop, const sail_int op);
 
 void zero_extend(lbits *rop, const lbits op, const sail_int len);
+fbits fast_zero_extend(const sbits op, const uint64_t n);
 void sign_extend(lbits *rop, const lbits op, const sail_int len);
+fbits fast_sign_extend(const fbits op, const uint64_t n, const uint64_t m);
+fbits fast_sign_extend2(const sbits op, const uint64_t m);
 
 void length_lbits(sail_int *rop, const lbits op);
 
@@ -267,6 +270,7 @@ fbits bitvector_access(const lbits op, const sail_int n_mpz);
 void sail_unsigned(sail_int *rop, const lbits op);
 void sail_signed(sail_int *rop, const lbits op);
 
+mach_int fast_signed(const fbits, const uint64_t);
 mach_int fast_unsigned(const fbits);
 
 void append(lbits *rop, const lbits op1, const lbits op2);
@@ -286,12 +290,19 @@ void set_slice_int(sail_int *rop,
 		   const sail_int start_mpz,
 		   const lbits slice);
 
+void update_lbits(lbits *rop, const lbits op, const sail_int n_mpz, const uint64_t bit);
+
 void vector_update_subrange_lbits(lbits *rop,
 				      const lbits op,
 				      const sail_int n_mpz,
 				      const sail_int m_mpz,
 				      const lbits slice);
 
+fbits fast_update_subrange(const fbits op,
+			   const mach_int n,
+			   const mach_int m,
+			   const fbits slice);
+
 void slice(lbits *rop, const lbits op, const sail_int start_mpz, const sail_int len_mpz);
 
 sbits sslice(const fbits op, const mach_int start, const mach_int len);
diff --git a/lib/string.sail b/lib/string.sail
index 9c4ad2f6..3fe74eb5 100644
--- a/lib/string.sail
+++ b/lib/string.sail
@@ -3,7 +3,7 @@ $define _STRING
 
 $include <arith.sail>
 
-val eq_string = {lem: "eq", _: "eq_string"} : (string, string) -> bool
+val eq_string = {lem: "eq", coq: "generic_eq", _: "eq_string"} : (string, string) -> bool
 
 infixl 9 ^-^
 
diff --git a/power/Makefile b/power/Makefile
index f7c49e00..be97aa0b 100644
--- a/power/Makefile
+++ b/power/Makefile
@@ -1,7 +1,7 @@
 SAIL:=../src/sail.native
 LEM:=../../lem/lem
 
-SOURCES:=power.sail ../etc/regfp.sail power_regfp.sail
+SOURCES:=power.sail ../lib/regfp.sail power_regfp.sail
 
 
 all: power.lem power.ml power_embed.lem
diff --git a/src/Makefile b/src/Makefile
index 146addbe..a002d4f3 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -74,16 +74,16 @@ full: sail lib doc
 ast.lem: ../language/sail.ott
 	ott -sort false -generate_aux_rules true -o ast.lem -picky_multiple_parses true ../language/sail.ott
 
-bytecode.lem: ../language/bytecode.ott ast.lem
-	ott -sort false -generate_aux_rules true -o bytecode.lem -picky_multiple_parses true ../language/bytecode.ott
+jib.lem: ../language/jib.ott ast.lem
+	ott -sort false -generate_aux_rules true -o jib.lem -picky_multiple_parses true ../language/jib.ott
 
 ast.ml: ast.lem
 	lem -ocaml ast.lem
 	sed -i.bak -f ast.sed ast.ml
 
-bytecode.ml: bytecode.lem
-	lem -ocaml bytecode.lem -lib . -lib gen_lib/
-	sed -i.bak -f ast.sed bytecode.ml
+jib.ml: jib.lem
+	lem -ocaml jib.lem -lib . -lib gen_lib/
+	sed -i.bak -f ast.sed jib.ml
 
 manifest.ml:
 	echo "(* Generated file -- do not edit. *)" > manifest.ml
@@ -99,19 +99,19 @@ else
 	echo let version=\"$(shell grep '^version:' ../opam | grep -o -E '"[^"]+"')\" >> manifest.ml
 endif
 
-sail: ast.ml bytecode.ml manifest.ml
+sail: ast.ml jib.ml manifest.ml
 	ocamlbuild -use-ocamlfind sail.native sail_lib.cma sail_lib.cmxa
 
-isail: ast.ml bytecode.ml manifest.ml
+isail: ast.ml jib.ml manifest.ml
 	ocamlbuild -use-ocamlfind isail.native sail_lib.cma sail_lib.cmxa libsail.cma libsail.cmxa
 
 
-coverage: ast.ml bytecode.ml manifest.ml
+coverage: ast.ml jib.ml manifest.ml
 	BISECT_COVERAGE=YES ocamlbuild -use-ocamlfind -plugin-tag 'package(bisect_ppx-ocamlbuild)' isail.native
 
 sail.native: sail
 
-sail.byte: ast.ml bytecode.ml manifest.ml
+sail.byte: ast.ml jib.ml manifest.ml
 	ocamlbuild -use-ocamlfind -cflag -g sail.byte
 
 isail.byte: ast.ml bytecode.ml share_directory.ml
@@ -136,9 +136,9 @@ clean:
 	-rm -f ast.ml
 	-rm -f ast.lem
 	-rm -f ast.ml.bak
-	-rm -f bytecode.ml
-	-rm -f bytecode.lem
-	-rm -f bytecode.ml.bak
+	-rm -f jib.ml
+	-rm -f jib.lem
+	-rm -f jib.ml.bak
 	-rm -f manifest.ml
 
 doc:
diff --git a/src/_tags b/src/_tags
index fbea6a00..41b443de 100644
--- a/src/_tags
+++ b/src/_tags
@@ -11,6 +11,7 @@ true: -traverse, debug, use_menhir
 <**/*.m{l,li}>: package(lem), package(base64)
 
 <gen_lib>: include
+<jib>: include
 <pprint> or <pprint/src>: include
 
 # disable partial match and unused variable warnings
diff --git a/src/ast_util.ml b/src/ast_util.ml
index afd00d3d..34345210 100644
--- a/src/ast_util.ml
+++ b/src/ast_util.ml
@@ -1060,6 +1060,18 @@ let ids_of_def = function
 let ids_of_defs (Defs defs) =
   List.fold_left IdSet.union IdSet.empty (List.map ids_of_def defs)
 
+let val_spec_ids (Defs defs) =
+  let val_spec_id (VS_aux (vs_aux, _)) =
+    match vs_aux with
+    | VS_val_spec (_, id, _, _) -> id
+  in
+  let rec vs_ids = function
+    | DEF_spec vs :: defs -> val_spec_id vs :: vs_ids defs
+    | def :: defs -> vs_ids defs
+    | [] -> []
+  in
+  IdSet.of_list (vs_ids defs)
+
 module BE = struct
   type t = base_effect
   let compare be1 be2 = String.compare (string_of_base_effect be1) (string_of_base_effect be2)
@@ -1905,6 +1917,77 @@ let typquant_subst_kid_aux sv subst = function
 
 let typquant_subst_kid sv subst (TypQ_aux (typq, l)) = TypQ_aux (typquant_subst_kid_aux sv subst typq, l)
 
+
+let subst_kids_nexp substs nexp =
+  let rec s_snexp substs (Nexp_aux (ne,l) as nexp) =
+    let re ne = Nexp_aux (ne,l) in
+    let s_snexp = s_snexp substs in
+    match ne with
+    | Nexp_var (Kid_aux (_,l) as kid) ->
+       (try KBindings.find kid substs
+       with Not_found -> nexp)
+    | Nexp_id _
+    | Nexp_constant _ -> nexp
+    | Nexp_times (n1,n2) -> re (Nexp_times (s_snexp n1, s_snexp n2))
+    | Nexp_sum (n1,n2)   -> re (Nexp_sum   (s_snexp n1, s_snexp n2))
+    | Nexp_minus (n1,n2) -> re (Nexp_minus (s_snexp n1, s_snexp n2))
+    | Nexp_exp ne -> re (Nexp_exp (s_snexp ne))
+    | Nexp_neg ne -> re (Nexp_neg (s_snexp ne))
+    | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args))
+  in s_snexp substs nexp
+
+let subst_kids_nc, subst_kids_typ, subst_kids_typ_arg =
+  let rec subst_kids_nc substs (NC_aux (nc,l) as n_constraint) =
+    let snexp nexp = subst_kids_nexp substs nexp in
+    let snc nc = subst_kids_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
+    | 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 _
+    | Typ_var _
+      -> ty
+    | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e))
+    | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2))
+    | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts))
+    | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas))
+    | Typ_exist (kopts,nc,t) ->
+       let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in
+       re (Typ_exist (kopts,subst_kids_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
+    | A_nexp ne -> A_aux (A_nexp (subst_kids_nexp substs ne),l)
+    | A_typ t -> A_aux (A_typ (s_styp substs t),l)
+    | A_order _ -> targ
+    | A_bool nc -> A_aux (A_bool (subst_kids_nc substs nc), l)
+  in subst_kids_nc, s_styp, s_starg
+
+
 let rec simp_loc = function
   | Parse_ast.Unknown -> None
   | Parse_ast.Unique (_, l) -> simp_loc l
@@ -2036,3 +2119,4 @@ let rec find_annot_defs sl = function
   | [] -> 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 6cc4e8a5..64b39b51 100644
--- a/src/ast_util.mli
+++ b/src/ast_util.mli
@@ -48,7 +48,7 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
-(** Utilities for operating on Sail ASTs *)
+(** Utilities and helper functions for operating on Sail ASTs *)
 
 open Ast
 module Big_int = Nat_big_num
@@ -56,16 +56,26 @@ module Big_int = Nat_big_num
 type mut = Immutable | Mutable
 
 (** [lvar] is the type of variables - they can either be registers,
-   local mutable or immutable variables, nullary union constructors
-   (i.e. None in option), or unbound identifiers *)
+   local mutable or immutable variables constructors or unbound
+   identifiers. *)
 type 'a lvar = Register of effect * effect * 'a | Enum of 'a | Local of mut * 'a | Unbound
 
 (** Note: Partial function -- fails for Unknown lvars *)
 val lvar_typ : 'a lvar -> 'a
 
+(** The empty annotation. Should be used carefully because it can
+   result in unhelpful error messgaes. However a common pattern is
+   generating code with [no_annot], then adding location information
+   with the various [locate_] functions in this module. *)
 val no_annot : unit annot
+
+(** [gen_loc l] takes a location l and generates a location which
+   means 'generated from location l'. This is useful for debugging
+   errors that occur in generated code. *)
 val gen_loc : Parse_ast.l -> Parse_ast.l
 
+(** {2 Functions for building (untyped) AST elements} *)
+
 val mk_id : string -> id
 val mk_kid : string -> kid
 val mk_ord : order_aux -> order
@@ -92,6 +102,11 @@ val mk_fexp : id -> unit exp -> unit fexp
 val mk_letbind : unit pat -> unit exp -> unit letbind
 val mk_kopt : kind_aux -> kid -> kinded_id
 
+val inc_ord : order
+val dec_ord : order
+
+(** {2 Unwrap aux constructors} *)
+
 val unaux_exp : 'a exp -> 'a exp_aux
 val unaux_pat : 'a pat -> 'a pat_aux
 val unaux_nexp : nexp -> nexp_aux
@@ -100,26 +115,33 @@ val unaux_typ : typ -> typ_aux
 val unaux_kind : kind -> kind_aux
 val unaux_constraint : n_constraint -> n_constraint_aux
 
+(** {2 Destruct type annotated patterns and expressions} *)
+
+(** [untyp_pat (P_aux (P_typ (typ, pat)), _)] returns [Some (pat,
+   typ)] or [None] if the pattern does not match. *)
 val untyp_pat : 'a pat -> 'a pat * typ option
+
+(** Same as [untyp_pat], but for [E_cast] nodes *)
 val uncast_exp : 'a exp -> 'a exp * typ option
 
-val inc_ord : order
-val dec_ord : order
+(** {2 Utilites for working with kinded_ids} *)
 
-(* Utilites for working with kinded_ids *)
 val kopt_kid : kinded_id -> kid
 val kopt_kind : kinded_id -> kind
+
 val is_int_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. *)
+(** {2 Utility functions for constructing types} *)
+
 val mk_typ : typ_aux -> typ
 val mk_typ_arg : typ_arg_aux -> typ_arg
 val mk_id_typ : id -> typ
 
-(* Sail builtin types. *)
+(** {2 Sail builtin types} *)
+
 val unknown_typ : typ
 val int_typ : typ
 val nat_typ : typ
@@ -140,18 +162,128 @@ val exc_typ : typ
 val tuple_typ : typ list -> typ
 val function_typ : typ list -> typ -> effect -> typ
 
-val no_effect : effect
-val mk_effect : base_effect_aux list -> effect
+val is_unit_typ : typ -> bool
+val is_number : typ -> bool
+val is_ref_typ : typ -> bool
+val is_vector_typ : typ -> bool
+val is_bit_typ : typ -> bool
+val is_bitvector_typ : typ -> bool
+
+(** {2 Simplifcation of numeric expressions and constraints}
+
+   These functions simplify nexps and n_constraints using various
+   basic rules. In general they will guarantee to reduce constant
+   numeric expressions like 2 + 5 into 7, although they will not
+   simplify 2^constant, as that often leads to unreadable error
+   messages containing huge numbers. *)
 
 val nexp_simp : nexp -> nexp
 val constraint_simp : n_constraint -> n_constraint
 
-(* If a constraint is a conjunction, return a list of all the top-level conjuncts *)
+(** If a constraint is a conjunction, return a list of all the top-level conjuncts *)
 val constraint_conj : n_constraint -> n_constraint list
-(* Same as constraint_conj but for disjunctions *)
+
+(** Same as constraint_conj but for disjunctions *)
 val constraint_disj : n_constraint -> n_constraint list
 
-(* Utilities for building n-expressions *)
+(** {2 Set and Map modules for various AST elements} *)
+
+module Id : sig
+  type t = id
+  val compare : id -> id -> int
+end
+
+module Kid : sig
+  type t = kid
+  val compare : kid -> kid -> int
+end
+
+module Kind : sig
+  type t = kind
+  val compare : kind -> kind -> int
+end
+
+module KOpt : sig
+  type t = kinded_id
+  val compare : kinded_id -> kinded_id -> int
+end
+
+module Nexp : sig
+  type t = nexp
+  val compare : nexp -> nexp -> int
+end
+
+module BE : sig
+  type t = base_effect
+  val compare : base_effect -> base_effect -> int
+end
+
+module 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
+  val compare : typ -> typ -> int
+end
+
+module IdSet : sig
+  include Set.S with type elt = id
+end
+
+module NexpSet : sig
+  include Set.S with type elt = nexp
+end
+
+module NexpMap : sig
+  include Map.S with type key = nexp
+end
+
+module KOptSet : sig
+  include Set.S with type elt = kinded_id
+end
+
+module KOptMap : sig
+  include Map.S with type key = kinded_id
+end
+
+module BESet : sig
+  include Set.S with type elt = base_effect
+end
+
+module KidSet : sig
+  include Set.S with type elt = kid
+end
+
+module KBindings : sig
+  include Map.S with type key = kid
+end
+
+module Bindings : sig
+  include Map.S with type key = id
+end
+
+module TypMap : sig
+  include Map.S with type key = typ
+end
+
+
+(** {2 Functions for building and manipulating effects} *)
+
+val no_effect : effect
+val mk_effect : base_effect_aux list -> effect
+
+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
+
+(** {2 Functions for building numeric expressions} *)
+
 val nconstant : Big_int.num -> nexp
 val nint : int -> nexp
 val nminus : nexp -> nexp -> nexp
@@ -162,7 +294,8 @@ val nvar : kid -> nexp
 val napp : id -> nexp list -> nexp
 val nid : id -> nexp
 
-(* Numeric constraint builders *)
+(** {2 Functions for building numeric constraints} *)
+
 val nc_eq : nexp -> nexp -> n_constraint
 val nc_neq : nexp -> nexp -> n_constraint
 val nc_lteq : nexp -> nexp -> n_constraint
@@ -178,13 +311,16 @@ val nc_set : kid -> Big_int.num list -> n_constraint
 val nc_int_set : kid -> int list -> n_constraint
 val nc_var : kid -> n_constraint
 
+(** {2 Functions for building type arguments}*)
+
 val arg_nexp : ?loc:l -> nexp -> typ_arg
 val arg_order : ?loc:l -> order -> typ_arg
 val arg_typ : ?loc:l -> typ -> typ_arg
 val arg_bool : ?loc:l -> n_constraint -> typ_arg
 val arg_kopt : kinded_id -> typ_arg
 
-(* Functions for working with type quantifiers *)
+(** {2 Functions for working with type quantifiers} *)
+
 val quant_add : quant_item -> typquant -> typquant
 val quant_items : typquant -> quant_item list
 val quant_kopts : typquant -> kinded_id list
@@ -194,7 +330,8 @@ 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 *)
+(** {2 Functions to map over annotations in sub-expressions} *)
+
 val map_exp_annot : ('a annot -> 'b annot) -> 'a exp -> 'b exp
 val map_pat_annot : ('a annot -> 'b annot) -> 'a pat -> 'b pat
 val map_pexp_annot : ('a annot -> 'b annot) -> 'a pexp -> 'b pexp
@@ -215,7 +352,7 @@ val map_scattered_annot : ('a annot -> 'b annot) -> 'a scattered_def -> 'b scatt
 val map_def_annot : ('a annot -> 'b annot) -> 'a def -> 'b def
 val map_defs_annot : ('a annot -> 'b annot) -> 'a defs -> 'b defs
 
-(* Extract locations from identifiers *)
+(** {2 Extract locations from terms} *)
 val id_loc : id -> Parse_ast.l
 val kid_loc : kid -> Parse_ast.l
 val typ_loc : typ -> Parse_ast.l
@@ -223,8 +360,11 @@ val pat_loc : 'a pat -> Parse_ast.l
 val exp_loc : 'a exp -> Parse_ast.l
 val def_loc : 'a def -> Parse_ast.l
 
-(* For debugging and error messages only: Not guaranteed to produce
-   parseable SAIL, or even print all language constructs! *)
+(** {2 Printing utilities}
+
+   Note: For debugging and error messages only - not guaranteed to
+   produce parseable Sail, or even print all language constructs! *)
+
 val string_of_id : id -> string
 val string_of_kid : kid -> string
 val string_of_base_effect_aux : base_effect_aux -> string
@@ -251,11 +391,15 @@ val string_of_mpat : 'a mpat -> string
 val string_of_letbind : 'a letbind -> string
 val string_of_index_range : index_range -> string
 
+(** {2 Functions for getting identifiers from toplevel definitions} *)
+
 val id_of_fundef : 'a fundef -> id
 val id_of_type_def : 'a type_def -> id
 val id_of_val_spec : 'a val_spec -> id
 val id_of_dec_spec : 'a dec_spec -> id
 
+(** {2 Functions for manipulating identifiers} *)
+
 val id_of_kid : kid -> id
 val kid_of_id : id -> kid
 
@@ -263,86 +407,7 @@ val prepend_id : string -> id -> id
 val append_id : id -> string -> id
 val prepend_kid : string -> kid -> kid
 
-module Id : sig
-  type t = id
-  val compare : id -> id -> int
-end
-
-module Kid : sig
-  type t = kid
-  val compare : kid -> kid -> int
-end
-
-module Kind : sig
-  type t = kind
-  val compare : kind -> kind -> int
-end
-
-module KOpt : sig
-  type t = kinded_id
-  val compare : kinded_id -> kinded_id -> int
-end
-
-module Nexp : sig
-  type t = nexp
-  val compare : nexp -> nexp -> int
-end
-
-module BE : sig
-  type t = base_effect
-  val compare : base_effect -> base_effect -> int
-end
-
-module 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
-  val compare : typ -> typ -> int
-end
-
-module IdSet : sig
-  include Set.S with type elt = id
-end
-
-module NexpSet : sig
-  include Set.S with type elt = nexp
-end
-
-module NexpMap : sig
-  include Map.S with type key = nexp
-end
-
-module KOptSet : sig
-  include Set.S with type elt = kinded_id
-end
-
-module KOptMap : sig
-  include Map.S with type key = kinded_id
-end
-
-module BESet : sig
-  include Set.S with type elt = base_effect
-end
-
-module KidSet : sig
-  include Set.S with type elt = kid
-end
-
-module KBindings : sig
-  include Map.S with type key = kid
-end
-
-module Bindings : sig
-  include Map.S with type key = id
-end
-
-module TypMap : sig
-  include Map.S with type key = typ
-end
+(** {2 Misc functions} *)
 
 val nexp_frees : nexp -> KidSet.t
 val nexp_identical : nexp -> nexp -> bool
@@ -351,27 +416,12 @@ val int_of_nexp_opt : nexp -> Big_int.num option
 
 val lexp_to_exp : 'a lexp -> 'a exp
 
-val is_unit_typ : typ -> bool
-val is_number : typ -> bool
-val is_ref_typ : typ -> bool
-val is_vector_typ : typ -> bool
-val is_bit_typ : typ -> bool
-val is_bitvector_typ : typ -> bool
-
 val typ_app_args_of : typ -> string * typ_arg_aux list * Ast.l
 val vector_typ_args_of : typ -> nexp * order * typ
 val vector_start_index : typ -> nexp
 
 val is_order_inc : order -> bool
 
-val has_effect : effect -> base_effect_aux -> bool
-
-val effect_set : effect -> BESet.t
-
-val equal_effects : effect -> effect -> bool
-val subseteq_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
@@ -393,9 +443,7 @@ val construct_pexp : 'a pat * ('a exp) option * 'a exp * (Ast.l * 'a) ->  'a pex
 val destruct_mpexp : 'a mpexp -> 'a mpat * ('a exp) option * (Ast.l * 'a)
 val construct_mpexp : 'a mpat * ('a exp) option * (Ast.l * 'a) ->  'a mpexp
 
-
 val is_valspec : id -> 'a def -> bool
-
 val is_fundef : id -> 'a def -> bool
 
 val rename_valspec : id -> 'a val_spec -> 'a val_spec
@@ -412,12 +460,16 @@ val type_union_id : type_union -> id
 val ids_of_def : 'a def -> IdSet.t
 val ids_of_defs : 'a defs -> IdSet.t
 
+val val_spec_ids : 'a defs -> IdSet.t
+
 val pat_ids : 'a pat -> IdSet.t
 
 val subst : id -> 'a exp -> 'a exp -> 'a exp
 
 val hex_to_bin : string -> string
 
+(** {2 Manipulating locations} *)
+
 (** locate takes an expression and recursively sets the location in
    every subexpression using a function that takes the orginal
    location as an argument. Expressions build using mk_exp and similar
@@ -432,18 +484,28 @@ val locate_lexp : (l -> l) -> 'a lexp -> 'a lexp
 
 val locate_typ : (l -> l) -> typ -> typ
 
-(* Make a unique location by giving it a Parse_ast.Unique wrapper with
+(** Make a unique location by giving it a Parse_ast.Unique wrapper with
    a generated number. *)
 val unique : l -> l
 
-
 val extern_assoc : string -> (string * string) list -> string option
 
-(** Substitutions *)
+(** Reduce a location to a pair of positions if possible *)
+val simp_loc : Ast.l -> (Lexing.position * Lexing.position) option
+
+(** Try to find the annotation closest to the provided (simplified)
+   location. Note that this function makes no guarantees about finding
+   the closest annotation or even finding an annotation at all. This
+   is used by the Emacs mode to provide type-at-cursor functionality
+   and we don't mind if it's a bit fuzzy in that context. *)
+val find_annot_ast : (Lexing.position * Lexing.position) option -> 'a defs -> (Ast.l * 'a) option
+
+(** {2 Substitutions}
 
-(* The function X_subst substitutes a type argument into something of
+   The function X_subst substitutes a type argument into something of
    type X. The type of the type argument determines which kind of type
-   variables willb e replaced *)
+   variables will be replaced *)
+
 val nexp_subst : kid -> typ_arg -> nexp -> nexp
 val constraint_subst : kid -> typ_arg -> n_constraint -> n_constraint
 val order_subst : kid -> typ_arg -> order -> order
@@ -452,9 +514,11 @@ val typ_arg_subst : kid -> typ_arg -> typ_arg -> typ_arg
 
 val subst_kid : (kid -> typ_arg -> 'a -> 'a) -> kid -> kid -> 'a -> 'a
 
+(* Multiple type-level substitutions *)
+val subst_kids_nexp : nexp KBindings.t -> nexp -> nexp
+val subst_kids_nc : nexp KBindings.t -> n_constraint -> n_constraint
+val subst_kids_typ : nexp KBindings.t -> typ -> typ
+val subst_kids_typ_arg : nexp KBindings.t -> typ_arg -> typ_arg
+
 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/constant_fold.ml b/src/constant_fold.ml
index 15772168..6706cc01 100644
--- a/src/constant_fold.ml
+++ b/src/constant_fold.ml
@@ -62,6 +62,9 @@ let optimize_constant_fold = ref false
 let rec fexp_of_ctor (field, value) =
   FE_aux (FE_Fexp (mk_id field, exp_of_value value), no_annot)
 
+(* The interpreter will return a value for each folded expression, so
+   we must convert that back to expression to re-insert it in the AST
+   *)
 and exp_of_value =
   let open Value in
   function
@@ -108,6 +111,32 @@ let safe_primops =
       "Elf_loader.elf_tohost"
     ]
 
+(** We can specify a list of identifiers that we want to remove from
+   the final AST here. This is useful for removing tracing features in
+   optimized builds, e.g. for booting an OS as fast as possible.
+
+   Basically we just do this by mapping
+
+   f(x, y, z) -> ()
+
+   when f is in the list of identifiers to be mapped to unit. The
+   advantage of doing it like this is if x, y, and z are
+   computationally expensive then we remove them also. String
+   concatentation is very expensive at runtime so this is something we
+   really want when cutting out tracing features. Obviously it's
+   important that they don't have any meaningful side effects, and
+   that f does actually have type unit.
+*)
+let opt_fold_to_unit = ref []
+
+let fold_to_unit id =
+  let remove =
+    !opt_fold_to_unit
+    |> List.map mk_id
+    |> List.fold_left (fun m id -> IdSet.add id m) IdSet.empty
+  in
+  IdSet.mem id remove
+
 let rec is_constant (E_aux (e_aux, _)) =
   match e_aux with
   | E_lit _ -> true
@@ -188,6 +217,9 @@ let rec rewrite_constant_function_calls' env ast =
 
   let rw_funcall e_aux annot =
     match e_aux with
+    | E_app (id, args) when fold_to_unit id ->
+       ok (); E_aux (E_lit (L_aux (L_unit, fst annot)), annot)
+
     | E_app (id, args) when List.for_all is_constant args ->
        evaluate e_aux annot
 
diff --git a/src/constant_propagation.ml b/src/constant_propagation.ml
new file mode 100644
index 00000000..33b67008
--- /dev/null
+++ b/src/constant_propagation.ml
@@ -0,0 +1,876 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Ast
+open Ast_util
+open Spec_analysis
+open Type_check
+
+(* COULD DO: dead code is only eliminated at if expressions, but we could
+   also cut out impossible case branches and code after assertions. *)
+
+(* Constant propogation.
+   Takes maps of immutable/mutable variables to subsitute.
+   The substs argument also contains the current type-level kid refinements
+   so that we can check for dead code.
+   Extremely conservative about evaluation order of assignments in
+   subexpressions, dropping assignments rather than committing to
+   any particular order *)
+
+
+let kbindings_from_list = List.fold_left (fun s (v,i) -> KBindings.add v i s) KBindings.empty
+let bindings_from_list = List.fold_left (fun s (v,i) -> Bindings.add v i s) Bindings.empty
+(* union was introduced in 4.03.0, a bit too recently *)
+let bindings_union s1 s2 =
+  Bindings.merge (fun _ x y -> match x,y with
+  |  _, (Some x) -> Some x
+  |  (Some x), _ -> Some x
+  |  _,  _ -> None) s1 s2
+let kbindings_union s1 s2 =
+  KBindings.merge (fun _ x y -> match x,y with
+  |  _, (Some x) -> Some x
+  |  (Some x), _ -> Some x
+  |  _,  _ -> None) s1 s2
+
+let rec list_extract f = function
+  | [] -> None
+  | h::t -> match f h with None -> list_extract f t | Some v -> Some v
+
+
+
+let is_pure e =
+  match e with
+  | Effect_aux (Effect_set [],_) -> true
+  | _ -> false
+
+let remove_bound (substs,ksubsts) pat =
+  let bound = bindings_from_pat pat in
+  List.fold_left (fun sub v -> Bindings.remove v sub) substs bound, ksubsts
+
+let rec is_value (E_aux (e,(l,annot))) =
+  let is_constructor id =
+    match destruct_tannot annot with
+    | None ->
+       (Reporting.print_err l "Monomorphisation"
+          ("Missing type information for identifier " ^ string_of_id id);
+        false) (* Be conservative if we have no info *)
+    | Some (env,_,_) ->
+       Env.is_union_constructor id env ||
+         (match Env.lookup_id id env with
+         | Enum _ -> true
+         | Unbound | Local _ | Register _ -> false)
+  in
+  match e with
+  | E_id id -> is_constructor id
+  | E_lit _ -> true
+  | E_tuple es -> List.for_all is_value es
+  | E_app (id,es) -> is_constructor id && List.for_all is_value es
+  (* We add casts to undefined to keep the type information in the AST *)
+  | E_cast (typ,E_aux (E_lit (L_aux (L_undef,_)),_)) -> true
+(* TODO: more? *)
+  | _ -> false
+
+let isubst_minus_set subst set =
+  IdSet.fold Bindings.remove set subst
+
+let threaded_map f state l =
+  let l',state' =
+    List.fold_left (fun (tl,state) element -> let (el',state') = f state element in (el'::tl,state'))
+      ([],state) l
+  in List.rev l',state'
+
+
+(* Attempt simple pattern matches *)
+let lit_match = function
+  | (L_zero | L_false), (L_zero | L_false) -> true
+  | (L_one  | L_true ), (L_one  | L_true ) -> true
+  | L_num i1, L_num i2 -> Big_int.equal i1 i2
+  | l1,l2 -> l1 = l2
+
+(* There's no undefined nexp, so replace undefined sizes with a plausible size.
+   32 is used as a sensible default. *)
+
+let fabricate_nexp_exist env l typ kids nc typ' =
+  match kids,nc,Env.expand_synonyms env typ' with
+  | ([kid],NC_aux (NC_set (kid',i::_),_),
+     Typ_aux (Typ_app (Id_aux (Id "atom",_),
+                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_))
+      when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 ->
+     Nexp_aux (Nexp_constant i,Unknown)
+  | ([kid],NC_aux (NC_true,_),
+     Typ_aux (Typ_app (Id_aux (Id "atom",_),
+                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_))
+      when Kid.compare kid kid'' = 0 ->
+     nint 32
+  | ([kid],NC_aux (NC_set (kid',i::_),_),
+     Typ_aux (Typ_app (Id_aux (Id "range",_),
+                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_);
+                        A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_))
+      when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 &&
+        Kid.compare kid kid''' = 0 ->
+     Nexp_aux (Nexp_constant i,Unknown)
+  | ([kid],NC_aux (NC_true,_),
+     Typ_aux (Typ_app (Id_aux (Id "range",_),
+                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_);
+                        A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_))
+      when Kid.compare kid kid'' = 0 &&
+        Kid.compare kid kid''' = 0 ->
+     nint 32
+  | ([], _, 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
+  | None -> nint 32
+  | Some (env,typ,_) ->
+     match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with
+     | None -> nint 32
+     (* TODO: check this *)
+     | Some (kopts,nc,typ') -> fabricate_nexp_exist env l typ (List.map kopt_kid kopts) nc typ'
+
+let atom_typ_kid kid = function
+  | Typ_aux (Typ_app (Id_aux (Id "atom",_),
+                      [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) ->
+     Kid.compare kid kid' = 0
+  | _ -> false
+
+(* We reduce casts in a few cases, in particular to ensure that where the
+   type checker has added a ({'n, true. atom('n)}) ex_int(...) cast we can
+   fill in the 'n.  For undefined we fabricate a suitable value for 'n. *)
+
+let reduce_cast typ exp l annot =
+  let env = env_of_annot (l,annot) in
+  let typ' = Env.base_typ_of env typ in
+  match exp, destruct_exist (Env.expand_synonyms env typ') with
+  | 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 __POS__ nc_env nc
+     then exp
+     else raise (Reporting.err_unreachable l __POS__
+                   ("Constant propagation error: literal " ^ Big_int.to_string n ^
+                       " does not satisfy constraint " ^ string_of_n_constraint nc))
+  | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' ->
+     let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in
+     let newtyp = subst_kids_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in
+     E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot))
+  | E_aux (E_cast (_,
+                   (E_aux (E_lit (L_aux (L_undef,_)),_) as exp)),_),
+     Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' ->
+     let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in
+     let newtyp = subst_kids_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in
+     E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot))
+  | _ -> E_aux (E_cast (typ,exp),(l,annot))
+
+(* Used for constant propagation in pattern matches *)
+type 'a matchresult =
+  | DoesMatch of 'a
+  | DoesNotMatch
+  | GiveUp
+
+(* Remove top-level casts from an expression.  Useful when we need to look at
+   subexpressions to reduce something, but could break type-checking if we used
+   it everywhere. *)
+let rec drop_casts = function
+  | E_aux (E_cast (_,e),_) -> drop_casts e
+  | exp -> exp
+
+let int_of_str_lit = function
+  | L_hex hex -> Big_int.of_string ("0x" ^ hex)
+  | L_bin bin -> Big_int.of_string ("0b" ^ bin)
+  | _ -> assert false
+
+let bits_of_lit = function
+  | L_bin bin -> bin
+  | L_hex hex -> hex_to_bin hex
+  | _ -> assert false
+
+let slice_lit (L_aux (lit,ll)) i len (Ord_aux (ord,_)) =
+  let i = Big_int.to_int i in
+  let len = Big_int.to_int len in
+  let bin = bits_of_lit lit in
+  match match ord with
+  | Ord_inc -> Some i
+  | Ord_dec -> Some (String.length bin - i - len)
+  | Ord_var _ -> None
+  with
+  | None -> None
+  | Some i ->
+     Some (L_aux (L_bin (String.sub bin i len),Generated ll))
+
+let concat_vec lit1 lit2 =
+  let bits1 = bits_of_lit lit1 in
+  let bits2 = bits_of_lit lit2 in
+  L_bin (bits1 ^ bits2)
+
+let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) =
+  match l1,l2 with
+  | (L_zero|L_false), (L_zero|L_false)
+  | (L_one |L_true ), (L_one |L_true)
+    -> Some true
+  | (L_hex _| L_bin _), (L_hex _|L_bin _)
+    -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2))
+  | L_undef, _ | _, L_undef -> None
+  | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2)
+  | _ -> Some (l1 = l2)
+
+let try_app (l,ann) (id,args) =
+  let new_l = Parse_ast.Generated l in
+  let env = env_of_annot (l,ann) in
+  let get_overloads f = List.map string_of_id
+    (Env.get_overloads (Id_aux (Id f, Parse_ast.Unknown)) env @
+    Env.get_overloads (Id_aux (DeIid f, Parse_ast.Unknown)) env) in
+  let is_id f = List.mem (string_of_id id) (f :: get_overloads f) in
+  if is_id "==" || is_id "!=" then
+    match args with
+    | [E_aux (E_lit l1,_); E_aux (E_lit l2,_)] ->
+       let lit b = if b then L_true else L_false in
+       let lit b = lit (if is_id "==" then b else not b) in
+       (match lit_eq l1 l2 with
+       | None -> None
+       | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)),(l,ann))))
+    | _ -> None
+  else if is_id "cast_bit_bool" then
+    match args with
+    | [E_aux (E_lit L_aux (L_zero,_),_)] -> Some (E_aux (E_lit (L_aux (L_false,new_l)),(l,ann)))
+    | [E_aux (E_lit L_aux (L_one ,_),_)] -> Some (E_aux (E_lit (L_aux (L_true ,new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "UInt" || is_id "unsigned" then
+    match args with
+    | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit,_), _)] ->
+       Some (E_aux (E_lit (L_aux (L_num (int_of_str_lit lit),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "slice" then
+    match args with
+    | [E_aux (E_lit (L_aux ((L_hex _| L_bin _),_) as lit), annot);
+       E_aux (E_lit L_aux (L_num i,_), _);
+       E_aux (E_lit L_aux (L_num len,_), _)] ->
+       (match Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) with
+       | Typ_aux (Typ_app (_,[_;A_aux (A_order ord,_);_]),_) ->
+          (match slice_lit lit i len ord with
+          | Some lit' -> Some (E_aux (E_lit lit',(l,ann)))
+          | None -> None)
+       | _ -> None)
+    | _ -> None
+  else if is_id "bitvector_concat" then
+    match args with
+    | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit1,_), _);
+       E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit2,_), _)] ->
+       Some (E_aux (E_lit (L_aux (concat_vec lit1 lit2,new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "shl_int" then
+    match args with
+    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
+       Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "mult_atom" || is_id "mult_int" || is_id "mult_range" then
+    match args with
+    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
+       Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "quotient_nat" then
+    match args with
+    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
+       Some (E_aux (E_lit (L_aux (L_num (Big_int.div i j),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "add_atom" || is_id "add_int" || is_id "add_range" then
+    match args with
+    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
+       Some (E_aux (E_lit (L_aux (L_num (Big_int.add i j),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "negate_range" then
+    match args with
+    | [E_aux (E_lit L_aux (L_num i,_),_)] ->
+       Some (E_aux (E_lit (L_aux (L_num (Big_int.negate i),new_l)),(l,ann)))
+    | _ -> None
+  else if is_id "ex_int" then
+    match args with
+    | [E_aux (E_lit lit,(l,_))] -> Some (E_aux (E_lit lit,(l,ann)))
+    | [E_aux (E_cast (_,(E_aux (E_lit (L_aux (L_undef,_)),_) as e)),(l,_))] ->
+       Some (reduce_cast (typ_of_annot (l,ann)) e l ann)
+    | _ -> None
+  else if is_id "vector_access" || is_id "bitvector_access" then
+    match args with
+    | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_);
+       E_aux (E_lit L_aux (L_num i,_),_)] ->
+       let v = int_of_str_lit lit in
+       let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in
+       let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in
+       Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann)))
+    | _ -> None
+  else None
+
+
+let construct_lit_vector args =
+  let rec aux l = function
+    | [] -> Some (L_aux (L_bin (String.concat "" (List.rev l)),Unknown))
+    | E_aux (E_lit (L_aux ((L_zero | L_one) as lit,_)),_)::t ->
+       aux ((if lit = L_zero then "0" else "1")::l) t
+    | _ -> None
+  in aux [] args
+
+(* Add a cast to undefined so that it retains its type, otherwise it can't be
+   substituted safely *)
+let keep_undef_typ value =
+  match value with
+  | E_aux (E_lit (L_aux (L_undef,lann)),eann) ->
+     E_aux (E_cast (typ_of_annot eann,value),(Generated Unknown,snd eann))
+  | _ -> value
+
+(* Check whether the current environment with the given kid assignments is
+   inconsistent (and hence whether the code is dead) *)
+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 __POS__ env nc_false
+
+
+let const_props defs ref_vars =
+  let rec const_prop_exp substs assigns ((E_aux (e,(l,annot))) as exp) =
+    (* Functions to treat lists and tuples of subexpressions as possibly
+       non-deterministic: that is, we stop making any assumptions about
+       variables that are assigned to in any of the subexpressions *)
+    let non_det_exp_list es =
+      let assigned_in =
+        List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp))
+          IdSet.empty es in
+      let assigns = isubst_minus_set assigns assigned_in in
+      let es' = List.map (fun e -> fst (const_prop_exp substs assigns e)) es in
+      es',assigns
+    in
+    let non_det_exp_2 e1 e2 =
+       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
+       let assigns = isubst_minus_set assigns assigned_in_e12 in
+       let e1',_ = const_prop_exp substs assigns e1 in
+       let e2',_ = const_prop_exp substs assigns e2 in
+       e1',e2',assigns
+    in
+    let non_det_exp_3 e1 e2 e3 =
+       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
+       let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in
+       let assigns = isubst_minus_set assigns assigned_in_e123 in
+       let e1',_ = const_prop_exp substs assigns e1 in
+       let e2',_ = const_prop_exp substs assigns e2 in
+       let e3',_ = const_prop_exp substs assigns e3 in
+       e1',e2',e3',assigns
+    in
+    let non_det_exp_4 e1 e2 e3 e4 =
+       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
+       let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in
+       let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in
+       let assigns = isubst_minus_set assigns assigned_in_e1234 in
+       let e1',_ = const_prop_exp substs assigns e1 in
+       let e2',_ = const_prop_exp substs assigns e2 in
+       let e3',_ = const_prop_exp substs assigns e3 in
+       let e4',_ = const_prop_exp substs assigns e4 in
+       e1',e2',e3',e4',assigns
+    in
+    let re e assigns = E_aux (e,(l,annot)),assigns in
+    match e with
+      (* TODO: are there more circumstances in which we should get rid of these? *)
+    | E_block [e] -> const_prop_exp substs assigns e
+    | E_block es ->
+       let es',assigns = threaded_map (const_prop_exp substs) assigns es in
+       re (E_block es') assigns
+    | E_nondet es ->
+       let es',assigns = non_det_exp_list es in
+       re (E_nondet es') assigns
+    | E_id id ->
+       let env = Type_check.env_of_annot (l, annot) in
+       (try
+         match Env.lookup_id id env with
+         | Local (Immutable,_) -> Bindings.find id (fst substs)
+         | Local (Mutable,_)   -> Bindings.find id assigns
+         | _ -> exp
+       with Not_found -> exp),assigns
+    | E_lit _
+    | E_sizeof _
+    | E_constraint _
+      -> exp,assigns
+    | E_cast (t,e') ->
+       let e'',assigns = const_prop_exp substs assigns e' in
+       if is_value e''
+       then reduce_cast t e'' l annot, assigns
+       else re (E_cast (t, e'')) assigns
+    | E_app (id,es) ->
+       let es',assigns = non_det_exp_list es in
+       let env = Type_check.env_of_annot (l, annot) in
+       (match try_app (l,annot) (id,es') with
+       | None ->
+          (match const_prop_try_fn l env (id,es') with
+          | None -> re (E_app (id,es')) assigns
+          | Some r -> r,assigns)
+       | Some r -> r,assigns)
+    | E_tuple es ->
+       let es',assigns = non_det_exp_list es in
+       re (E_tuple es') assigns
+    | E_if (e1,e2,e3) ->
+       let e1',assigns = const_prop_exp substs assigns e1 in
+       let e1_no_casts = drop_casts e1' in
+       (match e1_no_casts with
+       | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) ->
+          (match lit with
+          | L_true -> const_prop_exp substs assigns e2
+          |  _     -> const_prop_exp substs assigns e3)
+       | _ ->
+          (* If the guard is an equality check, propagate the value. *)
+          let env1 = env_of e1_no_casts in
+          let is_equal id =
+            List.exists (fun id' -> Id.compare id id' == 0)
+              (Env.get_overloads (Id_aux (DeIid "==", Parse_ast.Unknown))
+                 env1)
+          in
+          let substs_true =
+            match e1_no_casts with
+            | E_aux (E_app (id, [E_aux (E_id var,_); vl]),_)
+            | E_aux (E_app (id, [vl; E_aux (E_id var,_)]),_)
+                when is_equal id ->
+               if is_value vl then
+                 (match Env.lookup_id var env1 with
+                 | Local (Immutable,_) -> Bindings.add var vl (fst substs),snd substs
+                 | _ -> substs)
+               else substs
+            | _ -> substs
+          in
+          (* Discard impossible branches *)
+          if is_env_inconsistent (env_of e2) (snd substs) then
+            const_prop_exp substs assigns e3
+          else if is_env_inconsistent (env_of e3) (snd substs) then
+            const_prop_exp substs_true assigns e2
+          else
+            let e2',assigns2 = const_prop_exp substs_true assigns e2 in
+            let e3',assigns3 = const_prop_exp substs assigns e3 in
+            let assigns = isubst_minus_set assigns (assigned_vars e2) in
+            let assigns = isubst_minus_set assigns (assigned_vars e3) in
+            re (E_if (e1',e2',e3')) assigns)
+    | E_for (id,e1,e2,e3,ord,e4) ->
+       (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *)
+       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
+       let assigns = isubst_minus_set assigns (assigned_vars e4) in
+       let e4',_ = const_prop_exp (Bindings.remove id (fst substs),snd substs) assigns e4 in
+       re (E_for (id,e1',e2',e3',ord,e4')) assigns
+    | E_loop (loop,e1,e2) ->
+       let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in
+       let e1',_ = const_prop_exp substs assigns e1 in
+       let e2',_ = const_prop_exp substs assigns e2 in
+       re (E_loop (loop,e1',e2')) assigns
+    | E_vector es ->
+       let es',assigns = non_det_exp_list es in
+       begin
+         match construct_lit_vector es' with
+         | None -> re (E_vector es') assigns
+         | Some lit -> re (E_lit lit) assigns
+       end
+    | E_vector_access (e1,e2) ->
+       let e1',e2',assigns = non_det_exp_2 e1 e2 in
+       re (E_vector_access (e1',e2')) assigns
+    | E_vector_subrange (e1,e2,e3) ->
+       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
+       re (E_vector_subrange (e1',e2',e3')) assigns
+    | E_vector_update (e1,e2,e3) ->
+       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
+       re (E_vector_update (e1',e2',e3')) assigns
+    | E_vector_update_subrange (e1,e2,e3,e4) ->
+       let e1',e2',e3',e4',assigns = non_det_exp_4 e1 e2 e3 e4 in
+       re (E_vector_update_subrange (e1',e2',e3',e4')) assigns
+    | E_vector_append (e1,e2) ->
+       let e1',e2',assigns = non_det_exp_2 e1 e2 in
+       re (E_vector_append (e1',e2')) assigns
+    | E_list es ->
+       let es',assigns = non_det_exp_list es in
+       re (E_list es') assigns
+    | E_cons (e1,e2) ->
+       let e1',e2',assigns = non_det_exp_2 e1 e2 in
+       re (E_cons (e1',e2')) assigns
+    | E_record fes ->
+       let assigned_in_fes = assigned_vars_in_fexps fes in
+       let assigns = isubst_minus_set assigns assigned_in_fes in
+       re (E_record (const_prop_fexps substs assigns fes)) assigns
+    | E_record_update (e,fes) ->
+       let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in
+       let assigns = isubst_minus_set assigns assigned_in in
+       let e',_ = const_prop_exp substs assigns e in
+       re (E_record_update (e', const_prop_fexps substs assigns fes)) assigns
+    | E_field (e,id) ->
+       let e',assigns = const_prop_exp substs assigns e in
+       re (E_field (e',id)) assigns
+    | E_case (e,cases) ->
+       let e',assigns = const_prop_exp substs assigns e in
+       (match can_match e' cases substs assigns with
+       | None ->
+          let assigned_in =
+            List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe))
+              IdSet.empty cases
+          in
+          let assigns' = isubst_minus_set assigns assigned_in in
+          re (E_case (e', List.map (const_prop_pexp substs assigns) cases)) assigns'
+       | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) ->
+          let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in
+          let newbindings_env = bindings_from_list newbindings in
+          let substs' = bindings_union (fst substs) newbindings_env, snd substs in
+          const_prop_exp substs' assigns exp)
+    | E_let (lb,e2) ->
+       begin
+         match lb with
+         | LB_aux (LB_val (p,e), annot) ->
+            let e',assigns = const_prop_exp substs assigns e in
+            let substs' = remove_bound substs p in
+            let plain () =
+              let e2',assigns = const_prop_exp substs' assigns e2 in
+              re (E_let (LB_aux (LB_val (p,e'), annot),
+                         e2')) assigns in
+            if is_value e' && not (is_value e) then
+              match can_match e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with
+              | None -> plain ()
+              | Some (e'',bindings,kbindings) ->
+                 let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in
+                 let bindings = bindings_from_list bindings in
+                 let substs'' = bindings_union (fst substs') bindings, snd substs' in
+                 const_prop_exp substs'' assigns e''
+            else plain ()
+       end
+    (* TODO maybe - tuple assignments *)
+    | E_assign (le,e) ->
+       let env = Type_check.env_of_annot (l, annot) in
+       let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in
+       let assigns = isubst_minus_set assigns assigned_in in
+       let le',idopt = const_prop_lexp substs assigns le in
+       let e',_ = const_prop_exp substs assigns e in
+       let assigns =
+         match idopt with
+         | Some id ->
+            begin
+              match Env.lookup_id id env with
+              | Local (Mutable,_) | Unbound ->
+                 if is_value e' && not (IdSet.mem id ref_vars)
+                 then Bindings.add id (keep_undef_typ e') assigns
+                 else Bindings.remove id assigns
+              | _ -> assigns
+            end
+         | None -> assigns
+       in
+       re (E_assign (le', e')) assigns
+    | E_exit e ->
+       let e',_ = const_prop_exp substs assigns e in
+       re (E_exit e') Bindings.empty
+    | E_ref id -> re (E_ref id) Bindings.empty
+    | E_throw e ->
+       let e',_ = const_prop_exp substs assigns e in
+       re (E_throw e') Bindings.empty
+    | E_try (e,cases) ->
+       (* TODO: try and preserve *any* assignment info *)
+       let e',_ = const_prop_exp substs assigns e in
+       re (E_case (e', List.map (const_prop_pexp substs Bindings.empty) cases)) Bindings.empty
+    | E_return e ->
+       let e',_ = const_prop_exp substs assigns e in
+       re (E_return e') Bindings.empty
+    | E_assert (e1,e2) ->
+       let e1',e2',assigns = non_det_exp_2 e1 e2 in
+       re (E_assert (e1',e2')) assigns
+  
+    | E_app_infix _
+    | E_var _
+    | E_internal_plet _
+    | E_internal_return _
+    | E_internal_value _
+      -> raise (Reporting.err_unreachable l __POS__
+                  ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp))
+  and const_prop_fexps substs assigns fes =
+    List.map (const_prop_fexp substs assigns) fes
+  and const_prop_fexp substs assigns (FE_aux (FE_Fexp (id,e), annot)) =
+    FE_aux (FE_Fexp (id,fst (const_prop_exp substs assigns e)),annot)
+  and const_prop_pexp substs assigns = function
+    | (Pat_aux (Pat_exp (p,e),l)) ->
+       Pat_aux (Pat_exp (p,fst (const_prop_exp (remove_bound substs p) assigns e)),l)
+    | (Pat_aux (Pat_when (p,e1,e2),l)) ->
+       let substs' = remove_bound substs p in
+       let e1',assigns = const_prop_exp substs' assigns e1 in
+       Pat_aux (Pat_when (p, e1', fst (const_prop_exp substs' assigns e2)),l)
+  and const_prop_lexp substs assigns ((LEXP_aux (e,annot)) as le) =
+    let re e = LEXP_aux (e,annot), None in
+    match e with
+    | LEXP_id id (* shouldn't end up substituting here *)
+    | LEXP_cast (_,id)
+      -> le, Some id
+    | LEXP_memory (id,es) ->
+       re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp substs assigns e)) es)) (* or here *)
+    | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp substs assigns le)) les))
+    | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp substs assigns le), fst (const_prop_exp substs assigns e)))
+    | LEXP_vector_range (le,e1,e2) ->
+       re (LEXP_vector_range (fst (const_prop_lexp substs assigns le),
+                              fst (const_prop_exp substs assigns e1),
+                              fst (const_prop_exp substs assigns e2)))
+    | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp substs assigns le)) les))
+    | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp substs assigns le), id))
+    | LEXP_deref e ->
+       re (LEXP_deref (fst (const_prop_exp substs assigns e)))
+  (* Reduce a function when
+     1. all arguments are values,
+     2. the function is pure,
+     3. the result is a value
+     (and 4. the function is not scattered, but that's not terribly important)
+     to try and keep execution time and the results managable.
+  *)
+  and const_prop_try_fn l env (id,args) =
+    if not (List.for_all is_value args) then
+      None
+    else
+      let (tq,typ) = Env.get_val_spec_orig id env in
+      let eff = match typ with
+        | Typ_aux (Typ_fn (_,_,eff),_) -> Some eff
+        | _ -> None
+      in
+      let Defs ds = defs in
+      match eff, list_extract (function
+      | (DEF_fundef (FD_aux (FD_function (_,_,eff,((FCL_aux (FCL_Funcl (id',_),_))::_ as fcls)),_)))
+        -> if Id.compare id id' = 0 then Some fcls else None
+      | _ -> None) ds with
+      | None,_ | _,None -> None
+      | Some eff,_ when not (is_pure eff) -> None
+      | Some _,Some fcls ->
+         let arg = match args with
+           | [] -> E_aux (E_lit (L_aux (L_unit,Generated l)),(Generated l,empty_tannot))
+           | [e] -> e
+           | _ -> E_aux (E_tuple args,(Generated l,empty_tannot)) in
+         let cases = List.map (function
+           | FCL_aux (FCL_Funcl (_,pexp), ann) -> pexp)
+           fcls in
+         match can_match_with_env env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with
+         | Some (exp,bindings,kbindings) ->
+            let substs = bindings_from_list bindings, kbindings_from_list kbindings in
+            let result,_ = const_prop_exp substs Bindings.empty exp in
+            let result = match result with
+              | E_aux (E_return e,_) -> e
+              | _ -> result
+            in
+            if is_value result then Some result else None
+         | None -> None
+  
+  and can_match_with_env env (E_aux (e,(l,annot)) as exp0) cases (substs,ksubsts) assigns =
+    let rec findpat_generic check_pat description assigns = function
+      | [] -> (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 ->
+         findpat_generic check_pat description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl)
+      | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx
+          when pat_id_is_variable env id' ->
+         Some (exp, [(id', exp0)], [])
+      | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl
+          when pat_id_is_variable env id' -> begin
+            let substs = Bindings.add id' exp0 substs, ksubsts in
+            let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in
+            match guard with
+            | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[])
+            | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl
+            | _ -> None
+          end
+      | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin
+        match check_pat p with
+        | DoesNotMatch -> findpat_generic check_pat description assigns tl
+        | DoesMatch (vsubst,ksubst) -> begin
+          let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in
+          let substs = bindings_union substs (bindings_from_list vsubst),
+                       kbindings_union ksubsts (kbindings_from_list ksubst) in
+          let (E_aux (guard,_)),assigns = const_prop_exp substs assigns guard in
+          match guard with
+          | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst)
+          | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl
+          | _ -> None
+        end
+        | GiveUp -> None
+      end
+      | (Pat_aux (Pat_exp (p,exp),_))::tl ->
+         match check_pat p with
+         | DoesNotMatch -> findpat_generic check_pat description assigns tl
+         | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst)
+         | GiveUp -> None
+    in
+    match e with
+    | E_id id ->
+       (match Env.lookup_id id env with
+       | Enum _ ->
+          let checkpat = function
+            | P_aux (P_id id',_)
+            | P_aux (P_app (id',[]),_) ->
+               if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch
+            | P_aux (_,(l',_)) ->
+               (Reporting.print_err l' "Monomorphisation"
+                  "Unexpected kind of pattern for enumeration"; GiveUp)
+          in findpat_generic checkpat (string_of_id id) assigns cases
+       | _ -> None)
+    | E_lit (L_aux (lit_e, lit_l)) ->
+       let checkpat = function
+         | P_aux (P_lit (L_aux (lit_p, _)),_) ->
+            if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch
+         | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) ->
+            begin
+              match lit_e with
+              | L_num i ->
+                 DoesMatch ([id, E_aux (e,(l,annot))],
+                            [kid,Nexp_aux (Nexp_constant i,Unknown)])
+              (* For undefined we fix the type-level size (because there's no good
+                 way to construct an undefined size), but leave the term as undefined
+                 to make the meaning clear. *)
+              | L_undef ->
+                 let nexp = fabricate_nexp l annot in
+                 let typ = subst_kids_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in
+                 DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))],
+                            [kid,nexp])
+              | _ ->
+                 (Reporting.print_err lit_l "Monomorphisation"
+                    "Unexpected kind of literal for var match"; GiveUp)
+            end
+         | P_aux (_,(l',_)) ->
+            (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 ->
+       let checkpat = function
+         | P_aux (P_vector ps,_) ->
+            let matches = List.map2 (fun e p ->
+              match e, p with
+              | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) ->
+                 if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch
+              | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var ->
+                 DoesMatch ([var, e],[])
+              | _ -> GiveUp) es ps in
+            let final = List.fold_left (fun acc m -> match acc, m with
+              | _, GiveUp -> GiveUp
+              | GiveUp, _ -> GiveUp
+              | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub')
+              | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in
+            (match final with
+            | GiveUp ->
+               (Reporting.print_err l "Monomorphisation"
+                  "Unexpected kind of pattern for vector literal"; GiveUp)
+            | _ -> final)
+         | _ ->
+            (Reporting.print_err l "Monomorphisation"
+               "Unexpected kind of pattern for vector literal"; GiveUp)
+       in findpat_generic checkpat "vector literal" assigns cases
+  
+    | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) ->
+       let checkpat = function
+         | P_aux (P_lit (L_aux (lit_p, _)),_) -> DoesNotMatch
+         | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) ->
+              (* For undefined we fix the type-level size (because there's no good
+                 way to construct an undefined size), but leave the term as undefined
+                 to make the meaning clear. *)
+            let nexp = fabricate_nexp l annot in
+            let kids = equal_kids (env_of_annot p_id_annot) kid in
+            let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in
+            let typ = subst_kids_typ ksubst (typ_of_annot p_id_annot) in
+            DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))],
+                       KBindings.bindings ksubst)
+         | P_aux (_,(l',_)) ->
+            (Reporting.print_err l' "Monomorphisation"
+               "Unexpected kind of pattern for literal"; GiveUp)
+       in findpat_generic checkpat "literal" assigns cases
+    | _ -> None
+  
+  and can_match exp =
+    let env = Type_check.env_of exp in
+    can_match_with_env env exp
+
+in (const_prop_exp, const_prop_pexp)
+
+let const_prop d r = fst (const_props d r)
+let const_prop_pexp d r = snd (const_props d r)
+
+let referenced_vars exp =
+  let open Rewriter in
+  fst (fold_exp
+         { (compute_exp_alg IdSet.empty IdSet.union) with
+           e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp)
+
+(* This is intended to remove impossible cases when a type-level constant has
+   been used to fix a property of the architecture.  In particular, the current
+   version of the RISC-V model uses constructs like
+
+   match (width, sizeof(xlen)) {
+     (BYTE, _)    => ...
+     ...
+     (DOUBLE, 64) => ...
+   };
+
+   and the type checker will replace the sizeof with the literal 32 or 64.  This
+   pass will then remove the DOUBLE case.
+
+   It would be nice to have the full constant propagation above do this kind of
+   thing too...
+*)
+
+let remove_impossible_int_cases _ =
+
+  let must_keep_case exp (Pat_aux ((Pat_exp (p,_) | Pat_when (p,_,_)),_)) =
+    let rec aux (E_aux (exp,_)) (P_aux (p,_)) =
+      match exp, p with
+      | E_tuple exps, P_tup ps -> List.for_all2 aux exps ps
+      | E_lit (L_aux (lit,_)), P_lit (L_aux (lit',_)) -> lit_match (lit, lit')
+      | _ -> true
+    in aux exp p
+  in
+  let e_case (exp,cases) =
+    E_case (exp, List.filter (must_keep_case exp) cases)
+  in
+  let e_if (cond, e_then, e_else) =
+    match destruct_atom_bool (env_of cond) (typ_of cond) with
+    | Some nc ->
+       if prove __POS__ (env_of cond) nc then unaux_exp e_then else
+       if prove __POS__ (env_of cond) (nc_not nc) then unaux_exp e_else else
+       E_if (cond, e_then, e_else)
+    | _ -> E_if (cond, e_then, e_else)
+  in
+  let open Rewriter in
+  let rewrite_exp _ = fold_exp { id_exp_alg with e_case = e_case; e_if = e_if } in
+  rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp }
diff --git a/src/constant_propagation.mli b/src/constant_propagation.mli
new file mode 100644
index 00000000..437492c6
--- /dev/null
+++ b/src/constant_propagation.mli
@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Ast
+open Ast_util
+open Type_check
+
+(** [const_prop defs ref_vars substs assigns exp] performs constant propagation
+    on [exp] where [substs] is a pair of substitutions on immutable variables
+    and type variables, [assigns] is a substitution on mutable variables, and
+    [ref_vars] is the set of variable which may have had a reference taken
+    (and hence we cannot reliably track). *)
+
+val const_prop :
+  tannot defs ->
+  IdSet.t ->
+  tannot exp Bindings.t * nexp KBindings.t ->
+  tannot exp Bindings.t ->
+  tannot exp ->
+  tannot exp * tannot exp Bindings.t
+
+val referenced_vars : tannot exp -> IdSet.t
+
+val remove_impossible_int_cases : 'a -> tannot defs -> tannot defs
diff --git a/src/graph.ml b/src/graph.ml
index e3af0b97..703deba9 100644
--- a/src/graph.ml
+++ b/src/graph.ml
@@ -69,6 +69,15 @@ module type S =
     val add_edge : node -> node -> graph -> graph
     val add_edges : node -> node list -> graph -> graph
 
+    (** Add edges to the graph, but may leave the internal structure
+       of the graph in a non-normalized state. Fix leaves repairs any
+       such issue in the graph. These additional functions are much
+       faster than those above, but it is important to call fix_leaves
+       before calling reachable, prune, or any other function. *)
+    val add_edge' : node -> node -> graph -> graph
+    val add_edges' : node -> node list -> graph -> graph
+    val fix_leaves : graph -> graph
+
     val children : graph -> node -> node list
 
     (** Return the set of nodes that are reachable from the first set
@@ -119,19 +128,21 @@ module Make(Ord: OrderedType) = struct
   let fix_leaves cg =
     NS.fold (fun leaf cg -> if NM.mem leaf cg then cg else NM.add leaf NS.empty cg) (leaves cg) cg
 
-  (* FIXME: don't use fix_leaves because this is inefficient *)
-  let add_edge caller callee cg =
+  let add_edge' caller callee cg =
     try
-      fix_leaves (NM.add caller (NS.add callee (NM.find caller cg)) cg)
+      NM.add caller (NS.add callee (NM.find caller cg)) cg
     with
-    | Not_found -> fix_leaves (NM.add caller (NS.singleton callee) cg)
+    | Not_found -> NM.add caller (NS.singleton callee) cg
 
-  let add_edges caller callees cg =
+  let add_edges' caller callees cg =
     let callees = List.fold_left (fun s c -> NS.add c s) NS.empty callees in
     try
-      fix_leaves (NM.add caller (NS.union callees (NM.find caller cg)) cg)
+      NM.add caller (NS.union callees (NM.find caller cg)) cg
     with
-    | Not_found -> fix_leaves (NM.add caller callees cg)
+    | Not_found -> NM.add caller callees cg
+
+  let add_edge caller callee cg = fix_leaves (add_edge' caller callee cg)
+  let add_edges caller callees cg = fix_leaves (add_edges' caller callees cg)
 
   let reachable roots cuts cg =
     let visited = ref NS.empty in
@@ -223,6 +234,6 @@ module Make(Ord: OrderedType) = struct
     NM.bindings graph |> List.iter (fun (from_node, _) -> make_node from_node);
     NM.bindings graph |> List.iter (fun (from_node, to_nodes) -> NS.iter (make_line from_node) to_nodes);
     output_string out_chan "}\n";
-    Util.opt_colors := true;
+    Util.opt_colors := true
 
 end
diff --git a/src/graph.mli b/src/graph.mli
index 09b78304..02480a9d 100644
--- a/src/graph.mli
+++ b/src/graph.mli
@@ -71,6 +71,15 @@ module type S =
     val add_edge : node -> node -> graph -> graph
     val add_edges : node -> node list -> graph -> graph
 
+    (** Add edges to the graph, but may leave the internal structure
+       of the graph in a non-normalized state. Fix leaves repairs any
+       such issue in the graph. These additional functions are much
+       faster than those above, but it is important to call fix_leaves
+       before calling reachable, prune, or any other function. *)
+    val add_edge' : node -> node -> graph -> graph
+    val add_edges' : node -> node list -> graph -> graph
+    val fix_leaves : graph -> graph
+
     val children : graph -> node -> node list
 
     (** Return the set of nodes that are reachable from the first set
diff --git a/src/initial_check.ml b/src/initial_check.ml
index 33844a72..2aa0c511 100644
--- a/src/initial_check.ml
+++ b/src/initial_check.ml
@@ -811,18 +811,6 @@ let constraint_of_string str =
 let extern_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, [("_", string_of_id id)], false))
 let val_spec_of_string id str = mk_val_spec (VS_val_spec (typschm_of_string str, id, [], false))
 
-let val_spec_ids (Defs defs) =
-  let val_spec_id (VS_aux (vs_aux, _)) =
-    match vs_aux with
-    | VS_val_spec (_, id, _, _) -> id
-  in
-  let rec vs_ids = function
-    | DEF_spec vs :: defs -> val_spec_id vs :: vs_ids defs
-    | def :: defs -> vs_ids defs
-    | [] -> []
-  in
-  IdSet.of_list (vs_ids defs)
-
 let quant_item_param = function
   | QI_aux (QI_id kopt, _) when is_int_kopt kopt -> [prepend_id "atom_" (id_of_kid (kopt_kid kopt))]
   | QI_aux (QI_id kopt, _) when is_typ_kopt kopt -> [prepend_id "typ_" (id_of_kid (kopt_kid kopt))]
@@ -1047,7 +1035,7 @@ let process_ast ?generate:(generate=true) defs =
     |> generate_initialize_registers vs_ids
   else
     ast
-  
+
 let ast_of_def_string str =
   let def = Parser.def_eof Lexer.token (Lexing.from_string str) in
   process_ast (P.Defs [def])
diff --git a/src/initial_check.mli b/src/initial_check.mli
index a0bde482..b96a9efb 100644
--- a/src/initial_check.mli
+++ b/src/initial_check.mli
@@ -48,14 +48,18 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
+(** Initial desugaring pass over AST after parsing *)
+
 open Ast
 open Ast_util
 
-(* Generate undefined_T functions for every type T. False by
+(** {2 Options} *)
+
+(** Generate undefined_T functions for every type T. False by
    default. *)
 val opt_undefined_gen : bool ref
 
-(* Generate faster undefined_T functions. Rather than generating
+(** Generate faster undefined_T functions. Rather than generating
    functions that allow for the undefined values of enums and variants
    to be picked at runtime using a RNG or similar, this creates
    undefined_T functions for those types that simply return a specific
@@ -65,16 +69,17 @@ val opt_undefined_gen : bool ref
    default. *)
 val opt_fast_undefined : bool ref
 
-(* Allow # in identifiers when set, like the GHC option of the same name *)
+(** Allow # in identifiers when set, much like the GHC option of the same
+   name *)
 val opt_magic_hash : bool ref
 
-(* When true enums can be automatically casted to range types and
+(** When true enums can be automatically casted to range types and
    back.  Otherwise generated T_of_num and num_of_T functions must be
    manually used for each enum T *)
 val opt_enum_casts : bool ref
 
-(* This is a bit of a hack right now - it ensures that the undefiend
-   builtins (undefined_vector etc), only get added to the ast
+(** This is a bit of a hack right now - it ensures that the undefiend
+   builtins (undefined_vector etc), only get added to the AST
    once. The original assumption in sail is that the whole AST gets
    processed at once (therefore they could only get added once), and
    this isn't true any more with the interpreter. This needs to be
@@ -82,17 +87,17 @@ val opt_enum_casts : bool ref
    all the loaded files. *)
 val have_undefined_builtins : bool ref
 
-val ast_of_def_string : string -> unit defs
+(** {2 Desugar and process AST } *)
 
 (** 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
+(** {2 Parsing expressions and definitions from strings} *)
 
 val extern_of_string : id -> string -> unit def
 val val_spec_of_string : id -> string -> unit def
-
+val ast_of_def_string : string -> unit defs
 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 7a33c7d1..4db39123 100644
--- a/src/isail.ml
+++ b/src/isail.ml
@@ -57,7 +57,6 @@ open Pretty_print_sail
 
 type mode =
   | Evaluation of frame
-  | Bytecode of Value2.vl Bytecode_interpreter.gstate * Value2.vl Bytecode_interpreter.stack
   | Normal
   | Emacs
 
@@ -67,7 +66,6 @@ let prompt () =
   match !current_mode with
   | Normal -> "sail> "
   | Evaluation _ -> "eval> "
-  | Bytecode _ -> "ir> "
   | Emacs -> ""
 
 let eval_clear = ref true
@@ -76,7 +74,6 @@ let mode_clear () =
   match !current_mode with
   | Normal -> ()
   | Evaluation _ -> if !eval_clear then LNoise.clear_screen () else ()
-  | Bytecode _ -> () (* if !eval_clear then LNoise.clear_screen () else () *)
   | Emacs -> ()
 
 let rec user_input callback =
@@ -109,7 +106,7 @@ let sail_logo =
   in
   List.map banner logo @ [""] @ help @ [""]
 
-let vs_ids = ref (Initial_check.val_spec_ids !Interactive.ast)
+let vs_ids = ref (val_spec_ids !Interactive.ast)
 
 let interactive_state = ref (initial_state !Interactive.ast !Interactive.env Value.primops)
 
@@ -128,22 +125,6 @@ let print_program () =
   | Evaluation (Done (_, v)) ->
      print_endline (Value.string_of_value v |> Util.green |> Util.clear)
   | Evaluation _ -> ()
-  | Bytecode (_, stack) ->
-     let open Bytecode_interpreter in
-     let open Bytecode_util in
-     let pc = stack.top.pc in
-     let instrs = stack.top.instrs in
-     for i = 0 to stack.top.pc - 1 do
-       print_endline ("  " ^ Pretty_print_sail.to_string (pp_instr instrs.(i)))
-     done;
-     print_endline (">>  " ^ Pretty_print_sail.to_string (pp_instr instrs.(stack.top.pc)));
-     for i = stack.top.pc + 1 to Array.length instrs - 1 do
-       print_endline ("  " ^ Pretty_print_sail.to_string (pp_instr instrs.(i)))
-     done;
-     print_endline sep;
-     print_endline (Util.string_of_list ", "
-                     (fun (id, vl) -> Printf.sprintf "%s = %s" (string_of_id id) (string_of_value vl))
-                     (Bindings.bindings stack.top.locals))
 
 let rec run () =
   match !current_mode with
@@ -178,7 +159,6 @@ let rec run () =
           end;
           run ()
      end
-  | Bytecode _ -> ()
 
 let rec run_steps n =
   print_endline ("step " ^ string_of_int n);
@@ -215,7 +195,6 @@ let rec run_steps n =
           end;
           run_steps (n - 1)
      end
-  | Bytecode _ -> ()
 
 let help = function
   | ":t" | ":type" ->
@@ -398,16 +377,19 @@ let handle_input' input =
      | ":pretty" ->
         print_endline (Pretty_print_sail.to_string (Latex.defs !Interactive.ast))
      | ":compile" ->
+        (*
         let open PPrint in
         let open C_backend in
         let ast = Process_file.rewrite_ast_c !Interactive.env !Interactive.ast in
         let ast, env = Specialize.(specialize typ_ord_specialization ast !Interactive.env) in
         let ctx = initial_ctx env in
         interactive_bytecode := bytecode_ast ctx (List.map flatten_cdef) ast
+         *)
+        ()
      | ":ir" ->
         print_endline arg;
-        let open Bytecode in
-        let open Bytecode_util in
+        let open Jib in
+        let open Jib_util in
         let open PPrint in
         let is_cdef = function
           | CDEF_fundef (id, _, _, _) when Id.compare id (mk_id arg) = 0 -> true
@@ -443,7 +425,7 @@ let handle_input' input =
            Interactive.ast := append_ast !Interactive.ast ast;
            interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops;
            Interactive.env := env;
-           vs_ids := Initial_check.val_spec_ids !Interactive.ast
+           vs_ids := val_spec_ids !Interactive.ast
         | ":bin" ->
            begin
              let args = Util.split_on_char ' ' arg in
@@ -458,20 +440,10 @@ let handle_input' input =
            Interactive.ast := Ast.Defs [];
            Interactive.env := Type_check.initial_env;
            interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops;
-           vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+           vs_ids := 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 ->
@@ -495,7 +467,7 @@ let handle_input' input =
                Interactive.ast := append_ast !Interactive.ast ast;
                interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops;
                Interactive.env := env;
-               vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+               vs_ids := val_spec_ids !Interactive.ast;
                print_endline ("(message \"Checked " ^ arg ^ " done\")\n");
              with
              | Reporting.Fatal_error (Err_type (l, msg)) ->
@@ -505,7 +477,7 @@ let handle_input' input =
            Interactive.ast := Ast.Defs [];
            Interactive.env := Type_check.initial_env;
            interactive_state := initial_state !Interactive.ast !Interactive.env Value.primops;
-           vs_ids := Initial_check.val_spec_ids !Interactive.ast;
+           vs_ids := val_spec_ids !Interactive.ast;
            Initial_check.have_undefined_builtins := false;
            Process_file.clear_symbols ()
         | ":typeat" ->
@@ -586,18 +558,7 @@ let handle_input' input =
            end
         end
      end
-  | Bytecode (gstate, stack) ->
-     begin match input with
-     | Command (cmd, arg) ->
-        ()
-     | Expression str ->
-        print_endline "Evaluating IR, cannot evaluate expression"
-     | Empty ->
-        let gstate, stack = Bytecode_interpreter.step (gstate, stack) in
-        current_mode := Bytecode (gstate, stack);
-        print_program ()
-     end
-    
+
 let handle_input input =
   try handle_input' input with
   | Type_check.Type_error (env, l, err) ->
diff --git a/src/anf.ml b/src/jib/anf.ml
index 5db836e9..025138d0 100644
--- a/src/anf.ml
+++ b/src/jib/anf.ml
@@ -50,8 +50,8 @@
 
 open Ast
 open Ast_util
-open Bytecode
-open Bytecode_util
+open Jib
+open Jib_util
 open Type_check
 open PPrint
 
@@ -61,31 +61,6 @@ module Big_int = Nat_big_num
 (* 1. Conversion to A-normal form (ANF)                                   *)
 (**************************************************************************)
 
-(* The first step in compiling sail is converting the Sail expression
-   grammar into A-normal form. Essentially this converts expressions
-   such as f(g(x), h(y)) into something like:
-
-   let v0 = g(x) in let v1 = h(x) in f(v0, v1)
-
-   Essentially the arguments to every function must be trivial, and
-   complex expressions must be let bound to new variables, or used in
-   a block, assignment, or control flow statement (if, for, and
-   while/until loops). The aexp datatype represents these expressions,
-   while aval represents the trivial values.
-
-   The convention is that the type of an aexp is given by last
-   argument to a constructor. It is omitted where it is obvious - for
-   example all for loops have unit as their type. If some constituent
-   part of the aexp has an annotation, the it refers to the previous
-   argument, so in
-
-   AE_let (id, typ1, _, body, typ2)
-
-   typ1 is the type of the bound identifer, whereas typ2 is the type
-   of the whole let expression (and therefore also the body).
-
-   See Flanagan et al's 'The Essence of Compiling with Continuations'
-   *)
 type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l
 
 and 'a aexp_aux =
diff --git a/src/anf.mli b/src/jib/anf.mli
index 6b9c9b51..79fb35ca 100644
--- a/src/anf.mli
+++ b/src/jib/anf.mli
@@ -48,12 +48,38 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
+(** The A-normal form (ANF) grammar *)
+
 open Ast
 open Ast_util
-open Bytecode
+open Jib
 open Type_check
 
-(* The A-normal form (ANF) grammar *)
+(** The first step in compiling Sail is converting the Sail expression
+   grammar into A-normal form (ANF). Essentially this converts
+   expressions such as [f(g(x), h(y))] into something like:
+
+   [let v0 = g(x) in let v1 = h(x) in f(v0, v1)]
+
+   Essentially the arguments to every function must be trivial, and
+   complex expressions must be let bound to new variables, or used in
+   a block, assignment, or control flow statement (if, for, and
+   while/until loops). The aexp datatype represents these expressions,
+   while aval represents the trivial values.
+
+   The convention is that the type of an aexp is given by last
+   argument to a constructor. It is omitted where it is obvious - for
+   example all for loops have unit as their type. If some constituent
+   part of the aexp has an annotation, the it refers to the previous
+   argument, so in
+
+   [AE_let (id, typ1, _, body, typ2)]
+
+   [typ1] is the type of the bound identifer, whereas [typ2] is the type
+   of the whole let expression (and therefore also the body).
+
+   See Flanagan et al's {e The Essence of Compiling with Continuations}.
+   *)
 
 type 'a aexp = AE_aux of 'a aexp_aux * Env.t * l
 
@@ -88,6 +114,9 @@ and 'a apat_aux =
   | AP_nil of 'a
   | AP_wild of 'a
 
+(** We allow ANF->ANF optimization to insert fragments of C code
+   directly in the ANF grammar via [AV_C_fragment]. Such fragments
+   must be side-effect free expressions. *)
 and 'a aval =
   | AV_lit of lit * 'a
   | AV_id of id * 'a lvar
@@ -98,28 +127,35 @@ and 'a aval =
   | AV_record of ('a aval) Bindings.t * 'a
   | AV_C_fragment of fragment * 'a * ctyp
 
+(** Function for generating unique identifiers during ANF
+   translation. *)
 val gensym : unit -> id
 
-(* Functions for transforming ANF expressions *)
+(** {2 Functions for transforming ANF expressions} *)
 
+(** Map over all values in an ANF expression *)
 val map_aval : (Env.t -> Ast.l -> 'a aval -> 'a aval) -> 'a aexp -> 'a aexp
 
+(** Map over all function calls in an ANF expression *)
 val map_functions : (Env.t -> Ast.l -> id -> ('a aval) list -> 'a -> 'a aexp_aux) -> 'a aexp -> 'a aexp
 
+(** Remove all variable shadowing in an ANF expression *)
 val no_shadow : IdSet.t -> 'a aexp -> 'a aexp
 
 val apat_globals : 'a apat -> (id * 'a) list
-
 val apat_types : 'a apat -> 'a Bindings.t
 
+(** Returns true if an ANF expression is dead due to flow typing
+   implying it is unreachable. Note: This function calls SMT. *)
 val is_dead_aexp : 'a aexp -> bool
 
-(* Compiling to ANF expressions *)
+(** {2 Compiling to ANF expressions} *)
 
 val anf_pat : ?global:bool -> tannot pat -> typ apat
 
 val anf : tannot exp -> typ aexp
 
-(* Pretty printing ANF expressions *)
+(** {2 Pretty printing ANF expressions} *)
+
 val pp_aval : typ aval -> PPrint.document
 val pp_aexp : typ aexp -> PPrint.document
diff --git a/src/c_backend.ml b/src/jib/c_backend.ml
index ab388223..846b619f 100644
--- a/src/c_backend.ml
+++ b/src/jib/c_backend.ml
@@ -50,8 +50,9 @@
 
 open Ast
 open Ast_util
-open Bytecode
-open Bytecode_util
+open Jib
+open Jib_compile
+open Jib_util
 open Type_check
 open PPrint
 open Value2
@@ -62,10 +63,6 @@ module Big_int = Nat_big_num
 
 let c_verbosity = ref 0
 
-let opt_debug_flow_graphs = ref false
-let opt_debug_function = ref ""
-let opt_trace = ref false
-let opt_smt_trace = ref false
 let opt_static = ref false
 let opt_no_main = ref false
 let opt_memo_cache = ref false
@@ -108,49 +105,6 @@ let zencode_id = function
 let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1))
 let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1))
 
-(** The context type contains two type-checking
-   environments. ctx.local_env contains the closest typechecking
-   environment, usually from the expression we are compiling, whereas
-   ctx.tc_env is the global type checking environment from
-   type-checking the entire AST. We also keep track of local variables
-   in ctx.locals, so we know when their type changes due to flow
-   typing. *)
-type ctx =
-  { records : (ctyp Bindings.t) Bindings.t;
-    enums : IdSet.t Bindings.t;
-    variants : (ctyp Bindings.t) Bindings.t;
-    tc_env : Env.t;
-    local_env : Env.t;
-    locals : (mut * ctyp) Bindings.t;
-    letbinds : int list;
-    recursive_functions : IdSet.t;
-    no_raw : bool;
-    optimize_smt : bool;
-    iterate_size : bool;
-  }
-
-let initial_ctx env =
-  { records = Bindings.empty;
-    enums = Bindings.empty;
-    variants = Bindings.empty;
-    tc_env = env;
-    local_env = env;
-    locals = Bindings.empty;
-    letbinds = [];
-    recursive_functions = IdSet.empty;
-    no_raw = false;
-    optimize_smt = true;
-    iterate_size = false;
-  }
-
-let rec iterate_size ctx size n m =
-  if size > 64 then
-    CT_lint
-  else if prove __POS__ ctx.local_env (nc_and (nc_lteq (nconstant (min_int size)) n) (nc_lteq m (nconstant (max_int size)))) then
-    CT_fint size
-  else
-    iterate_size ctx (size + 1) n m
-
 (** Convert a sail type into a C-type. This function can be quite
    slow, because it uses ctx.local_env and SMT to analyse the Sail
    types and attempts to fit them into the smallest possible C
@@ -174,21 +128,16 @@ let rec ctyp_of_typ ctx typ =
      begin match destruct_range Env.empty typ with
      | None -> assert false (* Checked if range type in guard *)
      | Some (kids, constr, n, m) ->
+        let ctx = { ctx with local_env = add_existential Parse_ast.Unknown (List.map (mk_kopt K_int) kids) constr ctx.local_env } in
         match nexp_simp n, nexp_simp m with
         | Nexp_aux (Nexp_constant n, _), Nexp_aux (Nexp_constant m, _)
              when Big_int.less_equal (min_int 64) n && Big_int.less_equal m (max_int 64) ->
-           if ctx.iterate_size then
-             iterate_size ctx 2 (nconstant n) (nconstant m)
-           else
-             CT_fint 64
-        | n, m when ctx.optimize_smt ->
-           if ctx.iterate_size then
-             iterate_size ctx 2 n m
-           else if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then
+           CT_fint 64
+        | n, m ->
+           if prove __POS__ ctx.local_env (nc_lteq (nconstant (min_int 64)) n) && prove __POS__ ctx.local_env (nc_lteq m (nconstant (max_int 64))) then
              CT_fint 64
            else
              CT_lint
-        | _ -> CT_lint
      end
 
   | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" ->
@@ -205,7 +154,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_smt && prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits direction
+     | n when prove __POS__ ctx.local_env (nc_lteq n (nint 64)) -> CT_sbits (64, direction)
      | _ -> CT_lbits direction
      end
 
@@ -225,7 +174,7 @@ let rec ctyp_of_typ ctx typ =
 
   | Typ_tup typs -> CT_tup (List.map (ctyp_of_typ ctx) typs)
 
-  | Typ_exist _ when ctx.optimize_smt ->
+  | Typ_exist _ ->
      (* Use Type_check.destruct_exist when optimising with SMT, to
         ensure that we don't cause any type variable clashes in
         local_env, and that we can optimize the existential based upon
@@ -237,8 +186,6 @@ let rec ctyp_of_typ ctx typ =
      | None -> raise (Reporting.err_unreachable l __POS__ "Existential cannot be destructured!")
      end
 
-  | Typ_exist (_, _, typ) -> ctyp_of_typ ctx typ
-
   | Typ_var kid -> CT_poly
 
   | _ -> c_error ~loc:l ("No C type for type " ^ string_of_typ typ)
@@ -483,8 +430,50 @@ let analyze_primop' ctx id args typ =
      | _ -> no_change
      end
 
+  | "zero_extend", [AV_C_fragment (v1, _, CT_fbits _); _] ->
+     begin match destruct_vector ctx.tc_env typ with
+     | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _))
+          when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) ->
+        AE_val (AV_C_fragment (v1, typ, CT_fbits (Big_int.to_int n, true)))
+     | _ -> no_change
+     end
+
+  | "zero_extend", [AV_C_fragment (v1, _, CT_sbits _); _] ->
+     begin match destruct_vector ctx.tc_env typ with
+     | Some (Nexp_aux (Nexp_constant n, _), _, Typ_aux (Typ_id id, _))
+          when string_of_id id = "bit" && Big_int.less_equal n (Big_int.of_int 64) ->
+        AE_val (AV_C_fragment (F_call ("fast_zero_extend", [v1; v_int (Big_int.to_int n)]), typ, CT_fbits (Big_int.to_int n, true)))
+     | _ -> no_change
+     end
+
+  | "sign_extend", [AV_C_fragment (v1, _, CT_fbits (n, _)); _] ->
+     begin match destruct_vector ctx.tc_env typ with
+     | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _))
+          when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) ->
+        AE_val (AV_C_fragment (F_call ("fast_sign_extend", [v1; v_int n; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true)))
+     | _ -> no_change
+     end
+
+  | "sign_extend", [AV_C_fragment (v1, _, CT_sbits _); _] ->
+     begin match destruct_vector ctx.tc_env typ with
+     | Some (Nexp_aux (Nexp_constant m, _), _, Typ_aux (Typ_id id, _))
+          when string_of_id id = "bit" && Big_int.less_equal m (Big_int.of_int 64) ->
+        AE_val (AV_C_fragment (F_call ("fast_sign_extend2", [v1; v_int (Big_int.to_int m)]) , typ, CT_fbits (Big_int.to_int m, true)))
+     | _ -> no_change
+     end
+
+  | "add_bits", [AV_C_fragment (v1, _, CT_fbits (n, ord)); AV_C_fragment (v2, _, CT_fbits _)]
+       when n <= 63 ->
+     AE_val (AV_C_fragment (F_op (F_op (v1, "+", v2), "&", v_mask_lower n), typ, CT_fbits (n, ord)))
+
+  | "lteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] ->
+     AE_val (AV_C_fragment (F_op (v1, "<=", v2), typ, CT_bool))
   | "gteq", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] ->
      AE_val (AV_C_fragment (F_op (v1, ">=", v2), typ, CT_bool))
+  | "lt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] ->
+     AE_val (AV_C_fragment (F_op (v1, "<", v2), typ, CT_bool))
+  | "gt", [AV_C_fragment (v1, _, _); AV_C_fragment (v2, _, _)] ->
+     AE_val (AV_C_fragment (F_op (v1, ">", v2), typ, CT_bool))
 
   | "xor_bits", [AV_C_fragment (v1, _, (CT_fbits _ as ctyp)); AV_C_fragment (v2, _, CT_fbits _)] ->
      AE_val (AV_C_fragment (F_op (v1, "^", v2), typ, ctyp))
@@ -540,15 +529,15 @@ let analyze_primop' ctx id args typ =
        when ord1 = ord2 && n1 + n2 <= 64 ->
      AE_val (AV_C_fragment (F_op (F_op (vec1, "<<", v_int n2), "|", vec2), typ, CT_fbits (n1 + n2, ord1)))
 
-  | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))]
+  | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_fbits (n2, ord2))]
        when ord1 = ord2 && is_sbits_typ ctx typ ->
      AE_val (AV_C_fragment (F_call ("append_sf", [vec1; vec2; v_int n2]), typ, ctyp_of_typ ctx typ))
 
-  | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits ord2)]
+  | "append", [AV_C_fragment (vec1, _, CT_fbits (n1, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))]
        when ord1 = ord2 && is_sbits_typ ctx typ ->
      AE_val (AV_C_fragment (F_call ("append_fs", [vec1; v_int n1; vec2]), typ, ctyp_of_typ ctx typ))
 
-  | "append", [AV_C_fragment (vec1, _, CT_sbits ord1); AV_C_fragment (vec2, _, CT_sbits ord2)]
+  | "append", [AV_C_fragment (vec1, _, CT_sbits (64, ord1)); AV_C_fragment (vec2, _, CT_sbits (64, ord2))]
        when ord1 = ord2 && is_sbits_typ ctx typ ->
      AE_val (AV_C_fragment (F_call ("append_ss", [vec1; vec2]), typ, ctyp_of_typ ctx typ))
 
@@ -568,6 +557,14 @@ let analyze_primop' ctx id args typ =
      | _ -> no_change
      end
 
+  | "sail_signed", [AV_C_fragment (frag, vtyp, _)] ->
+     begin match destruct_vector ctx.tc_env vtyp with
+     | Some (Nexp_aux (Nexp_constant n, _), _, _)
+          when Big_int.less_equal n (Big_int.of_int 64) && is_stack_typ ctx typ ->
+        AE_val (AV_C_fragment (F_call ("fast_signed", [frag; v_int (Big_int.to_int n)]), typ, ctyp_of_typ ctx typ))
+     | _ -> no_change
+     end
+
   | "add_int", [AV_C_fragment (op1, _, _); AV_C_fragment (op2, _, _)] ->
      begin match destruct_range Env.empty typ with
      | None -> no_change
@@ -592,6 +589,12 @@ let analyze_primop' ctx id args typ =
      | _ -> no_change
      end
 
+  | "vector_update_subrange", [AV_C_fragment (xs, _, CT_fbits (n, true));
+                               AV_C_fragment (hi, _, CT_fint 64);
+                               AV_C_fragment (lo, _, CT_fint 64);
+                               AV_C_fragment (ys, _, CT_fbits (m, true))] ->
+     AE_val (AV_C_fragment (F_call ("fast_update_subrange", [xs; hi; lo; ys]), typ, CT_fbits (n, true)))
+
   | "undefined_bool", _ ->
      AE_val (AV_C_fragment (F_lit (V_bool false), typ, CT_bool))
 
@@ -609,867 +612,11 @@ let analyze_primop ctx id args typ =
   else
     no_change
 
-(**************************************************************************)
-(* 4. Conversion to low-level AST                                         *)
-(**************************************************************************)
-
-(** We now use a low-level AST (see language/bytecode.ott) that is
-   only slightly abstracted away from C. To be succint in comments we
-   usually refer to this as Sail IR or IR rather than low-level AST
-   repeatedly.
-
-   The general idea is ANF expressions are converted into lists of
-   instructions (type instr) where allocations and deallocations are
-   now made explicit. ANF values (aval) are mapped to the cval type,
-   which is even simpler still. Some things are still more abstract
-   than in C, so the type definitions follow the sail type definition
-   structure, just with typ (from ast.ml) replaced with
-   ctyp. Top-level declarations that have no meaning for the backend
-   are not included at this level.
-
-   The convention used here is that functions of the form compile_X
-   compile the type X into types in this AST, so compile_aval maps
-   avals into cvals. Note that the return types for these functions
-   are often quite complex, and they usually return some tuple
-   containing setup instructions (to allocate memory for the
-   expression), cleanup instructions (to deallocate that memory) and
-   possibly typing information about what has been translated. **)
-
-let ctype_def_ctyps = function
-  | CTD_enum _ -> []
-  | CTD_struct (_, fields) -> List.map snd fields
-  | CTD_variant (_, ctors) -> List.map snd ctors
-
-let cval_ctyp = function (_, ctyp) -> ctyp
-
-let rec clexp_ctyp = function
-  | CL_id (_, ctyp) -> ctyp
-  | CL_field (clexp, field) ->
-     begin match clexp_ctyp clexp with
-     | CT_struct (id, ctors) ->
-        begin
-          try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with
-          | Not_found -> c_error ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field)
-        end
-     | ctyp -> c_error ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp)
-     end
-  | CL_addr clexp ->
-     begin match clexp_ctyp clexp with
-     | CT_ref ctyp -> ctyp
-     | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp)
-     end
-  | CL_tuple (clexp, n) ->
-     begin match clexp_ctyp clexp with
-     | CT_tup typs ->
-        begin
-          try List.nth typs n with
-          | _ -> c_error "Tuple assignment index out of bounds"
-        end
-     | ctyp -> c_error ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp)
-     end
-  | CL_have_exception -> CT_bool
-  | CL_current_exception ctyp -> ctyp
-
-let cval_rename from_id to_id (frag, ctyp) = (frag_rename from_id to_id frag, ctyp)
-
-let rec instr_ctyps (I_aux (instr, aux)) =
-  match instr with
-  | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp -> [ctyp]
-  | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) -> [ctyp; cval_ctyp cval]
-  | I_if (cval, instrs1, instrs2, ctyp) ->
-     ctyp :: cval_ctyp cval :: List.concat (List.map instr_ctyps instrs1 @ List.map instr_ctyps instrs2)
-  | I_funcall (clexp, _, _, cvals) ->
-     clexp_ctyp clexp :: List.map cval_ctyp cvals
-  | I_copy (clexp, cval) | I_alias (clexp, cval) -> [clexp_ctyp clexp; cval_ctyp cval]
-  | I_block instrs | I_try_block instrs -> List.concat (List.map instr_ctyps instrs)
-  | I_throw cval | I_jump (cval, _) | I_return cval -> [cval_ctyp cval]
-  | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure -> []
-
-let rec c_ast_registers = function
-  | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast
-  | _ :: ast -> c_ast_registers ast
-  | [] -> []
-
-let cdef_ctyps ctx = function
-  | CDEF_reg_dec (_, ctyp, instrs) -> ctyp :: List.concat (List.map instr_ctyps instrs)
-  | CDEF_spec (_, ctyps, ctyp) -> ctyp :: ctyps
-  | CDEF_fundef (id, _, _, instrs) ->
-     let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in
-     let arg_typs, ret_typ = match fn_typ with
-       | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
-       | _ -> assert false
-     in
-     let arg_ctyps, ret_ctyp =
-       List.map (ctyp_of_typ ctx) arg_typs,
-       ctyp_of_typ { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } ret_typ
-     in
-     ret_ctyp :: arg_ctyps @ List.concat (List.map instr_ctyps instrs)
-
-  | CDEF_startup (id, instrs) | CDEF_finish (id, instrs) -> List.concat (List.map instr_ctyps instrs)
-  | CDEF_type tdef -> ctype_def_ctyps tdef
-  | CDEF_let (_, bindings, instrs) ->
-     List.map snd bindings
-     @ List.concat (List.map instr_ctyps instrs)
-
-let is_ct_enum = function
-  | CT_enum _ -> true
-  | _ -> false
-
-let is_ct_variant = function
-  | CT_variant _ -> true
-  | _ -> false
-
-let is_ct_tup = function
-  | CT_tup _ -> true
-  | _ -> false
-
-let is_ct_list = function
-  | CT_list _ -> true
-  | _ -> false
-
-let is_ct_vector = function
-  | CT_vector _ -> true
-  | _ -> false
-
-let is_ct_struct = function
-  | CT_struct _ -> true
-  | _ -> false
-
-let is_ct_ref = function
-  | CT_ref _ -> true
-  | _ -> false
-
-let rec chunkify n xs =
-  match Util.take n xs, Util.drop n xs with
-  | xs, [] -> [xs]
-  | xs, ys -> xs :: chunkify n ys
-
-let rec compile_aval l ctx = function
-  | AV_C_fragment (frag, typ, ctyp) ->
-     let ctyp' = ctyp_of_typ ctx typ in
-     if not (ctyp_equal ctyp ctyp' || ctx.iterate_size) then
-       raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp'));
-     [], (frag, ctyp_of_typ ctx typ), []
-
-  | AV_id (id, typ) ->
-     begin
-       try
-         let _, ctyp = Bindings.find id ctx.locals in
-         [], (F_id id, ctyp), []
-       with
-       | Not_found ->
-          [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), []
-     end
-
-  | AV_ref (id, typ) ->
-     [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), []
-
-  | AV_lit (L_aux (L_string str, _), typ) ->
-     [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), []
-
-  | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) ->
-     let gs = gensym () in
-     [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)],
-     (F_id gs, CT_lint),
-     [iclear CT_lint gs]
-
-  | AV_lit (L_aux (L_num n, _), typ) ->
-     let gs = gensym () in
-     [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)],
-     (F_id gs, CT_lint),
-     [iclear CT_lint gs]
-
-  | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), []
-  | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), []
-
-  | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), []
-  | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), []
-
-  | AV_lit (L_aux (L_real str, _), _) ->
-     let gs = gensym () in
-     [iinit CT_real gs (F_lit (V_string str), CT_string)],
-     (F_id gs, CT_real),
-     [iclear CT_real gs]
-
-  | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), []
-
-  | AV_lit (L_aux (_, l) as lit, _) ->
-     c_error ~loc:l ("Encountered unexpected literal " ^ string_of_lit lit)
-
-  | AV_tuple avals ->
-     let elements = List.map (compile_aval l ctx) avals in
-     let cvals = List.map (fun (_, cval, _) -> cval) elements in
-     let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in
-     let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in
-     let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in
-     let gs = gensym () in
-     setup
-     @ [idecl tup_ctyp gs]
-     @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals,
-     (F_id gs, CT_tup (List.map cval_ctyp cvals)),
-     [iclear tup_ctyp gs]
-     @ cleanup
-
-  | AV_record (fields, typ) ->
-     let ctyp = ctyp_of_typ ctx typ in
-     let gs = gensym () in
-     let compile_fields (id, aval) =
-       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
-       field_setup
-       @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval]
-       @ field_cleanup
-     in
-     [idecl ctyp gs]
-     @ List.concat (List.map compile_fields (Bindings.bindings fields)),
-     (F_id gs, ctyp),
-     [iclear ctyp gs]
-
-  | AV_vector ([], _) ->
-     c_error "Encountered empty vector literal"
-
-  (* Convert a small bitvector to a uint64_t literal. *)
-  | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 ->
-     begin
-       let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in
-       let len = List.length avals in
-       match destruct_vector ctx.tc_env typ with
-       | Some (_, Ord_aux (Ord_inc, _), _) ->
-          [], (bitstring, CT_fbits (len, false)), []
-       | Some (_, Ord_aux (Ord_dec, _), _) ->
-          [], (bitstring, CT_fbits (len, true)), []
-       | Some _ ->
-          c_error "Encountered order polymorphic bitvector literal"
-       | None ->
-          c_error "Encountered vector literal without vector type"
-     end
-
-  (* Convert a bitvector literal that is larger than 64-bits to a
-     variable size bitvector, converting it in 64-bit chunks. *)
-  | AV_vector (avals, typ) when is_bitvector avals ->
-     let len = List.length avals in
-     let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in
-     let first_chunk = bitstring (Util.take (len mod 64) avals) in
-     let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in
-     let gs = gensym () in
-     [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))]
-     @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true))
-                                       (mk_id "append_64")
-                                       [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks,
-     (F_id gs, CT_lbits true),
-     [iclear (CT_lbits true) gs]
-
-  (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *)
-  | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _))
-       when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 ->
-     let len = List.length avals in
-     let direction = match ord with
-       | Ord_aux (Ord_inc, _) -> false
-       | Ord_aux (Ord_dec, _) -> true
-       | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found"
-     in
-     let gs = gensym () in
-     let ctyp = CT_fbits (len, direction) in
-     let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in
-     let aval_mask i aval =
-       let setup, cval, cleanup = compile_aval l ctx aval in
-       match cval with
-       | (F_lit (V_bit Sail2_values.B0), _) -> []
-       | (F_lit (V_bit Sail2_values.B1), _) ->
-          [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)]
-       | _ ->
-          setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup
-     in
-     [idecl ctyp gs;
-      icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)]
-     @ List.concat (List.mapi aval_mask (List.rev avals)),
-     (F_id gs, ctyp),
-     []
-
-  (* Compiling a vector literal that isn't a bitvector *)
-  | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _))
-       when string_of_id id = "vector" ->
-     let len = List.length avals in
-     let direction = match ord with
-       | Ord_aux (Ord_inc, _) -> false
-       | Ord_aux (Ord_dec, _) -> true
-       | Ord_aux (Ord_var _, _) -> c_error "Polymorphic vector direction found"
-     in
-     let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in
-     let gs = gensym () in
-     let aval_set i aval =
-       let setup, cval, cleanup = compile_aval l ctx aval in
-       setup
-       @ [iextern (CL_id (gs, vector_ctyp))
-                  (mk_id "internal_vector_update")
-                  [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]]
-       @ cleanup
-     in
-     [idecl vector_ctyp gs;
-      iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]]
-     @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)),
-     (F_id gs, vector_ctyp),
-     [iclear vector_ctyp gs]
-
-  | AV_vector _ as aval ->
-     c_error ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type")
-
-  | AV_list (avals, Typ_aux (typ, _)) ->
-     let ctyp = match typ with
-       | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ
-       | _ -> c_error "Invalid list type"
-     in
-     let gs = gensym () in
-     let mk_cons aval =
-       let setup, cval, cleanup = compile_aval l ctx aval in
-       setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup
-     in
-     [idecl (CT_list ctyp) gs]
-     @ List.concat (List.map mk_cons (List.rev avals)),
-     (F_id gs, CT_list ctyp),
-     [iclear (CT_list ctyp) gs]
-
-let compile_funcall l ctx id args typ =
-  let setup = ref [] in
-  let cleanup = ref [] in
-
-  let quant, Typ_aux (fn_typ, _) =
-    try Env.get_val_spec id ctx.local_env
-    with Type_error _ ->
-      c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env
-  in
-  let arg_typs, ret_typ = match fn_typ with
-    | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
-    | _ -> assert false
-  in
-  let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in
-  let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in
-  let final_ctyp = ctyp_of_typ ctx typ in
-
-  let setup_arg ctyp aval =
-    let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in
-    setup := List.rev arg_setup @ !setup;
-    cleanup := arg_cleanup @ !cleanup;
-    let have_ctyp = cval_ctyp cval in
-    if is_polymorphic ctyp then
-      (F_poly (fst cval), have_ctyp)
-    else if ctyp_equal ctyp have_ctyp then
-      cval
-    else
-      let gs = gensym () in
-      setup := iinit ctyp gs cval :: !setup;
-      cleanup := iclear ctyp gs :: !cleanup;
-      (F_id gs, ctyp)
-  in
-
-  assert (List.length arg_ctyps = List.length args);
-
-  let setup_args = List.map2 setup_arg arg_ctyps args in
-
-  List.rev !setup,
-  begin fun clexp ->
-  if ctyp_equal (clexp_ctyp clexp) ret_ctyp then
-    ifuncall clexp id setup_args
-  else
-    let gs = gensym () in
-    iblock [idecl ret_ctyp gs;
-            ifuncall (CL_id (gs, ret_ctyp)) id setup_args;
-            icopy l clexp (F_id gs, ret_ctyp);
-            iclear ret_ctyp gs]
-  end,
-  !cleanup
-
-let rec apat_ctyp ctx (AP_aux (apat, _, _)) =
-  match apat with
-  | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats)
-  | AP_global (_, typ) -> ctyp_of_typ ctx typ
-  | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat)
-  | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ
-  | AP_app (_, _, typ) -> ctyp_of_typ ctx typ
-
-let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label =
-  let ctx = { ctx with local_env = env } in
-  match apat_aux, cval with
-  | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env ->
-     [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label],
-     [],
-     ctx
-
-  | AP_global (pid, typ), (frag, ctyp) ->
-     let global_ctyp = ctyp_of_typ ctx typ in
-     [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx
-
-  | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp ->
-     begin match Env.lookup_id pid ctx.tc_env with
-     | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx
-     | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx
-     end
-
-  | AP_id (pid, typ), _ ->
-     let ctyp = cval_ctyp cval in
-     let id_ctyp = ctyp_of_typ ctx typ in
-     c_debug (lazy ("Adding local " ^ string_of_id pid ^ " : " ^ string_of_ctyp id_ctyp));
-     let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in
-     [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx
-
-  | AP_tup apats, (frag, ctyp) ->
-     begin
-       let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in
-       let fold (instrs, cleanup, n, ctx) apat ctyp =
-         let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in
-         instrs @ instrs', cleanup' @ cleanup, n + 1, ctx
-       in
-       match ctyp with
-       | CT_tup ctyps ->
-          let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in
-          instrs, cleanup, ctx
-       | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp)
-     end
-
-  | AP_app (ctor, apat, variant_typ), (frag, ctyp) ->
-     begin match ctyp with
-     | CT_variant (_, ctors) ->
-        let ctor_c_id = string_of_id ctor in
-        let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in
-        (* These should really be the same, something has gone wrong if they are not. *)
-        if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then
-          c_error ~loc:l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ)))
-        else ();
-        let ctor_c_id, ctor_ctyp =
-          if is_polymorphic ctor_ctyp then
-            let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in
-            (if List.length unification > 0 then
-               ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification
-             else
-               ctor_c_id),
-            ctyp_suprema (apat_ctyp ctx apat)
-          else
-            ctor_c_id, ctor_ctyp
-        in
-        let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in
-        [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label]
-        @ instrs,
-        cleanup,
-        ctx
-     | ctyp ->
-        c_error ~loc:l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s"
-                                       (string_of_id ctor)
-                                       (string_of_typ variant_typ)
-                                       (string_of_fragment ~zencode:false frag)
-                                       (string_of_ctyp ctyp))
-     end
-
-  | AP_wild _, _ -> [], [], ctx
-
-  | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) ->
-     let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in
-     let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in
-     [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx
-
-  | AP_cons _, (_, _) -> c_error "Tried to pattern match cons on non list type"
-
-  | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx
-
-let unit_fragment = (F_lit V_unit, CT_unit)
-
-(** GLOBAL: label_counter is used to make sure all labels have unique
-   names. Like gensym_counter it should be safe to reset between
-   top-level definitions. **)
-let label_counter = ref 0
-
-let label str =
-  let str = str ^ string_of_int !label_counter in
-  incr label_counter;
-  str
-
-let pointer_assign ctyp1 ctyp2 =
-  match ctyp1 with
-  | CT_ref ctyp1 -> true
-  | _ -> false
-
-let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) =
-  let ctx = { ctx with local_env = env } in
-  match aexp_aux with
-  | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) ->
-     let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in
-     let setup, call, cleanup = compile_aexp ctx binding in
-     let letb_setup, letb_cleanup =
-       [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id]
-     in
-     let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in
-     let setup, call, cleanup = compile_aexp ctx body in
-     letb_setup @ setup, call, cleanup @ letb_cleanup
-
-  | AE_app (id, vs, typ) ->
-     compile_funcall l ctx id vs typ
-
-  | AE_val aval ->
-     let setup, cval, cleanup = compile_aval l ctx aval in
-     setup, (fun clexp -> icopy l clexp cval), cleanup
-
-  (* Compile case statements *)
-  | AE_case (aval, cases, typ) ->
-     let ctyp = ctyp_of_typ ctx typ in
-     let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in
-     let case_return_id = gensym () in
-     let finish_match_label = label "finish_match_" in
-     let compile_case (apat, guard, body) =
-       let trivial_guard = match guard with
-         | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _)
-           | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true
-         | _ -> false
-       in
-       let case_label = label "case_" in
-       c_debug (lazy ("Compiling match"));
-       let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in
-       c_debug (lazy ("Compiled match"));
-       let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in
-       let body_setup, body_call, body_cleanup = compile_aexp ctx body in
-       let gs = gensym () in
-       let case_instrs =
-         destructure @ [icomment "end destructuring"]
-         @ (if not trivial_guard then
-              guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup
-              @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit]
-              @ [icomment "end guard"]
-            else [])
-         @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup
-         @ [igoto finish_match_label]
-       in
-       if is_dead_aexp body then
-         [ilabel case_label]
-       else
-         [iblock case_instrs; ilabel case_label]
-     in
-     [icomment "begin match"]
-     @ aval_setup @ [idecl ctyp case_return_id]
-     @ List.concat (List.map compile_case cases)
-     @ [imatch_failure ()]
-     @ [ilabel finish_match_label],
-     (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)),
-     [iclear ctyp case_return_id]
-     @ aval_cleanup
-     @ [icomment "end match"]
-
-  (* Compile try statement *)
-  | AE_try (aexp, cases, typ) ->
-     let ctyp = ctyp_of_typ ctx typ in
-     let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in
-     let try_return_id = gensym () in
-     let handled_exception_label = label "handled_exception_" in
-     let fallthrough_label = label "fallthrough_exception_" in
-     let compile_case (apat, guard, body) =
-       let trivial_guard = match guard with
-         | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _)
-         | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true
-         | _ -> false
-       in
-       let try_label = label "try_" in
-       let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in
-       let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in
-       let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in
-       let body_setup, body_call, body_cleanup = compile_aexp ctx body in
-       let gs = gensym () in
-       let case_instrs =
-         destructure @ [icomment "end destructuring"]
-         @ (if not trivial_guard then
-              guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup
-              @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label]
-              @ [icomment "end guard"]
-            else [])
-         @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup
-         @ [igoto handled_exception_label]
-       in
-       [iblock case_instrs; ilabel try_label]
-     in
-     assert (ctyp_equal ctyp (ctyp_of_typ ctx typ));
-     [idecl ctyp try_return_id;
-      itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup);
-      ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label]
-     @ List.concat (List.map compile_case cases)
-     @ [igoto fallthrough_label;
-        ilabel handled_exception_label;
-        icopy l CL_have_exception (F_lit (V_bool false), CT_bool);
-        ilabel fallthrough_label],
-     (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)),
-     []
-
-  | AE_if (aval, then_aexp, else_aexp, if_typ) ->
-     if is_dead_aexp then_aexp then
-       compile_aexp ctx else_aexp
-     else if is_dead_aexp else_aexp then
-       compile_aexp ctx then_aexp
-     else
-       let if_ctyp = ctyp_of_typ ctx if_typ in
-       let compile_branch aexp =
-         let setup, call, cleanup = compile_aexp ctx aexp in
-         fun clexp -> setup @ [call clexp] @ cleanup
-       in
-       let setup, cval, cleanup = compile_aval l ctx aval in
-       setup,
-       (fun clexp -> iif cval
-                         (compile_branch then_aexp clexp)
-                         (compile_branch else_aexp clexp)
-                         if_ctyp),
-       cleanup
-
-  (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *)
-  | AE_record_update (aval, fields, typ) ->
-     let ctyp = ctyp_of_typ ctx typ in
-     let ctors = match ctyp with
-       | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors
-       | _ -> c_error "Cannot perform record update for non-record type"
-     in
-     let gs = gensym () in
-     let compile_fields (id, aval) =
-       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
-       field_setup
-       @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval]
-       @ field_cleanup
-     in
-     let setup, cval, cleanup = compile_aval l ctx aval in
-     [idecl ctyp gs]
-     @ setup
-     @ [icopy l (CL_id (gs, ctyp)) cval]
-     @ cleanup
-     @ List.concat (List.map compile_fields (Bindings.bindings fields)),
-     (fun clexp -> icopy l clexp (F_id gs, ctyp)),
-     [iclear ctyp gs]
-
-  | AE_short_circuit (SC_and, aval, aexp) ->
-     let left_setup, cval, left_cleanup = compile_aval l ctx aval in
-     let right_setup, call, right_cleanup = compile_aexp ctx aexp in
-     let gs = gensym () in
-     left_setup
-     @ [ idecl CT_bool gs;
-         iif cval
-             (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup)
-             [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)]
-             CT_bool ]
-     @ left_cleanup,
-     (fun clexp -> icopy l clexp (F_id gs, CT_bool)),
-     []
-  | AE_short_circuit (SC_or, aval, aexp) ->
-     let left_setup, cval, left_cleanup = compile_aval l ctx aval in
-     let right_setup, call, right_cleanup = compile_aexp ctx aexp in
-     let gs = gensym () in
-     left_setup
-     @ [ idecl CT_bool gs;
-         iif cval
-             [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)]
-             (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup)
-             CT_bool ]
-     @ left_cleanup,
-     (fun clexp -> icopy l clexp (F_id gs, CT_bool)),
-     []
-
-  (* This is a faster assignment rule for updating fields of a
-     struct. Turned on by !optimize_struct_updates. *)
-  | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _))
-       when Id.compare id rid = 0 && !optimize_struct_updates ->
-     c_debug (lazy ("Optimizing struct update"));
-     let compile_fields (field_id, aval) =
-       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
-       field_setup
-       @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval]
-       @ field_cleanup
-     in
-     List.concat (List.map compile_fields (Bindings.bindings fields)),
-     (fun clexp -> icopy l clexp unit_fragment),
-     []
-
-  | AE_assign (id, assign_typ, aexp) ->
-     let assign_ctyp =
-       match Bindings.find_opt id ctx.locals with
-       | Some (_, ctyp) -> ctyp
-       | None -> ctyp_of_typ ctx assign_typ
-     in
-     let setup, call, cleanup = compile_aexp ctx aexp in
-     setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup
-
-  | AE_block (aexps, aexp, _) ->
-     let block = compile_block ctx aexps in
-     let setup, call, cleanup = compile_aexp ctx aexp in
-     block @ setup, call, cleanup
-
-  | AE_loop (While, cond, body) ->
-     let loop_start_label = label "while_" in
-     let loop_end_label = label "wend_" in
-     let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in
-     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
-     let gs = gensym () in
-     let unit_gs = gensym () in
-     let loop_test = (F_unary ("!", F_id gs), CT_bool) in
-     [idecl CT_bool gs; idecl CT_unit unit_gs]
-     @ [ilabel loop_start_label]
-     @ [iblock (cond_setup
-                @ [cond_call (CL_id (gs, CT_bool))]
-                @ cond_cleanup
-                @ [ijump loop_test loop_end_label]
-                @ body_setup
-                @ [body_call (CL_id (unit_gs, CT_unit))]
-                @ body_cleanup
-                @ [igoto loop_start_label])]
-     @ [ilabel loop_end_label],
-     (fun clexp -> icopy l clexp unit_fragment),
-     []
-
-  | AE_loop (Until, cond, body) ->
-     let loop_start_label = label "repeat_" in
-     let loop_end_label = label "until_" in
-     let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in
-     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
-     let gs = gensym () in
-     let unit_gs = gensym () in
-     let loop_test = (F_id gs, CT_bool) in
-     [idecl CT_bool gs; idecl CT_unit unit_gs]
-     @ [ilabel loop_start_label]
-     @ [iblock (body_setup
-                @ [body_call (CL_id (unit_gs, CT_unit))]
-                @ body_cleanup
-                @ cond_setup
-                @ [cond_call (CL_id (gs, CT_bool))]
-                @ cond_cleanup
-                @ [ijump loop_test loop_end_label]
-                @ [igoto loop_start_label])]
-     @ [ilabel loop_end_label],
-     (fun clexp -> icopy l clexp unit_fragment),
-     []
-
-  | AE_cast (aexp, typ) -> compile_aexp ctx aexp
-
-  | AE_return (aval, typ) ->
-     let fn_return_ctyp = match Env.get_ret_typ env with
-       | Some typ -> ctyp_of_typ ctx typ
-       | None -> c_error ~loc:l "No function return type found when compiling return statement"
-     in
-     (* Cleanup info will be re-added by fix_early_return *)
-     let return_setup, cval, _ = compile_aval l ctx aval in
-     let creturn =
-       if ctyp_equal fn_return_ctyp (cval_ctyp cval) then
-         [ireturn cval]
-       else
-         let gs = gensym () in
-         [idecl fn_return_ctyp gs;
-          icopy l (CL_id (gs, fn_return_ctyp)) cval;
-          ireturn (F_id gs, fn_return_ctyp)]
-     in
-     return_setup @ creturn,
-     (fun clexp -> icomment "unreachable after return"),
-     []
-
-  | AE_throw (aval, typ) ->
-     (* Cleanup info will be handled by fix_exceptions *)
-     let throw_setup, cval, _ = compile_aval l ctx aval in
-     throw_setup @ [ithrow cval],
-     (fun clexp -> icomment "unreachable after throw"),
-     []
-
-  | AE_field (aval, id, typ) ->
-     let ctyp = ctyp_of_typ ctx typ in
-     let setup, cval, cleanup = compile_aval l ctx aval in
-     setup,
-     (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)),
-     cleanup
-
-  | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) ->
-     (* We assume that all loop indices are safe to put in a CT_fint. *)
-     let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in
-
-     let is_inc = match ord with
-       | Ord_inc -> true
-       | Ord_dec -> false
-       | Ord_var _ -> c_error "Polymorphic loop direction in C backend"
-     in
-
-     (* Loop variables *)
-     let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in
-     let from_gs = gensym () in
-     let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in
-     let to_gs = gensym () in
-     let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in
-     let step_gs = gensym () in
-     let variable_init gs setup call cleanup =
-       [idecl (CT_fint 64) gs;
-        iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)]
-     in
-
-     let loop_start_label = label "for_start_" in
-     let loop_end_label = label "for_end_" in
-     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
-     let body_gs = gensym () in
-
-     variable_init from_gs from_setup from_call from_cleanup
-     @ variable_init to_gs to_setup to_call to_cleanup
-     @ variable_init step_gs step_setup step_call step_cleanup
-     @ [iblock ([idecl (CT_fint 64) loop_var;
-                 icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64));
-                 idecl CT_unit body_gs;
-                 iblock ([ilabel loop_start_label]
-                         @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label]
-                         @ body_setup
-                         @ [body_call (CL_id (body_gs, CT_unit))]
-                         @ body_cleanup
-                         @ [icopy l (CL_id (loop_var, (CT_fint 64)))
-                                  (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))]
-                         @ [igoto loop_start_label]);
-                 ilabel loop_end_label])],
-     (fun clexp -> icopy l clexp unit_fragment),
-     []
-
-and compile_block ctx = function
-  | [] -> []
-  | exp :: exps ->
-     let setup, call, cleanup = compile_aexp ctx exp in
-     let rest = compile_block ctx exps in
-     let gs = gensym () in
-     iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest
-
-(** Compile a sail type definition into a IR one. Most of the
-   actual work of translating the typedefs into C is done by the code
-   generator, as it's easy to keep track of structs, tuples and unions
-   in their sail form at this level, and leave the fiddly details of
-   how they get mapped to C in the next stage. This function also adds
-   details of the types it compiles to the context, ctx, which is why
-   it returns a ctypdef * ctx pair. **)
-let compile_type_def ctx (TD_aux (type_def, _)) =
-  match type_def with
-  | TD_enum (id, ids, _) ->
-     CTD_enum (id, ids),
-     { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums }
-
-  | TD_record (id, _, ctors, _) ->
-     let ctors = List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ ctx typ) ctors) Bindings.empty ctors in
-     CTD_struct (id, Bindings.bindings ctors),
-     { ctx with records = Bindings.add id ctors ctx.records }
-
-  | TD_variant (id, typq, tus, _) ->
-     let compile_tu = function
-       | Tu_aux (Tu_ty_id (typ, id), _) ->
-          let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in
-          ctyp_of_typ ctx typ, id
-     in
-     let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in
-     CTD_variant (id, Bindings.bindings ctus),
-     { ctx with variants = Bindings.add id ctus ctx.variants }
-
-  (* Will be re-written before here, see bitfield.ml *)
-  | TD_bitfield _ -> failwith "Cannot compile TD_bitfield"
-  (* All type abbreviations are filtered out in compile_def  *)
-  | TD_abbrev _ -> assert false
-
-let instr_split_at f =
-  let rec instr_split_at' f before = function
-    | [] -> (List.rev before, [])
-    | instr :: instrs when f instr -> (List.rev before, instr :: instrs)
-    | instr :: instrs -> instr_split_at' f (instr :: before) instrs
-  in
-  instr_split_at' f []
-
 let generate_cleanup instrs =
   let generate_cleanup' (I_aux (instr, _)) =
     match instr with
-    | I_init (ctyp, id, cval) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)]
-    | I_decl (ctyp, id) when not (is_stack_ctyp ctyp) -> [(id, iclear ctyp id)]
+    | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)]
+    | I_decl (ctyp, id) -> [(id, iclear ctyp id)]
     | instr -> []
   in
   let is_clear ids = function
@@ -1492,365 +639,103 @@ let generate_cleanup instrs =
    flow to cleanup heap-allocated variables correctly when a function
    terminates early. See the generate_cleanup function for how this is
    done. *)
-let fix_early_return ret ctx instrs =
+let fix_early_heap_return ret ret_ctyp instrs =
   let end_function_label = label "end_function_" in
   let is_return_recur (I_aux (instr, _)) =
     match instr with
-    | I_return _ | I_if _ | I_block _ -> true
+    | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ | I_undefined _ -> true
     | _ -> false
   in
-  let rec rewrite_return historic instrs =
+  let rec rewrite_return instrs =
     match instr_split_at is_return_recur instrs with
     | instrs, [] -> instrs
     | before, I_aux (I_block instrs, _) :: after ->
        before
-       @ [iblock (rewrite_return (historic @ before) instrs)]
-       @ rewrite_return (historic @ before) after
+       @ [iblock (rewrite_return instrs)]
+       @ rewrite_return after
     | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after ->
-       let historic = historic @ before in
        before
-       @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp]
-       @ rewrite_return historic after
-    | before, I_aux (I_return cval, (_, l)) :: after ->
-       let cleanup_label = label "cleanup_" in
-       let end_cleanup_label = label "end_cleanup_" in
+       @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp]
+       @ rewrite_return after
+    | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after ->
+       before
+       @ [I_aux (I_funcall (CL_addr (CL_id (ret, CT_ref ctyp)), extern, fid, args), aux)]
+       @ rewrite_return after
+    | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after ->
+       before
+       @ [I_aux (I_copy (CL_addr (CL_id (ret, CT_ref ctyp)), cval), aux)]
+       @ rewrite_return after
+    | before, I_aux ((I_end | I_undefined _), _) :: after ->
        before
-       @ [icopy l ret cval;
-          igoto cleanup_label]
-       (* This is probably dead code until cleanup_label, but how can we be sure there are no jumps into it? *)
-       @ rewrite_return (historic @ before) after
-       @ [igoto end_cleanup_label]
-       @ [ilabel cleanup_label]
-       @ generate_cleanup (historic @ before)
        @ [igoto end_function_label]
-       @ [ilabel end_cleanup_label]
+       @ rewrite_return after
+    | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after ->
+       before @ instr :: rewrite_return after
     | _, _ -> assert false
   in
-  rewrite_return [] instrs
+  rewrite_return instrs
   @ [ilabel end_function_label]
 
 (* This is like fix_early_return, but for stack allocated returns. *)
-let fix_early_stack_return ctx instrs =
+let fix_early_stack_return ret ret_ctyp instrs =
   let is_return_recur (I_aux (instr, _)) =
     match instr with
-    | I_return _ | I_if _ | I_block _ -> true
+    | I_if _ | I_block _ | I_end | I_funcall _ | I_copy _ -> true
     | _ -> false
   in
-  let rec rewrite_return historic instrs =
+  let rec rewrite_return instrs =
     match instr_split_at is_return_recur instrs with
     | instrs, [] -> instrs
     | before, I_aux (I_block instrs, _) :: after ->
        before
-       @ [iblock (rewrite_return (historic @ before) instrs)]
-       @ rewrite_return (historic @ before) after
+       @ [iblock (rewrite_return instrs)]
+       @ rewrite_return after
     | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after ->
-       let historic = historic @ before in
        before
-       @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp]
-       @ rewrite_return historic after
-    | before, (I_aux (I_return cval, _) as ret) :: after ->
+       @ [iif cval (rewrite_return then_instrs) (rewrite_return else_instrs) ctyp]
+       @ rewrite_return after
+    | before, I_aux (I_funcall (CL_return ctyp, extern, fid, args), aux) :: after ->
        before
-       @ [icomment "early return cleanup"]
-       @ generate_cleanup (historic @ before)
-       @ [ret]
-       (* There could be jumps into here *)
-       @ rewrite_return (historic @ before) after
-    | _, _ -> assert false
-  in
-  rewrite_return [] instrs
-
-let fix_exception_block ?return:(return=None) ctx instrs =
-  let end_block_label = label "end_block_exception_" in
-  let is_exception_stop (I_aux (instr, _)) =
-    match instr with
-    | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true
-    | _ -> false
-  in
-  (* In this function 'after' is instructions after the one we've
-     matched on, 'before is instructions before the instruction we've
-     matched with, but after the previous match, and 'historic' are
-     all the befores from previous matches. *)
-  let rec rewrite_exception historic instrs =
-    match instr_split_at is_exception_stop instrs with
-    | instrs, [] -> instrs
-    | before, I_aux (I_block instrs, _) :: after ->
-       before
-       @ [iblock (rewrite_exception (historic @ before) instrs)]
-       @ rewrite_exception (historic @ before) after
-    | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after ->
-       let historic = historic @ before in
+       @ [I_aux (I_funcall (CL_id (ret, ctyp), extern, fid, args), aux)]
+       @ rewrite_return after
+    | before, I_aux (I_copy (CL_return ctyp, cval), aux) :: after ->
        before
-       @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp]
-       @ rewrite_exception historic after
-    | before, I_aux (I_throw cval, (_, l)) :: after ->
+       @ [I_aux (I_copy (CL_id (ret, ctyp), cval), aux)]
+       @ rewrite_return after
+    | before, I_aux (I_end, _) :: after ->
        before
-       @ [icopy l (CL_current_exception (cval_ctyp cval)) cval;
-          icopy l CL_have_exception (F_lit (V_bool true), CT_bool)]
-       @ generate_cleanup (historic @ before)
-       @ [igoto end_block_label]
-       @ rewrite_exception (historic @ before) after
-    | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after ->
-       let effects = match Env.get_val_spec f ctx.tc_env with
-         | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects
-         | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *)
-         | _ -> assert false (* valspec must have function type *)
-       in
-       if has_effect effects BE_escape then
-         before
-         @ [funcall;
-            iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit]
-         @ rewrite_exception (historic @ before) after
-       else
-         before @ funcall :: rewrite_exception (historic @ before) after
-    | _, _ -> assert false (* unreachable *)
-  in
-  match return with
-  | None ->
-     rewrite_exception [] instrs @ [ilabel end_block_label]
-  | Some ctyp ->
-     rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp]
-
-let rec map_try_block f (I_aux (instr, aux)) =
-  let instr = match instr with
-    | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr
-    | I_if (cval, instrs1, instrs2, ctyp) ->
-       I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp)
-    | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr
-    | I_block instrs -> I_block (List.map (map_try_block f) instrs)
-    | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs))
-    | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ -> instr
+       @ [ireturn (F_id ret, ret_ctyp)]
+       @ rewrite_return after
+    | before, (I_aux ((I_copy _ | I_funcall _), _) as instr) :: after ->
+       before @ instr :: rewrite_return after
+    | _, _ -> assert false
   in
-  I_aux (instr, aux)
-
-let fix_exception ?return:(return=None) ctx instrs =
-  let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in
-  fix_exception_block ~return:return ctx instrs
-
-let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp =
-  match p_aux with
-  | P_id id -> (id, ([], []))
-  | P_wild -> let gs = gensym () in (gs, ([], []))
-  | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], []))
-  | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp
-  | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp
-  | _ ->
-     let apat = anf_pat pat in
-     let gs = gensym () in
-     let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in
-     (gs, (destructure, cleanup))
+  rewrite_return instrs
 
-let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps =
-  match p_aux with
-  | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps
-  | P_tup pats when List.length pats = List.length ctyps ->
-     [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, []
-  | _ when List.length ctyps = 1 ->
-     [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], []
+let rec insert_heap_returns ret_ctyps = function
+  | (CDEF_spec (id, _, ret_ctyp) as cdef) :: cdefs ->
+     cdef :: insert_heap_returns (Bindings.add id ret_ctyp ret_ctyps) cdefs
 
-  | _ ->
-     let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in
-     let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in
-     destructure
-     @ [idecl (CT_tup ctyps) arg_id]
-     @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids,
-     List.map (fun (id, _) -> id, ([], [])) new_ids,
-     [iclear (CT_tup ctyps) arg_id]
-     @ cleanup
-
-let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs))
-
-let fix_destructure fail_label = function
-  | ([], cleanup) -> ([], cleanup)
-  | destructure, cleanup ->
-     let body_label = label "fundef_body_" in
-     (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup)
-
-let letdef_count = ref 0
-
-(** Compile a Sail toplevel definition into an IR definition **)
-let rec compile_def n total ctx def =
-  match def with
-  | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _))
-       when !opt_memo_cache ->
-     let digest =
-       def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string
-     in
-     let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in
-     let cached =
-       if Sys.file_exists cachefile then
-         let in_chan = open_in cachefile in
-         try
-           let compiled = Marshal.from_channel in_chan in
-           close_in in_chan;
-           Some (compiled, ctx)
-         with
-         | _ -> close_in in_chan; None
-       else
-         None
-     in
-     begin match cached with
-     | Some (compiled, ctx) ->
-        Util.progress "Compiling " (string_of_id id) n total;
-        compiled, ctx
+  | CDEF_fundef (id, None, args, body) :: cdefs ->
+     let gs = gensym () in
+     begin match Bindings.find_opt id ret_ctyps with
      | 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
+        raise (Reporting.err_general (id_loc id) ("Cannot find return type for function " ^ string_of_id id))
+     | Some ret_ctyp when not (is_stack_ctyp ret_ctyp) ->
+        CDEF_fundef (id, Some gs, args, fix_early_heap_return gs ret_ctyp body)
+        :: insert_heap_returns ret_ctyps cdefs
+     | Some ret_ctyp ->
+        CDEF_fundef (id, None, args, fix_early_stack_return gs ret_ctyp (idecl ret_ctyp gs :: body))
+        :: insert_heap_returns ret_ctyps cdefs
      end
 
-  | _ -> compile_def' n total ctx def
-
-and compile_def' n total ctx = function
-  | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) ->
-     [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx
-  | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) ->
-     let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in
-     let setup, call, cleanup = compile_aexp ctx aexp in
-     let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in
-     [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx
-
-  | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) ->
-     c_debug (lazy "Compiling VS");
-     let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in
-     let arg_typs, ret_typ = match fn_typ with
-       | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
-       | _ -> assert false
-     in
-     let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in
-     let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in
-     [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx
-
-  | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) ->
-     c_debug (lazy ("Compiling function " ^ string_of_id id));
-     Util.progress "Compiling " (string_of_id id) n total;
-
-     (* Find the function's type. *)
-     let quant, Typ_aux (fn_typ, _) =
-       try Env.get_val_spec id ctx.local_env
-       with Type_error _ ->
-         c_debug (lazy ("Falling back to global env for " ^ string_of_id id)); Env.get_val_spec id ctx.tc_env
-     in
-     let arg_typs, ret_typ = match fn_typ with
-       | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
-       | _ -> assert false
-     in
-
-     (* Handle the argument pattern. *)
-     let fundef_label = label "fundef_fail_" in
-     let orig_ctx = ctx in
-     (* The context must be updated before we call ctyp_of_typ on the argument types. *)
-     let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in
-
-     let arg_ctyps =  List.map (ctyp_of_typ ctx) arg_typs in
-     let ret_ctyp = ctyp_of_typ ctx ret_typ in
-
-     (* Optimize and compile the expression to ANF. *)
-     let aexp = no_shadow (pat_ids pat) (anf exp) in
-     c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp)));
-     let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in
-
-     if Id.compare (mk_id !opt_debug_function) id = 0 then
-       let header =
-         Printf.sprintf "Sail ANF for %s %s %s. (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id)
-                        (string_of_typquant quant)
-                        Util.(string_of_list ", " (fun typ -> string_of_typ typ |> yellow |> clear) arg_typs)
-                        Util.(string_of_typ ret_typ |> yellow |> clear)
-
-       in
-       prerr_endline (Util.header header (List.length arg_typs + 2));
-       prerr_endline (Pretty_print_sail.to_string (pp_aexp aexp))
-     else ();
-
-     (* Compile the function arguments as patterns. *)
-     let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in
-     let ctx =
-       (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *)
-       List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps
-     in
-
-     (* Optimize and compile the expression from ANF to C. *)
-     let aexp = no_shadow (pat_ids pat) (anf exp) in
-     c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp)));
-     let aexp = analyze_functions ctx analyze_primop (c_literals ctx aexp) in
-     c_debug (lazy (Pretty_print_sail.to_string (pp_aexp aexp)));
-     let setup, call, cleanup = compile_aexp ctx aexp in
-     c_debug (lazy "Compiled aexp");
-     let gs = gensym () in
-     let destructure, destructure_cleanup =
-       compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label
-     in
-
-     if is_stack_ctyp ret_ctyp then
-       let instrs = arg_setup @ destructure @ [idecl ret_ctyp gs] @ setup @ [call (CL_id (gs, ret_ctyp))] @ cleanup @ destructure_cleanup @ arg_cleanup @ [ireturn (F_id gs, ret_ctyp)] in
-       let instrs = fix_early_stack_return ctx instrs in
-       let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in
-       [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx
-     else
-       let instrs = arg_setup @ destructure @ setup @ [call (CL_addr (CL_id (gs, CT_ref ret_ctyp)))] @ cleanup @ destructure_cleanup @ arg_cleanup in
-       let instrs = fix_early_return (CL_addr (CL_id (gs, CT_ref ret_ctyp))) ctx instrs in
-       let instrs = fix_exception ctx instrs in
-       [CDEF_fundef (id, Some gs, List.map fst compiled_args, instrs)], orig_ctx
-
-  | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) ->
-     c_error ~loc:l "Encountered function with no clauses"
-  | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) ->
-     c_error ~loc:l "Encountered function with multiple clauses"
-
-  (* All abbreviations should expanded by the typechecker, so we don't
-     need to translate type abbreviations into C typedefs. *)
-  | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx
-
-  | DEF_type type_def ->
-     let tdef, ctx = compile_type_def ctx type_def in
-     [CDEF_type tdef], ctx
-
-  | DEF_val (LB_aux (LB_val (pat, exp), _)) ->
-     c_debug (lazy ("Compiling letbind " ^ string_of_pat pat));
-     let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in
-     let aexp = analyze_functions ctx analyze_primop (c_literals ctx (no_shadow IdSet.empty (anf exp))) in
-     let setup, call, cleanup = compile_aexp ctx aexp in
-     let apat = anf_pat ~global:true pat in
-     let gs = gensym () in
-     let end_label = label "let_end_" in
-     let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in
-     let gs_setup, gs_cleanup =
-       [idecl ctyp gs], [iclear ctyp gs]
-     in
-     let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in
-     let n = !letdef_count in
-     incr letdef_count;
-     let instrs =
-       gs_setup @ setup
-       @ [call (CL_id (gs, ctyp))]
-       @ cleanup
-       @ destructure
-       @ destructure_cleanup @ gs_cleanup
-       @ [ilabel end_label]
-     in
-     [CDEF_let (n, bindings, instrs)],
-     { ctx with letbinds = n :: ctx.letbinds }
+  | CDEF_fundef (id, gs, _, _) :: _ ->
+     raise (Reporting.err_unreachable (id_loc id) __POS__ "Found function with return already re-written in insert_heap_returns")
 
-  (* Only DEF_default that matters is default Order, but all order
-     polymorphism is specialised by this point. *)
-  | DEF_default _ -> [], ctx
-
-  (* Overloading resolved by type checker *)
-  | DEF_overload _ -> [], ctx
-
-  (* Only the parser and sail pretty printer care about this. *)
-  | DEF_fixity _ -> [], ctx
-
-  (* We just ignore any pragmas we don't want to deal with. *)
-  | DEF_pragma _ -> [], ctx
-
-  | DEF_internal_mutrec fundefs ->
-     let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in
-     List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs
+  | cdef :: cdefs ->
+     cdef :: insert_heap_returns ret_ctyps cdefs
 
-  | def ->
-     c_error ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def))
+  | [] -> []
 
 (** To keep things neat we use GCC's local labels extension to limit
    the scope of labels. We do this by iterating over all the blocks
@@ -1881,16 +766,6 @@ let add_local_labels instrs =
 (* 5. Optimizations                                                       *)
 (**************************************************************************)
 
-let rec clexp_rename from_id to_id =
-  let rename id = if Id.compare id from_id = 0 then to_id else id in
-  function
-  | CL_id (id, ctyp) -> CL_id (rename id, ctyp)
-  | CL_field (clexp, field) -> CL_field (clexp_rename from_id to_id clexp, field)
-  | CL_tuple (clexp, n) -> CL_tuple (clexp_rename from_id to_id clexp, n)
-  | CL_addr clexp -> CL_addr (clexp_rename from_id to_id clexp)
-  | CL_current_exception ctyp -> CL_current_exception ctyp
-  | CL_have_exception -> CL_have_exception
-
 let rec instrs_rename from_id to_id =
   let rename id = if Id.compare id from_id = 0 then to_id else id in
   let crename = cval_rename from_id to_id in
@@ -1914,7 +789,7 @@ let rec instrs_rename from_id to_id =
   | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs
   | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs
   | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs
-  | (I_aux ((I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs
+  | (I_aux ((I_comment _ | I_raw _ | I_end | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs
   | [] -> []
 
 let hoist_ctyp = function
@@ -1927,8 +802,8 @@ let hoist_id () =
   incr hoist_counter;
   id
 
-let hoist_allocations ctx = function
-  | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id ctx.recursive_functions ->
+let hoist_allocations recursive_functions = function
+  | CDEF_fundef (function_id, _, _, _) as cdef when IdSet.mem function_id recursive_functions ->
      c_debug (lazy (Printf.sprintf "skipping recursive function %s" (string_of_id function_id)));
      [cdef]
 
@@ -1973,49 +848,6 @@ let hoist_allocations ctx = function
 
   | cdef -> [cdef]
 
-let flat_counter = ref 0
-let flat_id () =
-  let id = mk_id ("local#" ^ string_of_int !flat_counter) in
-  incr flat_counter;
-  id
-
-let rec flatten_instrs = function
-  | I_aux (I_decl (ctyp, decl_id), aux) :: instrs ->
-     let fid = flat_id () in
-     I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs)
-
-  | I_aux ((I_block block | I_try_block block), _) :: instrs ->
-     flatten_instrs block @ flatten_instrs instrs
-
-  | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs ->
-     let then_label = label "then_" in
-     let endif_label = label "endif_" in
-     [ijump cval then_label]
-     @ flatten_instrs else_instrs
-     @ [igoto endif_label]
-     @ [ilabel then_label]
-     @ flatten_instrs then_instrs
-     @ [ilabel endif_label]
-     @ flatten_instrs instrs
-
-  | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs
-
-  | instr :: instrs -> instr :: flatten_instrs instrs
-  | [] -> []
-
-let flatten_cdef =
-  function
-  | CDEF_fundef (function_id, heap_return, args, body) ->
-     flat_counter := 0;
-     CDEF_fundef (function_id, heap_return, args, flatten_instrs body)
-
-  | CDEF_let (n, bindings, instrs) ->
-    flat_counter := 0;
-    CDEF_let (n, bindings, flatten_instrs instrs)
-
-  | cdef -> cdef
-
-
 let rec specialize_variants ctx prior =
   let unifications = ref (Bindings.empty) in
 
@@ -2159,7 +991,7 @@ let is_not_removed = function
     kill x;
 
     If found, we can remove the variable x, and directly modify y instead. *)
-let remove_alias ctx =
+let remove_alias =
   let pattern ctyp id =
     let alias = ref None in
     let rec scan ctyp id n instrs =
@@ -2228,7 +1060,6 @@ let remove_alias ctx =
      [CDEF_fundef (function_id, heap_return, args, opt body)]
   | cdef -> [cdef]
 
-
 (** This pass ensures that all variables created by I_decl have unique names *)
 let unique_names =
   let unique_counter = ref 0 in
@@ -2288,7 +1119,7 @@ let unique_names =
     kill y;
 
     If found we can replace y by x *)
-let combine_variables ctx =
+let combine_variables =
   let pattern ctyp id =
     let combine = ref None in
     let rec scan id n instrs =
@@ -2380,7 +1211,7 @@ let combine_variables ctx =
     to be 100% correct - so it's behind the -Oexperimental flag
     for now. Some benchmarking shows that this kind of optimization
     is very valuable however! *)
-let hoist_alias ctx =
+let hoist_alias =
   (* Must return true for a subset of the types hoist_ctyp would return true for. *)
   let is_struct = function
     | CT_struct _ -> true
@@ -2428,15 +1259,15 @@ let hoist_alias ctx =
 
 let concatMap f xs = List.concat (List.map f xs)
 
-let optimize ctx cdefs =
+let optimize recursive_functions cdefs =
   let nothing cdefs = cdefs in
   cdefs
   |> (if !optimize_alias then concatMap unique_names else nothing)
-  |> (if !optimize_alias then concatMap (remove_alias ctx) else nothing)
-  |> (if !optimize_alias then concatMap (combine_variables ctx) else nothing)
+  |> (if !optimize_alias then concatMap remove_alias else nothing)
+  |> (if !optimize_alias then concatMap combine_variables else nothing)
   (* We need the runtime to initialize hoisted allocations *)
-  |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations ctx) else nothing)
-  |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap (hoist_alias ctx) else nothing)
+  |> (if !optimize_hoist_allocations && not !opt_no_rts then concatMap (hoist_allocations recursive_functions) else nothing)
+  |> (if !optimize_hoist_allocations && !optimize_experimental then concatMap hoist_alias else nothing)
 
 (**************************************************************************)
 (* 6. Code generation                                                     *)
@@ -2495,7 +1326,7 @@ let sgen_cval_param (frag, ctyp) =
   match ctyp with
   | CT_lbits direction ->
      string_of_fragment frag ^ ", " ^ string_of_bool direction
-  | CT_sbits direction ->
+  | CT_sbits (_, direction) ->
      string_of_fragment frag ^ ", " ^ string_of_bool direction
   | CT_fbits (len, direction) ->
      string_of_fragment frag ^ ", UINT64_C(" ^ string_of_int len ^ ") , " ^ string_of_bool direction
@@ -2511,6 +1342,8 @@ let rec sgen_clexp = function
   | CL_addr clexp -> "(*(" ^ sgen_clexp clexp ^ "))"
   | CL_have_exception -> "have_exception"
   | CL_current_exception _ -> "current_exception"
+  | CL_return _ -> assert false
+  | CL_void -> assert false
 
 let rec sgen_clexp_pure = function
   | CL_id (id, _) -> sgen_id id
@@ -2519,6 +1352,8 @@ let rec sgen_clexp_pure = function
   | CL_addr clexp -> "(*(" ^ sgen_clexp_pure clexp ^ "))"
   | CL_have_exception -> "have_exception"
   | CL_current_exception _ -> "current_exception"
+  | CL_return _ -> assert false
+  | CL_void -> assert false
 
 (** Generate instructions to copy from a cval to a clexp. This will
    insert any needed type conversions from big integers to small
@@ -2740,6 +1575,8 @@ let rec codegen_instr fid ctx (I_aux (instr, (_, l))) =
   | I_raw str ->
      string ("  " ^ str)
 
+  | I_end -> assert false
+
   | I_match_failure ->
      string ("  sail_match_failure(\"" ^ String.escaped (string_of_id fid) ^ "\");")
 
@@ -3201,8 +2038,6 @@ let codegen_def' ctx = function
        string (Printf.sprintf "%svoid %s(%s%s *rop, %s);" static (sgen_function_id id) (extra_params ()) (sgen_ctyp ret_ctyp) (Util.string_of_list ", " sgen_ctyp arg_ctyps))
 
   | CDEF_fundef (id, ret_arg, args, instrs) as def ->
-     if !opt_debug_flow_graphs then make_dot id (instrs_graph instrs) else ();
-
      (* Extract type information about the function from the environment. *)
      let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in
      let arg_typs, ret_typ = match fn_typ with
@@ -3220,18 +2055,6 @@ let codegen_def' ctx = function
                                  ^ Util.string_of_list ", " string_of_ctyp arg_ctyps)
      else ();
 
-     (* If this function is set as opt_debug_function, then output its IR *)
-     if Id.compare (mk_id !opt_debug_function) id = 0 then
-       let header =
-         Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id)
-                        (Util.string_of_list ", " string_of_id args)
-                        (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps)
-                        Util.(string_of_ctyp ret_ctyp |> yellow |> clear)
-       in
-       prerr_endline (Util.header header (List.length arg_ctyps + 2));
-       prerr_endline (Pretty_print_sail.to_string (separate_map hardline pp_instr instrs))
-     else ();
-
      let instrs = add_local_labels instrs in
      let args = Util.string_of_list ", " (fun x -> x) (List.map2 (fun ctyp arg -> sgen_ctyp ctyp ^ " " ^ sgen_id arg) arg_ctyps args) in
      let function_header =
@@ -3323,7 +2146,7 @@ let codegen_ctg ctx = function
 (** When we generate code for a definition, we need to first generate
    any auxillary type definitions that are required. *)
 let codegen_def ctx def =
-  let ctyps = cdef_ctyps ctx def in
+  let ctyps = cdef_ctyps def |> CTSet.elements in
   (* We should have erased any polymorphism introduced by variants at this point! *)
   if List.exists is_polymorphic ctyps then
     let polymorphic_ctyps = List.filter is_polymorphic ctyps in
@@ -3356,71 +2179,6 @@ let sgen_finish = function
      Printf.sprintf "  finish_%s();" (sgen_id id)
   | _ -> assert false
 
-let instrument_tracing ctx =
-  let module StringSet = Set.Make(String) in
-  let traceable = StringSet.of_list ["fbits"; "sail_string"; "lbits"; "sail_int"; "unit"; "bool"] in
-  let rec instrument = function
-    | (I_aux (I_funcall (clexp, _, id, args), _) as instr) :: instrs ->
-       let trace_start =
-         iraw (Printf.sprintf "trace_start(\"%s\");" (String.escaped (string_of_id id)))
-       in
-       let trace_arg cval =
-         let ctyp_name = sgen_ctyp_name (cval_ctyp cval) in
-         if StringSet.mem ctyp_name traceable then
-           iraw (Printf.sprintf "trace_%s(%s);" ctyp_name (sgen_cval cval))
-         else
-           iraw "trace_unknown();"
-       in
-       let rec trace_args = function
-         | [] -> []
-         | [cval] -> [trace_arg cval]
-         | cval :: cvals ->
-            trace_arg cval :: iraw "trace_argsep();" :: trace_args cvals
-       in
-       let trace_end = iraw "trace_end();" in
-       let trace_ret = iraw "trace_unknown();"
-                            (*
-         let ctyp_name = sgen_ctyp_name ctyp in
-         if StringSet.mem ctyp_name traceable then
-           iraw (Printf.sprintf "trace_%s(%s);" (sgen_ctyp_name ctyp) (sgen_clexp_pure clexp))
-         else
-           iraw "trace_unknown();"
-                             *)
-       in
-       [trace_start]
-       @ trace_args args
-       @ [iraw "trace_argend();";
-          instr;
-          trace_end;
-          trace_ret;
-          iraw "trace_retend();"]
-       @ instrument instrs
-
-    | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (instrument block), aux) :: instrument instrs
-    | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (instrument block), aux) :: instrument instrs
-    | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs ->
-       I_aux (I_if (cval, instrument then_instrs, instrument else_instrs, ctyp), aux) :: instrument instrs
-
-    | instr :: instrs -> instr :: instrument instrs
-    | [] -> []
-  in
-  function
-  | CDEF_fundef (function_id, heap_return, args, body) ->
-     CDEF_fundef (function_id, heap_return, args, instrument body)
-  | cdef -> cdef
-
-let bytecode_ast ctx rewrites (Defs defs) =
-  let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in
-  let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in
-
-  let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in
-  let total = List.length defs in
-  let _, chunks, ctx =
-    List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs
-  in
-  let cdefs = List.concat (List.rev chunks) in
-  rewrites cdefs
-
 let rec get_recursive_functions (Defs defs) =
   match defs with
   | DEF_internal_mutrec fundefs :: defs ->
@@ -3448,114 +2206,25 @@ 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 jib_of_ast env ast =
+  let ctx =
+    initial_ctx
+      ~convert_typ:ctyp_of_typ
+      ~optimize_anf:(fun ctx aexp -> analyze_functions ctx analyze_primop (c_literals ctx aexp))
+      env
+  in
+  Jib_compile.compile_ast ctx ast
 
-let compile_ast ctx output_chan c_includes (Defs defs) =
+let compile_ast env output_chan c_includes ast =
   try
     c_debug (lazy (Util.log_line __MODULE__ __LINE__ "Identifying recursive functions"));
-    let recursive_functions = Spec_analysis.top_sort_defs (Defs defs) |> get_recursive_functions in
-    let ctx = { ctx with recursive_functions = recursive_functions } in
-    c_debug (lazy (Util.string_of_list ", " string_of_id (IdSet.elements recursive_functions)));
-
-    let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in
-    let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in
-    let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in
-
-    if !opt_memo_cache then
-      (try
-         if Sys.is_directory "_sbuild" then
-           ()
-         else
-           raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!")
-       with
-       | Sys_error _ -> Unix.mkdir "_sbuild" 0o775)
-    else ();
-
-    let total = List.length defs in
-    let _, chunks, ctx =
-      List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs
-    in
-    let cdefs = List.concat (List.rev chunks) in
-
-    let cdefs, ctx = specialize_variants ctx [] cdefs in
-    let cdefs = sort_ctype_defs cdefs in
-    let cdefs = optimize ctx cdefs in
-    let cdefs = if !opt_trace then List.map (instrument_tracing ctx) cdefs else cdefs in
+    let recursive_functions = Spec_analysis.top_sort_defs ast |> get_recursive_functions in
 
-    let cdefs = if !opt_smt_trace then List.map (fun cdef -> smt_trace ctx (flatten_cdef cdef)) cdefs else cdefs in
+    let cdefs, ctx = jib_of_ast env ast in
+    let cdefs = insert_heap_returns Bindings.empty cdefs in
+    let cdefs = optimize recursive_functions cdefs in
 
-    let docs = List.map (codegen_def ctx) cdefs in
+    let docs = separate_map (hardline ^^ hardline) (codegen_def ctx) cdefs in
 
     let preamble = separate hardline
                      ([ string "#include \"sail.h\"" ]
@@ -3641,7 +2310,7 @@ let compile_ast ctx output_chan c_includes (Defs defs) =
 
     let hlhl = hardline ^^ hardline in
 
-    Pretty_print_sail.to_string (preamble ^^ hlhl ^^ separate hlhl docs ^^ hlhl
+    Pretty_print_sail.to_string (preamble ^^ hlhl ^^ docs ^^ hlhl
                                  ^^ (if not !opt_no_rts then
                                        model_init ^^ hlhl
                                        ^^ model_fini ^^ hlhl
@@ -3651,4 +2320,5 @@ let compile_ast ctx output_chan c_includes (Defs defs) =
                                  ^^ model_main ^^ hardline)
     |> output_string output_chan
   with
-    Type_error (_, l, err) -> c_error ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err)
+  | Type_error (_, l, err) ->
+     c_error ~loc:l ("Unexpected type error when compiling to C:\n" ^ Type_error.string_of_type_error err)
diff --git a/src/c_backend.mli b/src/jib/c_backend.mli
index 3b26acdf..7314eb5a 100644
--- a/src/c_backend.mli
+++ b/src/jib/c_backend.mli
@@ -48,24 +48,11 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
-open Bytecode
+open Jib
 open Type_check
 
 (** Global compilation options *)
 
-(** Output a dataflow graph for each generated function in Graphviz
-   (dot) format. *)
-val opt_debug_flow_graphs : bool ref
-
-(** Print the ANF and IR representations of a specific function. *)
-val opt_debug_function : string ref
-
-(** Instrument generated code to output a trace. opt_smt_trace is WIP
-   but intended to enable generating traces suitable for concolic
-   execution with SMT. *)
-val opt_trace : bool ref
-val opt_smt_trace : bool ref
-
 (** Define generated functions as static *)
 val opt_static : bool ref
 
@@ -102,7 +89,7 @@ val opt_extra_arguments : string option ref
    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
+b   the Sail version. This cache can obviously become stale if the C
    backend changes - it'll load an old version compiled without said
    changes. *)
 val opt_memo_cache : bool ref
@@ -115,24 +102,8 @@ val optimize_struct_updates : bool ref
 val optimize_alias : bool ref
 val optimize_experimental : bool ref
 
-(** The compilation context. *)
-type ctx
-
-(** Create a context from a typechecking environment. This environment
-   should be the environment returned by typechecking the full AST. *)
-val initial_ctx : Env.t -> ctx
-
 (** Convert a typ to a IR ctyp *)
-val ctyp_of_typ : ctx -> Ast.typ -> ctyp
-
-
-val compile_aexp : ctx -> Ast.typ Anf.aexp -> instr list * (clexp -> instr) * instr list
-
-val compile_ast : ctx -> out_channel -> string list -> tannot Ast.defs -> unit
-
-val bytecode_ast : ctx -> (cdef list -> cdef list) -> tannot Ast.defs -> cdef list
-
-(** Rewriting steps for compiled ASTs *)
-val flatten_instrs : instr list -> instr list
+val ctyp_of_typ : Jib_compile.ctx -> Ast.typ -> ctyp
 
-val flatten_cdef : cdef -> cdef
+val jib_of_ast : Env.t -> tannot Ast.defs -> cdef list * Jib_compile.ctx
+val compile_ast : Env.t -> out_channel -> string list -> tannot Ast.defs -> unit
diff --git a/src/jib/jib_compile.ml b/src/jib/jib_compile.ml
new file mode 100644
index 00000000..27f833d8
--- /dev/null
+++ b/src/jib/jib_compile.ml
@@ -0,0 +1,1403 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Ast
+open Ast_util
+open Jib
+open Jib_util
+open Type_check
+open Value2
+
+open Anf
+
+let opt_debug_function = ref ""
+let opt_debug_flow_graphs = ref false
+let opt_memo_cache = ref false
+
+(**************************************************************************)
+(* 4. Conversion to low-level AST                                         *)
+(**************************************************************************)
+
+(** We now use a low-level AST called Jib (see language/bytecode.ott)
+   that is only slightly abstracted away from C. To be succint in
+   comments we usually refer to this as Sail IR or IR rather than
+   low-level AST repeatedly.
+
+   The general idea is ANF expressions are converted into lists of
+   instructions (type instr) where allocations and deallocations are
+   now made explicit. ANF values (aval) are mapped to the cval type,
+   which is even simpler still. Some things are still more abstract
+   than in C, so the type definitions follow the sail type definition
+   structure, just with typ (from ast.ml) replaced with
+   ctyp. Top-level declarations that have no meaning for the backend
+   are not included at this level.
+
+   The convention used here is that functions of the form compile_X
+   compile the type X into types in this AST, so compile_aval maps
+   avals into cvals. Note that the return types for these functions
+   are often quite complex, and they usually return some tuple
+   containing setup instructions (to allocate memory for the
+   expression), cleanup instructions (to deallocate that memory) and
+   possibly typing information about what has been translated. **)
+
+(* FIXME: This stage shouldn't care about this *)
+let max_int n = Big_int.pred (Big_int.pow_int_positive 2 (n - 1))
+let min_int n = Big_int.negate (Big_int.pow_int_positive 2 (n - 1))
+
+let rec is_bitvector = function
+  | [] -> true
+  | AV_lit (L_aux (L_zero, _), _) :: avals -> is_bitvector avals
+  | AV_lit (L_aux (L_one, _), _) :: avals -> is_bitvector avals
+  | _ :: _ -> false
+
+let rec value_of_aval_bit = function
+  | AV_lit (L_aux (L_zero, _), _) -> Sail2_values.B0
+  | AV_lit (L_aux (L_one, _), _) -> Sail2_values.B1
+  | _ -> assert false
+
+let is_ct_enum = function
+  | CT_enum _ -> true
+  | _ -> false
+
+let is_ct_variant = function
+  | CT_variant _ -> true
+  | _ -> false
+
+let is_ct_tup = function
+  | CT_tup _ -> true
+  | _ -> false
+
+let is_ct_list = function
+  | CT_list _ -> true
+  | _ -> false
+
+let is_ct_vector = function
+  | CT_vector _ -> true
+  | _ -> false
+
+let is_ct_struct = function
+  | CT_struct _ -> true
+  | _ -> false
+
+let is_ct_ref = function
+  | CT_ref _ -> true
+  | _ -> false
+
+let ctor_bindings = List.fold_left (fun map (id, ctyp) -> Bindings.add id ctyp map) Bindings.empty
+
+(** The context type contains two type-checking
+   environments. ctx.local_env contains the closest typechecking
+   environment, usually from the expression we are compiling, whereas
+   ctx.tc_env is the global type checking environment from
+   type-checking the entire AST. We also keep track of local variables
+   in ctx.locals, so we know when their type changes due to flow
+   typing. *)
+type ctx =
+  { records : (ctyp Bindings.t) Bindings.t;
+    enums : IdSet.t Bindings.t;
+    variants : (ctyp Bindings.t) Bindings.t;
+    tc_env : Env.t;
+    local_env : Env.t;
+    locals : (mut * ctyp) Bindings.t;
+    letbinds : int list;
+    no_raw : bool;
+    convert_typ : ctx -> typ -> ctyp;
+    optimize_anf : ctx -> typ aexp -> typ aexp
+  }
+
+let initial_ctx ~convert_typ:convert_typ ~optimize_anf:optimize_anf env =
+  { records = Bindings.empty;
+    enums = Bindings.empty;
+    variants = Bindings.empty;
+    tc_env = env;
+    local_env = env;
+    locals = Bindings.empty;
+    letbinds = [];
+    no_raw = false;
+    convert_typ = convert_typ;
+    optimize_anf = optimize_anf
+  }
+
+let ctyp_of_typ ctx typ = ctx.convert_typ ctx typ
+
+let rec chunkify n xs =
+  match Util.take n xs, Util.drop n xs with
+  | xs, [] -> [xs]
+  | xs, ys -> xs :: chunkify n ys
+
+let rec compile_aval l ctx = function
+  | AV_C_fragment (frag, typ, ctyp) ->
+     let ctyp' = ctyp_of_typ ctx typ in
+     if not (ctyp_equal ctyp ctyp') then
+       raise (Reporting.err_unreachable l __POS__ (string_of_ctyp ctyp ^ " != " ^ string_of_ctyp ctyp'));
+     [], (frag, ctyp_of_typ ctx typ), []
+
+  | AV_id (id, typ) ->
+     begin
+       try
+         let _, ctyp = Bindings.find id ctx.locals in
+         [], (F_id id, ctyp), []
+       with
+       | Not_found ->
+          [], (F_id id, ctyp_of_typ ctx (lvar_typ typ)), []
+     end
+
+  | AV_ref (id, typ) ->
+     [], (F_ref id, CT_ref (ctyp_of_typ ctx (lvar_typ typ))), []
+
+  | AV_lit (L_aux (L_string str, _), typ) ->
+     [], (F_lit (V_string (String.escaped str)), ctyp_of_typ ctx typ), []
+
+  | AV_lit (L_aux (L_num n, _), typ) when Big_int.less_equal (min_int 64) n && Big_int.less_equal n (max_int 64) ->
+     let gs = gensym () in
+     [iinit CT_lint gs (F_lit (V_int n), CT_fint 64)],
+     (F_id gs, CT_lint),
+     [iclear CT_lint gs]
+
+  | AV_lit (L_aux (L_num n, _), typ) ->
+     let gs = gensym () in
+     [iinit CT_lint gs (F_lit (V_string (Big_int.to_string n)), CT_string)],
+     (F_id gs, CT_lint),
+     [iclear CT_lint gs]
+
+  | AV_lit (L_aux (L_zero, _), _) -> [], (F_lit (V_bit Sail2_values.B0), CT_bit), []
+  | AV_lit (L_aux (L_one, _), _) -> [], (F_lit (V_bit Sail2_values.B1), CT_bit), []
+
+  | AV_lit (L_aux (L_true, _), _) -> [], (F_lit (V_bool true), CT_bool), []
+  | AV_lit (L_aux (L_false, _), _) -> [], (F_lit (V_bool false), CT_bool), []
+
+  | AV_lit (L_aux (L_real str, _), _) ->
+     let gs = gensym () in
+     [iinit CT_real gs (F_lit (V_string str), CT_string)],
+     (F_id gs, CT_real),
+     [iclear CT_real gs]
+
+  | AV_lit (L_aux (L_unit, _), _) -> [], (F_lit V_unit, CT_unit), []
+
+  | AV_lit (L_aux (_, l) as lit, _) ->
+     raise (Reporting.err_general l ("Encountered unexpected literal " ^ string_of_lit lit ^ " when converting ANF represention into IR"))
+
+  | AV_tuple avals ->
+     let elements = List.map (compile_aval l ctx) avals in
+     let cvals = List.map (fun (_, cval, _) -> cval) elements in
+     let setup = List.concat (List.map (fun (setup, _, _) -> setup) elements) in
+     let cleanup = List.concat (List.rev (List.map (fun (_, _, cleanup) -> cleanup) elements)) in
+     let tup_ctyp = CT_tup (List.map cval_ctyp cvals) in
+     let gs = gensym () in
+     setup
+     @ [idecl tup_ctyp gs]
+     @ List.mapi (fun n cval -> icopy l (CL_tuple (CL_id (gs, tup_ctyp), n)) cval) cvals,
+     (F_id gs, CT_tup (List.map cval_ctyp cvals)),
+     [iclear tup_ctyp gs]
+     @ cleanup
+
+  | AV_record (fields, typ) ->
+     let ctyp = ctyp_of_typ ctx typ in
+     let gs = gensym () in
+     let compile_fields (id, aval) =
+       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
+       field_setup
+       @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval]
+       @ field_cleanup
+     in
+     [idecl ctyp gs]
+     @ List.concat (List.map compile_fields (Bindings.bindings fields)),
+     (F_id gs, ctyp),
+     [iclear ctyp gs]
+
+  | AV_vector ([], _) ->
+     raise (Reporting.err_general l "Encountered empty vector literal")
+
+  (* Convert a small bitvector to a uint64_t literal. *)
+  | AV_vector (avals, typ) when is_bitvector avals && List.length avals <= 64 ->
+     begin
+       let bitstring = F_lit (V_bits (List.map value_of_aval_bit avals)) in
+       let len = List.length avals in
+       match destruct_vector ctx.tc_env typ with
+       | Some (_, Ord_aux (Ord_inc, _), _) ->
+          [], (bitstring, CT_fbits (len, false)), []
+       | Some (_, Ord_aux (Ord_dec, _), _) ->
+          [], (bitstring, CT_fbits (len, true)), []
+       | Some _ ->
+          raise (Reporting.err_general l "Encountered order polymorphic bitvector literal")
+       | None ->
+          raise (Reporting.err_general l "Encountered vector literal without vector type")
+     end
+
+  (* Convert a bitvector literal that is larger than 64-bits to a
+     variable size bitvector, converting it in 64-bit chunks. *)
+  | AV_vector (avals, typ) when is_bitvector avals ->
+     let len = List.length avals in
+     let bitstring avals = F_lit (V_bits (List.map value_of_aval_bit avals)) in
+     let first_chunk = bitstring (Util.take (len mod 64) avals) in
+     let chunks = Util.drop (len mod 64) avals |> chunkify 64 |> List.map bitstring in
+     let gs = gensym () in
+     [iinit (CT_lbits true) gs (first_chunk, CT_fbits (len mod 64, true))]
+     @ List.map (fun chunk -> ifuncall (CL_id (gs, CT_lbits true))
+                                       (mk_id "append_64")
+                                       [(F_id gs, CT_lbits true); (chunk, CT_fbits (64, true))]) chunks,
+     (F_id gs, CT_lbits true),
+     [iclear (CT_lbits true) gs]
+
+  (* If we have a bitvector value, that isn't a literal then we need to set bits individually. *)
+  | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ (Typ_aux (Typ_id bit_id, _)), _)]), _))
+       when string_of_id bit_id = "bit" && string_of_id id = "vector" && List.length avals <= 64 ->
+     let len = List.length avals in
+     let direction = match ord with
+       | Ord_aux (Ord_inc, _) -> false
+       | Ord_aux (Ord_dec, _) -> true
+       | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found")
+     in
+     let gs = gensym () in
+     let ctyp = CT_fbits (len, direction) in
+     let mask i = V_bits (Util.list_init (63 - i) (fun _ -> Sail2_values.B0) @ [Sail2_values.B1] @ Util.list_init i (fun _ -> Sail2_values.B0)) in
+     let aval_mask i aval =
+       let setup, cval, cleanup = compile_aval l ctx aval in
+       match cval with
+       | (F_lit (V_bit Sail2_values.B0), _) -> []
+       | (F_lit (V_bit Sail2_values.B1), _) ->
+          [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)]
+       | _ ->
+          setup @ [iif cval [icopy l (CL_id (gs, ctyp)) (F_op (F_id gs, "|", F_lit (mask i)), ctyp)] [] CT_unit] @ cleanup
+     in
+     [idecl ctyp gs;
+      icopy l (CL_id (gs, ctyp)) (F_lit (V_bits (Util.list_init 64 (fun _ -> Sail2_values.B0))), ctyp)]
+     @ List.concat (List.mapi aval_mask (List.rev avals)),
+     (F_id gs, ctyp),
+     []
+
+  (* Compiling a vector literal that isn't a bitvector *)
+  | AV_vector (avals, Typ_aux (Typ_app (id, [_; A_aux (A_order ord, _); A_aux (A_typ typ, _)]), _))
+       when string_of_id id = "vector" ->
+     let len = List.length avals in
+     let direction = match ord with
+       | Ord_aux (Ord_inc, _) -> false
+       | Ord_aux (Ord_dec, _) -> true
+       | Ord_aux (Ord_var _, _) -> raise (Reporting.err_general l "Polymorphic vector direction found")
+     in
+     let vector_ctyp = CT_vector (direction, ctyp_of_typ ctx typ) in
+     let gs = gensym () in
+     let aval_set i aval =
+       let setup, cval, cleanup = compile_aval l ctx aval in
+       setup
+       @ [iextern (CL_id (gs, vector_ctyp))
+                  (mk_id "internal_vector_update")
+                  [(F_id gs, vector_ctyp); (F_lit (V_int (Big_int.of_int i)), CT_fint 64); cval]]
+       @ cleanup
+     in
+     [idecl vector_ctyp gs;
+      iextern (CL_id (gs, vector_ctyp)) (mk_id "internal_vector_init") [(F_lit (V_int (Big_int.of_int len)), CT_fint 64)]]
+     @ List.concat (List.mapi aval_set (if direction then List.rev avals else avals)),
+     (F_id gs, vector_ctyp),
+     [iclear vector_ctyp gs]
+
+  | AV_vector _ as aval ->
+     raise (Reporting.err_general l ("Have AV_vector: " ^ Pretty_print_sail.to_string (pp_aval aval) ^ " which is not a vector type"))
+
+  | AV_list (avals, Typ_aux (typ, _)) ->
+     let ctyp = match typ with
+       | Typ_app (id, [A_aux (A_typ typ, _)]) when string_of_id id = "list" -> ctyp_of_typ ctx typ
+       | _ -> raise (Reporting.err_general l "Invalid list type")
+     in
+     let gs = gensym () in
+     let mk_cons aval =
+       let setup, cval, cleanup = compile_aval l ctx aval in
+       setup @ [ifuncall (CL_id (gs, CT_list ctyp)) (mk_id ("cons#" ^ string_of_ctyp ctyp)) [cval; (F_id gs, CT_list ctyp)]] @ cleanup
+     in
+     [idecl (CT_list ctyp) gs]
+     @ List.concat (List.map mk_cons (List.rev avals)),
+     (F_id gs, CT_list ctyp),
+     [iclear (CT_list ctyp) gs]
+
+let compile_funcall l ctx id args typ =
+  let setup = ref [] in
+  let cleanup = ref [] in
+
+  let quant, Typ_aux (fn_typ, _) =
+    (* If we can't find a function in local_env, fall back to the
+       global env - this happens when representing assertions, exit,
+       etc as functions in the IR. *)
+    try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env
+  in
+  let arg_typs, ret_typ = match fn_typ with
+    | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
+    | _ -> assert false
+  in
+  let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in
+  let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in
+  let final_ctyp = ctyp_of_typ ctx typ in
+
+  let setup_arg ctyp aval =
+    let arg_setup, cval, arg_cleanup = compile_aval l ctx aval in
+    setup := List.rev arg_setup @ !setup;
+    cleanup := arg_cleanup @ !cleanup;
+    let have_ctyp = cval_ctyp cval in
+    if is_polymorphic ctyp then
+      (F_poly (fst cval), have_ctyp)
+    else if ctyp_equal ctyp have_ctyp then
+      cval
+    else
+      let gs = gensym () in
+      setup := iinit ctyp gs cval :: !setup;
+      cleanup := iclear ctyp gs :: !cleanup;
+      (F_id gs, ctyp)
+  in
+
+  assert (List.length arg_ctyps = List.length args);
+
+  let setup_args = List.map2 setup_arg arg_ctyps args in
+
+  List.rev !setup,
+  begin fun clexp ->
+  if ctyp_equal (clexp_ctyp clexp) ret_ctyp then
+    ifuncall clexp id setup_args
+  else
+    let gs = gensym () in
+    iblock [idecl ret_ctyp gs;
+            ifuncall (CL_id (gs, ret_ctyp)) id setup_args;
+            icopy l clexp (F_id gs, ret_ctyp);
+            iclear ret_ctyp gs]
+  end,
+  !cleanup
+
+let rec apat_ctyp ctx (AP_aux (apat, _, _)) =
+  match apat with
+  | AP_tup apats -> CT_tup (List.map (apat_ctyp ctx) apats)
+  | AP_global (_, typ) -> ctyp_of_typ ctx typ
+  | AP_cons (apat, _) -> CT_list (apat_ctyp ctx apat)
+  | AP_wild typ | AP_nil typ | AP_id (_, typ) -> ctyp_of_typ ctx typ
+  | AP_app (_, _, typ) -> ctyp_of_typ ctx typ
+
+let rec compile_match ctx (AP_aux (apat_aux, env, l)) cval case_label =
+  let ctx = { ctx with local_env = env } in
+  match apat_aux, cval with
+  | AP_id (pid, _), (frag, ctyp) when Env.is_union_constructor pid ctx.tc_env ->
+     [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind (string_of_id pid))), CT_bool) case_label],
+     [],
+     ctx
+
+  | AP_global (pid, typ), (frag, ctyp) ->
+     let global_ctyp = ctyp_of_typ ctx typ in
+     [icopy l (CL_id (pid, global_ctyp)) cval], [], ctx
+
+  | AP_id (pid, _), (frag, ctyp) when is_ct_enum ctyp ->
+     begin match Env.lookup_id pid ctx.tc_env with
+     | Unbound -> [idecl ctyp pid; icopy l (CL_id (pid, ctyp)) (frag, ctyp)], [], ctx
+     | _ -> [ijump (F_op (F_id pid, "!=", frag), CT_bool) case_label], [], ctx
+     end
+
+  | AP_id (pid, typ), _ ->
+     let ctyp = cval_ctyp cval in
+     let id_ctyp = ctyp_of_typ ctx typ in
+     let ctx = { ctx with locals = Bindings.add pid (Immutable, id_ctyp) ctx.locals } in
+     [idecl id_ctyp pid; icopy l (CL_id (pid, id_ctyp)) cval], [iclear id_ctyp pid], ctx
+
+  | AP_tup apats, (frag, ctyp) ->
+     begin
+       let get_tup n ctyp = (F_field (frag, "ztup" ^ string_of_int n), ctyp) in
+       let fold (instrs, cleanup, n, ctx) apat ctyp =
+         let instrs', cleanup', ctx = compile_match ctx apat (get_tup n ctyp) case_label in
+         instrs @ instrs', cleanup' @ cleanup, n + 1, ctx
+       in
+       match ctyp with
+       | CT_tup ctyps ->
+          let instrs, cleanup, _, ctx = List.fold_left2 fold ([], [], 0, ctx) apats ctyps in
+          instrs, cleanup, ctx
+       | _ -> failwith ("AP_tup with ctyp " ^ string_of_ctyp ctyp)
+     end
+
+  | AP_app (ctor, apat, variant_typ), (frag, ctyp) ->
+     begin match ctyp with
+     | CT_variant (_, ctors) ->
+        let ctor_c_id = string_of_id ctor in
+        let ctor_ctyp = Bindings.find ctor (ctor_bindings ctors) in
+        (* These should really be the same, something has gone wrong if they are not. *)
+        if ctyp_equal ctor_ctyp (ctyp_of_typ ctx variant_typ) then
+          raise (Reporting.err_general l (Printf.sprintf "%s is not the same type as %s" (string_of_ctyp ctor_ctyp) (string_of_ctyp (ctyp_of_typ ctx variant_typ))))
+        else ();
+        let ctor_c_id, ctor_ctyp =
+          if is_polymorphic ctor_ctyp then
+            let unification = List.map ctyp_suprema (ctyp_unify ctor_ctyp (apat_ctyp ctx apat)) in
+            (if List.length unification > 0 then
+               ctor_c_id ^ "_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification
+             else
+               ctor_c_id),
+            ctyp_suprema (apat_ctyp ctx apat)
+          else
+            ctor_c_id, ctor_ctyp
+        in
+        let instrs, cleanup, ctx = compile_match ctx apat ((F_field (frag, Util.zencode_string ctor_c_id), ctor_ctyp)) case_label in
+        [ijump (F_op (F_field (frag, "kind"), "!=", F_lit (V_ctor_kind ctor_c_id)), CT_bool) case_label]
+        @ instrs,
+        cleanup,
+        ctx
+     | ctyp ->
+        raise (Reporting.err_general l (Printf.sprintf "Variant constructor %s : %s matching against non-variant type %s : %s"
+                                                       (string_of_id ctor)
+                                                       (string_of_typ variant_typ)
+                                                       (string_of_fragment ~zencode:false frag)
+                                                       (string_of_ctyp ctyp)))
+     end
+
+  | AP_wild _, _ -> [], [], ctx
+
+  | AP_cons (hd_apat, tl_apat), (frag, CT_list ctyp) ->
+     let hd_setup, hd_cleanup, ctx = compile_match ctx hd_apat (F_field (F_unary ("*", frag), "hd"), ctyp) case_label in
+     let tl_setup, tl_cleanup, ctx = compile_match ctx tl_apat (F_field (F_unary ("*", frag), "tl"), CT_list ctyp) case_label in
+     [ijump (F_op (frag, "==", F_lit V_null), CT_bool) case_label] @ hd_setup @ tl_setup, tl_cleanup @ hd_cleanup, ctx
+
+  | AP_cons _, (_, _) ->
+     raise (Reporting.err_general l "Tried to pattern match cons on non list type")
+
+  | AP_nil _, (frag, _) -> [ijump (F_op (frag, "!=", F_lit V_null), CT_bool) case_label], [], ctx
+
+let unit_fragment = (F_lit V_unit, CT_unit)
+
+let rec compile_aexp ctx (AE_aux (aexp_aux, env, l)) =
+  let ctx = { ctx with local_env = env } in
+  match aexp_aux with
+  | AE_let (mut, id, binding_typ, binding, (AE_aux (_, body_env, _) as body), body_typ) ->
+     let binding_ctyp = ctyp_of_typ { ctx with local_env = body_env } binding_typ in
+     let setup, call, cleanup = compile_aexp ctx binding in
+     let letb_setup, letb_cleanup =
+       [idecl binding_ctyp id; iblock (setup @ [call (CL_id (id, binding_ctyp))] @ cleanup)], [iclear binding_ctyp id]
+     in
+     let ctx = { ctx with locals = Bindings.add id (mut, binding_ctyp) ctx.locals } in
+     let setup, call, cleanup = compile_aexp ctx body in
+     letb_setup @ setup, call, cleanup @ letb_cleanup
+
+  | AE_app (id, vs, typ) ->
+     compile_funcall l ctx id vs typ
+
+  | AE_val aval ->
+     let setup, cval, cleanup = compile_aval l ctx aval in
+     setup, (fun clexp -> icopy l clexp cval), cleanup
+
+  (* Compile case statements *)
+  | AE_case (aval, cases, typ) ->
+     let ctyp = ctyp_of_typ ctx typ in
+     let aval_setup, cval, aval_cleanup = compile_aval l ctx aval in
+     let case_return_id = gensym () in
+     let finish_match_label = label "finish_match_" in
+     let compile_case (apat, guard, body) =
+       let trivial_guard = match guard with
+         | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _)
+           | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true
+         | _ -> false
+       in
+       let case_label = label "case_" in
+       let destructure, destructure_cleanup, ctx = compile_match ctx apat cval case_label in
+       let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in
+       let body_setup, body_call, body_cleanup = compile_aexp ctx body in
+       let gs = gensym () in
+       let case_instrs =
+         destructure @ [icomment "end destructuring"]
+         @ (if not trivial_guard then
+              guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup
+              @ [iif (F_unary ("!", F_id gs), CT_bool) (destructure_cleanup @ [igoto case_label]) [] CT_unit]
+              @ [icomment "end guard"]
+            else [])
+         @ body_setup @ [body_call (CL_id (case_return_id, ctyp))] @ body_cleanup @ destructure_cleanup
+         @ [igoto finish_match_label]
+       in
+       if is_dead_aexp body then
+         [ilabel case_label]
+       else
+         [iblock case_instrs; ilabel case_label]
+     in
+     [icomment "begin match"]
+     @ aval_setup @ [idecl ctyp case_return_id]
+     @ List.concat (List.map compile_case cases)
+     @ [imatch_failure ()]
+     @ [ilabel finish_match_label],
+     (fun clexp -> icopy l clexp (F_id case_return_id, ctyp)),
+     [iclear ctyp case_return_id]
+     @ aval_cleanup
+     @ [icomment "end match"]
+
+  (* Compile try statement *)
+  | AE_try (aexp, cases, typ) ->
+     let ctyp = ctyp_of_typ ctx typ in
+     let aexp_setup, aexp_call, aexp_cleanup = compile_aexp ctx aexp in
+     let try_return_id = gensym () in
+     let handled_exception_label = label "handled_exception_" in
+     let fallthrough_label = label "fallthrough_exception_" in
+     let compile_case (apat, guard, body) =
+       let trivial_guard = match guard with
+         | AE_aux (AE_val (AV_lit (L_aux (L_true, _), _)), _, _)
+         | AE_aux (AE_val (AV_C_fragment (F_lit (V_bool true), _, _)), _, _) -> true
+         | _ -> false
+       in
+       let try_label = label "try_" in
+       let exn_cval = (F_current_exception, ctyp_of_typ ctx (mk_typ (Typ_id (mk_id "exception")))) in
+       let destructure, destructure_cleanup, ctx = compile_match ctx apat exn_cval try_label in
+       let guard_setup, guard_call, guard_cleanup = compile_aexp ctx guard in
+       let body_setup, body_call, body_cleanup = compile_aexp ctx body in
+       let gs = gensym () in
+       let case_instrs =
+         destructure @ [icomment "end destructuring"]
+         @ (if not trivial_guard then
+              guard_setup @ [idecl CT_bool gs; guard_call (CL_id (gs, CT_bool))] @ guard_cleanup
+              @ [ijump (F_unary ("!", F_id gs), CT_bool) try_label]
+              @ [icomment "end guard"]
+            else [])
+         @ body_setup @ [body_call (CL_id (try_return_id, ctyp))] @ body_cleanup @ destructure_cleanup
+         @ [igoto handled_exception_label]
+       in
+       [iblock case_instrs; ilabel try_label]
+     in
+     assert (ctyp_equal ctyp (ctyp_of_typ ctx typ));
+     [idecl ctyp try_return_id;
+      itry_block (aexp_setup @ [aexp_call (CL_id (try_return_id, ctyp))] @ aexp_cleanup);
+      ijump (F_unary ("!", F_have_exception), CT_bool) handled_exception_label]
+     @ List.concat (List.map compile_case cases)
+     @ [igoto fallthrough_label;
+        ilabel handled_exception_label;
+        icopy l CL_have_exception (F_lit (V_bool false), CT_bool);
+        ilabel fallthrough_label],
+     (fun clexp -> icopy l clexp (F_id try_return_id, ctyp)),
+     []
+
+  | AE_if (aval, then_aexp, else_aexp, if_typ) ->
+     if is_dead_aexp then_aexp then
+       compile_aexp ctx else_aexp
+     else if is_dead_aexp else_aexp then
+       compile_aexp ctx then_aexp
+     else
+       let if_ctyp = ctyp_of_typ ctx if_typ in
+       let compile_branch aexp =
+         let setup, call, cleanup = compile_aexp ctx aexp in
+         fun clexp -> setup @ [call clexp] @ cleanup
+       in
+       let setup, cval, cleanup = compile_aval l ctx aval in
+       setup,
+       (fun clexp -> iif cval
+                         (compile_branch then_aexp clexp)
+                         (compile_branch else_aexp clexp)
+                         if_ctyp),
+       cleanup
+
+  (* FIXME: AE_record_update could be AV_record_update - would reduce some copying. *)
+  | AE_record_update (aval, fields, typ) ->
+     let ctyp = ctyp_of_typ ctx typ in
+     let ctors = match ctyp with
+       | CT_struct (_, ctors) -> List.fold_left (fun m (k, v) -> Bindings.add k v m) Bindings.empty ctors
+       | _ -> raise (Reporting.err_general l "Cannot perform record update for non-record type")
+     in
+     let gs = gensym () in
+     let compile_fields (id, aval) =
+       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
+       field_setup
+       @ [icopy l (CL_field (CL_id (gs, ctyp), string_of_id id)) cval]
+       @ field_cleanup
+     in
+     let setup, cval, cleanup = compile_aval l ctx aval in
+     [idecl ctyp gs]
+     @ setup
+     @ [icopy l (CL_id (gs, ctyp)) cval]
+     @ cleanup
+     @ List.concat (List.map compile_fields (Bindings.bindings fields)),
+     (fun clexp -> icopy l clexp (F_id gs, ctyp)),
+     [iclear ctyp gs]
+
+  | AE_short_circuit (SC_and, aval, aexp) ->
+     let left_setup, cval, left_cleanup = compile_aval l ctx aval in
+     let right_setup, call, right_cleanup = compile_aexp ctx aexp in
+     let gs = gensym () in
+     left_setup
+     @ [ idecl CT_bool gs;
+         iif cval
+             (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup)
+             [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool false), CT_bool)]
+             CT_bool ]
+     @ left_cleanup,
+     (fun clexp -> icopy l clexp (F_id gs, CT_bool)),
+     []
+  | AE_short_circuit (SC_or, aval, aexp) ->
+     let left_setup, cval, left_cleanup = compile_aval l ctx aval in
+     let right_setup, call, right_cleanup = compile_aexp ctx aexp in
+     let gs = gensym () in
+     left_setup
+     @ [ idecl CT_bool gs;
+         iif cval
+             [icopy l (CL_id (gs, CT_bool)) (F_lit (V_bool true), CT_bool)]
+             (right_setup @ [call (CL_id (gs, CT_bool))] @ right_cleanup)
+             CT_bool ]
+     @ left_cleanup,
+     (fun clexp -> icopy l clexp (F_id gs, CT_bool)),
+     []
+
+  (* This is a faster assignment rule for updating fields of a
+     struct. *)
+  | AE_assign (id, assign_typ, AE_aux (AE_record_update (AV_id (rid, _), fields, typ), _, _))
+       when Id.compare id rid = 0 ->
+     let compile_fields (field_id, aval) =
+       let field_setup, cval, field_cleanup = compile_aval l ctx aval in
+       field_setup
+       @ [icopy l (CL_field (CL_id (id, ctyp_of_typ ctx typ), string_of_id field_id)) cval]
+       @ field_cleanup
+     in
+     List.concat (List.map compile_fields (Bindings.bindings fields)),
+     (fun clexp -> icopy l clexp unit_fragment),
+     []
+
+  | AE_assign (id, assign_typ, aexp) ->
+     let assign_ctyp =
+       match Bindings.find_opt id ctx.locals with
+       | Some (_, ctyp) -> ctyp
+       | None -> ctyp_of_typ ctx assign_typ
+     in
+     let setup, call, cleanup = compile_aexp ctx aexp in
+     setup @ [call (CL_id (id, assign_ctyp))], (fun clexp -> icopy l clexp unit_fragment), cleanup
+
+  | AE_block (aexps, aexp, _) ->
+     let block = compile_block ctx aexps in
+     let setup, call, cleanup = compile_aexp ctx aexp in
+     block @ setup, call, cleanup
+
+  | AE_loop (While, cond, body) ->
+     let loop_start_label = label "while_" in
+     let loop_end_label = label "wend_" in
+     let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in
+     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
+     let gs = gensym () in
+     let unit_gs = gensym () in
+     let loop_test = (F_unary ("!", F_id gs), CT_bool) in
+     [idecl CT_bool gs; idecl CT_unit unit_gs]
+     @ [ilabel loop_start_label]
+     @ [iblock (cond_setup
+                @ [cond_call (CL_id (gs, CT_bool))]
+                @ cond_cleanup
+                @ [ijump loop_test loop_end_label]
+                @ body_setup
+                @ [body_call (CL_id (unit_gs, CT_unit))]
+                @ body_cleanup
+                @ [igoto loop_start_label])]
+     @ [ilabel loop_end_label],
+     (fun clexp -> icopy l clexp unit_fragment),
+     []
+
+  | AE_loop (Until, cond, body) ->
+     let loop_start_label = label "repeat_" in
+     let loop_end_label = label "until_" in
+     let cond_setup, cond_call, cond_cleanup = compile_aexp ctx cond in
+     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
+     let gs = gensym () in
+     let unit_gs = gensym () in
+     let loop_test = (F_id gs, CT_bool) in
+     [idecl CT_bool gs; idecl CT_unit unit_gs]
+     @ [ilabel loop_start_label]
+     @ [iblock (body_setup
+                @ [body_call (CL_id (unit_gs, CT_unit))]
+                @ body_cleanup
+                @ cond_setup
+                @ [cond_call (CL_id (gs, CT_bool))]
+                @ cond_cleanup
+                @ [ijump loop_test loop_end_label]
+                @ [igoto loop_start_label])]
+     @ [ilabel loop_end_label],
+     (fun clexp -> icopy l clexp unit_fragment),
+     []
+
+  | AE_cast (aexp, typ) -> compile_aexp ctx aexp
+
+  | AE_return (aval, typ) ->
+     let fn_return_ctyp = match Env.get_ret_typ env with
+       | Some typ -> ctyp_of_typ ctx typ
+       | None -> raise (Reporting.err_general l "No function return type found when compiling return statement")
+     in
+     (* Cleanup info will be re-added by fix_early_(heap/stack)_return *)
+     let return_setup, cval, _ = compile_aval l ctx aval in
+     let creturn =
+       if ctyp_equal fn_return_ctyp (cval_ctyp cval) then
+         [ireturn cval]
+       else
+         let gs = gensym () in
+         [idecl fn_return_ctyp gs;
+          icopy l (CL_id (gs, fn_return_ctyp)) cval;
+          ireturn (F_id gs, fn_return_ctyp)]
+     in
+     return_setup @ creturn,
+     (fun clexp -> icomment "unreachable after return"),
+     []
+
+  | AE_throw (aval, typ) ->
+     (* Cleanup info will be handled by fix_exceptions *)
+     let throw_setup, cval, _ = compile_aval l ctx aval in
+     throw_setup @ [ithrow cval],
+     (fun clexp -> icomment "unreachable after throw"),
+     []
+
+  | AE_field (aval, id, _) ->
+     let setup, cval, cleanup = compile_aval l ctx aval in
+     let ctyp = match cval_ctyp cval with
+       | CT_struct (struct_id, fields) ->
+          begin match Util.assoc_compare_opt Id.compare id fields with
+          | Some ctyp -> ctyp
+          | None ->
+             raise (Reporting.err_unreachable l __POS__
+                      ("Struct " ^ string_of_id struct_id ^ " does not have expected field " ^ string_of_id id ^ "?"))
+          end
+       | _ ->
+          raise (Reporting.err_unreachable l __POS__ "Field access on non-struct type in ANF representation!")
+     in
+     setup,
+     (fun clexp -> icopy l clexp (F_field (fst cval, Util.zencode_string (string_of_id id)), ctyp)),
+     cleanup
+
+  | AE_for (loop_var, loop_from, loop_to, loop_step, Ord_aux (ord, _), body) ->
+     (* We assume that all loop indices are safe to put in a CT_fint. *)
+     let ctx = { ctx with locals = Bindings.add loop_var (Immutable, CT_fint 64) ctx.locals } in
+
+     let is_inc = match ord with
+       | Ord_inc -> true
+       | Ord_dec -> false
+       | Ord_var _ -> raise (Reporting.err_general l "Polymorphic loop direction in C backend")
+     in
+
+     (* Loop variables *)
+     let from_setup, from_call, from_cleanup = compile_aexp ctx loop_from in
+     let from_gs = gensym () in
+     let to_setup, to_call, to_cleanup = compile_aexp ctx loop_to in
+     let to_gs = gensym () in
+     let step_setup, step_call, step_cleanup = compile_aexp ctx loop_step in
+     let step_gs = gensym () in
+     let variable_init gs setup call cleanup =
+       [idecl (CT_fint 64) gs;
+        iblock (setup @ [call (CL_id (gs, CT_fint 64))] @ cleanup)]
+     in
+
+     let loop_start_label = label "for_start_" in
+     let loop_end_label = label "for_end_" in
+     let body_setup, body_call, body_cleanup = compile_aexp ctx body in
+     let body_gs = gensym () in
+
+     variable_init from_gs from_setup from_call from_cleanup
+     @ variable_init to_gs to_setup to_call to_cleanup
+     @ variable_init step_gs step_setup step_call step_cleanup
+     @ [iblock ([idecl (CT_fint 64) loop_var;
+                 icopy l (CL_id (loop_var, (CT_fint 64))) (F_id from_gs, (CT_fint 64));
+                 idecl CT_unit body_gs;
+                 iblock ([ilabel loop_start_label]
+                         @ [ijump (F_op (F_id loop_var, (if is_inc then ">" else "<"), F_id to_gs), CT_bool) loop_end_label]
+                         @ body_setup
+                         @ [body_call (CL_id (body_gs, CT_unit))]
+                         @ body_cleanup
+                         @ [icopy l (CL_id (loop_var, (CT_fint 64)))
+                                  (F_op (F_id loop_var, (if is_inc then "+" else "-"), F_id step_gs), (CT_fint 64))]
+                         @ [igoto loop_start_label]);
+                 ilabel loop_end_label])],
+     (fun clexp -> icopy l clexp unit_fragment),
+     []
+
+and compile_block ctx = function
+  | [] -> []
+  | exp :: exps ->
+     let setup, call, cleanup = compile_aexp ctx exp in
+     let rest = compile_block ctx exps in
+     let gs = gensym () in
+     iblock (setup @ [idecl CT_unit gs; call (CL_id (gs, CT_unit))] @ cleanup) :: rest
+
+(** Compile a sail type definition into a IR one. Most of the
+   actual work of translating the typedefs into C is done by the code
+   generator, as it's easy to keep track of structs, tuples and unions
+   in their sail form at this level, and leave the fiddly details of
+   how they get mapped to C in the next stage. This function also adds
+   details of the types it compiles to the context, ctx, which is why
+   it returns a ctypdef * ctx pair. **)
+let compile_type_def ctx (TD_aux (type_def, (l, _))) =
+  match type_def with
+  | TD_enum (id, ids, _) ->
+     CTD_enum (id, ids),
+     { ctx with enums = Bindings.add id (IdSet.of_list ids) ctx.enums }
+
+  | TD_record (id, typq, ctors, _) ->
+     let record_ctx = { ctx with local_env = add_typquant l typq ctx.local_env } in
+     let ctors =
+       List.fold_left (fun ctors (typ, id) -> Bindings.add id (ctyp_of_typ record_ctx typ) ctors) Bindings.empty ctors
+     in
+     CTD_struct (id, Bindings.bindings ctors),
+     { ctx with records = Bindings.add id ctors ctx.records }
+
+  | TD_variant (id, typq, tus, _) ->
+     let compile_tu = function
+       | Tu_aux (Tu_ty_id (typ, id), _) ->
+          let ctx = { ctx with local_env = add_typquant (id_loc id) typq ctx.local_env } in
+          ctyp_of_typ ctx typ, id
+     in
+     let ctus = List.fold_left (fun ctus (ctyp, id) -> Bindings.add id ctyp ctus) Bindings.empty (List.map compile_tu tus) in
+     CTD_variant (id, Bindings.bindings ctus),
+     { ctx with variants = Bindings.add id ctus ctx.variants }
+
+  (* Will be re-written before here, see bitfield.ml *)
+  | TD_bitfield _ ->
+     Reporting.unreachable l __POS__ "Cannot compile TD_bitfield"
+
+  (* All type abbreviations are filtered out in compile_def  *)
+  | TD_abbrev _ ->
+     Reporting.unreachable l __POS__ "Found TD_abbrev in compile_type_def"
+
+let generate_cleanup instrs =
+  let generate_cleanup' (I_aux (instr, _)) =
+    match instr with
+    | I_init (ctyp, id, cval) -> [(id, iclear ctyp id)]
+    | I_decl (ctyp, id) -> [(id, iclear ctyp id)]
+    | instr -> []
+  in
+  let is_clear ids = function
+    | I_aux (I_clear (_, id), _) -> IdSet.add id ids
+    | _ -> ids
+  in
+  let cleaned = List.fold_left is_clear IdSet.empty instrs in
+  instrs
+  |> List.map generate_cleanup'
+  |> List.concat
+  |> List.filter (fun (id, _) -> not (IdSet.mem id cleaned))
+  |> List.map snd
+
+let fix_exception_block ?return:(return=None) ctx instrs =
+  let end_block_label = label "end_block_exception_" in
+  let is_exception_stop (I_aux (instr, _)) =
+    match instr with
+    | I_throw _ | I_if _ | I_block _ | I_funcall _ -> true
+    | _ -> false
+  in
+  (* In this function 'after' is instructions after the one we've
+     matched on, 'before is instructions before the instruction we've
+     matched with, but after the previous match, and 'historic' are
+     all the befores from previous matches. *)
+  let rec rewrite_exception historic instrs =
+    match instr_split_at is_exception_stop instrs with
+    | instrs, [] -> instrs
+    | before, I_aux (I_block instrs, _) :: after ->
+       before
+       @ [iblock (rewrite_exception (historic @ before) instrs)]
+       @ rewrite_exception (historic @ before) after
+    | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after ->
+       let historic = historic @ before in
+       before
+       @ [iif cval (rewrite_exception historic then_instrs) (rewrite_exception historic else_instrs) ctyp]
+       @ rewrite_exception historic after
+    | before, I_aux (I_throw cval, (_, l)) :: after ->
+       before
+       @ [icopy l (CL_current_exception (cval_ctyp cval)) cval;
+          icopy l CL_have_exception (F_lit (V_bool true), CT_bool)]
+       @ generate_cleanup (historic @ before)
+       @ [igoto end_block_label]
+       @ rewrite_exception (historic @ before) after
+    | before, (I_aux (I_funcall (x, _, f, args), _) as funcall) :: after ->
+       let effects = match Env.get_val_spec f ctx.tc_env with
+         | _, Typ_aux (Typ_fn (_, _, effects), _) -> effects
+         | exception (Type_error _) -> no_effect (* nullary union constructor, so no val spec *)
+         | _ -> assert false (* valspec must have function type *)
+       in
+       if has_effect effects BE_escape then
+         before
+         @ [funcall;
+            iif (F_have_exception, CT_bool) (generate_cleanup (historic @ before) @ [igoto end_block_label]) [] CT_unit]
+         @ rewrite_exception (historic @ before) after
+       else
+         before @ funcall :: rewrite_exception (historic @ before) after
+    | _, _ -> assert false (* unreachable *)
+  in
+  match return with
+  | None ->
+     rewrite_exception [] instrs @ [ilabel end_block_label]
+  | Some ctyp ->
+     rewrite_exception [] instrs @ [ilabel end_block_label; iundefined ctyp]
+
+let rec map_try_block f (I_aux (instr, aux)) =
+  let instr = match instr with
+    | I_decl _ | I_reset _ | I_init _ | I_reinit _ -> instr
+    | I_if (cval, instrs1, instrs2, ctyp) ->
+       I_if (cval, List.map (map_try_block f) instrs1, List.map (map_try_block f) instrs2, ctyp)
+    | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_throw _ | I_return _ -> instr
+    | I_block instrs -> I_block (List.map (map_try_block f) instrs)
+    | I_try_block instrs -> I_try_block (f (List.map (map_try_block f) instrs))
+    | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_jump _ | I_match_failure | I_undefined _ | I_end -> instr
+  in
+  I_aux (instr, aux)
+
+let fix_exception ?return:(return=None) ctx instrs =
+  let instrs = List.map (map_try_block (fix_exception_block ctx)) instrs in
+  fix_exception_block ~return:return ctx instrs
+
+let rec compile_arg_pat ctx label (P_aux (p_aux, (l, _)) as pat) ctyp =
+  match p_aux with
+  | P_id id -> (id, ([], []))
+  | P_wild -> let gs = gensym () in (gs, ([], []))
+  | P_tup [] | P_lit (L_aux (L_unit, _)) -> let gs = gensym () in (gs, ([], []))
+  | P_var (pat, _) -> compile_arg_pat ctx label pat ctyp
+  | P_typ (_, pat) -> compile_arg_pat ctx label pat ctyp
+  | _ ->
+     let apat = anf_pat pat in
+     let gs = gensym () in
+     let destructure, cleanup, _ = compile_match ctx apat (F_id gs, ctyp) label in
+     (gs, (destructure, cleanup))
+
+let rec compile_arg_pats ctx label (P_aux (p_aux, (l, _)) as pat) ctyps =
+  match p_aux with
+  | P_typ (_, pat) -> compile_arg_pats ctx label pat ctyps
+  | P_tup pats when List.length pats = List.length ctyps ->
+     [], List.map2 (fun pat ctyp -> compile_arg_pat ctx label pat ctyp) pats ctyps, []
+  | _ when List.length ctyps = 1 ->
+     [], [compile_arg_pat ctx label pat (List.nth ctyps 0)], []
+
+  | _ ->
+     let arg_id, (destructure, cleanup) = compile_arg_pat ctx label pat (CT_tup ctyps) in
+     let new_ids = List.map (fun ctyp -> gensym (), ctyp) ctyps in
+     destructure
+     @ [idecl (CT_tup ctyps) arg_id]
+     @ List.mapi (fun i (id, ctyp) -> icopy l (CL_tuple (CL_id (arg_id, CT_tup ctyps), i)) (F_id id, ctyp)) new_ids,
+     List.map (fun (id, _) -> id, ([], [])) new_ids,
+     [iclear (CT_tup ctyps) arg_id]
+     @ cleanup
+
+let combine_destructure_cleanup xs = List.concat (List.map fst xs), List.concat (List.rev (List.map snd xs))
+
+let fix_destructure fail_label = function
+  | ([], cleanup) -> ([], cleanup)
+  | destructure, cleanup ->
+     let body_label = label "fundef_body_" in
+     (destructure @ [igoto body_label; ilabel fail_label; imatch_failure (); ilabel body_label], cleanup)
+
+(** Functions that have heap-allocated return types are implemented by
+   passing a pointer a location where the return value should be
+   stored. The ANF -> Sail IR pass for expressions simply outputs an
+   I_return instruction for any return value, so this function walks
+   over the IR ast for expressions and modifies the return statements
+   into code that sets that pointer, as well as adds extra control
+   flow to cleanup heap-allocated variables correctly when a function
+   terminates early. See the generate_cleanup function for how this is
+   done. *)
+let fix_early_return ret instrs =
+  let end_function_label = label "end_function_" in
+  let is_return_recur (I_aux (instr, _)) =
+    match instr with
+    | I_return _ | I_undefined _ | I_if _ | I_block _ -> true
+    | _ -> false
+  in
+  let rec rewrite_return historic instrs =
+    match instr_split_at is_return_recur instrs with
+    | instrs, [] -> instrs
+    | before, I_aux (I_block instrs, _) :: after ->
+       before
+       @ [iblock (rewrite_return (historic @ before) instrs)]
+       @ rewrite_return (historic @ before) after
+    | before, I_aux (I_if (cval, then_instrs, else_instrs, ctyp), _) :: after ->
+       let historic = historic @ before in
+       before
+       @ [iif cval (rewrite_return historic then_instrs) (rewrite_return historic else_instrs) ctyp]
+       @ rewrite_return historic after
+    | before, I_aux (I_return cval, (_, l)) :: after ->
+       let cleanup_label = label "cleanup_" in
+       let end_cleanup_label = label "end_cleanup_" in
+       before
+       @ [icopy l ret cval;
+          igoto cleanup_label]
+       (* This is probably dead code until cleanup_label, but we cannot be sure there are no jumps into it. *)
+       @ rewrite_return (historic @ before) after
+       @ [igoto end_cleanup_label;
+          ilabel cleanup_label]
+       @ generate_cleanup (historic @ before)
+       @ [igoto end_function_label;
+          ilabel end_cleanup_label]
+    | before, I_aux (I_undefined _, (_, l)) :: after ->
+       let cleanup_label = label "cleanup_" in
+       let end_cleanup_label = label "end_cleanup_" in
+       before
+       @ [igoto cleanup_label]
+       @ rewrite_return (historic @ before) after
+       @ [igoto end_cleanup_label;
+          ilabel cleanup_label]
+       @ generate_cleanup (historic @ before)
+       @ [igoto end_function_label;
+          ilabel end_cleanup_label]
+    | _, _ -> assert false
+  in
+  rewrite_return [] instrs
+  @ [ilabel end_function_label; iend ()]
+
+let letdef_count = ref 0
+
+(** Compile a Sail toplevel definition into an IR definition **)
+let rec compile_def n total ctx def =
+  match def with
+  | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, _), _)]), _))
+       when !opt_memo_cache ->
+     let digest =
+       def |> Pretty_print_sail.doc_def |> Pretty_print_sail.to_string |> Digest.string
+     in
+     let cachefile = Filename.concat "_sbuild" ("ccache" ^ Digest.to_hex digest) in
+     let cached =
+       if Sys.file_exists cachefile then
+         let in_chan = open_in cachefile in
+         try
+           let compiled = Marshal.from_channel in_chan in
+           close_in in_chan;
+           Some (compiled, ctx)
+         with
+         | _ -> close_in in_chan; None
+       else
+         None
+     in
+     begin match cached with
+     | Some (compiled, ctx) ->
+        Util.progress "Compiling " (string_of_id id) n total;
+        compiled, ctx
+     | None ->
+        let compiled, ctx = compile_def' n total ctx def in
+        let out_chan = open_out cachefile in
+        Marshal.to_channel out_chan compiled [Marshal.Closures];
+        close_out out_chan;
+        compiled, ctx
+     end
+
+  | _ -> compile_def' n total ctx def
+
+and compile_def' n total ctx = function
+  | DEF_reg_dec (DEC_aux (DEC_reg (_, _, typ, id), _)) ->
+     [CDEF_reg_dec (id, ctyp_of_typ ctx typ, [])], ctx
+  | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), _)) ->
+     let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in
+     let setup, call, cleanup = compile_aexp ctx aexp in
+     let instrs = setup @ [call (CL_id (id, ctyp_of_typ ctx typ))] @ cleanup in
+     [CDEF_reg_dec (id, ctyp_of_typ ctx typ, instrs)], ctx
+
+  | DEF_reg_dec (DEC_aux (_, (l, _))) ->
+     raise (Reporting.err_general l "Cannot compile alias register declaration")
+
+  | DEF_spec (VS_aux (VS_val_spec (_, id, _, _), _)) ->
+     let quant, Typ_aux (fn_typ, _) = Env.get_val_spec id ctx.tc_env in
+     let arg_typs, ret_typ = match fn_typ with
+       | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
+       | _ -> assert false
+     in
+     let ctx' = { ctx with local_env = add_typquant (id_loc id) quant ctx.local_env } in
+     let arg_ctyps, ret_ctyp = List.map (ctyp_of_typ ctx') arg_typs, ctyp_of_typ ctx' ret_typ in
+     [CDEF_spec (id, arg_ctyps, ret_ctyp)], ctx
+
+  | DEF_fundef (FD_aux (FD_function (_, _, _, [FCL_aux (FCL_Funcl (id, Pat_aux (Pat_exp (pat, exp), _)), _)]), _)) ->
+     Util.progress "Compiling " (string_of_id id) n total;
+
+     (* Find the function's type. *)
+     let quant, Typ_aux (fn_typ, _) =
+       try Env.get_val_spec id ctx.local_env with Type_error _ -> Env.get_val_spec id ctx.tc_env
+     in
+     let arg_typs, ret_typ = match fn_typ with
+       | Typ_fn (arg_typs, ret_typ, _) -> arg_typs, ret_typ
+       | _ -> assert false
+     in
+
+     (* Handle the argument pattern. *)
+     let fundef_label = label "fundef_fail_" in
+     let orig_ctx = ctx in
+     (* The context must be updated before we call ctyp_of_typ on the argument types. *)
+     let ctx = { ctx with local_env = add_typquant (id_loc id) quant ctx.tc_env } in
+
+     let arg_ctyps =  List.map (ctyp_of_typ ctx) arg_typs in
+     let ret_ctyp = ctyp_of_typ ctx ret_typ in
+
+     (* Compile the function arguments as patterns. *)
+     let arg_setup, compiled_args, arg_cleanup = compile_arg_pats ctx fundef_label pat arg_ctyps in
+     let ctx =
+       (* We need the primop analyzer to be aware of the function argument types, so put them in ctx *)
+       List.fold_left2 (fun ctx (id, _) ctyp -> { ctx with locals = Bindings.add id (Immutable, ctyp) ctx.locals }) ctx compiled_args arg_ctyps
+     in
+
+     (* Optimize and compile the expression to ANF. *)
+     let aexp = no_shadow (pat_ids pat) (anf exp) in
+     let aexp = ctx.optimize_anf ctx aexp in
+
+     let setup, call, cleanup = compile_aexp ctx aexp in
+     let destructure, destructure_cleanup =
+       compiled_args |> List.map snd |> combine_destructure_cleanup |> fix_destructure fundef_label
+     in
+
+     let instrs = arg_setup @ destructure @ setup @ [call (CL_return ret_ctyp)] @ cleanup @ destructure_cleanup @ arg_cleanup in
+     let instrs = fix_early_return (CL_return ret_ctyp) instrs in
+     let instrs = fix_exception ~return:(Some ret_ctyp) ctx instrs in
+
+     if Id.compare (mk_id !opt_debug_function) id = 0 then
+       let header =
+         Printf.sprintf "Sail IR for %s %s(%s) : (%s) -> %s" Util.("function" |> red |> clear) (string_of_id id)
+                        (Util.string_of_list ", " string_of_id (List.map fst compiled_args))
+                        (Util.string_of_list ", " (fun ctyp -> Util.(string_of_ctyp ctyp |> yellow |> clear)) arg_ctyps)
+                        Util.(string_of_ctyp ret_ctyp |> yellow |> clear)
+       in
+       prerr_endline (Util.header header (List.length arg_ctyps + 2));
+       prerr_endline (Pretty_print_sail.to_string PPrint.(separate_map hardline pp_instr instrs))
+     else ();
+
+     if !opt_debug_flow_graphs then
+       begin
+         let instrs = Jib_optimize.(instrs |> optimize_unit |> flatten_instrs) in
+         let cfg = Jib_ssa.ssa instrs in
+         let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in
+         Jib_ssa.make_dot out_chan cfg;
+         close_out out_chan;
+       end;
+
+     [CDEF_fundef (id, None, List.map fst compiled_args, instrs)], orig_ctx
+
+  | DEF_fundef (FD_aux (FD_function (_, _, _, []), (l, _))) ->
+     raise (Reporting.err_general l "Encountered function with no clauses")
+
+  | DEF_fundef (FD_aux (FD_function (_, _, _, funcls), (l, _))) ->
+     raise (Reporting.err_general l "Encountered function with multiple clauses")
+
+  (* All abbreviations should expanded by the typechecker, so we don't
+     need to translate type abbreviations into C typedefs. *)
+  | DEF_type (TD_aux (TD_abbrev _, _)) -> [], ctx
+
+  | DEF_type type_def ->
+     let tdef, ctx = compile_type_def ctx type_def in
+     [CDEF_type tdef], ctx
+
+  | DEF_val (LB_aux (LB_val (pat, exp), _)) ->
+     let ctyp = ctyp_of_typ ctx (typ_of_pat pat) in
+     let aexp = ctx.optimize_anf ctx (no_shadow IdSet.empty (anf exp)) in
+     let setup, call, cleanup = compile_aexp ctx aexp in
+     let apat = anf_pat ~global:true pat in
+     let gs = gensym () in
+     let end_label = label "let_end_" in
+     let destructure, destructure_cleanup, _ = compile_match ctx apat (F_id gs, ctyp) end_label in
+     let gs_setup, gs_cleanup =
+       [idecl ctyp gs], [iclear ctyp gs]
+     in
+     let bindings = List.map (fun (id, typ) -> id, ctyp_of_typ ctx typ) (apat_globals apat) in
+     let n = !letdef_count in
+     incr letdef_count;
+     let instrs =
+       gs_setup @ setup
+       @ [call (CL_id (gs, ctyp))]
+       @ cleanup
+       @ destructure
+       @ destructure_cleanup @ gs_cleanup
+       @ [ilabel end_label]
+     in
+     [CDEF_let (n, bindings, instrs)],
+     { ctx with letbinds = n :: ctx.letbinds }
+
+  (* Only DEF_default that matters is default Order, but all order
+     polymorphism is specialised by this point. *)
+  | DEF_default _ -> [], ctx
+
+  (* Overloading resolved by type checker *)
+  | DEF_overload _ -> [], ctx
+
+  (* Only the parser and sail pretty printer care about this. *)
+  | DEF_fixity _ -> [], ctx
+
+  (* We just ignore any pragmas we don't want to deal with. *)
+  | DEF_pragma _ -> [], ctx
+
+  (* Termination measures only needed for Coq, and other theorem prover output *)
+  | DEF_measure _ -> [], ctx
+
+  | DEF_internal_mutrec fundefs ->
+     let defs = List.map (fun fdef -> DEF_fundef fdef) fundefs in
+     List.fold_left (fun (cdefs, ctx) def -> let cdefs', ctx = compile_def n total ctx def in (cdefs @ cdefs', ctx)) ([], ctx) defs
+
+  (* Scattereds and mapdefs should be removed by this point *)
+  | (DEF_scattered _ | DEF_mapdef _) as def ->
+     raise (Reporting.err_general Parse_ast.Unknown ("Could not compile:\n" ^ Pretty_print_sail.to_string (Pretty_print_sail.doc_def def)))
+
+let rec specialize_variants ctx prior =
+  let unifications = ref (Bindings.empty) in
+
+  let fix_variant_ctyp var_id new_ctors = function
+    | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors)
+    | ctyp -> ctyp
+  in
+
+  let specialize_constructor ctx ctor_id ctyp =
+    function
+    | I_aux (I_funcall (clexp, extern, id, [cval]), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 ->
+       (* Work out how each call to a constructor in instantiated and add that to unifications *)
+       let unification = List.map ctyp_suprema (ctyp_unify ctyp (cval_ctyp cval)) in
+       let mono_id = append_id ctor_id ("_" ^ Util.string_of_list "_" (fun ctyp -> Util.zencode_string (string_of_ctyp ctyp)) unification) in
+       unifications := Bindings.add mono_id (ctyp_suprema (cval_ctyp cval)) !unifications;
+
+       (* We need to cast each cval to it's ctyp_suprema in order to put it in the most general constructor *)
+       let casts =
+         let cast_to_suprema (frag, ctyp) =
+           let suprema = ctyp_suprema ctyp in
+           if ctyp_equal ctyp suprema then
+             [], (unpoly frag, ctyp), []
+           else
+             let gs = gensym () in
+             [idecl suprema gs;
+              icopy l (CL_id (gs, suprema)) (unpoly frag, ctyp)],
+             (F_id gs, suprema),
+             [iclear suprema gs]
+         in
+         List.map cast_to_suprema [cval]
+       in
+       let setup = List.concat (List.map (fun (setup, _, _) -> setup) casts) in
+       let cvals = List.map (fun (_, cval, _) -> cval) casts in
+       let cleanup = List.concat (List.map (fun (_, _, cleanup) -> cleanup) casts) in
+
+       let mk_funcall instr =
+         if List.length setup = 0 then
+           instr
+         else
+           iblock (setup @ [instr] @ cleanup)
+       in
+
+       mk_funcall (I_aux (I_funcall (clexp, extern, mono_id, cvals), aux))
+
+    | I_aux (I_funcall (clexp, extern, id, cvals), ((_, l) as aux)) as instr when Id.compare id ctor_id = 0 ->
+       Reporting.unreachable l __POS__ "Multiple argument constructor found"
+
+    | instr -> instr
+  in
+
+  function
+  | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs ->
+     let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in
+
+     let cdefs =
+       List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs)
+                      cdefs
+                      polymorphic_ctors
+     in
+
+     let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in
+     let specialized_ctors = Bindings.bindings !unifications in
+     let new_ctors = monomorphic_ctors @ specialized_ctors in
+
+     let ctx = {
+         ctx with variants = Bindings.add var_id
+                               (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors)
+                               ctx.variants
+       } in
+
+     let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in
+     let prior = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) prior in
+     specialize_variants ctx (CDEF_type (CTD_variant (var_id, new_ctors)) :: prior) cdefs
+
+  | cdef :: cdefs ->
+     let remove_poly (I_aux (instr, aux)) =
+       match instr with
+       | I_copy (clexp, (frag, ctyp)) when is_polymorphic ctyp ->
+          I_aux (I_copy (clexp, (frag, ctyp_suprema (clexp_ctyp clexp))), aux)
+       | instr -> I_aux (instr, aux)
+     in
+     let cdef = cdef_map_instr remove_poly cdef in
+     specialize_variants ctx (cdef :: prior) cdefs
+
+  | [] -> List.rev prior, ctx
+
+(** Once we specialize variants, there may be additional type
+   dependencies which could be in the wrong order. As such we need to
+   sort the type definitions in the list of cdefs. *)
+let sort_ctype_defs cdefs =
+  (* Split the cdefs into type definitions and non type definitions *)
+  let is_ctype_def = function CDEF_type _ -> true | _ -> false in
+  let unwrap = function CDEF_type ctdef -> ctdef | _ -> assert false in
+  let ctype_defs = List.map unwrap (List.filter is_ctype_def cdefs) in
+  let cdefs = List.filter (fun cdef -> not (is_ctype_def cdef)) cdefs in
+
+  let ctdef_id = function
+    | CTD_enum (id, _) | CTD_struct (id, _) | CTD_variant (id, _) -> id
+  in
+
+  let ctdef_ids = function
+    | CTD_enum _ -> IdSet.empty
+    | CTD_struct (_, ctors) | CTD_variant (_, ctors) ->
+       List.fold_left (fun ids (_, ctyp) -> IdSet.union (ctyp_ids ctyp) ids) IdSet.empty ctors
+  in
+
+  (* Create a reverse (i.e. from types to the types that are dependent
+     upon them) id graph of dependencies between types *)
+  let module IdGraph = Graph.Make(Id) in
+
+  let graph =
+    List.fold_left (fun g ctdef ->
+        List.fold_left (fun g id -> IdGraph.add_edge id (ctdef_id ctdef) g)
+          (IdGraph.add_edges (ctdef_id ctdef) [] g) (* Make sure even types with no dependencies are in graph *)
+          (IdSet.elements (ctdef_ids ctdef)))
+      IdGraph.empty
+      ctype_defs
+  in
+
+  (* Then select the ctypes in the correct order as given by the topsort *)
+  let ids = IdGraph.topsort graph in
+  let ctype_defs =
+    List.map (fun id -> CDEF_type (List.find (fun ctdef -> Id.compare (ctdef_id ctdef) id = 0) ctype_defs)) ids
+  in
+
+  ctype_defs @ cdefs
+
+let compile_ast ctx (Defs defs) =
+  let assert_vs = Initial_check.extern_of_string (mk_id "sail_assert") "(bool, string) -> unit effect {escape}" in
+  let exit_vs = Initial_check.extern_of_string (mk_id "sail_exit") "unit -> unit effect {escape}" in
+
+  let ctx = { ctx with tc_env = snd (Type_error.check ctx.tc_env (Defs [assert_vs; exit_vs])) } in
+
+  if !opt_memo_cache then
+    (try
+       if Sys.is_directory "_sbuild" then
+         ()
+       else
+         raise (Reporting.err_general Parse_ast.Unknown "_sbuild exists, but is a file not a directory!")
+     with
+     | Sys_error _ -> Unix.mkdir "_sbuild" 0o775)
+  else ();
+
+  let total = List.length defs in
+  let _, chunks, ctx =
+    List.fold_left (fun (n, chunks, ctx) def -> let defs, ctx = compile_def n total ctx def in n + 1, defs :: chunks, ctx) (1, [], ctx) defs
+  in
+  let cdefs = List.concat (List.rev chunks) in
+  let cdefs, ctx = specialize_variants ctx [] cdefs in
+  let cdefs = sort_ctype_defs cdefs in
+  cdefs, ctx
diff --git a/src/bytecode_interpreter.ml b/src/jib/jib_compile.mli
index 398e0c9d..f3bd8c76 100644
--- a/src/bytecode_interpreter.ml
+++ b/src/jib/jib_compile.mli
@@ -48,115 +48,53 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
+(** Compile Sail ASTs to Jib intermediate representation *)
+
+open Anf
 open Ast
 open Ast_util
-open Bytecode
-open Bytecode_util
-
-module StringMap = Map.Make(String)
-
-type 'a frame = {
-    jump_table : int StringMap.t;
-    locals : 'a Bindings.t;
-    pc : int;
-    instrs : instr array
-  }
-
-type 'a gstate = {
-    globals : 'a Bindings.t;
-    cdefs : cdef list
+open Jib
+open Type_check
+
+(** Output a dataflow graph for each generated function in Graphviz
+   (dot) format. *)
+val opt_debug_flow_graphs : bool ref
+
+(** Print the IR representation of a specific function. *)
+val opt_debug_function : string ref
+
+(** {2 Jib context} *)
+
+(** Context for compiling Sail to Jib. We need to pass a (global)
+   typechecking environment given by checking the full AST. We have to
+   provide a conversion function from Sail types into Jib types, as
+   well as a function that optimizes ANF expressions (which can just
+   be the identity function) *)
+type ctx =
+  { records : (ctyp Bindings.t) Bindings.t;
+    enums : IdSet.t Bindings.t;
+    variants : (ctyp Bindings.t) Bindings.t;
+    tc_env : Env.t;
+    local_env : Env.t;
+    locals : (mut * ctyp) Bindings.t;
+    letbinds : int list;
+    no_raw : bool;
+    convert_typ : ctx -> typ -> ctyp;
+    optimize_anf : ctx -> typ aexp -> typ aexp
   }
 
-type 'a stack = {
-    top : 'a frame;
-    ret : ('a -> 'a frame) list
-  }
-
-let make_jump_table instrs =
-  let rec aux n = function
-    | I_aux (I_label label, _) :: instrs -> StringMap.add label n (aux (n + 1) instrs)
-    | _ :: instrs -> aux (n + 1) instrs
-    | [] -> StringMap.empty
-  in
-  aux 0 instrs
-
-let new_gstate cdefs = {
-    globals = Bindings.empty;
-    cdefs = cdefs
-  }
-
-let new_stack instrs = {
-    top = {
-      jump_table = make_jump_table instrs;
-      locals = Bindings.empty;
-      pc = 0;
-      instrs = Array.of_list instrs
-    };
-    ret = []
-  }
-
-let with_top stack f =
-  { stack with top = f (stack.top) }
-
-let eval_fragment gstate locals = function
-  | F_id id ->
-     begin match Bindings.find_opt id locals with
-     | Some vl -> vl
-     | None ->
-        begin match Bindings.find_opt id gstate.globals with
-        | Some vl -> vl
-        | None -> failwith "Identifier not found"
-        end
-     end
-  | F_lit vl -> vl
-  | _ -> failwith "Cannot eval fragment"
-
-let is_function id = function
-  | CDEF_fundef (id', _, _, _) when Id.compare id id' = 0 -> true
-  | _ -> false
-
-let step (gstate, stack) =
-  let I_aux (instr_aux, (_, l)) = stack.top.instrs.(stack.top.pc) in
-  match instr_aux with
-  | I_decl _ ->
-     gstate, with_top stack (fun frame -> { frame with pc = frame.pc + 1 })
-
-  | I_init (_, id, (fragment, _)) ->
-     let vl = eval_fragment gstate stack.top.locals fragment in
-     gstate,
-     with_top stack (fun frame -> { frame with pc = frame.pc + 1; locals = Bindings.add id vl frame.locals })
-
-  | I_jump ((fragment, _), label) ->
-     let vl = eval_fragment gstate stack.top.locals fragment in
-     gstate,
-     begin match vl with
-     | V_bool true ->
-        with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table })
-     | V_bool false ->
-        with_top stack (fun frame -> { frame with pc = frame.pc + 1 })
-     | _ ->
-        failwith "Type error"
-     end
+val initial_ctx :
+  convert_typ:(ctx -> typ -> ctyp) ->
+  optimize_anf:(ctx -> typ aexp -> typ aexp) ->
+  Env.t ->
+  ctx
 
-  | I_funcall (clexp, _, id, cvals) ->
-     let args = List.map (fun (fragment, _) -> eval_fragment gstate stack.top.locals fragment) cvals in
-     let params, instrs =
-       match List.find_opt (is_function id) gstate.cdefs with
-       | Some (CDEF_fundef (_, _, params, instrs)) -> params, instrs
-       | _ -> failwith "Function not found"
-     in
-     gstate,
-     {
-       top = {
-         jump_table = make_jump_table instrs;
-         locals = List.fold_left2 (fun locals param arg -> Bindings.add param arg locals) Bindings.empty params args;
-         pc = 0;
-         instrs = Array.of_list instrs;
-       };
-       ret = (fun vl -> { stack.top with pc = stack.top.pc + 1 }) :: stack.ret
-     }
+(** {2 Compilation functions} *)
 
-  | I_goto label ->
-     gstate, with_top stack (fun frame -> { frame with pc = StringMap.find label frame.jump_table })
+(** Compile a Sail definition into a Jib definition. The first two
+   arguments are is the current definition number and the total number
+   of definitions, and can be used to drive a progress bar (see
+   Util.progress). *)
+val compile_def : int -> int -> ctx -> tannot def -> cdef list * ctx
 
-  | _ -> raise (Reporting.err_unreachable l __POS__ "Unhandled instruction")
+val compile_ast : ctx -> tannot defs -> cdef list * ctx
diff --git a/src/jib/jib_optimize.ml b/src/jib/jib_optimize.ml
new file mode 100644
index 00000000..889e650e
--- /dev/null
+++ b/src/jib/jib_optimize.ml
@@ -0,0 +1,129 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Ast_util
+open Jib
+open Jib_util
+
+let optimize_unit instrs =
+  let unit_cval cval =
+    match cval_ctyp cval with
+    | CT_unit -> (F_lit V_unit, CT_unit)
+    | _ -> cval
+  in
+  let unit_instr = function
+    | I_aux (I_funcall (clexp, extern, id, args), annot) as instr ->
+       begin match clexp_ctyp clexp with
+       | CT_unit ->
+          I_aux (I_funcall (CL_void, extern, id, List.map unit_cval args), annot)
+       | _ -> instr
+       end
+    | I_aux (I_copy (clexp, cval), annot) as instr ->
+       begin match clexp_ctyp clexp with
+       | CT_unit ->
+          I_aux (I_copy (CL_void, unit_cval cval), annot)
+       | _ -> instr
+       end
+    | I_aux (I_alias (clexp, cval), annot) as instr ->
+       begin match clexp_ctyp clexp with
+       | CT_unit ->
+          I_aux (I_alias (CL_void, unit_cval cval), annot)
+       | _ -> instr
+       end
+    | instr -> instr
+  in
+  let non_pointless_copy (I_aux (aux, annot)) =
+    match aux with
+    | I_copy (CL_void, _) -> false
+    | _ -> true
+  in
+  filter_instrs non_pointless_copy (map_instr_list unit_instr instrs)
+
+let flat_counter = ref 0
+let flat_id () =
+  let id = mk_id ("local#" ^ string_of_int !flat_counter) in
+  incr flat_counter;
+  id
+
+let rec flatten_instrs = function
+  | I_aux (I_decl (ctyp, decl_id), aux) :: instrs ->
+     let fid = flat_id () in
+     I_aux (I_decl (ctyp, fid), aux) :: flatten_instrs (instrs_rename decl_id fid instrs)
+
+  | I_aux ((I_block block | I_try_block block), _) :: instrs ->
+     flatten_instrs block @ flatten_instrs instrs
+
+  | I_aux (I_if (cval, then_instrs, else_instrs, _), _) :: instrs ->
+     let then_label = label "then_" in
+     let endif_label = label "endif_" in
+     [ijump cval then_label]
+     @ flatten_instrs else_instrs
+     @ [igoto endif_label]
+     @ [ilabel then_label]
+     @ flatten_instrs then_instrs
+     @ [ilabel endif_label]
+     @ flatten_instrs instrs
+
+  | I_aux (I_comment _, _) :: instrs -> flatten_instrs instrs
+
+  | instr :: instrs -> instr :: flatten_instrs instrs
+  | [] -> []
+
+let flatten_cdef =
+  function
+  | CDEF_fundef (function_id, heap_return, args, body) ->
+     flat_counter := 0;
+     CDEF_fundef (function_id, heap_return, args, flatten_instrs body)
+
+  | CDEF_let (n, bindings, instrs) ->
+    flat_counter := 0;
+    CDEF_let (n, bindings, flatten_instrs instrs)
+
+  | cdef -> cdef
diff --git a/src/jib/jib_optimize.mli b/src/jib/jib_optimize.mli
new file mode 100644
index 00000000..beffa81e
--- /dev/null
+++ b/src/jib/jib_optimize.mli
@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Jib
+
+(** Remove redundant assignments and variables of type
+   unit. unit-typed identifiers that are assigned to are replaced with
+   CL_void, and cvals (which should be pure!) are replaced with unit
+   types are replaced by unit-literals. *)
+val optimize_unit : instr list -> instr list
+
+(** Remove all instructions that can contain other nested
+   instructions, prodcing a flat list of instructions. *)
+val flatten_instrs : instr list -> instr list
+val flatten_cdef : cdef -> cdef
+
diff --git a/src/jib/jib_ssa.ml b/src/jib/jib_ssa.ml
new file mode 100644
index 00000000..1f477696
--- /dev/null
+++ b/src/jib/jib_ssa.ml
@@ -0,0 +1,602 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Ast_util
+open Jib
+open Jib_util
+
+module IntSet = Set.Make(struct type t = int let compare = compare end)
+
+(**************************************************************************)
+(* 1. Mutable graph type                                                  *)
+(**************************************************************************)
+
+type 'a array_graph = {
+    mutable next : int;
+    mutable nodes : ('a * IntSet.t * IntSet.t) option array
+  }
+
+let make ~initial_size () = {
+    next = 0;
+    nodes = Array.make initial_size None
+  }
+
+(** Add a vertex to a graph, returning the node index *)
+let add_vertex data graph =
+  let n = graph.next in
+  if n >= Array.length graph.nodes then
+    begin
+      let new_nodes = Array.make (Array.length graph.nodes * 2) None in
+      Array.blit graph.nodes 0 new_nodes 0 (Array.length graph.nodes);
+      graph.nodes <- new_nodes
+    end;
+  let n = graph.next in
+  graph.nodes.(n) <- Some (data, IntSet.empty, IntSet.empty);
+  graph.next <- n + 1;
+  n
+
+(** Add an edge between two existing vertices. Raises Invalid_argument
+   if either of the vertices do not exist. *)
+let add_edge n m graph =
+  begin match graph.nodes.(n) with
+  | Some (data, parents, children) ->
+     graph.nodes.(n) <- Some (data, parents, IntSet.add m children)
+  | None ->
+     raise (Invalid_argument "Parent node does not exist in graph")
+  end;
+  match graph.nodes.(m) with
+  | Some (data, parents, children) ->
+     graph.nodes.(m) <- Some (data, IntSet.add n parents, children)
+  | None ->
+     raise (Invalid_argument "Child node does not exist in graph")
+
+let cardinal graph = graph.next
+
+let reachable roots graph =
+  let visited = ref IntSet.empty in
+
+  let rec reachable' n =
+    if IntSet.mem n !visited then ()
+    else
+      begin
+        visited := IntSet.add n !visited;
+        match graph.nodes.(n) with
+        | Some (_, _, successors) ->
+           IntSet.iter reachable' successors
+        | None -> ()
+      end
+  in
+  IntSet.iter reachable' roots; !visited
+
+let prune visited graph =
+  for i = 0 to graph.next - 1 do
+    match graph.nodes.(i) with
+    | Some (n, preds, succs) ->
+       if IntSet.mem i visited then
+         graph.nodes.(i) <- Some (n, IntSet.inter visited preds, IntSet.inter visited succs)
+       else
+         graph.nodes.(i) <- None
+    | None -> ()
+  done
+
+(**************************************************************************)
+(* 2. Mutable control flow graph                                          *)
+(**************************************************************************)
+
+type cf_node =
+  | CF_label of string
+  | CF_block of instr list
+  | CF_start
+
+let control_flow_graph instrs =
+  let module StringMap = Map.Make(String) in
+  let labels = ref StringMap.empty in
+
+  let graph = make ~initial_size:512 () in
+
+  iter_instr (fun (I_aux (instr, annot)) ->
+      match instr with
+      | I_label label ->
+         labels := StringMap.add label (add_vertex ([], CF_label label) graph) !labels
+      | _ -> ()
+    ) (iblock instrs);
+
+  let cf_split (I_aux (aux, _)) =
+    match aux with
+    | I_block _ | I_label _ | I_goto _ | I_jump _ | I_if _ | I_end | I_match_failure | I_undefined _ -> true
+    | _ -> false
+  in
+
+  let rec cfg preds instrs =
+    let before, after = instr_split_at cf_split instrs in
+    let last = match after with
+      | I_aux (I_label _, _) :: _ -> []
+      | instr :: _ -> [instr]
+      | _ -> []
+    in
+    let preds = match before @ last with
+      | [] -> preds
+      | instrs ->
+         let n = add_vertex ([], CF_block instrs) graph in
+         List.iter (fun p -> add_edge p n graph) preds;
+         [n]
+    in
+    match after with
+    | I_aux (I_if (cond, then_instrs, else_instrs, _), _) :: after ->
+       let t = cfg preds then_instrs in
+       let e = cfg preds else_instrs in
+       cfg (t @ e) after
+
+    | I_aux ((I_end | I_match_failure | I_undefined _), _) :: after ->
+       cfg [] after
+
+    | I_aux (I_goto label, _) :: after ->
+       List.iter (fun p -> add_edge p (StringMap.find label !labels) graph) preds;
+       cfg [] after
+
+    | I_aux (I_jump (cval, label), _) :: after ->
+       List.iter (fun p -> add_edge p (StringMap.find label !labels) graph) preds;
+       cfg preds after
+
+    | I_aux (I_label label, _) :: after ->
+       cfg (StringMap.find label !labels :: preds) after
+
+    | I_aux (I_block instrs, _) :: after ->
+       let m = cfg preds instrs in
+       cfg m after
+
+    | _ :: after -> assert false
+
+    | [] -> preds
+  in
+
+  let start = add_vertex ([], CF_start) graph in
+  let finish = cfg [start] instrs in
+
+  let visited = reachable (IntSet.singleton start) graph in
+  prune visited graph;
+
+  start, finish, graph
+
+(**************************************************************************)
+(* 3. Computing dominators                                                *)
+(**************************************************************************)
+
+(** Calculate the (immediate) dominators of a graph using the
+   Lengauer-Tarjan algorithm. This is the slightly less sophisticated
+   version from Appel's book 'Modern compiler implementation in ML'
+   which runs in O(n log(n)) time. *)
+let immediate_dominators graph root =
+  let none = -1 in
+  let vertex   = Array.make (cardinal graph) 0 in
+  let parent   = Array.make (cardinal graph) none in
+  let ancestor = Array.make (cardinal graph) none in
+  let semi     = Array.make (cardinal graph) none in
+  let idom     = Array.make (cardinal graph) none in
+  let samedom  = Array.make (cardinal graph) none in
+  let best     = Array.make (cardinal graph) none in
+  let dfnum    = Array.make (cardinal graph) 0 in
+  let bucket   = Array.make (cardinal graph) IntSet.empty in
+
+  let rec ancestor_with_lowest_semi v =
+    let a = ancestor.(v) in
+    if ancestor.(a) <> none then
+      let b = ancestor_with_lowest_semi a in
+      ancestor.(v) <- ancestor.(a);
+      if dfnum.(semi.(b)) < dfnum.(semi.(best.(v))) then
+        best.(v) <- b
+      else ();
+    else ();
+    if best.(v) <> none then best.(v) else v
+  in
+
+  let link p n =
+    ancestor.(n) <- p;
+    best.(n) <- n
+  in
+
+  let count = ref 0 in
+
+  let rec dfs p n =
+    if dfnum.(n) = 0 then
+      begin
+        dfnum.(n) <- !count;
+        vertex.(!count) <- n;
+        parent.(n) <- p;
+        incr count;
+        match graph.nodes.(n) with
+        | Some (_, _, successors) ->
+           IntSet.iter (fun w -> dfs n w) successors
+        | None -> assert false
+      end
+  in
+  dfs none root;
+
+  for i = !count - 1 downto 1 do
+    let n = vertex.(i) in
+    let p = parent.(n) in
+    let s = ref p in
+
+    begin match graph.nodes.(n) with
+    | Some (_, predecessors, _) ->
+       IntSet.iter (fun v ->
+           let s' =
+             if dfnum.(v) <= dfnum.(n) then
+               v
+             else
+               semi.(ancestor_with_lowest_semi v)
+           in
+           if dfnum.(s') < dfnum.(!s) then s := s'
+         ) predecessors
+    | None -> assert false
+    end;
+    semi.(n) <- !s;
+    bucket.(!s) <- IntSet.add n bucket.(!s);
+    link p n;
+    IntSet.iter (fun v ->
+        let y = ancestor_with_lowest_semi v in
+        if semi.(y) = semi.(v) then
+          idom.(v) <- p
+        else
+          samedom.(n) <- y
+      ) bucket.(p);
+  done;
+  for i = 1 to !count - 1 do
+    let n = vertex.(i) in
+    if samedom.(n) <> none then
+      idom.(n) <- idom.(samedom.(n))
+  done;
+  idom
+
+(** [(dominator_children idoms).(n)] are the nodes whose immediate dominator
+   (idom) is n. *)
+let dominator_children idom =
+  let none = -1 in
+  let children = Array.make (Array.length idom) IntSet.empty in
+
+  for n = 0 to Array.length idom - 1 do
+    let p = idom.(n) in
+    if p <> none then
+      children.(p) <- IntSet.add n (children.(p))
+  done;
+  children
+
+(** [dominate idom n w] is true if n dominates w in the tree of
+   immediate dominators idom. *)
+let rec dominate idom n w =
+  let none = -1 in
+  let p = idom.(n) in
+  if p = none then
+    false
+  else if p = w then
+    true
+  else
+    dominate idom p w
+
+let dominance_frontiers graph root idom children =
+  let df = Array.make (cardinal graph) IntSet.empty in
+
+  let rec compute_df n =
+    let set = ref IntSet.empty in
+
+    begin match graph.nodes.(n) with
+    | Some (content, _, succs) ->
+       IntSet.iter (fun y ->
+           if idom.(y) <> n then
+             set := IntSet.add y !set
+         ) succs
+    | None -> ()
+    end;
+    IntSet.iter (fun c ->
+        compute_df c;
+        IntSet.iter (fun w ->
+            if not (dominate idom n w) then
+              set := IntSet.add w !set
+          ) (df.(c))
+      ) (children.(n));
+    df.(n) <- !set
+  in
+  compute_df root;
+  df
+
+(**************************************************************************)
+(* 4. Conversion to SSA form                                              *)
+(**************************************************************************)
+
+type ssa_elem =
+  | Phi of Ast.id * Ast.id list
+
+let place_phi_functions graph df =
+  let defsites = ref Bindings.empty in
+
+  let all_vars = ref IdSet.empty in
+
+  let rec all_decls = function
+    | I_aux (I_decl (_, id), _) :: instrs ->
+       IdSet.add id (all_decls instrs)
+    | _ :: instrs -> all_decls instrs
+    | [] -> IdSet.empty
+  in
+
+  let orig_A n =
+    match graph.nodes.(n) with
+    | Some ((_, CF_block instrs), _, _) ->
+       let vars = List.fold_left IdSet.union IdSet.empty (List.map instr_writes instrs) in
+       let vars = IdSet.diff vars (all_decls instrs) in
+       all_vars := IdSet.union vars !all_vars;
+       vars
+    | Some _ -> IdSet.empty
+    | None -> IdSet.empty
+  in
+  let phi_A = ref Bindings.empty in
+
+  for n = 0 to graph.next - 1 do
+    IdSet.iter (fun a ->
+        let ds = match Bindings.find_opt a !defsites with Some ds -> ds | None -> IntSet.empty in
+        defsites := Bindings.add a (IntSet.add n ds) !defsites
+      ) (orig_A n)
+  done;
+
+  IdSet.iter (fun a ->
+      let workset = ref (Bindings.find a !defsites) in
+      while not (IntSet.is_empty !workset) do
+        let n = IntSet.choose !workset in
+        workset := IntSet.remove n !workset;
+        IntSet.iter (fun y ->
+            let phi_A_a = match Bindings.find_opt a !phi_A with Some set -> set | None -> IntSet.empty in
+            if not (IntSet.mem y phi_A_a) then
+              begin
+                begin match graph.nodes.(y) with
+                | Some ((phis, cfnode), preds, succs) ->
+                   graph.nodes.(y) <- Some ((Phi (a, Util.list_init (IntSet.cardinal preds) (fun _ -> a)) :: phis, cfnode), preds, succs)
+                | None -> assert false
+                end;
+                phi_A := Bindings.add a (IntSet.add y phi_A_a) !phi_A;
+                if not (IdSet.mem a (orig_A y)) then
+                  workset := IntSet.add y !workset
+              end
+          ) df.(n)
+      done
+    ) !all_vars
+
+let rename_variables graph root children =
+  let counts = ref Bindings.empty in
+  let stacks = ref Bindings.empty in
+
+  let get_count id =
+    match Bindings.find_opt id !counts with Some n -> n | None -> 0
+  in
+  let top_stack id =
+    match Bindings.find_opt id !stacks with Some (x :: _) -> x | (Some [] | None) -> 0
+  in
+  let push_stack id n =
+    stacks := Bindings.add id (n :: match Bindings.find_opt id !stacks with Some s -> s | None -> []) !stacks
+  in
+
+  let rec fold_frag = function
+    | F_id id ->
+       let i = top_stack id in
+       F_id (append_id id ("_" ^ string_of_int i))
+    | F_ref id ->
+       let i = top_stack id in
+       F_ref (append_id id ("_" ^ string_of_int i))
+    | F_lit vl -> F_lit vl
+    | F_have_exception -> F_have_exception
+    | F_current_exception -> F_current_exception
+    | F_op (f1, op, f2) -> F_op (fold_frag f1, op, fold_frag f2)
+    | F_unary (op, f) -> F_unary (op, fold_frag f)
+    | F_call (id, fs) -> F_call (id, List.map fold_frag fs)
+    | F_field (f, field) -> F_field (fold_frag f, field)
+    | F_raw str -> F_raw str
+    | F_poly f -> F_poly (fold_frag f)
+  in
+
+  let rec fold_clexp = function
+    | CL_id (id, ctyp) ->
+       let i = get_count id + 1 in
+       counts := Bindings.add id i !counts;
+       push_stack id i;
+       CL_id (append_id id ("_" ^ string_of_int i), ctyp)
+    | CL_field (clexp, field) -> CL_field (fold_clexp clexp, field)
+    | CL_addr clexp -> CL_addr (fold_clexp clexp)
+    | CL_tuple (clexp, n) -> CL_tuple (fold_clexp clexp, n)
+    | CL_current_exception ctyp -> CL_current_exception ctyp
+    | CL_have_exception -> CL_have_exception
+    | CL_return ctyp -> CL_return ctyp
+    | CL_void -> CL_void
+  in
+
+  let fold_cval (f, ctyp) = (fold_frag f, ctyp) in
+
+  let ssa_instr (I_aux (aux, annot)) =
+    let aux = match aux with
+      | I_funcall (clexp, extern, id, args) ->
+         let args = List.map fold_cval args in
+         I_funcall (fold_clexp clexp, extern, id, args)
+      | I_copy (clexp, cval) ->
+         let cval = fold_cval cval in
+         I_copy (fold_clexp clexp, cval)
+      | I_decl (ctyp, id) ->
+         let i = get_count id + 1 in
+         counts := Bindings.add id i !counts;
+         push_stack id i;
+         I_decl (ctyp, append_id id ("_" ^ string_of_int i))
+      | I_init (ctyp, id, cval) ->
+         let cval = fold_cval cval in
+         let i = get_count id + 1 in
+         counts := Bindings.add id i !counts;
+         push_stack id i;
+         I_init (ctyp, append_id id ("_" ^ string_of_int i), cval)
+      | instr -> instr
+    in
+    I_aux (aux, annot)
+  in
+
+  let ssa_cfnode = function
+    | CF_start -> CF_start
+    | CF_block instrs -> CF_block (List.map ssa_instr instrs)
+    | CF_label label -> CF_label label
+  in
+
+  let ssa_ssanode = function
+    | Phi (id, args) ->
+       let i = get_count id + 1 in
+       counts := Bindings.add id i !counts;
+       push_stack id i;
+       Phi (append_id id ("_" ^ string_of_int i), args)
+  in
+
+  let fix_phi j = function
+    | Phi (id, ids) ->
+       Phi (id, List.mapi (fun k a ->
+                    if k = j then
+                      let i = top_stack a in
+                      append_id a ("_" ^ string_of_int i)
+                    else a)
+                  ids)
+  in
+
+  let rec rename n =
+    let old_stacks = !stacks in
+    begin match graph.nodes.(n) with
+    | Some ((ssa, cfnode), preds, succs) ->
+       let ssa = List.map ssa_ssanode ssa in
+       graph.nodes.(n) <- Some ((ssa, ssa_cfnode cfnode), preds, succs);
+       List.iter (fun succ ->
+           match graph.nodes.(succ) with
+           | Some ((ssa, cfnode), preds, succs) ->
+              (* Suppose n is the j-th predecessor of succ *)
+              let rec find_j n succ = function
+                | pred :: preds ->
+                   if pred = succ then n else find_j (n + 1) succ preds
+                | [] -> assert false
+              in
+              let j = find_j 0 n (IntSet.elements preds) in
+              graph.nodes.(succ) <- Some ((List.map (fix_phi j) ssa, cfnode), preds, succs)
+           | None -> assert false
+         ) (IntSet.elements succs)
+    | None -> assert false
+    end;
+    IntSet.iter (fun child -> rename child) (children.(n));
+    stacks := old_stacks
+  in
+  rename root
+
+let ssa instrs =
+  let start, finish, cfg = control_flow_graph instrs in
+  let idom = immediate_dominators cfg start in
+  let children = dominator_children idom in
+  let df = dominance_frontiers cfg start idom children in
+  place_phi_functions cfg df;
+  rename_variables cfg start children;
+  cfg
+
+(* Debugging utilities for outputing Graphviz files. *)
+
+let string_of_phis = function
+  | [] -> ""
+  | phis -> Util.string_of_list "\\l" (fun (Phi (id, args)) -> string_of_id id ^ " = phi(" ^ Util.string_of_list ", " string_of_id args ^ ")") phis ^ "\\l"
+
+let string_of_node = function
+  | (phis, CF_label label) -> string_of_phis phis ^ label
+  | (phis, CF_block instrs) -> string_of_phis phis ^ Util.string_of_list "\\l" (fun instr -> String.escaped (Pretty_print_sail.to_string (pp_instr ~short:true instr))) instrs
+  | (phis, CF_start) -> string_of_phis phis ^ "START"
+
+let vertex_color = function
+  | (_, CF_start)   -> "peachpuff"
+  | (_, CF_block _) -> "white"
+  | (_, CF_label _) -> "springgreen"
+
+let edge_color node_from node_to =
+  match node_from, node_to with
+  | CF_block _, CF_block _ -> "black"
+  | CF_label _, CF_block _ -> "red"
+  | CF_block _, CF_label _ -> "blue"
+  | _, _ -> "deeppink"
+
+let make_dot out_chan graph =
+  Util.opt_colors := false;
+  output_string out_chan "digraph DEPS {\n";
+  let make_node i n =
+    output_string out_chan (Printf.sprintf "  n%i [label=\"%s\";shape=box;style=filled;fillcolor=%s];\n" i (string_of_node n) (vertex_color n))
+  in
+  let make_line i s =
+    output_string out_chan (Printf.sprintf "  n%i -> n%i [color=black];\n" i s)
+  in
+  for i = 0 to graph.next - 1 do
+    match graph.nodes.(i) with
+    | Some (n, _, successors) ->
+       make_node i n;
+       IntSet.iter (fun s -> make_line i s) successors
+    | None -> ()
+  done;
+  output_string out_chan "}\n";
+  Util.opt_colors := true
+
+let make_dominators_dot out_chan idom graph =
+  Util.opt_colors := false;
+  output_string out_chan "digraph DOMS {\n";
+  let make_node i n =
+    output_string out_chan (Printf.sprintf "  n%i [label=\"%s\";shape=box;style=filled;fillcolor=%s];\n" i (string_of_node n) (vertex_color n))
+  in
+  let make_line i s =
+    output_string out_chan (Printf.sprintf "  n%i -> n%i [color=black];\n" i s)
+  in
+  for i = 0 to Array.length idom - 1 do
+    match graph.nodes.(i) with
+    | Some (n, _, _) ->
+       if idom.(i) = -1 then
+         make_node i n
+       else
+         (make_node i n; make_line i idom.(i))
+    | None -> ()
+  done;
+  output_string out_chan "}\n";
+  Util.opt_colors := true
diff --git a/src/jib/jib_ssa.mli b/src/jib/jib_ssa.mli
new file mode 100644
index 00000000..3796a114
--- /dev/null
+++ b/src/jib/jib_ssa.mli
@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*     Sail                                                               *)
+(*                                                                        *)
+(*  Copyright (c) 2013-2017                                               *)
+(*    Kathyrn Gray                                                        *)
+(*    Shaked Flur                                                         *)
+(*    Stephen Kell                                                        *)
+(*    Gabriel Kerneis                                                     *)
+(*    Robert Norton-Wright                                                *)
+(*    Christopher Pulte                                                   *)
+(*    Peter Sewell                                                        *)
+(*    Alasdair Armstrong                                                  *)
+(*    Brian Campbell                                                      *)
+(*    Thomas Bauereiss                                                    *)
+(*    Anthony Fox                                                         *)
+(*    Jon French                                                          *)
+(*    Dominic Mulligan                                                    *)
+(*    Stephen Kell                                                        *)
+(*    Mark Wassell                                                        *)
+(*                                                                        *)
+(*  All rights reserved.                                                  *)
+(*                                                                        *)
+(*  This software was developed by the University of Cambridge Computer   *)
+(*  Laboratory as part of the Rigorous Engineering of Mainstream Systems  *)
+(*  (REMS) project, funded by EPSRC grant EP/K008528/1.                   *)
+(*                                                                        *)
+(*  Redistribution and use in source and binary forms, with or without    *)
+(*  modification, are permitted provided that the following conditions    *)
+(*  are met:                                                              *)
+(*  1. Redistributions of source code must retain the above copyright     *)
+(*     notice, this list of conditions and the following disclaimer.      *)
+(*  2. Redistributions in binary form must reproduce the above copyright  *)
+(*     notice, this list of conditions and the following disclaimer in    *)
+(*     the documentation and/or other materials provided with the         *)
+(*     distribution.                                                      *)
+(*                                                                        *)
+(*  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''    *)
+(*  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED     *)
+(*  TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A       *)
+(*  PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR   *)
+(*  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,          *)
+(*  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT      *)
+(*  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF      *)
+(*  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND   *)
+(*  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,    *)
+(*  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT    *)
+(*  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF    *)
+(*  SUCH DAMAGE.                                                          *)
+(**************************************************************************)
+
+open Array
+
+(** A mutable array based graph type, with nodes indexed by integers. *)
+type 'a array_graph
+
+(** Create an empty array_graph, specifying the initial size of the
+   underlying array. *)
+val make : initial_size:int -> unit -> 'a array_graph
+
+(** Add a vertex to a graph, returning the index of the inserted
+   vertex. If the number of vertices exceeds the size of the
+   underlying array, then it is dynamically resized. *)
+val add_vertex : 'a -> 'a array_graph -> int
+
+(** Add an edge between two existing vertices. Raises Invalid_argument
+   if either of the vertices do not exist. *)
+val add_edge : int -> int -> 'a array_graph -> unit
+
+type cf_node =
+  | CF_label of string
+  | CF_block of Jib.instr list
+  | CF_start
+
+val control_flow_graph : Jib.instr list -> int * int list * ('a list * cf_node) array_graph
+
+type ssa_elem =
+  | Phi of Ast.id * Ast.id list
+
+(** Convert a list of instructions into SSA form *)
+val ssa : Jib.instr list -> (ssa_elem list * cf_node) array_graph
+
+(** Output the control-flow graph in graphviz format for
+   debugging. Can use 'dot -Tpng X.gv -o X.png' to generate a png
+   image of the graph. *)
+val make_dot : out_channel -> (ssa_elem list * cf_node) array_graph -> unit
diff --git a/src/bytecode_util.ml b/src/jib/jib_util.ml
index 489bcc64..81cd07ef 100644
--- a/src/bytecode_util.ml
+++ b/src/jib/jib_util.ml
@@ -50,7 +50,7 @@
 
 open Ast
 open Ast_util
-open Bytecode
+open Jib
 open Value2
 open PPrint
 
@@ -94,6 +94,9 @@ let iclear ?loc:(l=Parse_ast.Unknown) ctyp id =
 let ireturn ?loc:(l=Parse_ast.Unknown) cval =
   I_aux (I_return cval, (instr_number (), l))
 
+let iend ?loc:(l=Parse_ast.Unknown) () =
+  I_aux (I_end, (instr_number (), l))
+
 let iblock ?loc:(l=Parse_ast.Unknown) instrs =
   I_aux (I_block instrs, (instr_number (), l))
 
@@ -150,6 +153,8 @@ let rec clexp_rename from_id to_id = function
      CL_tuple (clexp_rename from_id to_id clexp, n)
   | CL_current_exception ctyp -> CL_current_exception ctyp
   | CL_have_exception -> CL_have_exception
+  | CL_return ctyp -> CL_return ctyp
+  | CL_void -> CL_void
 
 let rec instr_rename from_id to_id (I_aux (instr, aux)) =
   let instr = match instr with
@@ -198,6 +203,8 @@ let rec instr_rename from_id to_id (I_aux (instr, aux)) =
 
     | I_match_failure -> I_match_failure
 
+    | I_end -> I_end
+
     | I_reset (ctyp, id) when Id.compare id from_id = 0 -> I_reset (ctyp, to_id)
     | I_reset (ctyp, id) -> I_reset (ctyp, id)
 
@@ -257,8 +264,8 @@ and string_of_ctyp = function
   | CT_lbits false -> "lbits(inc)"
   | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)"
   | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)"
-  | CT_sbits true -> "sbits(dec)"
-  | CT_sbits false -> "sbits(inc)"
+  | CT_sbits (n, true) -> "sbits(" ^ string_of_int n ^ ", dec)"
+  | CT_sbits (n, false) -> "sbits(" ^ string_of_int n ^ ", inc)"
   | CT_fint n -> "int(" ^ string_of_int n ^ ")"
   | CT_bit -> "bit"
   | CT_unit -> "unit"
@@ -276,31 +283,17 @@ and string_of_ctyp = function
 (** This function is like string_of_ctyp, but recursively prints all
    constructors in variants and structs. Used for debug output. *)
 and full_string_of_ctyp = function
-  | CT_lint -> "int"
-  | CT_lbits true -> "lbits(dec)"
-  | CT_lbits false -> "lbits(inc)"
-  | CT_fbits (n, true) -> "fbits(" ^ string_of_int n ^ ", dec)"
-  | CT_fbits (n, false) -> "fbits(" ^ string_of_int n ^ ", int)"
-  | CT_sbits true -> "sbits(dec)"
-  | CT_sbits false -> "sbits(inc)"
-  | CT_fint n -> "int(" ^ string_of_int n ^ ")"
-  | CT_bit -> "bit"
-  | CT_unit -> "unit"
-  | CT_bool -> "bool"
-  | CT_real -> "real"
   | CT_tup ctyps -> "(" ^ Util.string_of_list ", " full_string_of_ctyp ctyps ^ ")"
-  | CT_enum (id, _) -> string_of_id id
   | CT_struct (id, ctors) | CT_variant (id, ctors) ->
      "struct " ^ string_of_id id
      ^ "{ "
      ^ Util.string_of_list ", " (fun (id, ctyp) -> string_of_id id ^ " : " ^ full_string_of_ctyp ctyp) ctors
      ^ "}"
-  | CT_string -> "string"
   | CT_vector (true, ctyp) -> "vector(dec, " ^ full_string_of_ctyp ctyp ^ ")"
   | CT_vector (false, ctyp) -> "vector(inc, " ^ full_string_of_ctyp ctyp ^ ")"
   | CT_list ctyp -> "list(" ^ full_string_of_ctyp ctyp ^ ")"
   | CT_ref ctyp -> "ref(" ^ full_string_of_ctyp ctyp ^ ")"
-  | CT_poly -> "*"
+  | ctyp -> string_of_ctyp ctyp
 
 let rec map_ctyp f = function
   | (CT_lint | CT_fint _ | CT_lbits _ | CT_fbits _ | CT_sbits _
@@ -316,7 +309,7 @@ let rec ctyp_equal ctyp1 ctyp2 =
   match ctyp1, ctyp2 with
   | CT_lint, CT_lint -> true
   | CT_lbits d1, CT_lbits d2 -> d1 = d2
-  | CT_sbits d1, CT_sbits d2 -> d1 = d2
+  | CT_sbits (m1, d1), CT_sbits (m2, d2) -> m1 = m2 && d1 = d2
   | CT_fbits (m1, d1), CT_fbits (m2, d2) -> m1 = m2 && d1 = d2
   | CT_bit, CT_bit -> true
   | CT_fint n, CT_fint m -> n = m
@@ -335,6 +328,75 @@ let rec ctyp_equal ctyp1 ctyp2 =
   | CT_poly, CT_poly -> true
   | _, _ -> false
 
+let rec ctyp_compare ctyp1 ctyp2 =
+  let lex_ord c1 c2 = if c1 = 0 then c2 else c1 in
+  match ctyp1, ctyp2 with
+  | CT_lint, CT_lint -> 0
+  | CT_lint, _ -> 1
+  | _, CT_lint -> -1
+
+  | CT_fint n, CT_fint m -> compare n m
+  | CT_fint _, _ -> 1
+  | _, CT_fint _ -> -1
+
+  | CT_fbits (n, ord1), CT_fbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2)
+  | CT_fbits _, _ -> 1
+  | _, CT_fbits _ -> -1
+
+  | CT_sbits (n, ord1), CT_sbits (m, ord2) -> lex_ord (compare n m) (compare ord1 ord2)
+  | CT_sbits _, _ -> 1
+  | _, CT_sbits _ -> -1
+
+  | CT_lbits ord1 , CT_lbits ord2 -> compare ord1 ord2
+  | CT_lbits _, _ -> 1
+  | _, CT_lbits _ -> -1
+
+  | CT_bit, CT_bit -> 0
+  | CT_bit, _ -> 1
+  | _, CT_bit -> -1
+
+  | CT_unit, CT_unit -> 0
+  | CT_unit, _ -> 1
+  | _, CT_unit -> -1
+
+  | CT_real, CT_real -> 0
+  | CT_real, _ -> 1
+  | _, CT_real -> -1
+
+  | CT_poly, CT_poly -> 0
+  | CT_poly, _ -> 1
+  | _, CT_poly -> -1
+
+  | CT_bool, CT_bool -> 0
+  | CT_bool, _ -> 1
+  | _, CT_bool -> -1
+
+  | CT_string, CT_string -> 0
+  | CT_string, _ -> 1
+  | _, CT_string -> -1
+
+  | CT_ref ctyp1, CT_ref ctyp2 -> ctyp_compare ctyp1 ctyp2
+  | CT_ref _, _ -> 1
+  | _, CT_ref _ -> -1
+
+  | CT_list ctyp1, CT_list ctyp2 -> ctyp_compare ctyp1 ctyp2
+  | CT_list _, _ -> 1
+  | _, CT_list _ -> -1
+
+  | CT_vector (d1, ctyp1), CT_vector (d2, ctyp2) ->
+     lex_ord (ctyp_compare ctyp1 ctyp2) (compare d1 d2)
+  | CT_vector _, _ -> 1
+  | _, CT_vector _ -> -1
+
+  | ctyp1, ctyp2 -> String.compare (full_string_of_ctyp ctyp1) (full_string_of_ctyp ctyp2)
+
+module CT = struct
+  type t = ctyp
+  let compare ctyp1 ctyp2 = ctyp_compare ctyp1 ctyp2
+end
+
+module CTSet = Set.Make(CT)
+
 let rec ctyp_unify ctyp1 ctyp2 =
   match ctyp1, ctyp2 with
   | CT_tup ctyps1, CT_tup ctyps2 when List.length ctyps1 = List.length ctyps2 ->
@@ -356,7 +418,7 @@ let rec ctyp_suprema = function
   | CT_lint -> CT_lint
   | CT_lbits d -> CT_lbits d
   | CT_fbits (_, d) -> CT_lbits d
-  | CT_sbits d -> CT_lbits d
+  | CT_sbits (_, d) -> CT_lbits d
   | CT_fint _ -> CT_lint
   | CT_unit -> CT_unit
   | CT_bool -> CT_bool
@@ -405,7 +467,7 @@ let pp_id id =
   string (string_of_id id)
 
 let pp_ctyp ctyp =
-  string (string_of_ctyp ctyp |> Util.yellow |> Util.clear)
+  string (full_string_of_ctyp ctyp |> Util.yellow |> Util.clear)
 
 let pp_keyword str =
   string ((str |> Util.red |> Util.clear) ^ " ")
@@ -420,6 +482,8 @@ let rec pp_clexp = function
   | CL_addr clexp -> string "*" ^^ pp_clexp clexp
   | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp
   | CL_have_exception -> string "have_exception"
+  | CL_return ctyp -> string "return : " ^^ pp_ctyp ctyp
+  | CL_void -> string "void"
 
 let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) =
   match instr with
@@ -470,6 +534,8 @@ let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) =
      pp_keyword "goto" ^^ string (str |> Util.blue |> Util.clear)
   | I_match_failure ->
      pp_keyword "match_failure"
+  | I_end ->
+     pp_keyword "end"
   | I_undefined ctyp ->
      pp_keyword "undefined" ^^ pp_ctyp ctyp
   | I_raw str ->
@@ -517,178 +583,47 @@ let pp_cdef = function
      ^^ surround 2 0 lbrace (separate_map (semi ^^ hardline) pp_instr instrs) rbrace
      ^^ hardline
 
-(**************************************************************************)
-(* 2. Dependency Graphs                                                   *)
-(**************************************************************************)
-
-type graph_node =
-  | G_id of id
-  | G_label of string
-  | G_instr of int * instr
-  | G_start
-
-let string_of_node = function
-  | G_id id -> string_of_id id
-  | G_label label -> label
-  | G_instr (n, instr) -> string_of_int n ^ ": " ^ Pretty_print_sail.to_string (pp_instr ~short:true instr)
-  | G_start -> "START"
-
-module Node = struct
-  type t = graph_node
-  let compare gn1 gn2 =
-    match gn1, gn2 with
-    | G_id id1, G_id id2 -> Id.compare id1 id2
-    | G_label str1, G_label str2 -> String.compare str1 str2
-    | G_instr (n1, _), G_instr (n2, _) -> compare n1 n2
-    | G_start  , _         -> 1
-    | _        , G_start   -> -1
-    | G_instr _, _         -> 1
-    | _        , G_instr _ -> -1
-    | G_id _   , _         -> 1
-    | _        , G_id _    -> -1
-end
-
-module NM = Map.Make(Node)
-module NS = Set.Make(Node)
-
-type dep_graph = NS.t NM.t
-
 let rec fragment_deps = function
-  | F_id id | F_ref id -> NS.singleton (G_id id)
-  | F_lit _ -> NS.empty
+  | F_id id | F_ref id -> IdSet.singleton id
+  | F_lit _ -> IdSet.empty
   | F_field (frag, _) | F_unary (_, frag) | F_poly frag -> fragment_deps frag
-  | F_call (_, frags) -> List.fold_left NS.union NS.empty (List.map fragment_deps frags)
-  | F_op (frag1, _, frag2) -> NS.union (fragment_deps frag1) (fragment_deps frag2)
-  | F_current_exception -> NS.empty
-  | F_have_exception -> NS.empty
-  | F_raw _ -> NS.empty
+  | F_call (_, frags) -> List.fold_left IdSet.union IdSet.empty (List.map fragment_deps frags)
+  | F_op (frag1, _, frag2) -> IdSet.union (fragment_deps frag1) (fragment_deps frag2)
+  | F_current_exception -> IdSet.empty
+  | F_have_exception -> IdSet.empty
+  | F_raw _ -> IdSet.empty
 
 let cval_deps = function (frag, _) -> fragment_deps frag
 
 let rec clexp_deps = function
-  | CL_id (id, _) -> NS.singleton (G_id id)
+  | CL_id (id, _) -> IdSet.singleton id
   | CL_field (clexp, _) -> clexp_deps clexp
   | CL_tuple (clexp, _) -> clexp_deps clexp
   | CL_addr clexp -> clexp_deps clexp
-  | CL_have_exception -> NS.empty
-  | CL_current_exception _ -> NS.empty
+  | CL_have_exception -> IdSet.empty
+  | CL_current_exception _ -> IdSet.empty
+  | CL_return _ -> IdSet.empty
+  | CL_void -> IdSet.empty
 
-(** Return the direct, non program-order dependencies of a single
-   instruction **)
+(* Return the direct, read/write dependencies of a single instruction *)
 let instr_deps = function
-  | I_decl (ctyp, id) -> NS.empty, NS.singleton (G_id id)
-  | I_reset (ctyp, id) -> NS.empty, NS.singleton (G_id id)
-  | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, NS.singleton (G_id id)
-  | I_if (cval, _, _, _) -> cval_deps cval, NS.empty
-  | I_jump (cval, label) -> cval_deps cval, NS.singleton (G_label label)
-  | I_funcall (clexp, _, _, cvals) -> List.fold_left NS.union NS.empty (List.map cval_deps cvals), clexp_deps clexp
+  | I_decl (ctyp, id) -> IdSet.empty, IdSet.singleton id
+  | I_reset (ctyp, id) -> IdSet.empty, IdSet.singleton id
+  | I_init (ctyp, id, cval) | I_reinit (ctyp, id, cval) -> cval_deps cval, IdSet.singleton id
+  | I_if (cval, _, _, _) -> cval_deps cval, IdSet.empty
+  | I_jump (cval, label) -> cval_deps cval, IdSet.empty
+  | I_funcall (clexp, _, _, cvals) -> List.fold_left IdSet.union IdSet.empty (List.map cval_deps cvals), clexp_deps clexp
   | I_copy (clexp, cval) -> cval_deps cval, clexp_deps clexp
   | I_alias (clexp, cval) -> cval_deps cval, clexp_deps clexp
-  | I_clear (_, id) -> NS.singleton (G_id id), NS.singleton (G_id id)
-  | I_throw cval | I_return cval -> cval_deps cval, NS.empty
-  | I_block _ | I_try_block _ -> NS.empty, NS.empty
-  | I_comment _ | I_raw _ -> NS.empty, NS.empty
-  | I_label label -> NS.singleton (G_label label), NS.empty
-  | I_goto label -> NS.empty, NS.singleton (G_label label)
-  | I_undefined _ -> NS.empty, NS.empty
-  | I_match_failure -> NS.empty, NS.empty
-
-let add_link from_node to_node graph =
-  try
-    NM.add from_node (NS.add to_node (NM.find from_node graph)) graph
-  with
-  | Not_found -> NM.add from_node (NS.singleton to_node) graph
-
-let leaves graph =
-  List.fold_left (fun acc (from_node, to_nodes) -> NS.filter (fun to_node -> Node.compare to_node from_node != 0) (NS.union acc to_nodes))
-                 NS.empty
-                 (NM.bindings graph)
-
-(* Ensure that all leaves exist in the graph *)
-let fix_leaves graph =
-  NS.fold (fun leaf graph -> if NM.mem leaf graph then graph else NM.add leaf NS.empty graph) (leaves graph) graph
-
-let instrs_graph instrs =
-  let icounter = ref 0 in
-  let graph = ref NM.empty in
-
-  let rec add_instr last_instr (I_aux (instr, _) as iaux) =
-    incr icounter;
-    let node = G_instr (!icounter, iaux) in
-    match instr with
-    | I_block instrs | I_try_block instrs ->
-       List.fold_left add_instr last_instr instrs
-    | I_if (_, then_instrs, else_instrs, _) ->
-       begin
-         let inputs, _ = instr_deps instr in (* if has no outputs *)
-         graph := add_link last_instr node !graph;
-         NS.iter (fun input -> graph := add_link input node !graph) inputs;
-         let n1 = List.fold_left add_instr node then_instrs in
-         let n2 = List.fold_left add_instr node else_instrs in
-         incr icounter;
-         let join = G_instr (!icounter, icomment "join") in
-         graph := add_link n1 join !graph;
-         graph := add_link n2 join !graph;
-         join
-       end
-    | I_goto label ->
-       begin
-         let _, outputs = instr_deps instr in
-         graph := add_link last_instr node !graph;
-         NS.iter (fun output -> graph := add_link node output !graph) outputs;
-         incr icounter;
-         G_instr (!icounter, icomment "after goto")
-       end
-    | _ ->
-       begin
-         let inputs, outputs = instr_deps instr in
-         graph := add_link last_instr node !graph;
-         NS.iter (fun input -> graph := add_link input node !graph) inputs;
-         NS.iter (fun output -> graph := add_link node output !graph) outputs;
-         node
-       end
-  in
-  ignore (List.fold_left add_instr G_start instrs);
-  fix_leaves !graph
-
-let make_dot id graph =
-  Util.opt_colors := false;
-  let to_string node = String.escaped (string_of_node node) in
-  let node_color = function
-    | G_start                           -> "lightpink"
-    | G_id _                            -> "yellow"
-    | G_instr (_, I_aux (I_decl _, _))  -> "olivedrab1"
-    | G_instr (_, I_aux (I_init _, _))  -> "springgreen"
-    | G_instr (_, I_aux (I_clear _, _)) -> "peachpuff"
-    | G_instr (_, I_aux (I_goto _, _))  -> "orange1"
-    | G_instr (_, I_aux (I_label _, _)) -> "white"
-    | G_instr (_, I_aux (I_raw _, _))   -> "khaki"
-    | G_instr _                         -> "azure"
-    | G_label _                         -> "lightpink"
-  in
-  let edge_color from_node to_node =
-    match from_node, to_node with
-    | G_start  , _         -> "goldenrod4"
-    | G_label _, _         -> "darkgreen"
-    | _        , G_label _ -> "goldenrod4"
-    | G_instr _, G_instr _ -> "black"
-    | G_id _   , G_instr _ -> "blue3"
-    | G_instr _, G_id _    -> "red3"
-    | _        , _         -> "coral3"
-  in
-  let out_chan = open_out (Util.zencode_string (string_of_id id) ^ ".gv") in
-  output_string out_chan "digraph DEPS {\n";
-  let make_node from_node =
-    output_string out_chan (Printf.sprintf "  \"%s\" [fillcolor=%s;style=filled];\n" (to_string from_node) (node_color from_node))
-  in
-  let make_line from_node to_node =
-    output_string out_chan (Printf.sprintf "  \"%s\" -> \"%s\" [color=%s];\n" (to_string from_node) (to_string to_node) (edge_color from_node to_node))
-  in
-  NM.bindings graph |> List.iter (fun (from_node, _) -> make_node from_node);
-  NM.bindings graph |> List.iter (fun (from_node, to_nodes) -> NS.iter (make_line from_node) to_nodes);
-  output_string out_chan "}\n";
-  Util.opt_colors := true;
-  close_out out_chan
+  | I_clear (_, id) -> IdSet.singleton id, IdSet.empty
+  | I_throw cval | I_return cval -> cval_deps cval, IdSet.empty
+  | I_block _ | I_try_block _ -> IdSet.empty, IdSet.empty
+  | I_comment _ | I_raw _ -> IdSet.empty, IdSet.empty
+  | I_label label -> IdSet.empty, IdSet.empty
+  | I_goto label -> IdSet.empty, IdSet.empty
+  | I_undefined _ -> IdSet.empty, IdSet.empty
+  | I_match_failure -> IdSet.empty, IdSet.empty
+  | I_end -> IdSet.empty, IdSet.empty
 
 let rec map_clexp_ctyp f = function
   | CL_id (id, ctyp) -> CL_id (id, f ctyp)
@@ -697,6 +632,8 @@ let rec map_clexp_ctyp f = function
   | CL_addr clexp -> CL_addr (map_clexp_ctyp f clexp)
   | CL_current_exception ctyp -> CL_current_exception (f ctyp)
   | CL_have_exception -> CL_have_exception
+  | CL_return ctyp -> CL_return (f ctyp)
+  | CL_void -> CL_void
 
 let rec map_instr_ctyp f (I_aux (instr, aux)) =
   let instr = match instr with
@@ -717,6 +654,7 @@ let rec map_instr_ctyp f (I_aux (instr, aux)) =
     | I_undefined ctyp -> I_undefined (f ctyp)
     | I_reset (ctyp, id) -> I_reset (f ctyp, id)
     | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2))
+    | I_end -> I_end
     | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr
   in
   I_aux (instr, aux)
@@ -726,7 +664,7 @@ let rec map_instr f (I_aux (instr, aux)) =
   let instr = match instr with
     | I_decl _ | I_init _ | I_reset _ | I_reinit _
       | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _
-      | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr
+      | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> instr
     | I_if (cval, instrs1, instrs2, ctyp) ->
        I_if (cval, List.map (map_instr f) instrs1, List.map (map_instr f) instrs2, ctyp)
     | I_block instrs ->
@@ -736,6 +674,18 @@ let rec map_instr f (I_aux (instr, aux)) =
   in
   f (I_aux (instr, aux))
 
+(** Iterate over each instruction within an instruction, bottom-up *)
+let rec iter_instr f (I_aux (instr, aux)) =
+  match instr with
+  | I_decl _ | I_init _ | I_reset _ | I_reinit _
+    | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _
+    | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ | I_end -> f (I_aux (instr, aux))
+  | I_if (cval, instrs1, instrs2, ctyp) ->
+     List.iter (iter_instr f) instrs1;
+     List.iter (iter_instr f) instrs2
+  | I_block instrs | I_try_block instrs ->
+     List.iter (iter_instr f) instrs
+
 (** Map over each instruction in a cdef using map_instr *)
 let cdef_map_instr f = function
   | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, ctyp, List.map (map_instr f) instrs)
@@ -770,42 +720,25 @@ let rec map_instrs f (I_aux (instr, aux)) =
     | I_funcall _ | I_copy _ | I_alias _ | I_clear _ | I_jump _ | I_throw _ | I_return _ -> instr
     | I_block instrs -> I_block (f (List.map (map_instrs f) instrs))
     | I_try_block instrs -> I_try_block (f (List.map (map_instrs f) instrs))
-    | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _ -> instr
+    | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_undefined _  | I_end -> instr
   in
   I_aux (instr, aux)
 
+let map_instr_list f instrs =
+  List.map (map_instr f) instrs
+
+let map_instrs_list f instrs =
+  f (List.map (map_instrs f) instrs)
+
 let rec instr_ids (I_aux (instr, _)) =
   let reads, writes = instr_deps instr in
-  let get_id = function
-    | G_id id -> Some id
-    | _ -> None
-  in
-  NS.elements reads @ NS.elements writes
-  |> List.map get_id
-  |> Util.option_these
-  |> IdSet.of_list
+  IdSet.union reads writes
 
 let rec instr_reads (I_aux (instr, _)) =
-  let reads, _ = instr_deps instr in
-  let get_id = function
-    | G_id id -> Some id
-    | _ -> None
-  in
-  NS.elements reads
-  |> List.map get_id
-  |> Util.option_these
-  |> IdSet.of_list
+  fst (instr_deps instr)
 
 let rec instr_writes (I_aux (instr, _)) =
-  let _, writes = instr_deps instr in
-  let get_id = function
-    | G_id id -> Some id
-    | _ -> None
-  in
-  NS.elements writes
-  |> List.map get_id
-  |> Util.option_these
-  |> IdSet.of_list
+  snd (instr_deps instr)
 
 let rec filter_instrs f instrs =
   let filter_instrs' = function
@@ -816,3 +749,126 @@ let rec filter_instrs f instrs =
     | instr -> instr
   in
   List.filter f (List.map filter_instrs' instrs)
+
+(** GLOBAL: label_counter is used to make sure all labels have unique
+   names. Like gensym_counter it should be safe to reset between
+   top-level definitions. **)
+let label_counter = ref 0
+
+let label str =
+  let str = str ^ string_of_int !label_counter in
+  incr label_counter;
+  str
+
+let cval_ctyp = function (_, ctyp) -> ctyp
+
+let rec clexp_ctyp = function
+  | CL_id (_, ctyp) -> ctyp
+  | CL_return ctyp -> ctyp
+  | CL_field (clexp, field) ->
+     begin match clexp_ctyp clexp with
+     | CT_struct (id, ctors) ->
+        begin
+          try snd (List.find (fun (id, ctyp) -> string_of_id id = field) ctors) with
+          | Not_found -> failwith ("Struct type " ^ string_of_id id ^ " does not have a constructor " ^ field)
+        end
+     | ctyp -> failwith ("Bad ctyp for CL_field " ^ string_of_ctyp ctyp)
+     end
+  | CL_addr clexp ->
+     begin match clexp_ctyp clexp with
+     | CT_ref ctyp -> ctyp
+     | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp)
+     end
+  | CL_tuple (clexp, n) ->
+     begin match clexp_ctyp clexp with
+     | CT_tup typs ->
+        begin
+          try List.nth typs n with
+          | _ -> failwith "Tuple assignment index out of bounds"
+        end
+     | ctyp -> failwith ("Bad ctyp for CL_addr " ^ string_of_ctyp ctyp)
+     end
+  | CL_have_exception -> CT_bool
+  | CL_current_exception ctyp -> ctyp
+  | CL_void -> CT_unit
+
+let rec instr_ctyps (I_aux (instr, aux)) =
+  match instr with
+  | I_decl (ctyp, _) | I_reset (ctyp, _) | I_clear (ctyp, _) | I_undefined ctyp ->
+     CTSet.singleton ctyp
+  | I_init (ctyp, _, cval) | I_reinit (ctyp, _, cval) ->
+     CTSet.add ctyp (CTSet.singleton (cval_ctyp cval))
+  | I_if (cval, instrs1, instrs2, ctyp) ->
+     CTSet.union (instrs_ctyps instrs1) (instrs_ctyps instrs2)
+     |> CTSet.add (cval_ctyp cval)
+     |> CTSet.add ctyp
+  | I_funcall (clexp, _, _, cvals) ->
+     List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map cval_ctyp cvals)
+     |> CTSet.add (clexp_ctyp clexp)
+  | I_copy (clexp, cval) | I_alias (clexp, cval) ->
+     CTSet.add (clexp_ctyp clexp) (CTSet.singleton (cval_ctyp cval))
+  | I_block instrs | I_try_block instrs ->
+     instrs_ctyps instrs
+  | I_throw cval | I_jump (cval, _) | I_return cval ->
+     CTSet.singleton (cval_ctyp cval)
+  | I_comment _ | I_label _ | I_goto _ | I_raw _ | I_match_failure | I_end ->
+     CTSet.empty
+
+and instrs_ctyps instrs = List.fold_left CTSet.union CTSet.empty (List.map instr_ctyps instrs)
+
+let ctype_def_ctyps = function
+  | CTD_enum _ -> []
+  | CTD_struct (_, fields) -> List.map snd fields
+  | CTD_variant (_, ctors) -> List.map snd ctors
+
+let cdef_ctyps = function
+  | CDEF_reg_dec (_, ctyp, instrs) ->
+     CTSet.add ctyp (instrs_ctyps instrs)
+  | CDEF_spec (_, ctyps, ctyp) ->
+     CTSet.add ctyp (List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty ctyps)
+  | CDEF_fundef (_, _, _, instrs) | CDEF_startup (_, instrs) | CDEF_finish (_, instrs) ->
+     instrs_ctyps instrs
+  | CDEF_type tdef ->
+     List.fold_right CTSet.add (ctype_def_ctyps tdef) CTSet.empty
+  | CDEF_let (_, bindings, instrs) ->
+     List.fold_left (fun m ctyp -> CTSet.add ctyp m) CTSet.empty (List.map snd bindings)
+     |> CTSet.union (instrs_ctyps instrs)
+
+let rec c_ast_registers = function
+  | CDEF_reg_dec (id, ctyp, instrs) :: ast -> (id, ctyp, instrs) :: c_ast_registers ast
+  | _ :: ast -> c_ast_registers ast
+  | [] -> []
+
+let instr_split_at f =
+  let rec instr_split_at' f before = function
+    | [] -> (List.rev before, [])
+    | instr :: instrs when f instr -> (List.rev before, instr :: instrs)
+    | instr :: instrs -> instr_split_at' f (instr :: before) instrs
+  in
+  instr_split_at' f []
+
+let rec instrs_rename from_id to_id =
+  let rename id = if Id.compare id from_id = 0 then to_id else id in
+  let crename = cval_rename from_id to_id in
+  let irename instrs = instrs_rename from_id to_id instrs in
+  let lrename = clexp_rename from_id to_id in
+  function
+  | (I_aux (I_decl (ctyp, new_id), _) :: _) as instrs when Id.compare from_id new_id = 0 -> instrs
+  | I_aux (I_decl (ctyp, new_id), aux) :: instrs -> I_aux (I_decl (ctyp, new_id), aux) :: irename instrs
+  | I_aux (I_reset (ctyp, id), aux) :: instrs -> I_aux (I_reset (ctyp, rename id), aux) :: irename instrs
+  | I_aux (I_init (ctyp, id, cval), aux) :: instrs -> I_aux (I_init (ctyp, rename id, crename cval), aux) :: irename instrs
+  | I_aux (I_reinit (ctyp, id, cval), aux) :: instrs -> I_aux (I_reinit (ctyp, rename id, crename cval), aux) :: irename instrs
+  | I_aux (I_if (cval, then_instrs, else_instrs, ctyp), aux) :: instrs ->
+     I_aux (I_if (crename cval, irename then_instrs, irename else_instrs, ctyp), aux) :: irename instrs
+  | I_aux (I_jump (cval, label), aux) :: instrs -> I_aux (I_jump (crename cval, label), aux) :: irename instrs
+  | I_aux (I_funcall (clexp, extern, id, cvals), aux) :: instrs ->
+     I_aux (I_funcall (lrename clexp, extern, rename id, List.map crename cvals), aux) :: irename instrs
+  | I_aux (I_copy (clexp, cval), aux) :: instrs -> I_aux (I_copy (lrename clexp, crename cval), aux) :: irename instrs
+  | I_aux (I_alias (clexp, cval), aux) :: instrs -> I_aux (I_alias (lrename clexp, crename cval), aux) :: irename instrs
+  | I_aux (I_clear (ctyp, id), aux) :: instrs -> I_aux (I_clear (ctyp, rename id), aux) :: irename instrs
+  | I_aux (I_return cval, aux) :: instrs -> I_aux (I_return (crename cval), aux) :: irename instrs
+  | I_aux (I_block block, aux) :: instrs -> I_aux (I_block (irename block), aux) :: irename instrs
+  | I_aux (I_try_block block, aux) :: instrs -> I_aux (I_try_block (irename block), aux) :: irename instrs
+  | I_aux (I_throw cval, aux) :: instrs -> I_aux (I_throw (crename cval), aux) :: irename instrs
+  | (I_aux ((I_comment _ | I_raw _ | I_end | I_label _ | I_goto _ | I_match_failure | I_undefined _), _) as instr) :: instrs -> instr :: irename instrs
+  | [] -> []
diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/lem_interp/sail2_instr_kinds.lem
index eadc85bf..bd3a3eb7 100644
--- a/src/lem_interp/sail2_instr_kinds.lem
+++ b/src/lem_interp/sail2_instr_kinds.lem
@@ -203,6 +203,30 @@ instance (Show trans_kind)
   end
 end
 
+(* cache maintenance instructions *)
+type cache_op_kind =
+  (* AArch64 DC *)
+  | Cache_op_D_IVAC | Cache_op_D_ISW  | Cache_op_D_CSW  |  Cache_op_D_CISW
+  | Cache_op_D_ZVA  | Cache_op_D_CVAC | Cache_op_D_CVAU | Cache_op_D_CIVAC
+  (* AArch64 IC *)
+  | Cache_op_I_IALLUIS | Cache_op_I_IALLU | Cache_op_I_IVAU
+
+instance (Show cache_op_kind)
+  let show = function
+  | Cache_op_D_IVAC    -> "Cache_op_D_IVAC"
+  | Cache_op_D_ISW     -> "Cache_op_D_ISW"
+  | Cache_op_D_CSW     -> "Cache_op_D_CSW"
+  | Cache_op_D_CISW    -> "Cache_op_D_CISW"
+  | Cache_op_D_ZVA     -> "Cache_op_D_ZVA"
+  | Cache_op_D_CVAC    -> "Cache_op_D_CVAC"
+  | Cache_op_D_CVAU    -> "Cache_op_D_CVAU"
+  | Cache_op_D_CIVAC   -> "Cache_op_D_CIVAC"
+  | Cache_op_I_IALLUIS -> "Cache_op_I_IALLUIS"
+  | Cache_op_I_IALLU   -> "Cache_op_I_IALLU"
+  | Cache_op_I_IVAU    -> "Cache_op_I_IVAU"
+  end
+end
+
 type instruction_kind =
   | IK_barrier   of barrier_kind
   | IK_mem_read  of read_kind
@@ -213,6 +237,7 @@ type instruction_kind =
   and branch/jump (single nia of kind NIA_concrete_address) *)
   | IK_trans     of trans_kind
   | IK_simple    of unit
+  | IK_cache_op  of cache_op_kind
 
 
 instance (Show instruction_kind)
@@ -224,6 +249,7 @@ instance (Show instruction_kind)
     | IK_branch ()            -> "IK_branch"
     | IK_trans trans_kind     -> "IK_trans " ^ (show trans_kind)
     | IK_simple ()            -> "IK_simple"
+    | IK_cache_op cache_kind  -> "IK_cache_op " ^ (show cache_kind)
   end
 end
 
diff --git a/src/libsail.mllib b/src/libsail.mllib
index c85ddba3..d4125d68 100644
--- a/src/libsail.mllib
+++ b/src/libsail.mllib
@@ -3,8 +3,6 @@ Ast
 Ast_util
 Bitfield
 Bytecode
-Bytecode_interpreter
-Bytecode_util
 C_backend
 Cgen_backend
 Constant_fold
@@ -16,6 +14,7 @@ Initial_check
 Interactive
 Interpreter
 Isail
+Jib
 Latex
 Lexer
 Manifest
diff --git a/src/monomorphise.ml b/src/monomorphise.ml
index 9b954611..9f82bb17 100644
--- a/src/monomorphise.ml
+++ b/src/monomorphise.ml
@@ -81,75 +81,6 @@ let kbindings_union s1 s2 =
   |  (Some x), _ -> Some x
   |  _,  _ -> None) s1 s2
 
-let subst_nexp substs nexp =
-  let rec s_snexp substs (Nexp_aux (ne,l) as nexp) =
-    let re ne = Nexp_aux (ne,l) in
-    let s_snexp = s_snexp substs in
-    match ne with
-    | Nexp_var (Kid_aux (_,l) as kid) ->
-       (try KBindings.find kid substs
-       with Not_found -> nexp)
-    | Nexp_id _
-    | Nexp_constant _ -> nexp
-    | Nexp_times (n1,n2) -> re (Nexp_times (s_snexp n1, s_snexp n2))
-    | Nexp_sum (n1,n2)   -> re (Nexp_sum   (s_snexp n1, s_snexp n2))
-    | Nexp_minus (n1,n2) -> re (Nexp_minus (s_snexp n1, s_snexp n2))
-    | Nexp_exp ne -> re (Nexp_exp (s_snexp ne))
-    | Nexp_neg ne -> re (Nexp_neg (s_snexp ne))
-    | Nexp_app (id,args) -> re (Nexp_app (id,List.map s_snexp args))
-  in s_snexp substs nexp
-
-let 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
-    | 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 _
-    | Typ_var _
-      -> ty
-    | Typ_fn (t1,t2,e) -> re (Typ_fn (List.map (s_styp substs) t1, s_styp substs t2,e))
-    | Typ_bidir (t1, t2) -> re (Typ_bidir (s_styp substs t1, s_styp substs t2))
-    | Typ_tup ts -> re (Typ_tup (List.map (s_styp substs) ts))
-    | Typ_app (id,tas) -> re (Typ_app (id,List.map (s_starg substs) tas))
-    | Typ_exist (kopts,nc,t) ->
-       let substs = List.fold_left (fun sub kopt -> KBindings.remove (kopt_kid kopt) sub) substs kopts in
-       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
-    | 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
-    | 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
   let s = String.init sz f in
@@ -164,50 +95,6 @@ let tabulate f n =
 let make_vectors sz =
   tabulate (make_vector_lit sz) (Big_int.shift_left (Big_int.of_int 1) sz)
 
-let pat_id_is_variable env id =
-  match Env.lookup_id id env with
-  (* Unbound is returned for both variables and constructors which take
-     arguments, but the latter only don't appear in a P_id *)
-  | Unbound
-  (* Shadowing of immutable locals is allowed; mutable locals and registers
-     are rejected by the type checker, so don't matter *)
-  | Local _
-  | Register _
-    -> true
-  | Enum _ -> false
-
-let rec is_value (E_aux (e,(l,annot))) =
-  let is_constructor id =
-    match destruct_tannot annot with
-    | None ->
-       (Reporting.print_err l "Monomorphisation"
-          ("Missing type information for identifier " ^ string_of_id id);
-        false) (* Be conservative if we have no info *)
-    | Some (env,_,_) ->
-       Env.is_union_constructor id env ||
-         (match Env.lookup_id id env with
-         | Enum _ -> true
-         | Unbound | Local _ | Register _ -> false)
-  in
-  match e with
-  | E_id id -> is_constructor id
-  | E_lit _ -> true
-  | E_tuple es -> List.for_all is_value es
-  | E_app (id,es) -> is_constructor id && List.for_all is_value es
-  (* We add casts to undefined to keep the type information in the AST *)
-  | E_cast (typ,E_aux (E_lit (L_aux (L_undef,_)),_)) -> true
-(* TODO: more? *)
-  | _ -> false
-
-let is_pure e =
-  match e with
-  | Effect_aux (Effect_set [],_) -> true
-  | _ -> false
-
-let rec list_extract f = function
-  | [] -> None
-  | h::t -> match f h with None -> list_extract f t | Some v -> Some v
-
 let rec cross = function
   | [] -> failwith "cross"
   | [(x,l)] -> List.map (fun y -> [(x,y)]) l
@@ -232,33 +119,9 @@ let kidset_bigunion = function
   | [] -> KidSet.empty
   | h::t -> List.fold_left KidSet.union h t
 
-let rec flatten_constraints = function
-  | [] -> []
-  | (NC_aux (NC_and (nc1,nc2),_))::t -> flatten_constraints (nc1::nc2::t)
-  | h::t -> h::(flatten_constraints t)
-
-(* NB: this only looks for direct equalities with the given kid.  It would be
-   better in principle to find the entire set of equal kids, but it isn't
-   necessary to deal with the fresh kids produced by the type checker while
-   checking P_var patterns, so we don't do it for now. *)
-let equal_kids_ncs kid ncs =
-  let is_eq = function
-    | NC_aux (NC_equal (Nexp_aux (Nexp_var var1,_), Nexp_aux (Nexp_var var2,_)),_) ->
-       if Kid.compare kid var1 == 0 then Some var2 else
-         if Kid.compare kid var2 == 0 then Some var1 else
-           None
-    | _ -> None
-  in
-  let kids = Util.map_filter is_eq ncs in
-  List.fold_left (fun s k -> KidSet.add k s) (KidSet.singleton kid) kids
-
-let equal_kids env kid =
-  let ncs = flatten_constraints (Env.get_constraints env) in
-  equal_kids_ncs kid ncs
-
 (* TODO: deal with non-set constraints, intersections, etc somehow *)
 let extract_set_nc l var nc =
-  let vars = equal_kids_ncs var [nc] in
+  let vars = Spec_analysis.equal_kids_ncs var [nc] in
   let rec aux_or (NC_aux (nc,l)) =
     match nc with
     | NC_equal (Nexp_aux (Nexp_var id,_), Nexp_aux (Nexp_constant n,_))
@@ -306,7 +169,7 @@ let apply_kid_insts kid_insts t =
   let kid_insts, kids' = split_insts kid_insts in
   let kid_insts = List.map (fun (v,i) -> (v,Nexp_aux (Nexp_constant i,Generated Unknown))) kid_insts in
   let subst = kbindings_from_list kid_insts in
-  kids', subst_src_typ subst t
+  kids', subst_kids_typ subst t
 
 let rec inst_src_type insts (Typ_aux (ty,l) as typ) =
   match ty with
@@ -555,374 +418,6 @@ let refine_constructor refinements l env id args =
   | exception Not_found -> None
 
 
-(* Substitute found nexps for variables in an expression, and rename constructors to reflect
-   specialisation *)
-
-(* TODO: kid shadowing *)
-let nexp_subst_fns substs =
-
-  let s_t t = subst_src_typ substs t in
-(*  let s_typschm (TypSchm_aux (TypSchm_ts (q,t),l)) = TypSchm_aux (TypSchm_ts (q,s_t t),l) in
-   hopefully don't need this anyway *)(*
-  let s_typschm tsh = tsh in*)
-  let s_tannot tannot =
-    match destruct_tannot tannot with
-    | None -> empty_tannot
-    | Some (env,t,eff) -> mk_tannot env (s_t t) eff (* TODO: what about env? *)
-  in
-  let rec s_pat (P_aux (p,(l,annot))) =
-    let re p = P_aux (p,(l,s_tannot annot)) in
-    match p with
-    | P_lit _ | P_wild | P_id _ -> re p
-    | P_or (p1, p2) -> re (P_or (s_pat p1, s_pat p2))
-    | P_not (p) -> re (P_not (s_pat p))
-    | P_var (p',tpat) -> re (P_var (s_pat p',tpat))
-    | P_as (p',id) -> re (P_as (s_pat p', id))
-    | P_typ (ty,p') -> re (P_typ (s_t ty,s_pat p'))
-    | P_app (id,ps) -> re (P_app (id, List.map s_pat ps))
-    | P_record (fps,flag) -> re (P_record (List.map s_fpat fps, flag))
-    | P_vector ps -> re (P_vector (List.map s_pat ps))
-    | P_vector_concat ps -> re (P_vector_concat (List.map s_pat ps))
-    | P_string_append ps -> re (P_string_append (List.map s_pat ps))
-    | P_tup ps -> re (P_tup (List.map s_pat ps))
-    | P_list ps -> re (P_list (List.map s_pat ps))
-    | P_cons (p1,p2) -> re (P_cons (s_pat p1, s_pat p2))
-  and s_fpat (FP_aux (FP_Fpat (id, p), (l,annot))) =
-    FP_aux (FP_Fpat (id, s_pat p), (l,s_tannot annot))
-  in
-  let rec s_exp (E_aux (e,(l,annot))) =
-    let re e = E_aux (e,(l,s_tannot annot)) in
-      match e with
-      | E_block es -> re (E_block (List.map s_exp es))
-      | E_nondet es -> re (E_nondet (List.map s_exp es))
-      | E_id _
-      | E_ref _
-      | E_lit _
-      | E_internal_value _
-        -> re e
-      | E_sizeof ne -> begin
-         let ne' = subst_nexp substs ne in
-         match ne' with
-         | Nexp_aux (Nexp_constant i,l) -> re (E_lit (L_aux (L_num i,l)))
-         | _ -> re (E_sizeof ne')
-      end
-      | E_constraint nc -> re (E_constraint (subst_nc substs nc))
-      | E_cast (t,e') -> re (E_cast (s_t t, s_exp e'))
-      | E_app (id,es) -> re (E_app (id, List.map s_exp es))
-      | E_app_infix (e1,id,e2) -> re (E_app_infix (s_exp e1,id,s_exp e2))
-      | E_tuple es -> re (E_tuple (List.map s_exp es))
-      | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3))
-      | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4))
-      | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2))
-      | E_vector es -> re (E_vector (List.map s_exp es))
-      | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2))
-      | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3))
-      | E_vector_update (e1,e2,e3) -> re (E_vector_update (s_exp e1,s_exp e2,s_exp e3))
-      | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (s_exp e1,s_exp e2,s_exp e3,s_exp e4))
-      | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2))
-      | E_list es -> re (E_list (List.map s_exp es))
-      | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2))
-      | E_record fes -> re (E_record (List.map s_fexp fes))
-      | E_record_update (e,fes) -> re (E_record_update (s_exp e, List.map s_fexp fes))
-      | E_field (e,id) -> re (E_field (s_exp e,id))
-      | E_case (e,cases) -> re (E_case (s_exp e, List.map s_pexp cases))
-      | E_let (lb,e) -> re (E_let (s_letbind lb, s_exp e))
-      | E_assign (le,e) -> re (E_assign (s_lexp le, s_exp e))
-      | E_exit e -> re (E_exit (s_exp e))
-      | E_return e -> re (E_return (s_exp e))
-      | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2))
-      | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2))
-      | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2))
-      | E_internal_return e -> re (E_internal_return (s_exp e))
-      | E_throw e -> re (E_throw (s_exp e))
-      | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases))
-    and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) =
-      FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot))
-    and s_pexp = function
-      | (Pat_aux (Pat_exp (p,e),(l,annot))) ->
-         Pat_aux (Pat_exp (s_pat p, s_exp e),(l,s_tannot annot))
-      | (Pat_aux (Pat_when (p,e1,e2),(l,annot))) ->
-         Pat_aux (Pat_when (s_pat p, s_exp e1, s_exp e2),(l,s_tannot annot))
-    and s_letbind (LB_aux (lb,(l,annot))) =
-      match lb with
-      | LB_val (p,e) -> LB_aux (LB_val (s_pat p,s_exp e), (l,s_tannot annot))
-    and s_lexp (LEXP_aux (e,(l,annot))) =
-      let re e = LEXP_aux (e,(l,s_tannot annot)) in
-      match e with
-      | LEXP_id _ -> re e
-      | LEXP_cast (typ,id) -> re (LEXP_cast (s_t typ, id))
-      | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map s_exp es))
-      | LEXP_tup les -> re (LEXP_tup (List.map s_lexp les))
-      | LEXP_vector (le,e) -> re (LEXP_vector (s_lexp le, s_exp e))
-      | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (s_lexp le, s_exp e1, s_exp e2))
-      | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map s_lexp les))
-      | LEXP_field (le,id) -> re (LEXP_field (s_lexp le, id))
-      | LEXP_deref e -> re (LEXP_deref (s_exp e))
-  in (s_pat,s_exp)
-let nexp_subst_pat substs = fst (nexp_subst_fns substs)
-let nexp_subst_exp substs = snd (nexp_subst_fns substs)
-
-let bindings_from_pat p =
-  let rec aux_pat (P_aux (p,(l,annot))) =
-    let env = Type_check.env_of_annot (l, annot) in
-    match p with
-    | P_lit _
-    | P_wild
-      -> []
-    | P_or (p1, p2) -> aux_pat p1 @ aux_pat p2
-    | P_not (p) -> aux_pat p
-    | P_as (p,id) -> id::(aux_pat p)
-    | P_typ (_,p) -> aux_pat p
-    | P_id id ->
-       if pat_id_is_variable env id then [id] else []
-    | P_var (p,kid) -> aux_pat p
-    | P_vector ps
-    | P_vector_concat ps
-    | P_string_append ps
-    | P_app (_,ps)
-    | P_tup ps
-    | P_list ps
-      -> List.concat (List.map aux_pat ps)
-    | P_record (fps,_) -> List.concat (List.map aux_fpat fps)
-    | P_cons (p1,p2) -> aux_pat p1 @ aux_pat p2
-  and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p
-  in aux_pat p
-
-let remove_bound (substs,ksubsts) pat =
-  let bound = bindings_from_pat pat in
-  List.fold_left (fun sub v -> Bindings.remove v sub) substs bound, ksubsts
-
-(* Attempt simple pattern matches *)
-let lit_match = function
-  | (L_zero | L_false), (L_zero | L_false) -> true
-  | (L_one  | L_true ), (L_one  | L_true ) -> true
-  | L_num i1, L_num i2 -> Big_int.equal i1 i2
-  | l1,l2 -> l1 = l2
-
-(* There's no undefined nexp, so replace undefined sizes with a plausible size.
-   32 is used as a sensible default. *)
-
-let fabricate_nexp_exist env l typ kids nc typ' =
-  match kids,nc,Env.expand_synonyms env typ' with
-  | ([kid],NC_aux (NC_set (kid',i::_),_),
-     Typ_aux (Typ_app (Id_aux (Id "atom",_),
-                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_))
-      when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 ->
-     Nexp_aux (Nexp_constant i,Unknown)
-  | ([kid],NC_aux (NC_true,_),
-     Typ_aux (Typ_app (Id_aux (Id "atom",_),
-                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_)]),_))
-      when Kid.compare kid kid'' = 0 ->
-     nint 32
-  | ([kid],NC_aux (NC_set (kid',i::_),_),
-     Typ_aux (Typ_app (Id_aux (Id "range",_),
-                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_);
-                        A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_))
-      when Kid.compare kid kid' = 0 && Kid.compare kid kid'' = 0 &&
-        Kid.compare kid kid''' = 0 ->
-     Nexp_aux (Nexp_constant i,Unknown)
-  | ([kid],NC_aux (NC_true,_),
-     Typ_aux (Typ_app (Id_aux (Id "range",_),
-                       [A_aux (A_nexp (Nexp_aux (Nexp_var kid'',_)),_);
-                        A_aux (A_nexp (Nexp_aux (Nexp_var kid''',_)),_)]),_))
-      when Kid.compare kid kid'' = 0 &&
-        Kid.compare kid kid''' = 0 ->
-     nint 32
-  | ([], _, 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
-  | None -> nint 32
-  | Some (env,typ,_) ->
-     match Type_check.destruct_exist (Type_check.Env.expand_synonyms env typ) with
-     | None -> nint 32
-     (* TODO: check this *)
-     | Some (kopts,nc,typ') -> fabricate_nexp_exist env l typ (List.map kopt_kid kopts) nc typ'
-
-let atom_typ_kid kid = function
-  | Typ_aux (Typ_app (Id_aux (Id "atom",_),
-                      [A_aux (A_nexp (Nexp_aux (Nexp_var kid',_)),_)]),_) ->
-     Kid.compare kid kid' = 0
-  | _ -> false
-
-(* We reduce casts in a few cases, in particular to ensure that where the
-   type checker has added a ({'n, true. atom('n)}) ex_int(...) cast we can
-   fill in the 'n.  For undefined we fabricate a suitable value for 'n. *)
-
-let reduce_cast typ exp l annot =
-  let env = env_of_annot (l,annot) in
-  let typ' = Env.base_typ_of env typ in
-  match exp, destruct_exist (Env.expand_synonyms env typ') with
-  | 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 __POS__ nc_env nc
-     then exp
-     else raise (Reporting.err_unreachable l __POS__
-                   ("Constant propagation error: literal " ^ Big_int.to_string n ^
-                       " does not satisfy constraint " ^ string_of_n_constraint nc))
-  | E_aux (E_lit (L_aux (L_undef,_)),_), Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' ->
-     let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in
-     let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in
-     E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot))
-  | E_aux (E_cast (_,
-                   (E_aux (E_lit (L_aux (L_undef,_)),_) as exp)),_),
-     Some ([kopt],nc,typ'') when atom_typ_kid (kopt_kid kopt) typ'' ->
-     let nexp = fabricate_nexp_exist env Unknown typ [kopt_kid kopt] nc typ'' in
-     let newtyp = subst_src_typ (KBindings.singleton (kopt_kid kopt) nexp) typ'' in
-     E_aux (E_cast (newtyp, exp), (Generated l,replace_typ newtyp annot))
-  | _ -> E_aux (E_cast (typ,exp),(l,annot))
-
-(* Used for constant propagation in pattern matches *)
-type 'a matchresult =
-  | DoesMatch of 'a
-  | DoesNotMatch
-  | GiveUp
-
-(* Remove top-level casts from an expression.  Useful when we need to look at
-   subexpressions to reduce something, but could break type-checking if we used
-   it everywhere. *)
-let rec drop_casts = function
-  | E_aux (E_cast (_,e),_) -> drop_casts e
-  | exp -> exp
-
-let int_of_str_lit = function
-  | L_hex hex -> Big_int.of_string ("0x" ^ hex)
-  | L_bin bin -> Big_int.of_string ("0b" ^ bin)
-  | _ -> assert false
-
-let bits_of_lit = function
-  | L_bin bin -> bin
-  | L_hex hex -> hex_to_bin hex
-  | _ -> assert false
-
-let slice_lit (L_aux (lit,ll)) i len (Ord_aux (ord,_)) =
-  let i = Big_int.to_int i in
-  let len = Big_int.to_int len in
-  let bin = bits_of_lit lit in
-  match match ord with
-  | Ord_inc -> Some i
-  | Ord_dec -> Some (String.length bin - i - len)
-  | Ord_var _ -> None
-  with
-  | None -> None
-  | Some i ->
-     Some (L_aux (L_bin (String.sub bin i len),Generated ll))
-
-let concat_vec lit1 lit2 =
-  let bits1 = bits_of_lit lit1 in
-  let bits2 = bits_of_lit lit2 in
-  L_bin (bits1 ^ bits2)
-
-let lit_eq (L_aux (l1,_)) (L_aux (l2,_)) =
-  match l1,l2 with
-  | (L_zero|L_false), (L_zero|L_false)
-  | (L_one |L_true ), (L_one |L_true)
-    -> Some true
-  | (L_hex _| L_bin _), (L_hex _|L_bin _)
-    -> Some (Big_int.equal (int_of_str_lit l1) (int_of_str_lit l2))
-  | L_undef, _ | _, L_undef -> None
-  | L_num i1, L_num i2 -> Some (Big_int.equal i1 i2)
-  | _ -> Some (l1 = l2)
-
-let try_app (l,ann) (id,args) =
-  let new_l = Generated l in
-  let env = env_of_annot (l,ann) in
-  let get_overloads f = List.map string_of_id
-    (Env.get_overloads (Id_aux (Id f, Parse_ast.Unknown)) env @
-    Env.get_overloads (Id_aux (DeIid f, Parse_ast.Unknown)) env) in
-  let is_id f = List.mem (string_of_id id) (f :: get_overloads f) in
-  if is_id "==" || is_id "!=" then
-    match args with
-    | [E_aux (E_lit l1,_); E_aux (E_lit l2,_)] ->
-       let lit b = if b then L_true else L_false in
-       let lit b = lit (if is_id "==" then b else not b) in
-       (match lit_eq l1 l2 with
-       | None -> None
-       | Some b -> Some (E_aux (E_lit (L_aux (lit b,new_l)),(l,ann))))
-    | _ -> None
-  else if is_id "cast_bit_bool" then
-    match args with
-    | [E_aux (E_lit L_aux (L_zero,_),_)] -> Some (E_aux (E_lit (L_aux (L_false,new_l)),(l,ann)))
-    | [E_aux (E_lit L_aux (L_one ,_),_)] -> Some (E_aux (E_lit (L_aux (L_true ,new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "UInt" || is_id "unsigned" then
-    match args with
-    | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit,_), _)] ->
-       Some (E_aux (E_lit (L_aux (L_num (int_of_str_lit lit),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "slice" then
-    match args with
-    | [E_aux (E_lit (L_aux ((L_hex _| L_bin _),_) as lit), annot);
-       E_aux (E_lit L_aux (L_num i,_), _);
-       E_aux (E_lit L_aux (L_num len,_), _)] ->
-       (match Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) with
-       | Typ_aux (Typ_app (_,[_;A_aux (A_order ord,_);_]),_) ->
-          (match slice_lit lit i len ord with
-          | Some lit' -> Some (E_aux (E_lit lit',(l,ann)))
-          | None -> None)
-       | _ -> None)
-    | _ -> None
-  else if is_id "bitvector_concat" then
-    match args with
-    | [E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit1,_), _);
-       E_aux (E_lit L_aux ((L_hex _| L_bin _) as lit2,_), _)] ->
-       Some (E_aux (E_lit (L_aux (concat_vec lit1 lit2,new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "shl_int" then
-    match args with
-    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
-       Some (E_aux (E_lit (L_aux (L_num (Big_int.shift_left i (Big_int.to_int j)),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "mult_atom" || is_id "mult_int" || is_id "mult_range" then
-    match args with
-    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
-       Some (E_aux (E_lit (L_aux (L_num (Big_int.mul i j),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "quotient_nat" then
-    match args with
-    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
-       Some (E_aux (E_lit (L_aux (L_num (Big_int.div i j),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "add_atom" || is_id "add_int" || is_id "add_range" then
-    match args with
-    | [E_aux (E_lit L_aux (L_num i,_),_); E_aux (E_lit L_aux (L_num j,_),_)] ->
-       Some (E_aux (E_lit (L_aux (L_num (Big_int.add i j),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "negate_range" then
-    match args with
-    | [E_aux (E_lit L_aux (L_num i,_),_)] ->
-       Some (E_aux (E_lit (L_aux (L_num (Big_int.negate i),new_l)),(l,ann)))
-    | _ -> None
-  else if is_id "ex_int" then
-    match args with
-    | [E_aux (E_lit lit,(l,_))] -> Some (E_aux (E_lit lit,(l,ann)))
-    | [E_aux (E_cast (_,(E_aux (E_lit (L_aux (L_undef,_)),_) as e)),(l,_))] ->
-       Some (reduce_cast (typ_of_annot (l,ann)) e l ann)
-    | _ -> None
-  else if is_id "vector_access" || is_id "bitvector_access" then
-    match args with
-    | [E_aux (E_lit L_aux ((L_hex _ | L_bin _) as lit,_),_);
-       E_aux (E_lit L_aux (L_num i,_),_)] ->
-       let v = int_of_str_lit lit in
-       let b = Big_int.bitwise_and (Big_int.shift_right v (Big_int.to_int i)) (Big_int.of_int 1) in
-       let lit' = if Big_int.equal b (Big_int.of_int 1) then L_one else L_zero in
-       Some (E_aux (E_lit (L_aux (lit',new_l)),(l,ann)))
-    | _ -> None
-  else None
-
-
-let construct_lit_vector args =
-  let rec aux l = function
-    | [] -> Some (L_aux (L_bin (String.concat "" (List.rev l)),Unknown))
-    | E_aux (E_lit (L_aux ((L_zero | L_one) as lit,_)),_)::t ->
-       aux ((if lit = L_zero then "0" else "1")::l) t
-    | _ -> None
-  in aux [] args
-
 type pat_choice = Parse_ast.l * (int * int * (id * tannot exp) list)
 
 (* We may need to split up a pattern match if (1) we've been told to case split
@@ -937,64 +432,9 @@ type split =
       list
   | ConstrSplit of (tannot pat * nexp KBindings.t) list
 
-let threaded_map f state l =
-  let l',state' =
-    List.fold_left (fun (tl,state) element -> let (el',state') = f state element in (el'::tl,state'))
-      ([],state) l
-  in List.rev l',state'
-
 let isubst_minus subst subst' =
   Bindings.merge (fun _ x y -> match x,y with (Some a), None -> Some a | _, _ -> None) subst subst'
 
-let isubst_minus_set subst set =
-  IdSet.fold Bindings.remove set subst
-
-let assigned_vars exp =
-  fst (Rewriter.fold_exp
-         { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with
-           Rewriter.lEXP_id = (fun id -> IdSet.singleton id, LEXP_id id);
-           Rewriter.lEXP_cast = (fun (ty,id) -> IdSet.singleton id, LEXP_cast (ty,id)) }
-         exp)
-
-let referenced_vars exp =
-  let open Rewriter in
-  fst (fold_exp
-         { (compute_exp_alg IdSet.empty IdSet.union) with
-           e_ref = (fun id -> IdSet.singleton id, E_ref id) } exp)
-
-let assigned_vars_in_fexps fes =
-  List.fold_left
-    (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e))
-    IdSet.empty
-    fes
-
-let assigned_vars_in_pexp (Pat_aux (p,_)) =
-  match p with
-  | Pat_exp (_,e) -> assigned_vars e
-  | Pat_when (p,e1,e2) -> IdSet.union (assigned_vars e1) (assigned_vars e2)
-
-let rec assigned_vars_in_lexp (LEXP_aux (le,_)) =
-  match le with
-  | LEXP_id id
-  | LEXP_cast (_,id) -> IdSet.singleton id
-  | LEXP_tup lexps
-  | LEXP_vector_concat lexps -> 
-     List.fold_left (fun vs le -> IdSet.union vs (assigned_vars_in_lexp le)) IdSet.empty lexps
-  | LEXP_memory (_,es) -> List.fold_left (fun vs e -> IdSet.union vs (assigned_vars e)) IdSet.empty es
-  | LEXP_vector (le,e) -> IdSet.union (assigned_vars_in_lexp le) (assigned_vars e)
-  | LEXP_vector_range (le,e1,e2) ->
-     IdSet.union (assigned_vars_in_lexp le) (IdSet.union (assigned_vars e1) (assigned_vars e2))
-  | LEXP_field (le,_) -> assigned_vars_in_lexp le
-  | LEXP_deref e -> assigned_vars e
-
-(* Add a cast to undefined so that it retains its type, otherwise it can't be
-   substituted safely *)
-let keep_undef_typ value =
-  match value with
-  | E_aux (E_lit (L_aux (L_undef,lann)),eann) ->
-     E_aux (E_cast (typ_of_annot eann,value),(Generated Unknown,snd eann))
-  | _ -> value
-
 let freshen_id =
   let counter = ref 0 in
   fun id ->
@@ -1174,13 +614,6 @@ let apply_pat_choices choices =
     e_assert = rewrite_assert;
     e_case = rewrite_case }
 
-(* Check whether the current environment with the given kid assignments is
-   inconsistent (and hence whether the code is dead) *)
-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 __POS__ env nc_false
-
 let split_defs all_errors splits defs =
   let no_errors_happened = ref true in
   let split_constructors (Defs defs) =
@@ -1209,467 +642,9 @@ let split_defs all_errors splits defs =
 
   let (refinements, defs') = split_constructors defs in
 
-  (* COULD DO: dead code is only eliminated at if expressions, but we could
-     also cut out impossible case branches and code after assertions. *)
-
-  (* Constant propogation.
-     Takes maps of immutable/mutable variables to subsitute.
-     The substs argument also contains the current type-level kid refinements
-     so that we can check for dead code.
-     Extremely conservative about evaluation order of assignments in
-     subexpressions, dropping assignments rather than committing to
-     any particular order *)
-  let rec const_prop_exp ref_vars substs assigns ((E_aux (e,(l,annot))) as exp) =
-    (* Functions to treat lists and tuples of subexpressions as possibly
-       non-deterministic: that is, we stop making any assumptions about
-       variables that are assigned to in any of the subexpressions *)
-    let non_det_exp_list es =
-      let assigned_in =
-        List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp))
-          IdSet.empty es in
-      let assigns = isubst_minus_set assigns assigned_in in
-      let es' = List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es in
-      es',assigns
-    in
-    let non_det_exp_2 e1 e2 =
-       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
-       let assigns = isubst_minus_set assigns assigned_in_e12 in
-       let e1',_ = const_prop_exp ref_vars substs assigns e1 in
-       let e2',_ = const_prop_exp ref_vars substs assigns e2 in
-       e1',e2',assigns
-    in
-    let non_det_exp_3 e1 e2 e3 =
-       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
-       let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in
-       let assigns = isubst_minus_set assigns assigned_in_e123 in
-       let e1',_ = const_prop_exp ref_vars substs assigns e1 in
-       let e2',_ = const_prop_exp ref_vars substs assigns e2 in
-       let e3',_ = const_prop_exp ref_vars substs assigns e3 in
-       e1',e2',e3',assigns
-    in
-    let non_det_exp_4 e1 e2 e3 e4 =
-       let assigned_in_e12 = IdSet.union (assigned_vars e1) (assigned_vars e2) in
-       let assigned_in_e123 = IdSet.union assigned_in_e12 (assigned_vars e3) in
-       let assigned_in_e1234 = IdSet.union assigned_in_e123 (assigned_vars e4) in
-       let assigns = isubst_minus_set assigns assigned_in_e1234 in
-       let e1',_ = const_prop_exp ref_vars substs assigns e1 in
-       let e2',_ = const_prop_exp ref_vars substs assigns e2 in
-       let e3',_ = const_prop_exp ref_vars substs assigns e3 in
-       let e4',_ = const_prop_exp ref_vars substs assigns e4 in
-       e1',e2',e3',e4',assigns
-    in
-    let re e assigns = E_aux (e,(l,annot)),assigns in
-    match e with
-      (* TODO: are there more circumstances in which we should get rid of these? *)
-    | E_block [e] -> const_prop_exp ref_vars substs assigns e
-    | E_block es ->
-       let es',assigns = threaded_map (const_prop_exp ref_vars substs) assigns es in
-       re (E_block es') assigns
-    | E_nondet es ->
-       let es',assigns = non_det_exp_list es in
-       re (E_nondet es') assigns
-    | E_id id ->
-       let env = Type_check.env_of_annot (l, annot) in
-       (try
-         match Env.lookup_id id env with
-         | Local (Immutable,_) -> Bindings.find id (fst substs)
-         | Local (Mutable,_)   -> Bindings.find id assigns
-         | _ -> exp
-       with Not_found -> exp),assigns
-    | E_lit _
-    | E_sizeof _
-    | E_constraint _
-      -> exp,assigns
-    | E_cast (t,e') ->
-       let e'',assigns = const_prop_exp ref_vars substs assigns e' in
-       if is_value e''
-       then reduce_cast t e'' l annot, assigns
-       else re (E_cast (t, e'')) assigns
-    | E_app (id,es) ->
-       let es',assigns = non_det_exp_list es in
-       let env = Type_check.env_of_annot (l, annot) in
-       (match try_app (l,annot) (id,es') with
-       | None ->
-          (match const_prop_try_fn ref_vars l env (id,es') with
-          | None -> re (E_app (id,es')) assigns
-          | Some r -> r,assigns)
-       | Some r -> r,assigns)
-    | E_tuple es ->
-       let es',assigns = non_det_exp_list es in
-       re (E_tuple es') assigns
-    | E_if (e1,e2,e3) ->
-       let e1',assigns = const_prop_exp ref_vars substs assigns e1 in
-       let e1_no_casts = drop_casts e1' in
-       (match e1_no_casts with
-       | E_aux (E_lit (L_aux ((L_true|L_false) as lit ,_)),_) ->
-          (match lit with
-          | L_true -> const_prop_exp ref_vars substs assigns e2
-          |  _     -> const_prop_exp ref_vars substs assigns e3)
-       | _ ->
-          (* If the guard is an equality check, propagate the value. *)
-          let env1 = env_of e1_no_casts in
-          let is_equal id =
-            List.exists (fun id' -> Id.compare id id' == 0)
-              (Env.get_overloads (Id_aux (DeIid "==", Parse_ast.Unknown))
-                 env1)
-          in
-          let substs_true =
-            match e1_no_casts with
-            | E_aux (E_app (id, [E_aux (E_id var,_); vl]),_)
-            | E_aux (E_app (id, [vl; E_aux (E_id var,_)]),_)
-                when is_equal id ->
-               if is_value vl then
-                 (match Env.lookup_id var env1 with
-                 | Local (Immutable,_) -> Bindings.add var vl (fst substs),snd substs
-                 | _ -> substs)
-               else substs
-            | _ -> substs
-          in
-          (* Discard impossible branches *)
-          if is_env_inconsistent (env_of e2) (snd substs) then
-            const_prop_exp ref_vars substs assigns e3
-          else if is_env_inconsistent (env_of e3) (snd substs) then
-            const_prop_exp ref_vars substs_true assigns e2
-          else
-            let e2',assigns2 = const_prop_exp ref_vars substs_true assigns e2 in
-            let e3',assigns3 = const_prop_exp ref_vars substs assigns e3 in
-            let assigns = isubst_minus_set assigns (assigned_vars e2) in
-            let assigns = isubst_minus_set assigns (assigned_vars e3) in
-            re (E_if (e1',e2',e3')) assigns)
-    | E_for (id,e1,e2,e3,ord,e4) ->
-       (* Treat e1, e2 and e3 (from, to and by) as a non-det tuple *)
-       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
-       let assigns = isubst_minus_set assigns (assigned_vars e4) in
-       let e4',_ = const_prop_exp ref_vars (Bindings.remove id (fst substs),snd substs) assigns e4 in
-       re (E_for (id,e1',e2',e3',ord,e4')) assigns
-    | E_loop (loop,e1,e2) ->
-       let assigns = isubst_minus_set assigns (IdSet.union (assigned_vars e1) (assigned_vars e2)) in
-       let e1',_ = const_prop_exp ref_vars substs assigns e1 in
-       let e2',_ = const_prop_exp ref_vars substs assigns e2 in
-       re (E_loop (loop,e1',e2')) assigns
-    | E_vector es ->
-       let es',assigns = non_det_exp_list es in
-       begin
-         match construct_lit_vector es' with
-         | None -> re (E_vector es') assigns
-         | Some lit -> re (E_lit lit) assigns
-       end
-    | E_vector_access (e1,e2) ->
-       let e1',e2',assigns = non_det_exp_2 e1 e2 in
-       re (E_vector_access (e1',e2')) assigns
-    | E_vector_subrange (e1,e2,e3) ->
-       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
-       re (E_vector_subrange (e1',e2',e3')) assigns
-    | E_vector_update (e1,e2,e3) ->
-       let e1',e2',e3',assigns = non_det_exp_3 e1 e2 e3 in
-       re (E_vector_update (e1',e2',e3')) assigns
-    | E_vector_update_subrange (e1,e2,e3,e4) ->
-       let e1',e2',e3',e4',assigns = non_det_exp_4 e1 e2 e3 e4 in
-       re (E_vector_update_subrange (e1',e2',e3',e4')) assigns
-    | E_vector_append (e1,e2) ->
-       let e1',e2',assigns = non_det_exp_2 e1 e2 in
-       re (E_vector_append (e1',e2')) assigns
-    | E_list es ->
-       let es',assigns = non_det_exp_list es in
-       re (E_list es') assigns
-    | E_cons (e1,e2) ->
-       let e1',e2',assigns = non_det_exp_2 e1 e2 in
-       re (E_cons (e1',e2')) assigns
-    | E_record fes ->
-       let assigned_in_fes = assigned_vars_in_fexps fes in
-       let assigns = isubst_minus_set assigns assigned_in_fes in
-       re (E_record (const_prop_fexps ref_vars substs assigns fes)) assigns
-    | E_record_update (e,fes) ->
-       let assigned_in = IdSet.union (assigned_vars_in_fexps fes) (assigned_vars e) in
-       let assigns = isubst_minus_set assigns assigned_in in
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       re (E_record_update (e', const_prop_fexps ref_vars substs assigns fes)) assigns
-    | E_field (e,id) ->
-       let e',assigns = const_prop_exp ref_vars substs assigns e in
-       re (E_field (e',id)) assigns
-    | E_case (e,cases) ->
-       let e',assigns = const_prop_exp ref_vars substs assigns e in
-       (match can_match ref_vars e' cases substs assigns with
-       | None ->
-          let assigned_in =
-            List.fold_left (fun vs pe -> IdSet.union vs (assigned_vars_in_pexp pe))
-              IdSet.empty cases
-          in
-          let assigns' = isubst_minus_set assigns assigned_in in
-          re (E_case (e', List.map (const_prop_pexp ref_vars substs assigns) cases)) assigns'
-       | Some (E_aux (_,(_,annot')) as exp,newbindings,kbindings) ->
-          let exp = nexp_subst_exp (kbindings_from_list kbindings) exp in
-          let newbindings_env = bindings_from_list newbindings in
-          let substs' = bindings_union (fst substs) newbindings_env, snd substs in
-          const_prop_exp ref_vars substs' assigns exp)
-    | E_let (lb,e2) ->
-       begin
-         match lb with
-         | LB_aux (LB_val (p,e), annot) ->
-            let e',assigns = const_prop_exp ref_vars substs assigns e in
-            let substs' = remove_bound substs p in
-            let plain () =
-              let e2',assigns = const_prop_exp ref_vars substs' assigns e2 in
-              re (E_let (LB_aux (LB_val (p,e'), annot),
-                         e2')) assigns in
-            if is_value e' && not (is_value e) then
-              match can_match ref_vars e' [Pat_aux (Pat_exp (p,e2),(Unknown,empty_tannot))] substs assigns with
-              | None -> plain ()
-              | Some (e'',bindings,kbindings) ->
-                 let e'' = nexp_subst_exp (kbindings_from_list kbindings) e'' in
-                 let bindings = bindings_from_list bindings in
-                 let substs'' = bindings_union (fst substs') bindings, snd substs' in
-                 const_prop_exp ref_vars substs'' assigns e''
-            else plain ()
-       end
-    (* TODO maybe - tuple assignments *)
-    | E_assign (le,e) ->
-       let env = Type_check.env_of_annot (l, annot) in
-       let assigned_in = IdSet.union (assigned_vars_in_lexp le) (assigned_vars e) in
-       let assigns = isubst_minus_set assigns assigned_in in
-       let le',idopt = const_prop_lexp ref_vars substs assigns le in
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       let assigns =
-         match idopt with
-         | Some id ->
-            begin
-              match Env.lookup_id id env with
-              | Local (Mutable,_) | Unbound ->
-                 if is_value e' && not (IdSet.mem id ref_vars)
-                 then Bindings.add id (keep_undef_typ e') assigns
-                 else Bindings.remove id assigns
-              | _ -> assigns
-            end
-         | None -> assigns
-       in
-       re (E_assign (le', e')) assigns
-    | E_exit e ->
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       re (E_exit e') Bindings.empty
-    | E_ref id -> re (E_ref id) Bindings.empty
-    | E_throw e ->
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       re (E_throw e') Bindings.empty
-    | E_try (e,cases) ->
-       (* TODO: try and preserve *any* assignment info *)
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       re (E_case (e', List.map (const_prop_pexp ref_vars substs Bindings.empty) cases)) Bindings.empty
-    | E_return e ->
-       let e',_ = const_prop_exp ref_vars substs assigns e in
-       re (E_return e') Bindings.empty
-    | E_assert (e1,e2) ->
-       let e1',e2',assigns = non_det_exp_2 e1 e2 in
-       re (E_assert (e1',e2')) assigns
-
-    | E_app_infix _
-    | E_var _
-    | E_internal_plet _
-    | E_internal_return _
-    | E_internal_value _
-      -> raise (Reporting.err_unreachable l __POS__
-                  ("Unexpected expression encountered in monomorphisation: " ^ string_of_exp exp))
-  and const_prop_fexps ref_vars substs assigns fes =
-    List.map (const_prop_fexp ref_vars substs assigns) fes
-  and const_prop_fexp ref_vars substs assigns (FE_aux (FE_Fexp (id,e), annot)) =
-    FE_aux (FE_Fexp (id,fst (const_prop_exp ref_vars substs assigns e)),annot)
-  and const_prop_pexp ref_vars substs assigns = function
-    | (Pat_aux (Pat_exp (p,e),l)) ->
-       Pat_aux (Pat_exp (p,fst (const_prop_exp ref_vars (remove_bound substs p) assigns e)),l)
-    | (Pat_aux (Pat_when (p,e1,e2),l)) ->
-       let substs' = remove_bound substs p in
-       let e1',assigns = const_prop_exp ref_vars substs' assigns e1 in
-       Pat_aux (Pat_when (p, e1', fst (const_prop_exp ref_vars substs' assigns e2)),l)
-  and const_prop_lexp ref_vars substs assigns ((LEXP_aux (e,annot)) as le) =
-    let re e = LEXP_aux (e,annot), None in
-    match e with
-    | LEXP_id id (* shouldn't end up substituting here *)
-    | LEXP_cast (_,id)
-      -> le, Some id
-    | LEXP_memory (id,es) ->
-       re (LEXP_memory (id,List.map (fun e -> fst (const_prop_exp ref_vars substs assigns e)) es)) (* or here *)
-    | LEXP_tup les -> re (LEXP_tup (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les))
-    | LEXP_vector (le,e) -> re (LEXP_vector (fst (const_prop_lexp ref_vars substs assigns le), fst (const_prop_exp ref_vars substs assigns e)))
-    | LEXP_vector_range (le,e1,e2) ->
-       re (LEXP_vector_range (fst (const_prop_lexp ref_vars substs assigns le),
-                              fst (const_prop_exp ref_vars substs assigns e1),
-                              fst (const_prop_exp ref_vars substs assigns e2)))
-    | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map (fun le -> fst (const_prop_lexp ref_vars substs assigns le)) les))
-    | LEXP_field (le,id) -> re (LEXP_field (fst (const_prop_lexp ref_vars substs assigns le), id))
-    | LEXP_deref e ->
-       re (LEXP_deref (fst (const_prop_exp ref_vars substs assigns e)))
-  (* Reduce a function when
-     1. all arguments are values,
-     2. the function is pure,
-     3. the result is a value
-     (and 4. the function is not scattered, but that's not terribly important)
-     to try and keep execution time and the results managable.
-  *)
-  and const_prop_try_fn ref_vars l env (id,args) =
-    if not (List.for_all is_value args) then
-      None
-    else
-      let (tq,typ) = Env.get_val_spec_orig id env in
-      let eff = match typ with
-        | Typ_aux (Typ_fn (_,_,eff),_) -> Some eff
-        | _ -> None
-      in
-      let Defs ds = defs in
-      match eff, list_extract (function
-      | (DEF_fundef (FD_aux (FD_function (_,_,eff,((FCL_aux (FCL_Funcl (id',_),_))::_ as fcls)),_)))
-        -> if Id.compare id id' = 0 then Some fcls else None
-      | _ -> None) ds with
-      | None,_ | _,None -> None
-      | Some eff,_ when not (is_pure eff) -> None
-      | Some _,Some fcls ->
-         let arg = match args with
-           | [] -> E_aux (E_lit (L_aux (L_unit,Generated l)),(Generated l,empty_tannot))
-           | [e] -> e
-           | _ -> E_aux (E_tuple args,(Generated l,empty_tannot)) in
-         let cases = List.map (function
-           | FCL_aux (FCL_Funcl (_,pexp), ann) -> pexp)
-           fcls in
-         match can_match_with_env ref_vars env arg cases (Bindings.empty,KBindings.empty) Bindings.empty with
-         | Some (exp,bindings,kbindings) ->
-            let substs = bindings_from_list bindings, kbindings_from_list kbindings in
-            let result,_ = const_prop_exp ref_vars substs Bindings.empty exp in
-            let result = match result with
-              | E_aux (E_return e,_) -> e
-              | _ -> result
-            in
-            if is_value result then Some result else None
-         | None -> None
-
-  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 l "Monomorphisation"
-                 ("Failed to find a case for " ^ description); None)
-      | [Pat_aux (Pat_exp (P_aux (P_wild,_),exp),_)] -> Some (exp,[],[])
-      | (Pat_aux (Pat_exp (P_aux (P_typ (_,p),_),exp),ann))::tl ->
-         findpat_generic check_pat description assigns ((Pat_aux (Pat_exp (p,exp),ann))::tl)
-      | (Pat_aux (Pat_exp (P_aux (P_id id',_),exp),_))::tlx
-          when pat_id_is_variable env id' ->
-         Some (exp, [(id', exp0)], [])
-      | (Pat_aux (Pat_when (P_aux (P_id id',_),guard,exp),_))::tl
-          when pat_id_is_variable env id' -> begin
-            let substs = Bindings.add id' exp0 substs, ksubsts in
-            let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in
-            match guard with
-            | E_lit (L_aux (L_true,_)) -> Some (exp,[(id',exp0)],[])
-            | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl
-            | _ -> None
-          end
-      | (Pat_aux (Pat_when (p,guard,exp),_))::tl -> begin
-        match check_pat p with
-        | DoesNotMatch -> findpat_generic check_pat description assigns tl
-        | DoesMatch (vsubst,ksubst) -> begin
-          let guard = nexp_subst_exp (kbindings_from_list ksubst) guard in
-          let substs = bindings_union substs (bindings_from_list vsubst),
-                       kbindings_union ksubsts (kbindings_from_list ksubst) in
-          let (E_aux (guard,_)),assigns = const_prop_exp ref_vars substs assigns guard in
-          match guard with
-          | E_lit (L_aux (L_true,_)) -> Some (exp,vsubst,ksubst)
-          | E_lit (L_aux (L_false,_)) -> findpat_generic check_pat description assigns tl
-          | _ -> None
-        end
-        | GiveUp -> None
-      end
-      | (Pat_aux (Pat_exp (p,exp),_))::tl ->
-         match check_pat p with
-         | DoesNotMatch -> findpat_generic check_pat description assigns tl
-         | DoesMatch (subst,ksubst) -> Some (exp,subst,ksubst)
-         | GiveUp -> None
-    in
-    match e with
-    | E_id id ->
-       (match Env.lookup_id id env with
-       | Enum _ ->
-          let checkpat = function
-            | P_aux (P_id id',_)
-            | P_aux (P_app (id',[]),_) ->
-               if Id.compare id id' = 0 then DoesMatch ([],[]) else DoesNotMatch
-            | P_aux (_,(l',_)) ->
-               (Reporting.print_err l' "Monomorphisation"
-                  "Unexpected kind of pattern for enumeration"; GiveUp)
-          in findpat_generic checkpat (string_of_id id) assigns cases
-       | _ -> None)
-    | E_lit (L_aux (lit_e, lit_l)) ->
-       let checkpat = function
-         | P_aux (P_lit (L_aux (lit_p, _)),_) ->
-            if lit_match (lit_e,lit_p) then DoesMatch ([],[]) else DoesNotMatch
-         | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) ->
-            begin
-              match lit_e with
-              | L_num i ->
-                 DoesMatch ([id, E_aux (e,(l,annot))],
-                            [kid,Nexp_aux (Nexp_constant i,Unknown)])
-              (* For undefined we fix the type-level size (because there's no good
-                 way to construct an undefined size), but leave the term as undefined
-                 to make the meaning clear. *)
-              | L_undef ->
-                 let nexp = fabricate_nexp l annot in
-                 let typ = subst_src_typ (KBindings.singleton kid nexp) (typ_of_annot p_id_annot) in
-                 DoesMatch ([id, E_aux (E_cast (typ,E_aux (e,(l,empty_tannot))),(l,empty_tannot))],
-                            [kid,nexp])
-              | _ ->
-                 (Reporting.print_err lit_l "Monomorphisation"
-                    "Unexpected kind of literal for var match"; GiveUp)
-            end
-         | P_aux (_,(l',_)) ->
-            (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 ->
-       let checkpat = function
-         | P_aux (P_vector ps,_) ->
-            let matches = List.map2 (fun e p ->
-              match e, p with
-              | E_aux (E_lit (L_aux (lit,_)),_), P_aux (P_lit (L_aux (lit',_)),_) ->
-                 if lit_match (lit,lit') then DoesMatch ([],[]) else DoesNotMatch
-              | E_aux (E_lit l,_), P_aux (P_id var,_) when pat_id_is_variable env var ->
-                 DoesMatch ([var, e],[])
-              | _ -> GiveUp) es ps in
-            let final = List.fold_left (fun acc m -> match acc, m with
-              | _, GiveUp -> GiveUp
-              | GiveUp, _ -> GiveUp
-              | DoesMatch (sub,ksub), DoesMatch(sub',ksub') -> DoesMatch(sub@sub',ksub@ksub')
-              | _ -> DoesNotMatch) (DoesMatch ([],[])) matches in
-            (match final with
-            | GiveUp ->
-               (Reporting.print_err l "Monomorphisation"
-                  "Unexpected kind of pattern for vector literal"; GiveUp)
-            | _ -> final)
-         | _ ->
-            (Reporting.print_err l "Monomorphisation"
-               "Unexpected kind of pattern for vector literal"; GiveUp)
-       in findpat_generic checkpat "vector literal" assigns cases
-
-    | E_cast (undef_typ, (E_aux (E_lit (L_aux (L_undef, lit_l)),_) as e_undef)) ->
-       let checkpat = function
-         | P_aux (P_lit (L_aux (lit_p, _)),_) -> DoesNotMatch
-         | P_aux (P_var (P_aux (P_id id,p_id_annot), TP_aux (TP_var kid, _)),_) ->
-              (* For undefined we fix the type-level size (because there's no good
-                 way to construct an undefined size), but leave the term as undefined
-                 to make the meaning clear. *)
-            let nexp = fabricate_nexp l annot in
-            let kids = equal_kids (env_of_annot p_id_annot) kid in
-            let ksubst = KidSet.fold (fun k b -> KBindings.add k nexp b) kids KBindings.empty in
-            let typ = subst_src_typ ksubst (typ_of_annot p_id_annot) in
-            DoesMatch ([id, E_aux (E_cast (typ,e_undef),(l,empty_tannot))],
-                       KBindings.bindings ksubst)
-         | P_aux (_,(l',_)) ->
-            (Reporting.print_err l' "Monomorphisation"
-               "Unexpected kind of pattern for literal"; GiveUp)
-       in findpat_generic checkpat "literal" assigns cases
-    | _ -> None
-
-  and can_match ref_vars exp =
-    let env = Type_check.env_of exp in
-    can_match_with_env ref_vars env exp
-  in
-
   let subst_exp ref_vars substs ksubsts exp =
     let substs = bindings_from_list substs, ksubsts in
-    fst (const_prop_exp ref_vars substs Bindings.empty exp)
+    fst (Constant_propagation.const_prop defs ref_vars substs Bindings.empty exp)
   in
 
   (* Split a variable pattern into every possible value *)
@@ -1824,7 +799,7 @@ let split_defs all_errors splits defs =
            (match spl p' with
            | None -> None
            | Some ps ->
-              let kids = equal_kids (env_of_pat p') kid in
+              let kids = Spec_analysis.equal_kids (env_of_pat p') kid in
               Some (List.map (fun (p,sub,pchoices,ksub) ->
                 P_aux (P_var (p,tp),(l,annot)), sub, pchoices,
                 List.concat
@@ -1949,7 +924,7 @@ let split_defs all_errors splits defs =
       match match_l l with
       | [] -> p
       | lvs ->
-         let pvs = bindings_from_pat p in
+         let pvs = Spec_analysis.bindings_from_pat p in
          let pvs = List.map string_of_id pvs in
          let overlap = List.exists (fun (v,_) -> List.mem v pvs) lvs in
          let () =
@@ -2033,7 +1008,7 @@ let split_defs all_errors splits defs =
               if check_split_size patsubsts (pat_loc p) then
                 List.map (fun (pat',substs,pchoices,ksubsts) ->
                   let ksubsts = kbindings_from_list ksubsts in
-                  let exp' = nexp_subst_exp ksubsts e in
+                  let exp' = Spec_analysis.nexp_subst_exp ksubsts e in
                   let exp' = subst_exp ref_vars substs ksubsts exp' in
                   let exp' = apply_pat_choices pchoices exp' in
                   let exp' = stop_at_false_assertions exp' in
@@ -2042,8 +1017,8 @@ let split_defs all_errors splits defs =
               else nosplit
            | ConstrSplit patnsubsts ->
               List.map (fun (pat',nsubst) ->
-                let pat' = nexp_subst_pat nsubst pat' in
-                let exp' = nexp_subst_exp nsubst e in
+                let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in
+                let exp' = Spec_analysis.nexp_subst_exp nsubst e in
                 Pat_aux (Pat_exp (pat', map_exp exp'),l)
               ) patnsubsts)
         | Pat_aux (Pat_when (p,e1,e2),l) ->
@@ -2054,10 +1029,10 @@ let split_defs all_errors splits defs =
               if check_split_size patsubsts (pat_loc p) then
                 List.map (fun (pat',substs,pchoices,ksubsts) ->
                   let ksubsts = kbindings_from_list ksubsts in
-                  let exp1' = nexp_subst_exp ksubsts e1 in
+                  let exp1' = Spec_analysis.nexp_subst_exp ksubsts e1 in
                   let exp1' = subst_exp ref_vars substs ksubsts exp1' in
                   let exp1' = apply_pat_choices pchoices exp1' in
-                  let exp2' = nexp_subst_exp ksubsts e2 in
+                  let exp2' = Spec_analysis.nexp_subst_exp ksubsts e2 in
                   let exp2' = subst_exp ref_vars substs ksubsts exp2' in
                   let exp2' = apply_pat_choices pchoices exp2' in
                   let exp2' = stop_at_false_assertions exp2' in
@@ -2066,9 +1041,9 @@ let split_defs all_errors splits defs =
               else nosplit
            | ConstrSplit patnsubsts ->
               List.map (fun (pat',nsubst) ->
-                let pat' = nexp_subst_pat nsubst pat' in
-                let exp1' = nexp_subst_exp nsubst e1 in
-                let exp2' = nexp_subst_exp nsubst e2 in
+                let pat' = Spec_analysis.nexp_subst_pat nsubst pat' in
+                let exp1' = Spec_analysis.nexp_subst_exp nsubst e1 in
+                let exp2' = Spec_analysis.nexp_subst_exp nsubst e2 in
                 Pat_aux (Pat_when (pat', map_exp exp1', map_exp exp2'),l)
               ) patnsubsts)
       and map_letbind (LB_aux (lb,annot)) =
@@ -2093,7 +1068,7 @@ let split_defs all_errors splits defs =
     let map_pexp r = let (_,f,_) = map_fns r in f in
     let map_letbind r = let (_,_,f) = map_fns r in f in
     let map_exp exp =
-      let ref_vars = referenced_vars exp in
+      let ref_vars = Constant_propagation.referenced_vars exp in
       map_exp ref_vars exp
     in
     let map_pexp top_pexp =
@@ -2101,11 +1076,11 @@ let split_defs all_errors splits defs =
          make false assumptions about them during constant propagation.  Note that
          we assume there aren't any in the guard. *)
       let (_,_,body,_) = destruct_pexp top_pexp in
-      let ref_vars = referenced_vars body in
+      let ref_vars = Constant_propagation.referenced_vars body in
       map_pexp ref_vars top_pexp
     in
     let map_letbind (LB_aux (LB_val (_,e),_) as lb) =
-      let ref_vars = referenced_vars e in
+      let ref_vars = Constant_propagation.referenced_vars e in
       map_letbind ref_vars lb
     in
 
@@ -2798,12 +1773,12 @@ let update_env_new_kids env deps typ_env_pre typ_env_post =
    plus any new type variables. *)
 
 let update_env env deps pat typ_env_pre typ_env_post =
-  let bound = bindings_from_pat pat in
+  let bound = Spec_analysis.bindings_from_pat pat in
   let var_deps = List.fold_left (fun ds v -> Bindings.add v deps ds) env.var_deps bound in
   update_env_new_kids { env with var_deps = var_deps } deps typ_env_pre typ_env_post
 
 let assigned_vars_exps es =
-  List.fold_left (fun vs exp -> IdSet.union vs (assigned_vars exp))
+  List.fold_left (fun vs exp -> IdSet.union vs (Spec_analysis.assigned_vars exp))
     IdSet.empty es
 
 (* For adding control dependencies to mutable variables *)
@@ -3290,7 +2265,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions =
     let Typ_aux (typ,_) = Env.base_typ_of env (typ_of_annot annot) in
     match typ with
     | Typ_app (Id_aux (Id "atom",_),[A_aux (A_nexp (Nexp_aux (Nexp_var kid,_)),_)]) ->
-       equal_kids env kid
+       Spec_analysis.equal_kids env kid
     | _ -> KidSet.empty
   in
   let default_split annot kids =
@@ -3365,7 +2340,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions =
          let s,v,k = aux pat in
          let kids = kids_bound_by_typ_pat tpat in
          let kids = KidSet.fold (fun kid s ->
-           KidSet.union s (equal_kids (env_of_annot (l,annot)) kid))
+           KidSet.union s (Spec_analysis.equal_kids (env_of_annot (l,annot)) kid))
            kids kids in
          s,v,KidSet.fold (fun kid k -> KBindings.add kid (Have (s, ExtraSplits.empty)) k) kids k
       | P_app (_,pats) -> of_list pats
@@ -3406,7 +2381,7 @@ let initial_env fn_id fn_l (TypQ_aux (tq,_)) pat body set_assertions =
     | _, _ -> None
   in
   let kid_deps = KBindings.merge merge_kid_deps_eqns kid_deps eqn_kid_deps in
-  let referenced_vars = referenced_vars body in
+  let referenced_vars = Constant_propagation.referenced_vars body in
   { top_kids; var_deps; kid_deps; referenced_vars }
 
 (* When there's more than one pick the first *)
@@ -3986,9 +2961,9 @@ let rec rewrite_app env typ (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, _), _)]
+    | [len; slice_len; vector; start; E_aux (E_app (zeros, _), _)]
       when is_zeros zeros ->
-       E_app (mk_id "set_slice_zeros", [len; slice_len; vector; pos])
+       E_app (mk_id "set_slice_zeros", [len; vector; start; slice_len])
     | _ -> E_app (id, args)
 
   else E_app (id,args)
@@ -4137,7 +3112,7 @@ let make_bitvector_cast_fns cast_name env quant_kids src_typ target_typ =
 
 (* TODO: bound vars *)
 let make_bitvector_env_casts env quant_kids (kid,i) exp =
-  let mk_cast var typ exp = (fst (make_bitvector_cast_fns "bitvector_cast_in" env quant_kids typ (subst_src_typ (KBindings.singleton kid (nconstant i)) typ))) var exp in
+  let mk_cast var typ exp = (fst (make_bitvector_cast_fns "bitvector_cast_in" env quant_kids typ (subst_kids_typ (KBindings.singleton kid (nconstant i)) typ))) var exp in
   let locals = Env.get_locals env in
   Bindings.fold (fun var (mut,typ) exp ->
     if mut = Immutable then mk_cast var typ exp else exp) locals exp
@@ -4209,7 +3184,7 @@ let fill_in_type env typ =
        (match solve_unique env (nvar kid) with
        | None -> subst
        | Some n -> KBindings.add kid (nconstant n) subst)) tyvars KBindings.empty in
-  subst_src_typ subst typ
+  subst_kids_typ subst typ
 
 (* TODO: top-level patterns *)
 (* TODO: proper environment tracking for variables.  Currently we pretend that
@@ -4280,7 +3255,7 @@ let add_bitvector_casts (Defs defs) =
            make_bitvector_env_casts env quant_kids inst body) e2 insts in
          let insts = List.fold_left (fun insts (kid,i) ->
            KBindings.add kid (nconstant i) insts) KBindings.empty insts in
-         let src_typ = subst_src_typ insts result_typ in
+         let src_typ = subst_kids_typ insts result_typ in
          let e2' = make_bitvector_cast_exp "bitvector_cast_out" env quant_kids src_typ result_typ e2' in
          E_aux (E_if (e1,e2',e3), ann)
       | E_return e' ->
diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml
index f42a279b..27b5b16e 100644
--- a/src/ocaml_backend.ml
+++ b/src/ocaml_backend.ml
@@ -999,7 +999,7 @@ let ocaml_compile spec defs generator_types =
     ignore(Unix.system ("cp -r " ^ sail_dir ^ "/lib/myocamlbuild_coverage.ml myocamlbuild.ml"));
   ocaml_pp_defs out_chan defs generator_types;
   close_out out_chan;
-  if IdSet.mem (mk_id "main") (Initial_check.val_spec_ids defs)
+  if IdSet.mem (mk_id "main") (val_spec_ids defs)
   then
     begin
       print_endline "Generating main";
diff --git a/src/pretty_print_coq.ml b/src/pretty_print_coq.ml
index 4553de56..ee83c89f 100644
--- a/src/pretty_print_coq.ml
+++ b/src/pretty_print_coq.ml
@@ -652,7 +652,7 @@ 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]
+    | Some pp -> separate space [pp; string "/\\"; parens prop]
   in
   let prop =
     match exists with
@@ -665,11 +665,11 @@ and doc_arithfact ctxt ?(exists = []) ?extra nc =
 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)
+  | NC_or (nc1, nc2) -> doc_op (string "\\/") (l80 nc1) (l85 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)
+  | NC_and (nc1, nc2) -> doc_op (string "/\\") (l70 nc1) (l80 nc2)
   | _ -> l70 nc_full
   and l70 (NC_aux (nc,_) as nc_full) =
   match nc with
@@ -1200,11 +1200,12 @@ let doc_exp, doc_let =
          wrap_parens (string "build_ex" ^/^ epp)
     in
     let construct_dep_pairs ?(rawbools=false) env =
-      let rec aux want_parens (E_aux (e,_) as exp) (Typ_aux (t,_) as typ) =
-        match e,t with
-        | E_tuple exps, Typ_tup typs
-        | E_cast (_, E_aux (E_tuple exps,_)), Typ_tup typs
+      let rec aux want_parens (E_aux (e,_) as exp) typ =
+        match e with
+        | E_tuple exps
+        | E_cast (_, E_aux (E_tuple exps,_))
           ->
+           let typs = List.map general_typ_of exps in
            parens (separate (string ", ") (List.map2 (aux false) exps typs))
         | _ ->
            let typ' = expand_range_type (Env.expand_synonyms (env_of exp) typ) in
@@ -1484,6 +1485,7 @@ let doc_exp, doc_let =
               Util.list_mapi (fun i exp -> mk_id ("#coq#arg" ^ string_of_int i),
                                            general_typ_of exp) args
             in
+            let () = debug ctxt (lazy (" arg types: " ^ String.concat ", " (List.map (fun (_,ty) -> string_of_typ ty) dummy_args))) in
             let dummy_exp = mk_exp (E_app (f, List.map (fun (id,_) -> mk_exp (E_id id)) dummy_args)) in
             let dummy_env = List.fold_left (fun env (id,typ) -> Env.add_local id (Immutable,typ) env) env dummy_args in
             let inst_exp =
@@ -1498,7 +1500,9 @@ let doc_exp, doc_let =
                type inferred when we know the target type.
                TODO: there are probably some edge cases where this won't pick up a need
                to cast. *)
-            | exception _ -> instantiation_of full_exp
+            | exception _ ->
+               (debug ctxt (lazy (" unable to infer function instantiation without return type " ^ string_of_typ (typ_of full_exp)));
+                instantiation_of full_exp)
           in
           let inst = KBindings.fold (fun k u m -> KBindings.add (KBindings.find (orig_kid k) tqs_map) u m) inst KBindings.empty in
           let () = debug ctxt (lazy (" instantiations: " ^ String.concat ", " (List.map (fun (kid,tyarg) -> string_of_kid kid ^ " => " ^ string_of_typ_arg tyarg) (KBindings.bindings inst)))) in
@@ -1842,29 +1846,6 @@ let doc_exp, doc_let =
             let epp = liftR (separate space [string "assert_exp'"; expY assert_e1; expY assert_e2]) in
             let epp = infix 0 1 (string ">>= fun _ =>") epp (top_exp new_ctxt false e2) in
             if aexp_needed then parens (align epp) else align epp
-         (* Special case because we don't handle variables with nested existentials well yet.
-            TODO: check that id1 is not used in e2' *)
-         | ((P_aux (P_id id1,_)) | P_aux (P_typ (_, P_aux (P_id id1,_)),_)),
-           _,
-           (E_aux (E_let (LB_aux (LB_val (pat', E_aux (E_cast (typ', E_aux (E_id id2,_)),_)),_), e2'),_))
-             when Id.compare id1 id2 == 0 ->
-            let m_str, tail_pp = if ctxt.early_ret then "MR",[string "_"] else "M",[] in
-            let e1_pp = parens (separate space ([expY e1; colon;
-                                                string m_str;
-                                                parens (doc_typ ctxt typ')]@tail_pp)) in
-            let middle =
-              match pat' with
-              | P_aux (P_id id,_)
-                   when Util.is_none (is_auto_decomposed_exist ctxt (env_of e1) (typ_of e1)) &&
-                          not (is_enum (env_of e1) id) ->
-                 separate space [string ">>= fun"; doc_id id; bigarrow]
-              | P_aux (P_typ (typ, P_aux (P_id id,_)),_)
-                   when Util.is_none (is_auto_decomposed_exist ctxt (env_of e1) typ) &&
-                          not (is_enum (env_of e1) id) ->
-                 separate space [string ">>= fun"; doc_id id; colon; doc_typ ctxt typ; bigarrow]              | _ ->
-                 separate space [string ">>= fun"; squote ^^ doc_pat ctxt true true (pat', typ'); bigarrow]
-            in
-            infix 0 1 middle e1_pp (top_exp new_ctxt false e2')
          | _ ->
             let epp =
               let middle =
@@ -2089,6 +2070,7 @@ let rec doc_range ctxt (BF_aux(r,_)) = match r with
   | BF_concat(ir1,ir2) -> (doc_range ctxt ir1) ^^ comma ^^ (doc_range ctxt ir2)
  *)
 
+(* TODO: check use of empty_ctxt below *)
 let doc_typdef generic_eq_types (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
@@ -2097,6 +2079,14 @@ 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(id,typq,A_aux (A_nexp nexp,_)) ->
+     let idpp = doc_id_type id in
+     doc_op coloneq
+       (separate space [string "Definition"; idpp;
+                        doc_typquant_items empty_ctxt parens typq;
+                        colon; string "Z"])
+       (doc_nexp empty_ctxt nexp) ^^ dot ^^ hardline ^^
+     separate space [string "Hint Unfold"; idpp; colon; string "sail."]
   | TD_abbrev _ -> empty (* TODO? *)
   | TD_bitfield _ -> empty (* TODO? *)
   | TD_record(id,typq,fs,_) ->
@@ -2148,10 +2138,11 @@ let doc_typdef generic_eq_types (TD_aux(td, (l, annot))) = match td with
         string "Defined." ^^ hardline
       else empty
     in
+    let resetimplicit = separate space [string "Arguments"; id_pp; colon; string "clear implicits."] in
     doc_op coloneq
-           (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt parens typq])
+           (separate space [string "Record"; id_pp; doc_typquant_items empty_ctxt braces typq])
            ((*doc_typquant typq*) (braces (space ^^ align fs_doc ^^ space))) ^^
-      dot ^^ hardline ^^ eq_pp ^^ updates_pp
+      dot ^^ hardline ^^ resetimplicit ^^ hardline ^^ eq_pp ^^ updates_pp
   | TD_variant(id,typq,ar,_) ->
      (match id with
       | Id_aux ((Id "read_kind"),_) -> empty
@@ -2779,7 +2770,7 @@ try
   (* let regtypes = find_regtypes d in *)
   let state_ids =
     State.generate_regstate_defs true defs
-    |> Initial_check.val_spec_ids
+    |> val_spec_ids
   in
   let is_state_def = function
     | DEF_spec vs -> IdSet.mem (id_of_val_spec vs) state_ids
diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml
index 6adcec46..eec61874 100644
--- a/src/pretty_print_lem.ml
+++ b/src/pretty_print_lem.ml
@@ -1024,6 +1024,22 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with
   | BF_concat(ir1,ir2) -> (doc_range ir1) ^^ comma ^^ (doc_range ir2)
  *)
 
+let doc_typquant_sorts idpp (TypQ_aux (typq,_)) =
+  match typq with
+  | TypQ_tq qs ->
+     let q (QI_aux (qi,_)) =
+       match qi with
+       | QI_id (KOpt_aux (KOpt_kind (K_aux (K_int,_),kid),_)) -> Some (string "`len`")
+       | QI_id (KOpt_aux (KOpt_kind (K_aux (K_type,_),kid),_)) -> Some underscore
+       | QI_id (KOpt_aux (KOpt_kind (K_aux ((K_order|K_bool),_),kid),_)) -> None
+       | QI_const _ -> None
+     in
+     if List.exists (function (QI_aux (QI_id (KOpt_aux (KOpt_kind (K_aux (K_int,_),_),_)),_)) -> true | _ -> false) qs then
+       let qs_pp = Util.map_filter q qs in
+       string "declare isabelle target_sorts " ^^ idpp ^^ space ^^ separate space (equals::qs_pp) ^^ hardline
+     else empty
+  | TypQ_no_forall -> empty
+
 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
@@ -1078,9 +1094,10 @@ let doc_typdef_lem env (TD_aux(td, (l, annot))) = match td with
           doc_op equals (string "field_is_inc") (string (if is_inc then "true" else "false")); semi_sp;
           doc_op equals (string "get_field") (parens (doc_op arrow (string "fun rec_val") get)); semi_sp;
           doc_op equals (string "set_field") (parens (doc_op arrow (string "fun rec_val v") set)); space])) in *)
+    let sorts_pp = doc_typquant_sorts (doc_id_lem_type id) typq in
     doc_op equals
            (separate space [string "type"; doc_id_lem_type id; doc_typquant_items_lem None typq])
-           ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline
+           ((*doc_typquant_lem typq*) (anglebars (space ^^ align fs_doc ^^ space))) ^^ hardline ^^ sorts_pp
     (* if !opt_sequential && string_of_id id = "regstate" then empty
     else separate_map hardline doc_field fs *)
   | TD_variant(id,typq,ar,_) ->
@@ -1466,7 +1483,7 @@ let pp_defs_lem (types_file,types_modules) (defs_file,defs_modules) type_env (De
   (* let regtypes = find_regtypes d in *)
   let state_ids =
     State.generate_regstate_defs !opt_mwords defs
-    |> Initial_check.val_spec_ids
+    |> val_spec_ids
   in
   let is_state_def = function
     | DEF_spec vs -> IdSet.mem (id_of_val_spec vs) state_ids
diff --git a/src/rewriter.ml b/src/rewriter.ml
index 89f64401..edf0d4a5 100644
--- a/src/rewriter.ml
+++ b/src/rewriter.ml
@@ -52,7 +52,6 @@ module Big_int = Nat_big_num
 open Ast
 open Ast_util
 open Type_check
-open Spec_analysis
 
 type 'a rewriters = {
     rewrite_exp  : 'a rewriters -> 'a exp -> 'a exp;
diff --git a/src/rewriter.mli b/src/rewriter.mli
index ec4e381c..ab29d1d9 100644
--- a/src/rewriter.mli
+++ b/src/rewriter.mli
@@ -48,6 +48,8 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
+(** General rewriting framework for Sail->Sail rewrites *)
+
 module Big_int = Nat_big_num
 open Ast
 open Type_check
@@ -65,14 +67,14 @@ val rewrite_exp : tannot rewriters -> tannot exp -> tannot exp
 
 val rewriters_base : tannot rewriters
 
-(* The identity re-writer *)
+(** The identity re-writer *)
 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 *)
+
+(** 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
diff --git a/src/rewrites.ml b/src/rewrites.ml
index 0be6825a..15e6ad05 100644
--- a/src/rewrites.ml
+++ b/src/rewrites.ml
@@ -319,380 +319,11 @@ let rewrite_bitvector_exps env defs =
     | (e_aux, a) -> E_aux (e_aux, a)
   in
   let rewrite_exp _ = fold_exp { id_exp_alg with e_aux = e_aux } in
-  if IdSet.mem (mk_id "bitvector_of_bitlist") (Initial_check.val_spec_ids defs) then
+  if IdSet.mem (mk_id "bitvector_of_bitlist") (val_spec_ids defs) then
     rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp } defs
   else defs
 
 
-(* Re-write trivial sizeof expressions - trivial meaning that the
-   value of the sizeof can be directly inferred from the type
-   variables in scope. *)
-let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp =
-  let extract_typ_var l env nexp (id, (_, typ)) =
-    let var = E_aux (E_id id, (l, mk_tannot env typ no_effect)) in
-    match destruct_atom_nexp env typ with
-    | 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 __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 __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
-  in
-  let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) =
-    match nexp_aux with
-    | Nexp_sum (n1, n2) ->
-       mk_exp ~loc:l (E_app (mk_id "add_atom", [split_nexp n1; split_nexp n2]))
-    | Nexp_minus (n1, n2) ->
-       mk_exp ~loc:l (E_app (mk_id "sub_atom", [split_nexp n1; split_nexp n2]))
-    | Nexp_times (n1, n2) ->
-       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
-    match e_aux with
-    | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) ->
-       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
-                       |> List.map (extract_typ_var l env nexp)
-                       |> List.map (fun opt -> match opt with Some x -> [x] | None -> [])
-                       |> List.concat
-            in
-            match exps with
-            | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp)
-            | [] when split_sizeof ->
-               fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp))
-            | [] -> orig_exp
-       end
-    | _ -> orig_exp
-  and rewrite_e_sizeof split_sizeof =
-    { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) }
-  in
-  (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
-
-   For each type-level variable used in a sizeof expressions whose value cannot
-   be directly extracted from existing parameters of the surrounding function,
-   a further parameter is added; calls to the function are rewritten
-   accordingly (possibly causing further rewriting in the calling function) *)
-let rewrite_sizeof env (Defs defs) =
-  let sizeof_frees exp =
-    fst (fold_exp
-           { (compute_exp_alg KidSet.empty KidSet.union) with
-             e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) }
-           exp) in
-
-  (* Collect nexps whose values can be obtained directly from a pattern bind *)
-  let nexps_from_params pat =
-    fst (fold_pat
-           { (compute_pat_alg [] (@)) with
-             p_aux = (fun ((v,pat),((l,_) as annot)) ->
-             let v' = match pat with
-               | P_id id | P_as (_, id) ->
-                  let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in
-                  (match typ with
-                   | Typ_app (atom, [A_aux (A_nexp nexp, _)])
-                        when string_of_id atom = "atom" ->
-                      [nexp, E_id id]
-                   | Typ_app (vector, _) when string_of_id vector = "vector" ->
-                      let id_length = Id_aux (Id "length", gen_loc l) in
-                      (try
-                         (match Env.get_val_spec id_length (env_of_annot annot) with
-                          | _ ->
-                             let (len,_,_) = vector_typ_args_of typ_aux in
-                             let exp = E_app (id_length, [E_aux (E_id id, annot)]) in
-                             [len, exp])
-                       with
-                       | _ -> [])
-                   | _ -> [])
-               | _ -> [] in
-             (v @ v', P_aux (pat,annot)))} pat) in
-
-  (* Substitute collected values in sizeof expressions *)
-  let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) =
-    try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap)
-    with
-    | Not_found ->
-       let binop nexp1 op nexp2 = E_app_infix (
-                                      E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)),
-                                      Id_aux (Id op, Parse_ast.Unknown),
-                                      E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2))
-                                    ) in
-       let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in
-       (match nexp with
-        | Nexp_constant i -> E_lit (L_aux (L_num i, l))
-        | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2
-        | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2
-        | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2
-        | _ -> E_sizeof nexp_aux) in
-
-  let ex_regex = Str.regexp "'ex[0-9]+" in
-
-  (* Rewrite calls to functions which have had parameters added to pass values
-     of type-level variables; these are added as sizeof expressions first, and
-     then further rewritten as above. *)
-  let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) =
-    let env = env_of_annot annot in
-    let full_exp = E_aux (exp, annot) in
-    let orig_exp = E_aux (exp_orig, annot) in
-    match exp with
-    | E_app (f, args) ->
-       if Bindings.mem f param_map then
-         (* Retrieve instantiation of the type variables of the called function
-           for the given parameters in the original environment *)
-         let inst =
-           try instantiation_of orig_exp with
-           | Type_error (_, l, err) ->
-             raise (Reporting.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 *)
-         let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in
-         let kid_exp kid = begin
-             (* We really don't want to see an existential here! *)
-             assert (not (Str.string_match ex_regex (string_of_kid kid) 0));
-             let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in
-             match uvar with
-             | Some (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) ->
-                  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
-                a variable in scope. It can't be an existential because the assert rules that out. *)
-             | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid)))
-             | _ ->
-                raise (Reporting.err_unreachable l __POS__
-                                                       ("failed to infer nexp for type variable " ^ string_of_kid kid ^
-                                                          " of function " ^ string_of_id f))
-           end in
-         let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in
-         (E_aux (E_app (f, kid_exps @ args), annot), orig_exp)
-       else (full_exp, orig_exp)
-    | _ -> (full_exp, orig_exp) in
-
-  (* Plug this into a folding algorithm that also keeps around a copy of the
-  original expressions, which we use to infer instantiations of type variables
-  in the original environments *)
-  let copy_exp_alg =
-    { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es'))
-    ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es'))
-    ; e_id = (fun id -> (E_id id, E_id id))
-    ; e_ref = (fun id -> (E_ref id, E_ref id))
-    ; e_lit = (fun lit -> (E_lit lit, E_lit lit))
-    ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e')))
-    ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es')))
-    ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2')))
-    ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es'))
-    ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3')))
-    ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4')))
-    ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2')))
-    ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es'))
-    ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2')))
-    ; e_vector_subrange =  (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3')))
-    ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3')))
-    ; e_vector_update_subrange =  (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4')))
-    ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2')))
-    ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es'))
-    ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2')))
-    ; e_record = (fun fexps -> let (fexps, fexps') = List.split fexps in (E_record fexps, E_record fexps'))
-    ; e_record_update = (fun ((e1,e1'),fexps) -> let (fexps, fexps') = List.split fexps in (E_record_update (e1,fexps), E_record_update (e1',fexps')))
-    ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id)))
-    ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps')))
-    ; e_try = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_try (e1,pexps), E_try (e1',pexps')))
-    ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2')))
-    ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2')))
-    ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp))
-    ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc))
-    ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1')))
-    ; e_throw = (fun (e1,e1') -> (E_throw (e1), E_throw (e1')))
-    ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1'))
-    ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) )
-    ; e_var = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_var (lexp,e2,e3), E_var (lexp',e2',e3')))
-    ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2')))
-    ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e'))
-    ; e_internal_value = (fun v -> (E_internal_value v, E_internal_value v))
-    ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot)))
-    ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id))
-    ; lEXP_deref = (fun (e, e') -> (LEXP_deref e, LEXP_deref e'))
-    ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es')))
-    ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id)))
-    ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups'))
-    ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2')))
-    ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3')))
-    ; lEXP_vector_concat = (fun lexps -> let (lexps,lexps') = List.split lexps in (LEXP_vector_concat lexps, LEXP_vector_concat lexps'))
-    ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id)))
-    ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot)))
-    ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e')))
-    ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot)))
-    ; def_val_empty = (Def_val_empty, Def_val_empty)
-    ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e'))
-    ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux)))
-    ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e')))
-    ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2')))
-    ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a)))
-    ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e')))
-    ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot)))
-    ; pat_alg = id_pat_alg
-    } in
-
-  let rewrite_sizeof_fun params_map
-                         (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) =
-    let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pexp), annot)) (funcls,nvars) =
-      let pat,guard,exp,pannot = destruct_pexp pexp in
-      let nmap = nexps_from_params pat in
-      (* first rewrite calls to other functions... *)
-      let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in
-      (* ... then rewrite sizeof expressions in current function body *)
-      let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in
-      let guard' = match guard with
-        | Some guard ->
-           (* As above *)
-           let guard' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } guard) in
-           Some (fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } guard')
-        | None -> None in
-      let pexp' = construct_pexp (pat,guard',exp'',pannot) in
-      (FCL_aux (FCL_Funcl (id,pexp'), annot) :: funcls,
-       KidSet.union nvars (sizeof_frees exp'')) in
-    let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in
-    (* Add a parameter for each remaining free type-level variable in a
-       sizeof expression *)
-    let kid_typ kid = atom_typ (nvar kid) in
-    let kid_annot kid = simple_annot l (kid_typ kid) in
-    let kid_pat kid =
-      P_aux (P_typ (kid_typ kid,
-                    P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)),
-                           kid_annot kid)), kid_annot kid) in
-    let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in
-    let kid_typs = List.map kid_typ (KidSet.elements nvars) in
-    let kid_pats = List.map kid_pat (KidSet.elements nvars) in
-    let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in
-    let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pexp), annot) as funcl) =
-      let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) =
-        let penv = env_of_annot pannot in
-        let peff = effect_of_annot (snd pannot) in
-        if KidSet.is_empty nvars then paux else
-          match typ_of_pat paux with
-          | Typ_aux (Typ_tup typs, _) ->
-             let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in
-             (match pat with
-              | P_tup pats ->
-                 P_aux (P_tup (kid_pats @ pats), (l, mk_tannot penv ptyp' peff))
-              | P_wild -> P_aux (pat, (l, mk_tannot penv ptyp' peff))
-              | P_typ (Typ_aux (Typ_tup typs, l), pat) ->
-                 P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l),
-                               rewrite_pat pat), (l, mk_tannot penv ptyp' peff))
-              | P_as (_, id) | P_id id ->
-                 (* adding parameters here would change the type of id;
-              we should remove the P_as/P_id here and add a let-binding to the body *)
-                 raise (Reporting.err_todo l
-                                                 "rewriting as- or id-patterns for sizeof expressions not yet implemented")
-              | _ ->
-                 raise (Reporting.err_unreachable l __POS__
-                                                        "unexpected pattern while rewriting function parameters for sizeof expressions"))
-          | ptyp ->
-             let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in
-             P_aux (P_tup (kid_pats @ [paux]), (l, mk_tannot penv ptyp' peff)) in
-      let pat,guard,exp,pannot = destruct_pexp pexp in
-      let pat' = rewrite_pat pat in
-      let guard' = match guard with
-        | Some guard -> Some (fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } guard)
-        | None -> None in
-      let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in
-      let pexp' = construct_pexp (pat',guard',exp',pannot) in
-      FCL_aux (FCL_Funcl (id, pexp'), annot) in
-    let funcls = List.map rewrite_funcl_params funcls in
-    let fd = FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot) in
-    let params_map =
-      if KidSet.is_empty nvars then params_map else
-        Bindings.add (id_of_fundef fd) nvars params_map in
-    (params_map, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in
-
-  let rewrite_sizeof_def (params_map, defs) = function
-    | DEF_fundef fd ->
-       let (params_map', fd') = rewrite_sizeof_fun params_map fd in
-       (params_map', defs @ [DEF_fundef fd'])
-    | DEF_internal_mutrec fds ->
-       let rewrite_fd (params_map, fds) fd =
-         let (params_map', fd') = rewrite_sizeof_fun params_map fd in
-         (params_map', fds @ [fd']) in
-       (* TODO Split rewrite_sizeof_fun into an analysis and a rewrite pass,
-          so that we can call the analysis until a fixpoint is reached and then
-          rewrite the mutually recursive functions *)
-       let (params_map', fds') = List.fold_left rewrite_fd (params_map, []) fds in
-       (params_map', defs @ [DEF_internal_mutrec fds'])
-    | DEF_val (LB_aux (lb, annot)) ->
-       begin
-         let lb' = match lb with
-         | LB_val (pat, exp) ->
-           let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in
-           LB_val (pat, exp') in
-         (params_map, defs @ [DEF_val (LB_aux (lb', annot))])
-       end
-    | DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp), annot)) ->
-       let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in
-       (params_map, defs @ [DEF_reg_dec (DEC_aux (DEC_config (id, typ, exp'), annot))])
-    | def ->
-       (params_map, defs @ [def]) in
-
-  let rewrite_sizeof_valspec params_map def =
-    let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id =
-      if Bindings.mem id params_map then
-        let kid_typs = List.map (fun kid -> atom_typ (nvar kid))
-                                (KidSet.elements (Bindings.find id params_map)) in
-        let typ' = match typ with
-          | Typ_aux (Typ_fn (vtyp_args, vtyp_ret, declared_eff), vl) ->
-             Typ_aux (Typ_fn (kid_typs @ vtyp_args, vtyp_ret, declared_eff), vl)
-          | _ ->
-            raise (Reporting.err_typ l "val spec with non-function type") in
-        TypSchm_aux (TypSchm_ts (tq, typ'), l)
-      else ts in
-    match def with
-    | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) ->
-       DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a))
-    | def -> def
-  in
-
-  let (params_map, defs) = List.fold_left rewrite_sizeof_def
-                                          (Bindings.empty, []) defs in
-  let defs = List.map (rewrite_sizeof_valspec params_map) defs in
-  (* Defs defs *)
-  fst (Type_error.check initial_env (Defs defs))
-
 let rewrite_defs_remove_assert defs =
   let e_assert ((E_aux (eaux, (l, _)) as exp), str) = match eaux with
     | E_constraint _ ->
@@ -2025,7 +1656,6 @@ let is_funcl_rec (FCL_aux (FCL_Funcl (id, pexp), _)) =
          E_app_infix (e1, f, e2))) }
     exp)
 
-
 let pat_var (P_aux (paux, a)) =
   let env = env_of_annot a in
   let is_var id =
@@ -2035,68 +1665,101 @@ let pat_var (P_aux (paux, a)) =
   | (P_as (_, id) | P_id id) when is_var id -> Some id
   | _ -> None
 
-(* 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 env (Defs defs) =
+(** Split out function clauses for individual union constructor patterns
+   (e.g. AST nodes) into auxiliary functions. Used for the execute function.
+
+   For example:
+
+   function execute(Instr(x, y)) = ...
+
+   would become
+
+   function execute_Instr(x, y) = ...
+
+   function execute(Instr(x, y)) = execute_C(x, y)
+
+   This is actually a slightly complex rewrite than it first appears, because
+   we have to deal with cases where the AST type has constraints in various
+   places, e.g.
+
+   union ast('x: Int), 0 <= 'x < 32 = {
+     Instr : {'r, 'r in {32, 64}. (int('x), bits('r))}
+   }
+ *)
+let rewrite_split_fun_ctor_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 =
       List.fold_left
         (fun (clauses, aux_funs) (FCL_aux (FCL_Funcl (id, pexp), fannot) as clause) ->
-           let pat, guard, exp, annot = destruct_pexp pexp in
-           match pat with
-             | P_aux (P_app (constr_id, args), pannot) ->
-                let argstup_typ = tuple_typ (List.map typ_of_pat args) in
-                let pannot' = swaptyp argstup_typ pannot in
-                let pat' =
-                  match args with
-                  | [arg] -> arg
-                  | _ -> P_aux (P_tup args, pannot')
-                in
-                let pexp' = construct_pexp (pat', guard, exp, annot) in
-                let aux_fun_id = prepend_id (fun_name ^ "_") constr_id in
-                let aux_funcl = FCL_aux (FCL_Funcl (aux_fun_id, pexp'), pannot') in
-                begin
-                  try
-                    let aux_clauses = Bindings.find aux_fun_id aux_funs in
-                    clauses,
-                    Bindings.add aux_fun_id (aux_clauses @ [aux_funcl]) aux_funs
-                  with Not_found ->
-                    let argpats, argexps = List.split (List.mapi
-                     (fun idx (P_aux (_,a) as pat) ->
-                        let id = match pat_var pat with
-                          | Some id -> id
-                          | None -> mk_id ("arg" ^ string_of_int idx)
-                        in
-                        P_aux (P_id id, a), E_aux (E_id id, a))
-                     args)
-                    in
-                    let pexp = construct_pexp
-                     (P_aux (P_app (constr_id, argpats), pannot),
-                      None,
-                      E_aux (E_app (aux_fun_id, argexps), annot),
-                      annot)
-                    in
-                    clauses @ [FCL_aux (FCL_Funcl (id, pexp), fannot)],
-                    Bindings.add aux_fun_id [aux_funcl] aux_funs
-                end
-             | _ -> clauses @ [clause], aux_funs)
+          let pat, guard, exp, annot = destruct_pexp pexp in
+          match pat with
+          | P_aux (P_app (ctor_id, args), pannot) ->
+             let ctor_typq, ctor_typ = Env.get_union_id ctor_id env in
+             let args = match args with [P_aux (P_tup args, _)] -> args | _ -> args in
+             let argstup_typ = tuple_typ (List.map typ_of_pat args) in
+             let pannot' = swaptyp argstup_typ pannot in
+             let pat' =
+               match args with
+               | [arg] -> arg
+               | _ -> P_aux (P_tup args, pannot')
+             in
+             let pexp' = construct_pexp (pat', guard, exp, annot) in
+             let aux_fun_id = prepend_id (fun_name ^ "_") ctor_id in
+             let aux_funcl = FCL_aux (FCL_Funcl (aux_fun_id, pexp'), pannot') in
+             begin
+               try
+                 let aux_clauses = Bindings.find aux_fun_id aux_funs in
+                 clauses,
+                 Bindings.add aux_fun_id (aux_clauses @ [(aux_funcl, ctor_typq, ctor_typ)]) aux_funs
+               with Not_found ->
+                 let argpats, argexps = List.split (List.mapi
+                                                      (fun idx (P_aux (_,a) as pat) ->
+                                                        let id = match pat_var pat with
+                                                          | Some id -> id
+                                                          | None -> mk_id ("arg" ^ string_of_int idx)
+                                                        in
+                                                        P_aux (P_id id, a), E_aux (E_id id, a))
+                                                      args)
+                 in
+                 let pexp = construct_pexp
+                              (P_aux (P_app (ctor_id, argpats), pannot),
+                               None,
+                               E_aux (E_app (aux_fun_id, argexps), annot),
+                               annot)
+                 in
+                 clauses @ [FCL_aux (FCL_Funcl (id, pexp), fannot)],
+                 Bindings.add aux_fun_id [(aux_funcl, ctor_typq, ctor_typ)] aux_funs
+             end
+          | _ -> clauses @ [clause], aux_funs)
         ([], Bindings.empty) clauses
     in
-    let add_aux_def id funcls defs =
-      let env, args_typ, ret_typ = match funcls with
-        | FCL_aux (FCL_Funcl (_, pexp), _) :: _ ->
+    let add_aux_def id aux_funs defs =
+      let funcls = List.map (fun (fcl, _, _) -> fcl) aux_funs in
+      let env, quants, args_typ, ret_typ = match aux_funs with
+        | (FCL_aux (FCL_Funcl (_, pexp), _), ctor_typq, ctor_typ) :: _ ->
            let pat, _, exp, _ = destruct_pexp pexp in
-           env_of exp, typ_of_pat pat, typ_of exp
+           let ctor_quants args_typ =
+             List.filter (fun qi -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ args_typ))
+                         (quant_items ctor_typq)
+           in
+           begin match ctor_typ with
+           | Typ_aux (Typ_fn ([Typ_aux (Typ_exist (kopts, nc, args_typ), _)], _, _), _) ->
+              env_of exp, ctor_quants args_typ @ List.map mk_qi_kopt kopts @ [mk_qi_nc nc], args_typ, typ_of exp
+           | Typ_aux (Typ_fn ([args_typ], _, _), _) -> env_of exp, ctor_quants args_typ, args_typ, typ_of exp
+           | _ ->
+              raise (Reporting.err_unreachable l __POS__
+                      ("Union constructor has non-function type: " ^ string_of_typ ctor_typ))
+           end
         | _ ->
            raise (Reporting.err_unreachable l __POS__
-             "rewrite_split_fun_constr_pats: empty auxiliary function")
+                   "rewrite_split_fun_constr_pats: empty auxiliary function")
       in
       let eff = List.fold_left
-        (fun eff (FCL_aux (FCL_Funcl (_, pexp), _)) ->
-           let _, _, exp, _ = destruct_pexp pexp in
-           union_effects eff (effect_of exp))
-        no_effect funcls
+                  (fun eff (FCL_aux (FCL_Funcl (_, pexp), _)) ->
+                    let _, _, exp, _ = destruct_pexp pexp in
+                    union_effects eff (effect_of exp))
+                  no_effect funcls
       in
       let fun_typ =
         (* Because we got the argument type from a pattern we need to
@@ -2107,27 +1770,9 @@ let rewrite_split_fun_constr_pats fun_name env (Defs defs) =
         | _ ->
            function_typ [args_typ] ret_typ eff
       in
-      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 -> KOptSet.subset (kopts_of_quant_item qi) (kopts_of_typ fun_typ))
-               qis
-             @ quant_new_kopts qis
-           in
-           TypQ_aux (TypQ_tq qis, 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
-          (mk_typschm typquant fun_typ, id, [], false),
+          (mk_typschm (mk_typquant quants) fun_typ, id, [], false),
           (Parse_ast.Unknown, empty_tannot))
       in
       let fundef = FD_aux (FD_function (r_o, t_o, e_o, funcls), fdannot) in
@@ -2288,41 +1933,6 @@ let rewrite_fix_val_specs env (Defs defs) =
   Defs defs
   (* else Defs defs *)
 
-(* Turn constraints into numeric expressions with sizeof *)
-let rewrite_constraint =
-  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 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)
-  in
-  let rewrite_e_aux (E_aux (e_aux, (l, _)) as exp) =
-    match e_aux with
-    | E_constraint nc ->
-       locate (fun _ -> gen_loc l) (check_exp (env_of exp) (rewrite_nc (env_of exp) nc) (atom_bool_typ nc))
-    | _ -> exp
-  in
-
-  let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in
-
-  rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) }
-
 let rewrite_type_union_typs rw_typ (Tu_aux (Tu_ty_id (typ, id), annot)) =
   Tu_aux (Tu_ty_id (rw_typ typ, id), annot)
 
@@ -5063,6 +4673,7 @@ let rewrite_defs_lem = [
   ("rewrite_undefined", rewrite_undefined_if_gen false);
   ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list);
   ("remove_not_pats", rewrite_defs_not_pats);
+  ("remove_impossible_int_cases", Constant_propagation.remove_impossible_int_cases);
   ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem);
   ("vector_concat_assignments", rewrite_vector_concat_assignments);
   ("tuple_assignments", rewrite_tuple_assignments);
@@ -5075,13 +4686,11 @@ let rewrite_defs_lem = [
   (* ("register_ref_writes", rewrite_register_ref_writes); *)
   ("nexp_ids", rewrite_defs_nexp_ids);
   ("fix_val_specs", rewrite_fix_val_specs);
-  ("split_execute", rewrite_split_fun_constr_pats "execute");
+  ("split_execute", rewrite_split_fun_ctor_pats "execute");
   ("recheck_defs", recheck_defs);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
-  (* ("constraint", rewrite_constraint); *)
   (* ("remove_assert", rewrite_defs_remove_assert); *)
   ("top_sort_defs", fun _ -> top_sort_defs);
-  ("trivial_sizeof", rewrite_trivial_sizeof);
   (* ("sizeof", rewrite_sizeof); *)
   ("early_return", rewrite_defs_early_return);
   ("fix_val_specs", rewrite_fix_val_specs);
@@ -5106,6 +4715,7 @@ let rewrite_defs_coq = [
   ("rewrite_undefined", rewrite_undefined_if_gen true);
   ("rewrite_defs_vector_string_pats_to_bit_list", rewrite_defs_vector_string_pats_to_bit_list);
   ("remove_not_pats", rewrite_defs_not_pats);
+  ("remove_impossible_int_cases", Constant_propagation.remove_impossible_int_cases);
   ("pat_lits", rewrite_defs_pat_lits rewrite_lit_lem);
   ("vector_concat_assignments", rewrite_vector_concat_assignments);
   ("tuple_assignments", rewrite_tuple_assignments);
@@ -5118,16 +4728,13 @@ let rewrite_defs_coq = [
   (* ("register_ref_writes", rewrite_register_ref_writes); *)
   ("nexp_ids", rewrite_defs_nexp_ids);
   ("fix_val_specs", rewrite_fix_val_specs);
-  ("split_execute", rewrite_split_fun_constr_pats "execute");
+  ("split_execute", rewrite_split_fun_ctor_pats "execute");
   ("minimise_recursive_functions", minimise_recursive_functions);
   ("recheck_defs", recheck_defs);
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
-  (* ("constraint", rewrite_constraint); *)
   (* ("remove_assert", rewrite_defs_remove_assert); *)
   ("move_termination_measures", move_termination_measures);
   ("top_sort_defs", fun _ -> top_sort_defs);
-  ("trivial_sizeof", rewrite_trivial_sizeof);
-  ("sizeof", rewrite_sizeof);
   ("early_return", rewrite_defs_early_return);
   (* merge funcls before adding the measure argument so that it doesn't
      disappear into an internal pattern match *)
@@ -5201,7 +4808,7 @@ 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);
-  ("split_execute", if_separate (rewrite_split_fun_constr_pats "execute"));
+  ("split_execute", if_separate (rewrite_split_fun_ctor_pats "execute"));
   ("exp_lift_assign", rewrite_defs_exp_lift_assign);
   ("merge_function_clauses", merge_funcls);
   ("recheck_defs", fun _ -> Optimize.recheck)
diff --git a/src/sail.ml b/src/sail.ml
index 82f8b8f2..d71e23c7 100644
--- a/src/sail.ml
+++ b/src/sail.ml
@@ -63,12 +63,14 @@ let opt_print_tofrominterp = ref false
 let opt_tofrominterp_output_dir : string option ref = ref None
 let opt_print_ocaml = ref false
 let opt_print_c = ref false
+let opt_print_ir = 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_sanity = ref false
 let opt_includes_c = ref ([]:string list)
+let opt_specialize_c = ref false
 let opt_libs_lem = ref ([]:string list)
 let opt_libs_coq = ref ([]:string list)
 let opt_file_arguments = ref ([]:string list)
@@ -142,6 +144,9 @@ let options = Arg.align ([
   ( "-marshal",
     Arg.Tuple [Arg.Set opt_marshal_defs; Arg.Set Initial_check.opt_undefined_gen],
     " OCaml-marshal out the rewritten AST to a file");
+  ( "-ir",
+    Arg.Set opt_print_ir,
+    " print intermediate representation");
   ( "-c",
     Arg.Tuple [Arg.Set opt_print_c; Arg.Set Initial_check.opt_undefined_gen],
     " output a C translated version of the input");
@@ -166,6 +171,12 @@ let options = Arg.align ([
   ( "-c_extra_args",
     Arg.String (fun args -> C_backend.opt_extra_arguments := Some args),
     "<arguments> supply extra argument to every generated C function call" );
+  ( "-c_specialize",
+    Arg.Set opt_specialize_c,
+    " specialize integer arguments in C output");
+  ( "-c_fold_unit",
+    Arg.String (fun str -> Constant_fold.opt_fold_to_unit := Util.split_on_char ',' str),
+    " remove comma separated list of functions from C output, replacing them with unit");
   ( "-elf",
     Arg.String (fun elf -> opt_process_elf := Some elf),
     " process an ELF file so that it can be executed by compiled C code");
@@ -187,11 +198,8 @@ let options = Arg.align ([
     Arg.Set C_backend.opt_static,
     " make generated C functions static");
   ( "-trace",
-    Arg.Tuple [Arg.Set C_backend.opt_trace; Arg.Set Ocaml_backend.opt_trace_ocaml],
+    Arg.Tuple [Arg.Set Ocaml_backend.opt_trace_ocaml],
     " instrument output with tracing");
-  ( "-smt_trace",
-    Arg.Tuple [Arg.Set C_backend.opt_smt_trace],
-    " instrument output with tracing for SMT");
   ( "-cgen",
     Arg.Set opt_print_cgen,
     " generate CGEN source");
@@ -297,7 +305,7 @@ let options = Arg.align ([
     Arg.String (fun l -> opt_ddump_rewrite_ast := Some (l, 0)),
     "<prefix> (debug) dump the ast after each rewriting step to <prefix>_<i>.lem");
   ( "-ddump_flow_graphs",
-    Arg.Set C_backend.opt_debug_flow_graphs,
+    Arg.Set Jib_compile.opt_debug_flow_graphs,
     " (debug) dump flow analysis for Sail functions when compiling to C");
   ( "-dtc_verbose",
     Arg.Int (fun verbosity -> Type_check.opt_tc_debug := verbosity),
@@ -315,7 +323,7 @@ let options = Arg.align ([
     Arg.Set Initial_check.opt_magic_hash,
     " (debug) allow special character # in identifiers");
   ( "-dfunction",
-    Arg.String (fun f -> C_backend.opt_debug_function := f),
+    Arg.String (fun f -> Jib_compile.opt_debug_function := f),
     " (debug) print debugging output for a single function");
   ( "-dprofile",
     Arg.Set Profile.opt_profile,
@@ -443,10 +451,31 @@ let main() =
        then
          let ast_c = rewrite_ast_c type_envs ast in
          let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in
-         (* let ast_c, type_envs = Specialize.(specialize' 2 int_specialization_with_externs ast_c type_envs) in *)
+         let ast_c, type_envs =
+           if !opt_specialize_c then
+             Specialize.(specialize' 2 int_specialization ast_c type_envs)
+           else
+             ast_c, type_envs
+         in
          let output_chan = match !opt_file_out with Some f -> open_out (f ^ ".c") | None -> stdout in
          Util.opt_warnings := true;
-         C_backend.compile_ast (C_backend.initial_ctx type_envs) output_chan (!opt_includes_c) ast_c;
+         C_backend.compile_ast type_envs output_chan (!opt_includes_c) ast_c;
+         close_out output_chan
+       else ());
+      (if !(opt_print_ir)
+       then
+         let ast_c = rewrite_ast_c type_envs ast in
+         let ast_c, type_envs = Specialize.(specialize typ_ord_specialization ast_c type_envs) in
+         let ast_c, type_envs = Specialize.(specialize' 2 int_specialization ast_c type_envs) in
+         let output_chan =
+           match !opt_file_out with
+           | Some f -> Util.opt_colors := false; open_out (f ^ ".ir.sail")
+           | None -> stdout
+         in
+         Util.opt_warnings := true;
+         let cdefs, _ = C_backend.jib_of_ast type_envs ast_c in
+         let str = Pretty_print_sail.to_string PPrint.(separate_map hardline Jib_util.pp_cdef cdefs) in
+         output_string output_chan (str ^ "\n");
          close_out output_chan
        else ());
       (if !(opt_print_cgen)
diff --git a/src/sail.odocl b/src/sail.odocl
index 87209053..0a45eba3 100644
--- a/src/sail.odocl
+++ b/src/sail.odocl
@@ -1,16 +1,17 @@
 ast
-ast_util
-finite_map
-initial_check
-lexer
-sail
 parse_ast
+lexer
 parser
-pp
-pretty_print
-process_file
-reporting_basic
+ast_util
+initial_check
+type_check
 rewriter
+rewrites
 specialize
-type_check
+anf
+jib
+jib_compile
+jib_ssa
+jib_util
 util
+graph
\ No newline at end of file
diff --git a/src/slice.ml b/src/slice.ml
index cbf8ee5d..f50104c4 100644
--- a/src/slice.ml
+++ b/src/slice.ml
@@ -53,15 +53,12 @@ open Ast_util
 open Rewriter
 
 type node =
-  (* In the graph we have a node Register that represents the actual
-     register, but functions get only get transitive dependencies on
-     that through Register_read, Register_write, and Register_ref
-     nodes. *)
   | Register of id
   | Function of id
   | Letbind of id
   | Type of id
   | Overload of id
+  | Constructor of id
 
 let node_id = function
   | Register id -> id
@@ -69,6 +66,7 @@ let node_id = function
   | Letbind id -> id
   | Type id -> id
   | Overload id -> id
+  | Constructor id -> id
 
 let node_kind = function
   | Register _ -> 0
@@ -76,6 +74,7 @@ let node_kind = function
   | Letbind _ -> 3
   | Type _ -> 4
   | Overload _ -> 5
+  | Constructor _ -> 6
 
 module Node = struct
   type t = node
@@ -93,6 +92,7 @@ let node_color cuts =
   | Letbind _ -> "yellow"
   | Type _ -> "springgreen"
   | Overload _ -> "peachpuff"
+  | Constructor _ -> "lightslateblue"
 
 let node_string n = node_id n |> string_of_id |> String.escaped
 
@@ -102,77 +102,176 @@ let builtins =
   let open Type_check in
   IdSet.of_list (List.map fst (Bindings.bindings Env.builtin_typs))
 
-let typ_ids typ =
-  let rec typ_ids (Typ_aux (aux, _)) =
-    match aux with
-    | Typ_var _ | Typ_internal_unknown -> IdSet.empty
-    | Typ_id id -> IdSet.singleton id
-    | Typ_app (id, typs) ->
-     IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids typs))
-    | Typ_fn (typs, typ, _) ->
-       IdSet.union (typ_ids typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids typs))
-    | Typ_bidir (typ1, typ2) ->
-       IdSet.union (typ_ids typ1) (typ_ids typ2)
-    | Typ_tup typs ->
-       List.fold_left IdSet.union IdSet.empty (List.map typ_ids typs)
-    | Typ_exist (_, _, typ) -> typ_ids typ
-  and typ_arg_ids (A_aux (aux, _)) =
-    match aux with
-    | A_typ typ -> typ_ids typ
-    | _ -> IdSet.empty
-  in
-  IdSet.diff (typ_ids typ) builtins
+let rec constraint_ids' (NC_aux (aux, _)) =
+  match aux with
+  | NC_equal (n1, n2) | NC_bounded_le (n1, n2) | NC_bounded_ge (n1, n2) | NC_not_equal (n1, n2) ->
+     IdSet.union (nexp_ids' n1) (nexp_ids' n2)
+  | NC_or (nc1, nc2) | NC_and (nc1, nc2) ->
+     IdSet.union (constraint_ids' nc1) (constraint_ids' nc2)
+  | NC_var _ | NC_true | NC_false | NC_set _ -> IdSet.empty
+  | NC_app (id, args) ->
+     IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args))
+
+and nexp_ids' (Nexp_aux (aux, _)) =
+  match aux with
+  | Nexp_id id -> IdSet.singleton id
+  | Nexp_app (id, nexps) ->
+     IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map nexp_ids' nexps))
+  | Nexp_var _ | Nexp_constant _ -> IdSet.empty
+  | Nexp_exp n | Nexp_neg n -> nexp_ids' n
+  | Nexp_times (n1, n2) | Nexp_sum (n1, n2) | Nexp_minus (n1, n2) ->
+     IdSet.union (nexp_ids' n1) (nexp_ids' n2)
+
+and typ_ids' (Typ_aux (aux, _)) =
+  match aux with
+  | Typ_var _ | Typ_internal_unknown -> IdSet.empty
+  | Typ_id id -> IdSet.singleton id
+  | Typ_app (id, args) ->
+     IdSet.add id (List.fold_left IdSet.union IdSet.empty (List.map typ_arg_ids' args))
+  | Typ_fn (typs, typ, _) ->
+     IdSet.union (typ_ids' typ) (List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs))
+  | Typ_bidir (typ1, typ2) ->
+     IdSet.union (typ_ids' typ1) (typ_ids' typ2)
+  | Typ_tup typs ->
+     List.fold_left IdSet.union IdSet.empty (List.map typ_ids' typs)
+  | Typ_exist (_, _, typ) -> typ_ids' typ
+
+and typ_arg_ids' (A_aux (aux, _)) =
+  match aux with
+  | A_typ typ -> typ_ids' typ
+  | A_nexp nexp -> nexp_ids' nexp
+  | A_bool nc -> constraint_ids' nc
+  | A_order _ -> IdSet.empty
+
+let constraint_ids nc = IdSet.diff (constraint_ids' nc) builtins
+let nexp_ids nc = IdSet.diff (constraint_ids' nc) builtins
+and typ_ids typ = IdSet.diff (typ_ids' typ) builtins
+let typ_arg_ids nc = IdSet.diff (typ_arg_ids' nc) builtins
 
 let add_def_to_graph graph def =
   let open Type_check in
   let module G = Graph.Make(Node) in
   let graph = ref graph in
 
+  let scan_pat self p_aux annot =
+    let env = env_of_annot annot in
+    begin match p_aux with
+    | P_app (id, _) ->
+       graph := G.add_edge' self (Constructor id) !graph
+    | P_typ (typ, _) ->
+       IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ)
+    | _ -> ()
+    end;
+    P_aux (p_aux, annot)
+  in
+  let rw_pat self = { id_pat_alg with p_aux = (fun (p_aux, annot) -> scan_pat self p_aux annot) } in
+
+  let scan_lexp self lexp_aux annot =
+    let env = env_of_annot annot in
+    begin match lexp_aux with
+    | LEXP_cast (typ, _) ->
+       IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ)
+    | LEXP_memory (id, _) ->
+       graph := G.add_edge' self (Function id) !graph
+    | _ -> ()
+    end;
+    LEXP_aux (lexp_aux, annot)
+  in
+
   let scan_exp self e_aux annot =
     let env = env_of_annot annot in
     begin match e_aux with
     | E_id id ->
        begin match Env.lookup_id id env with
-       | Register _ -> graph := G.add_edge self (Register id) !graph
+       | Register _ -> graph := G.add_edge' self (Register id) !graph
        | _ ->
           if IdSet.mem id (Env.get_toplevel_lets env) then
-            graph := G.add_edge self (Letbind id) !graph
+            graph := G.add_edge' self (Letbind id) !graph
           else ()
        end
     | E_app (id, _) ->
-       graph := G.add_edge self (Function id) !graph
+       if Env.is_union_constructor id env then
+         graph := G.add_edge' self (Constructor id) !graph
+       else
+         graph := G.add_edge' self (Function id) !graph
     | E_ref id ->
-       graph := G.add_edge self (Register id) !graph
+       graph := G.add_edge' self (Register id) !graph
     | E_cast (typ, _) ->
-       IdSet.iter (fun id -> graph := G.add_edge self (Type id) !graph) (typ_ids typ)
+       IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (typ_ids typ)
     | _ -> ()
     end;
     E_aux (e_aux, annot)
   in
-  let rw_exp self = { id_exp_alg with e_aux = (fun (e_aux, annot) -> scan_exp self e_aux annot) } in
+  let rw_exp self = { id_exp_alg with e_aux = (fun (e_aux, annot) -> scan_exp self e_aux annot);
+                                      pat_alg = rw_pat self } in
 
   let rewriters self =
     { rewriters_base with
       rewrite_exp = (fun _ -> fold_exp (rw_exp self));
+      rewrite_pat = (fun _ -> fold_pat (rw_pat self));
       rewrite_let = (fun _ -> fold_letbind (rw_exp self));
     }
   in
 
+  let scan_quant_item self (QI_aux (aux, _)) =
+    match aux with
+    | QI_id _ -> ()
+    | QI_const nc ->
+       IdSet.iter (fun id -> graph := G.add_edge' self (Type id) !graph) (constraint_ids nc)
+  in
+
+  let scan_typquant self (TypQ_aux (aux, _)) =
+    match aux with
+    | TypQ_no_forall -> ()
+    | TypQ_tq quants -> List.iter (scan_quant_item self) quants
+  in
+
+  let add_type_def_to_graph (TD_aux (aux, (l, _))) =
+    match aux with
+    | TD_abbrev (id, typq, arg) ->
+       graph := G.add_edges' (Type id) (List.map (fun id -> Type id) (IdSet.elements (typ_arg_ids arg))) !graph;
+       scan_typquant (Type id) typq
+    | TD_record (id, typq, fields, _) ->
+       let field_nodes =
+         List.map (fun (typ, _) -> typ_ids typ) fields
+         |> List.fold_left IdSet.union IdSet.empty
+         |> IdSet.elements
+         |> List.map (fun id -> Type id)
+       in
+       graph := G.add_edges' (Type id) field_nodes !graph;
+       scan_typquant (Type id) typq
+    | TD_variant (id, typq, ctors, _) ->
+       let ctor_nodes =
+         List.map (fun (Tu_aux (Tu_ty_id (typ, id), _)) -> (typ_ids typ, id)) ctors
+         |> List.fold_left (fun (ids, ctors) (ids', ctor) -> (IdSet.union ids ids', IdSet.add ctor ctors)) (IdSet.empty, IdSet.empty)
+       in
+       IdSet.iter (fun ctor_id -> graph := G.add_edge' (Constructor ctor_id) (Type id) !graph) (snd ctor_nodes);
+       IdSet.iter (fun typ_id -> graph := G.add_edge' (Type id) (Type typ_id) !graph) (fst ctor_nodes);
+       scan_typquant (Type id) typq
+    | TD_enum (id, _, _) ->
+       graph := G.add_edges' (Type id) [] !graph
+    | TD_bitfield _ ->
+       Reporting.unreachable l __POS__ "Bitfield should be re-written"
+  in
+
   begin match def with
   | DEF_spec (VS_aux (VS_val_spec (TypSchm_aux (TypSchm_ts (typq, typ), _), id, _, _), _)) ->
-     graph := G.add_edges (Function id) [] !graph;
-     IdSet.iter (fun typ_id -> graph := G.add_edge (Function id) (Type typ_id) !graph) (typ_ids typ)
+     graph := G.add_edges' (Function id) [] !graph;
+     IdSet.iter (fun typ_id -> graph := G.add_edge' (Function id) (Type typ_id) !graph) (typ_ids typ)
   | DEF_fundef fdef ->
      let id = id_of_fundef fdef in
-     graph := G.add_edges (Function id) [] !graph;
+     graph := G.add_edges' (Function id) [] !graph;
      ignore (rewrite_fun (rewriters (Function id)) fdef)
   | DEF_val (LB_aux (LB_val (pat, exp), _) as lb) ->
      let ids = pat_ids pat in
-     IdSet.iter (fun id -> graph := G.add_edges (Letbind id) [] !graph) ids;
+     IdSet.iter (fun id -> graph := G.add_edges' (Letbind id) [] !graph) ids;
      IdSet.iter (fun id -> ignore (rewrite_let (rewriters (Letbind id)) lb)) ids
+  | DEF_type tdef ->
+     add_type_def_to_graph tdef
+  | DEF_pragma _ -> ()
   | _ -> ()
   end;
-  !graph
+  G.fix_leaves !graph
 
 let rec graph_of_ast (Defs defs) =
   let module G = Graph.Make(Node) in
@@ -184,11 +283,8 @@ let rec graph_of_ast (Defs defs) =
 
   | [] -> G.empty
 
-let dot_of_ast ast =
+let dot_of_ast out_chan ast =
   let module G = Graph.Make(Node) in
   let module NodeSet = Set.Make(Node) in
   let g = graph_of_ast ast in
-  let roots = NodeSet.of_list (List.map (fun str -> Function (mk_id str)) ["execute_CGetPerm"; "execute_CSeal"]) in
-  let cuts = NodeSet.of_list (List.map (fun str -> Function (mk_id str)) ["readCapReg"; "writeCapReg"; "rGPR"; "wGPR"; "SignalException"]) in
-  let g = G.prune roots cuts g in
-  G.make_dot (node_color cuts) edge_color node_string stdout g
+  G.make_dot (node_color NodeSet.empty) edge_color node_string out_chan g
diff --git a/src/pp.mli b/src/slice.mli
index 5cfb3d88..09558ebf 100644
--- a/src/pp.mli
+++ b/src/slice.mli
@@ -48,11 +48,21 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
-open Format
-val pp_str : formatter -> string -> unit
+open Ast
 
-val lst : ('a, formatter, unit) format -> (formatter -> 'b -> unit) -> formatter -> 'b list -> unit
+type node =
+  | Register of id
+  | Function of id
+  | Letbind of id
+  | Type of id
+  | Overload of id
+  | Constructor of id
 
-val opt : (formatter -> 'a -> unit) -> formatter -> 'a option -> unit
+module Node : sig
+  type t = node
+  val compare : node -> node -> int
+end
 
-val pp_to_string : (formatter -> 'a) -> string
+val graph_of_ast : Type_check.tannot defs -> Graph.Make(Node).graph
+
+val dot_of_ast : out_channel -> Type_check.tannot defs -> unit
diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml
index e26ea8a2..80bff0dd 100644
--- a/src/spec_analysis.ml
+++ b/src/spec_analysis.ml
@@ -662,3 +662,212 @@ let top_sort_defs (Defs defs) =
     List.fold_left add_def_to_graph ([], [], Namemap.empty, Namemap.empty) defs in
   let components = scc ~original_order:original_order graph in
   Defs (prelude @ List.concat (List.map (def_of_component graph defset) components))
+
+
+(* Functions for finding the set of variables assigned to.  Used in constant propagation
+   and monomorphisation. *)
+
+
+let assigned_vars exp =
+  fst (Rewriter.fold_exp
+         { (Rewriter.compute_exp_alg IdSet.empty IdSet.union) with
+           Rewriter.lEXP_id = (fun id -> IdSet.singleton id, LEXP_id id);
+           Rewriter.lEXP_cast = (fun (ty,id) -> IdSet.singleton id, LEXP_cast (ty,id)) }
+         exp)
+
+let assigned_vars_in_fexps fes =
+  List.fold_left
+    (fun vs (FE_aux (FE_Fexp (_,e),_)) -> IdSet.union vs (assigned_vars e))
+    IdSet.empty
+    fes
+
+let assigned_vars_in_pexp (Pat_aux (p,_)) =
+  match p with
+  | Pat_exp (_,e) -> assigned_vars e
+  | Pat_when (p,e1,e2) -> IdSet.union (assigned_vars e1) (assigned_vars e2)
+
+let rec assigned_vars_in_lexp (LEXP_aux (le,_)) =
+  match le with
+  | LEXP_id id
+  | LEXP_cast (_,id) -> IdSet.singleton id
+  | LEXP_tup lexps
+  | LEXP_vector_concat lexps -> 
+     List.fold_left (fun vs le -> IdSet.union vs (assigned_vars_in_lexp le)) IdSet.empty lexps
+  | LEXP_memory (_,es) -> List.fold_left (fun vs e -> IdSet.union vs (assigned_vars e)) IdSet.empty es
+  | LEXP_vector (le,e) -> IdSet.union (assigned_vars_in_lexp le) (assigned_vars e)
+  | LEXP_vector_range (le,e1,e2) ->
+     IdSet.union (assigned_vars_in_lexp le) (IdSet.union (assigned_vars e1) (assigned_vars e2))
+  | LEXP_field (le,_) -> assigned_vars_in_lexp le
+  | LEXP_deref e -> assigned_vars e
+
+
+let pat_id_is_variable env id =
+  match Type_check.Env.lookup_id id env with
+  (* Unbound is returned for both variables and constructors which take
+     arguments, but the latter only don't appear in a P_id *)
+  | Unbound
+  (* Shadowing of immutable locals is allowed; mutable locals and registers
+     are rejected by the type checker, so don't matter *)
+  | Local _
+  | Register _
+    -> true
+  | Enum _ -> false
+
+let bindings_from_pat p =
+  let rec aux_pat (P_aux (p,(l,annot))) =
+    let env = Type_check.env_of_annot (l, annot) in
+    match p with
+    | P_lit _
+    | P_wild
+      -> []
+    | P_or (p1, p2) -> aux_pat p1 @ aux_pat p2
+    | P_not (p) -> aux_pat p
+    | P_as (p,id) -> id::(aux_pat p)
+    | P_typ (_,p) -> aux_pat p
+    | P_id id ->
+       if pat_id_is_variable env id then [id] else []
+    | P_var (p,kid) -> aux_pat p
+    | P_vector ps
+    | P_vector_concat ps
+    | P_string_append ps
+    | P_app (_,ps)
+    | P_tup ps
+    | P_list ps
+      -> List.concat (List.map aux_pat ps)
+    | P_record (fps,_) -> List.concat (List.map aux_fpat fps)
+    | P_cons (p1,p2) -> aux_pat p1 @ aux_pat p2
+  and aux_fpat (FP_aux (FP_Fpat (_,p), _)) = aux_pat p
+  in aux_pat p
+
+
+(* TODO: replace the below with solutions that don't depend so much on the
+   structure of the environment. *)
+
+let rec flatten_constraints = function
+  | [] -> []
+  | (NC_aux (NC_and (nc1,nc2),_))::t -> flatten_constraints (nc1::nc2::t)
+  | h::t -> h::(flatten_constraints t)
+
+(* NB: this only looks for direct equalities with the given kid.  It would be
+   better in principle to find the entire set of equal kids, but it isn't
+   necessary to deal with the fresh kids produced by the type checker while
+   checking P_var patterns, so we don't do it for now. *)
+let equal_kids_ncs kid ncs =
+  let is_eq = function
+    | NC_aux (NC_equal (Nexp_aux (Nexp_var var1,_), Nexp_aux (Nexp_var var2,_)),_) ->
+       if Kid.compare kid var1 == 0 then Some var2 else
+         if Kid.compare kid var2 == 0 then Some var1 else
+           None
+    | _ -> None
+  in
+  let kids = Util.map_filter is_eq ncs in
+  List.fold_left (fun s k -> KidSet.add k s) (KidSet.singleton kid) kids
+
+let equal_kids env kid =
+  let ncs = flatten_constraints (Type_check.Env.get_constraints env) in
+  equal_kids_ncs kid ncs
+
+
+
+(* TODO: kid shadowing *)
+let nexp_subst_fns substs =
+  let s_t t = subst_kids_typ substs t in
+(*  let s_typschm (TypSchm_aux (TypSchm_ts (q,t),l)) = TypSchm_aux (TypSchm_ts (q,s_t t),l) in
+   hopefully don't need this anyway *)(*
+  let s_typschm tsh = tsh in*)
+  let s_tannot tannot =
+    match Type_check.destruct_tannot tannot with
+    | None -> Type_check.empty_tannot
+    | Some (env,t,eff) -> Type_check.mk_tannot env (s_t t) eff (* TODO: what about env? *)
+  in
+  let rec s_pat (P_aux (p,(l,annot))) =
+    let re p = P_aux (p,(l,s_tannot annot)) in
+    match p with
+    | P_lit _ | P_wild | P_id _ -> re p
+    | P_or (p1, p2) -> re (P_or (s_pat p1, s_pat p2))
+    | P_not (p) -> re (P_not (s_pat p))
+    | P_var (p',tpat) -> re (P_var (s_pat p',tpat))
+    | P_as (p',id) -> re (P_as (s_pat p', id))
+    | P_typ (ty,p') -> re (P_typ (s_t ty,s_pat p'))
+    | P_app (id,ps) -> re (P_app (id, List.map s_pat ps))
+    | P_record (fps,flag) -> re (P_record (List.map s_fpat fps, flag))
+    | P_vector ps -> re (P_vector (List.map s_pat ps))
+    | P_vector_concat ps -> re (P_vector_concat (List.map s_pat ps))
+    | P_string_append ps -> re (P_string_append (List.map s_pat ps))
+    | P_tup ps -> re (P_tup (List.map s_pat ps))
+    | P_list ps -> re (P_list (List.map s_pat ps))
+    | P_cons (p1,p2) -> re (P_cons (s_pat p1, s_pat p2))
+  and s_fpat (FP_aux (FP_Fpat (id, p), (l,annot))) =
+    FP_aux (FP_Fpat (id, s_pat p), (l,s_tannot annot))
+  in
+  let rec s_exp (E_aux (e,(l,annot))) =
+    let re e = E_aux (e,(l,s_tannot annot)) in
+      match e with
+      | E_block es -> re (E_block (List.map s_exp es))
+      | E_nondet es -> re (E_nondet (List.map s_exp es))
+      | E_id _
+      | E_ref _
+      | E_lit _
+      | E_internal_value _
+        -> re e
+      | E_sizeof ne -> begin
+         let ne' = subst_kids_nexp substs ne in
+         match ne' with
+         | Nexp_aux (Nexp_constant i,l) -> re (E_lit (L_aux (L_num i,l)))
+         | _ -> re (E_sizeof ne')
+      end
+      | E_constraint nc -> re (E_constraint (subst_kids_nc substs nc))
+      | E_cast (t,e') -> re (E_cast (s_t t, s_exp e'))
+      | E_app (id,es) -> re (E_app (id, List.map s_exp es))
+      | E_app_infix (e1,id,e2) -> re (E_app_infix (s_exp e1,id,s_exp e2))
+      | E_tuple es -> re (E_tuple (List.map s_exp es))
+      | E_if (e1,e2,e3) -> re (E_if (s_exp e1, s_exp e2, s_exp e3))
+      | E_for (id,e1,e2,e3,ord,e4) -> re (E_for (id,s_exp e1,s_exp e2,s_exp e3,ord,s_exp e4))
+      | E_loop (loop,e1,e2) -> re (E_loop (loop,s_exp e1,s_exp e2))
+      | E_vector es -> re (E_vector (List.map s_exp es))
+      | E_vector_access (e1,e2) -> re (E_vector_access (s_exp e1,s_exp e2))
+      | E_vector_subrange (e1,e2,e3) -> re (E_vector_subrange (s_exp e1,s_exp e2,s_exp e3))
+      | E_vector_update (e1,e2,e3) -> re (E_vector_update (s_exp e1,s_exp e2,s_exp e3))
+      | E_vector_update_subrange (e1,e2,e3,e4) -> re (E_vector_update_subrange (s_exp e1,s_exp e2,s_exp e3,s_exp e4))
+      | E_vector_append (e1,e2) -> re (E_vector_append (s_exp e1,s_exp e2))
+      | E_list es -> re (E_list (List.map s_exp es))
+      | E_cons (e1,e2) -> re (E_cons (s_exp e1,s_exp e2))
+      | E_record fes -> re (E_record (List.map s_fexp fes))
+      | E_record_update (e,fes) -> re (E_record_update (s_exp e, List.map s_fexp fes))
+      | E_field (e,id) -> re (E_field (s_exp e,id))
+      | E_case (e,cases) -> re (E_case (s_exp e, List.map s_pexp cases))
+      | E_let (lb,e) -> re (E_let (s_letbind lb, s_exp e))
+      | E_assign (le,e) -> re (E_assign (s_lexp le, s_exp e))
+      | E_exit e -> re (E_exit (s_exp e))
+      | E_return e -> re (E_return (s_exp e))
+      | E_assert (e1,e2) -> re (E_assert (s_exp e1,s_exp e2))
+      | E_var (le,e1,e2) -> re (E_var (s_lexp le, s_exp e1, s_exp e2))
+      | E_internal_plet (p,e1,e2) -> re (E_internal_plet (s_pat p, s_exp e1, s_exp e2))
+      | E_internal_return e -> re (E_internal_return (s_exp e))
+      | E_throw e -> re (E_throw (s_exp e))
+      | E_try (e,cases) -> re (E_try (s_exp e, List.map s_pexp cases))
+    and s_fexp (FE_aux (FE_Fexp (id,e), (l,annot))) =
+      FE_aux (FE_Fexp (id,s_exp e),(l,s_tannot annot))
+    and s_pexp = function
+      | (Pat_aux (Pat_exp (p,e),(l,annot))) ->
+         Pat_aux (Pat_exp (s_pat p, s_exp e),(l,s_tannot annot))
+      | (Pat_aux (Pat_when (p,e1,e2),(l,annot))) ->
+         Pat_aux (Pat_when (s_pat p, s_exp e1, s_exp e2),(l,s_tannot annot))
+    and s_letbind (LB_aux (lb,(l,annot))) =
+      match lb with
+      | LB_val (p,e) -> LB_aux (LB_val (s_pat p,s_exp e), (l,s_tannot annot))
+    and s_lexp (LEXP_aux (e,(l,annot))) =
+      let re e = LEXP_aux (e,(l,s_tannot annot)) in
+      match e with
+      | LEXP_id _ -> re e
+      | LEXP_cast (typ,id) -> re (LEXP_cast (s_t typ, id))
+      | LEXP_memory (id,es) -> re (LEXP_memory (id,List.map s_exp es))
+      | LEXP_tup les -> re (LEXP_tup (List.map s_lexp les))
+      | LEXP_vector (le,e) -> re (LEXP_vector (s_lexp le, s_exp e))
+      | LEXP_vector_range (le,e1,e2) -> re (LEXP_vector_range (s_lexp le, s_exp e1, s_exp e2))
+      | LEXP_vector_concat les -> re (LEXP_vector_concat (List.map s_lexp les))
+      | LEXP_field (le,id) -> re (LEXP_field (s_lexp le, id))
+      | LEXP_deref e -> re (LEXP_deref (s_exp e))
+  in (s_pat,s_exp)
+let nexp_subst_pat substs = fst (nexp_subst_fns substs)
+let nexp_subst_exp substs = snd (nexp_subst_fns substs)
diff --git a/src/spec_analysis.mli b/src/spec_analysis.mli
index f13dd596..8586ac15 100644
--- a/src/spec_analysis.mli
+++ b/src/spec_analysis.mli
@@ -49,6 +49,7 @@
 (**************************************************************************)
 
 open Ast
+open Ast_util
 open Util
 open Type_check
 
@@ -76,3 +77,21 @@ val is_within_machine64 : typ -> nexp_range list -> triple *)
 (* val restrict_defs : 'a defs -> string list -> 'a defs *)
 
 val top_sort_defs : tannot defs -> tannot defs
+
+(** Return the set of mutable variables assigned to in the given AST. *)
+val assigned_vars : 'a exp -> IdSet.t
+val assigned_vars_in_fexps : 'a fexp list -> IdSet.t
+val assigned_vars_in_pexp : 'a pexp -> IdSet.t
+val assigned_vars_in_lexp : 'a lexp -> IdSet.t
+
+(** Variable bindings in patterns *)
+val pat_id_is_variable : env -> id -> bool
+val bindings_from_pat : tannot pat -> id list
+
+val equal_kids_ncs : kid -> n_constraint list -> KidSet.t
+val equal_kids : env -> kid -> KidSet.t
+
+(** Type-level substitutions into patterns and expressions.  Also attempts to
+    update type annotations, but not the associated environments. *)
+val nexp_subst_pat : nexp KBindings.t -> tannot pat -> tannot pat
+val nexp_subst_exp : nexp KBindings.t -> tannot exp -> tannot exp
diff --git a/src/specialize.ml b/src/specialize.ml
index 17d04a46..6b5b108a 100644
--- a/src/specialize.ml
+++ b/src/specialize.ml
@@ -52,6 +52,8 @@ open Ast
 open Ast_util
 open Rewriter
 
+let opt_ddump_spec_ast = ref None
+   
 let is_typ_ord_arg = function
   | A_aux (A_typ _, _) -> true
   | A_aux (A_order _, _) -> true
@@ -254,7 +256,7 @@ let rec instantiations_of spec id ast =
   !instantiations
 
 let rec rewrite_polymorphic_calls spec id ast =
-  let vs_ids = Initial_check.val_spec_ids ast in
+  let vs_ids = val_spec_ids ast in
 
   let rewrite_e_aux = function
     | E_aux (E_app (id', args), annot) as exp when Id.compare id id' = 0 ->
@@ -335,7 +337,8 @@ and remove_implicit_arg (A_aux (aux, l)) =
 let kopt_arg = function
   | KOpt_aux (KOpt_kind (K_aux (K_int, _), kid), _) -> arg_nexp (nvar kid)
   | KOpt_aux (KOpt_kind (K_aux (K_type,_), kid), _) -> arg_typ (mk_typ (Typ_var kid))
-  | _ -> failwith "oh no"
+  | KOpt_aux (KOpt_kind (K_aux (K_bool, _), kid), _) -> arg_bool (nc_var kid)
+  | KOpt_aux (KOpt_kind (K_aux (K_order, _), kid), _) -> arg_order (mk_ord (Ord_var kid))
 
 (* For numeric type arguments we have to be careful not to run into a
    situation where we have an instantiation like
@@ -492,7 +495,7 @@ let initial_calls = IdSet.of_list
 
 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 vs_ids = val_spec_ids ast in
 
   let inspect_exp = function
     | E_aux (E_app (call, _), _) as exp ->
@@ -565,6 +568,15 @@ let specialize_ids spec ids ast =
       (1, ast) (IdSet.elements ids)
   in
   let ast = reorder_typedefs ast in
+  begin match !opt_ddump_spec_ast with
+  | Some (f, i) ->
+     let filename = f ^ "_spec_" ^ string_of_int i ^ ".sail" in
+     let out_chan = open_out filename in
+     Pretty_print_sail.pp_defs out_chan ast;
+     close_out out_chan;
+     opt_ddump_spec_ast := Some (f, i + 1)
+  | None -> ()
+  end;
   let ast, _ = Type_error.check Type_check.initial_env ast in
   let ast =
     List.fold_left (fun ast id -> rewrite_polymorphic_calls spec id ast) ast (IdSet.elements ids)
diff --git a/src/type_check.ml b/src/type_check.ml
index 25ebb24e..e32ac45c 100644
--- a/src/type_check.ml
+++ b/src/type_check.ml
@@ -428,6 +428,7 @@ module Env : sig
   val get_typ_var_loc : kid -> t -> Ast.l
   val get_typ_vars : t -> kind_aux KBindings.t
   val get_typ_var_locs : t -> Ast.l KBindings.t
+  val add_typ_var_shadow : l -> kinded_id -> t -> t * kid option
   val add_typ_var : l -> kinded_id -> t -> t
   val get_ret_typ : t -> typ option
   val add_ret_typ : typ -> t -> t
@@ -651,10 +652,9 @@ end = struct
                           ^ " with " ^ Util.string_of_list ", " string_of_n_constraint env.constraints)
 
   let get_typ_synonym id env =
-    begin match Bindings.find_opt id env.typ_synonyms with
+    match Bindings.find_opt id env.typ_synonyms with
     | Some (typq, arg) -> mk_synonym typq arg
     | None -> raise Not_found
-    end
 
   let rec expand_constraint_synonyms env (NC_aux (aux, l) as nc) =
     typ_debug ~level:2 (lazy ("Expanding " ^ string_of_n_constraint nc));
@@ -1191,7 +1191,7 @@ end = struct
     with
     | Not_found -> Unbound
 
-  let add_typ_var l (KOpt_aux (KOpt_kind (K_aux (k, _), v), _)) env =
+  let add_typ_var_shadow 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
@@ -1201,13 +1201,15 @@ end = struct
           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
-        }
+        }, Some s_v
       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 }
+        { env with typ_vars = KBindings.add v (l, k) env.typ_vars }, None
       end
 
+  let add_typ_var l kopt env = fst (add_typ_var_shadow l kopt env)
+
   let get_constraints env = env.constraints
 
   let add_constraint constr env =
@@ -1832,7 +1834,7 @@ let instantiate_quants quants unifier =
    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, _)) =
+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
@@ -1857,6 +1859,10 @@ and ambiguous_nexp_vars (Nexp_aux (aux, _)) =
   | Nexp_sum (nexp1, nexp2) -> KidSet.union (tyvars_of_nexp nexp1) (tyvars_of_nexp nexp2)
   | _ -> KidSet.empty
 
+let ambiguous_vars typ =
+  let vars = ambiguous_vars' typ in
+  if KidSet.cardinal vars > 1 then vars else KidSet.empty
+
 (**************************************************************************)
 (* 3.5. Subtyping with existentials                                       *)
 (**************************************************************************)
@@ -3124,6 +3130,8 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
      end
   | P_app (f, pats) when Env.is_union_constructor f env ->
      begin
+       (* Treat Ctor((p, x)) the same as Ctor(p, x) *)
+       let pats = match pats with [P_aux (P_tup pats, _)] -> pats | _ -> pats in
        let (typq, ctor_typ) = Env.get_union_id f env in
        let quants = quant_items typq in
        let untuple (Typ_aux (typ_aux, _) as typ) = match typ_aux with
@@ -3143,6 +3151,7 @@ and bind_pat env (P_aux (pat_aux, (l, ())) as pat) (Typ_aux (typ_aux, _) as typ)
                 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 arg_typ', env = bind_existential l None arg_typ' env in
               let tpats, env, guards =
                 try List.fold_left2 bind_tuple_pat ([], env, []) pats (untuple arg_typ') with
                 | Invalid_argument _ -> typ_error env l "Union constructor pattern arguments have incorrect length"
@@ -3316,15 +3325,20 @@ and infer_pat env (P_aux (pat_aux, (l, ())) as 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) =
+  typ_print (lazy (Util.("Binding type pattern " |> yellow |> clear) ^ string_of_typ_pat typ_pat ^ " to " ^ string_of_typ typ));
   match typ_pat_aux, typ_aux with
   | TP_wild, _ -> env
   | TP_var kid, _ ->
      begin
        match typ_nexps typ, typ_constraints typ with
        | [nexp], [] ->
-          Env.add_constraint (nc_eq (nvar kid) nexp) (Env.add_typ_var l (mk_kopt K_int kid) env)
+          let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_int kid) env in
+          let nexp = match shadow with Some s_v -> nexp_subst kid (arg_nexp (nvar s_v)) nexp | None -> nexp in
+          Env.add_constraint (nc_eq (nvar kid) nexp) env
        | [], [nc] ->
-          Env.add_constraint (nc_and (nc_or (nc_not nc) (nc_var kid)) (nc_or nc (nc_not (nc_var kid)))) (Env.add_typ_var l (mk_kopt K_bool kid) env)
+          let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_bool kid) env in
+          let nexp = match shadow with Some s_v -> constraint_subst kid (arg_bool (nc_var s_v)) nc | None -> nc in
+          Env.add_constraint (nc_and (nc_or (nc_not nc) (nc_var kid)) (nc_or nc (nc_not (nc_var kid)))) env
        | [], [] ->
           typ_error env l ("No numeric expressions in " ^ string_of_typ typ ^ " to bind " ^ string_of_kid kid ^ " to")
        | _, _ ->
@@ -3337,7 +3351,9 @@ and bind_typ_pat_arg env (TP_aux (typ_pat_aux, l) as typ_pat) (A_aux (typ_arg_au
   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)
+     let env, shadow = Env.add_typ_var_shadow l (mk_kopt K_int kid) env in
+     let nexp = match shadow with Some s_v -> nexp_subst kid (arg_nexp (nvar s_v)) nexp | None -> nexp in
+     Env.add_constraint (nc_eq (nvar kid) nexp) env
   | _, A_typ typ -> bind_typ_pat env typ_pat typ
   | _, 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)
diff --git a/src/type_check.mli b/src/type_check.mli
index 048f5cb4..1712be58 100644
--- a/src/type_check.mli
+++ b/src/type_check.mli
@@ -56,19 +56,21 @@ module Big_int = Nat_big_num
 
 (** [opt_tc_debug] controls the verbosity of the type checker. 0 is
    silent, 1 prints a tree of the type derivation and 2 is like 1 but
-   with much more debugging information. *)
+   with much more debugging information. 3 is the highest level, and
+   is even more verbose still. *)
 val opt_tc_debug : int ref
 
-(** [opt_no_effects] turns of the effect checking. This can break
-   re-writer passes, so it should only be used for debugging. *)
+(** [opt_no_effects] turns of the effect checking. Effects will still
+   be propagated as normal however. *)
 val opt_no_effects : bool ref
 
 (** [opt_no_lexp_bounds_check] turns of the bounds checking in vector
    assignments in l-expressions. *)
 val opt_no_lexp_bounds_check : bool ref
 
-(** opt_expand_valspec expands typedefs in valspecs during type check.
-   We prefer not to do it for latex output but it is otherwise a good idea. *)
+(** [opt_expand_valspec] expands typedefs in valspecs during type
+   checking. We prefer not to do it for latex output but it is
+   otherwise a good idea. *)
 val opt_expand_valspec : bool ref
 
 (** Linearize cases involving power where we would otherwise require
@@ -204,9 +206,11 @@ module Env : sig
      node. *)
   val no_casts : t -> t
 
-  (* Is casting allowed by the environment? *)
+  (** Is casting allowed by the environment? *)
   val allow_casts : t -> bool
 
+  (** Note: Likely want use Type_check.initial_env instead. The empty
+     environment is lacking even basic builtins. *)
   val empty : t
 
   val pattern_completeness_ctx : t -> Pattern_completeness.ctx
@@ -218,17 +222,12 @@ module Env : sig
   val set_prover : (t -> n_constraint -> bool) option -> t -> t
 end
 
+(** {4 Environment helper functions} *)
+
 (** Push all the type variables and constraints from a typquant into
    an environment *)
 val add_typquant : Ast.l -> typquant -> Env.t -> Env.t
 
-(** Safely destructure an existential type. Returns None if the type
-   is not existential. This function will pick a fresh name for the
-   existential to ensure that no name-clashes occur. 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 add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t
 
 (** When the typechecker creates new type variables it gives them
@@ -240,10 +239,10 @@ val add_existential : Ast.l -> kinded_id list -> n_constraint -> Env.t -> Env.t
    not of this form. *)
 val orig_kid : kid -> kid
 
-(* Vector with default order. *)
+(** Vector with default order as set in environment by [default Order ord] *)
 val dvector_typ : Env.t -> nexp -> typ -> typ
 
-val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ
+(** {2 Type annotations} *)
 
 (** The type of type annotations *)
 type tannot
@@ -282,7 +281,7 @@ val strip_lexp : 'a lexp -> unit lexp
 val strip_mpexp : 'a mpexp -> unit mpexp
 val strip_mapcl : 'a mapcl -> unit mapcl
 
-(* Strip location information from types for comparison purposes *)
+(** Strip location information from types for comparison purposes *)
 val strip_typ : typ -> typ
 val strip_typq : typquant -> typquant
 val strip_id : id -> id
@@ -376,6 +375,15 @@ val expected_typ_of : Ast.l * tannot -> typ option
 
 (** {2 Utilities } *)
 
+(** Safely destructure an existential type. Returns None if the type
+   is not existential. This function will pick a fresh name for the
+   existential to ensure that no name-collisions occur, although we
+   can optionally suggest a name for the case where it would not cause
+   a collision. The "plain" version does not treat numeric types
+   (i.e. range, int, nat) 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_atom_nexp : Env.t -> typ -> nexp option
 
 val destruct_atom_bool : Env.t -> typ -> n_constraint option
@@ -386,6 +394,10 @@ val destruct_numeric : ?name:string option -> typ -> (kid list * n_constraint *
 
 val destruct_vector : Env.t -> typ -> (nexp * order * typ) option
 
+(** Construct an existential type with a guaranteed fresh
+   identifier. *)
+val exist_typ : (kid -> n_constraint) -> (kid -> typ) -> typ
+
 val subst_unifiers : typ_arg KBindings.t -> typ -> typ
 
 (** [unify l env goals typ1 typ2] returns set of typ_arg bindings such
@@ -396,6 +408,7 @@ val subst_unifiers : typ_arg KBindings.t -> typ -> typ
    typ2 (occurs check). *)
 val unify : l -> Env.t -> KidSet.t -> typ -> typ -> typ_arg KBindings.t
 
+(** Check if two types are alpha equivalent *)
 val alpha_equivalent : Env.t -> typ -> typ -> bool
 
 (** Throws Invalid_argument if the argument is not a E_app expression *)
@@ -414,7 +427,7 @@ val propagate_pexp_effect : tannot pexp -> tannot pexp * effect
 
 val big_int_of_nexp : nexp -> Big_int.num option
 
-(** {2 Checking full AST} *)
+(** {2 Checking full ASTs} *)
 
 (** Fully type-check an AST
 
diff --git a/src/util.ml b/src/util.ml
index 0ff00df1..703bbc1f 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -149,11 +149,16 @@ let rec power i tothe =
   then 1
   else i * power i (tothe - 1)
 
-let rec assoc_maybe eq l k =
+let rec assoc_equal_opt eq k l =
   match l with
     | [] -> None
-    | (k',v)::l -> if (eq k k') then Some v else assoc_maybe eq l k
+    | (k',v)::l -> if (eq k k') then Some v else assoc_equal_opt eq k l
 
+let rec assoc_compare_opt cmp k l =
+  match l with
+    | [] -> None
+    | (k',v)::l -> if cmp k k' = 0 then Some v else assoc_compare_opt cmp k l
+                 
 let rec compare_list f l1 l2 = 
   match (l1,l2) with
     | ([],[]) -> 0
@@ -324,18 +329,7 @@ module IntIntSet = Set.Make(
     type t = int * int
   end )
 
-
-module ExtraSet = functor (S : Set.S) ->
-  struct 
-    let add_list s l = List.fold_left (fun s x -> S.add x s) s l
-    let from_list l = add_list S.empty l
-    let list_union l = List.fold_left S.union S.empty l
-    let list_inter = function s :: l -> List.fold_left S.inter s l
-       | [] -> raise (Failure "ExtraSet.list_inter")
-  end;;
-
-
-let copy_file src dst = 
+let copy_file src dst =
   let len = 5096 in
   let b = Bytes.make len ' ' in
   let read_len = ref 0 in
@@ -352,7 +346,7 @@ let move_file src dst =
    try
      (* try efficient version *)
      Sys.rename src dst
-   with Sys_error _ -> 
+   with Sys_error _ ->
    begin
      (* OK, do it the the hard way *)
      copy_file src dst;
@@ -365,7 +359,7 @@ let same_content_files file1 file2 : bool =
     let s1 = Stream.of_channel (open_in_bin file1) in
     let s2 = Stream.of_channel (open_in_bin file2) in
     let stream_is_empty s = (try Stream.empty s; true with Stream.Failure -> false) in
-    try 
+    try
       while ((Stream.next s1) = (Stream.next s2)) do () done;
       false
     with Stream.Failure -> stream_is_empty s1 && stream_is_empty s2
@@ -449,9 +443,6 @@ let zencode_string str = "z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.ma
 
 let zencode_upper_string str = "Z" ^ List.fold_left (fun s1 s2 -> s1 ^ s2) "" (List.map zchar (string_to_list str))
 
-(** Encode string for use as a filename. We can't use zencode directly
-   because some operating systems make the mistake of being
-   case-insensitive. *)
 let file_encode_string str =
   let zstr = zencode_string str in
   let md5 = Digest.to_hex (Digest.string zstr) in
diff --git a/src/util.mli b/src/util.mli
index 51504941..06fd5eff 100644
--- a/src/util.mli
+++ b/src/util.mli
@@ -48,6 +48,8 @@
 (*  SUCH DAMAGE.                                                          *)
 (**************************************************************************)
 
+(** Various non Sail specific utility functions *)
+
 (* Last element of a list *)
 val last : 'a list -> 'a
 
@@ -72,7 +74,12 @@ val remove_duplicates : 'a list -> 'a list
 (** [remove_dups compare eq l] as remove_duplicates but with parameterised comparison and equality *)
 val remove_dups : ('a -> 'a -> int) -> ('a -> 'a -> bool) -> 'a list -> 'a list
 
-val assoc_maybe : ('a -> 'a -> bool) -> ('a * 'b) list -> 'a -> 'b option
+(** [assoc_equal_opt] and [assoc_compare_opt] are like List.assoc_opt
+   but take equality/comparison functions as arguments, rather than
+   relying on OCaml's built in equality *)
+val assoc_equal_opt : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b option
+
+val assoc_compare_opt : ('a -> 'a -> int) -> 'a -> ('a * 'b) list -> 'b option
 
 val power : int -> int -> int
 
@@ -118,6 +125,9 @@ val option_all : 'a option list -> 'a list option
     similarly [y] in case [h y] returns [None]. *)
 val changed2 : ('a -> 'b -> 'c) -> ('a -> 'a option) -> 'a -> ('b -> 'b option) -> 'b -> 'c option
 
+val is_some : 'a option -> bool
+val is_none : 'a option -> bool
+
 (** {2 List Functions} *)
 
 (** [list_index p l] returns the first index [i] such that
@@ -134,14 +144,14 @@ val option_first: ('a -> 'b option) -> 'a list -> 'b option
     If for all elements of [l] the
     function [f] returns [None], then [map_changed f l] returns [None].
     Otherwise, it uses [x] for all elements, where [f x] returns [None],
-    and returns the resulting list. *)   
+    and returns the resulting list. *)
 val map_changed : ('a -> 'a option) -> 'a list -> 'a list option
 
 (** [map_changed_default d f l] maps [f] over [l].
     If for all elements of [l] the
     function [f] returns [None], then [map_changed f l] returns [None].
     Otherwise, it uses [d x] for all elements [x], where [f x] returns [None],
-    and returns the resulting list. *)   
+    and returns the resulting list. *)
 val map_changed_default : ('a -> 'b) -> ('a -> 'b option) -> 'a list -> 'b list option
 
 (** [list_mapi f l] maps [f] over [l]. In contrast to the standard
@@ -151,7 +161,7 @@ val list_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
 
 (** [list_iter sf f [a1; ...; an]] applies function [f] in turn to [a1; ...; an] and
     calls [sf ()] in between. It is equivalent to [begin f a1; sf(); f a2; sf(); ...; f an; () end]. *)
-val list_iter_sep : (unit -> unit) -> ('a -> unit) -> 'a list -> unit 
+val list_iter_sep : (unit -> unit) -> ('a -> unit) -> 'a list -> unit
 
 (** [map_filter f l] maps [f] over [l] and removes all entries [x] of [l]
     with [f x = None]. *)
@@ -179,6 +189,12 @@ val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
 
 val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int
 
+val take : int -> 'a list -> 'a list
+val drop : int -> 'a list -> 'a list
+
+val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list)
+
+val list_init : int -> (int -> 'a) -> 'a list
 
 (** {2 Files} *)
 
@@ -208,41 +224,16 @@ val string_to_list : string -> char list
 module IntSet : Set.S with type elt = int
 module IntIntSet : Set.S with type elt = int * int
 
-(** Some useful extra functions for sets *)
-module ExtraSet : functor (S : Set.S) ->
-   sig
-     (** Add a list of values to an existing set. *)
-     val add_list : S.t -> S.elt list -> S.t
-
-     (** Construct a set from a list. *)
-     val from_list : S.elt list -> S.t
+(** {2 Formatting functions} *)
 
-     (** Builds the union of a list of sets  *)
-     val list_union : S.t list -> S.t
-
-     (** Builds the intersection of a list of sets.
-         If the list is empty, a match exception is thrown. *)
-     val list_inter : S.t list -> S.t
-   end
-
-val list_init : int -> (int -> 'a) -> 'a list
-
-(*Formatting functions*)
 val string_of_list : string -> ('a -> string) -> 'a list -> string
 
 val string_of_option : ('a -> string) -> 'a option -> string
 
 val split_on_char : char -> string -> string list
 
-val is_some : 'a option -> bool
-val is_none : 'a option -> bool
-
-val take : int -> 'a list -> 'a list
-val drop : int -> 'a list -> 'a list
-
-val take_drop : ('a -> bool) -> 'a list -> ('a list * 'a list)
+(** {2 Terminal color codes} *)
 
-(* Terminal color codes *)
 val termcode : int -> string
 val bold : string -> string
 val darkgray : string -> string
@@ -255,14 +246,27 @@ val blue : string -> string
 val magenta : string -> string
 val clear : string -> string
 
-val warn : string -> unit
+(** {2 Encoding schemes for strings} *)
+
+(** z-encoding will take any string with ASCII characters in the range
+   32-126 inclusive, and map it to a string that just contains ASCII
+   upper and lower case letters and numbers, prefixed with the letter
+   z. This mapping is one-to-one. *)
 
 val zencode_string : string -> string
 val zencode_upper_string : string -> string
 
+(** Encode string for use as a filename. We can't use zencode directly
+   because some operating systems make the mistake of being
+   case-insensitive. *)
 val file_encode_string : string -> string
 
+(** {2 Misc output functions} *)
+
 val log_line : string -> int -> string -> string
+
 val header : string -> int -> string
 
 val progress : string -> string -> int -> int -> unit
+
+val warn : string -> unit
diff --git a/test/aarch64_small/run_tests.sh b/test/aarch64_small/run_tests.sh
new file mode 100755
index 00000000..cc6f223e
--- /dev/null
+++ b/test/aarch64_small/run_tests.sh
@@ -0,0 +1,57 @@
+#!/usr/bin/env bash
+set -e
+
+DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )"
+cd $DIR
+SAILDIR="$DIR/../.."
+
+RED='\033[0;91m'
+GREEN='\033[0;92m'
+YELLOW='\033[0;93m'
+NC='\033[0m'
+
+rm -f $DIR/tests.xml
+
+pass=0
+fail=0
+XML=""
+
+function green {
+    (( pass += 1 ))
+    printf "$1: ${GREEN}$2${NC}\n"
+    XML+="    <testcase name=\"$1\"/>\n"
+}
+
+function yellow {
+    (( fail += 1 ))
+    printf "$1: ${YELLOW}$2${NC}\n"
+    XML+="    <testcase name=\"$1\">\n      <error message=\"$2\">$2</error>\n    </testcase>\n"
+}
+
+function red {
+    (( fail += 1 ))
+    printf "$1: ${RED}$2${NC}\n"
+    XML+="    <testcase name=\"$1\">\n      <error message=\"$2\">$2</error>\n    </testcase>\n"
+}
+
+function finish_suite {
+    printf "$1: Passed ${pass} out of $(( pass + fail ))\n\n"
+    XML="  <testsuite name=\"$1\" tests=\"$(( pass + fail ))\" failures=\"${fail}\" timestamp=\"$(date)\">\n$XML  </testsuite>\n"
+    printf "$XML" >> $DIR/tests.xml
+    XML=""
+    pass=0
+    fail=0
+}
+
+printf "<testsuites>\n" >> $DIR/tests.xml
+
+if make -B -C ../../aarch64_small SAIL="$SAILDIR/sail"
+then
+    green "built aarch64_small to lem" "ok"
+else
+    red "failed to build lem" "fail"
+fi
+
+finish_suite "aarch64_small tests"
+
+printf "</testsuites>\n" >> $DIR/tests.xml
diff --git a/test/c/extend_simple.expect b/test/c/extend_simple.expect
new file mode 100644
index 00000000..3a652eaf
--- /dev/null
+++ b/test/c/extend_simple.expect
@@ -0,0 +1,2 @@
+x = 0xFFFFFFFF
+y = 0x00000000FFFFFFFF
diff --git a/test/c/extend_simple.sail b/test/c/extend_simple.sail
new file mode 100644
index 00000000..23f14235
--- /dev/null
+++ b/test/c/extend_simple.sail
@@ -0,0 +1,10 @@
+default Order dec
+
+$include <prelude.sail>
+
+function main((): unit) -> unit = {
+  let x = sail_sign_extend(0xFF, 32);
+  let y = sail_zero_extend(x, 64);
+  print_bits("x = ", x);
+  print_bits("y = ", y)
+}
\ No newline at end of file
diff --git a/test/c/fast_signed.expect b/test/c/fast_signed.expect
new file mode 100644
index 00000000..9fcfea23
--- /dev/null
+++ b/test/c/fast_signed.expect
@@ -0,0 +1,12 @@
+x = -1
+y = -1
+z = -1
+w = -1
+x = -128
+y = -32768
+z = -9223372036854775808
+w = -170141183460469231731687303715884105728
+x = 127
+y = 32767
+z = 9223372036854775807
+w = 170141183460469231731687303715884105727
diff --git a/test/c/fast_signed.sail b/test/c/fast_signed.sail
new file mode 100644
index 00000000..b0f16f89
--- /dev/null
+++ b/test/c/fast_signed.sail
@@ -0,0 +1,30 @@
+default Order dec
+
+$include <prelude.sail>
+
+function main((): unit) -> unit = {
+  let x = signed(0xFF);
+  let y = signed(0xFFFF);
+  let z = signed(0xFFFFFFFF_FFFFFFFF);
+  let w = signed(0xFFFFFFFF_FFFFFFFF_FFFFFFFF_FFFFFFFF);
+  print_int("x = ", x);
+  print_int("y = ", y);
+  print_int("z = ", z);
+  print_int("w = ", w);
+  let x = signed(0x80);
+  let y = signed(0x8000);
+  let z = signed(0x80000000_00000000);
+  let w = signed(0x80000000_00000000_00000000_00000000);
+  print_int("x = ", x);
+  print_int("y = ", y);
+  print_int("z = ", z);
+  print_int("w = ", w);
+  let x = signed(0x7F);
+  let y = signed(0x7FFF);
+  let z = signed(0x7FFFFFFF_FFFFFFFF);
+  let w = signed(0x7FFFFFFF_FFFFFFFF_FFFFFFFF_FFFFFFFF);
+  print_int("x = ", x);
+  print_int("y = ", y);
+  print_int("z = ", z);
+  print_int("w = ", w);
+}
\ No newline at end of file
diff --git a/test/c/int_struct.expect b/test/c/int_struct.expect
new file mode 100644
index 00000000..f70f10e4
--- /dev/null
+++ b/test/c/int_struct.expect
@@ -0,0 +1 @@
+A
diff --git a/test/c/int_struct.sail b/test/c/int_struct.sail
new file mode 100644
index 00000000..42554593
--- /dev/null
+++ b/test/c/int_struct.sail
@@ -0,0 +1,24 @@
+default Order dec
+
+$include <prelude.sail>
+
+val print = "print_endline" : string -> unit
+
+struct Foo('n: Int) = {
+  field: bits('n)
+}
+
+type Foo32 = Foo(32)
+
+function bar(foo: Foo32) -> unit = {
+  if foo.field == 0xFFFF_FFFF then {
+    print("A")
+  } else {
+    print("B")
+  }
+}
+
+function main((): unit) -> unit = {
+  let x: Foo32 = struct { field = 0xFFFF_FFFF };
+  bar(x)
+}
\ No newline at end of file
diff --git a/test/c/int_struct_constrained.expect b/test/c/int_struct_constrained.expect
new file mode 100644
index 00000000..f70f10e4
--- /dev/null
+++ b/test/c/int_struct_constrained.expect
@@ -0,0 +1 @@
+A
diff --git a/test/c/int_struct_constrained.sail b/test/c/int_struct_constrained.sail
new file mode 100644
index 00000000..95cb6e9b
--- /dev/null
+++ b/test/c/int_struct_constrained.sail
@@ -0,0 +1,24 @@
+default Order dec
+
+$include <prelude.sail>
+
+val print = "print_endline" : string -> unit
+
+struct Foo('n: Int), 'n <= 64 = {
+  field: bits('n)
+}
+
+type Foo32 = Foo(32)
+
+function bar(foo: Foo32) -> unit = {
+  if foo.field == 0xFFFF_FFFF then {
+    print("A")
+  } else {
+    print("B")
+  }
+}
+
+function main((): unit) -> unit = {
+  let x: Foo32 = struct { field = 0xFFFF_FFFF };
+  bar(x)
+}
\ No newline at end of file
diff --git a/test/c/issue37.expect b/test/c/issue37.expect
new file mode 100644
index 00000000..6e77c916
--- /dev/null
+++ b/test/c/issue37.expect
@@ -0,0 +1 @@
+foo = 0xE
diff --git a/test/c/issue37.sail b/test/c/issue37.sail
new file mode 100644
index 00000000..404c4ef4
--- /dev/null
+++ b/test/c/issue37.sail
@@ -0,0 +1,9 @@
+default Order dec
+
+$include <vector_dec.sail>
+
+function main () : unit->unit = {
+  foo = 0xf;
+  foo[0] = bitzero;
+  print_bits("foo = ", foo)
+}
\ No newline at end of file
diff --git a/test/c/run_tests.py b/test/c/run_tests.py
index 4a02dd78..2ee44fca 100755
--- a/test/c/run_tests.py
+++ b/test/c/run_tests.py
@@ -95,7 +95,8 @@ xml += test_c('optimized C', '-O2', '-O', True)
 xml += test_c('constant folding', '', '-Oconstant_fold', True)
 xml += test_c('monomorphised C', '-O2', '-O -Oconstant_fold -auto_mono', True)
 xml += test_c('full optimizations', '-O2 -mbmi2 -DINTRINSICS', '-O -Oconstant_fold', True)
-xml += test_c('address sanitised', '-O2 -fsanitize=undefined', '-O', False)
+xml += test_c('specialization', '-O1', '-O -c_specialize', True)
+xml += test_c('undefined behavior sanitised', '-O2 -fsanitize=undefined', '-O', False)
 
 xml += test_interpreter('interpreter')
 
diff --git a/test/run_tests.sh b/test/run_tests.sh
index 09e99ff2..a228e270 100755
--- a/test/run_tests.sh
+++ b/test/run_tests.sh
@@ -47,3 +47,9 @@ printf "==========================================\n"
 
 ./arm/run_tests.sh
 
+printf "\n==========================================\n"
+printf "aarch64_small spec tests\n"
+printf "==========================================\n"
+
+./aarch64_small/run_tests.sh
+
diff --git a/test/typecheck/pass/execute_decode_hard.sail b/test/typecheck/pass/execute_decode_hard.sail
new file mode 100644
index 00000000..d5e91b79
--- /dev/null
+++ b/test/typecheck/pass/execute_decode_hard.sail
@@ -0,0 +1,26 @@
+default Order dec
+
+$include <prelude.sail>
+
+union ast('D: Int), 'D in {32, 64, 128} = {
+  Instr1 : {'R, 'R in {32, 64}. (int('R), bits('D))}
+}
+
+val execute : forall 'd, 'd in {32, 64, 128}. ast('d) -> unit
+
+function clause execute(Instr1(r as int('R), d)) = {
+  _prove(constraint('R in {32, 64}));
+  if length(d) == 64 then {
+    let _ = d[r - 1 .. 0];
+    ()
+  }
+}
+
+function clause execute(Instr1((r as int('R), d))) = {
+  _prove(constraint('R in {32, 64}));
+  if length(d) == 64 then {
+    let _ = d[r - 1 .. 0];
+    ()
+  }
+}
+
diff --git a/test/typecheck/fpthreesimp.sail b/test/typecheck/pass/fpthreesimp.sail
index 3f759ba4..d0f44119 100644
--- a/test/typecheck/fpthreesimp.sail
+++ b/test/typecheck/pass/fpthreesimp.sail
@@ -4,11 +4,11 @@ $include <prelude.sail>
 
 val Zeros : forall 'N, 'N >= 0. int('N) -> bits('N)
 
-type FPExponent ('N : Int) = {'E, ('N = 16 & 'E = 5) | ('N = 32 & 'E = 8) | ('N = 64 & 'E = 11). int('E)}
+type FPExponent ('N : Int) = {'E, ('N == 16 & 'E == 5) | ('N == 32 & 'E == 8) | ('N == 64 & 'E == 11). int('E)}
 
-val FPThree : forall 'N, 'N in {16, 32, 64}. bits(1) -> bits('N)
+val FPThree : forall 'N, 'N in {16, 32, 64}. (implicit('N), bits(1)) -> bits('N)
 
-function FPThree(sign) = {
+function FPThree(N, sign) = {
   let E : FPExponent('N) = if 'N == 16 then 5 else if 'N == 32 then 8 else 11;
   sign @ 0b1 @ Zeros(E - 1) @ 0b1 @ Zeros('N - E - 2)
 }
\ No newline at end of file
diff --git a/test/typecheck/pass/plus_one_unify.sail b/test/typecheck/pass/plus_one_unify.sail
new file mode 100644
index 00000000..0dceaa4c
--- /dev/null
+++ b/test/typecheck/pass/plus_one_unify.sail
@@ -0,0 +1,6 @@
+
+val f2 : forall 'm, 'm in {0,1}. (int('m+1)) -> int
+
+function f2(_) = 3
+
+let x = f2(1)
\ No newline at end of file
diff --git a/test/typecheck/pass/recursion.sail b/test/typecheck/pass/recursion.sail
new file mode 100644
index 00000000..5ca85f53
--- /dev/null
+++ b/test/typecheck/pass/recursion.sail
@@ -0,0 +1,15 @@
+default Order dec
+
+$include <prelude.sail>
+
+val log2 : int -> int
+
+function log2(n) =
+  if n <= 1 then 0 else 1 + log2(n/2)
+
+termination_measure log2(n) = n
+
+val testlog2 : unit -> unit effect {escape}
+
+function testlog2() =
+  assert(log2(64) == 6)
diff --git a/x86/Makefile b/x86/Makefile
index 6863714d..0c6e830e 100644
--- a/x86/Makefile
+++ b/x86/Makefile
@@ -1,7 +1,7 @@
 SAIL=../src/sail.native
 LEM:=../../lem/lem
 
-SOURCES=../etc/regfp.sail x64.sail
+SOURCES=../lib/regfp.sail x64.sail
 
 all: x86.lem x86.ml x86_embed.lem