diff --git a/basis/fsFFIPropsScript.sml b/basis/fsFFIPropsScript.sml
index ff83e0285b..aa23fcc1a7 100644
--- a/basis/fsFFIPropsScript.sml
+++ b/basis/fsFFIPropsScript.sml
@@ -150,7 +150,7 @@ Proof
   fs [validFD_def,nextFD_def]
   \\ qabbrev_tac `xs = MAP FST fs.infds`
   \\ match_mp_tac (SIMP_RULE std_ss []
-          (Q.ISPEC `\n:num. ~MEM n xs` whileTheory.LEAST_INTRO))
+          (Q.ISPEC `\n:num. ~MEM n xs` WhileTheory.LEAST_INTRO))
   \\ qexists_tac `SUM xs + 1`
   \\ strip_tac
   \\ qsuff_tac `!xs m:num. MEM m xs ==> m <= SUM xs`
diff --git a/basis/pure/mlstringScript.sml b/basis/pure/mlstringScript.sml
index 17a2f2d5e8..4910d25f84 100644
--- a/basis/pure/mlstringScript.sml
+++ b/basis/pure/mlstringScript.sml
@@ -749,10 +749,10 @@ Theorem OLEAST_LE_STEP:
     else (OLEAST j. i + 1 <= j /\ P j))
 Proof
   rw []
-  \\ simp [whileTheory.OLEAST_EQ_SOME]
+  \\ simp [WhileTheory.OLEAST_EQ_SOME]
   \\ qmatch_goalsub_abbrev_tac `opt1 = $OLEAST _`
   \\ Cases_on `opt1`
-  \\ fs [whileTheory.OLEAST_EQ_SOME]
+  \\ fs [WhileTheory.OLEAST_EQ_SOME]
   \\ rw []
   \\ fs [LESS_EQ |> REWRITE_RULE [ADD1] |> GSYM, arithmeticTheory.LT_LE]
   \\ CCONTR_TAC
diff --git a/candle/overloading/syntax/holSyntaxExtraScript.sml b/candle/overloading/syntax/holSyntaxExtraScript.sml
index 3d23e03072..ebd32aeffd 100644
--- a/candle/overloading/syntax/holSyntaxExtraScript.sml
+++ b/candle/overloading/syntax/holSyntaxExtraScript.sml
@@ -12996,7 +12996,7 @@ Proof
   rw[] >>
   last_x_assum(qspec_then `f` mp_tac) >>
   disch_then assume_tac >>
-  pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >>
+  pop_assum(mp_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >>
   rename1 `f n` >>
   rpt strip_tac >>
   reverse(Cases_on `R' (f n) (f (SUC n))`) >- goal_assum drule >>
diff --git a/candle/overloading/syntax/holSyntaxScript.sml b/candle/overloading/syntax/holSyntaxScript.sml
index 6782da328f..3cf4d8d524 100644
--- a/candle/overloading/syntax/holSyntaxScript.sml
+++ b/candle/overloading/syntax/holSyntaxScript.sml
@@ -298,7 +298,7 @@ QED
 Theorem LEAST_EXISTS[local]:
   (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m)
 Proof
-  metis_tac[whileTheory.LEAST_EXISTS]
+  metis_tac[WhileTheory.LEAST_EXISTS]
 QED
 
 val VARIANT_PRIMES_def = new_specification
diff --git a/candle/prover/candle_basis_evaluateScript.sml b/candle/prover/candle_basis_evaluateScript.sml
index 32981e6326..eb5071c009 100644
--- a/candle/prover/candle_basis_evaluateScript.sml
+++ b/candle/prover/candle_basis_evaluateScript.sml
@@ -220,6 +220,7 @@ Proof
   >- (Cases_on ‘op’ \\ gs[])
   >- (Cases_on ‘op’ \\ gs[])
   >- (Cases_on ‘op’ \\ gs[])
+  >- (Cases_on ‘op’ \\ gvs [])
   >- (
     gvs [do_app_cases, Boolv_def]
     \\ rw [v_ok_def]
diff --git a/candle/prover/candle_prover_evaluateScript.sml b/candle/prover/candle_prover_evaluateScript.sml
index 9091d23dd3..974479579e 100644
--- a/candle/prover/candle_prover_evaluateScript.sml
+++ b/candle/prover/candle_prover_evaluateScript.sml
@@ -635,15 +635,175 @@ Proof
     rw[do_app_cases] \\ gs [SF SFY_ss]
     \\ first_assum (irule_at Any)
     \\ simp [v_ok_def])
+  \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[]
+  >- (
+    rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()]
+    \\ pairarg_tac \\ gvs []
+    \\ gvs [v_ok_def, store_alloc_def, EVERY_EL, LLOOKUP_EQ_EL]
+    \\ first_assum (irule_at Any) \\ gs []
+    \\ rw [EL_APPEND_EQN] \\ gs [NOT_LESS, LESS_OR_EQ, ref_ok_def]
+    >- (
+      gs [kernel_loc_ok_def, LLOOKUP_EQ_EL, EL_APPEND_EQN]
+      \\ first_x_assum (drule_then strip_assume_tac)
+      \\ rw [] \\ gs [SF SFY_ss])
+    \\ strip_tac
+    \\ first_x_assum (drule_then assume_tac)
+    \\ drule kernel_loc_ok_LENGTH \\ gs [])
+  \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[]
+  >- (
+    rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()]
+    \\ first_assum (irule_at Any)
+    \\ gvs [v_ok_def, store_assign_def, EVERY_EL, EL_LUPDATE, LLOOKUP_EQ_EL]
+    \\ rw [ref_ok_def]
+    \\ irule kernel_loc_ok_LUPDATE1
+    \\ rpt strip_tac \\ gs [])
+  \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[]
+  >- (rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()])
   \\ Cases_on ‘op’ \\ gs []
+  \\ Cases_on ‘t’ \\ gs []
+QED
+
+Theorem state_ok_dest_thunk:
+  state_ok ctxt s ∧
+  EVERY (v_ok ctxt) vs ∧
+  dest_thunk (REVERSE vs) s.refs = IsThunk m v ⇒ v_ok ctxt v
+Proof
+  rw []
+  >- (
+    gvs [state_ok_def, oneline dest_thunk_def, AllCaseEqs(), v_ok_def,
+         store_lookup_def, LLOOKUP_THM]
+    \\ first_x_assum drule \\ rw [] \\ gvs [ref_ok_def])
+  \\ rw [env_ok_def, sing_env_def]
+  \\ Cases_on ‘n'’ \\ gvs []
+  \\ gvs [namespaceTheory.nsEmpty_def, namespaceTheory.nsBind_def,
+          namespaceTheory.nsLookup_def]
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def, state_ok_def,
+          LLOOKUP_THM, v_ok_def]
+  \\ first_x_assum drule_all \\ rw [] \\ gvs [ref_ok_def]
+QED
+
+Theorem state_ok_update_thunk:
+  state_ok ctxt s ∧
+  EVERY (v_ok ctxt) vs ∧
+  EVERY (v_ok ctxt) vs2 ∧
+  update_thunk (REVERSE vs) s.refs vs2 = SOME refs ⇒
+    state_ok ctxt (s with refs := refs)
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def,
+          state_ok_def, LLOOKUP_LUPDATE, v_ok_def]
+  \\ goal_assum drule \\ gvs [] \\ rw []
+  >- (
+    irule kernel_loc_ok_LUPDATE1 \\ gvs []
+    \\ metis_tac [EXTENSION])
+  >- (first_x_assum drule \\ rw [])
+  >- gvs [ref_ok_def]
 QED
 
 Theorem evaluate_v_ok_Op:
   op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "ast$App")
 Proof
   rw [evaluate_def] \\ Cases_on ‘getOpClass op’ \\ gs[]
-  >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[])
-  >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[])
+  >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[])
+  >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[])
+  >~ [‘Force’] >- (
+    Cases_on ‘op’ \\ gvs [] \\ Cases_on ‘t’ \\ gvs []
+    \\ qpat_x_assum ‘_ = (s',res)’ mp_tac
+    \\ TOP_CASE_TAC \\ gvs []
+    \\ last_x_assum drule_all \\ strip_tac
+    \\ reverse TOP_CASE_TAC \\ gvs []
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [])
+    \\ TOP_CASE_TAC \\ gvs []
+    >~ [‘BadRef’] >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [state_ok_def])
+    >~ [‘NotThunk’] >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [state_ok_def])
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs []
+      \\ drule_all_then assume_tac state_ok_dest_thunk \\ gvs [])
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [state_ok_def])
+    \\ ntac 2 (TOP_CASE_TAC \\ gvs [])
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [state_ok_def])
+    \\ TOP_CASE_TAC \\ gvs []
+    \\ ‘state_ok ctxt' (dec_clock q)’
+      by (gvs [dec_clock_def, state_ok_def] \\ metis_tac [])
+    \\ Cases_on ‘kernel_vals ctxt' v’
+    >- (
+      drule (INST_TYPE [“:'a”|->“:'ffi”] kernel_vals_ok)
+      \\ ‘v_ok ctxt' (Conv NONE [])’ by gvs [v_ok_def]
+      \\ disch_then (drule_all_then (strip_assume_tac)) \\ gs []
+      >- (
+        rw [] \\ gvs []
+        \\ goal_assum drule \\ gvs [state_ok_def])
+      \\ rpt (TOP_CASE_TAC \\ gvs [])
+      >- (
+        rw [] \\ gvs []
+        \\ goal_assum drule \\ gvs [state_ok_def])
+      >- (
+        rw [] \\ gvs []
+        \\ qexists ‘ctxt''’ \\ gvs []
+        \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_ok_update_thunk
+        \\ disch_then $ qspec_then ‘ctxt''’ mp_tac
+        \\ impl_tac \\ gvs []
+        \\ gvs [EVERY_EL])
+      >- (
+        rw [] \\ gvs []
+        \\ qexists ‘ctxt''’ \\ gvs [])
+      \\ rw [] \\ gvs []
+      \\ qexists ‘ctxt''’ \\ gvs [state_ok_def])
+    \\ first_x_assum drule
+    \\ impl_tac >- (
+      gvs [do_opapp_cases]
+      >~ [‘Closure env1 n e’] >- (
+        drule_all state_ok_dest_thunk \\ strip_tac
+        \\ gvs [v_ok_def]
+        \\ irule env_ok_with_nsBind \\ gvs [v_ok_def]
+        \\ ‘env1 with c := env1.c = env1’ by simp [sem_env_component_equality]
+        \\ gvs [])
+      \\ drule_all state_ok_dest_thunk \\ strip_tac
+      \\ gvs [v_ok_def]
+      \\ gs [env_ok_def, evaluateTheory.dec_clock_def, find_recfun_ALOOKUP,
+             SF SFY_ss]
+      \\ drule_then assume_tac ALOOKUP_MEM
+      \\ gs [EVERY_MEM, EVERY_MAP, FORALL_PROD, SF SFY_ss]
+      \\ Cases \\ simp [build_rec_env_merge, ml_progTheory.nsLookup_nsBind_compute]
+      \\ rw [] \\ gs []
+      \\ gs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some,
+             nsLookup_alist_to_ns_none]
+      >- simp [v_ok_def]
+      >~ [‘ALOOKUP _ _ = SOME _’] >- (
+        drule_then assume_tac ALOOKUP_MEM
+        \\ gvs [MEM_MAP, EXISTS_PROD, v_ok_def, EVERY_MEM]
+        \\ rw [DISJ_EQ_IMP, env_ok_def] \\ gs [SF SFY_ss])
+      \\ first_x_assum irule
+      \\ gs [SF SFY_ss])
+    \\ strip_tac \\ gvs []
+    \\ reverse TOP_CASE_TAC \\ gvs []
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum $ drule_at (Pos $ el 2)
+      \\ rw [] \\ gvs [])
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (
+      rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [state_ok_def])
+    \\ strip_tac \\ gvs []
+    \\ goal_assum $ drule_at (Pos $ el 3) \\ gvs []
+    \\ drule_at (Pat ‘update_thunk _ _ _ = _’) state_ok_update_thunk \\ gvs []
+    \\ disch_then drule \\ gvs []
+    \\ impl_tac \\ gvs []
+    \\ gvs [EVERY_EL])
   >~ [‘Simple’] >- (
     gvs [AllCaseEqs()]
     \\ first_x_assum (drule_all_then strip_assume_tac) \\ gs [state_ok_def]
diff --git a/candle/prover/candle_prover_invScript.sml b/candle/prover/candle_prover_invScript.sml
index 3905f2e1ab..cb29eb5617 100644
--- a/candle/prover/candle_prover_invScript.sml
+++ b/candle/prover/candle_prover_invScript.sml
@@ -205,7 +205,8 @@ Theorem kernel_vals_ind = v_ok_ind
 Definition ref_ok_def:
   ref_ok ctxt (Varray vs) = EVERY (v_ok ctxt) vs ∧
   ref_ok ctxt (Refv v) = v_ok ctxt v ∧
-  ref_ok ctxt (W8array vs) = T
+  ref_ok ctxt (W8array vs) = T ∧
+  ref_ok ctxt (Thunk m v) = v_ok ctxt v
 End
 
 Definition kernel_loc_ok_def:
diff --git a/candle/prover/permsScript.sml b/candle/prover/permsScript.sml
index 1cf6d48809..0f318dd685 100644
--- a/candle/prover/permsScript.sml
+++ b/candle/prover/permsScript.sml
@@ -37,7 +37,9 @@ Definition perms_ok_exp_def:
           (op = AallocFixed ⇒ RefAlloc ∈ ps) ∧
           (op = Aw8alloc ⇒ W8Alloc ∈ ps) ∧
           (op = Opassign ⇒ RefUpdate ∈ ps) ∧
-          (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps)
+          (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps) ∧
+          (∀m. op = ThunkOp (AllocThunk m) ⇒ RefAlloc ∈ ps) ∧
+          (∀m. op = ThunkOp (UpdateThunk m) ⇒ RefUpdate ∈ ps)
       | _ => T
 End
 
@@ -182,7 +184,8 @@ QED
 Definition perms_ok_ref_def:
   perms_ok_ref ps (Refv v) = perms_ok ps v ∧
   perms_ok_ref ps (Varray vs) = EVERY (perms_ok ps) vs ∧
-  perms_ok_ref ps (W8array ws) = T
+  perms_ok_ref ps (W8array ws) = T ∧
+  perms_ok_ref ps (Thunk _ v) = perms_ok ps v
 End
 
 Definition perms_ok_state_def:
@@ -295,6 +298,8 @@ Theorem do_app_perms:
   (op = Aw8alloc ⇒ W8Alloc ∈ ps) ∧
   (op = Opassign ⇒ RefUpdate ∈ ps) ∧
   (∀chn. op = FFI chn ⇒ FFIWrite chn ∈ ps ∧ DoFFI ∈ ps) ∧
+  (∀m. op = ThunkOp (AllocThunk m) ⇒ RefAlloc ∈ ps) ∧
+  (∀m. op = ThunkOp (UpdateThunk m) ⇒ RefUpdate ∈ ps) ∧
   op ≠ Opapp ⇒
     (∀n. n < LENGTH refs1 ∧ RefMention n ∈ ps ⇒ perms_ok_ref ps (EL n refs1)) ∧
     (RefAlloc ∉ ps ∧ W8Alloc ∉ ps ⇒ LENGTH refs1 = LENGTH refs) ∧
@@ -556,7 +561,22 @@ Proof
   >- (
     rw [do_app_cases] \\ gs[]
     \\ rw [perms_ok_def])
+  \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[]
+  >- (
+    rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()] \\ pairarg_tac \\ gs []
+    \\ gvs [perms_ok_def, store_alloc_def, perms_ok_ref_def, SUBSET_DEF]
+    \\ simp [EL_APPEND_EQN]
+    \\ rw [] \\ gs []
+    \\ gvs [NOT_LESS, LESS_OR_EQ, perms_ok_ref_def])
+  \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[]
+  >- (
+    rw [do_app_cases] \\ gs [thunk_op_def, AllCaseEqs()]
+    \\ gvs [perms_ok_def, store_assign_def]
+    \\ rw [EL_LUPDATE, perms_ok_ref_def])
+  \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[]
+  >- (rw [do_app_cases] \\ gvs [thunk_op_def, AllCaseEqs()])
   \\ Cases_on ‘op’ \\ gs []
+  \\ Cases_on ‘t’ \\ gs []
 QED
 
 Theorem perms_ok_do_opapp:
@@ -692,7 +712,78 @@ Proof
   >~ [‘Fun n e’] >- (
     gvs [evaluate_def, perms_ok_env_def, perms_ok_def, SF SFY_ss])
   >~ [‘App op xs’] >- (
-    gvs [evaluate_def]
+    Cases_on ‘getOpClass op = Force’ \\ gvs []
+    >- (
+      gvs [AllCaseEqs()] \\ gvs [evaluate_def] \\ gvs [AllCaseEqs()]
+      \\ gvs [perms_ok_env_BIGUNION, MEM_MAP, PULL_EXISTS, EVERY_MEM]
+      >- (
+        gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def,
+             perms_ok_state_def]
+        \\ last_x_assum drule \\ rw [] \\ gvs [perms_ok_def, perms_ok_ref_def])
+      \\ (
+        gvs [dec_clock_def]
+        \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def]
+        \\ gvs [do_opapp_cases]
+        >- ((* Closure *)
+          last_x_assum mp_tac
+          \\ reverse impl_tac
+          >- (
+            rw [] \\ gs []
+            \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def,
+                 perms_ok_state_def, EL_LUPDATE] \\ rw []
+            \\ gvs [perms_ok_ref_def]
+            \\ first_x_assum (drule_then assume_tac) \\ gs [])
+          \\ gvs [perms_ok_state_def]
+          \\ first_x_assum (drule_then assume_tac) \\ gvs []
+          \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def]
+          \\ Cases \\ simp [nsLookup_nsBind_compute]
+          \\ rw [] \\ gvs [perms_ok_def]
+          \\ first_x_assum irule
+          \\ first_x_assum (irule_at Any) \\ gvs [])
+        >- ((* Recclosure *)
+          last_x_assum mp_tac
+          \\ reverse impl_tac
+          >- (
+            rw [] \\ gs []
+            \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def,
+                 perms_ok_state_def, EL_LUPDATE] \\ rw []
+            \\ gvs [perms_ok_ref_def]
+            \\ first_x_assum (drule_then assume_tac) \\ gs [])
+          \\ gvs [perms_ok_state_def]
+          \\ first_x_assum (drule_then assume_tac) \\ gvs []
+          \\ gvs [perms_ok_ref_def, perms_ok_def, perms_ok_env_def]
+          \\ gvs [SF DNF_ss, find_recfun_ALOOKUP, EVERY_MEM, MEM_MAP,
+                  PULL_EXISTS]
+          \\ drule_then assume_tac ALOOKUP_MEM
+          \\ qmatch_asmsub_abbrev_tac ‘MEM yyy funs’
+          \\ first_assum drule \\ simp_tac std_ss [Abbr ‘yyy’]
+          \\ strip_tac
+          \\ simp [build_rec_env_merge]
+          \\ Cases \\ simp [nsLookup_nsBind_compute]
+          \\ rw [] \\ gs [nsLookup_nsAppend_some, nsLookup_alist_to_ns_some,
+                          nsLookup_alist_to_ns_none]
+          >- gvs [perms_ok_def]
+          >~ [‘ALOOKUP _ _ = NONE’] >- (
+            first_x_assum irule
+            \\ first_assum (irule_at Any)
+            \\ gs [ALOOKUP_NONE, MAP_MAP_o, o_DEF, LAMBDA_PROD, MEM_MAP,
+                   EXISTS_PROD]
+            \\ first_assum (irule_at Any)
+            \\ first_assum (irule_at Any) \\ gs []
+            \\ strip_tac \\ gvs [])
+          >~ [‘ALOOKUP _ _ = SOME _’] >- (
+            drule_then assume_tac ALOOKUP_MEM
+            \\ gs [MEM_MAP, EXISTS_PROD, perms_ok_def, EVERY_MAP, EVERY_MEM]
+            \\ gs [perms_ok_env_def, MEM_MAP, EXISTS_PROD]
+            \\ rw [] \\ gs [FORALL_PROD, SF SFY_ss])
+          \\ first_x_assum irule
+          \\ first_assum (irule_at Any)
+          \\ gs [ALOOKUP_NONE, MAP_MAP_o, o_DEF, LAMBDA_PROD, MEM_MAP,
+                 EXISTS_PROD]
+          \\ first_assum (irule_at Any)
+          \\ first_assum (irule_at Any) \\ gs [])))
+    \\ gvs [AllCaseEqs()]
+    \\ gvs [evaluate_def]
     \\ Cases_on ‘op = Opapp’ \\ gs []
     >- ((* Opapp *)
       gvs [CaseEqs ["result", "prod", "bool", "option"],
@@ -754,6 +845,7 @@ Proof
     \\ Cases_on ‘getOpClass op’ \\ gs[]
     >~ [‘EvalOp’] >- (Cases_on ‘op’ \\ gs[])
     >~ [‘FunApp’] >- (Cases_on ‘op’ \\ gs[])
+    >~ [‘Force’] >- (Cases_on ‘op’ \\ gs[])
     >~ [‘Simple’] >- (
       gvs [CaseEqs ["result", "prod", "bool", "option"]]
       \\ drule_then (qspec_then ‘ps’ mp_tac) do_app_perms
diff --git a/candle/standard/syntax/holSyntaxScript.sml b/candle/standard/syntax/holSyntaxScript.sml
index 2974f4f49a..f6dfb9bcf2 100644
--- a/candle/standard/syntax/holSyntaxScript.sml
+++ b/candle/standard/syntax/holSyntaxScript.sml
@@ -271,7 +271,7 @@ QED
 Triviality LEAST_EXISTS:
   (∃n:num. P n) ⇒ ∃k. P k ∧ ∀m. m < k ⇒ ¬(P m)
 Proof
-  metis_tac[whileTheory.LEAST_EXISTS]
+  metis_tac[WhileTheory.LEAST_EXISTS]
 QED
 
 val VARIANT_PRIMES_def = new_specification
diff --git a/characteristic/cfAppScript.sml b/characteristic/cfAppScript.sml
index 1a306bfb2f..2d45952ff9 100644
--- a/characteristic/cfAppScript.sml
+++ b/characteristic/cfAppScript.sml
@@ -613,7 +613,8 @@ Theorem do_app_io_events_ExtCall:
         ?s bs bs'. io_ev = IO_event (ExtCall s) bs bs'
 Proof
   strip_tac >>
-  gvs[DefnBase.one_line_ify NONE do_app_def,
+  gvs[oneline do_app_def,
+    oneline thunk_op_def, store_alloc_def,
     AllCaseEqs(),ffiTheory.call_FFI_def] >>
   pairarg_tac >> fs[]
 QED
diff --git a/characteristic/cfDivScript.sml b/characteristic/cfDivScript.sml
index cfd59a49c0..8c41138d93 100644
--- a/characteristic/cfDivScript.sml
+++ b/characteristic/cfDivScript.sml
@@ -4420,7 +4420,7 @@ Proof
   \\ rw[]
   \\ `LFLATTEN(LGENLIST f NONE) <> [||]` by(CCONTR_TAC >> fs[])
   \\ dxrule LFLATTEN_NOT_NIL_IMP
-  \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS])
+  \\ disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS])
   \\ qmatch_asmsub_abbrev_tac `LNTH a1`
   \\ Q.ISPECL_THEN [`a1`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST)
   \\ fs[]
@@ -4720,7 +4720,7 @@ Proof
     (fs[Once LFLATTEN])
   \\ match_mp_tac OR_INTRO_THM2
   \\ pop_assum(assume_tac o Ho_Rewrite.REWRITE_RULE [every_LGENLIST,o_DEF,NOT_FORALL_THM])
-  \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS])
+  \\ pop_assum(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS])
   \\ fs[CONV_RULE(LHS_CONV SYM_CONV) fromList_EQ_LNIL]
   \\ qspecl_then [`LEAST x. events (n + x) <> []`,`fromList o events o $+ n`] mp_tac
       (LGENLIST_CHUNK_GENLIST
diff --git a/compiler/backend/ag32/ag32_memoryScript.sml b/compiler/backend/ag32/ag32_memoryScript.sml
index f559759f99..8382b62b87 100644
--- a/compiler/backend/ag32/ag32_memoryScript.sml
+++ b/compiler/backend/ag32/ag32_memoryScript.sml
@@ -876,7 +876,7 @@ Theorem ag32_ffi_get_arg_length_loop1_thm:
                     ((4w =+ s.R 4w + n2w (n+1))
                     ((5w =+ s.R 5w + n2w (n+1)) s.R))) |>
 Proof
-  reverse(rw[whileTheory.OLEAST_def])
+  reverse(rw[WhileTheory.OLEAST_def])
   >- (
     rw[Once ag32_ffi_get_arg_length_loop1_def]
     \\ fs[] \\ metis_tac[] )
@@ -987,7 +987,7 @@ Proof
   \\ simp[Once get_next_mem_arg_def]
   \\ Cases_on`m a = 0w` \\ fs[]
   >- (
-    simp[whileTheory.OLEAST_def]
+    simp[WhileTheory.OLEAST_def]
     \\ IF_CASES_TAC \\ fs[]
     \\ numLib.LEAST_ELIM_TAC
     \\ conj_tac >- metis_tac[]
@@ -996,9 +996,9 @@ Proof
     \\ first_x_assum(qspec_then`0`mp_tac)
     \\ simp[] )
   \\ IF_CASES_TAC
-  >- ( simp[whileTheory.OLEAST_def] )
+  >- ( simp[WhileTheory.OLEAST_def] )
   \\ fs[]
-  \\ simp[whileTheory.OLEAST_def]
+  \\ simp[WhileTheory.OLEAST_def]
   \\ reverse IF_CASES_TAC \\ fs[]
   >- (
     Cases_on`n` \\ fs[]
@@ -1053,7 +1053,7 @@ Proof
             ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm,
             APPLY_UPDATE_THM]
     \\ CASE_TAC \\ simp[APPLY_UPDATE_THM]
-    \\ fs[whileTheory.OLEAST_def]
+    \\ fs[WhileTheory.OLEAST_def]
     \\ simp[Once ag32_ffi_get_arg_length_loop_def, APPLY_UPDATE_THM]
     \\ simp[ag32Theory.dfn'JumpIfZero_def, ag32Theory.incPC_def,
             ag32Theory.ri2word_def, ag32Theory.ALU_def, APPLY_UPDATE_THM]
@@ -1068,7 +1068,7 @@ Proof
     \\ rw[] \\ fs[]
     \\ AP_THM_TAC \\ AP_TERM_TAC
     \\ AP_THM_TAC \\ AP_TERM_TAC
-    \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def]
+    \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def]
     \\ IF_CASES_TAC \\ fs[])
   \\ rw[]
   \\ simp[Once ag32_ffi_get_arg_length_loop_def]
@@ -1078,7 +1078,7 @@ Proof
           ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_length_loop1_thm,
           APPLY_UPDATE_THM]
   \\ CASE_TAC \\ simp[APPLY_UPDATE_THM]
-  \\ fs[whileTheory.OLEAST_def]
+  \\ fs[WhileTheory.OLEAST_def]
   \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_length_loop s'`
   \\ first_x_assum(qspec_then`s'`mp_tac)
   \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w]
@@ -1106,7 +1106,7 @@ Proof
   \\ simp[get_mem_arg_def, GSYM ADD1, UNCURRY]
   \\ AP_TERM_TAC
   \\ AP_TERM_TAC
-  \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def]
+  \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def]
   \\ IF_CASES_TAC \\ fs[]
 QED
 
@@ -1294,7 +1294,7 @@ Theorem ag32_ffi_get_arg_find1_thm:
                R := ((8w =+ 0w)
                     ((5w =+ s.R 5w + n2w (n+1)) s.R)) |>
 Proof
-  reverse(rw[whileTheory.OLEAST_def])
+  reverse(rw[WhileTheory.OLEAST_def])
   >- (
     rw[Once ag32_ffi_get_arg_find1_def]
     \\ fs[] \\ metis_tac[] )
@@ -1400,7 +1400,7 @@ Proof
           ag32Theory.incPC_def, ag32Theory.ALU_def, ag32Theory.dfn'JumpIfZero_def,
           ag32Theory.dfn'JumpIfNotZero_def, ag32_ffi_get_arg_find1_thm,
           APPLY_UPDATE_THM]
-  \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[whileTheory.OLEAST_def]
+  \\ CASE_TAC \\ simp[APPLY_UPDATE_THM] \\ fs[WhileTheory.OLEAST_def]
   \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_find s'`
   \\ first_x_assum(qspec_then`s'`mp_tac)
   \\ simp[Abbr`s'`, APPLY_UPDATE_THM, ADD1, GSYM word_add_n2w]
@@ -1430,12 +1430,12 @@ Proof
     rw[]
     \\ rw[get_mem_arg_def]
     \\ rw[get_next_mem_arg_LEAST]
-    \\ rw[whileTheory.OLEAST_def]
+    \\ rw[WhileTheory.OLEAST_def]
     \\ fs[] )
   \\ rw[] \\ fs[]
   \\ Cases_on`index` \\ fs[get_mem_arg_def]
   \\ simp[UNCURRY]
-  \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def]
+  \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def]
   \\ IF_CASES_TAC \\ fs[]
 QED
 
@@ -1511,7 +1511,7 @@ Proof
   \\ Induct_on`n` \\ rw[]
   >- (
     simp[Once ag32_ffi_get_arg_store_def]
-    \\ fs[whileTheory.OLEAST_def]
+    \\ fs[WhileTheory.OLEAST_def]
     \\ qpat_x_assum`_ = 0n`mp_tac
     \\ numLib.LEAST_ELIM_TAC
     \\ conj_tac >- metis_tac[]
@@ -1537,7 +1537,7 @@ Proof
   \\ simp[Once ag32_ffi_get_arg_store_def]
   \\ IF_CASES_TAC
   >- (
-    fs[whileTheory.OLEAST_def]
+    fs[WhileTheory.OLEAST_def]
     \\ first_assum(qspec_then`n'`mp_tac)
     \\ simp_tac(srw_ss())[DISJ_EQ_IMP]
     \\ impl_tac >- fs[] \\ strip_tac
@@ -1571,7 +1571,7 @@ Proof
     \\ disch_then(qspec_then`n'`mp_tac)
     \\ strip_tac \\ fs[]
     \\ fs[bitTheory.BITS_ZERO3, NOT_LESS_EQUAL, DISJ_EQ_IMP] \\ rw[]
-    \\ fs[whileTheory.OLEAST_def]
+    \\ fs[WhileTheory.OLEAST_def]
     \\ qpat_x_assum`_ = SUC _`mp_tac
     \\ numLib.LEAST_ELIM_TAC
     \\ conj_tac >- metis_tac[]
@@ -1580,7 +1580,7 @@ Proof
     \\ simp[] )
   \\ qmatch_goalsub_abbrev_tac`ag32_ffi_get_arg_store s'`
   \\ last_x_assum(qspec_then`s'`mp_tac)
-  \\ fs[whileTheory.OLEAST_def]
+  \\ fs[WhileTheory.OLEAST_def]
   \\ qpat_x_assum`_ = SUC _`mp_tac
   \\ numLib.LEAST_ELIM_TAC
   \\ conj_tac >- metis_tac[]
diff --git a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml
index 1c90aeca10..08a5c2a831 100644
--- a/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml
+++ b/compiler/backend/ag32/proofs/ag32_basis_ffiProofScript.sml
@@ -2147,7 +2147,7 @@ Proof
   >- (
     rw[bytes_in_memory_APPEND]
     \\ rw[get_next_mem_arg_LEAST]
-    \\ simp[whileTheory.OLEAST_def]
+    \\ simp[WhileTheory.OLEAST_def]
     \\ reverse IF_CASES_TAC
     >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] )
     \\ simp[]
@@ -2169,7 +2169,7 @@ Proof
   \\ first_x_assum drule
   \\ disch_then drule
   \\ rw[]
-  \\ simp[get_next_mem_arg_LEAST, whileTheory.OLEAST_def]
+  \\ simp[get_next_mem_arg_LEAST, WhileTheory.OLEAST_def]
   \\ reverse IF_CASES_TAC
   >- ( fs[SNOC_APPEND, bytes_in_memory_APPEND, bytes_in_memory_def] )
   \\ simp[]
@@ -2403,7 +2403,7 @@ Proof
     \\ qpat_x_assum`a' = a`SUBST_ALL_TAC
     \\ qpat_x_assum`a = _`(assume_tac o SYM)
     \\ simp[Abbr`s1`, APPLY_UPDATE_THM]
-    \\ simp[whileTheory.OLEAST_def]
+    \\ simp[WhileTheory.OLEAST_def]
     \\ simp[GSYM CONJ_ASSOC]
     \\ conj_asm1_tac
     >- (
diff --git a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml
index 4f300345e9..0fdab920d6 100644
--- a/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml
+++ b/compiler/backend/ag32/proofs/ag32_ffi_codeProofScript.sml
@@ -3045,7 +3045,7 @@ Proof
   Q.REFINE_EXISTS_TAC ‘k + k2’ >> simp0[FUNPOW_ADD] >> simp0[Once LET_THM] >>
   rev_full_simp_tac (srw_ss()) [] >>
   ‘(OLEAST n. s2.MEM (s2.R 5w + n2w n) = 0w) = SOME zoff’
-    by (glAbbrs 2 >> DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[] >>
+    by (glAbbrs 2 >> DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[] >>
         conj_tac >- (goal_assum drule) >> rw[] >>
         ‘¬(zoff < n) ∧ ¬(n < zoff)’ suffices_by simp[] >> metis_tac[]) >>
   qpat_x_assum ‘Abbrev (s3 = _)’ mp_tac >>
@@ -3436,7 +3436,7 @@ Proof
         ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def
         ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def]
     \\ simp[ag32_ffi_get_arg_find1_thm]
-    \\ simp[whileTheory.OLEAST_def]
+    \\ simp[WhileTheory.OLEAST_def]
     \\ IF_CASES_TAC \\ fs[]
     \\ simp[APPLY_UPDATE_THM]
     \\ simp[word_add_n2w]
@@ -3539,7 +3539,7 @@ Proof
     (SIMP_RULE bool_ss [PULL_EXISTS] ag32_ffi_get_arg_find_decomp1_thm)>>
   simp[] >>
   ‘(OLEAST n. s1.MEM (s1.R 5w + n2w n) = 0w) = SOME off’
-    by (DEEP_INTRO_TAC whileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >>
+    by (DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO >> simp[Abbr`s1`] >>
         conj_tac >- goal_assum drule >> qx_gen_tac `n` >> strip_tac >>
         ‘¬(n < off) ∧ ¬(off < n)’ suffices_by simp[] >> metis_tac[]) >>
    simp[ag32_ffi_get_arg_find1_thm, combinTheory.UPDATE_def] >>
@@ -3568,7 +3568,7 @@ Proof
       ,ag32Theory.dfn'Normal_def, ag32Theory.norm_def
       ,ag32Theory.ALU_def, ag32Theory.ri2word_def, ag32Theory.incPC_def]
   \\ simp[ag32_ffi_get_arg_find1_thm]
-  \\ simp[whileTheory.OLEAST_def]
+  \\ simp[WhileTheory.OLEAST_def]
   \\ IF_CASES_TAC \\ fs[]
   \\ simp[APPLY_UPDATE_THM]
   \\ simp[word_add_n2w]
diff --git a/compiler/backend/backend_commonScript.sml b/compiler/backend/backend_commonScript.sml
index baf94ca78a..6dddc55e7d 100644
--- a/compiler/backend/backend_commonScript.sml
+++ b/compiler/backend/backend_commonScript.sml
@@ -129,7 +129,7 @@ Definition data_num_stubs_def:
 End
 
 Definition bvl_num_stubs_def:
-  bvl_num_stubs = data_num_stubs + 8 + (* dummy to make it a multiple of 3 *) 1
+  bvl_num_stubs = data_num_stubs + 9 + (* dummy to make it a multiple of 3 *) 0
 End
 
 Definition bvl_to_bvi_namespaces_def:
diff --git a/compiler/backend/backend_passesScript.sml b/compiler/backend/backend_passesScript.sml
index 77d1a5586f..39e23a3dae 100644
--- a/compiler/backend/backend_passesScript.sml
+++ b/compiler/backend/backend_passesScript.sml
@@ -85,7 +85,8 @@ Definition to_bvl_all_def:
            call_state := (g,aux)|> in
     let init_stubs = toAList (init_code c1.max_app) in
     let init_globs =
-            [(num_stubs c1.max_app − 1,0,
+            [(num_stubs c1.max_app − 2, 2, force_thunk_code);
+             (num_stubs c1.max_app − 1, 0,
               init_globals c1.max_app (num_stubs c1.max_app + c1.start))] in
     let comp_progs = clos_to_bvl$compile_prog c1.max_app prog in
     let prog' = init_stubs ++ init_globs ++ comp_progs in
@@ -106,6 +107,7 @@ Proof
   \\ fs [to_bvl_all_def,to_bvl_def,clos_to_bvlTheory.compile_def,
          clos_to_bvlTheory.compile_common_def]
   \\ rpt (pairarg_tac \\ gvs [])
+  \\ rewrite_tac [GSYM APPEND_ASSOC,APPEND]
 QED
 
 Definition to_bvi_all_def:
diff --git a/compiler/backend/bviScript.sml b/compiler/backend/bviScript.sml
index 79eefd0ec4..e9aa6182d8 100644
--- a/compiler/backend/bviScript.sml
+++ b/compiler/backend/bviScript.sml
@@ -46,5 +46,11 @@ Datatype:
       | Raise exp
       | Tick exp
       | Call num (num option) (exp list) (exp option)
+      | Force num (* loc to call for evaluation of unevaluated thunk *)
+              num (* var holding thunk *)
       | Op op (exp list)
 End
+
+Overload mk_unit = “bvi$Op (BlockOp (Cons 0)) []”
+
+Overload mk_elem_at = “λb i. bvi$Op (BlockOp (ElemAt i)) [b]”
diff --git a/compiler/backend/bvi_letScript.sml b/compiler/backend/bvi_letScript.sml
index e11c8da8c6..80a6f5155d 100644
--- a/compiler/backend/bvi_letScript.sml
+++ b/compiler/backend/bvi_letScript.sml
@@ -92,6 +92,10 @@ Definition compile_def:
      [Raise (HD (compile env d [x1]))]) /\
   (compile env d [Op op xs] = [Op op (compile env d xs)]) /\
   (compile env d [Tick x] = [Tick (HD (compile env d [x]))]) /\
+  (compile env d [Force loc v] =
+     case LLOOKUP env v of
+     | SOME n => [Force loc (v + n)]
+     | _ => [Force loc (v + d)]) /\
   (compile env d [Call t dest xs h] =
      [Call t dest (compile env d xs)
          (case h of NONE => NONE
@@ -129,6 +133,10 @@ Definition compile_sing_def:
      (Raise ((compile_sing env d x1)))) /\
   (compile_sing env d (Op op xs) = (Op op (compile_list env d xs))) /\
   (compile_sing env d (Tick x) = (Tick (compile_sing env d x))) /\
+  (compile_sing env d (Force loc v) =
+     case LLOOKUP env v of
+     | SOME n => Force loc (v + n)
+     | _ => Force loc (v + d)) /\
   (compile_sing env d (Call t dest xs h) =
      (Call t dest (compile_list env d xs)
          (case h of NONE => NONE
diff --git a/compiler/backend/bvi_tailrecScript.sml b/compiler/backend/bvi_tailrecScript.sml
index 53bf664be7..e597ee6b4a 100644
--- a/compiler/backend/bvi_tailrecScript.sml
+++ b/compiler/backend/bvi_tailrecScript.sml
@@ -511,6 +511,9 @@ Definition scan_expr_def:
       [(DROP (LENGTH ys) tu, ty, F, op)]) ∧
   (scan_expr ts loc [Raise x] = [(ts, Any, F, NONE)]) ∧
   (scan_expr ts loc [Tick x] = scan_expr ts loc [x]) ∧
+  (scan_expr ts loc [Force _ n] =
+    let ty = if n < LENGTH ts then EL n ts else Any in
+      [(ts, ty, F, NONE)]) ∧
   (scan_expr ts loc [Call t d xs h] = [(ts, Any, F, NONE)]) ∧
   (scan_expr ts loc [Op op xs] =
     let opr = from_op op in
@@ -566,6 +569,9 @@ Definition scan_expr_sing_def:
       (DROP (LENGTH ys) tu, ty, F, op)) ∧
   (scan_expr_sing ts loc (Raise x) = (ts, Any, F, NONE)) ∧
   (scan_expr_sing ts loc (Tick x) = scan_expr_sing ts loc x) ∧
+  (scan_expr_sing ts loc (Force _ n) =
+    let ty = if n < LENGTH ts then EL n ts else Any in
+      (ts, ty, F, NONE)) ∧
   (scan_expr_sing ts loc (Call t d xs h) = (ts, Any, F, NONE)) ∧
   (scan_expr_sing ts loc (Op op xs) =
     let opr = from_op op in
@@ -639,6 +645,7 @@ Definition rewrite_def:
   (rewrite loc next opr acc ts (Tick x) =
     let (r, y) = rewrite loc next opr acc ts x in
       (r, Tick y)) /\
+  (rewrite loc next opr acc ts (Force l v) = (F, Force l v)) /\
   (rewrite loc next opr acc ts exp =
     dtcase check_op ts opr loc exp of
       NONE => (F, apply_op opr (Var acc) exp)
@@ -668,6 +675,7 @@ Theorem rewrite_PMATCH:
              (r, Let xs y)
        | Tick x =>
            let (r, y) = rewrite loc next opr acc ts x in (r, Tick y)
+       | Force l v => (F, Force l v)
        | _ =>
            dtcase check_op ts opr loc expr of
              NONE => (F, apply_op opr (Var acc) expr)
@@ -680,7 +688,6 @@ Proof
   \\ recInduct (theorem "rewrite_ind") \\ rw [rewrite_def]
 QED
 
-
 Theorem rewrite_eq = rewrite_def |> SRULE [scan_expr_eq];
 
 
@@ -857,16 +864,16 @@ val opt_tm = ``
               NONE)))``
 val aux_tm = ``Let [Var 0; Op (IntOp (Const 1)) []] ^opt_tm``
 
-Theorem fac_check_exp:
+Triviality fac_check_exp:
    check_exp 0 1 ^fac_tm = SOME Times
 Proof
-EVAL_TAC
+  EVAL_TAC
 QED
 
 Theorem fac_compile_exp:
    compile_exp 0 1 1 ^fac_tm = SOME (^aux_tm, ^opt_tm)
 Proof
-EVAL_TAC
+  EVAL_TAC
 QED
 
 val rev_tm = ``
@@ -892,15 +899,15 @@ val opt_tm = ``
 
 val aux_tm = ``Let [Var 0; Op (BlockOp (Cons 0)) []] ^opt_tm``
 
-Theorem rev_check_exp:
-   check_exp 444 1 ^rev_tm = SOME Append
+Triviality rev_check_exp:
+  check_exp 444 1 ^rev_tm = SOME Append
 Proof
-EVAL_TAC
+  EVAL_TAC
 QED
 
-Theorem rev_compile_exp:
-   compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm)
+Triviality rev_compile_exp:
+  compile_exp 444 445 1 ^rev_tm = SOME (^aux_tm, ^opt_tm)
 Proof
-EVAL_TAC
+  EVAL_TAC
 QED
 
diff --git a/compiler/backend/bvi_to_dataScript.sml b/compiler/backend/bvi_to_dataScript.sml
index 16dd1113a7..1c7fc32cc7 100644
--- a/compiler/backend/bvi_to_dataScript.sml
+++ b/compiler/backend/bvi_to_dataScript.sml
@@ -121,6 +121,11 @@ Definition compile_def:
   (compile n env tail live [Tick x1] =
      let (c1,v1,n1) = compile n env tail live [x1] in
        (Seq Tick c1, v1, n1)) /\
+  (compile n env tail live [Force loc v] =
+     let var = any_el v env 0n in
+     let ret = (if tail then NONE
+                else SOME (n, list_to_num_set (live ++ env))) in
+       (Force ret loc var, [n], MAX (n+1) (var+1))) ∧
   (compile n env tail live [Call ticks dest xs NONE] =
      let (c1,vs,n1) = compile n env F live xs in
      let ret = (if tail then NONE
@@ -163,6 +168,11 @@ Definition compile_sing_def:
   (compile_sing n env tail live (Tick x1) =
      let (c1,v1,n1) = compile_sing n env tail live x1 in
        (Seq Tick c1, v1, n1)) /\
+  (compile_sing n env tail live (Force loc v) =
+     let var = any_el v env 0n in
+     let ret = (if tail then NONE
+                else SOME (n, list_to_num_set (live ++ env))) in
+       (Force ret loc var, n, MAX (n+1) (var+1))) ∧
   (compile_sing n env tail live (Call ticks dest xs NONE) =
      let (c1,vs,n1) = compile_list n env live xs in
      let ret = (if tail then NONE
diff --git a/compiler/backend/bvlScript.sml b/compiler/backend/bvlScript.sml
index cd500db1ac..efc28816b4 100644
--- a/compiler/backend/bvlScript.sml
+++ b/compiler/backend/bvlScript.sml
@@ -34,6 +34,8 @@ Datatype:
       | Handle exp exp
       | Tick exp
       | Call num (num option) (exp list)
+      | Force num (* loc to call for evaluation of unevaluated thunk *)
+              num (* var holding thunk *)
       | Op closLang$op (exp list)
 End
 
@@ -44,3 +46,7 @@ End
 Definition mk_tick_def:
   mk_tick n e = FUNPOW Tick n e : bvl$exp
 End
+
+Overload mk_unit = “bvl$Op (BlockOp (Cons 0)) []”
+
+Overload mk_elem_at = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”;
diff --git a/compiler/backend/bvl_constScript.sml b/compiler/backend/bvl_constScript.sml
index 6ee9236f1e..7f32e4d8fb 100644
--- a/compiler/backend/bvl_constScript.sml
+++ b/compiler/backend/bvl_constScript.sml
@@ -320,6 +320,12 @@ Definition compile_def:
      [Raise (HD (compile env [x1]))]) /\
   (compile env [Op op xs] = [SmartOp op (compile env xs)]) /\
   (compile env [Tick x] = [Tick (HD (compile env [x]))]) /\
+  (compile env [Force loc v] =
+     dtcase LLOOKUP env v of
+     | NONE => [Force loc v]
+     | SOME NONE => [Force loc v]
+     | SOME (SOME (Var i)) => [Force loc (v + i)]
+     | SOME (SOME x) => [Force loc v]) /\
   (compile env [Call t dest xs] = [Call t dest (compile env xs)])
 End
 
@@ -347,6 +353,12 @@ Definition compile_sing_def:
      Raise (compile_sing env x1)) /\
   (compile_sing env (Op op xs) = SmartOp op (compile_list env xs)) /\
   (compile_sing env (Tick x) = Tick (compile_sing env x)) /\
+  (compile_sing env (Force loc v) =
+     dtcase LLOOKUP env v of
+     | NONE => Force loc v
+     | SOME NONE => Force loc v
+     | SOME (SOME (Var i)) => Force loc (v + i)
+     | SOME (SOME x) => Force loc v) ∧
   (compile_sing env (Call t dest xs) = Call t dest (compile_list env xs)) ∧
 
   (compile_list env [] = []) /\
diff --git a/compiler/backend/bvl_handleScript.sml b/compiler/backend/bvl_handleScript.sml
index 1e0d11d9b9..778ebad1a8 100644
--- a/compiler/backend/bvl_handleScript.sml
+++ b/compiler/backend/bvl_handleScript.sml
@@ -17,8 +17,9 @@ Definition can_raise_def:
   (can_raise (Let xs x2) = (can_raise x2 ∨ can_raise1 xs)) ∧
   (can_raise (Handle x1 x2) = can_raise x2) ∧
   (can_raise (Raise x1) = T) ∧
-  (can_raise (Op op xs) = can_raise1 xs) ∧
+  (can_raise (Op op xs) = (op = ThunkOp ForceThunk ∨ can_raise1 xs)) ∧
   (can_raise (Tick x) = can_raise x) ∧
+  (can_raise (Force m n) = T) ∧
   (can_raise (Call t dest xs) = T) ∧
   (can_raise1 [] = F) ∧
   (can_raise1 (x::xs) = (can_raise x ∨ can_raise1 xs))
@@ -54,6 +55,7 @@ Definition handle_adj_vars_def:
   (handle_adj_vars l d (Raise x1) = Raise (handle_adj_vars l d x1)) ∧
   (handle_adj_vars l d (Op op xs) = Op op (handle_adj_vars1 l d xs)) ∧
   (handle_adj_vars l d (Tick x) = Tick (handle_adj_vars l d x)) ∧
+  (handle_adj_vars l d (Force m v) = Force m (if v < l then v else v+d)) ∧
   (handle_adj_vars l d (Call t dest xs) =
      Call t dest (handle_adj_vars1 l d xs)) ∧
   (handle_adj_vars1 l d [] = []) ∧
@@ -68,6 +70,7 @@ Definition handle_size_def:
   (handle_size (Raise x1) = 1 + handle_size x1) ∧
   (handle_size (Op op xs) = 1 + handle_size1 xs) ∧
   (handle_size (Tick x) = 1 + handle_size x) ∧
+  (handle_size (Force m n) = 1) ∧
   (handle_size (Call t dest xs) = 1 + handle_size1 xs) ∧
   (handle_size1 [] = 1:num) ∧
   (handle_size1 (x::xs) = 1 + handle_size x + handle_size1 xs)
@@ -87,6 +90,7 @@ Definition handle_simp_def:
   (handle_simp (Raise x1) = Raise (handle_simp x1)) /\
   (handle_simp (Op op xs) = Op op (handle_simp_list xs)) /\
   (handle_simp (Tick x) = Tick (handle_simp x)) /\
+  (handle_simp (Force m n) = Force m n) /\
   (handle_simp (Call t dest xs) = Call t dest (handle_simp_list xs)) /\
   (handle_simp_list [] = ([]:bvl$exp list)) /\
   (handle_simp_list (x::xs) = handle_simp x :: handle_simp_list xs) /\
@@ -193,10 +197,15 @@ Definition compile_def:
        OptionalLetLet (Raise (HD dx)) n lx (s1+1) l F) /\
   (compile l n [Op op xs] =
      let (ys,lx,s1,nr1) = compile l n xs in
-       OptionalLetLet (Op op ys) n lx (s1+1) l nr1) /\
+       if op = ThunkOp ForceThunk then
+         ([Op op ys],lx,s1+1,F)
+       else
+         OptionalLetLet (Op op ys) n lx (s1+1) l nr1) /\
   (compile l n [Tick x] =
      let (y,lx,s1,nr1) = compile l n [x] in
        ([Tick (HD y)],lx,s1,nr1)) /\
+  (compile l n [Force m v] = if v < n then ([Force m v],Var v,1,F)
+                             else ([Op (IntOp (Const 0)) []],Empty,1,T)) /\
   (compile l n [Call t dest xs] =
      let (ys,lx,s1,nr1) = compile l n xs in
        OptionalLetLet (Call t dest ys) n lx (s1+1) l F)
@@ -236,10 +245,15 @@ Definition compile_sing_def:
        OptionalLetLet_sing (Raise dx) n lx (s1+1) l F) /\
   (compile_sing l n (Op op xs) =
      let (ys,lx,s1,nr1) = compile_list l n xs in
-       OptionalLetLet_sing (Op op ys) n lx (s1+1) l nr1) /\
+       if op = ThunkOp ForceThunk then
+         (Op op ys,lx,s1+1,F)
+       else
+         OptionalLetLet_sing (Op op ys) n lx (s1+1) l nr1) /\
   (compile_sing l n (Tick x) =
      let (y,lx,s1,nr1) = compile_sing l n x in
        (Tick y,lx,s1,nr1)) /\
+  (compile_sing l n (Force m v) = if v < n then (Force m v,Var v,1,F)
+                                  else (Op (IntOp (Const 0)) [],Empty,1,T)) /\
   (compile_sing l n (Call t dest xs) =
      let (ys,lx,s1,nr1) = compile_list l n xs in
        OptionalLetLet_sing (Call t dest ys) n lx (s1+1) l F) ∧
diff --git a/compiler/backend/bvl_inlineScript.sml b/compiler/backend/bvl_inlineScript.sml
index 915e5c876e..3058cc3dee 100644
--- a/compiler/backend/bvl_inlineScript.sml
+++ b/compiler/backend/bvl_inlineScript.sml
@@ -32,6 +32,7 @@ Definition tick_inline_def:
      [Op op (tick_inline cs xs)]) /\
   (tick_inline cs [Tick x] =
      [Tick (HD (tick_inline cs [x]))]) /\
+  (tick_inline cs [Force m n] = [Force m n]) /\
   (tick_inline cs [Call ticks dest xs] =
      case dest of NONE => [Call ticks dest (tick_inline cs xs)] | SOME n =>
      case lookup n cs of
@@ -57,6 +58,7 @@ Definition tick_inline_sing_def:
      (Op op (tick_inline_list cs xs))) /\
   (tick_inline_sing cs (Tick x) =
      (Tick (tick_inline_sing cs x))) /\
+  (tick_inline_sing cs (Force m n) = Force m n) /\
   (tick_inline_sing cs (Call ticks dest xs) =
      case dest of NONE => Call ticks dest (tick_inline_list cs xs) | SOME n =>
      case lookup n cs of
@@ -105,6 +107,7 @@ Definition is_small_aux_def:
      let n = n - 1 in if n = 0 then 0 else
        is_small_aux n xs) /\
   (is_small_aux n [Tick x] = is_small_aux n [x]) /\
+  (is_small_aux n [Force _ _] = n) /\
   (is_small_aux n [Call ticks dest xs] =
      let n = n - 1 in if n = 0 then 0 else
        is_small_aux n xs)
@@ -132,6 +135,7 @@ Definition is_small_sing_def:
      let n = n - 1 in if n = 0 then 0 else
        is_small_list n xs) /\
   (is_small_sing n (Tick x) = is_small_sing n x) /\
+  (is_small_sing n (Force _ _) = n) /\
   (is_small_sing n (Call ticks dest xs) =
      let n = n - 1 in if n = 0 then 0 else
        is_small_list n xs) /\
@@ -178,6 +182,7 @@ Definition is_rec_def:
        is_rec n [x2]) /\
   (is_rec n [Op op xs] = is_rec n xs) /\
   (is_rec n [Tick x] = is_rec n [x]) /\
+  (is_rec n [Force _ _] = F) /\
   (is_rec n [Call ticks dest xs] =
      if dest = SOME n then T else is_rec n xs)
 End
@@ -197,6 +202,7 @@ Definition is_rec_sing_def:
        is_rec_sing n x2) /\
   (is_rec_sing n (Op op xs) = is_rec_list n xs) /\
   (is_rec_sing n (Tick x) = is_rec_sing n x) /\
+  (is_rec_sing n (Force _ _) = F) /\
   (is_rec_sing n (Call ticks dest xs) =
      if dest = SOME n then T else is_rec_list n xs) /\
   (is_rec_list n [] = F) /\
@@ -271,6 +277,7 @@ Definition remove_ticks_def:
   (remove_ticks [Op op xs] =
      [Op op (remove_ticks xs)]) /\
   (remove_ticks [Tick x] = remove_ticks [x]) /\
+  (remove_ticks [Force m n] = [Force m n]) /\
   (remove_ticks [Call ticks dest xs] =
      [Call 0 dest (remove_ticks xs)])
 End
@@ -291,6 +298,7 @@ Definition remove_ticks_sing_def:
   (remove_ticks_sing (Op op xs) =
      Op op (remove_ticks_list xs)) /\
   (remove_ticks_sing (Tick x) = remove_ticks_sing x) /\
+  (remove_ticks_sing (Force m n) = Force m n) /\
   (remove_ticks_sing (Call ticks dest xs) =
      Call 0 dest (remove_ticks_list xs)) /\
   (remove_ticks_list [] = []) /\
@@ -356,6 +364,7 @@ Definition let_op_def:
   (let_op [Op op xs] =
      [Op op (let_op xs)]) /\
   (let_op [Tick x] = [Tick (HD (let_op [x]))]) /\
+  (let_op [Force m n] = [Force m n]) /\
   (let_op [Call ticks dest xs] = [Call ticks dest (let_op xs)])
 End
 
@@ -379,6 +388,7 @@ Definition let_op_one_def:
   (let_op_one (Op op xs) =
      Op op (let_op_list xs)) /\
   (let_op_one (Tick x) = Tick (let_op_one x)) /\
+  (let_op_one (Force m n) = Force m n) /\
   (let_op_one (Call ticks dest xs) = Call ticks dest (let_op_list xs)) /\
   (let_op_list [] = []) /\
   (let_op_list ((x:bvl$exp)::xs) =
diff --git a/compiler/backend/bvl_to_bviScript.sml b/compiler/backend/bvl_to_bviScript.sml
index 76a93aa4e1..886055f678 100644
--- a/compiler/backend/bvl_to_bviScript.sml
+++ b/compiler/backend/bvl_to_bviScript.sml
@@ -53,6 +53,7 @@ Definition alloc_glob_count_def:
      alloc_glob_count [x] +
      alloc_glob_count [y]) /\
   (alloc_glob_count [Tick x] = alloc_glob_count [x]) /\
+  (alloc_glob_count [Force loc v] = 0) /\
   (alloc_glob_count [Raise x] = alloc_glob_count [x]) /\
   (alloc_glob_count [Let xs x] = alloc_glob_count (x::xs)) /\
   (alloc_glob_count [Call _ _ xs] = alloc_glob_count xs) /\
@@ -71,6 +72,7 @@ Definition global_count_sing_def:
   (global_count_sing (Handle x y) =
      global_count_sing x +
      global_count_sing y) /\
+  (global_count_sing (Force loc v) = 0) /\
   (global_count_sing (Tick x) = global_count_sing x) /\
   (global_count_sing (Raise x) = global_count_sing x) /\
   (global_count_sing (Let xs x) =
@@ -351,6 +353,8 @@ Definition compile_exps_def:
   (compile_exps n [Tick x1] =
      let (c1,aux1,n1) = compile_exps n [x1] in
        ([Tick (HD c1)], aux1, n1)) /\
+  (compile_exps n [Force loc v] =
+     ([Force (num_stubs + nss * loc) v], Nil, n)) /\
   (compile_exps n [Op op xs] =
      let (c1,aux1,n1) = compile_exps n xs in
        ([compile_op op c1],aux1,n1)) /\
@@ -402,6 +406,8 @@ Definition compile_exps_sing_def:
   (compile_exps_sing n (Tick x1) =
      let (c1,aux1,n1) = compile_exps_sing n x1 in
        (Tick c1, aux1, n1)) /\
+  (compile_exps_sing n (Force loc v) =
+     (Force (num_stubs + nss * loc) v, Nil, n)) /\
   (compile_exps_sing n (Op op xs) =
      let (c1,aux1,n1) = compile_exps_list n xs in
        (compile_op op c1,aux1,n1)) /\
diff --git a/compiler/backend/closLangScript.sml b/compiler/backend/closLangScript.sml
index 12a74002e6..ce09bbd1b8 100644
--- a/compiler/backend/closLangScript.sml
+++ b/compiler/backend/closLangScript.sml
@@ -116,6 +116,7 @@ Datatype:
      | GlobOp glob_op
      | MemOp mem_op
      | Install       (* installs new code at runtime *)
+     | ThunkOp thunk_op
 End
 
 Datatype:
@@ -180,6 +181,7 @@ Definition pure_op_def:
     | MemOp Ref => F
     | MemOp Update => F
     | Install => F
+    | ThunkOp _ => F
     | _ => T
 End
 
diff --git a/compiler/backend/clos_to_bvlScript.sml b/compiler/backend/clos_to_bvlScript.sml
index 41ffa57156..c16edb60a4 100644
--- a/compiler/backend/clos_to_bvlScript.sml
+++ b/compiler/backend/clos_to_bvlScript.sml
@@ -167,8 +167,6 @@ Definition mk_el_def[simp]:
   mk_el b i : bvl$exp = Op (MemOp El) [i; b]
 End
 
-Overload mk_elem_at[local] = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”;
-
 Definition free_let_def:
   free_let cl n = (GENLIST (\n. mk_elem_at cl (n+2)) n)
 End
@@ -265,6 +263,7 @@ Definition num_stubs_def:
     (* generic apps *)         max_app
     (* partial apps *)       + max_app * (max_app - 1) DIV 2
     + 1 (* code to install a jump table in global 0 *)
+    + 1 (* location for force_thunk stub *)
 End
 
 Definition generic_app_fn_location_def:
@@ -391,6 +390,16 @@ Definition init_globals_def:
       (Call 0 (SOME start_loc) []))
 End
 
+Definition force_thunk_code_def:
+  force_thunk_code =
+    If (Op (BlockOp (EqualConst (Int 0))) [mk_elem_at (Var 1) 1])
+      (Let [Call 0 NONE [mk_unit; Var 1; mk_elem_at (Var 1) 0]]
+        (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1)))
+      (Let [Call 0 (SOME 0) [mk_unit; Var 1]]
+        (Let [Op (ThunkOp (UpdateThunk Evaluated)) [Var 0; Var 1]] (Var 1)))
+       : bvl$exp
+End
+
 Definition compile_exps_def:
   (compile_exps max_app [] aux = ([],aux)) /\
   (compile_exps max_app ((x:closLang$exp)::y::xs) aux =
@@ -417,6 +426,8 @@ Definition compile_exps_def:
      let (c1,aux1) = compile_exps max_app xs aux in
      ([if op = Install then
          Call 0 NONE [Op Install c1]
+       else if op = ThunkOp ForceThunk then
+         Let c1 (Force (num_stubs max_app - 2) 0)
        else
          Op (compile_op op) c1]
      ,aux1)) /\
@@ -504,6 +515,7 @@ Definition compile_exp_sing_def:
   (compile_exp_sing max_app (Op t op xs) aux =
      let (c1,aux1) = compile_exp_list max_app xs aux in
      (if op = Install then Call 0 NONE [Op Install c1]
+      else if op = ThunkOp ForceThunk then Let c1 (Force (num_stubs max_app - 2) 0)
       else Op (compile_op op) c1
      ,aux1)) /\
   (compile_exp_sing max_app (App t loc_opt x1 xs2) aux =
@@ -852,8 +864,9 @@ Definition make_name_alist_def:
   make_name_alist nums prog nstubs dec_start (dec_length:num) =
     let src_names = get_src_names (MAP (SND o SND) prog) LN in
       fromAList(MAP(λn.(n, if n < nstubs then
-                             if n = nstubs-1 then mlstring$strlit "bvl_init"
-                                             else mlstring$strlit "bvl_stub"
+                             if n = nstubs-1 then mlstring$strlit "bvl_init" else
+                             if n = nstubs-2 then mlstring$strlit "bvl_force" else
+                                                  mlstring$strlit "bvl_stub"
                            else let clos_name = n - nstubs in
                              if dec_start ≤ clos_name ∧ clos_name < dec_start + dec_length
                              then mlstring$strlit "dec" else
@@ -869,13 +882,15 @@ Theorem make_name_alist_eq =
 Definition compile_def:
   compile c0 es =
     let (c, prog) = compile_common c0 es in
+    let n = num_stubs c.max_app in
     let init_stubs = toAList (init_code c.max_app) in
-    let init_globs = [(num_stubs c.max_app - 1, 0n, init_globals c.max_app (num_stubs c.max_app + c.start))] in
+    let init_globs = [(n - 1, 0n, init_globals c.max_app (n + c.start))] in
+    let force_stub = [(n - 2, 2n, force_thunk_code)] in
     let comp_progs = compile_prog c.max_app prog in
-    let prog' = init_stubs ++ init_globs ++ comp_progs in
-    let func_names = make_name_alist (MAP FST prog') prog (num_stubs c.max_app)
+    let prog' = init_stubs ++ force_stub ++ init_globs ++ comp_progs in
+    let func_names = make_name_alist (MAP FST prog') prog n
                        c0.next_loc (LENGTH es) in
-    let c = c with start := num_stubs c.max_app - 1 in
+    let c = c with start := n - 1 in
       (c, code_sort prog', func_names)
 End
 
diff --git a/compiler/backend/dataLangScript.sml b/compiler/backend/dataLangScript.sml
index 3d12d8ac24..07b4baf520 100644
--- a/compiler/backend/dataLangScript.sml
+++ b/compiler/backend/dataLangScript.sml
@@ -75,6 +75,7 @@ Datatype:
        | Raise num
        | Return num
        | Tick
+       | Force ((num # num_set) option) num num
 End
 
 Definition mk_ticks_def:
diff --git a/compiler/backend/data_liveScript.sml b/compiler/backend/data_liveScript.sml
index 5346065f74..9a95778008 100644
--- a/compiler/backend/data_liveScript.sml
+++ b/compiler/backend/data_liveScript.sml
@@ -46,6 +46,7 @@ Definition is_pure_def:
   (is_pure (MemOp XorByte) = F) /\
   (is_pure (MemOp ConfigGC) = F) /\
   (is_pure Install = F) /\
+  (is_pure (ThunkOp _) = F) /\
   (is_pure _ = T)
 End
 
@@ -87,6 +88,7 @@ Theorem is_pure_pmatch:
     | IntOp LessEq => F
     | Install => F
     | MemOp ConfigGC => F
+    | ThunkOp _ => F
     | _ => T
 Proof
   rpt strip_tac
@@ -118,6 +120,12 @@ Definition compile_def:
      let (d3,l3) = compile c3 live in
      let (d2,l2) = compile c2 live in
        (If n d2 d3, insert n () (union l2 l3))) /\
+  (compile (Force NONE loc src) live =
+     (Force NONE loc src,insert src () LN)) /\
+  (compile (Force (SOME (n,names)) loc src) live =
+     let l1 = inter names (delete n live) in
+     let l2 = insert src () l1 in
+       (Force (SOME (n,l1)) loc src,l2)) /\
   (compile (Call NONE dest vs handler) live =
      (Call NONE dest vs handler,list_to_num_set vs)) /\
   (compile (Call (SOME (n,names)) dest vs NONE) live =
diff --git a/compiler/backend/data_spaceScript.sml b/compiler/backend/data_spaceScript.sml
index 8394549081..52470ba45d 100644
--- a/compiler/backend/data_spaceScript.sml
+++ b/compiler/backend/data_spaceScript.sml
@@ -38,6 +38,7 @@ Definition op_space_req_def:
   (op_space_req (WordOp (FP_uop _)) _ = 3) /\
   (op_space_req (WordOp (FP_bop _)) _ = 3) /\
   (op_space_req (WordOp (FP_top _)) _ = 3) /\
+  (op_space_req (ThunkOp (AllocThunk _)) l = l + 1) /\
   (op_space_req _ _ = 0)
 End
 
diff --git a/compiler/backend/data_to_wordScript.sml b/compiler/backend/data_to_wordScript.sml
index 6c6daae297..db2b0d0a0b 100644
--- a/compiler/backend/data_to_wordScript.sml
+++ b/compiler/backend/data_to_wordScript.sml
@@ -1218,6 +1218,25 @@ val def = assign_Define `
                       (Assign (adjust_var dest) Unit),l)
       : 'a wordLang$prog # num`;
 
+val def = assign_Define `
+  assign_UpdateThunk ev (c:data_to_word$config) (l:num) (dest:num) v1 v2 =
+      (dtcase ev of
+       | NotEvaluated =>
+           (Seq (Store (Op Add [real_addr c (adjust_var v1);
+                                Const bytes_in_word])
+                       (adjust_var v2))
+                (Assign (adjust_var dest) Unit),l)
+       | Evaluated =>
+           (dtcase encode_header c (8 + 6) 1 of
+            | NONE => (GiveUp,l)
+            | SOME (header:'a word) => (list_Seq
+                [Assign 1 (real_addr c (adjust_var v1));
+                 Assign 3 (Const header);
+                 Store (Var 1) 3;
+                 Store (Op Add [Var 1; Const bytes_in_word]) (adjust_var v2);
+                 Assign (adjust_var dest) Unit],l)))
+      : 'a wordLang$prog # num`;
+
 val def = assign_Define `
   assign_UpdateByte (c:data_to_word$config) (l:num) (dest:num) v1 v2 v3 =
       (list_Seq [
@@ -1489,6 +1508,28 @@ val def = assign_Define `
                             Const 1w])],l))
       : 'a wordLang$prog # num`;
 
+val def = assign_Define `
+  assign_AllocThunk (ev : thunk_mode) (c:data_to_word$config) (secn:num)
+             (l:num) (dest:num) (names:num_set option) arg =
+          (let tag = (dtcase ev of
+                         | Evaluated => 8 + 6
+                         | NotEvaluated => 0 + 6) in
+           dtcase encode_header c tag 1 of
+              | NONE => (GiveUp,l)
+              | SOME (header:'a word) => (list_Seq
+                 [Set TriggerGC (Op Sub [Lookup TriggerGC;
+                     Const (bytes_in_word * 2w)]);
+                  Assign 1 (Op Sub [Lookup EndOfHeap;
+                     Const (bytes_in_word * 2w)]);
+                  Set EndOfHeap (Var 1);
+                  Assign 3 (Const header);
+                  StoreEach 1 [3; adjust_var arg] 0w;
+                  Assign (adjust_var dest)
+                    (Op Or [Shift Lsl (Op Sub [Var 1; Lookup CurrHeap])
+                              (shift_length c − shift (:'a));
+                            Const 1w])],l))
+      : 'a wordLang$prog # num`;
+
 val def = assign_Define `
   assign_RefByte (c:data_to_word$config) (secn:num)
              (l:num) (dest:num) (names:num_set option) immutable v1 v2 =
@@ -2332,6 +2373,8 @@ Definition assign_def:
     | BlockOp (Build parts) => assign_Build c secn l dest names parts
     | BlockOp (ConsExtend tag) => assign_ConsExtend c secn l dest names tag args
     | MemOp Ref => assign_Ref c secn l dest names args
+    | ThunkOp (AllocThunk ev) => arg1 args (assign_AllocThunk ev c secn l dest names) (Skip,l)
+    | ThunkOp (UpdateThunk ev) => arg2 args (assign_UpdateThunk ev c l dest) (Skip,l)
     | MemOp (RefByte imm) => arg2 args (assign_RefByte c secn l dest names imm) (Skip,l)
     | MemOp XorByte => arg2 args (assign_XorByte c secn l dest names) (Skip,l)
     | Label n => (LocValue (adjust_var dest) n,l)
@@ -2377,6 +2420,40 @@ Definition assign_def:
     | _ => (Skip,l)
 End
 
+Definition force_thunk_def:
+  force_thunk (c:data_to_word$config) secn (l:num) ret loc v1 =
+    (dtcase encode_header c (8 + 6) 1 of
+     | NONE => (GiveUp,l)
+     | SOME (header:'a word) =>
+     If Test (adjust_var v1) (Imm 1w)
+       (dtcase ret of
+        | NONE => Return 0 [adjust_var v1]
+        | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1)))
+       (list_Seq
+          [Assign 1 (real_addr c (adjust_var v1));
+           Assign 3 (Op And [Load (Var 1); Const 0b111100w]);
+           If Equal 3 (Imm (n2w ((8 + 6) * 4)))
+             (dtcase ret of
+              | NONE =>
+                 list_Seq
+                   [Assign 1 (Load (Op Add [Var 1; Const bytes_in_word]));
+                    Return 0 [1]]
+              | SOME (dest,_) =>
+                  Assign (adjust_var dest)
+                         (Load (Op Add [Var 1; Const bytes_in_word]))) $
+           If NotEqual 3 (Imm (n2w ((0 + 6) * 4)))
+             (dtcase ret of
+              | NONE => Return 0 [adjust_var v1]
+              | SOME (dest,_) => Assign (adjust_var dest) (Var (adjust_var v1)))
+             (list_Seq
+                [Assign 5 (Load (Op Add [Var 1; Const bytes_in_word]));
+                 (dtcase ret of
+                  | NONE => Call NONE (SOME loc) [0; adjust_var v1; 5] NONE
+                  | SOME (r,ns) => Call (SOME ([adjust_var r],adjust_sets ns,Skip,secn,l))
+                                     (SOME loc) [adjust_var v1; 5] NONE)])]),l+1)
+      : 'a wordLang$prog # num
+End
+
 Definition comp_def:
   comp c (secn:num) (l:num) (p:dataLang$prog) =
     dtcase p of
@@ -2405,6 +2482,7 @@ Definition comp_def:
                             SilentFFI c 3 (adjust_sets names)])
                 Skip),l)
     | Assign dest op args names => assign c secn l dest op args names
+    | Force ret loc v => force_thunk c secn l ret loc v
     | Call ret target args handler =>
         dtcase ret of
         | NONE => (Call NONE target (0::MAP adjust_var args) NONE,l)
@@ -2718,4 +2796,3 @@ Proof
     \\ pop_assum (fn th => once_rewrite_tac [th])
     \\ rewrite_tac [th_FF,AnyArith_call_tree_def,structure_le_def])
 QED
-
diff --git a/compiler/backend/flatLangScript.sml b/compiler/backend/flatLangScript.sml
index c5344bb1e6..a009581a72 100644
--- a/compiler/backend/flatLangScript.sml
+++ b/compiler/backend/flatLangScript.sml
@@ -105,6 +105,8 @@ Datatype:
   | El num
   (* No-op step for a single value *)
   | Id
+  (* Thunk *)
+  | ThunkOp ast$thunk_op
 End
 
 Type ctor_id = ``:num``
diff --git a/compiler/backend/flat_to_closScript.sml b/compiler/backend/flat_to_closScript.sml
index 95347e0c7c..00278e5c96 100644
--- a/compiler/backend/flat_to_closScript.sml
+++ b/compiler/backend/flat_to_closScript.sml
@@ -193,6 +193,7 @@ Definition compile_op_def:
     | Eval => Op t Install xs (* if need to flip:  Let t xs (Op t Install [Var t 1; Var t 0]) *)
     | FpFromWord => Let None xs (Var None 0)
     | FpToWord => Let None xs (Var None 0)
+    | ThunkOp op => Op t (ThunkOp op) xs
     | _ => Let None xs (Var None 0)
 End
 
diff --git a/compiler/backend/presLangScript.sml b/compiler/backend/presLangScript.sml
index 4ae34dd19e..f9a90f9ffc 100644
--- a/compiler/backend/presLangScript.sml
+++ b/compiler/backend/presLangScript.sml
@@ -190,6 +190,20 @@ Definition shift_to_display_def:
   (shift_to_display Ror = empty_item (strlit "Ror"))
 End
 
+Definition thunk_mode_to_display_def:
+  (thunk_mode_to_display Evaluated = empty_item (strlit "Evaluated"))
+  /\
+  (thunk_mode_to_display NotEvaluated = empty_item (strlit "NotEvaluated"))
+End
+
+Definition thunk_op_to_display_def:
+  (thunk_op_to_display (AllocThunk m) =
+    Item NONE (strlit "AllocThunk") [thunk_mode_to_display m]) ∧
+  (thunk_op_to_display (UpdateThunk m) =
+    Item NONE (strlit "UpdateThunk") [thunk_mode_to_display m]) ∧
+  (thunk_op_to_display ForceThunk = empty_item (strlit "ForceThunk"))
+End
+
 Definition op_to_display_def:
   op_to_display (p:ast$op) =
   case p of
@@ -251,6 +265,7 @@ Definition op_to_display_def:
   | FFI v35 => empty_item (strlit "FFI v35")
   | Eval => empty_item (strlit "Eval")
   | Env_id => empty_item (strlit "Eval")
+  | ThunkOp t => thunk_op_to_display t
 End
 
 Definition lop_to_display_def:
@@ -473,6 +488,7 @@ Definition flat_op_to_display_def:
     | ConfigGC => empty_item (strlit "ConfigGC")
     | FFI s => Item NONE (strlit "FFI") [string_imp s]
     | Eval => empty_item (strlit "Eval")
+    | ThunkOp t => thunk_op_to_display t
     | GlobalVarAlloc n => item_with_num (strlit "GlobalVarAlloc") n
     | GlobalVarInit n => item_with_num (strlit "GlobalVarInit") n
     | GlobalVarLookup n => item_with_num (strlit "GlobalVarLookup") n
@@ -690,6 +706,7 @@ Definition clos_op_to_display_def:
     | WordOp (FP_bop op) => fp_bop_to_display op
     | WordOp (FP_top op) => fp_top_to_display op
     | Install => String (strlit "Install")
+    | ThunkOp t => thunk_op_to_display t
 End
 
 Triviality MEM_clos_exps_size:
@@ -815,6 +832,9 @@ Definition bvl_to_display_def:
     Item NONE (strlit "call")
          (String (attach_name ns dest) ::
           (bvl_to_display_list ns h xs))) /\
+  (bvl_to_display ns h (Force loc n) =
+    Item NONE (strlit "force")
+         [display_num_as_varn (h-n-1); String (attach_name ns (SOME loc))]) /\
   (bvl_to_display ns h (Op op xs) =
     Item NONE (strlit "op") (clos_op_to_display ns op ::
                              (bvl_to_display_list ns h xs)))  ∧
@@ -873,6 +893,9 @@ Definition bvi_to_display_def:
            | SOME e => [Item NONE (strlit "handler") [display_num_as_varn h;
                                                       empty_item (strlit "->");
                                                       bvi_to_display ns (h+1) e]]))) /\
+  (bvi_to_display ns h (Force loc n) =
+    Item NONE (strlit "force")
+         [display_num_as_varn (h-n-1); String (attach_name ns (SOME loc))]) ∧
   (bvi_to_display ns h (Op op xs) =
     Item NONE (strlit "op") (clos_op_to_display ns op ::
                              (bvi_to_display_list ns h xs)))  ∧
@@ -950,6 +973,11 @@ Definition data_prog_to_display_def:
             list_to_display num_to_display args;
             Item NONE (strlit "some") [Tuple [num_to_display v;
                 data_prog_to_display k ns handler]]]
+    | Force ret loc src => Item NONE (strlit "force")
+        [option_to_display (\(x, y). Tuple
+                [num_to_display x; num_set_to_display y]) ret;
+         num_to_display loc;
+         num_to_display src]
     | Assign n op args n_set => Tuple
         [num_to_display n;
          String (strlit ":=");
diff --git a/compiler/backend/proofs/bvi_letProofScript.sml b/compiler/backend/proofs/bvi_letProofScript.sml
index e957fac2f3..77d88a3fce 100644
--- a/compiler/backend/proofs/bvi_letProofScript.sml
+++ b/compiler/backend/proofs/bvi_letProofScript.sml
@@ -259,6 +259,18 @@ Proof
     \\ pop_assum $ drule_at $ Pos $ el 2 \\ gvs []
     \\ disch_then drule
     \\ impl_tac >- (CCONTR_TAC \\ gvs []) \\ gvs [])
+  \\ Cases_on ‘∃force_loc n. h = Force force_loc n’ \\ gvs []
+  >- (
+    imp_res_tac env_rel_length \\ gvs []
+    \\ gvs [evaluate_def, AllCaseEqs()]
+    \\ gvs [compile_def, evaluate_def]
+    \\ CASE_TAC \\ gvs []
+    >>~- ([‘LLOOKUP ax n = NONE’],
+      gvs [evaluate_def] \\ drule_all env_rel_LLOOKUP_NONE \\ rw [])
+    \\ (
+      drule env_rel_LOOKUP_SOME \\ gvs [v_rel_def]
+      \\ disch_then drule \\ gvs [] \\ rw []
+      \\ gvs [evaluate_def, LLOOKUP_EQ_EL, EL_DROP]))
   \\ reverse (Cases_on `?ys y. h = Let ys y` \\ fs [])
   THEN1 (Cases_on `h` \\ fs [])
   \\ fs [] \\ rpt (qpat_x_assum `T` kall_tac) \\ rveq \\ fs [evaluate_def]
diff --git a/compiler/backend/proofs/bvi_tailrecProofScript.sml b/compiler/backend/proofs/bvi_tailrecProofScript.sml
index e202197268..68aa5db36e 100644
--- a/compiler/backend/proofs/bvi_tailrecProofScript.sml
+++ b/compiler/backend/proofs/bvi_tailrecProofScript.sml
@@ -559,6 +559,11 @@ Proof
     \\ rfs [EL_APPEND1, EL_APPEND2, EL_LENGTH_APPEND])
   (*Op*)
   \\ CASE_TAC \\ fs [evaluate_def]
+  >>~- ([‘dest_thunk’],
+    gvs [AllCaseEqs(), NOT_LESS]
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), ty_rel_def, LIST_REL_EL_EQN]
+    \\ first_x_assum drule \\ rw [] \\ gvs [bvlSemTheory.v_to_list_def]
+    \\ metis_tac [evaluate_SING_IMP])
   >-
    (rw [case_eq_thms, case_elim_thms, IS_SOME_EXISTS, PULL_EXISTS, bool_case_eq,
         pair_case_eq, from_op_def, arg_ty_def, op_ty_def]
@@ -586,6 +591,7 @@ Proof
   \\ rpt (PURE_TOP_CASE_TAC \\ fs []) \\ rveq
   \\ fs [evaluate_def, bool_case_eq, pair_case_eq, case_eq_thms, case_elim_thms] \\ rveq
   \\ fs [] \\ rveq \\ rfs []
+  \\ imp_res_tac evaluate_SING_IMP \\ gvs []
   \\ metis_tac []
 QED
 
@@ -1618,7 +1624,8 @@ Proof
     \\ simp [LEFT_EXISTS_AND_THM, CONJ_ASSOC]
     \\ conj_tac
     >-
-     (first_x_assum (qspecl_then [`xs`, `s`] mp_tac)
+     (gvs []
+      \\ first_x_assum (qspecl_then [`xs`, `s`] mp_tac)
       \\ simp [bviTheory.exp_size_def]
       \\ `env_rel ty F acc env1 env2` by fs [env_rel_def]
       \\ rpt (disch_then drule) \\ fs []
@@ -1977,6 +1984,86 @@ Proof
     \\ fs [bvl_to_bvi_id] \\ rw []
     \\ fs [check_op_def, try_swap_def, opbinargs_def, get_bin_args_def, apply_op_def]
     \\ rw [] \\ metis_tac [is_rec_term_ok])
+  \\ Cases_on ‘∃force_loc n. h = Force force_loc n’ \\ gvs []
+  >- (
+    gvs [scan_expr_def, evaluate_def]
+    \\ ‘LENGTH env1 ≤ LENGTH env2’ by metis_tac [env_rel_def, IS_PREFIX_LENGTH]
+    \\ imp_res_tac state_rel_const \\ gvs []
+    \\ rw [] \\ gvs [AllCaseEqs(), PULL_EXISTS]
+    >- (
+      gvs [oneline dest_thunk_def, env_rel_def, AllCaseEqs(), PULL_EXISTS]
+      \\ drule_then drule is_prefix_el \\ simp []
+      \\ disch_then $ assume_tac o GSYM \\ gvs [])
+    >- (
+      gvs [oneline dest_thunk_def, env_rel_def, AllCaseEqs(), PULL_EXISTS]
+      \\ drule_then drule is_prefix_el \\ simp []
+      \\ disch_then $ assume_tac o GSYM \\ gvs []
+      \\ gvs [find_code_def, AllCaseEqs()]
+      \\ simp [GSYM PULL_EXISTS] \\ reverse $ rw []
+      >- gvs [state_rel_def, state_component_equality]
+      \\ drule state_rel_code_rel \\ rw [code_rel_def]
+      \\ first_x_assum drule \\ rw []
+      \\ gvs [compile_exp_def]
+      \\ Cases_on `check_exp force_loc 2 exp` \\ gvs []
+      \\ pairarg_tac \\ gvs [])
+    \\ last_assum $ qspecl_then [‘[exp]’, ‘dec_clock 1 s’] mp_tac
+    \\ gvs [dec_clock_def]
+    \\ disch_then drule
+    \\ gvs [find_code_def, oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ ‘state_rel (s with clock := s.clock - 1) (s' with clock := s'.clock - 1)’
+      by gvs [state_rel_def]
+    \\ disch_then $ drule_at (Pat ‘state_rel _ _’) \\ gvs []
+    \\ ‘ty_rel [RefPtr v0 ptr; v] [Any; Any]’ by gvs [ty_rel_def]
+    \\ disch_then $ drule_at (Pat ‘ty_rel _ _’) \\ gvs []
+    \\ disch_then $ qspec_then ‘F’ mp_tac \\ simp [env_rel_def]
+    \\ disch_then $ qspec_then ‘[RefPtr v0 ptr; v]’ mp_tac \\ rw []
+    \\ ‘EL n env2 = EL n env1’ by (
+      gvs [env_rel_def] \\ drule_then drule is_prefix_el \\ rw [])
+    \\ gvs [PULL_EXISTS]
+    \\ qpat_x_assum ‘state_rel (s with clock := _) (s' with clock := _)’
+         assume_tac
+    \\ drule state_rel_code_rel \\ simp [code_rel_def]
+    \\ disch_then drule \\ rw []
+    \\ Cases_on ‘check_exp force_loc 2 exp’ \\ gvs []
+    \\ gvs [compile_exp_def, AllCaseEqs()]
+    \\ pairarg_tac \\ gvs []
+    \\ imp_res_tac scan_expr_not_Noop
+    \\ drule evaluate_let_wrap
+    \\ qabbrev_tac ‘a = [RefPtr v0 ptr; v]’
+    \\ disch_then $ qspecl_then [‘opt'’, ‘a’,
+                                 ‘s' with clock := s'.clock - 1’] assume_tac
+    \\ ‘LENGTH a = 2’ by (unabbrev_all_tac \\ gvs []) \\ gvs []
+    \\ ntac 2 (pop_assum kall_tac)
+    \\ first_assum (qspecl_then [‘[exp]’,‘dec_clock 1 s’] mp_tac)
+    \\ impl_tac >- (imp_res_tac evaluate_clock \\ fs [dec_clock_def])
+    \\ ‘env_rel (op_type x) T (LENGTH a) a (a ++ [op_id_val x] ++ a)’ by (
+      Cases_on ‘x’
+      \\ gvs [op_id_val_def, op_type_def, env_rel_def, EL_LENGTH_APPEND,
+             EL_APPEND1, IS_PREFIX_APPEND, bvlSemTheory.v_to_list_def])
+    \\ ‘ty_rel a [Any; Any]’ by gvs [ty_rel_def, LIST_REL_EL_EQN, EL_REPLICATE]
+    \\ gvs [dec_clock_def]
+    \\ rpt (disch_then drule) \\ gvs []
+    \\ disch_then (qspec_then ‘force_loc’ mp_tac) \\ rw []
+    \\ unabbrev_all_tac \\ gvs []
+    \\ ‘REPLICATE 2 Any = [Any; Any]’ by gvs [REPLICATE_compute] \\ gvs []
+    \\ first_x_assum $ qspecl_then [‘x’,‘n'’] mp_tac \\ rw [] \\ gvs []
+    \\ gvs [optimized_code_def, compile_exp_def, check_exp_def]
+    \\ gvs [evaluate_def, apply_op_def, AllCaseEqs()]
+    \\ (
+      scan_expr_ty_rel
+        |> SPEC_ALL
+        |> INST_TYPE [alpha|->“:num#'c”,beta|->“:'ffi”]
+        |> GEN_ALL
+        |> drule
+      \\ rpt (disch_then drule) \\ strip_tac \\ gvs []
+      \\ pop_assum mp_tac \\ gvs [] \\ once_rewrite_tac [ty_rel_def]
+      \\ strip_tac \\ gvs []
+      \\ PRED_ASSUM is_forall kall_tac
+      \\ Cases_on ‘x’
+      \\ gvs [op_type_def, to_op_def, do_app_def, do_app_aux_def, op_id_val_def,
+              bvlSemTheory.do_app_def, bvlSemTheory.v_to_list_def,
+              list_to_v_imp, oneline bvlSemTheory.do_int_app_def,
+              AllCaseEqs()]))
   \\ Cases_on `∃ticks dest xs hdl. h = Call ticks dest xs hdl` \\ fs [] \\ rveq
   >-
    (simp [scan_expr_def, evaluate_def]
diff --git a/compiler/backend/proofs/bvi_to_dataProofScript.sml b/compiler/backend/proofs/bvi_to_dataProofScript.sml
index 6d00deeb63..39b38edc6f 100644
--- a/compiler/backend/proofs/bvi_to_dataProofScript.sml
+++ b/compiler/backend/proofs/bvi_to_dataProofScript.sml
@@ -66,6 +66,7 @@ QED
 Definition data_to_bvi_ref_def[simp]:
   data_to_bvi_ref (ValueArray l)   = ValueArray (MAP data_to_bvi_v l)
 ∧ data_to_bvi_ref (ByteArray b bl) = ByteArray b bl
+∧ data_to_bvi_ref (Thunk m v)      = Thunk m (data_to_bvi_v v)
 End
 
 (* State relation *)
@@ -359,7 +360,9 @@ val [ data_to_bvi_eq_Number,  data_to_bvi_eq_Word64
 Theorem data_to_bvi_ref_eq[simp]:
   (∀v fl ds. data_to_bvi_ref v = ByteArray fl ds <=> v = ByteArray fl ds) ∧
   (∀v l.     data_to_bvi_ref v = ValueArray l
-    <=> ∃l'. v = ValueArray l' ∧ l = MAP data_to_bvi_v l')
+    <=> ∃l'. v = ValueArray l' ∧ l = MAP data_to_bvi_v l') ∧
+  (∀v m w.   data_to_bvi_ref v = Thunk m w
+    <=> ∃w'. v = Thunk m w' ∧ w = data_to_bvi_v w')
 Proof
   rw [] \\ Cases_on `v` \\ fs [data_to_bvi_ref_def] \\ METIS_TAC []
 QED
@@ -368,8 +371,10 @@ Theorem data_to_bvi_ref_eq'[simp] =
 (CONV_RULE (DEPTH_FORALL_CONV (EVERY_CONJ_CONV
 (DEPTH_FORALL_CONV (LHS_CONV (SYM_CONV))))) data_to_bvi_ref_eq)
 
-val [data_to_bvi_eq_ByteArray, data_to_bvi_eq_ValueArray] =
-  zip ["data_to_bvi_eq_ByteArray", "data_to_bvi_eq_ValueArray"]
+val [data_to_bvi_eq_ByteArray, data_to_bvi_eq_ValueArray,
+     data_to_bvi_eq_Thunk] =
+  zip ["data_to_bvi_eq_ByteArray", "data_to_bvi_eq_ValueArray",
+       "data_to_bvi_eq_Thunk"]
       (CONJUNCTS data_to_bvi_ref_eq)  |> map save_thm;
 
 (* Construction of the pre-image of `data_to_bvi_result` *)
@@ -489,6 +494,7 @@ fun cases_on_op q = Cases_on q
 Theorem data_to_bvi_do_app:
   ∀op t r z res s1.
     op ≠ Install ∧ op ≠ IntOp Greater ∧ op ≠ IntOp GreaterEq ∧ (∀b. op ≠ MemOp (CopyByte b)) ∧
+    op ≠ ThunkOp ForceThunk ∧
     state_rel r t ∧
     do_app op (MAP data_to_bvi_v z) r = Rval (res,s1)
     ⇒ ∃s2 pres.
@@ -585,6 +591,12 @@ Proof
   >- (rename1 `Label` \\ rfs [code_rel_def])
   >- (rename1 `FFI` \\ rw[])
   >- (rename1 `FFI ""` \\ rw[])
+  >~ [`ThunkOp (AllocThunk t)`]
+  >- (rw [data_to_bvi_ref_def]
+      \\ gvs [refs_rel_LEAST_eq, lookup_map, map_replicate])
+  >~ [`ThunkOp (UpdateThunk t)`]
+  >- (rw [data_to_bvi_ref_def]
+      \\ gvs [refs_rel_LEAST_eq, lookup_map, map_replicate])
 QED
 
 Theorem state_rel_peak_safe:
@@ -636,6 +648,17 @@ Proof
   \\ rveq \\ fs [state_component_equality]
 QED
 
+Theorem state_rel_dest_thunk:
+  state_rel s t ∧
+  dest_thunk (data_to_bvi_v z) s.refs = IsThunk ev v ⇒
+    ∃v'. dest_thunk z t.refs = IsThunk ev v' ∧
+         data_to_bvi_v v' = v
+Proof
+  rw []
+  \\ gvs [oneline bviSemTheory.dest_thunk_def, oneline dest_thunk_def,
+          state_rel_def, lookup_map, AllCaseEqs()]
+QED
+
 fun note_tac s g = (print ("compile_correct: " ^ s ^ "\n"); ALL_TAC g);
 
 Theorem compile_correct:
@@ -956,7 +979,8 @@ Proof
        \\ IMP_RES_TAC get_vars_inter
        \\ IMP_RES_TAC get_vars_reverse
        \\ rveq \\ fs [])
-    \\ reverse(Cases_on `do_app op (REVERSE a) r`) \\ full_simp_tac(srw_ss())[] >- (
+    \\ gvs []
+    \\ reverse(Cases_on `do_app op (MAP data_to_bvi_v (REVERSE z')) r`) \\ full_simp_tac(srw_ss())[] >- (
      imp_res_tac bviPropsTheory.do_app_err >> full_simp_tac(srw_ss())[] >>
      rveq >> IF_CASES_TAC >>
      fs[dataSemTheory.evaluate_def,iAssign_def,dataLangTheory.op_requires_names_def,
@@ -967,7 +991,7 @@ Proof
      fs[state_rel_def] >>
      rfs[] >> fs [data_to_bvi_result_def] >>
      fs[call_env_def,flush_state_def,data_to_bvi_ref_def,lookup_map])
-    \\ PairCases_on `a'` \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []
+    \\ PairCases_on `a` \\ full_simp_tac(srw_ss())[] \\ REV_FULL_SIMP_TAC std_ss []
     \\ rpt var_eq_tac >> full_simp_tac(srw_ss())[]
     \\ full_simp_tac(srw_ss())[LET_DEF,evaluate_def,iAssign_def]
     \\ (fn (hs,goal) => (reverse (sg `let tail = F in ^goal`))
@@ -976,7 +1000,7 @@ Proof
       \\ reverse (Cases_on `tail`) THEN1 METIS_TAC []
       \\ full_simp_tac(srw_ss())[evaluate_def,LET_DEF] \\ REV_FULL_SIMP_TAC std_ss []
       \\ Cases_on `pres` \\ full_simp_tac(srw_ss())[]
-      \\ `∃z2. get_var n1 t2'.locals = SOME  z2 ∧ a'0 = data_to_bvi_v z2`
+      \\ `∃z2. get_var n1 t2'.locals = SOME  z2 ∧ a0 = data_to_bvi_v z2`
             by FULL_SIMP_TAC (srw_ss()) [var_corr_def,lookup_map,get_var_def]
            \\ full_simp_tac(srw_ss())[var_corr_def,call_env_def,flush_state_def,state_rel_def,data_to_bvi_result_def])
     \\ simp[]
@@ -1005,6 +1029,7 @@ Proof
       \\ Cases_on`h` \\ fs[set_var_def,lookup_insert,var_corr_def,state_rel_def,o_DEF,get_var_def,lookup_insert,lookup_map]
       \\ qmatch_goalsub_abbrev_tac`fromAList progs1`
       \\ qmatch_goalsub_abbrev_tac`union t2.code (fromAList progs2)`
+      \\ gvs [PULL_EXISTS]
       \\ conj_tac
       >- (
         ntac 2 (pop_assum kall_tac) \\ rveq \\
@@ -1183,6 +1208,9 @@ Proof
       \\ fs[jump_exc_def]
       \\ TOP_CASE_TAC \\ fs[]
       \\ TOP_CASE_TAC \\ fs[])
+    \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs []
+    >- gvs [bviSemTheory.do_app_def, bvlSemTheory.do_app_def,
+           bviSemTheory.do_app_aux_def, AllCaseEqs()]
     \\ fs []
     \\ fs[bviSemTheory.state_component_equality] \\ rveq
     \\ Cases_on `op_requires_names op`
@@ -1373,6 +1401,166 @@ Proof
     \\ FULL_SIMP_TAC (srw_ss()) [var_corr_def,dataSemTheory.dec_clock_def,
                                  get_var_def,state_rel_def,bviSemTheory.dec_clock_def,
                                  jump_exc_NONE])
+  >- ((* Force *)
+    gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS]
+    >- (
+      gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN]
+      \\ last_assum $ drule_then assume_tac \\ fs []
+      \\ fs [get_var_def, lookup_map] \\ gvs []
+      \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs []
+      \\ Cases_on `tail` \\ gvs []
+      >- gvs [state_rel_def, flush_state_def]
+      \\ gvs [cut_env_def]
+      \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by (
+        gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set]
+        \\ rw []
+        >- (
+          gvs [EVERY_EL, MEM_EL]
+          \\ first_x_assum drule \\ rw []
+          \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs [])
+        >- (
+          gvs [MEM_EL]
+          \\ first_x_assum drule \\ rw []
+          \\ simp [SF SFY_ss]))
+      \\ gvs [set_var_def, state_rel_def, lookup_insert, lookup_inter_alt,
+              domain_list_to_num_set, lookup_map] \\ rw []
+      >- (last_x_assum drule \\ rw [])
+      >- gvs [MEM_EL]
+      >- (
+        gvs [SUBSET_DEF, domain_list_to_num_set]
+        \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs []))
+      >- (
+        gvs [SUBSET_DEF, domain_list_to_num_set]
+        \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs []))
+      >- gvs [MEM_EL]
+      >- gvs [MEM_EL]
+      >- gvs [jump_exc_def])
+    >- (
+      gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN]
+      \\ last_assum $ drule_then assume_tac \\ fs []
+      \\ fs [get_var_def, lookup_map] \\ gvs []
+      \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs []
+      \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs []
+      \\ gvs [find_code_def, dataSemTheory.find_code_def, AllCaseEqs()]
+      \\ `lookup force_loc t1.code = SOME (2,compile_exp 2 exp)`
+        by gvs [state_rel_def, code_rel_def] \\ gvs []
+      \\ Cases_on `tail` \\ gvs []
+      >- gvs [state_rel_def]
+      \\ gvs [cut_env_def]
+      \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by (
+        gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set]
+        \\ rw []
+        >- (
+          gvs [EVERY_EL, MEM_EL]
+          \\ first_x_assum drule \\ rw []
+          \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs [])
+        >- (
+          gvs [MEM_EL, state_rel_def]
+          \\ first_x_assum drule \\ rw []
+          \\ simp [SF SFY_ss]))
+      \\ gvs [state_rel_def, call_env_def, push_env_def, dec_clock_def])
+    \\ gvs [any_el_ALT, var_corr_def, LIST_REL_EL_EQN]
+    \\ first_assum $ drule_then assume_tac \\ fs []
+    \\ fs [get_var_def, lookup_map] \\ gvs []
+    \\ drule_all_then assume_tac state_rel_dest_thunk \\ gvs []
+    \\ `find_code (SOME force_loc) (MAP data_to_bvi_v [z;v']) s.code =
+          SOME (args,exp)` by gvs []
+    \\ drule_all find_code_lemma \\ rw [] \\ gvs []
+    \\ `t1.clock = s.clock` by gvs [state_rel_def] \\ gvs []
+    \\ Cases_on `tail` \\ gvs [PULL_EXISTS]
+    >- (
+      gvs [compile_exp_def]
+      \\ last_x_assum
+        $ qspecl_then [`call_env args' ss (dec_clock t1)`, `LENGTH args'`,
+                       `COUNT_LIST (LENGTH args')`, `T`, `[]`] mp_tac
+      \\ gvs [] \\ impl_tac
+      >- (
+        rw []
+        >- gvs [COUNT_LIST_GENLIST]
+        >- gvs [COUNT_LIST_GENLIST, EL_MAP, dec_clock_def, call_env_def,
+                lookup_fromList]
+        >- gvs [call_env_def, lookup_fromList, dec_clock_def]
+        >- gvs [dec_clock_def, bviSemTheory.dec_clock_def, state_rel_def,
+                call_env_def]
+        >- gvs [jump_exc_def, dec_clock_def, call_env_def, AllCaseEqs()])
+      \\ rw [] \\ gvs []
+      \\ Cases_on `pres` \\ gvs []
+      \\ Cases_on `x` \\ gvs [dec_clock_def]
+      >- (
+        qspecl_then [`prog`,`call_env args' ss (t1 with clock := s.clock - 1)`]
+                    assume_tac optimise_correct \\ gvs []
+        \\ gvs [state_rel_def, call_env_def])
+      \\ qspecl_then [`prog`,`call_env args' ss (t1 with clock := s.clock - 1)`]
+                      assume_tac optimise_correct \\ gvs []
+      \\ Cases_on `e` \\ gvs []
+      >- (
+        gvs [state_rel_def, jump_exc_def, call_env_def, AllCaseEqs()]
+        \\ qexists `ls` \\ gvs [state_component_equality])
+      \\ gvs [state_rel_def])
+    \\ last_x_assum $ qspecl_then [
+      `call_env args' ss (push_env (inter t1.locals
+          (list_to_num_set (live ++ corr))) F (dec_clock t1))`,
+      `LENGTH args'`, `COUNT_LIST (LENGTH args')`, `T`, `[]`] mp_tac
+    \\ gvs [COUNT_LIST_GENLIST, dec_clock_def, bviSemTheory.dec_clock_def]
+    \\ impl_tac
+    >- (
+      rw []
+      >- gvs [call_env_def, push_env_def, lookup_fromList, EL_MAP]
+      >- gvs [call_env_def, push_env_def, lookup_fromList]
+      >- gvs [call_env_def, push_env_def, state_rel_def]
+      >- gvs [call_env_def, push_env_def, jump_exc_def, AllCaseEqs(), LASTN_TL])
+    \\ rw [] \\ gvs []
+    \\ Cases_on `pres` \\ gvs [PULL_EXISTS]
+    \\ `domain (list_to_num_set (live ++ corr)) ⊆ domain t1.locals` by (
+      gvs [SUBSET_DEF, domain_lookup, lookup_list_to_num_set]
+      \\ rw []
+      >- (
+        gvs [EVERY_EL, MEM_EL]
+        \\ first_x_assum drule \\ rw []
+        \\ Cases_on `lookup (EL n'' live) t1.locals` \\ gvs [])
+      >- (
+        gvs [MEM_EL]
+        \\ first_x_assum drule \\ rw []
+        \\ simp [SF SFY_ss]))
+    \\ gvs [cut_env_def, PULL_EXISTS, compile_exp_def, COUNT_LIST_GENLIST]
+    \\ qspecl_then [`prog`,
+      `call_env args' ss (push_env (inter t1.locals (list_to_num_set (live ++ corr)))
+                   F (t1 with clock := s.clock − 1))`]
+                    assume_tac optimise_correct \\ gvs []
+    \\ reverse $ Cases_on `x` \\ gvs []
+    >- (
+      Cases_on `e` \\ gvs []
+      >- (
+        gvs [state_rel_def, jump_exc_def, call_env_def, push_env_def,
+             LASTN_TL, AllCaseEqs()]
+        \\ qexists `ls` \\ gvs [state_component_equality])
+      \\ gvs [state_rel_def])
+    \\ `pop_env (t2 with <| locals_size := ls';
+                            stack_max := smx;
+                            safe_for_space := safe;
+                            peak_heap_length := peak |>) =
+       SOME (t2 with <| stack := t1.stack;
+                        locals := inter t1.locals (list_to_num_set (live ++ corr));
+                        locals_size := t1.locals_size;
+                        stack_max := smx;
+                        safe_for_space := safe;
+                        peak_heap_length := peak|>)`
+      by (Q.PAT_X_ASSUM `xx = t2.stack` (ASSUME_TAC o GSYM)
+          \\ FULL_SIMP_TAC (srw_ss()) [call_env_def,push_env_def,flush_state_def,
+                                       pop_env_def,dataSemTheory.dec_clock_def,bviSemTheory.dec_clock_def,
+                                       FUNPOW_dec_clock_code,LET_DEF])
+    \\ gvs [set_var_def, state_rel_def, lookup_insert, lookup_inter_alt,
+            lookup_map]
+    \\ rw []
+    >- (last_x_assum drule \\ rw [])
+    >- gvs [domain_list_to_num_set, MEM_EL]
+    >- (
+      gvs [domain_list_to_num_set]
+      \\ rpt (first_x_assum $ qspec_then `k` assume_tac \\ gvs []))
+    >- gvs [domain_list_to_num_set]
+    >- gvs [domain_list_to_num_set]
+    >- gvs [call_env_def, push_env_def]
+    >- gvs [jump_exc_def, call_env_def, push_env_def, AllCaseEqs()])
   (* Call *)
   \\ note_tac "Call"
   \\ Cases_on `handler`
diff --git a/compiler/backend/proofs/bvl_constProofScript.sml b/compiler/backend/proofs/bvl_constProofScript.sml
index 2f84db1d58..3e4548ca35 100644
--- a/compiler/backend/proofs/bvl_constProofScript.sml
+++ b/compiler/backend/proofs/bvl_constProofScript.sml
@@ -13,7 +13,9 @@ Definition v_rel_def:
   v_rel (:'c) (:'ffi) a x y xs ys =
     case a of
     | Var n => LLOOKUP ys n = SOME x
-    | Op _ _ => !(s:('c,'ffi) bvlSem$state) env. evaluate ([a],env,s) = (Rval [x],s)
+    | Op _ _ =>
+      (x = y) ∧
+      !(s:('c,'ffi) bvlSem$state) env. evaluate ([a],env,s) = (Rval [x],s)
     | _ => F
 End
 
@@ -184,10 +186,13 @@ Proof
     fs [dest_simple_eq, case_op_const_eq] \\
     simp [evaluate_def, do_app_def,oneline do_int_app_def] \\
     fsrw_tac [DNF_ss] [case_eq_thms] \\
-    rw [REVERSE_DEF] \\
-    imp_res_tac evaluate_SING  \\
-    fs [] \\ rveq \\
-    intLib.COOPER_TAC)
+    rw [REVERSE_DEF]
+    \\ (
+      imp_res_tac evaluate_SING  \\
+      fs [] \\ rveq \\
+      intLib.COOPER_TAC
+        ORELSE metis_tac [intLib.COOPER_PROVE
+                           ``!(a : int) b. 0 ≤ a ∧ a < &b ⇒ Num a < b``]))
   \\ fs []
   \\ every_case_tac \\ fs []
   \\ fs [dest_simple_eq] \\ rveq
@@ -219,7 +224,6 @@ Proof
   \\ rw [] \\ gvs [] \\ eq_tac \\ rw []
 QED
 
-
 Theorem SmartOp_thm:
    evaluate ([Op op xs],env,s) = (res,s2) /\
     res ≠ Rerr (Rabort Rtype_error) ==>
@@ -295,6 +299,15 @@ Proof
     \\ res_tac \\ rw [] \\ Cases_on `e` \\ fs [] \\ rw [] \\ fs []
     \\ first_x_assum match_mp_tac
     \\ fs [env_rel_def])
+  >~ [‘dest_thunk’] >- (
+    imp_res_tac env_rel_length \\ gvs []
+    \\ rpt (PURE_CASE_TAC \\ gvs [])
+    \\ gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS]
+    >>~- ([‘LLOOKUP _ _ = NONE’], drule env_rel_LLOOKUP_NONE \\ rw [])
+    >>~- ([‘LLOOKUP _ _ = SOME NONE’], drule env_rel_LLOOKUP_NONE \\ rw [])
+    \\ (
+      drule_all env_rel_LOOKUP_SOME \\ rw []
+      \\ gvs [v_rel_def, LLOOKUP_DROP, LLOOKUP_EQ_EL, EL_DROP]))
   \\ TRY (match_mp_tac SmartOp_thm)
   \\ fs [evaluate_def] \\ every_case_tac \\ fs [] \\ rw [] \\ fs []
   \\ res_tac \\ fs [] \\ rw [] \\ fs [] \\ rw [] \\ fs []
@@ -402,7 +415,7 @@ Proof
     \\ fs[MEM_MAP, MEM_FILTER, IS_SOME_EXISTS, PULL_EXISTS]
     \\ simp[MEM_EL, PULL_EXISTS]
     \\ goal_assum(first_assum o mp_then Any mp_tac) \\ simp[]
-    \\ PURE_FULL_CASE_TAC \\ fs[] )
+    \\ PURE_FULL_CASE_TAC \\ fs[])
   >- (
     rw[]
     \\ last_x_assum drule
@@ -411,6 +424,17 @@ Proof
     >- metis_tac[]
     \\ imp_res_tac MEM_extract_list_code_labels
     \\ fs[])
+  >- (
+    CASE_TAC \\ gvs []
+    \\ CASE_TAC \\ gvs []
+    \\ rw []
+    \\ Cases_on ‘x'' = loc’ \\ gvs []
+    \\ asm_exists_tac \\ gvs []
+    \\ gvs [LLOOKUP_THM]
+    \\ gvs [MEM_MAP, MEM_FILTER, IS_SOME_EXISTS, PULL_EXISTS]
+    \\ simp [MEM_EL, PULL_EXISTS]
+    \\ goal_assum (first_assum o mp_then Any mp_tac) \\ simp []
+    \\ FULL_CASE_TAC \\ gvs [])
 QED
 
 Theorem compile_exp_code_labels:
diff --git a/compiler/backend/proofs/bvl_handleProofScript.sml b/compiler/backend/proofs/bvl_handleProofScript.sml
index df1d0528a4..bbaeacef72 100644
--- a/compiler/backend/proofs/bvl_handleProofScript.sml
+++ b/compiler/backend/proofs/bvl_handleProofScript.sml
@@ -55,6 +55,8 @@ Proof
    (rpt (CASE_TAC \\ fs [])
     \\ first_x_assum (qspec_then ‘a'::xs’ mp_tac)
     \\ imp_res_tac evaluate_IMP_LENGTH \\ fs [ADD1])
+  >-
+   (rw [] \\ gvs [EL_APPEND])
   \\ once_rewrite_tac [evaluate_CONS] \\ fs []
 QED
 
@@ -179,6 +181,7 @@ Definition handle_ok_def:
          EVERY isVar xs /\ bVarBound (LENGTH xs) [b] /\
          handle_ok [b] /\ handle_ok [x2]
      | _ => F) /\
+  (handle_ok [Force loc n] <=> T) ∧
   (handle_ok [Call ticks dest xs] <=> handle_ok xs)
 Termination
   WF_REL_TAC `measure (exp1_size)`
@@ -435,6 +438,11 @@ Theorem compile_correct = Q.prove(`
       \\ Cases \\ fs [ADD1]) \\ res_tac \\ fs [])
   THEN1 (* Op *)
    (fs [env_rel_mk_Union] \\ rpt gen_tac \\ strip_tac
+    \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs []
+    >- (
+      gvs [AllCaseEqs()]
+      \\ rpt strip_tac
+      \\ simp [evaluate_def] \\ gvs [])
     \\ drule (GEN_ALL OptionalLetLet_IMP) \\ strip_tac
     \\ pop_assum match_mp_tac
     \\ drule (GEN_ALL OptionalLetLet_limit)
@@ -446,6 +454,12 @@ Theorem compile_correct = Q.prove(`
     \\ imp_res_tac do_app_err \\ fs [] \\ res_tac \\ fs [])
   THEN1 (* Tick *)
    (Cases_on `s.clock = 0` \\ fs [] \\ rw [evaluate_def] \\ res_tac \\ fs [])
+  THEN1 (* Force *)
+   (rw [] \\ gvs []
+    \\ gvs [AllCaseEqs(), evaluate_def, PULL_EXISTS]
+    \\ imp_res_tac env_rel_length \\ gvs [EL_APPEND]
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS, env_rel_def,
+            LIST_RELi_EL_EQN])
   THEN1 (* Call *)
    (fs [env_rel_mk_Union] \\ rpt gen_tac \\ strip_tac
     \\ drule (GEN_ALL OptionalLetLet_IMP) \\ strip_tac
@@ -790,7 +804,7 @@ Proof
   \\ rveq \\ fs[NULL_EQ] \\ rw[bvl_handleTheory.OptionalLetLet_def]
   \\ fs[]
   \\ fsrw_tac[DNF_ss][SUBSET_DEF]
-  \\ EVAL_TAC
+  \\ EVAL_TAC \\ rw []
 QED
 
 Triviality get_code_labels_dest_handle_Raise:
diff --git a/compiler/backend/proofs/bvl_inlineProofScript.sml b/compiler/backend/proofs/bvl_inlineProofScript.sml
index a957a9b71e..30f4020971 100644
--- a/compiler/backend/proofs/bvl_inlineProofScript.sml
+++ b/compiler/backend/proofs/bvl_inlineProofScript.sml
@@ -208,6 +208,8 @@ Proof
     \\ drule evaluate_add_clock \\ fs [inc_clock_def])
   THEN1 (* Op *)
    (fs [remove_ticks_def,evaluate_def]
+    \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs []
+    >- (gvs [AllCaseEqs(), do_app_def, PULL_EXISTS] \\ metis_tac [])
     \\ FULL_CASE_TAC \\ fs []
     \\ first_x_assum drule \\ fs []
     \\ disch_then drule \\ strip_tac
@@ -223,6 +225,14 @@ Proof
     \\ disch_then drule \\ strip_tac
     \\ fs [bvlSemTheory.evaluate_def]
     \\ qexists_tac `ck + 1` \\ fs [dec_clock_def])
+  THEN1
+   (gvs [remove_ticks_def, evaluate_def, oneline dest_thunk_def,
+         AllCaseEqs(), PULL_EXISTS, state_rel_def, find_code_def,
+         lookup_map, dec_clock_def]
+    >- (qexistsl [‘0’, ‘t with clock := 0`] \\ gvs [])
+    \\ last_x_assum $ drule_at (Pat ‘evaluate _ = _’)
+    \\ disch_then $ qspec_then ‘t with clock := t.clock - 1’ assume_tac
+    \\ gvs [] \\ metis_tac [])
   (* Call *)
   \\ fs [remove_ticks_def]
   \\ fs [bvlSemTheory.evaluate_def]
@@ -285,12 +295,13 @@ val evaluate_remove_ticks_thm =
 
 Definition remove_ticks_cc_def:
   remove_ticks_cc cc =
-    (λcfg prog'. cc cfg (MAP (I ## I ## (λx. HD (remove_ticks [x]))) prog'))
+    (λcfg prog'.
+         cc cfg (MAP (I ## I ## (λx. HD (bvl_inline$remove_ticks [x]))) prog'))
 End
 
 Definition remove_ticks_co_def:
   remove_ticks_co =
-    (I ## MAP (I ## I ## (λx. HD (remove_ticks [x]))))
+    (I ## MAP (I ## I ## (λx. HD (bvl_inline$remove_ticks [x]))))
 End
 
 Theorem evaluate_compile_prog:
@@ -550,7 +561,7 @@ Proof
 QED
 
 val remove_ticks_CONS = prove(
-  ``!xs x. remove_ticks (x::xs) =
+  ``!xs x. bvl_inline$remove_ticks (x::xs) =
            HD (remove_ticks [x]) :: remove_ticks xs``,
   Cases \\ fs [remove_ticks_def]);
 
@@ -579,6 +590,7 @@ Inductive exp_rel:
    exp_rel cs [Tick x] [Tick y]) /\
   (exp_rel cs xs ys ==>
    exp_rel cs [Op op xs] [Op op ys]) /\
+  (exp_rel cs [Force loc n] [Force loc n]) /\
   (exp_rel cs xs ys ==>
    exp_rel cs [Call ticks dest xs] [Call ticks dest ys]) /\
   (exp_rel cs xs ys /\ lookup n cs = SOME (arity, x) /\
@@ -904,6 +916,16 @@ Proof
   \\ imp_res_tac do_app_const \\ fs []
 QED
 
+Theorem exp_rel_refl:
+   !cs xs. exp_rel cs xs xs
+Proof
+  ho_match_mp_tac tick_inline_ind \\ rw []
+  \\ once_rewrite_tac [exp_rel_cases] \\ fs []
+  \\ Cases_on `dest` \\ fs []
+  \\ Cases_on `lookup x cs` \\ fs []
+  \\ Cases_on `x'` \\ fs []
+QED
+
 Theorem evaluate_inline:
    !es env s1 res t1 s2 es2.
       in_state_rel limit s1 t1 /\ exp_rel s1.code es es2 /\
@@ -962,7 +984,9 @@ Proof
     \\ drule subspt_exp_rel \\ disch_then drule \\ rw []
     \\ pop_assum drule \\ rw [] \\ fs [])
   THEN1
-   (fs [case_eq_thms] \\ rveq \\ fs []
+   (Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs []
+    >- gvs [evaluate_def, do_app_def, AllCaseEqs()]
+    \\ fs [case_eq_thms] \\ rveq \\ fs []
     \\ first_x_assum drule
     \\ disch_then drule \\ strip_tac
     \\ fs [evaluate_def]
@@ -980,6 +1004,17 @@ Proof
     \\ first_x_assum drule
     \\ disch_then drule \\ strip_tac
     \\ fs [evaluate_def])
+  THEN1
+   (gvs [AllCaseEqs(), evaluate_def, PULL_EXISTS, oneline dest_thunk_def]
+    >- gvs [in_state_rel_def]
+    >- (
+      gvs [in_state_rel_def, find_code_def, AllCaseEqs()]
+      \\ first_x_assum drule \\ rw [] \\ gvs [])
+    \\ ‘in_state_rel limit (dec_clock 1 s) (dec_clock 1 t1)’
+      by gvs [in_state_rel_def, dec_clock_def]
+    \\ last_x_assum drule \\ rw []
+    \\ gvs [find_code_def, AllCaseEqs(), in_state_rel_def, PULL_EXISTS]
+    \\ last_x_assum drule \\ rw [] \\ gvs [])
   THEN1
    (reverse (fs [case_eq_thms] \\ rveq \\ fs [])
     \\ first_x_assum drule
@@ -1022,16 +1057,6 @@ Proof
   \\ drule evaluate_expand_env \\ fs []
 QED
 
-Theorem exp_rel_refl:
-   !cs xs. exp_rel cs xs xs
-Proof
-  ho_match_mp_tac tick_inline_ind \\ rw []
-  \\ once_rewrite_tac [exp_rel_cases] \\ fs []
-  \\ Cases_on `dest` \\ fs []
-  \\ Cases_on `lookup x cs` \\ fs []
-  \\ Cases_on `x'` \\ fs []
-QED
-
 Definition in_co_def:
   in_co limit co = (λn.
       (let
@@ -1410,20 +1435,20 @@ val let_state_rel_def = let_state_rel_def
   |> SIMP_RULE (srw_ss()) [state_component_equality,GSYM CONJ_ASSOC];
 
 Theorem HD_let_op[simp]:
-   [HD (let_op [x])] = let_op [x]
+   [HD (let_op [x :bvl$exp])] = let_op [x]
 Proof
   Cases_on `x` \\ simp_tac std_ss [let_op_def] \\ fs []
   \\ CASE_TAC \\ fs []
 QED
 
 val let_op_sing_thm = prove(
-  ``let_op_sing x = HD (let_op [x])``,
+  ``let_op_sing (x :bvl$exp) = HD (let_op [x])``,
   fs [let_op_sing_def]
   \\ once_rewrite_tac [GSYM HD_let_op] \\ fs []);
 
 val var_list_IMP_evaluate = prove(
-  ``!a2 a1 l xs s.
-      var_list (LENGTH a1) l xs /\ LENGTH (xs:bvl$exp list) = LENGTH a2 ==>
+  ``!a2 a1 l (xs :bvl$exp list) (s :('a, 'b) state).
+      var_list (LENGTH a1) l xs /\ LENGTH xs = LENGTH a2 ==>
       evaluate (l,a1++a2++env,s) = (Rval a2,s)``,
   Induct THEN1
    (fs [APPEND_NIL,var_list_def]
@@ -1442,14 +1467,14 @@ val var_list_IMP_evaluate = prove(
 
 val var_list_IMP_evaluate = prove(
   ``var_list 0 l xs /\ LENGTH (xs:bvl$exp list) = LENGTH a ==>
-    evaluate (l,a++env,s) = (Rval a,s)``,
+    evaluate (l,a++env,(s :('a, 'b) state)) = (Rval a,s)``,
   rw []
   \\ match_mp_tac (Q.SPECL [`xs`,`[]`] var_list_IMP_evaluate
        |> SIMP_RULE std_ss [APPEND,LENGTH])
   \\ asm_exists_tac \\ fs []);
 
 Theorem LENGTH_let_op:
-   !xs. LENGTH (let_op xs) = LENGTH xs
+   !(xs :bvl$exp list). LENGTH (let_op xs) = LENGTH xs
 Proof
   ho_match_mp_tac let_op_ind \\ rw [let_op_def]
   \\ CASE_TAC \\ fs []
@@ -1524,6 +1549,14 @@ Proof
      (first_x_assum drule \\ rw [] \\ fs []
       \\ TOP_CASE_TAC \\ fs []
       \\ fs [evaluate_def]
+      \\ Cases_on `x = ThunkOp ForceThunk` \\ gvs [] >- (
+        Cases_on `HD (let_op [x2])` \\ gvs [dest_op_def]
+        \\ drule (GEN_ALL var_list_IMP_evaluate) \\ fs [LENGTH_let_op]
+        \\ imp_res_tac evaluate_IMP_LENGTH
+        \\ disch_then drule \\ rw []
+        \\ qsuff_tac `let_op [x2] = [Op (ThunkOp ForceThunk) l]`
+        >- (rw [] \\ gvs [evaluate_def])
+        \\ once_rewrite_tac [GSYM HD_let_op] \\ gvs [])
       \\ Cases_on `HD (let_op [x2])` \\ fs [dest_op_def] \\ rveq
       \\ drule (GEN_ALL var_list_IMP_evaluate) \\ fs [LENGTH_let_op]
       \\ imp_res_tac evaluate_IMP_LENGTH
@@ -1541,7 +1574,9 @@ Proof
    (fs [case_eq_thms] \\ rveq \\ fs []
    \\ res_tac \\ fs [] \\ res_tac \\ fs [])
   THEN1
-   (fs [case_eq_thms] \\ rveq \\ fs []
+   (Cases_on ‘op = ThunkOp ForceThunk’ \\ gvs []
+    >- gvs [AllCaseEqs(), PULL_EXISTS, do_app_def]
+    \\ fs [case_eq_thms] \\ rveq \\ fs []
     \\ res_tac \\ fs [] \\ res_tac \\ fs []
     \\ rveq \\ fs []
     \\ drule do_app_lemma
@@ -1556,6 +1591,28 @@ Proof
     \\ fs [] \\ res_tac \\ fs [] \\ res_tac \\ fs []
     \\ rveq \\ fs []
     \\ qexists_tac `t2` \\ fs [] \\ fs [let_state_rel_def])
+  THEN1
+   (gvs [AllCaseEqs(), PULL_EXISTS]
+    >- gvs [let_state_rel_def]
+    >- gvs [let_state_rel_def, find_code_def, AllCaseEqs(), lookup_map,
+            let_opt_def]
+    \\ rename1 ‘let_state_rel q l s t’
+    \\ ‘let_state_rel q l (dec_clock 1 s) (dec_clock 1 t)’
+      by gvs [let_state_rel_def, dec_clock_def]
+    \\ last_x_assum drule \\ rw []
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ ‘FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated v)’
+      by gvs [let_state_rel_def]
+    \\ gvs []
+    \\ ‘t.clock ≠ 0’ by gvs [let_state_rel_def] \\ gvs [PULL_EXISTS]
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ ‘find_code (SOME force_loc) [RefPtr v0 ptr; v] t.code = SOME (args,
+           compile_any q l (LENGTH args) (let_op_sing exp))’
+      by gvs [find_code_def, AllCaseEqs(), let_state_rel_def, lookup_map,
+              let_opt_def]
+    \\ gvs []
+    \\ match_mp_tac bvl_handleProofTheory.compile_any_correct \\ fs []
+    \\ gvs [let_op_sing_thm])
   THEN1
    (fs [case_eq_thms] \\ rveq \\ fs []
     \\ res_tac \\ fs [] \\ res_tac \\ fs [] \\ rveq
diff --git a/compiler/backend/proofs/bvl_to_bviProofScript.sml b/compiler/backend/proofs/bvl_to_bviProofScript.sml
index 2a164916cd..dbe07381dd 100644
--- a/compiler/backend/proofs/bvl_to_bviProofScript.sml
+++ b/compiler/backend/proofs/bvl_to_bviProofScript.sml
@@ -99,6 +99,8 @@ Definition state_rel_def:
          | NONE => T
          | SOME (ValueArray vs) =>
              (FLOOKUP t.refs (b k) = SOME (ValueArray (MAP (adjust_bv b) vs)))
+         | SOME (Thunk m v) =>
+             (FLOOKUP t.refs (b k) = SOME (Thunk m (adjust_bv b v)))
          | SOME res => (FLOOKUP t.refs (b k) = SOME res)) /\
     (s.ffi = t.ffi) /\
     (∀p. t.global = SOME p ⇒
@@ -139,6 +141,24 @@ Proof
   >> rfs[]
 QED
 
+Theorem state_rel_FLOOKUP_valueArray:
+  state_rel b s t ∧
+  FLOOKUP s.refs ptr = SOME (ValueArray vs) ⇒
+    FLOOKUP t.refs (b ptr) = SOME (ValueArray (MAP (adjust_bv b) vs))
+Proof
+  rw [state_rel_def]
+  \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])
+QED
+
+Theorem state_rel_FLOOKUP_Thunk:
+  state_rel b s t ∧
+  FLOOKUP s.refs ptr = SOME (Thunk m v) ⇒
+    FLOOKUP t.refs (b ptr) = SOME (Thunk m (adjust_bv b v))
+Proof
+  rw [state_rel_def]
+  \\ rpt (first_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])
+QED
+
 Definition bv_ok_def:
   (bv_ok (refs: num |-> v ref) (RefPtr l r) <=> r IN FDOM refs) /\
   (bv_ok refs (Block tag vs) <=> EVERY (bv_ok refs) vs) /\
@@ -187,6 +207,7 @@ Definition state_ok_def:
     EVERY (\x. case x of NONE => T | SOME v => bv_ok s.refs v) s.globals /\
     !k. case FLOOKUP s.refs k of
         | SOME (ValueArray vs) => EVERY (bv_ok s.refs) vs
+        | SOME (Thunk _ v) => bv_ok s.refs v
         | _ => T
 End
 
@@ -289,7 +310,7 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem do_app_ok_lemma[local]:
   state_ok r /\ EVERY (bv_ok r.refs) a /\
@@ -506,6 +527,50 @@ Proof
     rename1 `ToListByte`
     \\ qspec_tac (`l`,`l`)
     \\ Induct \\ fs [bv_ok_def,list_to_v_def] )
+  >- (
+    rename1 `AllocThunk` \\ gvs [] \\ rw []
+    >- (
+      gvs [state_ok_def, bvlSemTheory.state_component_equality] \\ rw []
+      >- (
+        gvs [EVERY_EL] \\ rw []
+        \\ first_x_assum drule \\ rw []
+        \\ CASE_TAC \\ gvs []
+        \\ irule bv_ok_SUBSET_IMP \\ gvs []
+        \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM])
+      >- (
+        gvs [FLOOKUP_DEF, FAPPLY_FUPDATE_THM] \\ rw []
+        >- (
+          irule bv_ok_SUBSET_IMP \\ gvs []
+          \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM])
+        \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs []
+        \\ CASE_TAC \\ gvs [EVERY_EL] \\ rw []
+        \\ rpt (first_x_assum drule \\ rw [])
+        \\ irule bv_ok_SUBSET_IMP \\ gvs []
+        \\ goal_assum $ drule_at Any \\ gvs [LEAST_NOTIN_FDOM]))
+    >- (
+      gvs [state_ok_def, bvlSemTheory.state_component_equality] \\ rw []
+      \\ simp [bv_ok_def]))
+  >- (
+    rename1 `UpdateThunk` \\ gvs []
+    \\ gvs [bv_ok_def, state_ok_def, bvlSemTheory.state_component_equality]
+    \\ rw []
+    >- (
+      gvs [EVERY_EL] \\ rw []
+      \\ first_x_assum drule \\ rw []
+      \\ CASE_TAC \\ gvs []
+      \\ irule bv_ok_SUBSET_IMP \\ gvs []
+      \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION])
+    >- (
+      simp [FLOOKUP_UPDATE] \\ rw []
+      >- (
+        irule bv_ok_SUBSET_IMP \\ gvs []
+        \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION])
+      \\ first_x_assum $ qspec_then `k` assume_tac \\ gvs []
+      \\ rpt (CASE_TAC \\ gvs [])
+      \\ gvs [EVERY_EL] \\ rw []
+      \\ rpt (first_x_assum drule \\ rw [])
+      \\ irule bv_ok_SUBSET_IMP \\ gvs []
+      \\ goal_assum $ drule_at Any \\ gvs [ABSORPTION]))
 QED
 
 Theorem do_app_ok:
@@ -549,6 +614,36 @@ Theorem evaluate_ok:
       EVERY (bv_ok t.refs) env
 Proof
   recInduct bvlSemTheory.evaluate_ind \\ rpt strip_tac
+  >>~ [‘Force’]
+  >- (
+    gvs [bvlSemTheory.evaluate_def, AllCaseEqs()]
+    >- gvs [state_ok_def]
+    \\ last_x_assum mp_tac \\ impl_tac \\ rw []
+    >- gvs [state_ok_def, bvlSemTheory.dec_clock_def]
+    \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def,
+            oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF]
+    \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs []))
+  >- (
+    gvs [bvlSemTheory.evaluate_def, AllCaseEqs()]
+    >- (
+      gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), state_ok_def]
+      \\ first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs [])
+    \\ rpt (CASE_TAC \\ gvs [])
+    >- (
+      pop_assum mp_tac \\ impl_tac \\ rw []
+      >- gvs [state_ok_def, bvlSemTheory.dec_clock_def]
+      \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def,
+              oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF]
+      \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs []))
+    \\ qpat_x_assum ‘_ ⇒ _’ mp_tac \\ impl_tac \\ rw []
+    >- gvs [state_ok_def, bvlSemTheory.dec_clock_def]
+    \\ gvs [find_code_def, AllCaseEqs(), EVERY_EL, state_ok_def,
+            oneline bvlSemTheory.dest_thunk_def, bv_ok_def, FLOOKUP_DEF]
+    \\ rpt (first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs []))
+  >- (
+    gvs [bvlSemTheory.evaluate_def, AllCaseEqs()]
+    \\ rpt (FULL_CASE_TAC \\ gvs [])
+    \\ drule (GEN_ALL evaluate_IMP_bv_ok) \\ rw [])
   \\ fs[bvlSemTheory.evaluate_def] \\ rw [] \\ fs []
   \\ fs [case_eq_thms] \\ rveq \\ fs []
   \\ imp_res_tac evaluate_SING \\ fs[] \\ rveq \\ fs []
@@ -614,6 +709,8 @@ Proof
          \\ FIRST_X_ASSUM MATCH_MP_TAC
          \\ IMP_RES_TAC bvlPropsTheory.evaluate_IMP_LENGTH
          \\ full_simp_tac(srw_ss())[AC ADD_COMM ADD_ASSOC])
+  THEN1 (gvs [] \\ rpt (PURE_CASE_TAC \\ gvs [])
+         \\ gvs [oneline bvlSemTheory.dest_thunk_def, AllCaseEqs(), EL_APPEND])
 QED
 
 val iEval_def = bviSemTheory.evaluate_def;
@@ -741,7 +838,7 @@ Proof
   \\ ‘p ≠ new_p ∧ new_p ∉ FDOM s.refs’ by
     (`∃x. (λptr. ptr NOTIN FDOM (s.refs |+ (p,ARB))) x` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-     \\ drule whileTheory.LEAST_INTRO \\ fs [])
+     \\ drule WhileTheory.LEAST_INTRO \\ fs [])
   \\ fs []
   \\ simp [Abbr‘s1’,FLOOKUP_UPDATE,Abbr‘new_refs’,inc_clock_def]
   \\ disch_then $ qspecl_then [‘T’,‘T’,‘LENGTH ls’] mp_tac
@@ -1174,6 +1271,11 @@ Proof
     \\ simp[iEval_append,iEval_def,compile_int_thm]
     \\ BasicProvers.EVERY_CASE_TAC
     \\ full_simp_tac(srw_ss())[iEval_def,compile_int_thm])
+  >>~ [‘dest_thunk’]
+  >- gvs [AllCaseEqs()]
+  >- (
+    rpt (PURE_CASE_TAC \\ gvs [])
+    \\ unabbrev_all_tac \\ gvs [EL_APPEND])
   \\ full_simp_tac(srw_ss())[iEval_def]
   \\ TRY (FIRST_X_ASSUM (MP_TAC o Q.SPECL [`n`,`vs`]) \\ full_simp_tac(srw_ss())[] \\ NO_TAC)
   \\ FIRST_X_ASSUM (MP_TAC o Q.SPECL [`n2`]) \\ full_simp_tac(srw_ss())[]
@@ -1269,6 +1371,7 @@ Theorem do_app_adjust[local]:
   (∀flag. op ≠ MemOp (RefByte flag)) ∧ (op ≠ MemOp RefArray) ∧
   (∀n. op ≠ GlobOp (Global n)) ∧ (∀n. op ≠ GlobOp (SetGlobal n)) ∧ (op ≠ GlobOp AllocGlobal) ∧
   op ≠ Install /\
+  (∀t. op ≠ ThunkOp t) ∧
   (∀n. op ≠ BlockOp (FromList n)) ∧ (op ≠ MemOp FromListByte) ∧
   (op ≠ MemOp ToListByte) ∧ (∀c. op ≠ BlockOp (Build c)) ∧ op ≠ MemOp XorByte ∧
   (∀b. op ≠ MemOp (CopyByte b)) ∧ (op ≠ MemOp ConcatByteVec) ∧ (∀n. op ≠ Label n) ∧
@@ -1548,6 +1651,7 @@ Theorem eval_ind_alt:
         P (xs,env,s) ⇒
         P ([Let xs x2],env,s)) ∧
      (∀x1 env s. P ([x1],env,s) ⇒ P ([Raise x1],env,s)) ∧
+     (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧
      (∀x1 x2 env s1.
         (∀v3 s v8 v.
            evaluate ([x1],env,s1) = (v3,s) ∧ v3 = Rerr v8 ∧
@@ -1555,7 +1659,15 @@ Theorem eval_ind_alt:
            P ([x2],v::env,s)) ∧
         (∀xs env. list_size exp_size xs <= exp_size x1 ⇒ P (xs,env,s1)) ⇒
         P ([Handle x1 x2],env,s1)) ∧
-     (∀op xs env s. P (xs,env,s) ⇒ P ([Op op xs],env,s)) ∧
+     (∀force_loc n env s.
+        (∀thunk_v v1 v v' args exp.
+           n < LENGTH env ∧ thunk_v = EL n env ∧
+           dest_thunk thunk_v s.refs = IsThunk v1 v ∧ v1 = NotEvaluated ∧
+           s.clock ≠ 0 ∧
+           find_code (SOME force_loc) [thunk_v; v] s.code = SOME v' ∧
+           v' = (args,exp) ∧ s.clock ≠ 0 ⇒
+           P ([exp],args,dec_clock 1 s)) ⇒
+        P ([Force force_loc n],env,s)) ∧
      (∀x env s.
         (s.clock ≠ 0 ⇒ P ([x],env,dec_clock 1 s)) ⇒
         P ([Tick x],env,s)) ∧
@@ -1661,6 +1773,85 @@ Proof
   \\ metis_tac[INJ_DEF]
 QED
 
+Theorem state_rel_add_thunk:
+   state_rel b s (t:('c,'ffi) bviSem$state) ∧
+   state_ok s ∧
+   pp ∉ FDOM s.refs ∧
+   qq ∉ FDOM t.refs ⇒
+   state_rel ((pp =+ qq) b)
+     (s with refs := s.refs |+ (pp,Thunk m v))
+     (t with refs := t.refs |+ (qq,Thunk m (adjust_bv ((pp =+ qq) b) v)))
+Proof
+  strip_tac
+  \\ fs [state_rel_def, FLOOKUP_UPDATE]
+  \\ conj_tac >- (match_mp_tac INJ_EXTEND \\ fs [])
+  \\ conj_tac >- (
+    fs [APPLY_UPDATE_THM]
+    \\ gen_tac
+    \\ IF_CASES_TAC \\ fs[]
+    \\ qpat_x_assum `∀k. option_CASE (FLOOKUP s.refs k) _ _`
+         $ qspec_then `k` mp_tac
+    \\ TOP_CASE_TAC \\ simp []
+    \\ `qq ≠ b k`
+      by (pop_assum mp_tac \\ rw [FLOOKUP_DEF] \\ metis_tac [INJ_DEF])
+    \\ simp[]
+    \\ TOP_CASE_TAC \\ rw [MAP_EQ_f]
+    \\ match_mp_tac (bv_ok_IMP_adjust_bv_eq |> GEN_ALL)
+    \\ qexists_tac `s.refs`
+    \\ fs [state_ok_def]
+    \\ first_x_assum$ qspec_then `k` mp_tac
+    \\ simp [EVERY_MEM]
+    \\ rw [APPLY_UPDATE_THM]
+    \\ metis_tac [])
+  \\ simp [APPLY_UPDATE_THM]
+  \\ gen_tac \\ strip_tac
+  \\ `qq ≠ p` by (
+    fs []
+    \\ `p ∈ FDOM t.refs` by fs [FLOOKUP_DEF]
+    \\ metis_tac [])
+  \\ fs [] \\ conj_tac >- rw []
+  \\ simp [APPLY_UPDATE_THM]
+  \\ qexists `z` \\ simp [MAP_EQ_f]
+  \\ Cases \\ rw [miscTheory.the_def]
+  \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq)
+  \\ qexists `s.refs`
+  \\ simp [APPLY_UPDATE_THM]
+  \\ fs [state_ok_def, EVERY_MEM]
+  \\ res_tac \\ fs []
+  \\ rw []
+  \\ metis_tac [INJ_DEF]
+QED
+
+Theorem state_rel_update_thunk:
+   state_rel b s (t:('c,'ffi) bviSem$state) ∧
+   state_ok s ∧
+   ptr ∈ FDOM s.refs ⇒
+   state_rel b
+     (s with refs := s.refs |+ (ptr,Thunk m v))
+     (t with refs := t.refs |+ (b ptr,Thunk m (adjust_bv b v)))
+Proof
+  rw []
+  \\ gvs [state_rel_def] \\ rw [] \\ gvs []
+  >- (
+    gvs [INJ_DEF]
+    \\ rw []
+    \\ ntac 2 (last_x_assum drule \\ strip_tac) \\ gvs [])
+  >- (
+    gvs [FLOOKUP_UPDATE] \\ rw []
+    \\ last_x_assum $ qspec_then `k` assume_tac \\ gvs []
+    \\ ntac 2 (CASE_TAC \\ gvs [])
+    \\ gvs [INJ_DEF, FLOOKUP_DEF])
+  >- metis_tac []
+  >- (
+    gvs [FLOOKUP_UPDATE] \\ rw []
+    >- (
+      gvs [INJ_DEF]
+      \\ last_x_assum drule \\ strip_tac
+      \\ qpat_x_assum `∀x. b ptr ≠ b _ ∨ _`
+           $ qspec_then `ptr` assume_tac \\ gvs [])
+    >- metis_tac [])
+QED
+
 val iEval_bVarBound_extra = prove(
   ``∀n xs n vs s env d.
      bVarBound (LENGTH vs) xs ∧ handle_ok xs /\ d = FST (compile_exps n xs) ⇒
@@ -1892,7 +2083,7 @@ Proof
 QED
 
 Theorem compile_inc_next:
-   compile_inc next1 prog1 = (next2,prog2) ==>
+   bvl_to_bvi$compile_inc next1 prog1 = (next2,prog2) ==>
     next1 <= next2
 Proof
   rw [] \\ drule compile_inc_lemma \\ rw []
@@ -1981,6 +2172,11 @@ Proof
        (fs[compile_op_def]
         \\ qexists_tac`c` \\ simp[] \\ rw []
         \\ fs [evaluate_def])
+      \\ Cases_on `op = ThunkOp ForceThunk`
+      >- (
+        gvs [compile_op_def]
+        \\ qexists `c` \\ gvs []
+        \\ gvs [evaluate_def])
       \\ Cases_on`op = MemOp (CopyByte T)`
       >- (note_tac "Op: CopyByte" \\
         fs[compile_op_def]
@@ -1993,6 +2189,8 @@ Proof
       \\ imp_res_tac compile_exps_LENGTH
       \\ fs [NULL_EQ,LENGTH_NIL]
       \\ Cases_on `xs` \\ fs [bviSemTheory.evaluate_def])
+    \\ Cases_on ‘op = ThunkOp ForceThunk’
+    >- gvs [bvlSemTheory.do_app_def, AllCaseEqs()]
     \\ REPEAT STRIP_TAC \\ Cases_on `do_app op (REVERSE a) s5`
     \\ full_simp_tac(srw_ss())[]
     \\ TRY(
@@ -2142,6 +2340,74 @@ Proof
       \\ fs [names_ok_def]
       \\ qpat_x_assum `!n k. _` (qspec_then `0` mp_tac) \\ fs []
       \\ fs [EVERY_MEM,FORALL_PROD] \\ metis_tac[])
+    \\ Cases_on `∃m. op = ThunkOp (AllocThunk m)` >- (
+      rw [] \\ gvs []
+      \\ gvs [compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS]
+      \\ gvs [do_app_def, do_app_aux_def, AllCaseEqs(), PULL_EXISTS]
+      \\ qabbrev_tac `b3 = ((LEAST ptr. ptr ∉ FDOM s5.refs) =+
+           (LEAST ptr. ptr ∉ FDOM (bvi_to_bvl t2).refs)) b2`
+      \\ qexistsl [`b3`, `c`] \\ gvs []
+      \\ qabbrev_tac `x = (LEAST ptr. ptr ∉ FDOM s5.refs)`
+      \\ qabbrev_tac `y = LEAST ptr. ptr ∉ FDOM (bvi_to_bvl t2).refs`
+      \\ gvs []
+      \\ `x ∉ FDOM s5.refs` by (
+        `∃p. (\ptr. ptr ∉ FDOM s5.refs) p` by
+          (rw [] \\ metis_tac [NUM_NOT_IN_FDOM])
+        \\ imp_res_tac WhileTheory.LEAST_INTRO \\ gvs [])
+      \\ `y ∉ FDOM t2.refs` by (
+        `∃p. (\ptr. ptr ∉ FDOM t2.refs) p` by
+          (rw [] \\ metis_tac [NUM_NOT_IN_FDOM])
+        \\ imp_res_tac WhileTheory.LEAST_INTRO \\ gvs [])
+      \\ gvs []
+      \\ gvs [bvlSemTheory.do_app_def, AllCaseEqs(), PULL_EXISTS]
+      \\ rw [adjust_bv_def]
+      \\ `MAP (adjust_bv b3) env = MAP (adjust_bv b2) env` by (
+        gvs [MAP_EQ_f] \\ rpt strip_tac
+        \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq)
+        \\ qexists_tac `s5.refs`
+        \\ gvs [EVERY_MEM] \\ res_tac
+        \\ imp_res_tac evaluate_refs_SUBSET
+        \\ rpt strip_tac >- metis_tac [bv_ok_SUBSET_IMP]
+        \\ qunabbrev_tac `b3` \\ gvs [APPLY_UPDATE_THM]
+        \\ rw [] \\ gvs [])
+      \\ `adjust_bv b2 v = adjust_bv b3 v` by (
+        match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq)
+        \\ qexists `s5.refs`
+        \\ imp_res_tac evaluate_ok \\ gvs []
+        \\ qunabbrev_tac `b3` \\ gvs [APPLY_UPDATE_THM]
+        \\ rw [] \\ gvs [])
+      \\ gvs []
+      \\ conj_tac >- (qunabbrev_tac `b3` \\ rw [])
+      \\ reverse conj_tac >- (
+        rpt strip_tac \\ unabbrev_all_tac
+        \\ gvs [APPLY_UPDATE_THM] \\ rw []
+        \\ imp_res_tac evaluate_refs_SUBSET
+        \\ gvs [SUBSET_DEF])
+      \\ gvs [bvl_to_bvi_def, bvi_to_bvl_def]
+      \\ qmatch_goalsub_abbrev_tac `state_rel _ _ tt`
+      \\ `tt = t2 with refs := t2.refs |+ (b3 x,Thunk m (adjust_bv b2 v))` by (
+        unabbrev_all_tac \\ gvs [state_component_equality])
+      \\ simp [Abbr `tt`, Abbr `b3`]
+      \\ irule state_rel_add_thunk \\ gvs []
+      \\ imp_res_tac evaluate_ok)
+    \\ Cases_on `∃m. op = ThunkOp (UpdateThunk m)` \\ gvs [] >- (
+      rw [] \\ gvs []
+      \\ gvs [compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS]
+      \\ gvs [do_app_def, do_app_aux_def, AllCaseEqs(), PULL_EXISTS]
+      \\ goal_assum drule
+      \\ gvs [bvlSemTheory.do_app_def, AllCaseEqs(), PULL_EXISTS]
+      \\ Cases_on `a` \\ gvs [adjust_bv_def]
+      \\ drule_all state_rel_FLOOKUP_Thunk \\ rw []
+      \\ simp [bvl_to_bvi_def, bvi_to_bvl_def]
+      \\ qmatch_goalsub_abbrev_tac `state_rel _ _ tt`
+      \\ `tt = t2 with refs := t2.refs |+ (b2 ptr,Thunk m (adjust_bv b2 h))` by (
+        unabbrev_all_tac \\ gvs [state_component_equality])
+      \\ qunabbrev_tac `tt` \\ gvs []
+      \\ irule state_rel_update_thunk \\ gvs []
+      \\ imp_res_tac evaluate_ok \\ gvs [FLOOKUP_DEF])
+    \\ `∀thunk_op. op ≠ ThunkOp thunk_op` by (
+      qx_gen_tac `t` \\ Cases_on `t` \\ gvs [])
+    \\ gvs []
     \\ Cases_on `?i. op = IntOp (Const i)` \\ full_simp_tac(srw_ss())[] THEN1
      (note_tac "Op: Const" \\ CONV_TAC SWAP_EXISTS_CONV \\ Q.EXISTS_TAC `b2`
       \\ CONV_TAC SWAP_EXISTS_CONV \\ Q.EXISTS_TAC `c`
@@ -2241,12 +2507,12 @@ Proof
       \\ `~(x IN FDOM s5.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
         \\ REV_FULL_SIMP_TAC std_ss [])
       \\ `~(y IN FDOM t2.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO
         \\ full_simp_tac(srw_ss())[bvi_to_bvl_def]
         \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def])
       \\ full_simp_tac(srw_ss())[]
@@ -2345,12 +2611,12 @@ Proof
       \\ `~(x IN FDOM s5.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
         \\ REV_FULL_SIMP_TAC std_ss [])
       \\ `~(y IN FDOM t2.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO
         \\ full_simp_tac(srw_ss())[bvi_to_bvl_def]
         \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def])
       \\ full_simp_tac(srw_ss())[]
@@ -2439,12 +2705,12 @@ Proof
       \\ `~(x IN FDOM s5.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM s5.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO \\ full_simp_tac(srw_ss())[]
         \\ REV_FULL_SIMP_TAC std_ss [])
       \\ `~(y IN FDOM t2.refs)` by
        (`?p. (\ptr. ptr NOTIN FDOM t2.refs) p` by
           (SIMP_TAC std_ss [] \\ METIS_TAC [NUM_NOT_IN_FDOM])
-        \\ IMP_RES_TAC whileTheory.LEAST_INTRO
+        \\ IMP_RES_TAC WhileTheory.LEAST_INTRO
         \\ full_simp_tac(srw_ss())[bvi_to_bvl_def]
         \\ REV_FULL_SIMP_TAC (srw_ss()) [bvi_to_bvl_def])
       \\ full_simp_tac(srw_ss())[]
@@ -2887,7 +3153,8 @@ Proof
         \\ simp[MAP_EQ_f] \\ rw[] \\ fs[EVERY_MEM]
         \\ match_mp_tac (GEN_ALL bv_ok_IMP_adjust_bv_eq) \\ qexists_tac `s5.refs`
         \\ simp[APPLY_UPDATE_THM] \\ rw[]
-        \\ fs[Abbr`a`,LEAST_NOTIN_FDOM] )
+        >- fs[Abbr`a`,LEAST_NOTIN_FDOM]
+        >- fs[Abbr`a'`,LEAST_NOTIN_FDOM])
       \\ simp[FLOOKUP_UPDATE,APPLY_UPDATE_THM]
       \\ ntac 2 strip_tac
       \\ first_x_assum drule
@@ -3590,6 +3857,60 @@ Proof
       \\ IMP_RES_TAC evaluate_ok \\ full_simp_tac(srw_ss())[]
       \\ REV_FULL_SIMP_TAC std_ss []
       \\ full_simp_tac(srw_ss())[EVERY_MEM] \\ RES_TAC))
+  THEN1 (* Force *)
+   (note_tac "Force"
+    \\ gvs [AllCaseEqs()]
+    >- (
+      last_x_assum kall_tac
+      \\ gvs [evaluate_def, EL_MAP, AllCaseEqs(), PULL_EXISTS,
+              oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def,
+              adjust_bv_def]
+      \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [inc_clock_def]
+      \\ qexists ‘0’ \\ gvs [state_rel_def])
+    >- (
+      gvs [evaluate_def, EL_MAP, AllCaseEqs(), PULL_EXISTS,
+           oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def,
+           adjust_bv_def]
+      \\ drule_all state_rel_FLOOKUP_Thunk \\ rw [] \\ gvs []
+      \\ goal_assum drule \\ gvs [inc_clock_def]
+      \\ qexistsl [‘t1’, ‘0’] \\ gvs [state_rel_def, state_component_equality]
+      \\ gvs [find_code_def, AllCaseEqs()]
+      \\ first_x_assum drule \\ rw [] \\ gvs []
+      \\ pairarg_tac \\ gvs [])
+    >- (
+      gvs [oneline bvlSemTheory.dest_thunk_def, oneline dest_thunk_def,
+           AllCaseEqs()]
+      \\ ‘state_rel b1 (dec_clock 1 s) (dec_clock 1 t1)’
+        by gvs [state_rel_def, dec_clock_def, bvlSemTheory.dec_clock_def]
+      \\ last_x_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs []
+      \\ gvs [find_code_def, AllCaseEqs(), bv_ok_def]
+      \\ pop_assum kall_tac
+      \\ qpat_x_assum ‘state_rel _ _ _’ mp_tac
+      \\ rw [Once state_rel_def]
+      \\ first_x_assum drule \\ rw []
+      \\ pairarg_tac \\ gvs []
+      \\ first_x_assum drule \\ gvs []
+      \\ impl_tac \\ rw []
+      >- gvs [state_ok_def, bvlSemTheory.dec_clock_def]
+      >- gvs [FLOOKUP_DEF]
+      >- (
+        qpat_x_assum ‘state_ok _’ mp_tac
+        \\ rw [state_ok_def]
+        \\ first_x_assum $ qspec_then ‘ptr’ assume_tac \\ gvs [])
+      \\ gvs [adjust_bv_def, inc_clock_def, dec_clock_def]
+      \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs []
+      \\ simp [evaluate_def, EL_MAP, adjust_bv_def, dest_thunk_def] \\ gvs []
+      \\ last_x_assum $ qspec_then ‘ptr’ assume_tac
+      \\ gvs [find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def]
+      \\ imp_res_tac compile_exps_SING \\ gvs []
+      \\ imp_res_tac bvi_letProofTheory.evaluate_compile_exp \\ gvs []
+      \\ goal_assum $ drule_at (Pat ‘evaluate _ = _’) \\ gvs []
+      \\ gvs [MAP_EQ_f] \\ rw []
+      \\ irule (GEN_ALL bv_ok_IMP_adjust_bv_eq)
+      \\ qexists ‘s.refs’ \\ gvs []
+      \\ imp_res_tac evaluate_refs_SUBSET \\ gvs [dec_clock_def]
+      \\ imp_res_tac bv_ok_SUBSET_IMP \\ gvs [EVERY_MEM]))
   THEN1 (* Tick *)
    (note_tac "Tick" \\
     `?c1 aux1 n1. compile_exps n [x] = (c1,aux1,n1)` by METIS_TAC [PAIR]
diff --git a/compiler/backend/proofs/clos_annotateProofScript.sml b/compiler/backend/proofs/clos_annotateProofScript.sml
index 9409976d7b..85d48311b2 100644
--- a/compiler/backend/proofs/clos_annotateProofScript.sml
+++ b/compiler/backend/proofs/clos_annotateProofScript.sml
@@ -237,6 +237,12 @@ Proof
   \\ fs [rich_listTheory.EL_APPEND2]
 QED
 
+Definition opt_rel_def[simp]:
+  opt_rel f NONE NONE = T /\
+  opt_rel f (SOME x) (SOME y) = f x y /\
+  opt_rel f _ _ = F
+End
+
 Definition state_rel_def:
   state_rel (s:('c,'ffi) closSem$state) (t:('c,'ffi) closSem$state) <=>
     (s.clock = t.clock) /\
@@ -344,6 +350,10 @@ val do_app_lemma = prove(
    (`ref_rel v_rel (s.refs ' ptr) (t.refs ' ptr)` by fs []
     \\ rpt (qpat_x_assum `!x. _` kall_tac) \\ rfs []
     \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
+  THEN1
+   (`ref_rel v_rel (s.refs ' ptr) (t.refs ' ptr)` by fs []
+    \\ rpt (qpat_x_assum `!x. _` kall_tac) \\ rfs []
+    \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
   \\ rfs [] \\ fs [FAPPLY_FUPDATE_THM] \\ rveq
   \\ fs [ref_rel_def] \\ rw []);
 
@@ -578,6 +588,42 @@ val code_tac =
           EVERY_MAP,EVERY_GENLIST,shift_seq_def]
     \\ fs[every_Fn_vs_NONE_EVERY_MAP,o_DEF];
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel (ref_rel v_rel) r1 r2) ∧
+  (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel (ref_rel v_rel) r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality state_rel_clocks_eqs:
+  state_rel s t ⇒ s.clock = t.clock
+Proof
+  gvs [state_rel_def]
+QED
+
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL v_rel vs ys ⇒
+    (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+       ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ rpt (
+      imp_res_tac state_rel_opt_rel_refs \\ rw []
+      \\ gvs [oneline opt_rel_def]
+      \\ FULL_CASE_TAC \\ gvs [])
+    \\ gvs [state_rel_def, FLOOKUP_UPDATE] \\ rw []
+    \\ simp [ref_rel_def, Once v_rel_cases]
+    \\ metis_tac [])
+QED
+
 Triviality shift_correct:
   (!xs env (s1:('c,'ffi) closSem$state) env' t1 res s2 m l i.
      (evaluate (xs,env,s1) = (res,s2)) /\ res <> Rerr (Rabort Rtype_error) /\
@@ -832,6 +878,24 @@ Proof
       \\ fs[shift_LENGTH_LEMMA, LENGTH_FST_alt_free]
       \\ Q.ISPEC_THEN`vs'`FULL_STRUCT_CASES_TAC SNOC_CASES \\ fs[]
       \\ fs[LIST_REL_SNOC] )
+    >- ( (* ThunkOp ThunkForce case *)
+      gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      \\ rgs [Once v_rel_cases]
+      \\ imp_res_tac (cj 1 state_rel_opt_rel_refs)
+      \\ qpat_x_assum `opt_rel (ref_rel v_rel) _ _` mp_tac
+      \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS]
+      \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS]
+      \\ last_x_assum $ qspecl_then [`[b]`, `t2`, `0`, `1`, `i`] mp_tac
+      \\ (
+        gvs [] \\ impl_tac
+        >- (
+          gvs [AppUnit_def, alt_fv, alt_fv1_thm, SUBSET_DEF, IN_DEF, env_ok_def,
+               dec_clock_def]
+          \\ code_tac
+          \\ gvs [state_rel_def])
+        \\ rw [AppUnit_def, alt_free_def, shift_def, get_var_def]
+        \\ goal_assum drule \\ rw []
+        \\ drule_all rel_update_thunk \\ rw []))
     \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] >>
     last_x_assum mp_tac >>
     reverse BasicProvers.CASE_TAC >- (
diff --git a/compiler/backend/proofs/clos_callProofScript.sml b/compiler/backend/proofs/clos_callProofScript.sml
index c479c8ba62..db9d848c09 100644
--- a/compiler/backend/proofs/clos_callProofScript.sml
+++ b/compiler/backend/proofs/clos_callProofScript.sml
@@ -73,7 +73,8 @@ val _ = export_rewrites["is_Recclosure_def"];
 
 Definition every_refv_def:
   (every_refv P (ValueArray vs) ⇔ EVERY P vs) ∧
-   (every_refv P _ ⇔ T)
+  (every_refv P (Thunk m v) ⇔ P v) ∧
+  (every_refv P _ ⇔ T)
 End
 val _ = export_rewrites["every_refv_def"];
 
@@ -1885,6 +1886,9 @@ Proof
     \\ Cases_on `op` \\ Cases_on `REVERSE a`
     \\ simp[do_app_def, case_eq_thms, bool_case_eq, pair_case_eq, CaseEq"ffi$ffi_result"]
     \\ strip_tac \\ rveq \\ fs []
+    \\ TRY (
+      rename [`case v of Evaluated => _ | NotEvaluated => _`]
+      \\ Cases_on `v` \\ gvs [])
     \\ Cases_on`a` \\ fs[] \\ rveq \\ fs[]
     \\ strip_tac \\ fs[v_rel_def, PULL_EXISTS] \\ rveq
     \\ imp_res_tac state_rel_flookup_refs \\ fs[]
@@ -1917,6 +1921,11 @@ Proof
      (res_tac \\ fs []
       \\ qpat_x_assum `!x. _` kall_tac
       \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
+    THEN1
+     (res_tac \\ fs []
+      \\ qpat_x_assum `!x. _` kall_tac
+      \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
+    THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM])
     THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM])
     THEN1 (strip_tac \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM]))
   \\ assume_tac (GEN_ALL simple_val_rel_do_app
@@ -1958,6 +1967,8 @@ Proof
        \\ qspec_tac (`xs`,`xs`) \\ qspec_tac (`ys`,`ys`)
        \\ Induct \\ fs [] \\ Cases_on `xs` \\ simp_tac std_ss [PULL_EXISTS]
        \\ fs [])
+    THEN1
+      (match_mp_tac (FEVERY_STRENGTHEN_THM |> CONJUNCT2) \\ fs [])
     THEN1
       (qpat_x_assum `_ xs ys` mp_tac
        \\ qspec_tac (`ys`,`ys`) \\ qspec_tac (`xs`,`xs`)
@@ -2225,7 +2236,7 @@ Proof
     first_x_assum (fn t => mp_tac t \\ match_mp_tac fmap_rel_mono)
     \\ rw []
     \\ Cases_on `x` \\ Cases_on `y` \\ fs [ref_rel_def]
-    \\ first_x_assum (fn t => mp_tac t \\ match_mp_tac LIST_REL_mono)
+    \\ TRY (first_x_assum (fn t => mp_tac t \\ match_mp_tac LIST_REL_mono))
     \\ rw []
     \\ drule_then irule (GEN_ALL v_rel_SUBMAP_subg)
     \\ fs [SUBMAP_FUNION_ID, DISJOINT_SYM]
@@ -2394,6 +2405,17 @@ Proof
   \\ EVERY_CASE_TAC \\ rw [] \\ fs []
 QED
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel g l s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧
+          OPTREL (ref_rel (v_rel g l s2.code)) r1 r2) ∧
+  (state_rel g l s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧
+          OPTREL (ref_rel (v_rel g l s2.code)) r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, FLOOKUP_DEF, fmap_rel_def] \\ rw []
+QED
+
 (* compiler correctness *)
 
 val t0 = ``t0:('c,'ffi) closSem$state``;
@@ -2987,7 +3009,7 @@ Proof
     \\ strip_tac
     \\ reverse (Cases_on `q`) \\ fs []
     THEN1 (rw [] \\ qexists_tac `ck` \\ asm_exists_tac \\ fs [])
-    \\ reverse (Cases_on `op = Install`) THEN1
+    \\ reverse (Cases_on `op = Install ∨ op = ThunkOp ForceThunk`) THEN1
      (fs [] \\ reverse (Cases_on `do_app op (REVERSE a) r`) \\ fs []
       THEN1
        (rveq \\ fs []
@@ -3008,121 +3030,214 @@ Proof
       \\ strip_tac \\ pop_assum mp_tac \\ fs []
       \\ imp_res_tac do_app_const \\ fs []
       \\ strip_tac \\ asm_exists_tac \\ fs [])
-    \\ rveq \\ fs []
-    \\ fs [pair_case_eq]
-    \\ rveq \\ fs []
-    \\ qpat_x_assum `do_install _ r = _` mp_tac
-    \\ Cases_on `v = Rerr (Rabort Rtype_error)` \\ fs []
-    \\ simp [Once do_install_def]
-    \\ simp [option_case_eq,list_case_eq,PULL_EXISTS,pair_case_eq,bool_case_eq]
-    \\ pairarg_tac
-    \\ fs [SWAP_REVERSE_SYM,
-       Q.INST [`b`|->`DISJOINT (S1 : 'c set) S2 /\ P`] bool_case_eq,
-       option_case_eq,pair_case_eq,PULL_EXISTS]
-    \\ rpt gen_tac \\ strip_tac \\ rveq \\ fs []
-    \\ `aux = []` by (drule (Q.SPEC `0` code_inv_k) \\ fs [syntax_ok_def])
-    \\ Cases_on `r.clock = 0`
-    THEN1
-     (rpt strip_tac \\ fs [] \\ rveq \\ fs []
+    \\ rw []
+    >~ [`Install`] >- (
+      rveq \\ fs []
+      \\ fs [pair_case_eq]
+      \\ rveq \\ fs []
+      \\ qpat_x_assum `do_install _ r = _` mp_tac
+      \\ Cases_on `v = Rerr (Rabort Rtype_error)` \\ fs []
+      \\ simp [Once do_install_def]
+      \\ simp [option_case_eq,list_case_eq,PULL_EXISTS,pair_case_eq,bool_case_eq]
+      \\ pairarg_tac
+      \\ fs [SWAP_REVERSE_SYM,
+         Q.INST [`b`|->`DISJOINT (S1 : 'c set) S2 /\ P`] bool_case_eq,
+         option_case_eq,pair_case_eq,PULL_EXISTS]
+      \\ rpt gen_tac \\ strip_tac \\ rveq \\ fs []
+      \\ `aux = []` by (drule (Q.SPEC `0` code_inv_k) \\ fs [syntax_ok_def])
+      \\ Cases_on `r.clock = 0`
+      THEN1
+       (rpt strip_tac \\ fs [] \\ rveq \\ fs []
+        \\ imp_res_tac v_to_bytes_thm
+        \\ imp_res_tac v_to_words_thm
+        \\ fs [bool_case_eq] \\ fs []
+        \\ fs [] \\ rveq \\ fs []
+        \\ `?cfg' progs. t.compile_oracle 0 = (cfg',progs)` by metis_tac [PAIR]
+        \\ drule (GEN_ALL code_rel_state_rel_install)
+        \\ rpt (disch_then drule)
+        \\ simp []
+        \\ strip_tac
+        \\ fs [shift_seq_def]
+        \\ `exp1 <> []` by
+          (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs [])
+        \\ qabbrev_tac `t1 = t with
+            <|clock := 0; compile_oracle := shift_seq 1 t.compile_oracle;
+              code := t.code |++ SND progs|>`
+        \\ qexists_tac `ck`
+        \\ qexists_tac `t1`
+        \\ qunabbrev_tac `t1` \\ fs [FUPDATE_LIST, shift_seq_def]
+        \\ asm_exists_tac
+        \\ fs []
+        \\ conj_tac THEN1
+         (`wfv_state g2 l2 t.code
+             (r with
+              <| clock := 0; compile_oracle := shift_seq 1 r.compile_oracle;
+                 code := r.code |>)` by fs [wfv_state_def,shift_seq_def]
+          \\ fs [shift_seq_def,FUPDATE_LIST]
+          \\ match_mp_tac (GEN_ALL wfv_state_subg)
+          \\ asm_exists_tac
+          \\ fs [GSYM FUPDATE_LIST])
+        \\ fs [do_install_def]
+        \\ fs [shift_seq_def]
+        \\ `t.clock = 0` by fs [state_rel_def] \\ fs []
+        \\ rfs [state_rel_def,FUPDATE_LIST]
+        \\ fs [code_inv_def]
+        \\ simp [state_co_def]
+        \\ metis_tac [subg_trans, SUBSET_TRANS])
+      \\ fs [bool_case_eq] \\ fs []
+      \\ rveq \\ fs [FUPDATE_LIST,shift_seq_def]
       \\ imp_res_tac v_to_bytes_thm
       \\ imp_res_tac v_to_words_thm
-      \\ fs [bool_case_eq] \\ fs []
       \\ fs [] \\ rveq \\ fs []
-      \\ `?cfg' progs. t.compile_oracle 0 = (cfg',progs)` by metis_tac [PAIR]
+      \\ ntac 2 (qpat_x_assum `!x._` kall_tac)
+      \\ `?x23 x34. t.compile_oracle 0 = (x23,x34)` by metis_tac [PAIR]
       \\ drule (GEN_ALL code_rel_state_rel_install)
-      \\ rpt (disch_then drule)
-      \\ simp []
-      \\ strip_tac
       \\ fs [shift_seq_def]
+      \\ rpt (disch_then drule) \\ strip_tac
+      \\ `t.clock <> 0` by fs [state_rel_def] \\ fs []
+      \\ fs [state_rel_def,FUPDATE_LIST]
+      \\ Cases_on `evaluate
+                (exps,[],
+                 r with
+                 <|clock := t.clock − 1;
+                   compile_oracle := (λi. r.compile_oracle (i + 1));
+                   code := FEMPTY|>)` \\ fs [] \\ rveq \\ fs []
+      \\ `q ≠ Rerr (Rabort Rtype_error)` by (every_case_tac \\ fs [] \\ rveq \\ fs [])
+      \\ fs []
+      \\ first_x_assum drule
+      \\ disch_then (qspecl_then [`[]`,`t with
+            <|clock := t.clock − 1;
+              compile_oracle := (λi. t.compile_oracle (i + 1));
+              code := FOLDL $|+ t.code aux1|>`, `l2'`, `g2'`] mp_tac)
+      \\ simp [] \\ rfs []
       \\ `exp1 <> []` by
         (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs [])
-      \\ qabbrev_tac `t1 = t with
-          <|clock := 0; compile_oracle := shift_seq 1 t.compile_oracle;
-            code := t.code |++ SND progs|>`
-      \\ qexists_tac `ck`
-      \\ qexists_tac `t1`
-      \\ qunabbrev_tac `t1` \\ fs [FUPDATE_LIST, shift_seq_def]
-      \\ asm_exists_tac
+      \\ reverse impl_tac THEN1
+       (strip_tac \\ fs [] \\ rveq \\ fs []
+        \\ qpat_x_assum `_ = (Rval _,t)` assume_tac
+        \\ drule evaluate_add_clock
+        \\ disch_then (qspec_then `ck'` mp_tac) \\ fs [] \\ strip_tac
+        \\ qexists_tac `ck+ck'` \\ fs [] \\ rfs []
+        \\ fs [do_install_def,shift_seq_def,FUPDATE_LIST]
+        \\ asm_exists_pat_tac `result_rel (LIST_REL _)`
+        \\ TOP_CASE_TAC \\ fs []
+        \\ FULL_CASE_TAC \\ fs [] \\ rveq \\ fs []
+        \\ imp_res_tac evaluate_IMP_LENGTH
+        \\ fs [LENGTH_EQ_NUM_compute]
+        \\ rveq \\ fs []
+        \\ rename [`EVERY _ aa`]
+        \\ `aa = [] ∨ ∃x l. aa = SNOC x l` by metis_tac [SNOC_CASES]
+        THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC]
+        \\ `a = [] ∨ ∃x l. a = SNOC x l` by metis_tac [SNOC_CASES]
+        THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC]
+        \\ fs [LIST_REL_SNOC]
+        \\ metis_tac [subg_trans, SUBSET_TRANS])
+      \\ simp [env_rel_def] \\ rveq \\ fs []
+      \\ IMP_RES_THEN MP_TAC (Q.SPEC `0` code_inv_k)
+      \\ simp [syntax_ok_def]
+      \\ rpt disch_tac
       \\ fs []
       \\ conj_tac THEN1
-       (`wfv_state g2 l2 t.code
-           (r with
-            <| clock := 0; compile_oracle := shift_seq 1 r.compile_oracle;
-               code := r.code |>)` by fs [wfv_state_def,shift_seq_def]
-        \\ fs [shift_seq_def,FUPDATE_LIST]
-        \\ match_mp_tac (GEN_ALL wfv_state_subg)
-        \\ asm_exists_tac
-        \\ fs [GSYM FUPDATE_LIST])
-      \\ fs [do_install_def]
-      \\ fs [shift_seq_def]
-      \\ `t.clock = 0` by fs [state_rel_def] \\ fs []
-      \\ rfs [state_rel_def,FUPDATE_LIST]
-      \\ fs [code_inv_def]
-      \\ simp [state_co_def]
-      \\ metis_tac [subg_trans, SUBSET_TRANS])
-    \\ fs [bool_case_eq] \\ fs []
-    \\ rveq \\ fs [FUPDATE_LIST,shift_seq_def]
-    \\ imp_res_tac v_to_bytes_thm
-    \\ imp_res_tac v_to_words_thm
-    \\ fs [] \\ rveq \\ fs []
-    \\ ntac 2 (qpat_x_assum `!x._` kall_tac)
-    \\ `?x23 x34. t.compile_oracle 0 = (x23,x34)` by metis_tac [PAIR]
-    \\ drule (GEN_ALL code_rel_state_rel_install)
-    \\ fs [shift_seq_def]
-    \\ rpt (disch_then drule) \\ strip_tac
-    \\ `t.clock <> 0` by fs [state_rel_def] \\ fs []
-    \\ fs [state_rel_def,FUPDATE_LIST]
-    \\ Cases_on `evaluate
-              (exps,[],
-               r with
-               <|clock := t.clock − 1;
-                 compile_oracle := (λi. r.compile_oracle (i + 1));
-                 code := FEMPTY|>)` \\ fs [] \\ rveq \\ fs []
-    \\ `q ≠ Rerr (Rabort Rtype_error)` by (every_case_tac \\ fs [] \\ rveq \\ fs [])
-    \\ fs []
-    \\ first_x_assum drule
-    \\ disch_then (qspecl_then [`[]`,`t with
+       (`wfv_state g2 l2 t.code (r with
           <|clock := t.clock − 1;
-            compile_oracle := (λi. t.compile_oracle (i + 1));
-            code := FOLDL $|+ t.code aux1|>`, `l2'`, `g2'`] mp_tac)
-    \\ simp [] \\ rfs []
-    \\ `exp1 <> []` by
-      (CCONTR_TAC \\ imp_res_tac calls_length \\ fs [] \\ rveq \\ fs [])
-    \\ reverse impl_tac THEN1
-     (strip_tac \\ fs [] \\ rveq \\ fs []
-      \\ qpat_x_assum `_ = (Rval _,t)` assume_tac
-      \\ drule evaluate_add_clock
-      \\ disch_then (qspec_then `ck'` mp_tac) \\ fs [] \\ strip_tac
-      \\ qexists_tac `ck+ck'` \\ fs [] \\ rfs []
-      \\ fs [do_install_def,shift_seq_def,FUPDATE_LIST]
-      \\ asm_exists_pat_tac `result_rel (LIST_REL _)`
-      \\ TOP_CASE_TAC \\ fs []
-      \\ FULL_CASE_TAC \\ fs [] \\ rveq \\ fs []
-      \\ imp_res_tac evaluate_IMP_LENGTH
-      \\ fs [LENGTH_EQ_NUM_compute]
-      \\ rveq \\ fs []
-      \\ rename [`EVERY _ aa`]
-      \\ `aa = [] ∨ ∃x l. aa = SNOC x l` by metis_tac [SNOC_CASES]
-      THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC]
-      \\ `a = [] ∨ ∃x l. a = SNOC x l` by metis_tac [SNOC_CASES]
-      THEN1 fs [] \\ full_simp_tac std_ss [LAST_SNOC] \\ fs [EVERY_SNOC]
-      \\ fs [LIST_REL_SNOC]
-      \\ metis_tac [subg_trans, SUBSET_TRANS])
-    \\ simp [env_rel_def] \\ rveq \\ fs []
-    \\ IMP_RES_THEN MP_TAC (Q.SPEC `0` code_inv_k)
-    \\ simp [syntax_ok_def]
-    \\ rpt disch_tac
-    \\ fs []
-    \\ conj_tac THEN1
-     (`wfv_state g2 l2 t.code (r with
-        <|clock := t.clock − 1;
-          compile_oracle := (λi. r.compile_oracle (i + 1)); code := FEMPTY|>)`
-            by (fs [code_inv_def,wfv_state_def] \\ fs [] \\ rfs [])
-      \\ match_mp_tac (GEN_ALL wfv_state_subg)
-      \\ asm_exists_tac \\ fs [GSYM FUPDATE_LIST])
-    \\ fs [code_inv_def, wfg_subg_refl]
-    \\ rfs []
-    \\ fs [code_includes_def])
+            compile_oracle := (λi. r.compile_oracle (i + 1)); code := FEMPTY|>)`
+              by (fs [code_inv_def,wfv_state_def] \\ fs [] \\ rfs [])
+        \\ match_mp_tac (GEN_ALL wfv_state_subg)
+        \\ asm_exists_tac \\ fs [GSYM FUPDATE_LIST])
+      \\ fs [code_inv_def, wfg_subg_refl]
+      \\ rfs []
+      \\ fs [code_includes_def])
+    >~ [`ThunkOp ForceThunk`] >- (
+      gvs [AllCaseEqs(), PULL_EXISTS]
+      \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      >- (
+        gvs [v_rel_def]
+        \\ rpt (goal_assum drule \\ gvs [])
+        \\ rw [GSYM PULL_EXISTS]
+        >- (
+          gvs [wfv_state_def, FEVERY_ALL_FLOOKUP]
+          \\ first_x_assum drule \\ rw [])
+        \\ goal_assum drule \\ gvs []
+        \\ drule_all state_rel_flookup_refs \\ rw [] \\ gvs [])
+      >- (
+        gvs [v_rel_def]
+        \\ gvs [AppUnit_def, calls_def, code_locs_def]
+        \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs []
+        \\ first_x_assum $ drule_at (Pat `state_rel _ _ _ _`) \\ gvs []
+        \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac
+        \\ impl_tac
+        >- (
+          rw []
+          >- (
+            gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP]
+            \\ first_x_assum drule \\ rw [])
+          >- (irule calls_wfg \\ metis_tac[])
+          >- imp_res_tac subg_trans
+          >- gvs [env_rel_def, dec_clock_def]
+          >- (
+            irule code_includes_SUBMAP
+            \\ goal_assum $ drule_at Any \\ rw []
+            \\ imp_res_tac evaluate_mono \\ gvs []))
+        \\ rw [] \\ gvs []
+        \\ qrefinel [`_`, `t' with refs := refs1`] \\ gvs[]
+        \\ goal_assum drule \\ gvs []
+        \\ `subg g1 g2'` by (imp_res_tac subg_trans \\ gvs []) \\ gvs []
+        \\ `l1 ⊆ l2'` by (imp_res_tac SUBSET_TRANS \\ gvs []) \\ gvs []
+        \\ `wfv_state g2' l2' t'.code (s'' with refs := refs)` by (
+          gvs [wfv_state_def, FEVERY_ALL_FLOOKUP, FLOOKUP_UPDATE] \\ rw []
+          \\ gvs [oneline update_thunk_def, AllCaseEqs()]
+          \\ gvs [store_thunk_def, AllCaseEqs()]
+          \\ gvs [FLOOKUP_UPDATE]
+          \\ Cases_on `ptr = k` \\ gvs []
+          \\ first_x_assum drule \\ gvs []) \\ gvs []
+        \\ qrefinel [`_`, `ck'' + ck`]
+        \\ `∀ck''. evaluate (e1,env2,t0 with clock := ck + ck'' + t0.clock) =
+              (Rval [RefPtr v0 ptr],t with clock := ck'' + t.clock)` by (
+          imp_res_tac evaluate_add_clock \\ gvs [])
+        \\ gvs [PULL_EXISTS]
+        \\ imp_res_tac state_rel_clock \\ gvs [PULL_EXISTS, dec_clock_def]
+        \\ goal_assum drule \\ gvs []
+        \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+        \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+        \\ (
+          gvs [v_rel_def, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+          \\ rpt (
+              drule (GEN_ALL $ cj 1 state_rel_opt_rel_refs)
+              \\ disch_then dxrule \\ rw [OPTREL_def] \\ gvs [])
+          \\ qmatch_goalsub_abbrev_tac `t' with refs := trefs`
+          \\ qexists `trefs` \\ unabbrev_all_tac \\ gvs []
+          \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw []
+          \\ simp [v_rel_def]))
+      >- (
+        gvs [v_rel_def]
+        \\ gvs [AppUnit_def, calls_def, code_locs_def]
+        \\ drule_all_then assume_tac state_rel_flookup_refs \\ gvs []
+        \\ first_x_assum $ drule_at (Pat `state_rel _ _ _ _`) \\ gvs []
+        \\ disch_then $ qspecl_then [`g`, `[b]`] mp_tac
+        \\ impl_tac
+        >- (
+          rw []
+          >- (
+            gvs [dec_clock_def, wfv_state_def, FEVERY_ALL_FLOOKUP]
+            \\ first_x_assum drule \\ rw [])
+          >- (irule calls_wfg \\ metis_tac[])
+          >- imp_res_tac subg_trans
+          >- gvs [env_rel_def, dec_clock_def]
+          >- (
+            irule code_includes_SUBMAP
+            \\ goal_assum $ drule_at Any \\ rw []
+            \\ imp_res_tac evaluate_mono \\ gvs []))
+        \\ rw [] \\ gvs []
+        \\ goal_assum drule \\ gvs []
+        \\ `subg g1 g2'` by (imp_res_tac subg_trans \\ gvs []) \\ gvs []
+        \\ `l1 ⊆ l2'` by (imp_res_tac SUBSET_TRANS \\ gvs []) \\ gvs []
+        \\ qrefine `ck'' + ck`
+        \\ `∀ck''. evaluate (e1,env2,t0 with clock := ck + ck'' + t0.clock) =
+              (Rval [RefPtr v0 ptr],t with clock := ck'' + t.clock)` by (
+          imp_res_tac evaluate_add_clock \\ gvs [])
+        \\ gvs [PULL_EXISTS]
+        \\ imp_res_tac state_rel_clock \\ gvs [PULL_EXISTS, dec_clock_def]
+        \\ goal_assum drule \\ gvs [])))
   (* Fn *)
   \\ conj_tac >- (
     say "Fn"
diff --git a/compiler/backend/proofs/clos_fvsProofScript.sml b/compiler/backend/proofs/clos_fvsProofScript.sml
index 808b6d05a9..327c4db413 100644
--- a/compiler/backend/proofs/clos_fvsProofScript.sml
+++ b/compiler/backend/proofs/clos_fvsProofScript.sml
@@ -98,7 +98,16 @@ Inductive ref_rel:
   (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\
   (!xs ys.
     LIST_REL v_rel xs ys ==>
-    ref_rel (ValueArray xs) (ValueArray ys))
+    ref_rel (ValueArray xs) (ValueArray ys)) /\
+  (!m v w.
+    v_rel v w ==>
+    ref_rel (Thunk m v) (Thunk m w))
+End
+
+Definition opt_rel_def[simp]:
+  opt_rel f NONE NONE = T /\
+  opt_rel f (SOME x) (SOME y) = f x y /\
+  opt_rel f _ _ = F
 End
 
 Definition state_rel_def:
@@ -264,6 +273,50 @@ val do_install_lemma = prove(
             simple_val_rel_def]
   \\ fs [v_rel_cases]);
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧
+  (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality state_rel_clocks_eqs:
+  state_rel s1 s2 ⇒ s1.clock = s2.clock
+Proof
+  rw [state_rel_def, state_component_equality]
+QED
+
+Triviality state_rel_dec_clock:
+  state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2)
+Proof
+  rw [state_rel_def, dec_clock_def, state_component_equality]
+QED
+
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL v_rel vs ys ⇒
+    (update_thunk [RefPtr v ptr] s1.refs vs = NONE ⇒
+       update_thunk [RefPtr v ptr] s2.refs ys = NONE) ∧
+    (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+       ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()]
+    \\ rpt (
+      imp_res_tac state_rel_opt_rel_refs \\ rw []
+      \\ gvs [oneline opt_rel_def]
+      \\ FULL_CASE_TAC \\ gvs []
+      \\ rgs [Once ref_rel_cases])
+    \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw []
+    \\ simp [Once ref_rel_cases])
+QED
+
 (* evaluate level correctness *)
 
 Theorem evaluate_remove_fvs:
@@ -392,7 +445,20 @@ Proof
       \\ fs []
       \\ CCONTR_TAC
       \\ fs [])
-    (* op <> Install *)
+    \\ IF_CASES_TAC \\ rveq \\ fs [] >- ((* Op = ThunkOp ForceThunk *)
+      gvs [AllCaseEqs(), PULL_EXISTS]
+      \\ (
+        gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+        \\ imp_res_tac (cj 1 state_rel_opt_rel_refs)
+        \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac
+        \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs []
+        \\ rgs [Once ref_rel_cases]
+        \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS]
+        \\ imp_res_tac state_rel_dec_clock \\ gvs []
+        \\ last_x_assum drule_all \\ rw [AppUnit_def, remove_fvs_def]
+        \\ goal_assum drule \\ rw []
+        \\ drule_all rel_update_thunk \\ rw []))
+    (* op <> Install ∧ op <> ThunkOp ForceThunk *)
     \\ drule EVERY2_REVERSE \\ disch_tac
     \\ drule (GEN_ALL do_app_lemma)
     \\ disch_then drule
diff --git a/compiler/backend/proofs/clos_interpProofScript.sml b/compiler/backend/proofs/clos_interpProofScript.sml
index 7988cc35f9..b6807b8e78 100644
--- a/compiler/backend/proofs/clos_interpProofScript.sml
+++ b/compiler/backend/proofs/clos_interpProofScript.sml
@@ -727,6 +727,27 @@ Proof
   \\ gvs [AllCaseEqs()]
 QED
 
+Triviality state_rel_refs_clocks_eqs:
+  state_rel s1 s2 ⇒ s1.refs = s2.refs ∧ s1.clock = s2.clock
+Proof
+  rw [state_rel_def, state_component_equality]
+QED
+
+Triviality state_rel_update_thunk:
+  state_rel s1 s2 ⇒
+    update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+      ∃refs2. update_thunk [RefPtr v ptr] s2.refs vs = SOME refs2 ∧
+              state_rel (s1 with refs := refs1) (s2 with refs := refs2)
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [oneline store_thunk_def, AllCaseEqs()]
+    \\ imp_res_tac state_rel_refs_clocks_eqs \\ gvs []
+    \\ gvs [state_rel_def])
+QED
+
 Theorem evaluate_interp_lemma:
   (∀xs (s1:('c,'ffi) closSem$state) env t1 res s2.
      (evaluate (xs,env,s1) = (res,s2)) ∧ res <> Rerr (Rabort Rtype_error) ⇒
@@ -807,7 +828,7 @@ Proof
     \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS]
     \\ first_assum $ drule_at $ Pos $ el 3
     \\ disch_then $ drule_at $ Pos last
-    \\ impl_tac >- (fs [exp_size_def] \\ strip_tac \\ gvs [])
+    \\ impl_tac >- (fs [] \\ strip_tac \\ gvs [])
     \\ strip_tac \\ fs []
     \\ reverse (gvs [CaseEq"result"])
     >- (qexists_tac ‘ck’ \\ fs [])
@@ -816,7 +837,7 @@ Proof
     \\ first_assum $ drule_at $ Pos $ el 3
     \\ disch_then $ drule_at $ Pos last
     \\ imp_res_tac evaluate_clock \\ fs []
-    \\ impl_tac >- (fs [exp_size_def] \\ strip_tac \\ gvs [])
+    \\ impl_tac >- (fs [] \\ strip_tac \\ gvs [])
     \\ strip_tac \\ fs []
     \\ qpat_x_assum ‘evaluate (xs,_) = _’ assume_tac
     \\ drule evaluate_add_clock \\ fs []
@@ -827,9 +848,9 @@ Proof
     \\ first_assum $ drule_at $ Pos $ el 3
     \\ disch_then $ drule_at $ Pos last
     \\ impl_tac >-
-     (fs [exp_size_def]
+     (fs []
       \\ rw [] \\ imp_res_tac evaluate_IMP_LENGTH \\ fs []
-      \\ qsuff_tac ‘LENGTH xs ≤ exp3_size xs’ >- fs []
+      \\ qsuff_tac ‘LENGTH xs ≤ exp3_alt_size xs’ >- fs []
       \\ qid_spec_tac ‘xs’ \\ Induct \\ fs [])
     \\ strip_tac
     \\ qpat_x_assum ‘evaluate (xs,_) = _’ assume_tac
@@ -943,11 +964,13 @@ Proof
   \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS]
   \\ first_assum $ drule_at $ Pos $ el 3
   \\ disch_then $ drule_at $ Pos last
-  \\ impl_tac >- (fs [exp_size_def,dec_clock_def] \\ strip_tac \\ gvs [])
+  \\ impl_tac >- (
+    conj_tac >- (IF_CASES_TAC \\ gvs [])
+    \\ strip_tac \\ gvs [])
   \\ strip_tac
   \\ reverse $ gvs [CaseEq"result"]
   >- (qexists_tac ‘ck’ \\ fs [])
-  \\ Cases_on ‘p ≠ Install’ \\ gvs []
+  \\ Cases_on ‘p ≠ Install ∧ p ≠ ThunkOp ForceThunk’ \\ gvs []
   \\ gvs [evaluate_def,CaseEq"prod",PULL_EXISTS]
   >-
    (qabbrev_tac ‘vr = λv1 v2. v1 = v2:closSem$v’
@@ -971,57 +994,77 @@ Proof
     \\ gvs [Abbr‘vr’] >- (Cases_on ‘err’ \\ gvs [])
     \\ fs [state_rel_def,state_rel_1_def]
     \\ drule_then irule do_app_oHD_globals \\ fs [])
-  \\ rename [‘state_rel s3 t3’]
-  \\ qpat_x_assum ‘do_install _ _ = _’ mp_tac
-  \\ simp [Once do_install_def]
-  \\ simp [AllCaseEqs()] \\ strip_tac \\ gvs []
-  \\ pairarg_tac \\ gvs []
-  \\ gvs [CaseEq"bool"]
-  \\ gvs [CaseEq"option"]
-  \\ gvs [CaseEq"prod"]
-  \\ ‘s3.compile = pure_cc (insert_interp ## I) t3.compile ∧
-      t3.compile_oracle = pure_co (insert_interp ## I) ∘ s3.compile_oracle ∧
-      t3.clock = s3.clock ∧
-      FDOM t3.code = EMPTY ∧ FDOM s3.code = EMPTY’
-        by fs [state_rel_def]
-  \\ ‘insert_interp exps ≠ []’ by (gvs [insert_interp_def] \\ gvs [AllCaseEqs()])
-  \\ gvs [CaseEq"bool"]
-  >-
-   (qexists_tac ‘ck’ \\ fs []
-    \\ simp [do_install_def]
-    \\ fs [pure_co_def,pure_cc_def]
-    \\ fs [o_DEF,shift_seq_def]
-    \\ fs [state_rel_def,FUN_EQ_THM]
-    \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST]))
-  \\ ‘aux = []’ by
-   (fs [state_rel_def,FUN_EQ_THM]
-    \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST]))
-  \\ gvs [SWAP_REVERSE_SYM,CaseEq"prod"]
-  \\ drule_at (Pos $ el 2) evaluate_insert_interp \\ fs [FUPDATE_LIST]
-  \\ disch_then $ qspec_then ‘t3 with
-              <|clock := t3.clock − 1;
-                compile_oracle := shift_seq 1 t3.compile_oracle;
-                code := t3.code |>’ mp_tac
-  \\ impl_tac
-  >-
-   (fs [interp_assum_def] \\ rpt strip_tac
+  >~ [`do_install`] >- (
+    rename [‘state_rel s3 t3’]
+    \\ qpat_x_assum ‘do_install _ _ = _’ mp_tac
+    \\ simp [Once do_install_def]
+    \\ simp [AllCaseEqs()] \\ strip_tac \\ gvs []
+    \\ pairarg_tac \\ gvs []
+    \\ gvs [CaseEq"bool"]
+    \\ gvs [CaseEq"option"]
+    \\ gvs [CaseEq"prod"]
+    \\ ‘s3.compile = pure_cc (insert_interp ## I) t3.compile ∧
+        t3.compile_oracle = pure_co (insert_interp ## I) ∘ s3.compile_oracle ∧
+        t3.clock = s3.clock ∧
+        FDOM t3.code = EMPTY ∧ FDOM s3.code = EMPTY’
+          by fs [state_rel_def]
+    \\ ‘insert_interp exps ≠ []’ by (gvs [insert_interp_def] \\ gvs [AllCaseEqs()])
+    \\ gvs [CaseEq"bool"]
     >-
-     (last_x_assum irule \\ fs []
-      \\ first_assum $ irule_at Any \\ fs []
-      \\ imp_res_tac evaluate_clock \\ fs [])
+     (qexists_tac ‘ck’ \\ fs []
+      \\ simp [do_install_def]
+      \\ fs [pure_co_def,pure_cc_def]
+      \\ fs [o_DEF,shift_seq_def]
+      \\ fs [state_rel_def,FUN_EQ_THM]
+      \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST]))
+    \\ ‘aux = []’ by
+     (fs [state_rel_def,FUN_EQ_THM]
+      \\ rpt (first_x_assum (qspec_then ‘0:num’ assume_tac) \\ gvs [FUPDATE_LIST]))
+    \\ gvs [SWAP_REVERSE_SYM,CaseEq"prod"]
+    \\ drule_at (Pos $ el 2) evaluate_insert_interp \\ fs [FUPDATE_LIST]
+    \\ disch_then $ qspec_then ‘t3 with
+                <|clock := t3.clock − 1;
+                  compile_oracle := shift_seq 1 t3.compile_oracle;
+                  code := t3.code |>’ mp_tac
+    \\ impl_tac
     >-
-     (last_x_assum irule \\ fs []
-      \\ first_assum $ irule_at Any \\ fs []
-      \\ imp_res_tac evaluate_clock \\ fs [])
-    \\ gvs [FUN_EQ_THM,shift_seq_def,state_rel_def])
-  \\ strip_tac
-  \\ qpat_x_assum ‘evaluate _ = (Rval _,_)’ assume_tac
-  \\ drule evaluate_add_clock \\ fs []
-  \\ disch_then $ qspec_then ‘ck'’ assume_tac
-  \\ qexists_tac ‘ck+ck'’ \\ fs [PULL_EXISTS]
-  \\ fs [do_install_def,pure_co_def,shift_seq_def,pure_cc_def,pure_co_def,PULL_EXISTS]
-  \\ gvs [FUPDATE_LIST]
-  \\ gvs [AllCaseEqs()]
+     (fs [interp_assum_def] \\ rpt strip_tac
+      >-
+       (last_x_assum irule \\ fs []
+        \\ first_assum $ irule_at Any \\ fs []
+        \\ imp_res_tac evaluate_clock \\ fs [])
+      >-
+       (last_x_assum irule \\ fs []
+        \\ first_assum $ irule_at Any \\ fs []
+        \\ imp_res_tac evaluate_clock \\ fs [])
+      \\ gvs [FUN_EQ_THM,shift_seq_def,state_rel_def])
+    \\ strip_tac
+    \\ qpat_x_assum ‘evaluate _ = (Rval _,_)’ assume_tac
+    \\ drule evaluate_add_clock \\ fs []
+    \\ disch_then $ qspec_then ‘ck'’ assume_tac
+    \\ qexists_tac ‘ck+ck'’ \\ fs [PULL_EXISTS]
+    \\ fs [do_install_def,pure_co_def,shift_seq_def,pure_cc_def,pure_co_def,PULL_EXISTS]
+    \\ gvs [FUPDATE_LIST]
+    \\ gvs [AllCaseEqs()])
+  >~ [`dest_thunk`] >- (
+    gvs [AllCaseEqs()]
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ qrefine `ck + ck'` \\ gvs []
+    \\ `∀ck'. evaluate (xs,env,t1 with clock := ck + (ck' + t1.clock)) =
+          (Rval [RefPtr v0 ptr],t2 with clock := ck' + t2.clock)` by (
+      rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs []
+    \\ imp_res_tac state_rel_refs_clocks_eqs \\ gvs [PULL_EXISTS]
+    >- (qexists `0` \\ gvs [state_rel_def])
+    \\ (
+      last_x_assum $ qspecl_then [`[AppUnit (Var None 0)]`, `s'`] mp_tac
+      \\ gvs [GSYM PULL_FORALL]
+      \\ impl_tac
+      >- (imp_res_tac evaluate_clock \\ gvs [AppUnit_def])
+      \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs [dec_clock_def]
+      \\ disch_then $ qspec_then `t2` mp_tac \\ gvs [dec_clock_def]
+      \\ rw []
+      \\ goal_assum drule \\ gvs []
+      \\ imp_res_tac state_rel_update_thunk \\ rw []))
 QED
 
 Theorem evaluate_interp_thm:
@@ -1069,7 +1112,9 @@ Definition state_rel'_def:
     t.clock = s.clock ∧
     t.ffi = s.ffi ∧
     s.globals = t.globals ∧ EVERY (OPTION_ALL v_ok) t.globals ∧
-    s.refs = t.refs ∧ FEVERY (λ(k,v). ∀vs. v = ValueArray vs ⇒ EVERY v_ok vs) t.refs ∧
+    s.refs = t.refs ∧
+    FEVERY (λ(k,v). ∀vs. v = ValueArray vs ⇒ EVERY v_ok vs) t.refs ∧
+    FEVERY (λ(k,v). ∀m w. v = Thunk m w ⇒ v_ok w) t.refs ∧
     s.compile = pure_cc (insert_interp ## I) t.compile ∧
     t.compile_oracle = pure_co (insert_interp ## I) o s.compile_oracle
 End
@@ -1089,6 +1134,18 @@ Proof
   fs [state_rel'_def]
 QED
 
+Triviality state_rel'_refs:
+  state_rel' s t ⇒ t.refs = s.refs
+Proof
+  fs [state_rel'_def]
+QED
+
+Triviality state_rel'_dec_clock:
+  state_rel' s t ⇒ state_rel' (dec_clock 1 s) (dec_clock 1 t)
+Proof
+  gvs [state_rel'_def, dec_clock_def]
+QED
+
 Triviality has_install_list_eq:
   ∀xs. has_install_list xs ⇔ EXISTS has_install xs
 Proof
@@ -1179,8 +1236,12 @@ Proof
          \\ qid_spec_tac ‘vs’ \\ Induct \\ gvs [Abbr‘vr’])
       \\ fs [simple_state_rel_def] \\ simp [Abbr‘vr’] \\ rpt $ pop_assum kall_tac
       \\ rw [] \\ gvs [state_rel'_def]
-      \\ TRY $ drule_all FEVERY_FLOOKUP \\ fs []
-      >- (qid_spec_tac ‘w’ \\ Induct \\ fs [])
+      >- (
+        imp_res_tac FEVERY_FLOOKUP \\ pairarg_tac
+        \\ gvs [EVERY_EL, LIST_REL_EL_EQN])
+      >- (
+        imp_res_tac FEVERY_FLOOKUP \\ pairarg_tac
+        \\ gvs [EVERY_EL, LIST_REL_EL_EQN])
       >- (qpat_x_assum ‘EVERY _ _’ mp_tac
           \\ rename [‘EVERY _ xs’] \\ qid_spec_tac ‘xs’ \\ Induct
           \\ fs [] \\ Cases \\ fs [])
@@ -1191,6 +1252,8 @@ Proof
             (pop_assum mp_tac \\ qid_spec_tac ‘xs’ \\ qid_spec_tac ‘ys’
              \\ Induct \\ fs [PULL_EXISTS] \\ rw [] \\ gvs [] \\ res_tac \\ fs [])
           \\ gvs [] \\ rw [] \\ fs [] \\ res_tac \\ fs [])
+      >- (gvs [FEVERY_DEF,SF DNF_ss,FAPPLY_FUPDATE_THM] \\ rw []
+          \\ res_tac \\ fs [])
       \\ pop_assum mp_tac
       \\ qid_spec_tac ‘xs’
       \\ qid_spec_tac ‘ys’
@@ -1199,6 +1262,32 @@ Proof
       \\ Cases_on ‘h’ \\ fs []
       \\ Cases_on ‘x’ \\ fs [] \\ gvs [])
     \\ strip_tac
+    \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs []
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      \\ imp_res_tac state_rel'_refs \\ gvs []
+      \\ imp_res_tac state_rel'_clock \\ gvs [PULL_EXISTS]
+      >- (
+        gvs [state_rel'_def]
+        \\ imp_res_tac FEVERY_FLOOKUP
+        \\ rpt (pairarg_tac \\ gvs []))
+      \\ (
+        gvs [AppUnit_def, has_install_def]
+        \\ imp_res_tac state_rel'_dec_clock
+        \\ last_x_assum drule
+        \\ impl_tac
+        >- (
+          gvs [state_rel'_def]
+          \\ imp_res_tac FEVERY_FLOOKUP
+          \\ rpt (pairarg_tac \\ gvs []))
+        \\ rw [] \\ gvs []
+        \\ gvs [oneline update_thunk_def, AllCaseEqs()]
+        \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+        \\ gvs [oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+        \\ imp_res_tac state_rel'_refs \\ gvs []
+        \\ gvs [state_rel'_def]
+        \\ gvs [FEVERY_DEF,FAPPLY_FUPDATE_THM] \\ rw []
+        \\ res_tac \\ fs []))
     \\ gvs [AllCaseEqs()]
     \\ gvs [Abbr‘vr’]
     \\ Cases_on ‘err’ \\ gvs [])
diff --git a/compiler/backend/proofs/clos_knownProofScript.sml b/compiler/backend/proofs/clos_knownProofScript.sml
index 4362671563..71dee3ce8a 100644
--- a/compiler/backend/proofs/clos_knownProofScript.sml
+++ b/compiler/backend/proofs/clos_knownProofScript.sml
@@ -647,6 +647,9 @@ Proof
   >-(Cases_on `i` >> gvs[known_op_def])
   >-(Cases_on `i` >> gvs[known_op_def] >>
     gvs[oneline do_int_app_def,AllCaseEqs()])
+  >- (
+    rename1 `FLOOKUP _ _ = SOME (Thunk m _)`
+    \\ Cases_on `m` \\ gvs [])
 QED
 
 Theorem ssgc_free_co_shift_seq:
@@ -675,6 +678,7 @@ Proof
          \\ rveq
          \\ fs [MAP_APPEND, elist_globals_append])
   THEN1 (rw [] \\ res_tac)
+  THEN1 (rw [] \\ res_tac)
   THEN1 (simp [shift_seq_def] \\ rw [] \\ res_tac)
 QED
 
@@ -742,6 +746,7 @@ Proof
       >- (irule IMP_EVERY_LUPDATE >> simp[] >> metis_tac[])
       >- metis_tac[]
       >- metis_tac[]
+      >- metis_tac[]
       >- metis_tac[])
   >- (rename [‘El’] \\ simp[PULL_FORALL] \\ rw []
       \\ fs [ssgc_free_def] \\ res_tac
@@ -773,6 +778,7 @@ Proof
       >- metis_tac[]
       >- metis_tac[]
       >- (fs[MEM_LUPDATE] >> metis_tac[MEM_EL])
+      >- (fs[MEM_LUPDATE] >> metis_tac[MEM_EL])
       >- metis_tac[]
       >- metis_tac[]
       >- (dsimp[SUBSET_DEF, get_global_def,
@@ -818,13 +824,13 @@ Proof
   >- (rename [‘EqualConst’]
       \\ rw [] \\ fs [Boolv_def])
   >- (rename [‘FFI’] \\ dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq] >>
-      rpt strip_tac >> PURE_FULL_CASE_TAC >> fs [] >> rveq
-      >- (first_x_assum match_mp_tac >> fs[FLOOKUP_UPDATE,bool_case_eq] >> metis_tac[])
-      >- (fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[])
-      >- (last_x_assum match_mp_tac >> fs[])
-      >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[])
-      >- (first_x_assum match_mp_tac >> fs[] >> metis_tac[])
-      \\ dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq])
+      rpt strip_tac >> PURE_FULL_CASE_TAC >> fs [] >> rveq >>
+      fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[])
+  >- (rename [‘ThunkOp’] >>
+      dsimp[ssgc_free_def, FLOOKUP_UPDATE, bool_case_eq] >>
+      rpt strip_tac >>
+      rpt (FULL_CASE_TAC >> gvs []) >> fs [] >> rveq >>
+      fs[ssgc_free_def,FLOOKUP_UPDATE, bool_case_eq] >> metis_tac[])
 QED
 
 Theorem dest_closure_Full_sgc_free:
@@ -857,6 +863,21 @@ Proof
    THEN1 (irule EVERY_DROP \\ simp [EVERY_REVERSE])
 QED
 
+Triviality update_thunk_ssgc_free:
+  ssgc_free s ∧
+  EVERY vsgc_free vs ∧
+  update_thunk [RefPtr v ptr] s.refs vs = SOME refs ⇒
+    ssgc_free (s with refs := refs)
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()]
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [store_thunk_def, AllCaseEqs()]
+    \\ gvs [ssgc_free_def, FLOOKUP_UPDATE] \\ rw []
+    \\ rpt (first_x_assum drule \\ rw []))
+QED
+
 val say = say0 "evaluate_changed_globals_0";
 
 (* Evaluate  *)
@@ -1018,6 +1039,73 @@ Proof
       \\ rpt (pop_assum kall_tac)
       \\ fs [elist_globals_append, SET_OF_BAG_UNION]
       \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION])
+    \\ Cases_on `op = ThunkOp ForceThunk` \\ gvs []
+    THEN1
+     (
+      gvs [oneline dest_thunk_def, AllCaseEqs()]
+      \\ TRY (
+        qexists `n` \\ gvs [SET_OF_BAG_UNION]
+        \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION])
+      >- (
+        gvs [ssgc_free_def]
+        \\ rpt (first_x_assum drule \\ rw [])
+        \\ qexists `n` \\ gvs [SET_OF_BAG_UNION]
+        \\ metis_tac [mglobals_extend_SUBSET, UNION_ASSOC, SUBSET_UNION])
+      >- (
+        gvs [Once AppUnit_def]
+        \\ `vsgc_free v` by (
+          gvs [ssgc_free_def]
+          \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def]
+        \\ qexists `n' + n`
+        \\ simp [first_n_exps_shift_seq]
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals`
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals`
+        \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals`
+        \\ rfs []
+        \\ `g1 ∪ g2 ⊆ g3` suffices_by
+          metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET]
+        \\ unabbrev_all_tac
+        \\ rpt (pop_assum kall_tac)
+        \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def,
+                op_gbag_def]
+        \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION])
+      >- (
+        gvs [Once AppUnit_def]
+        \\ `vsgc_free v` by (
+          gvs [ssgc_free_def]
+          \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def]
+        \\ conj_tac >- (drule_all update_thunk_ssgc_free \\ gvs [])
+        \\ qexists `n' + n`
+        \\ simp [first_n_exps_shift_seq]
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals`
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals`
+        \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals`
+        \\ rfs []
+        \\ `g1 ∪ g2 ⊆ g3` suffices_by
+          metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET]
+        \\ unabbrev_all_tac
+        \\ rpt (pop_assum kall_tac)
+        \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def,
+                op_gbag_def]
+        \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION])
+      >- (
+        gvs [Once AppUnit_def]
+        \\ `vsgc_free v` by (
+          gvs [ssgc_free_def]
+          \\ rpt (first_x_assum drule \\ rw [])) \\ gvs [dec_clock_def]
+        \\ qexists `n' + n`
+        \\ simp [first_n_exps_shift_seq]
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s0.globals g1 s1.globals`
+        \\ qmatch_asmsub_abbrev_tac `mglobals_extend s1.globals g2 s.globals`
+        \\ qmatch_goalsub_abbrev_tac `mglobals_extend s0.globals g3 s.globals`
+        \\ rfs []
+        \\ `g1 ∪ g2 ⊆ g3` suffices_by
+          metis_tac [mglobals_extend_trans, mglobals_extend_SUBSET]
+        \\ unabbrev_all_tac
+        \\ rpt (pop_assum kall_tac)
+        \\ gvs [elist_globals_append, SET_OF_BAG_UNION, AppUnit_def,
+                op_gbag_def]
+        \\ metis_tac [UNION_ASSOC, UNION_COMM, SUBSET_UNION]))
     \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs []
     \\ drule do_app_ssgc \\ fs [EVERY_REVERSE]
     \\ strip_tac \\ rveq \\ fs []
@@ -2116,41 +2204,121 @@ Proof
     THEN1
      (irule state_globals_approx_known_op_evaluate
       \\ rpt (goal_assum drule \\ simp []))
-    \\ reverse (Cases_on `opn = Install`) \\ fs []
+    \\ reverse (Cases_on `opn = Install ∨ opn = ThunkOp ForceThunk`) \\ fs []
     THEN1
      (fs [result_case_eq, pair_case_eq] \\ rveq \\ fs []
       THEN1 (irule known_op_correct_approx
              \\ rpt (goal_assum drule \\ simp []))
       \\ irule state_globals_approx_known_op_evaluate
       \\ rpt (goal_assum drule \\ simp []))
-    \\ fs [known_op_def] \\ rveq \\ rfs []
-    \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs []
-    THEN1
-     (fs [do_install_def, case_eq_thms] \\ rveq \\ fs []
-      \\ pairarg_tac \\ fs []
-      \\ fs [bool_case_eq, pair_case_eq, case_eq_thms] \\ rveq \\ fs [])
-    \\ rename1 `do_install _ _ = (_, s2)`
-    \\ `?n. s.compile_oracle = shift_seq n s1.compile_oracle /\
-            mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals`
-       by (drule evaluate_changed_globals
-           \\ drule do_install_ssgc
-           \\ last_assum (mp_then (Pos hd) mp_tac evaluate_changed_globals)
-           \\ simp [] \\ disch_then kall_tac \\ strip_tac \\ strip_tac
-           \\ goal_assum drule
-           \\ last_assum (mp_then (Pos hd) mp_tac mglobals_extend_trans)
-           \\ disch_then drule
-           \\ fs [first_n_exps_shift_seq, SET_OF_BAG_UNION, elist_globals_append])
-    \\ `oracle_gapprox_disjoint g s1.compile_oracle`
-       by (irule oracle_gapprox_disjoint_lemma
-           \\ rpt (goal_assum drule \\ simp []))
-    \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps]
-    \\ rw [state_globals_approx_def]
-    \\ first_x_assum (qspec_then `n` assume_tac)
-    \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS]
-    \\ pop_assum drule \\ strip_tac
-    \\ fs [mglobals_extend_def]
-    \\ first_x_assum drule \\ simp [] \\ strip_tac
-    \\ metis_tac [state_globals_approx_def])
+    >~ [`Install`] >- (
+      fs [known_op_def] \\ rveq \\ rfs []
+      \\ reverse (fs [result_case_eq, pair_case_eq]) \\ rveq \\ fs []
+      THEN1
+       (fs [do_install_def, case_eq_thms] \\ rveq \\ fs []
+        \\ pairarg_tac \\ fs []
+        \\ fs [bool_case_eq, pair_case_eq, case_eq_thms] \\ rveq \\ fs [])
+      \\ rename1 `do_install _ _ = (_, s2)`
+      \\ `?n. s.compile_oracle = shift_seq n s1.compile_oracle /\
+              mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals`
+         by (drule evaluate_changed_globals
+             \\ drule do_install_ssgc
+             \\ last_assum (mp_then (Pos hd) mp_tac evaluate_changed_globals)
+             \\ simp [] \\ disch_then kall_tac \\ strip_tac \\ strip_tac
+             \\ goal_assum drule
+             \\ last_assum (mp_then (Pos hd) mp_tac mglobals_extend_trans)
+             \\ disch_then drule
+             \\ fs [first_n_exps_shift_seq, SET_OF_BAG_UNION, elist_globals_append])
+      \\ `oracle_gapprox_disjoint g s1.compile_oracle`
+         by (irule oracle_gapprox_disjoint_lemma
+             \\ rpt (goal_assum drule \\ simp []))
+      \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps]
+      \\ rw [state_globals_approx_def]
+      \\ first_x_assum (qspec_then `n` assume_tac)
+      \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS]
+      \\ pop_assum drule \\ strip_tac
+      \\ fs [mglobals_extend_def]
+      \\ first_x_assum drule \\ simp [] \\ strip_tac
+      \\ metis_tac [state_globals_approx_def])
+    >~ [`ThunkOp ForceThunk`] >- (
+      gvs [known_op_def]
+      \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+      >- (
+        `∃n. s.compile_oracle = shift_seq n s1.compile_oracle ∧
+             mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals`
+          by (
+            drule evaluate_changed_globals
+            \\ impl_tac >- (
+              gvs [dec_clock_def, AppUnit_def]
+              \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+              \\ drule evaluate_changed_globals \\ rw []
+              \\ gvs [ssgc_free_def]
+              \\ first_x_assum drule \\ gvs [])
+            \\ rw []
+            \\ goal_assum drule
+            \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def])
+        \\ `oracle_gapprox_disjoint g s1.compile_oracle` by (
+          irule oracle_gapprox_disjoint_lemma
+          \\ rpt (goal_assum drule \\ simp []))
+        \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps]
+        \\ rw [state_globals_approx_def]
+        \\ first_x_assum (qspec_then `n` assume_tac)
+        \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS]
+        \\ pop_assum drule \\ strip_tac
+        \\ fs [mglobals_extend_def]
+        \\ first_x_assum drule \\ simp [] \\ strip_tac
+        \\ metis_tac [state_globals_approx_def])
+      >- (
+        `∃n. s''.compile_oracle = shift_seq n s1.compile_oracle ∧
+             mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s''.globals`
+          by (
+            drule evaluate_changed_globals
+            \\ impl_tac >- (
+              gvs [dec_clock_def, AppUnit_def]
+              \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+              \\ drule evaluate_changed_globals \\ rw []
+              \\ gvs [ssgc_free_def]
+              \\ first_x_assum drule \\ gvs [])
+            \\ rw []
+            \\ goal_assum drule
+            \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def])
+        \\ `oracle_gapprox_disjoint g s1.compile_oracle` by (
+          irule oracle_gapprox_disjoint_lemma
+          \\ rpt (goal_assum drule \\ simp []))
+        \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps]
+        \\ reverse $ rw [state_globals_approx_def]
+        >- (imp_res_tac evaluate_SING \\ gvs [])
+        \\ first_x_assum (qspec_then `n` assume_tac)
+        \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS]
+        \\ pop_assum drule \\ strip_tac
+        \\ fs [mglobals_extend_def]
+        \\ first_x_assum drule \\ simp [] \\ strip_tac
+        \\ metis_tac [state_globals_approx_def])
+      >- (
+        `∃n. s.compile_oracle = shift_seq n s1.compile_oracle ∧
+             mglobals_extend s1.globals (SET_OF_BAG (elist_globals (FLAT (first_n_exps s1.compile_oracle n)))) s.globals`
+          by (
+            drule evaluate_changed_globals
+            \\ impl_tac >- (
+              gvs [dec_clock_def, AppUnit_def]
+              \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+              \\ drule evaluate_changed_globals \\ rw []
+              \\ gvs [ssgc_free_def]
+              \\ first_x_assum drule \\ gvs [])
+            \\ rw []
+            \\ goal_assum drule
+            \\ gvs [dec_clock_def, AppUnit_def, op_gbag_def])
+        \\ `oracle_gapprox_disjoint g s1.compile_oracle` by (
+          irule oracle_gapprox_disjoint_lemma
+          \\ rpt (goal_assum drule \\ simp []))
+        \\ pop_assum mp_tac \\ simp [oracle_gapprox_disjoint_first_n_exps]
+        \\ rw [state_globals_approx_def]
+        \\ first_x_assum (qspec_then `n` assume_tac)
+        \\ fs [gapprox_disjoint_def, DISJOINT_ALT, domain_lookup, PULL_EXISTS]
+        \\ pop_assum drule \\ strip_tac
+        \\ fs [mglobals_extend_def]
+        \\ first_x_assum drule \\ simp [] \\ strip_tac
+        \\ metis_tac [state_globals_approx_def])))
   THEN1
    (say "App"
     \\ rpt (pairarg_tac \\ fs []) \\ rveq
@@ -2575,13 +2743,17 @@ Inductive ref_rel:
   (!bs. ref_rel c g (ByteArray bs) (ByteArray bs)) /\
   (!xs ys.
     LIST_REL (v_rel c g) xs ys ==>
-    ref_rel c g (ValueArray xs) (ValueArray ys))
+    ref_rel c g (ValueArray xs) (ValueArray ys)) /\
+  (!m v w.
+    v_rel c g v w ==>
+      ref_rel c g (Thunk m v) (Thunk m w))
 End
 
 Theorem ref_rel_simps[simp] =
   LIST_CONJ [
   SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ValueArray vs) x``,
-  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ByteArray bs) x``]
+  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (ByteArray bs) x``,
+  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel c g (Thunk m v) x``]
 
 Theorem ref_rel_upd_inline_factor:
    ref_rel (c with inline_factor := k) = ref_rel c
@@ -2655,7 +2827,7 @@ QED
 Theorem ref_rel_subspt:
    !c g r1 r2 g'. ref_rel c g r1 r2 /\ subspt g g' ==> ref_rel c g' r1 r2
 Proof
-  Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt]
+  Cases_on `r1` \\ rw [] \\ metis_tac [v_rel_LIST_REL_subspt, v_rel_subspt]
 QED
 
 Theorem state_rel_subspt:
@@ -2965,6 +3137,41 @@ Proof
     \\ rw[] \\ metis_tac[])
 QED
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel c g s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ OPTREL (ref_rel c g) r1 r2) ∧
+  (state_rel c g s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ OPTREL (ref_rel c g) r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality rel_update_thunk:
+  state_rel c g s1 s2 ∧
+  LIST_REL (v_rel c g) vs ys ⇒
+    (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+       ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+               state_rel c g (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ TRY (
+      rename1 `FLOOKUP s2.refs pf = SOME _ ∧ _`
+      \\ qpat_x_assum `FLOOKUP s1.refs pf = _` assume_tac
+      \\ drule_all (cj 1 state_rel_opt_rel_refs) \\ rw [OPTREL_def] \\ gvs [])
+    \\ TRY (
+      rename1 `FLOOKUP s2.refs ps = SOME _ ∧ _`
+      \\ qpat_x_assum `FLOOKUP s1.refs ps = _` assume_tac
+      \\ drule_all (cj 1 state_rel_opt_rel_refs) \\ rw [OPTREL_def]
+      \\ gvs [])
+    \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw []
+    \\ metis_tac [])
+QED
+
+
 val say = say0 "known_correct0";
 
 Theorem known_correct0[local]:
@@ -3522,6 +3729,158 @@ Proof
                       elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION]))
       THEN1 simp [compile_inc_upd_inline_factor, is_state_oracle_shift_imp]
       THEN1 fs [result_case_eq])
+    \\ Cases_on `opn = ThunkOp ForceThunk` \\ gvs []
+    >- (
+      simp [isGlobal_def]
+      \\ irule_at (Pos hd) SmartOp_thm \\ simp [evaluate_def]
+      \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      >- (
+        `∃w. FLOOKUP t.refs ptr = SOME (Thunk Evaluated w) ∧
+                 v_rel c (next_g s) v w` by (
+          gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF]
+          \\ first_x_assum drule \\ rw []) \\ gvs [])
+      >- (
+        `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧
+                 v_rel c (next_g s1) v w` by (
+          gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF]
+          \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS]
+        \\ simp [GSYM PULL_EXISTS] \\ rw []
+        \\ gvs [PULL_EXISTS]
+        \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`)
+        \\ `known c [AppUnit (Var None 0)] [Other] g0 =
+              ([(AppUnit (Var None 0),Other)],g0)`
+          by (
+            gvs [AppUnit_def, known_op_def, op_gbag_def]
+            \\ gvs [known_def]
+            \\ rpt (pairarg_tac \\ gvs [any_el_def, decide_inline_def])
+            \\ gvs [known_op_def, isGlobal_def]
+            \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def])
+        \\ gvs []
+        \\ disch_then drule \\ gvs []
+        \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs []
+        \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs []
+        \\ impl_tac >- (
+          rw []
+          >- gvs [AppUnit_def]
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [co_every_Fn_vs_NONE_shift_seq])
+          >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def,
+                  op_gbag_def]
+          >- gvs [AppUnit_def]
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_changed_globals \\ gvs [])
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_changed_globals \\ rw [] \\ gvs []
+            \\ gvs [ssgc_free_def]
+            \\ rpt (first_x_assum drule \\ rw []))
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [oracle_state_sgc_free_shift_seq])
+          >- (
+            gvs [next_g_def, dec_clock_def]
+            \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs []
+            \\ gvs [shift_seq_def]
+            \\ drule (iffLR oracle_gapprox_subspt_add)
+            \\ disch_then $ qspecl_then [`0`, `k`] assume_tac \\ gvs []
+            \\ imp_res_tac subspt_trans)
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [oracle_gapprox_subspt_shift_seq])
+          >- (
+            gvs [AppUnit_def, fv_max_def] \\ rw []
+            \\ CCONTR_TAC
+            \\ qmatch_asmsub_abbrev_tac `fv1 v' exp`
+            \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def])
+            \\ gvs [])
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [unique_set_globals_shift_seq, AppUnit_def,
+                    unique_set_globals_def, op_gbag_def] \\ rw []
+            \\ first_x_assum $ qspec_then `n + k` assume_tac \\ gvs []
+            \\ qspecl_then [`s0.compile_oracle`, `n`, `k`] assume_tac
+                 first_n_exps_shift_seq \\ gvs []
+            \\ gvs [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION]))
+        \\ rw [] \\ gvs []
+        \\ gvs [next_g_def]
+        \\ drule_all rel_update_thunk \\ rw [])
+      >- (
+        `∃w. FLOOKUP t.refs ptr = SOME (Thunk NotEvaluated w) ∧
+           v_rel c (next_g s1) v w` by (
+          gvs [state_rel_def, fmap_rel_def, FLOOKUP_DEF]
+          \\ first_x_assum drule \\ rw []) \\ gvs [PULL_EXISTS]
+        \\ simp [GSYM PULL_EXISTS] \\ rw []
+        \\ last_x_assum $ drule_at (Pat `state_rel _ _ _`)
+        \\ `known c [AppUnit (Var None 0)] [Other] g0 =
+              ([(AppUnit (Var None 0),Other)],g0)`
+          by (
+            gvs [AppUnit_def, known_op_def, op_gbag_def]
+            \\ gvs [known_def]
+            \\ rpt (pairarg_tac \\ gvs [any_el_def, decide_inline_def])
+            \\ gvs [known_op_def, isGlobal_def]
+            \\ gvs [clos_opTheory.SmartOp_def, clos_opTheory.SmartOp'_def])
+        \\ gvs []
+        \\ disch_then drule \\ gvs []
+        \\ disch_then $ qspec_then `[v]` mp_tac \\ gvs []
+        \\ disch_then $ qspecl_then [`[w]`, `[]`] mp_tac \\ gvs []
+        \\ impl_tac >- (
+          rw []
+          >- gvs [AppUnit_def]
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [co_every_Fn_vs_NONE_shift_seq])
+          >- gvs [AppUnit_def, dec_clock_def, mglobals_disjoint_def,
+                  op_gbag_def]
+          >- gvs [AppUnit_def]
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_changed_globals \\ gvs [])
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_changed_globals \\ rw [] \\ gvs []
+            \\ gvs [ssgc_free_def]
+            \\ rpt (first_x_assum drule \\ rw []))
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [oracle_state_sgc_free_shift_seq])
+          >- (
+            gvs [next_g_def, dec_clock_def]
+            \\ qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw [] \\ gvs []
+            \\ gvs [shift_seq_def]
+            \\ drule (iffLR oracle_gapprox_subspt_add)
+            \\ disch_then $ qspecl_then [`0`, `k`] assume_tac \\ gvs []
+            \\ imp_res_tac subspt_trans)
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [oracle_gapprox_subspt_shift_seq])
+          >- (
+            gvs [AppUnit_def, fv_max_def] \\ rw []
+            \\ CCONTR_TAC
+            \\ qmatch_asmsub_abbrev_tac `fv1 v' exp`
+            \\ `fv v' [exp] ⇔ v' = 0` by (unabbrev_all_tac \\ gvs [fv_def])
+            \\ gvs [])
+          >- (
+            qpat_x_assum `evaluate (_,_,s0) = _` assume_tac
+            \\ drule evaluate_IMP_shift_seq \\ rw []
+            \\ gvs [unique_set_globals_shift_seq, AppUnit_def,
+                    unique_set_globals_def, op_gbag_def] \\ rw []
+            \\ first_x_assum $ qspec_then `n + k` assume_tac \\ gvs []
+            \\ qspecl_then [`s0.compile_oracle`, `n`, `k`] assume_tac
+                 first_n_exps_shift_seq \\ gvs []
+            \\ gvs [elist_globals_append, BAG_ALL_DISTINCT_BAG_UNION]))
+        \\ rw [] \\ gvs []
+        \\ Cases_on `e` \\ Cases_on `e'` \\ gvs []))
     \\ Cases_on `isGlobal opn /\ gO_destApx apx <> gO_None`
     THEN1
      (fs []
diff --git a/compiler/backend/proofs/clos_letopProofScript.sml b/compiler/backend/proofs/clos_letopProofScript.sml
index 0f3b5d9bf8..3f1669f6ef 100644
--- a/compiler/backend/proofs/clos_letopProofScript.sml
+++ b/compiler/backend/proofs/clos_letopProofScript.sml
@@ -87,13 +87,22 @@ Theorem v_rel_simps[simp] =
   prove(``v_rel Unit x <=> x = Unit``,
         fs [closSemTheory.Unit_def,Once v_rel_cases])]
 
+Definition opt_rel_def[simp]:
+  opt_rel f NONE NONE = T /\
+  opt_rel f (SOME x) (SOME y) = f x y /\
+  opt_rel f _ _ = F
+End
+
 (* state relation *)
 
 Inductive ref_rel:
   (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\
   (!xs ys.
     LIST_REL v_rel xs ys ==>
-    ref_rel (ValueArray xs) (ValueArray ys))
+    ref_rel (ValueArray xs) (ValueArray ys)) /\
+  (!m v w.
+    v_rel v w ==>
+    ref_rel (Thunk m v) (Thunk m w))
 End
 
 Definition FMAP_REL_def:
@@ -309,6 +318,50 @@ val do_install_lemma = prove(
   \\ fs [simple_val_rel_def, simple_state_rel] \\ rw [] \\ fs [v_rel_cases]
   \\ EVAL_TAC \\ fs [FUN_EQ_THM]);
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧
+  (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality state_rel_clocks_eqs:
+  state_rel s1 s2 ⇒ s1.clock = s2.clock
+Proof
+  rw [state_rel_def, state_component_equality]
+QED
+
+Triviality state_rel_dec_clock:
+  state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2)
+Proof
+  rw [state_rel_def, dec_clock_def, state_component_equality]
+QED
+
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL v_rel vs ys ⇒
+    (update_thunk [RefPtr v ptr] s1.refs vs = NONE ⇒
+       update_thunk [RefPtr v ptr] s2.refs ys = NONE) ∧
+    (update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+       ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ rpt (
+      imp_res_tac state_rel_opt_rel_refs \\ rw []
+      \\ gvs [oneline opt_rel_def]
+      \\ FULL_CASE_TAC \\ gvs []
+      \\ rgs [Once ref_rel_cases])
+    \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw []
+    \\ simp [Once ref_rel_cases])
+QED
+
 (* evaluate_let_op *)
 
 Theorem evaluate_let_op:
@@ -458,7 +511,21 @@ Proof
       \\ fs []
       \\ CCONTR_TAC
       \\ fs [])
-   (* op <> Install *)
+    \\ IF_CASES_TAC \\ rveq \\ fs []
+    THEN1 (* Op = ThunkOp ForceThunk *)
+     (gvs [AllCaseEqs()]
+      \\ (
+        gvs [oneline dest_thunk_def, AllCaseEqs()]
+        \\ imp_res_tac (cj 1 state_rel_opt_rel_refs)
+        \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac
+        \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs [PULL_EXISTS]
+        \\ rgs [Once ref_rel_cases]
+        \\ imp_res_tac state_rel_clocks_eqs \\ gvs [PULL_EXISTS]
+        \\ imp_res_tac state_rel_dec_clock \\ gvs []
+        \\ last_x_assum drule_all \\ rw [AppUnit_def, let_op_def]
+        \\ goal_assum drule \\ rw []
+        \\ drule_all rel_update_thunk \\ rw []))
+   (* op <> Install /\ op <> ThunkOp ForceThunk *)
    \\ drule EVERY2_REVERSE \\ disch_tac
    \\ drule (GEN_ALL do_app_lemma)
    \\ disch_then drule
diff --git a/compiler/backend/proofs/clos_mtiProofScript.sml b/compiler/backend/proofs/clos_mtiProofScript.sml
index 7ad9dfb16b..6d235af1c9 100644
--- a/compiler/backend/proofs/clos_mtiProofScript.sml
+++ b/compiler/backend/proofs/clos_mtiProofScript.sml
@@ -119,9 +119,18 @@ Inductive ref_rel:
   (!bs. ref_rel max_app (ByteArray bs) (ByteArray bs)) /\
   (!xs ys.
     LIST_REL (v_rel max_app) xs ys ==>
-    ref_rel max_app (ValueArray xs) (ValueArray ys))
+    ref_rel max_app (ValueArray xs) (ValueArray ys)) /\
+  (!m v w.
+    v_rel max_app v w ==>
+    ref_rel max_app (Thunk m v) (Thunk m w))
 End
 
+Theorem ref_rel_simps[simp] =
+  LIST_CONJ [
+  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (ValueArray vs) x``,
+  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (ByteArray bs) x``,
+  SIMP_CONV (srw_ss()) [ref_rel_cases] ``ref_rel max_app (Thunk m v) x``]
+
 Definition FMAP_REL_def:
   FMAP_REL r f1 f2 <=>
     FDOM f1 = FDOM f2 /\
@@ -151,6 +160,18 @@ Definition state_rel_def:
     t.compile_oracle = pure_co (clos_mti$compile_inc s.max_app) o s.compile_oracle
 End
 
+Triviality state_rel_max_app:
+  state_rel s t ⇒ s.max_app = t.max_app ∧ 1 ≤ t.max_app
+Proof
+  gvs [state_rel_def]
+QED
+
+Triviality state_rel_clocks:
+  state_rel s t ⇒ s.clock = t.clock
+Proof
+  gvs [state_rel_def]
+QED
+
 (* evaluation theorem *)
 
 Theorem collect_args_IMP:
@@ -498,12 +519,51 @@ Proof
    (Cases_on `s'.refs ' ptr` \\ fs []
     \\ Cases_on `t.refs ' ptr` \\ fs [ref_rel_cases]
     \\ fs [] \\ rveq \\ fs [])
+  THEN1
+   (Cases_on `s'.refs ' ptr` \\ fs []
+    \\ Cases_on `t.refs ' ptr` \\ fs [ref_rel_cases]
+    \\ fs [] \\ rveq \\ fs [])
   THEN
    (rpt gen_tac \\ Cases_on `k = p` \\ fs []
-    THEN1 (fs [ref_rel_cases])
     \\ fs [FAPPLY_FUPDATE_THM])
 QED
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ OPTREL (ref_rel s1.max_app) r1 r2) ∧
+  (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ OPTREL (ref_rel s1.max_app) r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL (v_rel s1.max_app) vs ys ⇒
+    (update_thunk [RefPtr v ptr] s2.refs ys = NONE ⇒
+       update_thunk [RefPtr v ptr] s1.refs vs = NONE) ∧
+    (update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ⇒
+       ∃refs1. update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()]
+    \\ TRY (
+      drule_all (cj 2 state_rel_opt_rel_refs) \\ rw [OPTREL_def]
+      \\ rgs [Once ref_rel_cases])
+    \\ TRY (
+      drule (cj 1 state_rel_opt_rel_refs) \\ strip_tac
+      \\ first_x_assum dxrule \\ rw [OPTREL_def] \\ gvs []
+      \\ imp_res_tac (cj 2 state_rel_opt_rel_refs) \\ gvs [OPTREL_def]
+      \\ rgs [Once ref_rel_cases])
+    \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw []
+    \\ simp [ref_rel_def]
+    \\ metis_tac [])
+QED
+
 val do_app_inst =
   simple_val_rel_do_app_rev
   |> Q.INST [`vr`|->`v_rel s.max_app`]
@@ -723,6 +783,30 @@ Proof
       \\ fs []
       \\ CCONTR_TAC
       \\ fs [])
+    \\ Cases_on `opp = ThunkOp ForceThunk` \\ gvs [] \\ rveq
+    >- (
+      Cases_on `res1` \\ gvs []
+      \\ gvs [AllCaseEqs()]
+      \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      \\ drule_all (cj 2 state_rel_opt_rel_refs) \\ rw [OPTREL_def]
+      \\ rgs [Once ref_rel_cases]
+      \\ imp_res_tac evaluate_const \\ gvs []
+      \\ imp_res_tac state_rel_clocks \\ gvs [PULL_EXISTS]
+      \\ (
+        `state_rel (dec_clock 1 s2) (dec_clock 1 s')` by (
+          gvs [state_rel_def, dec_clock_def]) \\ gvs []
+        \\ last_x_assum $ drule_at (Pat `state_rel _ _`) \\ gvs []
+        \\ disch_then $ qspecl_then [`[AppUnit (Var None 0)]`, `v'`] mp_tac
+        \\ gvs [] \\ impl_tac
+        >- gvs [state_rel_def, dec_clock_def, AppUnit_def, no_mti_def,
+                intro_multi_def, collect_apps_def]
+        \\ rw [] \\ gvs []
+        \\ gvs [dec_clock_def]
+        \\ Cases_on `res1` \\ gvs []
+        \\ imp_res_tac state_rel_max_app \\ gvs []
+        \\ drule rel_update_thunk \\ gvs []
+        \\ disch_then drule \\ rw [] \\ gvs []
+        \\ qrefine `Rval _` \\ gvs [PULL_EXISTS]))
     (* do_app *)
     \\ Cases_on `res1` \\ fs []
     \\ imp_res_tac evaluate_const \\ fs []
@@ -1251,6 +1335,9 @@ Proof
     ONCE_REWRITE_TAC[contains_App_SOME_EXISTS] >>
     srw_tac[QUANT_INST_ss[pair_default_qp]][] >>
     metis_tac[contains_App_SOME_collect_args,SND,PAIR])
+  >- (
+    Cases_on `op` >> simp [contains_App_SOME_def] >>
+    Cases_on `t'` >> simp [contains_App_SOME_def])
 QED
 
 Theorem contains_App_SOME_compile[simp]:
@@ -1336,7 +1423,8 @@ Theorem collect_apps_preserves_set_globals:
 Proof
   ho_match_mp_tac clos_mtiTheory.collect_apps_ind >>
   simp[clos_mtiTheory.collect_apps_def, bool_case_eq] >> rpt strip_tac
-  >- (fs[elist_globals_append] >>
+  >- (pop_assum (assume_tac o SYM) >> gvs[elist_globals_append] >>
+      last_x_assum $ qspecl_then [`es''`,`e'`] assume_tac >> gvs [] >>
       metis_tac[bagTheory.COMM_BAG_UNION, bagTheory.ASSOC_BAG_UNION])
   >- (rveq >> simp[])
 QED
diff --git a/compiler/backend/proofs/clos_numberProofScript.sml b/compiler/backend/proofs/clos_numberProofScript.sml
index b9fb977c81..5a1fe15205 100644
--- a/compiler/backend/proofs/clos_numberProofScript.sml
+++ b/compiler/backend/proofs/clos_numberProofScript.sml
@@ -457,8 +457,11 @@ Proof
    (`ref_rel (v_rel s.max_app) (s.refs ' ptr) (t.refs ' ptr)` by fs[]
     \\ rpt (qpat_x_assum `!x._` kall_tac)
     \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
+  THEN1
+   (`ref_rel (v_rel s.max_app) (s.refs ' ptr) (t.refs ' ptr)` by fs[]
+    \\ rpt (qpat_x_assum `!x._` kall_tac)
+    \\ rfs [] \\ Cases_on `s.refs ' ptr` \\ fs [ref_rel_def])
   \\ rpt gen_tac \\ fs [] \\ Cases_on `x = p` \\ fs [FAPPLY_FUPDATE_THM]
-  \\ metis_tac []
 QED
 
 val do_app_inst =
@@ -614,6 +617,26 @@ Proof
   simp[LIST_REL_EL_EQN]
 QED
 
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL (v_rel s1.max_app) vs ys ∧
+  update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ⇒
+    ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+            state_rel (s1 with refs := refs1) (s2 with refs := refs2)
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ rpt (
+      imp_res_tac state_rel_refs \\ gvs [fmap_rel_def, FLOOKUP_DEF]
+      \\ first_x_assum dxrule \\ rw [] \\ gvs [])
+    \\ gvs [state_rel_def, fmap_rel_def, FAPPLY_FUPDATE_THM] \\ rw []
+    \\ simp [Once v_rel_cases]
+    \\ metis_tac [])
+QED
+
 (*
 val do_install_Rabort = prove(
   ``closSem$do_install xs s2 = (Rerr (Rabort a),s3) ==>
@@ -743,7 +766,7 @@ Proof
     `r1 <> Rerr (Rabort Rtype_error)` by (strip_tac \\ fs []) \\ fs[] >>
     tac >> full_simp_tac(srw_ss())[] >>
     Cases_on`op = Install` >- (
-      fs[]
+      gvs [contains_App_SOME_def]
       \\ first_x_assum drule
       \\ disch_then drule
       \\ disch_then(qspec_then`n`strip_assume_tac) \\ rfs[]
@@ -796,6 +819,34 @@ Proof
       \\ fs [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq]
     ) >>
     srw_tac[][] >>
+    Cases_on`op = ThunkOp ForceThunk` >- (
+      gvs [contains_App_SOME_def]
+      \\ first_x_assum drule_all \\ rw []
+      \\ pop_assum $ qspec_then `n` assume_tac \\ gvs []
+      \\ Cases_on `res'` \\ Cases_on `r1` \\ gvs []
+      \\ imp_res_tac state_rel_max_app \\ gvs []
+      \\ imp_res_tac evaluate_const \\ gvs []
+      \\ imp_res_tac state_rel_clock \\ gvs []
+      \\ gvs [AllCaseEqs()]
+      \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+      \\ rgs [Once v_rel_cases]
+      \\ imp_res_tac state_rel_refs \\ gvs [fmap_rel_def, FLOOKUP_DEF]
+      \\ first_x_assum drule \\ rw [] \\ gvs [PULL_EXISTS]
+      \\ gvs [AppUnit_def, contains_App_SOME_def]
+      \\ `(dec_clock 1 s2').max_app = s2'.max_app` by (
+        gvs [state_rel_def, dec_clock_def]) \\ gvs []
+      \\ `state_rel (dec_clock 1 s2') (dec_clock 1 t2)` by (
+        drule state_rel_with_clock \\ rw [dec_clock_def])
+      \\ last_x_assum $ drule_all_then $ qspec_then `n` mp_tac
+      \\ rw [renumber_code_locs_def]
+      \\ goal_assum drule \\ rw []
+      \\ imp_res_tac evaluate_const \\ gvs []
+      \\ drule_at (Pos $ el 3) rel_update_thunk \\ gvs []) >>
+    srw_tac[][] >>
+    `¬contains_App_SOME s.max_app xs` by (
+      Cases_on `op` \\ gvs [contains_App_SOME_def]
+      \\ Cases_on `t` \\ gvs [contains_App_SOME_def]) >>
+    gvs[] >>
     first_x_assum(fn th => first_assum(mp_tac o MATCH_MP (ONCE_REWRITE_RULE[GSYM AND_IMP_INTRO]th))) >>
     disch_then(fn th => first_assum(qspec_then`n`STRIP_ASSUME_TAC o MATCH_MP th)) >> rev_full_simp_tac(srw_ss())[] >>
     Cases_on `r1` \\ full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >>
diff --git a/compiler/backend/proofs/clos_ticksProofScript.sml b/compiler/backend/proofs/clos_ticksProofScript.sml
index 71a3e630aa..2efaa5e8d3 100644
--- a/compiler/backend/proofs/clos_ticksProofScript.sml
+++ b/compiler/backend/proofs/clos_ticksProofScript.sml
@@ -104,13 +104,23 @@ Theorem v_rel_simps[simp] =
   prove(``v_rel x Unit <=> x = Unit``,
         fs [closSemTheory.Unit_def,Once v_rel_cases])]
 
+
+Definition opt_rel_def[simp]:
+  opt_rel f NONE NONE = T /\
+  opt_rel f (SOME x) (SOME y) = f x y /\
+  opt_rel f _ _ = F
+End
+
 (* state relation *)
 
 Inductive ref_rel:
   (!bs. ref_rel (ByteArray bs) (ByteArray bs)) /\
   (!xs ys.
     LIST_REL v_rel xs ys ==>
-    ref_rel (ValueArray xs) (ValueArray ys))
+    ref_rel (ValueArray xs) (ValueArray ys)) /\
+  (!m v w.
+    v_rel v w ==>
+    ref_rel (Thunk m v) (Thunk m w))
 End
 
 Definition FMAP_REL_def:
@@ -362,6 +372,50 @@ val v_rel_IMP_v_to_words = prove(
   ``v_rel x y ==> v_to_words y = v_to_words x``,
   metis_tac [simple_val_rel, closPropsTheory.simple_val_rel_v_to_words]);
 
+Triviality state_rel_opt_rel_refs:
+  (state_rel s1 s2 ∧ FLOOKUP s1.refs n = r1 ⇒
+     ∃r2. FLOOKUP s2.refs n = r2 ∧ opt_rel ref_rel r1 r2) ∧
+  (state_rel s1 s2 ∧ FLOOKUP s2.refs n = r2 ⇒
+     ∃r1. FLOOKUP s1.refs n = r1 ∧ opt_rel ref_rel r1 r2)
+Proof
+  rw [] \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_DEF] \\ rw []
+QED
+
+Triviality state_rel_clock_eqs:
+  state_rel s t ⇒ s.clock = t.clock
+Proof
+  gvs [state_rel_def]
+QED
+
+Triviality state_rel_dec_clock:
+  state_rel s1 s2 ⇒ state_rel (dec_clock 1 s1) (dec_clock 1 s2)
+Proof
+  rw [state_rel_def, dec_clock_def, state_component_equality]
+QED
+
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL v_rel vs ys ⇒
+    (update_thunk [RefPtr v ptr] s2.refs ys = NONE ⇒
+       update_thunk [RefPtr v ptr] s1.refs vs = NONE) ∧
+    (update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ⇒
+       ∃refs1. update_thunk [RefPtr v ptr] s1.refs vs = SOME refs1 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+  \\ (
+    gvs [Once v_rel_cases, oneline store_thunk_def, AllCaseEqs()]
+    \\ rpt (
+      imp_res_tac state_rel_opt_rel_refs \\ rw []
+      \\ gvs [oneline opt_rel_def]
+      \\ FULL_CASE_TAC \\ gvs []
+      \\ rgs [Once ref_rel_cases])
+    \\ gvs [state_rel_def, FMAP_REL_def, FLOOKUP_UPDATE] \\ rw []
+    \\ simp [Once ref_rel_cases])
+QED
+
 Theorem evaluate_remove_ticks:
    (!ys env2 (t1:('c,'ffi) closSem$state) res2 t2 env1 s1 xs.
      (evaluate (ys,env2,t1) = (res2,t2)) /\
@@ -540,8 +594,9 @@ Proof
     \\ reverse (fs [case_eq_thms]) \\ rveq
     \\ Cases_on `res1` \\ fs []
     THEN1 (qexists_tac `ck + LENGTH ts` \\ fs [])
-    \\ reverse (Cases_on `op = Install`) \\ fs [] \\ rveq
-    THEN1 (* op /= Install *)
+    \\ reverse (Cases_on `op = Install ∨ op = ThunkOp ForceThunk`)
+    \\ fs [] \\ rveq
+    THEN1 (* op /= Install /\ op /= ForceThunk *)
      (fs [case_eq_thms] \\ rw []
       \\ qexists_tac `ck + LENGTH ts` \\ fs []
       \\ drule (GEN_ALL do_app_lemma)
@@ -552,35 +607,59 @@ Proof
       \\ PairCases_on `v1`
       \\ fs []
       \\ metis_tac [])
-    (* op = Install *)
-    \\ drule EVERY2_REVERSE \\ disch_tac
-    \\ drule (GEN_ALL do_install_lemma)
-    \\ disch_then drule
-    \\ fs [CaseEq "prod"]
-    \\ TOP_CASE_TAC
-    \\ reverse TOP_CASE_TAC
+    THEN1 (* op = Install *)
+     (drule EVERY2_REVERSE \\ disch_tac
+      \\ drule (GEN_ALL do_install_lemma)
+      \\ disch_then drule
+      \\ fs [CaseEq "prod"]
+      \\ TOP_CASE_TAC
+      \\ reverse TOP_CASE_TAC
+      >- (
+        rw [] \\ qexists_tac`ck + LENGTH ts` \\ rw []
+        \\ fs [] \\ rveq \\ fs [] \\ rfs []
+      )
+      \\ rw [] \\ fs [CaseEq "prod"] \\ rfs []
+      \\ FIRST_X_ASSUM drule
+      \\ disch_then drule
+      \\ disch_then (drule o SIMP_RULE bool_ss [GSYM code_rel_def])
+      \\ fs [code_rel_def]
+      \\ rw []
+      \\ qexists_tac `ck' + ck + LENGTH ts` \\ rw[]
+      \\ imp_res_tac evaluate_clock
+      \\ imp_res_tac evaluate_add_clock \\ fs []
+      \\ imp_res_tac do_install_add_to_clock
+      \\ imp_res_tac evaluate_length_imp
+      \\ fs []
+      \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ rveq \\ fs []
+      \\ irule LIST_REL_LAST
+      \\ rw []
+      \\ CCONTR_TAC
+      \\ fs [])
+    (* op = ThunkOp ForceThunk *)
+    \\ gvs [PULL_FORALL]
+    \\ qrefine `ck' + ck + LENGTH ts` \\ gvs []
+    \\ `∀ck'. evaluate (es,env1,s1 with clock := ck + (ck' + s1.clock)) =
+         (Rval a,s2 with clock := s2.clock + ck')` by (
+      rw [] \\ drule evaluate_add_clock \\ gvs []) \\ gvs []
+    \\ gvs [AllCaseEqs()]
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ TRY (qexists `0` \\ gvs [state_rel_def] \\ NO_TAC)
+    \\ imp_res_tac (cj 2 state_rel_opt_rel_refs)
+    \\ qpat_x_assum `opt_rel ref_rel _ _` mp_tac
+    \\ simp [oneline opt_rel_def] \\ CASE_TAC \\ gvs []
+    \\ rgs [Once ref_rel_cases]
+    \\ TRY (qexists `0` \\ gvs [state_rel_def] \\ NO_TAC)
+    \\ imp_res_tac state_rel_clock_eqs \\ gvs [PULL_EXISTS]
+    \\ imp_res_tac state_rel_dec_clock \\ gvs []
+    \\ last_x_assum $ drule_then $ drule_then
+        $ qspec_then `[AppUnit (Var None 0)]` assume_tac
+    \\ gvs [AppUnit_def, remove_ticks_def, dec_clock_def]
+    \\ goal_assum drule \\ gvs [PULL_EXISTS]
+    \\ Cases_on `res1` \\ gvs []
+    >- (drule_all rel_update_thunk \\ rw [])
     >- (
-      rw [] \\ qexists_tac`ck + LENGTH ts` \\ rw []
-      \\ fs [] \\ rveq \\ fs [] \\ rfs []
-    )
-    \\ rw [] \\ fs [CaseEq "prod"] \\ rfs []
-    \\ FIRST_X_ASSUM drule
-    \\ disch_then drule
-    \\ disch_then (drule o SIMP_RULE bool_ss [GSYM code_rel_def])
-    \\ fs [code_rel_def]
-    \\ rw []
-    \\ qexists_tac `ck' + ck + LENGTH ts` \\ rw[]
-    \\ imp_res_tac evaluate_clock
-    \\ imp_res_tac evaluate_add_clock \\ fs []
-    \\ imp_res_tac do_install_add_to_clock
-    \\ imp_res_tac evaluate_length_imp
-    \\ fs []
-    \\ CASE_TAC \\ fs [] \\ rveq \\ fs [] \\ rveq \\ fs []
-    \\ irule LIST_REL_LAST
-    \\ rw []
-    \\ CCONTR_TAC
-    \\ fs []
-  )
+      qrefine `Rval _` \\ rw [PULL_EXISTS]
+      \\ drule_all rel_update_thunk \\ rw []))
   THEN1 (* Fn *)
    (fs [LENGTH_EQ_NUM_compute] \\ rveq
     \\ fs [code_rel_def]
diff --git a/compiler/backend/proofs/clos_to_bvlProofScript.sml b/compiler/backend/proofs/clos_to_bvlProofScript.sml
index 04ccb496b9..597cb3d4a8 100644
--- a/compiler/backend/proofs/clos_to_bvlProofScript.sml
+++ b/compiler/backend/proofs/clos_to_bvlProofScript.sml
@@ -33,8 +33,6 @@ val _ = temp_bring_to_front_overload"evaluate"{Name="evaluate",Thy="bvlSem"};
 val _ = temp_bring_to_front_overload"num_stubs"{Name="num_stubs",Thy="clos_to_bvl"};
 val _ = temp_bring_to_front_overload"compile_exps"{Name="compile_exps",Thy="clos_to_bvl"};
 
-Overload mk_elem_at[local] = “λb i. bvl$Op (BlockOp (ElemAt i)) [b]”;
-
 (* TODO: move? *)
 
 val EVERY2_GENLIST = LIST_REL_GENLIST |> EQ_IMP_RULE |> snd |> Q.GEN`l`
@@ -1102,6 +1100,7 @@ End
 
 Definition ref_rel_def:
   (ref_rel R (closSem$ValueArray vs) (bvlSem$ValueArray ws) ⇔ LIST_REL R vs ws) ∧
+  (ref_rel R (closSem$Thunk m1 v) (bvlSem$Thunk m2 w) ⇔ m1 = m2 ∧ R v w) ∧
   (ref_rel R (ByteArray as) (ByteArray g bs) ⇔ ~g ∧ as = bs) ∧
   (ref_rel _ _ _ = F)
 End
@@ -1109,6 +1108,7 @@ val _ = export_rewrites["ref_rel_def"];
 
 Theorem ref_rel_simp[simp]:
    (ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧
+   (ref_rel R (Thunk m v) y ⇔ ∃w. y = Thunk m w ∧ R v w) ∧
    (ref_rel R (ByteArray bs) y ⇔ y = ByteArray F bs)
 Proof
   Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM]
@@ -1131,6 +1131,7 @@ Definition state_rel_def:
          lookup (generic_app_fn_location n) t.code = SOME (n + 2, generate_generic_app s.max_app n)) ∧
     (!tot n. tot < s.max_app ∧ n < tot ⇒
       lookup (partial_app_fn_location s.max_app tot n) t.code = SOME (tot - n + 1, generate_partial_app_closure_fn tot n)) ∧
+    lookup (num_stubs s.max_app - 2) t.code = SOME (2,force_thunk_code) ∧
     compile_oracle_inv s.max_app s.code s.compile s.compile_oracle
                                  t.code t.compile t.compile_oracle ∧
     (!name arity c.
@@ -1370,27 +1371,37 @@ Proof
   >- (
     pop_assum mp_tac \\ rw[] \\ rw[]
     >- (
-      Cases_on`v` \\ fs[ref_rel_def] \\
+      Cases_on`v` \\ fs[ref_rel_def]
+      >- (
+        match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\
+        ONCE_REWRITE_TAC[CONJ_COMM] >>
+        first_assum(match_exists_tac o concl) >> simp[] >>
+        rpt strip_tac >>
+        match_mp_tac v_rel_UPDATE_REF >>
+        fs[IN_FRANGE_FLOOKUP]
+        \\ asm_exists_tac \\ fs[])
+      >- (
+        match_mp_tac v_rel_UPDATE_REF
+        \\ gvs [IN_FRANGE_FLOOKUP]
+        \\ goal_assum drule))
+    \\ res_tac \\ fs[]
+    \\ rw[] \\ fs[]
+    >- (
+      fs[INJ_DEF,FLOOKUP_DEF]
+      \\ metis_tac[] )
+    \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[]
+    >- (
       match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\
       ONCE_REWRITE_TAC[CONJ_COMM] >>
       first_assum(match_exists_tac o concl) >> simp[] >>
       rpt strip_tac >>
       match_mp_tac v_rel_UPDATE_REF >>
       fs[IN_FRANGE_FLOOKUP]
-      \\ asm_exists_tac \\ fs[] )
-    \\ res_tac \\ fs[]
-    \\ rw[] \\ fs[]
+      \\ asm_exists_tac \\ fs[])
     >- (
-      fs[INJ_DEF,FLOOKUP_DEF]
-      \\ metis_tac[] )
-    \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] \\
-    match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\
-    ONCE_REWRITE_TAC[CONJ_COMM] >>
-    first_assum(match_exists_tac o concl) >> simp[] >>
-    rpt strip_tac >>
-    match_mp_tac v_rel_UPDATE_REF >>
-    fs[IN_FRANGE_FLOOKUP]
-    \\ asm_exists_tac \\ fs[] )
+      match_mp_tac v_rel_UPDATE_REF
+      \\ gvs [IN_FRANGE_FLOOKUP]
+      \\ goal_assum drule))
 QED
 
 Theorem state_rel_NEW_REF:
@@ -1413,13 +1424,17 @@ Proof
   >- ( fs[SUBSET_DEF] )
   \\ res_tac \\ rw[]
   >- fs[FLOOKUP_DEF]
-  \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[] \\
-  match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\
-  ONCE_REWRITE_TAC[CONJ_COMM] >>
-  first_assum(match_exists_tac o concl) >> simp[] >>
-  rpt strip_tac >>
-  match_mp_tac v_rel_NEW_REF >>
-  fs[IN_FRANGE_FLOOKUP]
+  \\ Cases_on`x` \\ fs[ref_rel_def] \\ rw[]
+  >- (
+    match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) \\
+    ONCE_REWRITE_TAC[CONJ_COMM] >>
+    first_assum(match_exists_tac o concl) >> simp[] >>
+    rpt strip_tac >>
+    match_mp_tac v_rel_NEW_REF >>
+    fs[IN_FRANGE_FLOOKUP])
+  >- (
+    match_mp_tac v_rel_NEW_REF
+    \\ gvs [IN_FRANGE_FLOOKUP])
 QED
 
 (* semantic functions respect relation *)
@@ -1521,7 +1536,7 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem do_app[local]:
    (do_app op xs s1 = Rval (v,s2)) /\
@@ -1532,7 +1547,8 @@ Theorem do_app[local]:
    (op ≠ MemOp RefArray) ∧ (∀f. op ≠ MemOp (RefByte f)) ∧ (op ≠ MemOp UpdateByte) ∧
    (op ≠ MemOp FromListByte) ∧ op ≠ MemOp ConcatByteVec ∧
    (∀b. op ≠ MemOp (CopyByte b)) ∧ (∀c. op ≠ BlockOp (Constant c)) ∧
-   (∀n. op ≠ (FFI n)) ==>
+   (∀n. op ≠ (FFI n)) ∧
+   (∀t. op ≠ (ThunkOp t)) ==>
    ?w t2.
      (do_app (compile_op op) ys t1 = Rval (w,t2)) /\
      v_rel s1.max_app f t1.refs t1.code v w /\
@@ -3366,12 +3382,32 @@ Proof
   rw[FLOOKUP_UPDATE] \\
   first_x_assum drule \\ rw[] \\ simp[] \\
   rw[] >- ( fs[FLOOKUP_DEF] \\ METIS_TAC[LEAST_NOTIN_FDOM] ) \\
-  Cases_on`x` \\ fs[] \\
-  match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
-  ONCE_REWRITE_TAC[CONJ_COMM] >>
-  asm_exists_tac \\ fs[] \\ rw[] \\
-  match_mp_tac v_rel_NEW_REF \\
-  simp[LEAST_NOTIN_FDOM]
+  Cases_on`x` \\ fs[]
+  >- (
+    match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
+    ONCE_REWRITE_TAC[CONJ_COMM] >>
+    asm_exists_tac \\ fs[] \\ rw[] \\
+    match_mp_tac v_rel_NEW_REF \\
+    simp[LEAST_NOTIN_FDOM])
+  >- (match_mp_tac v_rel_NEW_REF \\ simp [LEAST_NOTIN_FDOM])
+QED
+
+Theorem rel_dest_thunk:
+  state_rel f s t ∧
+  v_rel s.max_app f t.refs t.code h y ∧
+  dest_thunk [h] s.refs = IsThunk m r1 ⇒
+  ∃r2.
+    dest_thunk y t.refs = IsThunk m r2 ∧
+    v_rel s.max_app f t.refs t.code r1 r2
+Proof
+  rw []
+  \\ gvs [oneline closSemTheory.dest_thunk_def, oneline dest_thunk_def,
+          AllCaseEqs(), PULL_EXISTS]
+  \\ (qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y` mp_tac
+      \\ reverse $ rw [Once v_rel_cases]
+      >- gvs [add_args_F]
+      >- rgs [Once cl_rel_cases]
+      \\ drule_all state_rel_refs_lookup \\ rw [] \\ gvs [])
 QED
 
 Theorem compile_exps_correct:
@@ -3735,8 +3771,10 @@ Proof
           \\ rename1 `_ x2 x3`
           \\ Cases_on `x3` \\ fs []
           \\ Cases_on `x2` \\ fs [ref_rel_def]
-          \\ first_x_assum (fn th => mp_tac th \\ match_mp_tac LIST_REL_mono)
-          \\ rpt strip_tac \\ match_mp_tac v_rel_union \\ simp [])
+          >- (
+            first_x_assum (fn th => mp_tac th \\ match_mp_tac LIST_REL_mono)
+            \\ rpt strip_tac \\ match_mp_tac v_rel_union \\ simp [])
+          >- (match_mp_tac v_rel_union \\ simp []))
         THEN1
          (fs [compile_oracle_inv_def]
           \\ fs [FUN_EQ_THM,shift_seq_def]
@@ -3947,6 +3985,108 @@ Proof
       \\ disj2_tac \\ CCONTR_TAC \\ fs []
       )
     \\ srw_tac[][]
+    \\ Cases_on `op = ThunkOp ForceThunk` >- (
+      ‘lookup (num_stubs s.max_app − 2) t1.code =
+       SOME (2,force_thunk_code)’ by fs [state_rel_def]
+      \\ last_x_assum assume_tac
+      \\ gvs [closSemTheory.evaluate_def, compile_exps_def]
+      \\ pairarg_tac \\ gvs [evaluate_def]
+      \\ Cases_on ‘evaluate (xs,env,s)’ \\ fs []
+      \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ fs []
+      \\ first_x_assum drule_all
+      \\ strip_tac
+      \\ reverse $ Cases_on ‘q’ \\ gvs []
+      >-
+       (qexists_tac ‘ck’ \\ fs []
+        \\ first_x_assum $ irule_at $ Pos hd \\ fs [])
+      \\ Cases_on ‘dest_thunk a r.refs’ \\ fs []
+      \\ rename [‘IsThunk thunk_mode’]
+      \\ qrefine ‘ck + ck2’ \\ gvs []
+      \\ drule evaluate_add_clock \\ simp [inc_clock_def]
+      \\ disch_then kall_tac
+      \\ ‘LENGTH a = 1’ by
+        gvs [oneline closSemTheory.dest_thunk_def,AllCaseEqs()]
+      \\ gvs [LENGTH_EQ_NUM_compute]
+      \\ drule_at (Pos last) rel_dest_thunk
+      \\ imp_res_tac evaluate_const \\ gvs []
+      \\ disch_then drule_all
+      \\ strip_tac \\ fs []
+      \\ Cases_on ‘thunk_mode’ \\ fs []
+      >- (gvs [] \\ first_x_assum $ irule_at $ Pos hd \\ fs [])
+      \\ simp [bvlSemTheory.find_code_def]
+      \\ drule bvlPropsTheory.evaluate_mono
+      \\ simp [subspt_lookup]
+      \\ disch_then drule \\ strip_tac \\ simp [dec_clock_def]
+      \\ gvs [closSemTheory.dec_clock_def]
+      \\ first_x_assum $ drule_at (Pat ‘state_rel _ _ _’)
+      \\ Cases_on ‘evaluate ([AppUnit (Var None 0)],[v],r)’ \\ gvs []
+      \\ Cases_on ‘q = Rerr (Rabort Rtype_error)’ \\ gvs []
+      \\ gvs [AppUnit_def] \\ simp [compile_exps_def]
+      \\ disch_then $ qspecl_then [‘aux1’, ‘[r2]’] mp_tac \\ gvs []
+      \\ impl_tac
+      >- (
+        gvs [closSemTheory.dec_clock_def] \\ rw []
+        >- (
+          drule_all (GEN_ALL compile_exps_IMP_code_installed) \\ rw []
+          \\ drule evaluate_mono \\ rw []
+          \\ gvs [code_installed_def, subspt_def, EVERY_EL] \\ rw []
+          \\ pairarg_tac \\ gvs []
+          \\ first_x_assum drule \\ rw []
+          \\ gvs [domain_lookup])
+        >- gvs [env_rel_def])
+      \\ rw [] \\ gvs []
+      \\ qexists ‘ck' + 1’ \\ gvs [PULL_EXISTS]
+      \\ reverse $ Cases_on ‘q’ \\ gvs [PULL_EXISTS]
+      >- (
+        goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs []
+        \\ qexists ‘e'’ \\ gvs [] \\ rw []
+        >- (
+          ‘e' ≠ Rabort Rtype_error’ by (Cases_on ‘e’ \\ gvs []) \\ gvs []
+          \\ qpat_x_assum ‘evaluate _ = (Rerr e',_)’ mp_tac
+          \\ simp [clos_tag_shift_def, mk_cl_call_def,
+                   generic_app_fn_location_def, evaluate_def, do_app_def,
+                   find_code_def]
+          \\ rpt (PURE_CASE_TAC \\ gvs [])
+          \\ simp [force_thunk_code_def, evaluate_def, do_app_def,
+                   find_code_def]
+          \\ rw [] \\ gvs [])
+        \\ metis_tac [SUBMAP_TRANS])
+      \\ Cases_on ‘update_thunk [h] r'.refs a’ \\ gvs [PULL_EXISTS]
+      \\ pop_assum mp_tac
+      \\ simp [oneline update_thunk_def, AllCaseEqs()] \\ rw []
+      \\ gvs [store_thunk_def, AllCaseEqs(), v_rel_SIMP, PULL_EXISTS]
+      \\ drule_at (Pat ‘FLOOKUP _ _ = SOME _’) state_rel_UPDATE_REF
+      \\ disch_then drule \\ gvs []
+      \\ ‘FLOOKUP f2' ptr = SOME r2'’ by metis_tac [FLOOKUP_SUBMAP]
+      \\ disch_then drule \\ gvs []
+      \\ imp_res_tac evaluate_const \\ gvs []
+      \\ `ref_rel (v_rel s.max_app f2' t2'.refs t2'.code)
+            (Thunk Evaluated v'') (Thunk Evaluated y')` by gvs [ref_rel_def]
+      \\ disch_then drule \\ gvs [] \\ rw []
+      \\ goal_assum $ drule_at (Pat ‘state_rel _ _ _’) \\ gvs []
+      \\ qexists ‘y'’ \\ gvs [] \\ rw []
+      >- (
+        qpat_x_assum ‘evaluate _ = (Rval [y'],_)’ mp_tac
+        \\ simp [clos_tag_shift_def, mk_cl_call_def,
+                 generic_app_fn_location_def, evaluate_def, do_app_def,
+                 AllCaseEqs(), PULL_EXISTS, dec_clock_def] \\ rw []
+        \\ gvs [find_code_def, AllCaseEqs()]
+        \\ (
+          simp [force_thunk_code_def, evaluate_def, do_app_def, EL_APPEND,
+                find_code_def, AllCaseEqs(), PULL_EXISTS, dec_clock_def]
+          \\ rw [] \\ gvs []
+          \\ drule_then drule (GEN_ALL state_rel_refs_lookup) \\ rw []
+          \\ metis_tac []))
+      >- (
+        irule v_rel_UPDATE_REF \\ gvs [TO_FLOOKUP]
+        \\ first_x_assum drule \\ rw [SF SFY_ss])
+      >- metis_tac [SUBMAP_TRANS]
+      >- (
+        ‘r2' ∈ (FRANGE f2')’ by (
+          gvs [TO_FLOOKUP] \\ first_x_assum drule \\ rw [SF SFY_ss])
+        \\ rw [FDIFF_FUPDATE]
+        \\ metis_tac [SUBMAP_TRANS]))
+    \\ srw_tac[][]
     \\ full_simp_tac(srw_ss())[cEval_def,compile_exps_def] \\ SRW_TAC [] [bEval_def]
     \\ `?p. evaluate (xs,env,s) = p` by full_simp_tac(srw_ss())[] \\ PairCases_on `p` \\ full_simp_tac(srw_ss())[]
     \\ `?cc. compile_exps s.max_app xs aux1 = cc` by full_simp_tac(srw_ss())[] \\ PairCases_on `cc` \\ full_simp_tac(srw_ss())[]
@@ -3961,6 +4101,11 @@ Proof
     \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
     \\ fs []
     \\ qexists_tac `ck` >> simp[]
+    \\ `compile_op op ≠ ThunkOp ForceThunk` by (
+      CCONTR_TAC \\ gvs []
+      \\ gvs [oneline compile_op_def, AllCaseEqs()]
+      \\ gvs [oneline compile_const_def, AllCaseEqs()]
+      \\ pairarg_tac \\ gvs [])
     \\ reverse(Cases_on `do_app op (REVERSE a) p1`) \\ full_simp_tac(srw_ss())[] >- (
       srw_tac[][] >>
       first_x_assum(mp_tac o INST_TYPE[beta|->gamma] o MATCH_MP
@@ -4045,11 +4190,15 @@ Proof
         \\ RES_TAC \\ full_simp_tac(srw_ss())[]
         \\ `qq <> m` by (REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_DEF] \\ SRW_TAC [] [])
         \\ Cases_on`x`>>full_simp_tac(srw_ss())[]
-        \\ Q.PAT_X_ASSUM `LIST_REL (v_rel _ f2 t2.refs t2.code) xs' ys'` MP_TAC
-        \\ MATCH_MP_TAC listTheory.LIST_REL_mono
-        \\ REPEAT STRIP_TAC
-        \\ MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]
-        \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[])
+        >- (
+          Q.PAT_X_ASSUM `LIST_REL (v_rel _ f2 t2.refs t2.code) xs' ys'` MP_TAC
+          \\ MATCH_MP_TAC listTheory.LIST_REL_mono
+          \\ REPEAT STRIP_TAC
+          \\ MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]
+          \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[])
+        >- (
+          MATCH_MP_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]
+          \\ MATCH_MP_TAC v_rel_NEW_F \\ full_simp_tac(srw_ss())[]))
       \\ conj_tac >-
        (full_simp_tac(srw_ss())[SUBMAP_DEF,FAPPLY_FUPDATE_THM] \\ SRW_TAC [][] \\ METIS_TAC [] ) >>
       full_simp_tac(srw_ss())[SUBMAP_DEF,FAPPLY_FUPDATE_THM,FDIFF_def,DRESTRICT_DEF] >> srw_tac[][] >> METIS_TAC[])
@@ -4105,11 +4254,15 @@ Proof
         \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
         \\ qmatch_rename_tac`ref_rel _ ref _`
         \\ Cases_on`ref` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
-        \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
-        \\ MATCH_MP_TAC listTheory.LIST_REL_mono
-        \\ REPEAT STRIP_TAC
-        \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
-        \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
+          \\ MATCH_MP_TAC listTheory.LIST_REL_mono
+          \\ REPEAT STRIP_TAC
+          \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []))
       \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
       \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def])
     \\ Cases_on `op = MemOp RefArray` \\ full_simp_tac(srw_ss())[] THEN1 (
@@ -4161,16 +4314,23 @@ Proof
             full_simp_tac(srw_ss())[SUBSET_DEF] >> res_tac >>
             var_eq_tac >>
             full_simp_tac(srw_ss())[Abbr`m`,LEAST_NOTIN_FDOM] ) >>
-          Cases_on`x`>>full_simp_tac(srw_ss())[] >>
-          match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
-          ONCE_REWRITE_TAC[CONJ_COMM] >>
-          first_assum(match_exists_tac o concl) >> simp[] >>
-          rpt strip_tac >>
-          match_mp_tac v_rel_NEW_REF >>
-          reverse conj_tac >- (
-            simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
-          match_mp_tac v_rel_NEW_F >>
-          simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM] ) >>
+          Cases_on`x`>>full_simp_tac(srw_ss())[]
+          >- (
+            match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
+            ONCE_REWRITE_TAC[CONJ_COMM] >>
+            first_assum(match_exists_tac o concl) >> simp[] >>
+            rpt strip_tac >>
+            match_mp_tac v_rel_NEW_REF >>
+            reverse conj_tac >- (
+              simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
+            match_mp_tac v_rel_NEW_F >>
+            simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])
+          >- (
+            match_mp_tac v_rel_NEW_REF >>
+            reverse conj_tac >- (
+              simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
+            match_mp_tac v_rel_NEW_F >>
+            simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])) >>
         strip_tac >> var_eq_tac >> simp[] >>
         simp[LIST_REL_REPLICATE_same] >> srw_tac[][] >>
         match_mp_tac v_rel_NEW_REF >>
@@ -4243,16 +4403,23 @@ Proof
             full_simp_tac(srw_ss())[SUBSET_DEF] >> res_tac >>
             var_eq_tac >>
             full_simp_tac(srw_ss())[Abbr`m`,LEAST_NOTIN_FDOM] ) >>
-          Cases_on`x`>>full_simp_tac(srw_ss())[] >>
-          match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
-          ONCE_REWRITE_TAC[CONJ_COMM] >>
-          first_assum(match_exists_tac o concl) >> simp[] >>
-          rpt strip_tac >>
-          match_mp_tac v_rel_NEW_REF >>
-          reverse conj_tac >- (
-            simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
-          match_mp_tac v_rel_NEW_F >>
-          simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM] ) >>
+          Cases_on`x`>>full_simp_tac(srw_ss())[]
+          >- (
+            match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
+            ONCE_REWRITE_TAC[CONJ_COMM] >>
+            first_assum(match_exists_tac o concl) >> simp[] >>
+            rpt strip_tac >>
+            match_mp_tac v_rel_NEW_REF >>
+            reverse conj_tac >- (
+              simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
+            match_mp_tac v_rel_NEW_F >>
+            simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])
+          >- (
+             match_mp_tac v_rel_NEW_REF >>
+            reverse conj_tac >- (
+              simp[Abbr`pp`,LEAST_NOTIN_FDOM] ) >>
+            match_mp_tac v_rel_NEW_F >>
+            simp[Abbr`pp`,Abbr`qq`,LEAST_NOTIN_FDOM])) >>
         strip_tac >> var_eq_tac >> simp[]) >>
       conj_tac >- (
         match_mp_tac SUBMAP_TRANS >>
@@ -4303,11 +4470,15 @@ Proof
           \\ SIMP_TAC std_ss [INJ_DEF,FRANGE_DEF] \\ full_simp_tac(srw_ss())[FLOOKUP_DEF]
           \\ METIS_TAC [])
         \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ Cases_on`x` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
-        \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
-        \\ MATCH_MP_TAC listTheory.LIST_REL_mono
-        \\ REPEAT STRIP_TAC
-        \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
-        \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
+          \\ MATCH_MP_TAC listTheory.LIST_REL_mono
+          \\ REPEAT STRIP_TAC
+          \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []))
       \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
       \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def])
     \\ Cases_on `∃n. op = FFI n` \\ full_simp_tac(srw_ss())[] THEN1 (
@@ -4327,6 +4498,9 @@ Proof
       >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[])
       \\ Cases_on`x` \\ full_simp_tac(srw_ss())[]
       \\ Cases_on`x'` \\ full_simp_tac(srw_ss())[]
+      >~ [`FLOOKUP _ _ = SOME (ValueArray _)`]
+      >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[] >> rveq)
+      >~ [`FLOOKUP _ _ = SOME (Thunk _ _)`]
       >- (fs[state_rel_def] >> res_tac >> fs[] >> rfs[] >> rveq)
       \\ Cases_on`call_FFI p1.ffi (ExtCall n) l l''`
       \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]
@@ -4367,11 +4541,15 @@ Proof
           \\ SIMP_TAC std_ss [INJ_DEF,FRANGE_DEF] \\ full_simp_tac(srw_ss())[FLOOKUP_DEF]
           \\ rveq \\ METIS_TAC [])
         \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [] \\ Cases_on`x` >> full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
-        \\ Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
-        \\ MATCH_MP_TAC listTheory.LIST_REL_mono
-        \\ REPEAT STRIP_TAC
-        \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
-        \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          Q.PAT_X_ASSUM `LIST_REL pp xs' ws''` MP_TAC
+          \\ MATCH_MP_TAC listTheory.LIST_REL_mono
+          \\ REPEAT STRIP_TAC
+          \\ MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
+        >- (
+          MATCH_MP_TAC v_rel_UPDATE_REF \\ full_simp_tac(srw_ss())[]
+          \\ full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC []))
       \\ `m IN FRANGE f2` by (full_simp_tac(srw_ss())[FLOOKUP_DEF,FRANGE_DEF] \\ METIS_TAC [])
       \\ full_simp_tac(srw_ss())[SUBMAP_DEF,FDIFF_def,DRESTRICT_DEF,FAPPLY_FUPDATE_THM, add_args_def]
       \\ rveq \\ fs[])
@@ -4419,12 +4597,16 @@ Proof
         rw[FLOOKUP_UPDATE] \\
         first_x_assum drule \\ rw[] \\ simp[] \\
         rw[] >- ( fs[FLOOKUP_DEF] \\ METIS_TAC[LEAST_NOTIN_FDOM] ) \\
-        Cases_on`x''` \\ fs[] \\
-        match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
-        ONCE_REWRITE_TAC[CONJ_COMM] >>
-        asm_exists_tac \\ fs[] \\ rw[] \\
-        match_mp_tac v_rel_NEW_REF \\
-        simp[LEAST_NOTIN_FDOM])
+        Cases_on`x''` \\ fs[]
+        >- (
+          match_mp_tac(MP_CANON(GEN_ALL LIST_REL_mono)) >>
+          ONCE_REWRITE_TAC[CONJ_COMM] >>
+          asm_exists_tac \\ fs[] \\ rw[] \\
+          match_mp_tac v_rel_NEW_REF \\
+          simp[LEAST_NOTIN_FDOM])
+        >- (
+          match_mp_tac v_rel_NEW_REF
+          \\ simp [LEAST_NOTIN_FDOM]))
       \\ simp[]
       \\ qmatch_goalsub_abbrev_tac`t2.refs |+ (ptr,_)`
       \\ `ptr ∉ FRANGE f2`
@@ -4484,11 +4666,15 @@ Proof
       \\ res_tac \\ simp[]
       \\ rw[] \\ fs[] \\ rfs[IN_FRANGE_FLOOKUP] \\ rw[]
       \\ Cases_on`x` \\ fs[]
-      \\ match_mp_tac (MP_CANON(GEN_ALL LIST_REL_mono))
-      \\ ONCE_REWRITE_TAC[CONJ_COMM] >>
-      asm_exists_tac \\ fs[] \\ rw[] \\
-      match_mp_tac v_rel_NEW_REF
-      \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM] )
+      >- (
+        match_mp_tac (MP_CANON(GEN_ALL LIST_REL_mono))
+        \\ ONCE_REWRITE_TAC[CONJ_COMM] >>
+        asm_exists_tac \\ fs[] \\ rw[] \\
+        match_mp_tac v_rel_NEW_REF
+        \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM])
+      >- (
+        match_mp_tac v_rel_NEW_REF
+        \\ fs[Abbr`ptr`,LEAST_NOTIN_FDOM]))
     \\ Cases_on`∃fl. op = MemOp XorByte` \\ fs[] >- (
       fs[closSemTheory.do_app_def,bvlSemTheory.do_app_def,PULL_EXISTS]
       \\ fs[case_eq_thms,v_case_eq_thms,PULL_EXISTS,SWAP_REVERSE_SYM,AllCaseEqs()]
@@ -4541,6 +4727,81 @@ Proof
       \\ fs[FDIFF_def,DRESTRICT_DEF,SUBMAP_DEF,FAPPLY_FUPDATE_THM]
       \\ rw[DRESTRICT_DEF,FAPPLY_FUPDATE_THM] \\ rw[]
       \\ fs[IN_FRANGE_FLOOKUP] )
+    \\ Cases_on `∃t. op = ThunkOp t` \\ gvs [] >- (
+      Cases_on `t` \\ gvs []
+      >- (
+        gvs [closSemTheory.do_app_def, do_app_def, AllCaseEqs(), PULL_EXISTS]
+        \\ qabbrev_tac `pp = LEAST ptr. ptr NOTIN FDOM p1.refs`
+        \\ qabbrev_tac `qq = LEAST ptr. ptr NOTIN FDOM t2.refs`
+        \\ qexists `f2 |+ (pp,qq)` \\ gvs []
+        \\ `¬(pp ∈ FDOM p1.refs)` by (unabbrev_all_tac \\ rw [LEAST_NOTIN_FDOM])
+        \\ `¬(qq ∈ FDOM t2.refs)` by (unabbrev_all_tac \\ rw [LEAST_NOTIN_FDOM])
+        \\ `¬(pp ∈ FDOM f2)` by gvs [state_rel_def]
+        \\ `¬(qq ∈ FRANGE f2)` by
+          (rpt strip_tac \\ gvs [state_rel_def, SUBSET_DEF] \\ res_tac)
+        \\ `FRANGE (f2 \\ pp) = FRANGE f2` by
+          (gvs [FRANGE_DEF, finite_mapTheory.DOMSUB_FAPPLY_THM, EXTENSION]
+           \\ metis_tac [])
+        \\ gvs []
+        \\ fs [list_CASE_same] \\ rveq
+        \\ conj_tac >- (gvs [v_rel_cases, FLOOKUP_UPDATE])
+        \\ conj_tac
+        >- (
+          gvs [state_rel_def, FLOOKUP_UPDATE]
+          \\ rpt strip_tac
+          >- (
+            qpat_x_assum `LIST_REL ppp qqq rrr` mp_tac
+            \\ match_mp_tac listTheory.LIST_REL_mono
+            \\ rpt strip_tac
+            \\ match_mp_tac OPTREL_v_rel_NEW_REF \\ gvs []
+            \\ match_mp_tac OPTREL_v_rel_NEW_F \\ gvs [])
+          >- (
+            qpat_x_assum `INJ ($' f2) (FDOM _) (FRANGE f2)` mp_tac
+            \\ rpt (qpat_x_assum `INJ xx yy zz` (K all_tac))
+            \\ gvs [INJ_DEF,FAPPLY_FUPDATE_THM,FRANGE_DEF]
+            \\ rpt strip_tac \\ metis_tac [])
+          >- (
+            ntac 2 (pop_assum mp_tac) \\ rw[]
+            \\ first_x_assum match_mp_tac \\ asm_exists_tac \\ rw[])
+          \\ Cases_on `n = pp` \\ gvs []
+          >- (
+            gvs []
+            \\ imp_res_tac evaluate_const
+            \\ match_mp_tac v_rel_NEW_REF \\ gvs []
+            \\ match_mp_tac v_rel_NEW_F \\ gvs [])
+          \\ res_tac \\ gvs []
+          \\ `qq ≠ m` by (strip_tac \\ gvs [FLOOKUP_DEF])
+          \\ Cases_on `x` \\ gvs []
+          >- (
+            qpat_x_assum `LIST_REL (v_rel _ f2 t2.refs t2.code) l ws` mp_tac
+            \\ match_mp_tac LIST_REL_mono
+            \\ rpt strip_tac
+            \\ match_mp_tac v_rel_NEW_REF \\ gvs []
+            \\ match_mp_tac v_rel_NEW_F \\ gvs [])
+          >- (
+            match_mp_tac v_rel_NEW_REF \\ gvs []
+            \\ match_mp_tac v_rel_NEW_F \\ gvs []))
+        \\ conj_tac
+        >- (gvs [SUBMAP_DEF, FAPPLY_FUPDATE_THM] \\ metis_tac [])
+        \\ gvs [SUBMAP_DEF, FAPPLY_FUPDATE_THM, FDIFF_def, DRESTRICT_DEF]
+        \\ metis_tac [])
+      >- (
+        gvs [closSemTheory.do_app_def, do_app_def, AllCaseEqs(), PULL_EXISTS]
+        \\ Cases_on `a` \\ gvs []
+        \\ qpat_x_assum `v_rel _ _ _ _ (RefPtr _ _) y'` mp_tac
+        \\ reverse $ rw [Once v_rel_cases]
+        >- gvs [add_args_F]
+        >- rgs [Once cl_rel_cases]
+        \\ drule_all (GEN_ALL state_rel_refs_lookup) \\ rw [] \\ gvs []
+        \\ goal_assum $ drule_at Any \\ gvs [] \\ rw []
+        >- (
+          drule (GEN_ALL state_rel_UPDATE_REF)
+          \\ rpt (disch_then drule)
+          \\ disch_then irule \\ gvs []
+          \\ imp_res_tac evaluate_const \\ gvs [])
+        >- (
+          `r2 ∈ (FRANGE f2)` by (rgs [TO_FLOOKUP] \\ rw [SF SFY_ss])
+          \\ gvs [FDIFF_FUPDATE] \\ rw [])))
     \\ imp_res_tac closSemTheory.do_app_const
     \\ first_x_assum(mp_tac o INST_TYPE[beta|->gamma] o MATCH_MP
          (GEN_ALL(REWRITE_RULE[GSYM AND_IMP_INTRO]do_app)))
@@ -4722,7 +4983,7 @@ Proof
       \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM]
       \\ REPEAT STRIP_TAC \\ SRW_TAC [] []
       \\ ASSUME_TAC (EXISTS_NOT_IN_refs |>
-           SIMP_RULE std_ss [whileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[])
+           SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS]) \\ full_simp_tac(srw_ss())[])
     \\ MATCH_MP_TAC IMP_IMP \\ reverse STRIP_TAC
     >- (REPEAT STRIP_TAC
         \\ qexists_tac`ck'`
@@ -4738,7 +4999,7 @@ Proof
         \\ full_simp_tac(srw_ss())[DRESTRICT_DEF,FAPPLY_FUPDATE_THM]
         \\ REPEAT STRIP_TAC \\ SRW_TAC [] []
         \\ ASSUME_TAC (EXISTS_NOT_IN_refs |>
-             SIMP_RULE std_ss [whileTheory.LEAST_EXISTS])
+             SIMP_RULE std_ss [WhileTheory.LEAST_EXISTS])
         \\ full_simp_tac(srw_ss())[])
     \\ conj_tac >- simp []
     \\ reverse (REPEAT STRIP_TAC) THEN1
@@ -4754,35 +5015,38 @@ Proof
         \\ REPEAT STRIP_TAC \\ RES_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_UPDATE]
         \\ `m <> rr` by (REPEAT STRIP_TAC \\ full_simp_tac(srw_ss())[FLOOKUP_DEF]) \\ full_simp_tac(srw_ss())[]
         \\ Cases_on`x'''`>>full_simp_tac(srw_ss())[]
-        \\ Q.PAT_X_ASSUM `LIST_REL ppp xs ys'` MP_TAC
+        >- (
+          Q.PAT_X_ASSUM `LIST_REL ppp xs ys'` MP_TAC
+          \\ MATCH_MP_TAC listTheory.LIST_REL_mono
+          \\ IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[])
+        >- (IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[]))
+      \\ TRY (simp[] \\ NO_TAC)
+      \\ MATCH_MP_TAC env_rel_APPEND
+      \\ reverse STRIP_TAC THEN1
+       (UNABBREV_ALL_TAC \\ full_simp_tac(srw_ss())[]
+        \\ MATCH_MP_TAC (env_rel_NEW_REF |> GEN_ALL) \\ full_simp_tac(srw_ss())[])
+      \\ srw_tac[][LIST_REL_EL_EQN, LENGTH_GENLIST, LENGTH_MAP2, ADD1]
+      \\ DEP_REWRITE_TAC [el_map2]
+      \\ conj_tac >- gvs []
+      \\ srw_tac[][v_rel_cases, cl_rel_cases]
+      \\ full_simp_tac(srw_ss())[]
+      \\ simp_tac std_ss [SF DNF_ss]
+      \\ disj2_tac
+      \\ qexists_tac `ys`
+      \\ qabbrev_tac `exps = ll++[x'']`
+      \\ `LENGTH ll + 1 = LENGTH exps` by full_simp_tac(srw_ss())[Abbr `exps`]
+      \\ Q.EXISTS_TAC `ZIP (exps,GENLIST (\i.x+num_stubs s.max_app+2*i) (LENGTH exps))`
+      \\ full_simp_tac(srw_ss())[LENGTH_ZIP, EL_MAP, LENGTH_MAP, EL_ZIP, MAP_ZIP]
+      \\ `?num e. EL n exps = (num, e)` by metis_tac [pair_CASES]
+      \\ `1 < LENGTH exps` by (full_simp_tac(srw_ss())[] \\ DECIDE_TAC)
+      \\ full_simp_tac(srw_ss())[Abbr `t1refs`,FLOOKUP_UPDATE]
+      \\ `MAP FST ll ++ [FST x''] = MAP FST exps` by srw_tac[][Abbr `exps`]
+      \\ simp [EL_MAP]
+      \\ srw_tac[][]
+      THEN1
+       (Q.PAT_X_ASSUM `LIST_REL (v_rel _ f1 t1.refs t1.code) x' ys` MP_TAC
         \\ MATCH_MP_TAC listTheory.LIST_REL_mono
         \\ IMP_RES_TAC v_rel_NEW_REF \\ full_simp_tac(srw_ss())[])
-    \\ MATCH_MP_TAC env_rel_APPEND
-    \\ reverse STRIP_TAC THEN1
-     (UNABBREV_ALL_TAC \\ full_simp_tac(srw_ss())[]
-      \\ MATCH_MP_TAC (env_rel_NEW_REF |> GEN_ALL) \\ full_simp_tac(srw_ss())[])
-    \\ srw_tac[][LIST_REL_EL_EQN, LENGTH_GENLIST, LENGTH_MAP2, ADD1]
-    \\ DEP_REWRITE_TAC [el_map2]
-    \\ conj_tac >- gvs []
-    \\ srw_tac[][v_rel_cases, cl_rel_cases]
-    \\ full_simp_tac(srw_ss())[]
-    \\ simp_tac std_ss [SF DNF_ss]
-    \\ disj2_tac
-    \\ qexists_tac `ys`
-    \\ qabbrev_tac `exps = ll++[x'']`
-    \\ `LENGTH ll + 1 = LENGTH exps` by full_simp_tac(srw_ss())[Abbr `exps`]
-    \\ Q.EXISTS_TAC `ZIP (exps,GENLIST (\i.x+num_stubs s.max_app+2*i) (LENGTH exps))`
-    \\ full_simp_tac(srw_ss())[LENGTH_ZIP, EL_MAP, LENGTH_MAP, EL_ZIP, MAP_ZIP]
-    \\ `?num e. EL n exps = (num, e)` by metis_tac [pair_CASES]
-    \\ `1 < LENGTH exps` by (full_simp_tac(srw_ss())[] \\ DECIDE_TAC)
-    \\ full_simp_tac(srw_ss())[Abbr `t1refs`,FLOOKUP_UPDATE]
-    \\ `MAP FST ll ++ [FST x''] = MAP FST exps` by srw_tac[][Abbr `exps`]
-    \\ simp [EL_MAP,EL_ZIP]
-    \\ srw_tac[][]
-    THEN1
-     (Q.PAT_X_ASSUM `LIST_REL (v_rel _ f1 t1.refs t1.code) x' ys` MP_TAC
-      \\ MATCH_MP_TAC listTheory.LIST_REL_mono
-      \\ METIS_TAC [v_rel_NEW_REF])
     THEN1
      (full_simp_tac(srw_ss())[state_rel_def, SUBSET_DEF] >> metis_tac [])
     THEN1
@@ -7394,6 +7658,7 @@ Theorem compile_prog_semantics:
    FEVERY (λp. every_Fn_SOME [SND (SND p)]) code1 ∧
    FEVERY (λp. every_Fn_vs_SOME [SND (SND p)]) code1 ∧
    lookup nsm1 code2 = SOME (0, init_globals max_app (num_stubs max_app + start)) /\
+   lookup (num_stubs max_app - 2) code2 = SOME (2,force_thunk_code) ∧
    compile_oracle_inv max_app code1 cc1 co1 code2 cc2 co2 ∧
    code_installed prog2 code2
    ⇒
@@ -8190,7 +8455,8 @@ Theorem syntax_oracle_ok_to_oracle_inv:
     (pure_cc (compile_inc c.max_app) cc) co'
     (fromAList
        (toAList (init_code c.max_app) ++
-        [(num_stubs c.max_app - 1,0,
+        [(num_stubs c.max_app − 2,2,force_thunk_code);
+         (num_stubs c.max_app - 1,0,
           init_globals c.max_app (c''.start + num_stubs c.max_app))] ++
         compile_prog c.max_app prog')) cc
     (pure_co (compile_inc c.max_app) ∘ co')
@@ -8653,6 +8919,7 @@ Proof
     \\ imp_res_tac ALOOKUP_MEM
     \\ metis_tac[] )
   \\ conj_tac >- ( irule ALOOKUP_ALL_DISTINCT_MEM \\ fs[] )
+  \\ conj_tac >- ( irule ALOOKUP_ALL_DISTINCT_MEM \\ fs[] )
   \\ simp[Once CONJ_ASSOC]
   \\ conj_tac >- (
     fs[compile_common_def]
@@ -8813,7 +9080,7 @@ Theorem compile_exps_code_labels:
      ⊆
      IMAGE (((+) (num_stubs app))) (BIGUNION (set (MAP get_code_labels es1))) ∪
      BIGUNION (set (MAP (get_code_labels o SND o SND) aux1)) ∪
-     domain (init_code app)
+     domain (init_code app) ∪ {num_stubs app − 2}
 Proof
   recInduct clos_to_bvlTheory.compile_exps_ind
   \\ rw [clos_to_bvlTheory.compile_exps_def] \\ rw []
@@ -8910,7 +9177,7 @@ Theorem compile_prog_code_labels:
    BIGUNION (set (MAP (get_code_labels o SND o SND)
                    (compile_prog max_app prog))) SUBSET
    IMAGE (((+) (clos_to_bvl$num_stubs max_app))) (BIGUNION (set (MAP get_code_labels (MAP (SND o SND) prog)))) ∪
-   domain (init_code max_app)
+   domain (init_code max_app) ∪ {num_stubs max_app − 2}
 Proof
   rw[clos_to_bvlTheory.compile_prog_def]
   \\ pairarg_tac \\ fs[]
diff --git a/compiler/backend/proofs/data_liveProofScript.sml b/compiler/backend/proofs/data_liveProofScript.sml
index d72aa848c2..b026e28c5b 100644
--- a/compiler/backend/proofs/data_liveProofScript.sml
+++ b/compiler/backend/proofs/data_liveProofScript.sml
@@ -51,7 +51,7 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]];
 
 Triviality state_rel_IMP_do_app_aux:
   (do_app_aux op args s1 = Rval (v,s2)) /\
@@ -74,6 +74,8 @@ Proof
   \\ fs [state_rel_def,consume_space_def,case_eq_thms,do_install_def,UNCURRY]
   \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality]
   \\ SRW_TAC [] [] \\ fs[]
+  \\ gvs [AllCaseEqs()]
+  \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality]
 QED
 
 Triviality state_rel_IMP_do_app:
@@ -113,6 +115,8 @@ Proof
   \\ fs [state_rel_def,consume_space_def,case_eq_thms,do_install_def,UNCURRY]
   \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality]
   \\ SRW_TAC [] [] \\ fs[]
+  \\ gvs [AllCaseEqs()]
+  \\ ASM_SIMP_TAC (srw_ss()) [dataSemTheory.state_component_equality]
 QED
 
 Triviality state_rel_IMP_do_app_err:
@@ -318,6 +322,233 @@ Proof
       \\ MATCH_MP_TAC IMP_IMP \\ STRIP_TAC
       \\ ONCE_REWRITE_TAC [EQ_SYM_EQ] \\ REPEAT STRIP_TAC \\ fs []
       \\ fs [state_rel_def,domain_union]))
+  THEN1 ( (* Force *)
+    Cases_on ‘ret’ \\ gvs [evaluate_def, compile_def]
+    >- (
+      Cases_on ‘get_var src s.locals’ \\ gvs []
+      \\ ‘get_var src t1.locals = get_var src s.locals’
+        by gvs [state_rel_def, get_var_def] \\ gvs []
+      \\ ‘t1.refs = s.refs’ by gvs [state_rel_def] \\ gvs []
+      \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs []
+      \\ Cases_on ‘t’ \\ gvs []
+      >- gvs [state_rel_def, flush_state_def]
+      \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes’
+        by gvs [state_rel_def] \\ gvs []
+      \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’
+      \\ gvs []
+      \\ Cases_on ‘x'’ \\ gvs []
+      \\ Cases_on ‘r’ \\ gvs []
+      \\ ‘t1.clock = s.clock’ by gvs [state_rel_def] \\ gvs []
+      \\ Cases_on ‘s.clock = 0’ \\ gvs []
+      >- gvs [state_rel_def, flush_state_def]
+      \\ Cases_on ‘evaluate (q',call_env q r' (dec_clock s))’ \\ gvs []
+      \\ Cases_on ‘q''’ \\ gvs []
+      \\ fs []
+      \\ rename1 ‘evaluate (q',call_env q r' (dec_clock s)) = (SOME res2,s2)’
+      \\ qspecl_then [‘q'’,‘call_env q r' (dec_clock s)’] mp_tac
+                     evaluate_stack_swap
+      \\ fs []
+      \\ `∃sm sfs. call_env q r' (dec_clock t1) = call_env q r' (dec_clock s)
+            with <| stack := t1.stack; stack_max := sm; safe_for_space := sfs;
+                    peak_heap_length := t1.peak_heap_length |>`
+        by fs [call_env_def, dec_clock_def, state_rel_def,
+               state_component_equality, flush_state_def]
+      \\ Cases_on ‘res2’ \\ fs []
+      >- (
+        fs [call_env_def,dec_clock_def] \\ rpt strip_tac
+        \\ ‘LENGTH s.stack = LENGTH t1.stack’ by fs [state_rel_def]
+        \\ first_x_assum $ qspec_then ‘t1.stack’ mp_tac \\ fs []
+        \\ strip_tac
+        \\ drule_all_then (qspecl_then
+                             [‘sm’,‘sfs’,‘t1.peak_heap_length’]
+                             strip_assume_tac)
+             evaluate_smx_safe_peak_swap
+        \\ fs [state_rel_def])
+      \\ Cases_on ‘e’ \\ fs []
+      >- (
+        rpt strip_tac
+        \\ pop_assum $ qspec_then ‘t1.stack’ mp_tac
+        \\ qpat_x_assum ‘!x.bbb’ (mp_tac o GSYM)
+        \\ rename1
+             ‘jump_exc (call_env q r' (dec_clock s)) = SOME s3’
+        \\ qpat_x_assum ‘jump_exc (call_env q r' (dec_clock s)) = SOME s3’
+              (mp_tac o GSYM)
+        \\ simp [call_env_def, dec_clock_def, Once jump_exc_def, LET_THM]
+        \\ ntac 2 CASE_TAC \\ strip_tac
+        \\ pop_assum (fn th => full_simp_tac std_ss [GSYM th])
+        \\ asm_simp_tac (srw_ss()) [Once jump_exc_def]
+        \\ simp [Once jump_exc_def]
+        \\ ntac 2 CASE_TAC \\ fs [] \\ strip_tac
+        \\ `s.handler = t1.handler /\
+            LENGTH s.stack = LENGTH t1.stack` by fs [state_rel_def]
+        \\ asm_simp_tac (srw_ss()) [Once jump_exc_def]
+        \\ rpt strip_tac \\ fs []
+        \\ drule_all_then (qspecl_then
+                             [‘sm’,‘sfs’,‘t1.peak_heap_length’]
+                             strip_assume_tac)
+             evaluate_smx_safe_peak_swap
+        \\ fs[state_rel_def])
+      \\ Cases_on ‘a’ \\ fs []
+      \\ (
+        fs [call_env_def,dec_clock_def] \\ rpt strip_tac
+        \\ ‘LENGTH s.stack = LENGTH t1.stack’ by fs [state_rel_def]
+        \\ first_x_assum $ qspec_then ‘t1.stack’ mp_tac \\ fs []
+        \\ rw [state_rel_def]
+        \\ drule_all_then (qspecl_then
+                             [‘sm’,‘sfs’,‘t1.peak_heap_length’]
+                             strip_assume_tac)
+            evaluate_smx_safe_peak_swap
+        \\ fs[state_rel_def]))
+    \\ Cases_on ‘x’
+    \\ rename1 ‘(d,l1) = compile (Force (SOME (v,names)) loc src) l2’
+    \\ fs [compile_def, LET_DEF, evaluate_def]
+    \\ ‘get_var src t1.locals = get_var src s.locals’
+      by gvs [state_rel_def, get_var_def] \\ gvs []
+    \\ Cases_on ‘get_var src s.locals’ \\ gvs []
+    \\ ‘t1.refs = s.refs’ by gvs [state_rel_def] \\ gvs []
+    \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs []
+    \\ Cases_on ‘t’ \\ gvs []
+    >- (
+      gvs [AllCaseEqs(), PULL_EXISTS, cut_env_def, state_rel_def, set_var_def]
+      \\ gvs [SF DNF_ss, lookup_insert, lookup_inter_alt]
+      \\ gvs [SUBSET_DEF, domain_lookup] \\ rw []
+      \\ ntac 2 (first_x_assum drule_all \\ rw []))
+    \\ ‘t1.code = s.code ∧ t1.stack_frame_sizes = s.stack_frame_sizes ∧
+        t1.clock = s.clock’
+      by gvs [state_rel_def] \\ gvs []
+    \\ Cases_on ‘find_code (SOME loc) [x; v'] s.code s.stack_frame_sizes’
+    \\ gvs []
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘r’ \\ gvs []
+    \\ Cases_on ‘cut_env names s.locals’ \\ fs []
+    \\ fs [cut_env_def] \\ reverse (srw_tac [] [])
+    >- (
+      pop_assum mp_tac \\ fs []
+      \\ fs [SUBSET_DEF,domain_list_insert,domain_inter,
+             domain_delete,state_rel_def]
+      \\ rpt strip_tac \\ imp_res_tac get_vars_IMP_domain
+      \\ fs [domain_lookup] \\ metis_tac [])
+    \\ Cases_on ‘s.clock = 0’ \\ gvs []
+    >- gvs [state_rel_def, call_env_def, push_env_def, dec_clock_def,
+            flush_state_def]
+    \\ qabbrev_tac `t5 = call_env q r' (push_env
+             ((inter t1.locals (inter names (delete v l2)))) F (dec_clock t1))`
+    \\ `?sfsp smax lss. (call_env q r' (push_env ((inter s.locals names)) F
+                                                 (dec_clock s))
+          with <| locals_size := lss;
+                  safe_for_space := sfsp;
+                  peak_heap_length := t5.peak_heap_length;
+                  stack := t5.stack;
+                  stack_max := smax |>) = t5` by
+     (unabbrev_all_tac
+      \\ fs [call_env_def,push_env_def,dec_clock_def,state_rel_def,
+             state_component_equality]) \\ fs []
+    \\ qabbrev_tac `t4 =
+         call_env q r' (push_env ((inter s.locals names)) F (dec_clock s))`
+    \\ ‘LENGTH t4.stack = LENGTH t5.stack’ by
+     (unabbrev_all_tac \\ fs [call_env_def, push_env_def, dec_clock_def]
+      \\ fs [state_rel_def])
+    \\ qspecl_then [‘q'’,‘t4’] mp_tac evaluate_stack_swap
+    \\ Cases_on ‘evaluate (q',t4)’ \\ fs []
+    \\ Cases_on ‘q''’ \\ fs [] \\ Cases_on ‘x'’ \\ fs []
+    >- (
+      rpt strip_tac
+      \\ first_x_assum $ qspec_then ‘t5.stack’ mp_tac \\ fs []
+      \\ rpt strip_tac \\ fs [] \\ simp [pop_env_def]
+      \\ unabbrev_all_tac \\ fs [call_env_def, push_env_def]
+      \\ fs [pop_env_def] \\ fs [state_rel_def, set_var_def]
+      \\ qmatch_asmsub_abbrev_tac  ‘evaluate (q',p) = (SOME _, ss)’
+      \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’
+      \\ drule_all_then (qspecl_then [‘ss'.stack_max’
+                                     ,‘ss'.safe_for_space’
+                                     ,‘ss'.peak_heap_length’] assume_tac)
+                        evaluate_smx_safe_peak_swap
+      \\ fs []
+      \\ `ss' = p with <| stack_max := ss'.stack_max;
+                          safe_for_space := ss'.safe_for_space;
+                          peak_heap_length := ss'.peak_heap_length |>`
+         by (unabbrev_all_tac \\ rveq \\ fs [state_component_equality])
+      \\ pop_assum (fn t => once_rewrite_tac [t]) \\ fs []
+      \\ unabbrev_all_tac
+      \\ once_asm_rewrite_tac []
+      \\ fs []
+      \\ fs [lookup_insert, lookup_inter_alt, domain_list_insert,
+             domain_inter, domain_delete] \\ rpt strip_tac)
+    \\ Cases_on ‘e’ \\ fs []
+    >- (
+      rpt strip_tac
+      \\ pop_assum $ qspec_then ‘t5.stack’ mp_tac
+      \\ qpat_x_assum ‘!x.bbb’ (mp_tac o GSYM)
+      \\ rename1 ‘jump_exc t4 = SOME s3’
+      \\ qpat_x_assum ‘jump_exc t4 = SOME s3’ (mp_tac o GSYM)
+      \\ unabbrev_all_tac
+      \\ simp_tac (srw_ss()) [call_env_def, push_env_def, dec_clock_def,
+                              Once jump_exc_def]
+      \\ ntac 2 CASE_TAC \\ strip_tac
+      \\ ‘s.handler < LENGTH s.stack’ by
+       (Cases_on ‘s.handler = LENGTH s.stack’
+        \\ fs [LASTN_LEMMA] \\ decide_tac)
+      \\ imp_res_tac LASTN_TL \\ fs []
+      \\ asm_simp_tac (srw_ss()) [Once jump_exc_def]
+      \\ SIMP_TAC std_ss [Once jump_exc_def]
+      \\ ntac 2 CASE_TAC \\ fs [] \\ strip_tac
+      \\ `s.handler = t1.handler ∧
+          LENGTH s.stack = LENGTH t1.stack` by fs [state_rel_def]
+      \\ asm_simp_tac (srw_ss()) [Once jump_exc_def]
+      \\ ‘t1.handler < LENGTH t1.stack’ by fs []
+      \\ imp_res_tac LASTN_TL \\ fs [] \\ rpt strip_tac
+      \\ qabbrev_tac `env = Env t1.locals_size
+                                 ((inter t1.locals
+                                   (inter names (delete v l2))))`
+      \\ `t1 with <| locals := fromList q; stack := env::t1.stack;
+                     clock := s.clock - 1|> =
+          s with <| safe_for_space := t1.safe_for_space;
+                    peak_heap_length := t1.peak_heap_length;
+                    locals_size := t1.locals_size;
+                    stack_max := t1.stack_max;
+                    locals := fromList q; stack := env::t1.stack;
+                    clock := s.clock - 1|>` by
+                fs [state_component_equality, state_rel_def]
+      \\ qmatch_asmsub_abbrev_tac  ‘evaluate (q',p) = (SOME _, ss)’
+      \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’
+      \\ drule_all_then (qspecl_then [‘ss'.stack_max’
+                                     ,‘ss'.safe_for_space’
+                                     ,‘ss'.peak_heap_length’] assume_tac)
+                        evaluate_smx_safe_peak_swap
+      \\ fs []
+      \\ `ss' = p with <| stack_max := ss'.stack_max;
+                          safe_for_space := ss'.safe_for_space;
+                          peak_heap_length := ss'.peak_heap_length |>`
+          by (
+            unabbrev_all_tac \\ rveq
+            \\ fs [state_component_equality, state_rel_def])
+      \\ pop_assum (fn t => once_rewrite_tac [t])
+      \\ unabbrev_all_tac
+      \\ once_asm_rewrite_tac []
+      \\ fs []
+      \\ rev_full_simp_tac std_ss []
+      \\ fs [state_rel_def] \\ srw_tac [] [] \\ fs [])
+    \\ Cases_on ‘a’ \\ fs []
+    \\ (
+      rpt strip_tac
+      \\ first_x_assum (qspec_then ‘t5.stack’ mp_tac) \\ fs []
+      \\ rpt strip_tac
+      \\ qmatch_asmsub_abbrev_tac  ‘evaluate (q',p) = (SOME _, ss)’
+      \\ qmatch_goalsub_abbrev_tac ‘evaluate (q', ss')’
+      \\ drule_all_then (qspecl_then [‘ss'.stack_max’
+                                     ,‘ss'.safe_for_space’
+                                     ,‘ss'.peak_heap_length’] assume_tac)
+                        evaluate_smx_safe_peak_swap
+      \\ fs []
+      \\ `ss' = p with <| stack_max := ss'.stack_max;
+                          safe_for_space := ss'.safe_for_space;
+                          peak_heap_length := ss'.peak_heap_length |>`
+          by (unabbrev_all_tac \\ rveq \\ fs [state_component_equality]
+             \\ fs [call_env_def,push_env_def])
+     \\ pop_assum (fn t => once_rewrite_tac [t])
+     \\ unabbrev_all_tac
+     \\ once_asm_rewrite_tac []
+     \\ fs [state_rel_def]))
   (* Call from here onwards *)
   \\ Cases_on `ret` \\ fs [evaluate_def,compile_def]
   THEN1 (* Call with ret = NONE *)
diff --git a/compiler/backend/proofs/data_spaceProofScript.sml b/compiler/backend/proofs/data_spaceProofScript.sml
index 33d594b15f..a245057d51 100644
--- a/compiler/backend/proofs/data_spaceProofScript.sml
+++ b/compiler/backend/proofs/data_spaceProofScript.sml
@@ -35,8 +35,6 @@ Proof
   \\ rw [] \\ fs [] \\ res_tac \\ fs []
 QED
 
-val case_eq_thms = bvlPropsTheory.case_eq_thms;
-
 Theorem do_stack_with_space:
   ∀op vs s z . do_stack op vs (s with space := z) = (do_stack op vs s) with space := z
 Proof
@@ -79,7 +77,8 @@ Proof
     \\ fs[lookup_insert,state_component_equality]
     \\ METIS_TAC [])
   THEN1 (* Assign *)
-   (BasicProvers.TOP_CASE_TAC \\ fs[cut_state_opt_def]
+   (gvs []
+    \\ BasicProvers.TOP_CASE_TAC \\ fs[cut_state_opt_def]
     \\ BasicProvers.CASE_TAC \\ fs[]
     THEN1 (Cases_on `get_vars args s.locals`
       \\ fs[cut_state_opt_def]
@@ -214,7 +213,8 @@ Proof
       \\ MAP_EVERY Q.EXISTS_TAC [`w'`,`safe'''`,`peak'''`,`smx'''`]
       \\ IF_CASES_TAC \\ fs [])
     THEN1 (* Assign *)
-     (fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`)
+     (gvs []
+      \\ fs[pMakeSpace_def,space_def] \\ reverse (Cases_on `o0`)
       \\ fs[evaluate_def,cut_state_opt_def]
       THEN1
        (fs[pMakeSpace_def,space_def,evaluate_def,
@@ -297,14 +297,13 @@ Proof
          \\ fs[case_eq_thms] \\ rveq
          \\ fs [] \\ rfs []
          \\ fs[state_component_equality] \\ rveq
-         \\ qpat_abbrev_tac `v4_locals = v4.locals`
+         \\ qpat_x_assum `_ = s1.locals` (assume_tac o GSYM) \\ gvs []
          \\ rveq
          \\ fs[op_space_req_def]
          \\ first_assum(mp_tac o MATCH_MP(REWRITE_RULE[GSYM AND_IMP_INTRO]evaluate_locals))
          \\ disch_then drule
          \\ simp[]
-         \\ qpat_abbrev_tac`ll = insert n _ (inter _ _)`
-         \\ disch_then(qspec_then`ll`mp_tac)
+         \\ disch_then(qspec_then`s1.locals`mp_tac)
          \\ impl_tac THEN1
            (UNABBREV_ALL_TAC \\ fs[]
             \\ fs[dataSemTheory.state_component_equality]
@@ -312,9 +311,9 @@ Proof
             \\ fs[locals_ok_def,lookup_insert,lookup_inter_alt]
             \\ fs[domain_delete,domain_list_insert])
          \\ strip_tac \\ simp[]
-         \\ drule_then (qspecl_then [ `v4.stack_max`
-                                    , `v4.safe_for_space`
-                                    , `v4.peak_heap_length`] ASSUME_TAC)
+         \\ drule_then (qspecl_then [ `s1.stack_max`
+                                    , `s1.safe_for_space`
+                                    , `s1.peak_heap_length`] ASSUME_TAC)
                        evaluate_smx_safe_peak_swap
          \\ fs [state_fupdcanon]
          \\ qexists_tac`w`
@@ -451,6 +450,31 @@ Proof
    (Cases_on `get_var n s.locals` \\ fs[]
     \\ IMP_RES_TAC locals_ok_get_var \\ fs[]
     \\ SRW_TAC [] [] \\ fs[])
+  THEN1 (* Force *)
+    (gvs [AllCaseEqs(), PULL_EXISTS]
+     \\ imp_res_tac locals_ok_get_var \\ gvs []
+     \\ imp_res_tac locals_ok_cut_env \\ gvs []
+     >- gvs [flush_state_def, state_component_equality, locals_ok_def]
+     >- (
+      gvs [set_var_def, state_component_equality, locals_ok_def]
+      \\ rw [lookup_insert])
+     >- gvs [flush_state_def, state_component_equality, locals_ok_def]
+     >- (
+      `call_env args1 ss (dec_clock (s with locals := l)) =
+          call_env args1 ss (dec_clock s)`
+        by gvs [state_component_equality, dec_clock_def, call_env_def] \\ gvs []
+      \\ gvs [state_component_equality]
+      \\ metis_tac [locals_ok_refl])
+     >- (
+      gvs [PULL_EXISTS]
+      \\ gvs [call_env_def, dec_clock_def, push_env_def, locals_ok_def]
+      \\ gvs [state_component_equality])
+    >- (
+      gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality]
+      \\ metis_tac [locals_ok_refl])
+    >- (
+      gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality]
+      \\ metis_tac [locals_ok_refl]))
   THEN1 (* Call *)
    (Cases_on `get_vars args s.locals` \\ fs[]
     \\ IMP_RES_TAC locals_ok_get_vars \\ fs[]
diff --git a/compiler/backend/proofs/data_to_wordProofScript.sml b/compiler/backend/proofs/data_to_wordProofScript.sml
index 95cddf542a..5dfa2f7b17 100644
--- a/compiler/backend/proofs/data_to_wordProofScript.sml
+++ b/compiler/backend/proofs/data_to_wordProofScript.sml
@@ -7,7 +7,7 @@ Ancestors
   data_to_word_gcProof word_to_wordProof wordProps data_to_word
   wordLang wordSem[qualified] dataProps copying_gc int_bitwise
   finite_map data_to_word_memoryProof data_to_word_bignumProof
-  data_to_word_assignProof wordConvs wordConvsProof while set_sep
+  data_to_word_assignProof wordConvs wordConvsProof While set_sep
   semanticsProps alignment word_bignum word_bignumProof
   gen_gc_partial gc_shared gen_gc[qualified]
 Libs
@@ -50,6 +50,117 @@ Proof
   \\ gvs[do_space_def,AllCaseEqs(),consume_space_def]
 QED
 
+Triviality word_test_lemma1:
+  good_dimindex (:α) ⇒
+  (0b111100w && x = n2w ((8 + 6) * 4):'a word ⇔
+   ~ word_bit 2 x ∧ word_bit 3 x ∧ word_bit 4 x ∧ word_bit 5 x)
+Proof
+  simp [word_eq,word_bit_and,word_bit_n2w,good_dimindex_def]
+  \\ rw [] \\ gvs [] \\ rw []
+  \\ simp [METIS_PROVE [] “(∀n. (P n = Q n)) ⇔ (∀n. P n ⇒ Q n) ∧ (∀n. Q n ⇒ P n)”]
+  \\ gvs [SF DNF_ss,SF CONJ_ss]
+QED
+
+Triviality word_test_lemma2:
+  good_dimindex (:α) ⇒
+  (0b111100w && x = n2w ((0 + 6) * 4):'a word ⇔
+   ~ word_bit 2 x ∧ word_bit 3 x ∧ word_bit 4 x ∧ ~ word_bit 5 x)
+Proof
+  simp [word_eq,word_bit_and,word_bit_n2w,good_dimindex_def]
+  \\ rw [] \\ gvs [] \\ rw []
+  \\ simp [METIS_PROVE [] “(∀n. (P n = Q n)) ⇔ (∀n. P n ⇒ Q n) ∧ (∀n. Q n ⇒ P n)”]
+  \\ gvs [SF DNF_ss,SF CONJ_ss]
+  \\ eq_tac \\ rw [] \\ gvs []
+  \\ first_assum $ qspec_then ‘2’ assume_tac
+  \\ first_assum $ qspec_then ‘3’ assume_tac
+  \\ first_assum $ qspec_then ‘4’ assume_tac
+  \\ first_assum $ qspec_then ‘5’ assume_tac
+  \\ fs []
+QED
+
+Theorem memory_rel_Thunk_bits:
+  memory_rel c be ts refs sp st m dm ((RefPtr bl p,Word (w:'a word))::vars) ∧
+  lookup p refs = SOME (Thunk ev z) ∧ good_dimindex (:α) ∧
+  get_real_addr c st w = SOME a ∧
+  m a = Word x
+  ⇒
+  (case ev of
+   | Evaluated => 0b111100w && x = n2w ((8 + 6) * 4)
+   | NotEvaluated => 0b111100w && x = n2w ((0 + 6) * 4))
+Proof
+  strip_tac
+  \\ drule_all memory_rel_Thunk_IMP \\ fs []
+  \\ strip_tac
+  \\ drule word_test_lemma1 \\ fs []
+  \\ drule word_test_lemma2 \\ fs []
+  \\ Cases_on ‘ev’ \\ gs []
+QED
+
+Theorem memory_rel_Force:
+   memory_rel c be ts refs sp st m dm ((RefPtr bl nn,ptr)::vars) /\
+    lookup nn refs = SOME (Thunk ev v) /\
+    good_dimindex (:'a) ==>
+    ?ptr_w x:'a word w w'.
+      ptr = Word ptr_w /\
+      get_real_addr c st ptr_w = SOME x /\
+      x IN dm /\ m x = Word w /\
+      (x + bytes_in_word) IN dm /\
+      memory_rel c be ts refs sp st m dm
+        ((v,m (x + bytes_in_word))::(RefPtr bl nn,ptr)::vars)
+Proof
+  rewrite_tac [CONJ_ASSOC]
+  \\ once_rewrite_tac [CONJ_COMM]
+  \\ fs [memory_rel_def,PULL_EXISTS] \\ rw []
+  \\ asm_exists_tac \\ fs []
+  \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac
+  \\ rpt_drule (GEN_ALL deref_thm) \\ fs [domain_lookup] \\ strip_tac
+  \\ asm_exists_tac \\ fs []
+  \\ Cases_on `v'` \\ fs [heap_el_def]
+  \\ every_case_tac \\ fs [] \\ clean_tac
+  \\ fs [GSYM CONJ_ASSOC,word_addr_def]
+  \\ fs [heap_in_memory_store_def]
+  \\ rpt_drule get_real_addr_get_addr \\ fs []
+  \\ disch_then kall_tac
+  \\ drule LESS_LENGTH
+  \\ strip_tac \\ fs [] \\ clean_tac
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND]
+  \\ fs [EL_LENGTH_APPEND]
+  \\ imp_res_tac heap_lookup_SPLIT
+  \\ PairCases_on `b` \\ fs []
+  \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def]
+  \\ pairarg_tac \\ gvs []
+  \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ gvs []
+  \\ Cases_on `b0` \\ fs [word_payload_def]
+  \\ gvs [word_list_def,word_list_APPEND,SEP_CLAUSES] \\ fs [SEP_F_def]
+  \\ SEP_R_TAC \\ fs []
+QED
+
+Theorem MEM_join_env_cut_env:
+  ∀(a:v # α word_loc) t r s.
+    MEM a (join_env x (toAList (inter t (adjust_set x)))) ∧
+    dataSem$cut_env r s = SOME x ⇒
+    MEM a (join_env s (toAList (inter t (adjust_set s))))
+Proof
+  fs [join_env_def,MEM_MAP,EXISTS_PROD,MEM_FILTER]
+  \\ rw [] \\ gvs [cut_env_def]
+  \\ fs [MEM_toAList]
+  \\ last_assum $ irule_at Any \\ simp []
+  \\ fs [lookup_inter_alt,IN_domain_adjust_set_inter]
+  \\ rw [] \\ fs []
+  \\ imp_res_tac IN_adjust_set_IN
+QED
+
+Theorem jump_exc_locals:
+  wordSem$jump_exc (t with locals := l) = jump_exc t
+Proof
+  fs [wordSemTheory.jump_exc_def]
+QED
+
+Theorem state_rel_cut_env_IMP_cut_env =
+  state_rel_cut_state_opt_SOME |> Q.GEN ‘args’ |> Q.SPEC ‘[]’ |> GEN_ALL
+  |> SRULE [get_vars_def,cut_state_opt_def,cut_state_def,
+            CaseEq"option",PULL_EXISTS,wordSemTheory.get_vars_def];
+
 Theorem data_compile_correct:
    !prog s c n l l1 l2 res s1 (t:('a,'c,'ffi)wordSem$state) locs.
       (dataSem$evaluate (prog,s) = (res,s1)) /\
@@ -96,7 +207,8 @@ Proof
     \\ imp_res_tac word_ml_inv_get_var_IMP
     \\ match_mp_tac word_ml_inv_insert \\ fs [])
   >~ [‘evaluate (Assign _ _ _ _,s)’] >-
-   (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def]
+   (full_simp_tac std_ss []
+    \\ fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def]
     \\ imp_res_tac (METIS_PROVE [] ``(if b1 /\ b2 then x1 else x2) = y ==>
                                      b1 /\ b2 /\ x1 = y \/
                                      (b1 ==> ~b2) /\ x2 = y``)
@@ -124,6 +236,255 @@ Proof
     \\ Cases_on `names_opt` \\ fs [cut_state_opt_def] \\ srw_tac[][] \\ fs []
     \\ fs [cut_state_def,cut_env_def] \\ every_case_tac
     \\ fs [] \\ rw [] \\ fs [set_var_def])
+  >~ [‘evaluate (Force _ _ _,s)’] >-
+   (simp [comp_def, force_thunk_def]
+    \\ TOP_CASE_TAC \\ gvs []
+    >- gvs [encode_header_def, encode_header_def, state_rel_def,
+            good_dimindex_def, limits_inv_def, dimword_def, memory_rel_def,
+            heap_in_memory_store_def, consume_space_def, arch_size_def,
+            NOT_LESS]
+    \\ simp [wordSemTheory.evaluate_def]
+    \\ gvs [evaluate_def]
+    \\ Cases_on `get_var src s.locals` \\ gvs []
+    \\ Cases_on `dest_thunk x' s.refs` \\ gvs []
+    \\ gvs [oneline dest_thunk_def]
+    \\ Cases_on `x'` \\ gvs []
+    \\ Cases_on `lookup n' s.refs` \\ gvs []
+    \\ Cases_on `x'` \\ gvs []
+    \\ `IsThunk t' v = IsThunk t'' a` by (Cases_on `t''` \\ gvs []) \\ gvs []
+    \\ qpat_x_assum `_ = IsThunk t' a` kall_tac
+    \\ drule_all state_rel_get_var_RefPtr \\ rw [] \\ gvs []
+    \\ simp [wordSemTheory.get_var_imm_def, word_cmp_Test_1, word_bit_def,
+             get_addr_0]
+    \\ simp [Once list_Seq_def, wordSemTheory.evaluate_def]
+    \\ qpat_assum `state_rel _ _ _ _ _ _ _` mp_tac
+    \\ pure_rewrite_tac [Once state_rel_thm] \\ rw []
+    \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+    \\ drule_all memory_rel_get_var_IMP \\ rw [] \\ gvs []
+    \\ drule_all memory_rel_Force \\ rw [] \\ gvs []
+    \\ `word_exp t (real_addr c (adjust_var src)) = SOME (Word x')`
+      by metis_tac [get_real_addr_lemma] \\ gvs []
+    \\ simp [Once list_Seq_def, wordSemTheory.evaluate_def]
+    \\ simp [wordSemTheory.set_var_def, wordSemTheory.word_exp_def,
+             wordSemTheory.get_var_def, wordSemTheory.the_words_def,
+             wordSemTheory.mem_load_def, word_op_def]
+    \\ simp [list_Seq_def, wordSemTheory.evaluate_def]
+    \\ simp [wordSemTheory.get_var_def, wordSemTheory.get_var_imm_def]
+    \\ drule_all memory_rel_Thunk_bits \\ strip_tac
+    \\ rename [‘_ = SOME (Thunk has_been_eval a)’]
+    \\ Cases_on `has_been_eval` \\ gvs []
+    >- (
+      simp [asmTheory.word_cmp_def]
+      \\ Cases_on `ret` \\ gvs []
+      >- (
+        simp [wordSemTheory.evaluate_def]
+        \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def,
+                 lookup_insert, wordSemTheory.the_words_def,
+                 word_op_def, wordSemTheory.mem_load_def,
+                 wordSemTheory.set_var_def, wordSemTheory.get_vars_def]
+        \\ simp [flush_state_def, wordSemTheory.flush_state_def]
+        \\ fs [state_rel_thm] \\ simp [join_env_def]
+        \\ conj_tac
+        >-
+         (irule backendPropsTheory.option_le_trans
+          \\ first_x_assum $ irule_at Any
+          \\ Cases_on ‘s.locals_size’ \\ fs []
+          \\ Cases_on ‘stack_size t.stack’ \\ fs [])
+        \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac
+        \\ match_mp_tac memory_rel_rearrange
+        \\ simp [SF DNF_ss])
+      \\ Cases_on `x''` \\ gvs []
+      \\ simp [wordSemTheory.evaluate_def, wordSemTheory.word_exp_def,
+               wordSemTheory.get_var_def, lookup_insert,
+               wordSemTheory.the_words_def, word_op_def,
+               wordSemTheory.mem_load_def]
+      \\ Cases_on `cut_env r s.locals` \\ gvs []
+      \\ conj_tac >- (simp [set_var_def])
+      \\ simp [wordSemTheory.set_var_def, set_var_def]
+      \\ fs [state_rel_thm,lookup_insert,adjust_var_11]
+      \\ conj_tac >- (rw [] \\ gvs [cut_env_def,lookup_inter_alt]
+                      \\ pop_assum mp_tac \\ rw [] \\ fs [])
+      \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+      \\ match_mp_tac memory_rel_insert
+      \\ fs[inter_insert_ODD_adjust_set_alt]
+      \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac
+      \\ match_mp_tac memory_rel_rearrange
+      \\ simp [SF DNF_ss]
+      \\ rpt strip_tac
+      \\ drule_all MEM_join_env_cut_env \\ fs [])
+    \\ IF_CASES_TAC \\ gvs []
+    >- gvs [asmTheory.word_cmp_def, dimword_def, good_dimindex_def]
+    \\ IF_CASES_TAC \\ gvs []
+    >- gvs [asmTheory.word_cmp_def, dimword_def, good_dimindex_def]
+    \\ simp [wordSemTheory.word_exp_def, wordSemTheory.get_var_def,
+             lookup_insert, wordSemTheory.the_words_def, word_op_def,
+             wordSemTheory.mem_load_def, wordSemTheory.set_var_def]
+    \\ Cases_on `find_code (SOME loc) [RefPtr b n'; a] s.code
+                           s.stack_frame_sizes` \\ gvs []
+    \\ Cases_on `x''` \\ gvs []
+    \\ Cases_on `r` \\ gvs []
+    \\ Cases_on `ret` \\ gvs []
+    >- (
+      simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def,
+            wordSemTheory.get_var_def, lookup_insert]
+      \\ once_rewrite_tac [GSYM wordSemTheory.get_var_def] \\ gvs []
+      \\ simp [wordSemTheory.bad_dest_args_def]
+      \\ gvs [find_code_def]
+      \\ Cases_on `lookup loc s.code` \\ gvs []
+      \\ Cases_on `x''` \\ gvs []
+      \\ simp [wordSemTheory.find_code_def]
+      \\ qpat_x_assum `code_rel _ _ _` assume_tac
+      \\ gvs [code_rel_def]
+      \\ first_x_assum drule \\ strip_tac \\ gvs []
+      \\ simp [wordSemTheory.add_ret_loc_def]
+      \\ IF_CASES_TAC \\ gvs []
+      >- simp [wordSemTheory.flush_state_def]
+      \\ gvs [CaseEq"prod",CaseEq"option",PULL_EXISTS]
+      \\ qmatch_goalsub_abbrev_tac ‘(FST _, t8)’
+      \\ last_x_assum $ qspecl_then [‘c’,‘loc’,‘2’,‘l1’,‘l2’,‘t8’,‘locs’] mp_tac
+      \\ impl_tac >-
+       (fs [state_rel_thm,dataSemTheory.call_env_def,
+            dataSemTheory.dec_clock_def,wordSemTheory.dec_clock_def,
+            wordSemTheory.call_env_def,dec_clock_def,Abbr‘t8’]
+        \\ conj_tac >- EVAL_TAC
+        \\ conj_tac >-
+         (simp [fromList_def,fromList2_def]
+          \\ simp [lookup_insert]
+          \\ rw [] \\ gvs [])
+        \\ conj_tac >-
+         (Cases_on ‘t.stack_max’ \\ gvs []
+          \\ Cases_on ‘stack_size t.stack’ \\ gvs []
+          \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ gvs [] )
+        \\ conj_tac >-
+         (imp_res_tac stack_rel_IMP_size_of_stack
+          \\ Cases_on ‘size_of_stack s.stack’ \\ gvs []
+          \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ gvs []
+          \\ Cases_on ‘s.stack_max’ \\ gvs []
+          \\ Cases_on ‘t.stack_max’ \\ gvs [])
+        \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac
+        \\ match_mp_tac memory_rel_rearrange
+        \\ simp [SF DNF_ss]
+        \\ EVAL_TAC
+        \\ simp [SF DNF_ss])
+      \\ strip_tac \\ fs []
+      \\ Cases_on ‘res1’ \\ gvs []
+      \\ strip_tac \\ gvs []
+      \\ CASE_TAC \\ gvs []
+      \\ CASE_TAC \\ gvs []
+      \\ ‘(jump_exc t8 = NONE ⇔ jump_exc t = NONE) ∧
+          mk_loc (jump_exc t8) = mk_loc (jump_exc t) : 'a word_loc’ by
+       (gvs [wordSemTheory.jump_exc_def,Abbr‘t8’,wordSemTheory.call_env_def,
+             wordSemTheory.dec_clock_def,mk_loc_def]
+        \\ IF_CASES_TAC \\ simp []
+        \\ rpt (CASE_TAC \\ gvs [mk_loc_def]))
+      \\ gvs []
+      \\ Cases_on ‘jump_exc t’ \\ gvs [wordSemTheory.set_var_def])
+    \\ Cases_on `x''` \\ gvs []
+    \\ simp [wordSemTheory.evaluate_def, wordSemTheory.get_vars_def,
+             wordSemTheory.get_var_def, lookup_insert]
+    \\ once_rewrite_tac [GSYM wordSemTheory.get_var_def] \\ gvs []
+    \\ simp [wordSemTheory.bad_dest_args_def]
+    \\ gvs [find_code_def]
+    \\ Cases_on `lookup loc s.code` \\ gvs []
+    \\ Cases_on `x''` \\ gvs []
+    \\ simp [wordSemTheory.find_code_def]
+    \\ qpat_x_assum `code_rel _ _ _` assume_tac
+    \\ gvs [code_rel_def]
+    \\ first_x_assum drule \\ strip_tac \\ gvs []
+    \\ simp [wordSemTheory.add_ret_loc_def, domain_adjust_sets]
+    \\ Cases_on `cut_env r s.locals` \\ gvs []
+    \\ simp [cut_envs_adjust_sets_insert_ODD]
+    \\ pop_assum mp_tac
+    \\ simp [cut_env_def, SUBSET_DEF, domain_lookup] \\ strip_tac \\ gvs []
+    \\ simp [adjust_sets_def, adjust_set_def, wordSemTheory.cut_envs_def,
+             wordSemTheory.cut_names_def, domain_lookup, domain_fromAList]
+    \\ simp [SUBSET_DEF, MEM_MAP, PULL_EXISTS]
+    \\ reverse $ IF_CASES_TAC \\ gvs []
+    >- (
+      spose_not_then kall_tac
+      \\ pairarg_tac \\ gvs [MEM_toAList, domain_lookup]
+      \\ first_x_assum $ drule_then assume_tac \\ gvs []
+      \\ first_x_assum $ qspec_then `n` assume_tac \\ gvs []
+      \\ Cases_on `lookup (adjust_var n) t.locals` \\ gvs [])
+    \\ IF_CASES_TAC \\ gvs []
+    >-
+     (fs [dataSemTheory.call_env_def,wordSemTheory.call_env_def]
+      \\ imp_res_tac stack_rel_IMP_size_of_stack
+      \\ fs [dataSemTheory.push_env_def,wordSemTheory.push_env_def,
+             wordSemTheory.env_to_list_def,dataSemTheory.dec_clock_def,
+             wordSemTheory.stack_size_def,
+             wordSemTheory.stack_size_frame_def,
+             dataSemTheory.size_of_stack_def,
+             dataSemTheory.size_of_stack_frame_def]
+      \\ fs [GSYM wordSemTheory.stack_size_def,
+             GSYM wordSemTheory.stack_size_frame_def,
+             GSYM dataSemTheory.size_of_stack_def,
+             GSYM dataSemTheory.size_of_stack_frame_def]
+      \\ Cases_on ‘s.stack_max’ \\ fs []
+      \\ Cases_on ‘t.stack_max’ \\ fs []
+      \\ Cases_on ‘s.locals_size’ \\ fs []
+      \\ Cases_on ‘lookup loc s.stack_frame_sizes’ \\ fs []
+      \\ Cases_on ‘size_of_stack s.stack’ \\ fs [])
+    \\ gvs [CaseEq"prod",CaseEq"option",PULL_EXISTS]
+    \\ qmatch_goalsub_abbrev_tac ‘(FST _, t8)’
+    \\ last_x_assum $ qspecl_then [‘c’,‘loc’,‘2’,‘n’,‘l’,‘t8’,‘(l1,l2)::locs’] mp_tac
+    \\ impl_tac >-
+     (conj_tac >- (CCONTR_TAC \\ gvs [])
+      \\ reverse conj_tac >- gvs [Abbr‘t8’]
+      \\ simp [Abbr‘t8’]
+      \\ irule state_rel_call_env_push \\ simp []
+      \\ conj_tac >-
+      (fs [cut_envs_adjust_sets_ODD]
+       \\ qexists_tac ‘r’
+       \\ ‘cut_env r s.locals = SOME (inter s.locals r)’ by
+         simp [dataSemTheory.cut_env_def,SUBSET_DEF,domain_lookup]
+       \\ drule_all state_rel_cut_env_IMP_cut_env
+       \\ strip_tac \\ simp []
+       \\ drule cut_env_IMP_cut_envs \\ strip_tac
+       \\ gvs [wordSemTheory.cut_envs_def,CaseEq"option"]
+       \\ gvs [wordSemTheory.cut_names_def,CaseEq"option"]
+       \\ simp [adjust_sets_def,adjust_set_def])
+      \\ fs [state_rel_thm,lookup_insert]
+      \\ fs[inter_insert_ODD_adjust_set_alt]
+      \\ qpat_x_assum ‘_ t.mdomain _’ mp_tac
+      \\ match_mp_tac memory_rel_rearrange
+      \\ simp [SF DNF_ss])
+    \\ strip_tac \\ fs []
+    \\ Cases_on ‘res1’
+    >- (gvs [] \\ gvs [AllCaseEqs()])
+    \\ gvs []
+    \\ rename [‘word_res = NotEnoughSpace ⇒ _’]
+    \\ Cases_on ‘word_res = NotEnoughSpace’ \\ gvs []
+    >- (gvs [AllCaseEqs(),dataSemTheory.set_var_def,dataSemTheory.pop_env_def])
+    \\ rename [‘dataSem$evaluate _ = (SOME data_res,s2)’]
+    \\ reverse $ Cases_on ‘data_res’
+    >- (
+      reverse (Cases_on `e`) \\ full_simp_tac(srw_ss())[] \\ srw_tac[][]
+      \\ full_simp_tac(srw_ss())[jump_exc_call_env,jump_exc_dec_clock,
+                                 jump_exc_push_env_NONE,Abbr‘t8’,jump_exc_locals]
+      THEN1 (every_case_tac \\ fs[])
+      \\ Cases_on `jump_exc t = NONE` \\ full_simp_tac(srw_ss())[]
+      \\ full_simp_tac(srw_ss())[jump_exc_push_env_NONE_simp,jump_exc_locals]
+      \\ `LENGTH locs = LENGTH s.stack` by
+         (fs[state_rel_def] \\ imp_res_tac LIST_REL_LENGTH \\ fs[]) \\ full_simp_tac(srw_ss())[]
+      \\ `LENGTH s1.stack < LENGTH locs` by(imp_res_tac eval_exc_stack_shorter \\ fs[])
+      \\ imp_res_tac LASTN_TL \\ full_simp_tac(srw_ss())[]
+      \\ fs [jump_exc_push_env_NONE]
+      \\ fs [wordSemTheory.set_var_def])
+    \\ gvs []
+    \\ Cases_on ‘pop_env s2’ \\ gvs []
+    \\ qrefinel [‘_’,‘NONE’] \\ simp [AllCaseEqs(),PULL_EXISTS]
+    \\ rename [‘set_var ret_var _ _’]
+    \\ drule_all state_rel_pop_env_set_var_IMP
+    \\ disch_then $ qspec_then ‘ret_var’ strip_assume_tac
+    \\ gvs [wordSemTheory.set_vars_def,alist_insert_def,wordSemTheory.set_var_def,
+            dataSemTheory.set_var_def]
+    \\ reverse $ rpt strip_tac
+    >- (imp_res_tac dataPropsTheory.pop_env_const
+        \\ imp_res_tac wordPropsTheory.pop_env_const
+        \\ gvs [])
+    \\ simp [Abbr‘t8’]
+    \\ drule evaluate_IMP_domain_EQ \\ fs [])
   >~ [‘evaluate (Tick,s)’] >-
    (fs [comp_def,dataSemTheory.evaluate_def,wordSemTheory.evaluate_def]
     \\ `t.clock = s.clock` by fs [state_rel_def] \\ fs [] \\ srw_tac[][]
@@ -1342,7 +1703,8 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on)
+      [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem data_to_word_lab_pres_lem:
   ∀c n l p.
@@ -1375,6 +1737,12 @@ Proof
     BasicProvers.EVERY_CASE_TAC>>
     fs[extract_labels_def,list_Seq_def,extract_labels_StoreEach,
        extract_labels_StoreAnyConsts,Maxout_bits_code_def])
+  >~ [‘force_thunk’] >- (
+    pairarg_tac \\ gvs [force_thunk_def, AllCaseEqs()]
+    >- gvs [GiveUp_def, extract_labels_def]
+    \\ gvs [extract_labels_def]
+    \\ CASE_TAC \\ gvs [list_Seq_def, extract_labels_def]
+    \\ CASE_TAC \\ gvs [extract_labels_def])
   >>
     (rpt (pairarg_tac>>fs[])>>rveq>>
           fs[extract_labels_def,EVERY_MEM,FORALL_PROD,ALL_DISTINCT_APPEND,
@@ -1511,6 +1879,12 @@ Proof
     IF_CASES_TAC >>
     simp[comp_def,no_share_inst_def,list_Seq_no_share_inst]
   )
+  >~ [‘Force’] >- (
+    gvs [comp_def, force_thunk_def, AllCaseEqs()]
+    >- gvs [GiveUp_def, no_share_inst_def]
+    \\ gvs [no_share_inst_def]
+    \\ CASE_TAC \\ gvs [no_share_inst_def, list_Seq_no_share_inst]
+    \\ CASE_TAC \\ gvs [no_share_inst_def])
   >> gvs[comp_def,no_share_inst_def] (* Raise | Return | Tick *)
 QED
 
@@ -1635,7 +2009,8 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b'`], [`g'`], [`m`], []];
+  map (MAP_EVERY Cases_on)
+      [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem assign_no_inst[local]:
   ((a.has_longdiv ⇒ (ac.ISA = x86_64)) ∧
@@ -1674,7 +2049,7 @@ Theorem comp_no_inst:
   every_inst (inst_ok_less ac) (FST(comp c n m p))
 Proof
   ho_match_mp_tac comp_ind>>Cases_on`p`>>rw[]>>
-  simp[Once comp_def,every_inst_def]>>
+  simp[Once comp_def,every_inst_def,force_thunk_def]>>
   every_case_tac>>fs[]>>
   rpt(pairarg_tac>>fs[])>>
   fs[assign_no_inst]>>
@@ -1958,8 +2333,11 @@ Proof
     (fs[SUBSET_DEF]>>metis_tac[])
   >-
     (fs[SUBSET_DEF]>>metis_tac[])
-  >>
-    EVAL_TAC>>rw[]>>fs[]
+  >~ [‘force_thunk’] >- (
+    gvs [force_thunk_def]
+    \\ every_case_tac \\ gvs [GiveUp_def, SUBSET_DEF]
+    \\ EVAL_TAC \\ rpt strip_tac \\ disj1_tac \\ gvs []) >>
+  EVAL_TAC>>rw[]>>fs[]
 QED
 
 Triviality word_good_handlers_StoreEach:
@@ -2012,6 +2390,10 @@ Proof
     metis_tac[])
   >-
     fs[word_good_handlers_assign]
+  >~ [‘force_thunk’] >- (
+    gvs [force_thunk_def]
+    \\ every_case_tac \\ gvs [GiveUp_def]
+    \\ EVAL_TAC)
   >>
     EVAL_TAC>>rw[]>>fs[]
 QED
@@ -2125,4 +2507,3 @@ Proof
   simp[EVERY_MAP,LAMBDA_PROD,compile_part_def,data_to_word_comp_good_handlers]>>
   fs[EVERY_MEM,FORALL_PROD]
 QED
-
diff --git a/compiler/backend/proofs/data_to_word_assignProofScript.sml b/compiler/backend/proofs/data_to_word_assignProofScript.sml
index 48c3ea5f1e..a6da340927 100644
--- a/compiler/backend/proofs/data_to_word_assignProofScript.sml
+++ b/compiler/backend/proofs/data_to_word_assignProofScript.sml
@@ -7,7 +7,7 @@ Libs
 Ancestors
   data_to_word_memoryProof data_to_word_gcProof dataSem
   wordSem[qualified] data_to_word int_bitwise dataProps
-  copying_gc data_to_word_bignumProof wordProps while set_sep
+  copying_gc data_to_word_bignumProof wordProps While set_sep
   semanticsProps alignment backendProps word_bignum wordLang
   word_bignumProof gen_gc_partial gc_shared word_gcFunctions
   gen_gc[qualified] bvi_to_data[qualified]
@@ -251,6 +251,13 @@ Proof
   match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs []
 QED
 
+Theorem reorder_2_lemma:
+  memory_rel c be ts x.refs x.space t.store t.memory t.mdomain (x1::x2::xs) ==>
+  memory_rel c be ts x.refs x.space t.store t.memory t.mdomain (x2::x1::xs)
+Proof
+  match_mp_tac memory_rel_rearrange \\ fs [] \\ rw [] \\ fs []
+QED
+
 Theorem evaluate_StoreEach = Q.prove(`
   !xs ys t offset m1.
       store_list (a + offset) ys t.memory t.mdomain = SOME m1 /\
@@ -2095,7 +2102,7 @@ Proof
 QED
 
 fun cases_on_op q = Cases_on q >|
-  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on) [[], [], [], [], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem do_app_aux_safe_for_space_mono:
   (do_app_aux op xs s = Rval (r,s1)) /\ s1.safe_for_space ==> s.safe_for_space
@@ -4933,6 +4940,169 @@ Proof
   \\ drule ALOOKUP_MEM \\ simp []
 QED
 
+Theorem do_app_AllocThunk:
+   do_app (ThunkOp (AllocThunk m)) [v] x =
+    case consume_space (1 + 1) x of
+      NONE => Rerr (Rabort Rtype_error)
+    | SOME s1 =>
+      Rval
+      (RefPtr F (LEAST ptr. ptr ∉ domain s1.refs),
+         s1 with <|
+           refs := insert (LEAST ptr. ptr ∉ domain s1.refs) (Thunk m v) s1.refs;
+           safe_for_space := (
+             do_stack
+               (ThunkOp (AllocThunk m)) [v]
+               (do_lim_safe s1 (ThunkOp (AllocThunk m)) [v])).safe_for_space;
+           stack_max := (
+             do_stack
+               (ThunkOp (AllocThunk m)) [v]
+               (do_lim_safe s1 (ThunkOp (AllocThunk m)) [v])).stack_max |>)
+Proof
+  gvs [do_app, consume_space_def]
+QED
+
+Theorem assign_AllocThunk:
+  (∃ev. op = ThunkOp (AllocThunk ev)) ==> ^assign_thm_goal
+Proof
+  rpt strip_tac \\ drule0 (evaluate_GiveUp2 |> GEN_ALL) \\ rw [] \\ fs []
+  \\ `t.termdep <> 0` by fs[]
+  \\ asm_rewrite_tac [] \\ pop_assum kall_tac
+  \\ rpt_drule0 state_rel_cut_IMP
+  \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac
+  \\ imp_res_tac get_vars_IMP_LENGTH \\ fs []
+  \\ fs [assign_def] \\ fs [do_app_AllocThunk] \\ fs[do_app]
+  \\ Cases_on `consume_space (LENGTH vals + 1) x` \\ fs [] \\ rveq
+  \\ Cases_on `vals` \\ gvs []
+  \\ Cases_on `t'` \\ gvs []
+  \\ gvs [dataLangTheory.op_requires_names_def,
+          dataLangTheory.op_space_reset_def]
+  \\ imp_res_tac get_vars_IMP_LENGTH \\ fs [] \\ clean_tac
+  \\ fs [consume_space_def] \\ clean_tac
+  \\ imp_res_tac state_rel_get_vars_IMP
+  \\ Cases_on `ws` \\ gvs []
+  \\ Cases_on `args` \\ gvs []
+  \\ simp [allowed_op_def]
+  \\ TOP_CASE_TAC \\ fs []
+  >- (
+    conj_tac
+    >- (
+      fs [state_rel_def]
+      \\ rw [option_le_max_right]
+      \\ metis_tac[option_le_trans])
+    \\ fs[encode_header_def]
+    \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def,
+          dimword_def, memory_rel_def, heap_in_memory_store_def,
+          consume_space_def, arch_size_def]
+    \\ rfs[NOT_LESS]
+    \\ Cases_on `ev` \\ gvs [])
+  \\ simp [state_rel_thm] \\ eval_tac
+  \\ fs [state_rel_thm] \\ eval_tac
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ drule0 (memory_rel_get_vars_IMP |> GEN_ALL)
+  \\ disch_then drule0 \\ fs [NOT_LESS,DECIDE ``n + 1 <= m <=> n < m:num``]
+  \\ strip_tac
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ qabbrev_tac `new = LEAST ptr. ptr ∉ domain x.refs`
+  \\ `new ∉ domain x.refs` by metis_tac [LEAST_NOTIN_spt_DOMAIN]
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ rpt_drule0 memory_rel_AllocThunk \\ strip_tac
+  \\ fs [list_Seq_def] \\ eval_tac
+  \\ fs [wordSemTheory.set_store_def,FLOOKUP_UPDATE]
+  \\ qpat_abbrev_tac `t5 = t with <| locals := _ ; store := _ |>`
+  \\ pairarg_tac \\ fs []
+  \\ `t.memory = t5.memory /\ t.mdomain = t5.mdomain` by
+       (unabbrev_all_tac \\ fs []) \\ fs []
+  \\ ntac 2 (pop_assum kall_tac)
+  \\ drule0 evaluate_StoreEach
+  \\ disch_then (qspecl_then [`[3; adjust_var h'']`,`1`] mp_tac)
+  \\ impl_tac
+  >- (
+    unabbrev_all_tac
+    \\ gvs [wordSemTheory.get_vars_def, wordSemTheory.get_var_def,
+            lookup_insert])
+  \\ clean_tac \\ fs [] \\ UNABBREV_ALL_TAC
+  \\ fs [lookup_insert,FAPPLY_FUPDATE_THM,adjust_var_11,FLOOKUP_UPDATE,
+         code_oracle_rel_def,FLOOKUP_UPDATE]
+  \\ rpt (qpat_x_assum `!x y z. _` kall_tac)
+  \\ rw [] \\ fs [] \\ rw [] \\ fs []
+  \\ fs [inter_insert_ODD_adjust_set]
+  >- (rw[option_le_max_right] >> metis_tac[option_le_trans])
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ match_mp_tac memory_rel_insert \\ fs []
+  \\ fs [make_ptr_def]
+  \\ `TriggerGC <> EndOfHeap` by fs []
+  \\ pop_assum (fn th => fs [MATCH_MP FUPDATE_COMMUTES th])
+QED
+
+Theorem assign_UpdateThunk:
+  (∃ev. op = ThunkOp (UpdateThunk ev)) ==> ^assign_thm_goal
+Proof
+  rpt strip_tac \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs []
+  \\ `t.termdep <> 0` by fs[]
+  \\ gvs [dataLangTheory.op_requires_names_def,
+          dataLangTheory.op_space_reset_def]
+  \\ rpt_drule0 state_rel_cut_IMP
+  \\ qpat_x_assum `state_rel c l1 l2 s t [] locs` kall_tac \\ strip_tac
+  \\ imp_res_tac get_vars_IMP_LENGTH \\ fs []
+  \\ gvs [do_app,allowed_op_def,AllCaseEqs()]
+  \\ imp_res_tac state_rel_get_vars_IMP
+  \\ fs [bvlSemTheory.Unit_def] \\ rveq
+  \\ fs [GSYM bvlSemTheory.Unit_def] \\ rveq
+  \\ fs [assign_def] \\ eval_tac \\ fs [state_rel_thm]
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ drule0 (memory_rel_get_vars_IMP |> GEN_ALL)
+  \\ disch_then drule0 \\ fs []
+  \\ Cases_on `args` \\ gvs []
+  \\ Cases_on `t'` \\ gvs []
+  \\ Cases_on `t''` \\ gvs []
+  \\ Cases_on `ws` \\ gvs []
+  \\ Cases_on `t'` \\ gvs []
+  \\ imp_res_tac get_vars_2_IMP \\ fs []
+  \\ strip_tac
+  \\ drule0 reorder_2_lemma \\ strip_tac
+  \\ reverse $ Cases_on `ev` \\ gvs []
+  >- (
+    drule0 (memory_rel_UpdateThunk_NotEvaluated |> GEN_ALL) \\ fs []
+    \\ strip_tac \\ clean_tac
+    \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x')` by
+          metis_tac [get_real_offset_lemma,get_real_addr_lemma]
+    \\ fs [] \\ eval_tac \\ fs [EVAL ``word_exp s1 Unit``]
+    \\ fs [wordSemTheory.mem_store_def]
+    \\ fs [lookup_insert,adjust_var_11]
+    \\ rw [] \\ fs [option_le_max_right]
+    \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+    \\ match_mp_tac memory_rel_insert \\ fs []
+    \\ match_mp_tac memory_rel_Unit \\ fs []
+    \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange)
+    \\ rw [] \\ gvs [])
+  \\ TOP_CASE_TAC \\ gvs []
+  >- (
+    fs[encode_header_def]
+    \\ fs[encode_header_def, state_rel_def, good_dimindex_def, limits_inv_def,
+          dimword_def, memory_rel_def, heap_in_memory_store_def,
+          consume_space_def, arch_size_def]
+    \\ rfs[NOT_LESS])
+  \\ drule0 (memory_rel_UpdateThunk_Evaluated |> GEN_ALL) \\ fs []
+  \\ strip_tac \\ clean_tac
+  \\ `word_exp t (real_addr c (adjust_var h)) = SOME (Word x'')` by
+        metis_tac [get_real_offset_lemma,get_real_addr_lemma]
+  \\ fs [list_Seq_def] \\ eval_tac \\ fs [EVAL ``word_exp s1 Unit``]
+  \\ fs [wordSemTheory.mem_store_def]
+  \\ fs [lookup_insert,adjust_var_11]
+  \\ rw []
+  >- simp [option_le_max_right]
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ match_mp_tac memory_rel_insert \\ fs []
+  \\ match_mp_tac memory_rel_Unit \\ fs [UPDATE_LIST_THM]
+  \\ first_x_assum (fn th => mp_tac th THEN match_mp_tac memory_rel_rearrange)
+  \\ rw [] \\ gvs []
+  \\ ntac 2 disj2_tac \\ ntac 2 disj1_tac \\ gvs []
+  \\ gvs [join_env_def, MEM_MAP, MEM_FILTER]
+  \\ rpt (pairarg_tac \\ gvs [])
+  \\ qexists `(n,v)` \\ gvs []
+  \\ gvs [MEM_toAList,lookup_inter_alt,lookup_insert,AllCaseEqs()]
+QED
+
 Theorem assign_ConfigGC:
    op = MemOp ConfigGC ==> ^assign_thm_goal
 Proof
@@ -14051,27 +14221,44 @@ Proof[exclude_simps = EXP_LE_LOG_SIMP EXP_LT_LOG_SIMP LE_EXP_LOG_SIMP
   \\ qexists_tac ‘x.space − LENGTH y2’ \\ fs []
 QED
 
+fun foldr1 f (x::xs) = foldr f x xs | foldr1 f [] = fail();
+
+Triviality join_lemma =
+  METIS_PROVE [] “(b1 ⇒ x) ∧ (b2 ⇒ x) ⇒ (b1 ∨ b2 ⇒ x)”;
+
+Triviality imp_assign =
+  DB.match ["-"] “_ ==> ^assign_thm_goal” |> map (#1 o #2)
+  |> foldr1 (fn (x,y) => MATCH_MP join_lemma (CONJ x y));
+
 Theorem assign_thm:
   ^assign_thm_goal
 Proof
-  Cases_on `op = GlobOp AllocGlobal` \\ fs []
-  THEN1 (fs [do_app] \\ every_case_tac \\ fs [])
-  \\ Cases_on `op = IntOp Greater` \\ fs []
-  THEN1 (fs [do_app] \\ every_case_tac \\ fs [])
-  \\ Cases_on `op = IntOp GreaterEq` \\ fs []
-  THEN1 (fs [do_app] \\ every_case_tac \\ fs [])
-  \\ map_every (fn th =>
-         (Cases_on `^(th |> concl |> dest_imp |> #1)` THEN1 (fs []
-             \\ match_mp_tac th \\ fs [])))
-      (DB.match ["-"] ``_ ==> ^assign_thm_goal`` |> map (#1 o #2))
-  \\ fs [] \\ strip_tac
-  \\ Cases_on`op = MemOp (CopyByte T)` >- (
-    fs[do_app_def,do_space_def,do_app_aux_def]
-    \\ every_case_tac \\ fs[] )
-  \\ drule0 (evaluate_GiveUp |> GEN_ALL) \\ rw [] \\ fs []
-  \\ qsuff_tac `assign c n l dest op args names_opt = (GiveUp,l)` \\ fs []
-  \\ `?f. f () = op` by (qexists_tac `K op` \\ fs []) (* here for debugging only *)
-  \\ cases_on_op `op` \\ fs [assign_def]
-  \\ rpt (PURE_CASE_TAC \\ fs [])
-  \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC
+  strip_tac
+  \\ Cases_on `op = GlobOp AllocGlobal`
+  >- (fs [do_app] \\ every_case_tac \\ fs [])
+  \\ Cases_on `op = IntOp Greater`
+  >- (fs [do_app] \\ every_case_tac \\ fs [])
+  \\ Cases_on `op = IntOp GreaterEq`
+  >- (fs [do_app] \\ every_case_tac \\ fs [])
+  \\ Cases_on`op = MemOp (CopyByte T)`
+  >- (fs[do_app_def,do_space_def,do_app_aux_def] \\ every_case_tac \\ fs[])
+  \\ irule imp_assign
+  \\ asm_rewrite_tac []
+  \\ rpt $ first_assum $ irule_at Any
+  \\ Cases_on ‘∃i. op = IntOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [])
+  \\ Cases_on ‘∃i. op = GlobOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [])
+  \\ Cases_on ‘∃i. op = MemOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []
+      \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC)
+  \\ Cases_on ‘∃i. op = BlockOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []
+      \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC)
+  \\ Cases_on ‘∃i. op = WordOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs [] \\ Cases_on ‘w’ \\ gvs [])
+  \\ Cases_on ‘∃i. op = ThunkOp i’
+  >- (fs [] \\ fs [] \\ gvs [] \\ Cases_on ‘i’ \\ gvs []
+      \\ qhdtm_x_assum`do_app`mp_tac \\ EVAL_TAC)
+  \\ Cases_on ‘op’ \\ gvs []
 QED
diff --git a/compiler/backend/proofs/data_to_word_gcProofScript.sml b/compiler/backend/proofs/data_to_word_gcProofScript.sml
index d6590d1ca7..cbf8103508 100644
--- a/compiler/backend/proofs/data_to_word_gcProofScript.sml
+++ b/compiler/backend/proofs/data_to_word_gcProofScript.sml
@@ -7,7 +7,7 @@ Libs
 Ancestors
   mllist dataSem wordSem[qualified] data_to_word backendProps
   data_to_word_memoryProof dataProps copying_gc int_bitwise
-  finite_map wordProps while set_sep semanticsProps alignment
+  finite_map wordProps While set_sep semanticsProps alignment
   word_bignum wordLang word_bignumProof gen_gc_partial gc_shared
   word_gcFunctions gen_gc[qualified]
 
@@ -1212,30 +1212,29 @@ QED
 
 Theorem is_ref_header_alt:
    good_dimindex (:'a) ==>
-    (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3) /\ ~(w ' 4))
+    (is_ref_header (w:'a word) <=> ~(w ' 2) /\ (w ' 3))
 Proof
   fs [is_ref_header_def,fcpTheory.CART_EQ,good_dimindex_def] \\ rw []
   \\ fs [word_and_def,word_index,fcpTheory.FCP_BETA]
   \\ rw [] \\ eq_tac \\ rw [] \\ fs []
   \\ TRY (qpat_x_assum `!x._`
        (fn th => qspec_then `2` mp_tac th
-                 \\ qspec_then `3` mp_tac th
-                 \\ qspec_then `4` mp_tac th ))
+                 \\ qspec_then `3` mp_tac th))
   \\ fs [] \\ Cases_on `i = 2`
-  \\ fs [] \\ Cases_on `i = 3`
-  \\ fs [] \\ Cases_on `i = 4` \\ fs []
+  \\ fs [] \\ Cases_on `i = 3` \\ fs []
 QED
 
 Theorem is_ref_header_thm:
    (word_payload addrs ll tt0 tt1 conf = (h,ts,c5)) /\ good_dimindex (:'a) /\
     conf.len_size + 5 <= dimindex (:'a) ==>
-    (is_ref_header (h:'a word) ⇔ tt0 = RefTag)
+    (is_ref_header (h:'a word) ⇔ isMutTag tt0)
 Proof
   Cases_on `tt0` \\ fs [word_payload_def] \\ rw []
   \\ fs [make_header_def,make_byte_header_def,is_ref_header_alt]
   \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index]
   \\ rw []
   \\ fs [word_or_def,fcpTheory.FCP_BETA,good_dimindex_def,word_lsl_def,word_index]
+  \\ simp [isMutTag_def]
 QED
 
 Definition is_Ref_def:
@@ -1252,7 +1251,7 @@ End
 Theorem word_gen_gc_move_thm:
    (gen_gc$gc_move gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_heap curr s.heap conf *
      word_list pa xs * frame) (fun2set (m,dm)) /\
@@ -1322,7 +1321,7 @@ Proof
   \\ drule is_ref_header_thm
   \\ asm_simp_tac std_ss []
   \\ disch_then kall_tac
-  \\ reverse (Cases_on `tt0 = RefTag`) \\ fs []
+  \\ reverse (Cases_on `isMutTag tt0`) \\ fs []
   THEN1
    (pairarg_tac \\ full_simp_tac(srw_ss())[]
     \\ pairarg_tac \\ full_simp_tac(srw_ss())[]
@@ -1518,7 +1517,7 @@ Theorem word_gen_gc_move_roots_thm:
    !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1.
     (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_heap curr s.heap conf *
      word_list pa xs * frame) (fun2set (m,dm)) /\
@@ -1572,7 +1571,7 @@ Theorem word_gen_gc_move_list_thm = Q.prove(`
   !x xs x1 w s1 s pb1 pa1 pa m1 m ib1 i1 frame dm curr c1 k k1.
     (gen_gc$gc_move_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_heap curr s.heap conf * word_list pa xs *
      word_list k (MAP (word_addr conf) x) * frame) (fun2set (m,dm)) /\
@@ -1837,12 +1836,29 @@ Proof
   \\ drule word_list_IMP_limit \\ fs []
 QED
 
+Definition muttag_header_def:
+  muttag_header (ThunkTag e) = (thunk_tag_to_bits e ≪ 3 ‖ 6w) ∧
+  muttag_header _ = 2w
+End
+
+Theorem isMutTag_word_payload_IMP:
+  ∀x1 x2 x3.
+    word_payload ys l t qs conf = (x1,x2,x3) ∧
+    isMutTag t ⇒
+    x1 = make_header conf (muttag_header t) (LENGTH ys) ∧
+    x2 = MAP (word_addr conf) ys ∧
+    x3 = (qs = [] ∧ LENGTH ys = l ∧ (t ≠ RefTag ⇒ l = 1))
+Proof
+  rw [isMutTag_def,muttag_header_def]
+  \\ fs [word_payload_def,SF CONJ_ss,muttag_header_def]
+QED
+
 Theorem word_gen_gc_move_refs_thm:
    !k s m dm curr xs s1 pb1 pa1 m1 ib1 i1 frame c1 p1.
     (gen_gc$gc_move_refs gen_conf s = s1) /\ s1.ok /\
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
     heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_gen_gc_move_refs conf k
        ((* r2a *) p + bytes_in_word *
@@ -1935,6 +1951,14 @@ Proof
   \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def,
          heap_length_APPEND,word_payload_def,GSYM word_add_n2w,
          WORD_LEFT_ADD_DISTRIB,word_list_def]
+  \\ pairarg_tac \\ fs []
+  \\ dxrule_then drule isMutTag_word_payload_IMP
+  \\ strip_tac \\ rveq
+  \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def,
+         heap_length_APPEND,word_payload_def,GSYM word_add_n2w,
+         WORD_LEFT_ADD_DISTRIB,word_list_def]
+  \\ fs [heap_length_def,el_length_def]
+  \\ fs [GSYM heap_length_def]
   \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR] \\ rfs [] \\ rveq
   \\ ntac 4 (pop_assum mp_tac)
   \\ SEP_R_TAC \\ fs [theWord_def,isWord_def]
@@ -1976,6 +2000,12 @@ Proof
     \\ `LENGTH xs' = LENGTH l` by
           (imp_res_tac gen_gcTheory.gc_move_list_length \\ fs [])
     \\ qunabbrev_tac `newp`
+    \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def,
+          heap_length_APPEND,word_payload_def,GSYM word_add_n2w,SUM_APPEND,
+          WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]
+    \\ pairarg_tac \\ fs []
+    \\ dxrule_then drule isMutTag_word_payload_IMP
+    \\ strip_tac \\ rveq
     \\ fs [word_heap_parts_def,word_heap_APPEND,word_heap_def,word_el_def,
           heap_length_APPEND,word_payload_def,GSYM word_add_n2w,SUM_APPEND,
           WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]
@@ -1999,7 +2029,7 @@ Theorem word_gen_gc_move_data_thm:
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
     heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\
     conf.len_size + 2 < dimindex (:α) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_gen_gc_move_data conf k
        ((* h2a *) p + bytes_in_word * n2w (heap_length s.h1),
@@ -2207,7 +2237,7 @@ Theorem word_gen_gc_move_loop_thm:
     heap_length s.heap <= dimword (:'a) DIV 2 ** shift_length conf /\
     heap_length s.heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\
     conf.len_size + 2 < dimindex (:α) /\ s.r3 = [] /\ s.r2 = [] /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     (word_gen_gc_move_loop conf k
        ((* pax *) p + bytes_in_word * n2w (heap_length s.h1),
@@ -2363,7 +2393,7 @@ Theorem word_gen_gc_thm:
     heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\
     heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\
     conf.len_size + 2 < dimindex (:α) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     conf.len_size + 5 <= dimindex (:'a) /\
     good_dimindex (:'a) /\
     (word_heap curr heap conf *
@@ -2461,9 +2491,9 @@ Proof
 QED
 
 Theorem heap_drop_0:
-   heap_drop 0 h = h
+  heap_drop 0 h = h
 Proof
-Cases_on `h` >> fs[heap_drop_def,heap_split_def]
+  Cases_on `h` >> fs[heap_drop_def,heap_split_def]
 QED
 
 Theorem gc_forward_ptr_heap_split:
@@ -2551,7 +2581,7 @@ Theorem word_gen_gc_partial_move_thm:
     (heap_segment (gc_conf.gen_start,gc_conf.refs_start) gcstate.heap = SOME(old,current,refs)) /\
     heap_length gcstate.heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * frame) (fun2set (m,dm)) /\
-    (!t r. (gc_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gc_conf.isRef (t,r) <=> isMutTag t)) /\
     (word_gen_gc_partial_move conf (word_addr conf x,n2w gcstate.a,pa,curr,m,dm,
                                     bytes_in_word * n2w gc_conf.gen_start,
                                     bytes_in_word * n2w gc_conf.refs_start) =
@@ -2667,7 +2697,7 @@ Proof
   \\ drule is_ref_header_thm
   \\ asm_simp_tac std_ss []
   \\ disch_then kall_tac
-  \\ reverse (Cases_on `tt0 = RefTag`) \\ fs []
+  \\ reverse (Cases_on `isMutTag tt0`) \\ fs []
   THEN1
    (pairarg_tac \\ full_simp_tac(srw_ss())[]
     \\ pairarg_tac \\ full_simp_tac(srw_ss())[]
@@ -2975,7 +3005,7 @@ Theorem word_gen_gc_partial_move_roots_thm:
     gen_conf.gen_start <= gen_conf.refs_start /\
     gen_conf.refs_start <= heap_length s.heap /\
     (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs * frame) (fun2set (m,dm)) /\
     (word_gen_gc_partial_move_roots conf (MAP (word_addr conf) x,n2w s.a,pa,
@@ -3043,7 +3073,7 @@ Theorem word_gen_gc_partial_move_list_thm:
     gen_conf.gen_start <= gen_conf.refs_start /\
     gen_conf.refs_start <= heap_length s.heap /\
     (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     (word_heap (curr + bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs *
      word_list k (MAP (word_addr conf) x) * frame) (fun2set (m,dm)) /\
@@ -3156,7 +3186,7 @@ Theorem word_gen_gc_partial_move_data_thm:
     gen_conf.refs_start <= heap_length s.heap /\
     (heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs)) /\
     conf.len_size + 2 < dimindex (:α) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     (word_gen_gc_partial_move_data conf k
        ((* h2a *) p + bytes_in_word * n2w (heap_length s.h1),
         n2w s.a,
@@ -3360,7 +3390,6 @@ Proof
          WORD_LEFT_ADD_DISTRIB,word_list_def,el_length_def,heap_length_def]
 QED
 
-
 Theorem word_gen_gc_partial_move_ref_list_thm:
    !x ck xs x1 s1 s pa1 pa m1 m i1 frame dm curr c1 k old current refs.
     (gen_gc_partial$gc_move_ref_list gen_conf s x = (x1,s1)) /\ s1.ok /\ s.h2 = [] /\ s.r4 = [] /\
@@ -3372,7 +3401,7 @@ Theorem word_gen_gc_partial_move_ref_list_thm:
     heap_segment (gen_conf.gen_start,gen_conf.refs_start) s.heap = SOME(old,current,refs) /\
     heap_length x <= heap_length s.heap /\
     EVERY isRef x /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     heap_length s.heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     (word_heap (curr+bytes_in_word * n2w(heap_length old)) current conf * word_list pa xs *
      word_heap k x conf * frame) (fun2set (m,dm)) /\
@@ -3419,10 +3448,13 @@ Proof
   \\ fs[word_heap_def] \\ rfs[]
   \\ PairCases_on `b`
   \\ fs[word_el_def]
-  \\ pairarg_tac \\ fs[isRef_def] \\ rveq \\ fs[word_payload_def]
+  \\ pairarg_tac \\ fs []
+  \\ pairarg_tac \\ fs [isRef_def]
+  \\ dxrule_then drule isMutTag_word_payload_IMP
+  \\ strip_tac \\ rveq
   \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR]
   \\ rveq \\ fs[word_list_def]
-  \\ `m k = Word(make_header conf 2w (LENGTH l))` by SEP_R_TAC
+  \\ `m k = Word(make_header conf (muttag_header b0) (LENGTH l))` by SEP_R_TAC
   \\ fs[theWord_def,el_length_def]
   \\ ntac 2 (pairarg_tac \\ fs[])
   \\ drule(GEN_ALL word_gen_gc_partial_move_list_thm)
@@ -3451,10 +3483,13 @@ Proof
   \\ fs[word_heap_APPEND,word_heap_def,word_el_def,el_length_def]
   \\ pairarg_tac \\ fs[] \\ fs[word_list_def]
   \\ fs[word_payload_def] \\ rveq \\ fs[]
+  \\ dxrule_then drule isMutTag_word_payload_IMP
+  \\ strip_tac \\ rveq
+  \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR]
   \\ fs[GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB,heap_length_def]
   \\ fs[AC STAR_ASSOC STAR_COMM]
   \\ fs[SEP_CLAUSES]
-  \\ fs[isRef_def]
+  \\ fs[isRef_def,isMutTag_def]
 QED
 
 val gc_move_ref_list_IMP = prove (
@@ -3504,17 +3539,18 @@ Proof
   Induct >- fs[gc_move_ref_list_def]
   >> Cases >> rpt strip_tac
   >> fs[gc_move_ref_list_def]
-  >> rveq >> fs[is_Ref_def]
+  >> rveq >> fs[is_Ref_def,isMutTag_def]
   >> ntac 2 (pairarg_tac >> fs[])
-  >> rveq >> fs[is_Ref_def]
+  >> rveq >> fs[is_Ref_def,isMutTag_def]
   >> metis_tac[]
 QED
 
 Theorem EVERY_is_Ref_isRef:
-   (∀t r. f (t,r) ⇔ t = RefTag) ==> EVERY (is_Ref f) refs = EVERY isRef refs
+   (∀t r. f (t,r) ⇔ isMutTag t) ==> EVERY (is_Ref f) refs = EVERY isRef refs
 Proof
-  Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac >> fs[isRef_def,is_Ref_def]
-  >> Cases_on `b` >> fs[isRef_def]
+  Induct_on `refs` >- fs[] >> Cases >> rpt strip_tac
+  >> fs[isRef_def,is_Ref_def,isMutTag_def]
+  >> Cases_on `b` >> fs[isRef_def,isMutTag_def]
 QED
 
 Definition ends_with_refs_def:
@@ -3523,7 +3559,7 @@ Definition ends_with_refs_def:
 End
 
 Theorem word_gen_gc_partial_thm:
-   !m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new.
+  ∀m dm curr s1 pa1 m1 i1 frame c1 roots heap roots1 roots1' new.
     (gen_gc_partial$partial_gc gen_conf (roots,heap) = (roots1,s1)) /\ s1.ok /\
     heap_length heap <= dimword (:'a) DIV 2 ** shift_length conf /\
     heap_length heap * (dimindex (:'a) DIV 8) < dimword (:'a) /\
@@ -3533,7 +3569,7 @@ Theorem word_gen_gc_partial_thm:
     ends_with_refs gen_conf.refs_start heap /\
     heap_length heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     conf.len_size + 2 < dimindex (:α) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     (word_gen_gc_partial conf (MAP (word_addr conf) roots,curr,new,
                                bytes_in_word * n2w (heap_length heap),m,dm,
                                bytes_in_word * n2w gen_conf.gen_start,
@@ -3673,7 +3709,7 @@ Theorem word_gen_gc_partial_full_thm:
     gen_conf.refs_start <= heap_length heap /\
     heap_length heap * (dimindex (:α) DIV 8) < dimword (:α) /\
     conf.len_size + 2 < dimindex (:α) /\
-    (!t r. (gen_conf.isRef (t,r) <=> t = RefTag)) /\
+    (!t r. (gen_conf.isRef (t,r) <=> isMutTag t)) /\
     (word_gen_gc_partial_full conf (MAP (word_addr conf) roots,curr,new,
                                bytes_in_word * n2w (heap_length heap),m,dm,
                                bytes_in_word * n2w gen_conf.gen_start,
@@ -3900,7 +3936,7 @@ Proof
   fs [abs_ml_inv_def,unused_space_inv_def,gc_kind_inv_def]
   \\ strip_tac \\ fs []
   \\ `EVERY isDataElement h2` by
-       (fs [EVERY_MEM] \\ Cases \\ strip_tac \\ res_tac \\ fs [isRef_def])
+       (fs [EVERY_MEM] \\ Cases \\ strip_tac \\ res_tac \\ fs [isRef_def,isMutTag_def])
   \\ fs [data_up_to_def]
   \\ Cases_on `sp + sp1 = 0` \\ fs []
   THEN1
@@ -4610,7 +4646,7 @@ Proof
     \\ fs [heap_split_0]
     \\ fs [gen_state_ok_def,EVERY_MAP,gen_start_ok_def,heap_split_0]
     \\ fs [heap_split_def,el_length_def] \\ every_case_tac
-    \\ fs [isRef_def,heap_lookup_def])
+    \\ fs [isRef_def,heap_lookup_def,isMutTag_def])
   \\ pop_assum $ irule_at Any
   \\ CASE_TAC \\ fs []
   \\ fs [heap_in_memory_store_def,heap_length_heap_expand,word_heap_heap_expand]
@@ -5321,16 +5357,17 @@ QED
 
 val _ = temp_delsimps ["fromAList_def"]
 
-Theorem state_rel_call_env_push_env: (* TODO: tidy up proof *)
-   !opt:(num # 'a wordLang$prog # num # num) option.
-      state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\
-      get_vars args s.locals = SOME xs /\
-      get_vars (MAP adjust_var args) t = SOME ws /\
-      dataSem$cut_env r s.locals = SOME x /\
-      wordSem$cut_envs (adjust_sets r) t.locals = SOME y ==>
-      state_rel c q l (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s)))
-       (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) []
-       ((l1,l2)::locs)
+Theorem state_rel_call_env_push_opt:
+  ∀(opt:(num # 'a wordLang$prog # num # num) option).
+    state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧
+    lookup 0 t.locals = SOME (Loc l1 l2) ∧
+    LENGTH xs = LENGTH ws ∧
+    cut_env r s.locals = SOME x ∧
+    cut_envs (adjust_sets r) t.locals = SOME y ⇒
+    state_rel c q l
+      (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s)))
+      (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) []
+      ((l1,l2)::locs)
 Proof
   Cases \\ TRY (PairCases_on `x'`) \\ full_simp_tac(srw_ss())[]
   \\ full_simp_tac(srw_ss())[state_rel_def,call_env_def,push_env_def,
@@ -5383,16 +5420,16 @@ Proof
     \\ full_simp_tac(srw_ss())[DIV_LT_X]
     \\ `k < 2 + LENGTH xs * 2 /\ 0 < LENGTH xs * 2` by
      (rev_full_simp_tac(srw_ss())[] \\ Cases_on `xs` \\ full_simp_tac(srw_ss())[]
-      THEN1 (Cases_on `k` \\ full_simp_tac(srw_ss())[]
-      \\ Cases_on `n` \\ full_simp_tac(srw_ss())[] \\ decide_tac)
-      \\ full_simp_tac(srw_ss())[MULT_CLAUSES] \\ decide_tac)
+      THEN1 (gvs [] \\ Cases_on `k` \\ gvs [DECIDE “SUC n < 2 ⇔ n = 0”])
+      \\ Cases_on ‘ws’ \\ gvs [])
     \\ full_simp_tac(srw_ss())[] \\ qexists_tac `(k - 2) DIV 2` \\ full_simp_tac(srw_ss())[]
     \\ full_simp_tac(srw_ss())[DIV_LT_X]
+    \\ gvs []
     \\ Cases_on `k` \\ full_simp_tac(srw_ss())[]
     \\ Cases_on `n` \\ full_simp_tac(srw_ss())[DECIDE ``SUC (SUC n) = n + 2``]
     \\ full_simp_tac(srw_ss())[MATCH_MP ADD_DIV_RWT (DECIDE ``0<2:num``)]
     \\ full_simp_tac(srw_ss())[GSYM ADD1,EL] \\ NO_TAC)
-  \\ full_simp_tac(srw_ss())[] \\ disj1_tac \\ disj2_tac
+  \\ full_simp_tac(srw_ss())[] \\ disj2_tac \\ disj1_tac
   \\ Cases_on `x'` \\ full_simp_tac(srw_ss())[join_env_def,MEM_MAP,MEM_FILTER,EXISTS_PROD]
   \\ full_simp_tac(srw_ss())[MEM_toAList] \\ srw_tac[][MEM_ZIP]
   \\ full_simp_tac(srw_ss())[lookup_fromList2,lookup_fromList,lookup_inter_alt]
@@ -5416,6 +5453,45 @@ Proof
   \\ imp_res_tac lookup_adjust_var_after_cut \\ gvs []
 QED
 
+Theorem state_rel_call_env_push:
+  state_rel c l1 l2 s t (ZIP(xs,ws)) locs ∧
+  LENGTH xs = LENGTH ws ∧
+  lookup 0 t.locals = SOME (Loc l1 l2) ∧
+  cut_env r s.locals = SOME x ∧
+  cut_envs (adjust_sets r) t.locals = SOME y ⇒
+  state_rel c q l
+    (call_env xs ss (push_env x F (dec_clock s)))
+    (call_env (Loc q l::ws) ss (push_env y NONE (dec_clock t))) []
+    ((l1,l2)::locs)
+Proof
+  strip_tac
+  \\ drule_all (state_rel_call_env_push_opt |> Q.SPEC ‘NONE’ |> SRULE [])
+  \\ fs []
+QED
+
+Theorem state_rel_call_env_push_env: (* TODO: tidy up proof *)
+  !opt:(num # 'a wordLang$prog # num # num) option.
+    state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\
+    get_vars args s.locals = SOME xs /\
+    get_vars (MAP adjust_var args) t = SOME ws /\
+    dataSem$cut_env r s.locals = SOME x /\
+    wordSem$cut_envs (adjust_sets r) t.locals = SOME y ==>
+    state_rel c q l (call_env xs ss (push_env x (IS_SOME opt) (dec_clock s)))
+       (call_env (Loc q l::ws) ss (push_env y opt (dec_clock t))) []
+       ((l1,l2)::locs)
+Proof
+  rpt strip_tac
+  \\ irule state_rel_call_env_push_opt
+  \\ imp_res_tac get_vars_IMP_LENGTH \\ full_simp_tac(srw_ss())[]
+  \\ imp_res_tac wordPropsTheory.get_vars_length_lemma \\ full_simp_tac(srw_ss())[IS_SOME_IF]
+  \\ rpt $ first_x_assum $ irule_at $ Pos hd
+  \\ fs [state_rel_def]
+  \\ rpt $ first_x_assum $ irule_at Any
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+  \\ drule_all word_ml_inv_get_vars_IMP
+  \\ fs []
+QED
+
 Theorem find_code_thm_ret:
       state_rel c l1 l2 s (t:('a,'c,'ffi)wordSem$state) [] locs /\
       get_vars args s.locals = SOME xs /\
@@ -6841,8 +6917,8 @@ Proof
 QED
 
 Theorem soundness_size_of:
-  !lims roots r1 s1 root_vars
-   (vars:'a word_loc heap_address list) n2 r2 s2 p1 refs.
+  ∀lims roots r1 s1 root_vars
+    (vars:'a word_loc heap_address list) n2 r2 s2 p1 refs.
     (∀n. reachable_refs root_vars refs n ⇒
          bc_ref_inv c n refs (f,tf,heap,be)) /\
     LIST_REL (λv x. v_inv c v (x,f,tf,heap)) root_vars vars /\
@@ -6852,7 +6928,7 @@ Theorem soundness_size_of:
     FDOM f SUBSET domain refs /\ subspt r1 refs /\
     (lims.arch_64_bit ⇔ dimindex (:α) = 64) /\
     size_of lims roots r1 s1 = (n2,r2,s2) ==>
-    ?p2. SUM (MAP (lookup_len heap) p2) <= n2 + SUM (MAP (lookup_len heap) p1) /\
+    ∃p2. SUM (MAP (lookup_len heap) p2) <= n2 + SUM (MAP (lookup_len heap) p1) /\
          traverse_heap heap p1 vars p2 /\ subspt r2 refs /\
          IMAGE ($' tf) (domain s2) SUBSET set p2 /\
          IMAGE ($' f) (domain refs DIFF domain r2) SUBSET set p2
@@ -6887,7 +6963,7 @@ Proof
     \\ asm_exists_tac \\ fs []
     \\ asm_exists_tac \\ fs []
     \\ fs [EXTENSION] \\ metis_tac [])
-  THEN1 (* Word case *)
+  >~ [‘Word64’] >-
    (fs [size_of_def] \\ rveq
     \\ fs [v_inv_def] \\ rveq \\ fs [Word64Rep_def]
     \\ every_case_tac \\ fs []
@@ -6896,7 +6972,7 @@ Proof
     \\ fs [SUBSET_DEF]
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs [])
-  THEN1 (* Number case *)
+  >~ [‘Number’] >-
    (fs [] \\ rveq \\ fs [] \\ fs [v_inv_def]
     \\ Cases_on `small_int (:α) i` \\ fs [] \\ rveq \\ fs []
     THEN1
@@ -6912,12 +6988,12 @@ Proof
     \\ fs [SUBSET_DEF]
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs [])
-  THEN1 (* CodePtr case *)
+  >~ [‘CodePtr’] >-
    (fs [size_of_def] \\ rveq
     \\ fs [v_inv_def] \\ rveq \\ fs []
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
     \\ qexists_tac `p1` \\ fs [])
-  THEN1 (* RefPtr case *)
+  >~ [‘RefPtr r1 r’] >-
    (fs [size_of_def] \\ rveq
     \\ fs [v_inv_def] \\ rveq \\ fs [CaseEq"option"] \\ rveq \\ fs []
     THEN1
@@ -6925,8 +7001,9 @@ Proof
       THEN1 (once_rewrite_tac [traverse_heap_cases]\\ fs [])
       \\ fs [SUBSET_DEF] \\ first_x_assum match_mp_tac
       \\ qexists_tac `r` \\ fs [] \\ fs [domain_lookup])
+    \\ rename [‘lookup r refs1 = SOME v’]
     \\ reverse (Cases_on `v`) \\ fs []
-    THEN1
+    >~ [‘ByteArray b l’] >-
      (rveq \\ fs [] \\ fs []
       \\ first_x_assum (qspec_then `r` mp_tac)
       \\ (impl_tac THEN1 fs [reachable_refs_def,get_refs_def])
@@ -6940,6 +7017,33 @@ Proof
       \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
       \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
       \\ fs [SUBSET_DEF,PULL_EXISTS] \\ metis_tac [])
+    >~ [‘Thunk t a’] >-
+     (pairarg_tac \\ gvs [PULL_EXISTS]
+      \\ first_assum (qspec_then `r` mp_tac)
+      \\ impl_tac THEN1 fs [reachable_refs_def,get_refs_def]
+      \\ simp [bc_ref_inv_def,FLOOKUP_DEF]
+      \\ CASE_TAC \\ gvs []
+      \\ fs [subspt_lookup]
+      \\ first_assum drule
+      \\ strip_tac \\ fs [] \\ rveq \\ fs []
+      \\ strip_tac \\ fs []
+      \\ last_x_assum $ drule_at $ Pos $ el 2
+      \\ disch_then $ qspecl_then [`f ' r :: p1`,`refs`] mp_tac
+      \\ impl_tac THEN1
+       (fs [] \\ fs [lookup_delete,SUBSET_DEF,PULL_EXISTS]
+        \\ simp [SF DNF_ss]
+        \\ rpt strip_tac
+        \\ first_x_assum match_mp_tac
+        \\ fs [reachable_refs_def,get_refs_def]
+        \\ once_rewrite_tac [RTC_CASES1] \\ disj2_tac
+        \\ rename [`RTC _ r5 r6`] \\ qexists_tac `r5` \\ fs []
+        \\ simp [ref_edge_def,get_refs_def,MEM_FLAT,MEM_MAP,PULL_EXISTS]
+        \\ asm_exists_tac \\ fs [])
+      \\ strip_tac \\ qexists_tac `p2` \\ fs []
+      \\ rfs [lookup_len_def,el_length_def,ThunkBlock_def]
+      \\ once_rewrite_tac [traverse_heap_cases]
+      \\ rpt disj2_tac \\ fs [])
+    \\ rename [‘ValueArray l’]
     \\ pop_assum mp_tac
     \\ pairarg_tac \\ fs [] \\ rw []
     \\ first_assum (qspec_then `r` mp_tac)
@@ -6964,7 +7068,7 @@ Proof
     \\ imp_res_tac LIST_REL_LENGTH \\ fs []
     \\ once_rewrite_tac [traverse_heap_cases]
     \\ rpt disj2_tac \\ fs [])
-  THEN1 (* empty Block *)
+  >~ [‘Block ts tag []’] >-
    (fs [size_of_def] \\ rveq
     \\ fs [v_inv_def] \\ rveq \\ fs []
     \\ once_rewrite_tac [traverse_heap_cases] \\ fs []
diff --git a/compiler/backend/proofs/data_to_word_memoryProofScript.sml b/compiler/backend/proofs/data_to_word_memoryProofScript.sml
index 25d9ff223f..558af85b73 100644
--- a/compiler/backend/proofs/data_to_word_memoryProofScript.sml
+++ b/compiler/backend/proofs/data_to_word_memoryProofScript.sml
@@ -4,7 +4,7 @@
 Theory data_to_word_memoryProof
 Ancestors
   dataSem dataProps wordSem data_to_word gc_shared gc_combined
-  word_gcFunctions copying_gc int_bitwise set_sep labSem while
+  word_gcFunctions copying_gc int_bitwise set_sep labSem While
   alignment multiword
 Libs
   preamble helperLib blastLib[qualified]
@@ -114,7 +114,12 @@ QED
 (* -- *)
 
 Datatype:
-  tag = BlockTag num | RefTag | BytesTag bool num | NumTag bool | Word64Tag
+  tag = BlockTag num         (* immutable Block                         *)
+      | RefTag               (* mutable arrays / references             *)
+      | BytesTag bool num    (* mutable byte arrays / immutable strings *)
+      | ThunkTag thunk_mode  (* mutable thunks                          *)
+      | NumTag bool          (* immutable bignum on the heap            *)
+      | Word64Tag            (* immutable word64 on the heap            *)
 End
 
 Definition BlockRep_def:
@@ -217,43 +222,58 @@ Definition ref_edge_def:
   ref_edge refs (x:num) (y:num) =
     case lookup x refs of
     | SOME (ValueArray ys) => MEM y (get_refs (Block 0 ARB ys))
+    | SOME (Thunk _ v) => MEM y (get_refs (Block 0 ARB [v]))
     | _ => F
 End
 
 Definition reachable_refs_def:
   reachable_refs roots refs t =
-    ?x r. MEM x roots /\ MEM r (get_refs x) /\ RTC (ref_edge refs) r t
+    ∃x r. MEM x roots ∧ MEM r (get_refs x) ∧ RTC (ref_edge refs) r t
 End
 
 Definition RefBlock_def:
   RefBlock xs = DataElement xs (LENGTH xs) (RefTag,[])
 End
 
+Definition ThunkBlock_def:
+  ThunkBlock ev x = DataElement [x] 1 (ThunkTag ev,[])
+End
+
 Definition bc_ref_inv_def:
   bc_ref_inv conf n refs (f,tf,heap,be) =
     case (FLOOKUP f n, lookup n refs) of
     | (SOME x, SOME (ValueArray ys)) =>
-        (?zs. (heap_lookup x heap = SOME (RefBlock zs)) /\
-              EVERY2 (\z y. v_inv conf y (z,f,tf,heap)) zs ys)
+        (∃zs. heap_lookup x heap = SOME (RefBlock zs) ∧
+              EVERY2 (λz y. v_inv conf y (z,f,tf,heap)) zs ys)
     | (SOME x, SOME (ByteArray flag bs)) =>
         let ws = LENGTH bs DIV (dimindex (:α) DIV 8) + 1 in
           (heap_lookup x heap = SOME (Bytes be flag bs (REPLICATE ws (0w:'a word))))
+    | (SOME x, SOME (Thunk ev v)) =>
+        (∃(z:α word_loc heap_address).
+           heap_lookup x heap = SOME (ThunkBlock ev z) ∧
+           v_inv conf v (z,f,tf,heap))
     | _ => F
 End
 
 (* TODO: MOVE *)
 Definition v_all_ts_def:
-  v_all_ts (Block ts _ xs) = ts :: FLAT (MAP v_all_ts xs)
-∧ v_all_ts _ = []
+  v_all_ts (Block ts _ xs) = ts :: FLAT (MAP v_all_ts xs) ∧
+  v_all_ts _ = []
 Termination
   WF_REL_TAC `measure (v_size)` \\ rpt strip_tac \\ Induct_on `xs`
   \\ srw_tac [] [v_size_def] \\ res_tac \\ DECIDE_TAC
 End
 
+Definition find_ref_def[simp]:
+  find_ref (ValueArray l) x = MEM x l ∧
+  find_ref (Thunk m v) x = (v = x) ∧
+  find_ref _ _ = F
+End
+
 (* TODO: MOVE *)
 Definition all_ts_def:
   all_ts refs stack =
-    let refs_v = {x | ∃n l. sptree$lookup n refs = SOME (ValueArray l) ∧ MEM x l}
+    let refs_v = {x | ∃n r. sptree$lookup n refs = SOME r ∧ find_ref r x}
     in {ts | ∃x. (x ∈ refs_v ∨ MEM x stack) ∧ MEM ts (v_all_ts x)}
 End
 
@@ -286,8 +306,12 @@ Definition unused_space_inv_def:
     data_up_to ptr heap
 End
 
+Definition isMutTag_def:
+  isMutTag t ⇔ t = RefTag ∨ ∃ev. t = ThunkTag ev
+End
+
 Definition isRef_def:
-  isRef (DataElement ys l (tag,qs)) = (tag = RefTag) /\
+  isRef (DataElement ys l (tag,qs)) = isMutTag tag ∧
   isRef _ = F
 End
 
@@ -570,8 +594,16 @@ Proof
   \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) []
   \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,f_o_f_DEF]
   \\ Cases_on `x'` \\ full_simp_tac (srw_ss()) []
-  \\ TRY (fs[Bytes_def,LET_THM] >> res_tac >> simp[ADDR_MAP_def]
-          \\ rw [] \\ qexists_tac `ws` \\ fs [] >> NO_TAC)
+  >~ [‘lookup n refs = SOME (ByteArray b l)’] >-
+   (fs[Bytes_def,LET_THM] \\ res_tac \\ simp[ADDR_MAP_def]
+    \\ rw [] \\ qexists_tac `ws` \\ fs [])
+  >~ [‘lookup n refs = SOME (Thunk ev v)’] >-
+   (fs [ThunkBlock_def]
+    \\ res_tac \\ gvs []
+    \\ disch_then $ drule_at Any \\ gvs [] \\ rw []
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ first_x_assum $ drule_at (Pat `heap_lookup _ _ = SOME _`) \\ rw []
+    \\ Cases_on `z` \\ gvs [ADDR_MAP_def, ADDR_APPLY_def])
   \\ res_tac \\ full_simp_tac (srw_ss()) [LENGTH_ADDR_MAP,EVERY2_ADDR_MAP]
   \\ rpt strip_tac \\ qpat_x_assum `EVERY2 qqq zs l` MP_TAC
   \\ match_mp_tac EVERY2_IMP_EVERY2 \\ simp_tac std_ss [] \\ rpt strip_tac
@@ -592,7 +624,7 @@ Proof
    (rpt strip_tac \\ qpat_x_assum `!x.bb` match_mp_tac \\ metis_tac [RTC_CASES1])
   \\ `RTC (ref_edge refs) r r' /\ RTC (ref_edge refs) r r` by metis_tac [RTC_CASES1]
   \\ res_tac \\ qpat_x_assum `!x.bb` (K ALL_TAC)
-  \\ full_simp_tac std_ss [bc_ref_inv_def,RefBlock_def,RTC_REFL]
+  \\ full_simp_tac std_ss [bc_ref_inv_def,RefBlock_def,ThunkBlock_def,RTC_REFL]
   \\ Cases_on `FLOOKUP f r` \\ full_simp_tac (srw_ss()) []
   \\ Cases_on `FLOOKUP f r'` \\ full_simp_tac (srw_ss()) []
   \\ Cases_on `lookup r refs` \\ full_simp_tac (srw_ss()) []
@@ -675,8 +707,8 @@ Definition all_reachable_from_roots_def:
        p IN reachable_addresses roots heap
 End
 
-val IN_reachable_addresses =
-  ``x ∈ reachable_addresses roots heap``
+Triviality IN_reachable_addresses =
+  “x ∈ reachable_addresses roots heap”
   |> SIMP_CONV std_ss [Once IN_DEF,reachable_addresses_def]
 
 Theorem reachable_addresses_related:
@@ -794,13 +826,12 @@ QED
 
 Definition make_gc_conf_def:
   make_gc_conf limit =
-    <| limit := limit; isRef := \x. FST x = RefTag |>
-        : (tag # 'a) gen_gc$gen_gc_conf
+    <| limit := limit; isRef := isMutTag o FST |> : (tag # 'a) gen_gc$gen_gc_conf
 End
 
 Triviality gc_move_data_refs_split:
-  (gen_gc$gc_move cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag))
-   /\ EVERY isDataElement s.h2 /\(EVERY (λx. ¬isRef x)) s.h2 /\ EVERY isRef s.r4 ==>
+  (gen_gc$gc_move cc s x = (x1,s1)) /\ (∀t r. cc.isRef (t,r) <=> isMutTag t) /\
+   EVERY isDataElement s.h2 /\ EVERY (λx. ¬isRef x) s.h2 /\ EVERY isRef s.r4 ==>
    EVERY isDataElement s1.h2 /\
    (EVERY (λx. ¬isRef x)) s1.h2 /\ EVERY isRef s1.r4
 Proof
@@ -814,7 +845,7 @@ QED
 
 Triviality gc_move_list_data_refs_split:
   !x x1 s s1.
-  (gen_gc$gc_move_list cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag))
+  (gen_gc$gc_move_list cc s x = (x1,s1)) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t))
    /\ EVERY isDataElement s.h2 /\(EVERY (λx. ¬isRef x)) s.h2 /\ EVERY isRef s.r4 ==>
    EVERY isDataElement s1.h2 /\(EVERY (λx. ¬isRef x)) s1.h2 /\ EVERY isRef s1.r4
 Proof
@@ -825,7 +856,7 @@ QED
 
 Triviality gc_move_refs_data_refs_split:
   !cc s s1.
-  (gen_gc$gc_move_refs cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag))
+  (gen_gc$gc_move_refs cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t))
    /\ EVERY isDataElement (s.h1++s.h2) /\ (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\
    EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==>
    EVERY isDataElement (s1.h1++s1.h2) /\
@@ -847,7 +878,7 @@ QED
 
 Triviality gc_move_data_data_refs_split:
   !cc s s1.
-  (gen_gc$gc_move_data cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> t = RefTag))
+  (gen_gc$gc_move_data cc s = s1) /\ (!t r. (cc.isRef (t,r) <=> isMutTag t))
    /\ (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\
    EVERY isDataElement (s.h1++s.h2) /\
    EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==>
@@ -870,7 +901,7 @@ QED
 Triviality gc_move_loop_data_refs_split:
   !clock cc s s1.
   (gen_gc$gc_move_loop cc s clock = s1) /\
-  (!t r. (cc.isRef (t,r) <=> t = RefTag)) /\
+  (!t r. (cc.isRef (t,r) <=> isMutTag t)) /\
   EVERY isDataElement (s.h1++s.h2) /\
   (EVERY (λx. ¬isRef x)) (s.h1++s.h2) /\
   EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4) ==>
@@ -896,7 +927,7 @@ QED
 Triviality gen_gc_data_refs_split:
   !cc roots heap.
   (gen_gc cc (roots,heap) = (roots1,s)) /\
-  (!t r. (cc.isRef (t,r) <=> t = RefTag)) ==>
+  (!t r. (cc.isRef (t,r) <=> isMutTag t)) ==>
   (EVERY (λx. ¬isRef x)) (s.h1 ++ s.h2) /\
   EVERY isDataElement (s.h1 ++ s.h2) /\
   EVERY isRef (s.r1 ++ s.r2 ++ s.r3 ++ s.r4)
@@ -1154,6 +1185,7 @@ Proof
      (fs [EVERY_MEM] \\ CCONTR_TAC \\ fs []
       \\ Cases_on `x` \\ fs [isRef_def]
       \\ Cases_on `b` \\ fs [isRef_def] \\ rveq
+      \\ gvs [isMutTag_def]
       \\ res_tac \\ fs [] \\ res_tac \\ fs [])
     \\ fs [EVERY_MEM] \\ CCONTR_TAC \\ fs []
     \\ qpat_x_assum `MEM e _` (assume_tac o REWRITE_RULE [MEM_SPLIT])
@@ -1163,10 +1195,10 @@ Proof
     \\ rveq \\ fs[]
     \\ `isRef x` by metis_tac []
     \\ Cases_on `x` \\ fs [isRef_def]
-    \\ Cases_on `b` \\ fs [isRef_def]
+    \\ Cases_on `b` \\ fs [isRef_def,isMutTag_def]
     \\ Cases_on `e` \\ rveq
     \\ fs [gen_gc_partialTheory.similar_data_def,isRef_def]
-    \\ rveq \\ fs[isRef_def])
+    \\ rveq \\ fs[isRef_def,isMutTag_def])
   \\ fs [roots_ok_def]
   \\ rpt strip_tac
   \\ imp_res_tac MEM_ADDR_MAP
@@ -1735,10 +1767,11 @@ Theorem isDataElement_lemmas[simp]:
     isDataElement (Word64Rep (:'a) w) /\
     isDataElement (RefBlock ws) /\
     isDataElement (Bytes y1 y2 y3 y4) /\
+    isDataElement (ThunkBlock ev v) /\
     isDataElement (Bignum i)
 Proof
   rw [BlockRep_def,isDataElement_def,Bignum_def,i2mw_def,
-    Word64Rep_def,RefBlock_def,Bytes_def]
+      Word64Rep_def,RefBlock_def,Bytes_def,ThunkBlock_def]
 QED
 
 (* --- Allocating multiple cons-elements in one go --- *)
@@ -1817,7 +1850,7 @@ Theorem list_to_BlockReps_Ref:
      xs <> [] ==> EVERY (\v. ~isRef v) (list_to_BlockReps conf x len xs)
 Proof
   Induct \\ rw [list_to_BlockReps_def, BlockRep_def]
-  \\ TRY CASE_TAC \\ fs [isRef_def]
+  \\ TRY CASE_TAC \\ fs [isRef_def,isMutTag_def]
 QED
 
 Theorem list_to_BlockReps_NULL:
@@ -1880,8 +1913,7 @@ Theorem list_to_BlockReps_Pointer =
 Theorem list_to_v_get_refs:
    !xs t r ts.
      MEM r (get_refs (list_to_v ts t xs)) ==>
-
-       ?x. (MEM x xs \/ x = t) /\ MEM r (get_refs x)
+       ∃x. (MEM x xs \/ x = t) /\ MEM r (get_refs x)
 Proof
   Induct \\ rw [dataSemTheory.list_to_v_def]
   \\ fs [get_refs_def] \\ metis_tac []
@@ -2136,8 +2168,10 @@ Definition v_all_vs_def:
 End
 
 Definition all_vs_def:
-  all_vs refs stack = { v | ∃(n:num) l. lookup n refs = SOME (ValueArray l) ∧ MEM v (v_all_vs l)} ∪
-                      { v | MEM v (v_all_vs stack)}
+  all_vs refs stack =
+    { v | ∃(n:num) l. lookup n refs = SOME (ValueArray l) ∧ MEM v (v_all_vs l)} ∪
+    { v | ∃n ev x. lookup n refs = SOME (Thunk ev x) ∧ MEM v (v_all_vs [x])} ∪
+    { v | MEM v (v_all_vs stack)}
 End
 
 Theorem v_all_vs_MEM:
@@ -2164,12 +2198,18 @@ Theorem v_in_all_vs:
     ⇒ y ∈ all_vs refs stack
 Proof
   rw [all_vs_def]
-  >- (disj1_tac
+  >- (ntac 2 disj1_tac
      \\ cases_on `x` \\ fs [v_all_vs_def]
      \\ map_every qexists_tac [`n`,`l`]
      \\ rw []
      \\ drule_then ASSUME_TAC v_all_vs_MEM
      \\ fs [])
+  >- (disj1_tac \\ disj2_tac
+     \\ cases_on `x` \\ fs [v_all_vs_def]
+     \\ map_every qexists_tac [`n`,`ev`,`x'`]
+     \\ rw []
+     \\ drule_then ASSUME_TAC v_all_vs_MEM
+     \\ fs [])
   >- (disj2_tac
      \\ cases_on `x` \\ fs [v_all_vs_def]
      \\ drule_then ASSUME_TAC v_all_vs_MEM
@@ -2244,7 +2284,8 @@ Proof
   Cases \\  rw [all_vs_def,all_ts_def,v_all_ts_def]
   >- (drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs []
      \\ drule_then ASSUME_TAC v_all_vs_ts \\ fs []
-     \\ metis_tac [FRANGE_FLOOKUP])
+     \\ goal_assum $ drule_at Any \\ disj1_tac
+     \\ goal_assum drule \\ gvs [])
   >- (fs [MEM_FLAT,MEM_MAP] \\ rveq
      \\ `MEM a (v_all_vs l')`
         by (drule_then ASSUME_TAC v_all_vs_MEM \\ fs [MEM_v_all_vs])
@@ -2255,6 +2296,20 @@ Proof
      \\ `MEM ts (v_all_ts x)`             by metis_tac [v_all_vs_ts_MEM]
      \\ qexists_tac `x` \\ rw [] \\ disj1_tac
      \\ asm_exists_tac \\ rw [])
+  >- (drule_then assume_tac v_all_vs_MEM2 \\ gvs []
+     \\ drule_then assume_tac v_all_vs_ts \\ gvs []
+     \\ goal_assum $ drule_at Any \\ disj1_tac
+     \\ goal_assum drule \\ gvs [])
+  >- (fs [MEM_FLAT,MEM_MAP] \\ rveq
+     \\ `MEM a (v_all_vs l)`
+        by (drule_then ASSUME_TAC v_all_vs_MEM \\ fs [MEM_v_all_vs])
+     \\ drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs []
+     \\ drule_then ASSUME_TAC v_all_vs_ts \\ fs []
+     \\ `MEM a (v_all_vs [Block n0 n l])` by rw [v_all_vs_def,MEM_v_all_vs]
+     \\ `MEM a (v_all_vs [x])`            by metis_tac [v_all_vs_trans]
+     \\ `MEM ts (v_all_ts x)`             by metis_tac [v_all_vs_ts_MEM]
+     \\ qexists_tac `x` \\ rw [] \\ disj1_tac
+     \\ asm_exists_tac \\ rw [])
   >- (drule_then ASSUME_TAC v_all_vs_MEM2 \\ fs []
      \\ drule_then ASSUME_TAC v_all_vs_ts
      \\ metis_tac [])
@@ -2297,17 +2352,6 @@ Proof
      \\ metis_tac [])
 QED
 
-(* NOT USED *)
-Theorem all_ts_alt:
-  all_ts refs stack = { ts | ∃x. x ∈ all_vs refs stack ∧ MEM ts (v_all_ts x)}
-Proof
-  rw [FUN_EQ_THM]
-  \\ EQ_TAC
-  \\ rw []
-  >- (fs [all_ts_def,all_vs_def] \\ metis_tac [FRANGE_FLOOKUP,MEM_v_all_vs])
-  >- (drule MEM_in_all_ts \\ disch_then drule \\ fs [IN_DEF])
-QED
-
 Theorem v_inv_tf_update_thm:
   ∀v y f tf heap ts' a conf.
     v_inv conf v (y,f,tf,heap) ∧ ts' ∉ FDOM tf ⇒
@@ -2363,15 +2407,17 @@ Proof
      \\ rveq \\ fs [])
 QED
 
+Triviality v_inv_ind_alt =
+  v_inv_ind |> Q.SPEC `λv (x,f,tf,heap). P v x f tf heap`
+            |> SIMP_RULE std_ss []
+            |> Q.GEN `P`;
+
 Theorem v_inv_tf_restrict:
   ∀v y f tf heap conf P.
      v_inv conf v (y,f,tf,heap) ∧ (∀x. MEM x (v_all_ts v) ⇒ x ∈ P)
      ⇒ v_inv conf v (y,f, DRESTRICT tf P,heap)
 Proof
-  let val ind = theorem "v_inv_ind" |> Q.SPEC `λv (x,f,tf,heap). P v x f tf heap`
-                                    |> SIMP_RULE std_ss []
-                                    |> Q.GEN `P`
-  in ho_match_mp_tac ind end
+  ho_match_mp_tac v_inv_ind_alt
   \\ rw [v_inv_def]
   \\ every_case_tac \\ fs []
   \\ qexists_tac `xs` \\ rw []
@@ -2497,9 +2543,13 @@ Proof
   \\ rpt strip_tac \\ full_simp_tac std_ss [RefBlock_def]
   \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) []
   \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) []
-  \\ Cases_on `x'` \\ full_simp_tac (srw_ss()) []
-  THEN1 (
-    imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) []
+  \\ rename [‘lookup n refs = SOME x_ref’]
+  \\ Cases_on ‘x_ref’ \\ full_simp_tac (srw_ss()) []
+  >~ [‘lookup n refs = SOME (ByteArray b1 l1)’] >-
+   (fs[Bytes_def,LET_THM] >> imp_res_tac heap_store_rel_lemma
+    \\ metis_tac [])
+  >~ [‘lookup n refs = SOME (ValueArray array_vals)’] >-
+   (imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) []
     \\ qpat_x_assum `EVERY2 PP zs l` MP_TAC
     \\ match_mp_tac EVERY2_IMP_EVERY2 \\ full_simp_tac (srw_ss()) []
     \\ rpt strip_tac \\ res_tac
@@ -2507,8 +2557,13 @@ Proof
     \\ match_mp_tac (GEN_ALL v_inv_SUBMAP)
     \\ goal_assum (first_x_assum o mp_then Any mp_tac)
     \\ fs [])
-  \\ fs[Bytes_def,LET_THM] >> imp_res_tac heap_store_rel_lemma
-  \\ metis_tac []
+  >~ [‘lookup n refs = SOME (Thunk ev thunk_v)’] >-
+   (fs [ThunkBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma \\ full_simp_tac (srw_ss()) []
+    \\ match_mp_tac v_inv_tf_update_thm \\ asm_rewrite_tac []
+    \\ match_mp_tac (GEN_ALL v_inv_SUBMAP)
+    \\ goal_assum (first_x_assum o mp_then Any mp_tac)
+    \\ fs [])
 QED
 
 Theorem cons_thm_EMPTY:
@@ -2633,23 +2688,39 @@ Proof
   \\ BasicProvers.TOP_CASE_TAC \\ fs[]
   \\ BasicProvers.TOP_CASE_TAC \\ fs[]
   \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[]
-  \\ fs[RefBlock_def,Bytes_def]
-  \\ imp_res_tac heap_store_rel_lemma
-  \\ fs[]
-  \\ TRY (qexists_tac`ws'` \\ simp[])
-  \\ match_mp_tac EVERY2_MEM_MONO
-  \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
-  \\ simp[FORALL_PROD] \\ rw[]
-  \\ ho_match_mp_tac v_inv_tf_restrict
-  \\ conj_tac
-  >- (match_mp_tac v_inv_SUBMAP \\ simp[])
-  >- (rw [] \\ ho_match_mp_tac MEM_in_all_ts
-       \\ qexists_tac `p_2` \\ rw []
-       \\ rw [all_vs_def] \\ disj1_tac
-       \\ map_every qexists_tac [`n`,`l`] \\ rw []
-       \\ ho_match_mp_tac MEM_v_all_vs
-       \\ drule MEM_ZIP2 \\ rw []
-       \\ rw [EL_MEM])
+  >- (
+    fs[RefBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ fs[]
+    \\ match_mp_tac EVERY2_MEM_MONO
+    \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
+    \\ simp[FORALL_PROD] \\ rw[]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP \\ simp[])
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `p_2` \\ rw []
+    \\ rw [all_vs_def] \\ ntac 2 disj1_tac
+    \\ map_every qexists_tac [`n`,`l`] \\ rw []
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ drule MEM_ZIP2 \\ rw []
+    \\ rw [EL_MEM])
+  >- (
+    fs[Bytes_def]
+    \\ imp_res_tac heap_store_rel_lemma)
+  >- (
+    fs[ThunkBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ fs[]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP \\ simp[])
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ first_x_assum $ irule_at Any
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ goal_assum drule
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ rw [EL_MEM])
 QED
 
 (* bignum *)
@@ -2698,7 +2769,7 @@ Proof
   \\ rfs[]
   \\ fs[bc_stack_ref_inv_def]
   \\ conj_tac THEN1
-   (`tag <> RefTag` by
+   (`tag ≠ RefTag ∧ ∀ev. tag ≠ ThunkTag ev` by
      (CCONTR_TAC \\ qpat_x_assum `Abbrev _` mp_tac
       \\ fs [Bignum_def,markerTheory.Abbrev_def]
       \\ pairarg_tac \\ fs [] \\ NO_TAC)
@@ -2754,23 +2825,39 @@ Proof
   \\ BasicProvers.TOP_CASE_TAC \\ fs[]
   \\ BasicProvers.TOP_CASE_TAC \\ fs[]
   \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[]
-  \\ fs[RefBlock_def,Bytes_def]
-  \\ imp_res_tac heap_store_rel_lemma
-  \\ fs[]
-  \\ TRY (qexists_tac`ws'` \\ simp[])
-  \\ match_mp_tac EVERY2_MEM_MONO
-  \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
-  \\ simp[FORALL_PROD] \\ rw[]
-  \\ ho_match_mp_tac v_inv_tf_restrict
-  \\ conj_tac
-  >- (match_mp_tac v_inv_SUBMAP \\ simp[])
-  >- (rw [] \\ ho_match_mp_tac MEM_in_all_ts
-       \\ qexists_tac `p_2` \\ rw []
-       \\ rw [all_vs_def] \\ disj1_tac
-       \\ map_every qexists_tac [`n`,`l`] \\ rw []
-       \\ ho_match_mp_tac MEM_v_all_vs
-       \\ drule MEM_ZIP2 \\ rw []
-       \\ rw [EL_MEM])
+  >- (
+    fs[RefBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ fs[]
+    \\ match_mp_tac EVERY2_MEM_MONO
+    \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
+    \\ simp[FORALL_PROD] \\ rw[]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP \\ simp[])
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `p_2` \\ rw []
+    \\ rw [all_vs_def] \\ ntac 2 disj1_tac
+    \\ map_every qexists_tac [`n`,`l`] \\ rw []
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ drule MEM_ZIP2 \\ rw []
+    \\ rw [EL_MEM])
+  >- (
+    fs[Bytes_def]
+    \\ imp_res_tac heap_store_rel_lemma)
+  >- (
+    fs[ThunkBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ fs[]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP \\ simp[])
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ first_x_assum $ irule_at Any
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ goal_assum drule
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ rw [EL_MEM])
 QED
 
 (* update ref *)
@@ -2785,6 +2872,16 @@ Proof
   \\ rw [lookup_insert]
 QED
 
+Triviality ref_edge_Thunk:
+  ref_edge (insert ptr (Thunk ev v) refs) x y =
+    if x = ptr then MEM y (get_refs (Block 0 ARB [v])) else ref_edge refs x y
+Proof
+  simp_tac std_ss [FUN_EQ_THM,ref_edge_def] \\ rpt strip_tac
+  \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM]
+  \\ Cases_on `x = ptr` \\ full_simp_tac (srw_ss()) []
+  \\ rw [lookup_insert]
+QED
+
 Triviality reachable_refs_UPDATE:
   reachable_refs (xs ++ RefPtr b ptr::stack) (insert ptr (ValueArray xs) refs) n ==>
     reachable_refs (xs ++ RefPtr b ptr::stack) refs n
@@ -2809,6 +2906,30 @@ Proof
   \\ full_simp_tac std_ss [] \\ res_tac
 QED
 
+Triviality reachable_refs_Thunk_UPDATE:
+  reachable_refs (v::RefPtr b ptr::stack) (insert ptr (Thunk ev v) refs) n ==>
+    reachable_refs (v::RefPtr b ptr::stack) refs n
+Proof
+  full_simp_tac std_ss [reachable_refs_def] \\ rpt strip_tac
+  \\ Cases_on `?m. MEM m (get_refs (Block 0 ARB [v])) /\
+        RTC (ref_edge refs) m n` THEN1
+   (full_simp_tac std_ss [get_refs_def,MEM_FLAT,MEM_MAP]
+    \\ gvs [] \\ metis_tac [])
+  \\ full_simp_tac std_ss [METIS_PROVE [] ``~b \/ c <=> b ==> c``]
+  \\ full_simp_tac std_ss [] \\ Q.LIST_EXISTS_TAC [`x`,`r`]
+  \\ full_simp_tac std_ss []
+  \\ full_simp_tac std_ss [RTC_eq_NRC]
+  \\ Q.ABBREV_TAC `k = n'` \\ POP_ASSUM (K ALL_TAC) \\ qexists_tac `k`
+  \\ POP_ASSUM MP_TAC \\ POP_ASSUM MP_TAC \\ REPEAT (POP_ASSUM (K ALL_TAC))
+  \\ Q.SPEC_TAC (`r`,`r`) \\ Induct_on `k`
+  \\ full_simp_tac std_ss [NRC]
+  \\ rpt strip_tac \\ full_simp_tac std_ss [] \\ res_tac
+  \\ qexists_tac `z` \\ full_simp_tac std_ss []
+  \\ full_simp_tac std_ss [ref_edge_Thunk]
+  \\ reverse (Cases_on `r = ptr`)
+  \\ full_simp_tac std_ss [] \\ res_tac
+QED
+
 Triviality reachable_refs_UPDATE1:
   reachable_refs (xs ++ RefPtr b ptr::stack) (insert ptr (ValueArray xs1) refs) n ==>
     (!v. MEM v xs1 ==> ~MEM v xs ==> ?xs2. (lookup ptr refs = SOME (ValueArray xs2)) /\ MEM v xs2) ==>
@@ -2919,6 +3040,7 @@ Proof
   \\ full_simp_tac std_ss [heap_store_RefBlock_thm]
   \\ strip_tac THEN1
    (full_simp_tac std_ss [RefBlock_inv_def]
+    \\ rw []
     \\ full_simp_tac std_ss [heap_lookup_RefBlock_lemma]
     \\ full_simp_tac std_ss [isRefBlock_def] \\ metis_tac [])
   \\ strip_tac THEN1 (full_simp_tac std_ss [heap_lookup_PREFIX])
@@ -2996,6 +3118,154 @@ Proof
   THEN1 (full_simp_tac (srw_ss()) [v_inv_def,SUBMAP_DEF])
 QED
 
+Definition isThunkBlock_def:
+  isThunkBlock x = ?ev v. x = ThunkBlock ev v
+End
+
+Definition ThunkBlock_inv_def:
+  ThunkBlock_inv heap heap2 <=>
+    (!n x. (heap_lookup n heap = SOME x) /\ ~(isThunkBlock x) ==>
+           (heap_lookup n heap2 = SOME x)) /\
+    (!n x. (heap_lookup n heap2 = SOME x) /\ ~(isThunkBlock x) ==>
+           (heap_lookup n heap = SOME x))
+End
+
+Theorem heap_store_ThunkBlock_thm:
+  ∀ha.
+    (heap_store (heap_length ha) [ThunkBlock ev1 v1] (ha ++ ThunkBlock ev2 v2::hb) =
+    (ha ++ ThunkBlock ev1 v1::hb,T))
+Proof
+  Induct \\ full_simp_tac (srw_ss()) [heap_store_def,heap_length_def]
+  >- (
+    full_simp_tac std_ss [ThunkBlock_def,el_length_def]
+    \\ strip_tac)
+  \\ rpt strip_tac \\ full_simp_tac std_ss []
+  \\ `~(el_length h + SUM (MAP el_length ha) < el_length h) /\ el_length h <> 0` by
+       (Cases_on `h` \\ full_simp_tac std_ss [el_length_def] \\ DECIDE_TAC)
+  \\ full_simp_tac std_ss [LET_DEF]
+QED
+
+Triviality heap_lookup_ThunkBlock_lemma:
+  (heap_lookup n (ha ++ ThunkBlock ev v::hb) = SOME x) =
+      if n < heap_length ha then
+        (heap_lookup n ha = SOME x)
+      else if n = heap_length ha then
+        (x = ThunkBlock ev v)
+      else if heap_length ha + 2 <= n then
+        (heap_lookup (n - heap_length ha - 2) hb = SOME x)
+      else F
+Proof
+  Cases_on `n < heap_length ha` \\ full_simp_tac std_ss [LESS_IMP_heap_lookup]
+  \\ full_simp_tac std_ss [NOT_LESS_IMP_heap_lookup]
+  \\ full_simp_tac std_ss [heap_lookup_def]
+  \\ Cases_on `n <= heap_length ha` \\ full_simp_tac std_ss []
+  THEN1 (`heap_length ha = n` by DECIDE_TAC \\ full_simp_tac std_ss [] \\ metis_tac [])
+  \\ `heap_length ha <> n` by DECIDE_TAC \\ full_simp_tac std_ss []
+  \\ `0 < el_length (ThunkBlock ev v)`
+       by (full_simp_tac std_ss [el_length_def,ThunkBlock_def] >> decide_tac)
+  \\ full_simp_tac std_ss [] \\ srw_tac [] []
+  \\ full_simp_tac std_ss [el_length_def,ThunkBlock_def,NOT_LESS]
+QED
+
+Triviality heap_store_ThunkBlock:
+  (heap_lookup n heap = SOME (ThunkBlock NotEvaluated y)) ⇒
+  ∃heap2.
+    heap_store n [ThunkBlock ev h] heap = (heap2,T) ∧
+    ThunkBlock_inv heap heap2 ∧
+    (heap_lookup n heap2 = SOME (ThunkBlock ev h)) ∧
+    (heap_length heap2 = heap_length heap) ∧
+    (FILTER isForwardPointer heap2 = FILTER isForwardPointer heap) ∧
+    (∀xs l d.
+       MEM (DataElement xs l d) heap2 ⇒
+         (DataElement xs l d = ThunkBlock ev h) ∨
+         MEM (DataElement xs l d) heap) ∧
+    (∀a. isSomeDataElement (heap_lookup a heap2) =
+         isSomeDataElement (heap_lookup a heap)) ∧
+    (∀m x. m <> n ∧ (heap_lookup m heap = SOME x) ⇒
+          (heap_lookup m heap2 = SOME x))
+Proof
+  rpt strip_tac \\ imp_res_tac heap_lookup_SPLIT
+  \\ full_simp_tac std_ss [heap_store_ThunkBlock_thm]
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [ThunkBlock_inv_def]
+    \\ full_simp_tac std_ss [heap_lookup_ThunkBlock_lemma]
+    \\ full_simp_tac std_ss [isThunkBlock_def] \\ metis_tac [])
+  \\ strip_tac THEN1 (full_simp_tac std_ss [heap_lookup_PREFIX])
+  \\ strip_tac THEN1 (full_simp_tac (srw_ss())
+       [heap_length_APPEND,heap_length_def,ThunkBlock_def,el_length_def])
+  \\ strip_tac THEN1
+   (full_simp_tac (srw_ss()) [rich_listTheory.FILTER_APPEND,FILTER,
+                              isForwardPointer_def,ThunkBlock_def])
+  \\ strip_tac THEN1
+   (full_simp_tac (srw_ss()) [MEM,MEM_APPEND,ThunkBlock_def] \\ metis_tac [])
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [isSomeDataElement_def,heap_lookup_ThunkBlock_lemma]
+    \\ full_simp_tac std_ss [ThunkBlock_def] \\ metis_tac [])
+  \\ full_simp_tac std_ss [isSomeDataElement_def,heap_lookup_ThunkBlock_lemma]
+  \\ metis_tac []
+QED
+
+Triviality NOT_isThunkBlock:
+  ~(isThunkBlock (Bignum x)) /\
+    ~(isThunkBlock (Word64Rep a w)) /\
+    ~(isThunkBlock (DataElement xs (LENGTH xs) (BlockTag n,[])))
+Proof
+  simp_tac (srw_ss()) [isThunkBlock_def,ThunkBlock_def,Bignum_def]
+  \\ Cases_on`a` \\ rw[]
+  \\ TRY pairarg_tac \\ fs[]
+  \\ EVAL_TAC \\ rw[]
+QED
+
+Triviality v_inv_Thunk:
+  ThunkBlock_inv heap heap2 ==>
+    !x h f tf. (v_inv conf x (h,f,tf,heap2) = v_inv conf x (h,f,tf,heap))
+Proof
+  strip_tac \\ completeInduct_on `v_size x` \\ NTAC 3 strip_tac
+  \\ full_simp_tac std_ss [PULL_FORALL] \\ Cases_on `x` THEN1
+   (full_simp_tac std_ss [v_inv_def] \\ srw_tac [] []
+    \\ rpt strip_tac \\ full_simp_tac std_ss []
+    \\ full_simp_tac std_ss [ThunkBlock_inv_def]
+    \\ metis_tac [NOT_isThunkBlock])
+  THEN1 (
+    fs[v_inv_def,ThunkBlock_inv_def]
+    \\ metis_tac[NOT_isThunkBlock] )
+  THEN1 (full_simp_tac (srw_ss()) [v_inv_def,ADDR_APPLY_def,BlockRep_def]
+    \\ Cases_on `l = []` \\ full_simp_tac std_ss []
+    \\ full_simp_tac (srw_ss()) [v_inv_def,ADDR_APPLY_def,BlockRep_def]
+    \\ rpt strip_tac
+    \\ full_simp_tac std_ss [EVERY2_EVERY,LENGTH_ADDR_MAP,EVERY_MEM,FORALL_PROD]
+    \\ rpt strip_tac \\ EQ_TAC \\ rpt strip_tac
+    THEN1
+     (qpat_x_assum `LENGTH l = LENGTH xs` ASSUME_TAC
+      \\ full_simp_tac (srw_ss()) [MEM_ZIP,LENGTH_ADDR_MAP,PULL_EXISTS]
+      \\ `heap_lookup ptr heap =
+           SOME (DataElement xs (LENGTH xs) (BlockTag n,[]))` by
+              metis_tac [ThunkBlock_inv_def,NOT_isThunkBlock]
+      \\ full_simp_tac (srw_ss()) [MEM_ZIP]
+      \\ rpt strip_tac
+      \\ Q.MATCH_ASSUM_RENAME_TAC `t < LENGTH xs` \\ res_tac
+      \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac [])
+      \\ imp_res_tac MEM_IMP_v_size
+      \\ last_x_assum $ qspec_then ‘EL t l’ mp_tac \\ gvs []
+      \\ metis_tac [])
+    THEN1
+     (qpat_x_assum `LENGTH l = LENGTH xs` ASSUME_TAC
+      \\ full_simp_tac (srw_ss()) [MEM_ZIP,LENGTH_ADDR_MAP,PULL_EXISTS]
+      \\ `heap_lookup ptr heap2 =
+           SOME (DataElement xs (LENGTH xs) (BlockTag n,[]))` by
+              metis_tac [ThunkBlock_inv_def,NOT_isThunkBlock]
+      \\ full_simp_tac (srw_ss()) [MEM_ZIP]
+      \\ rpt strip_tac
+      \\ Q.MATCH_ASSUM_RENAME_TAC `t < LENGTH xs` \\ res_tac
+      \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac [])
+      \\ `MEM (EL t l) l` by (full_simp_tac std_ss [MEM_EL] \\ metis_tac [])
+      \\ imp_res_tac MEM_IMP_v_size
+      \\ last_x_assum $ qspec_then ‘EL t l’ mp_tac \\ gvs []
+      \\ metis_tac []))
+  THEN1 (full_simp_tac std_ss [v_inv_def])
+  THEN1 (full_simp_tac (srw_ss()) [v_inv_def,SUBMAP_DEF])
+QED
+
 val heap_lookup_heap_split = prove(
   ``!heap a b h1 h2 x.
       heap_split a heap = SOME (h1,h2) /\
@@ -3054,6 +3324,17 @@ val data_up_to_alt = prove(
   \\ rpt (CASE_TAC \\ fs [])
   \\ rw [] \\ eq_tac \\ rw []);
 
+val update_thunk_gen_state_ok = prove(
+  ``heap_store b [ThunkBlock ev t1] heap = (heap2,T) ∧ a <= b ∧
+    gen_state_ok a (a + (sp + sp1)) heap gens ⇒
+    gen_state_ok a (a + (sp + sp1)) heap2 gens``,
+  Cases_on `gens` \\ fs [gen_state_ok_def]
+  \\ fs [EVERY_MEM] \\ rpt strip_tac \\ fs [] \\ res_tac
+  \\ fs [gen_start_ok_def] \\ rpt strip_tac
+  \\ drule (GEN_ALL heap_split_heap_store)
+  \\ disch_then drule \\ fs [] \\ strip_tac
+  \\ fs [] \\ rpt strip_tac \\ res_tac \\ fs []) |> GEN_ALL;
+
 Theorem data_up_to_heap_store:
    !heap a b heap2 y.
       data_up_to a heap /\ heap_store b [y] heap = (heap2,T) /\
@@ -3127,7 +3408,7 @@ Proof
     \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[]
     \\ qpat_x_assum `heap_lookup _ _ = SOME (RefBlock zs)` assume_tac
     \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[]
-    THEN1 fs[RefBlock_def,isRef_def]
+    THEN1 fs[RefBlock_def,isRef_def,isMutTag_def]
     \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac
     \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma]
     \\ disch_then (assume_tac o GSYM) \\ fs[]
@@ -3194,13 +3475,28 @@ Proof
         \\ rw []
         \\ ho_match_mp_tac MEM_in_all_ts
         \\ qexists_tac `p_2` \\ rw []
-        \\ rw [all_vs_def] \\ disj1_tac
+        \\ rw [all_vs_def] \\ ntac 2 disj1_tac
         \\ map_every qexists_tac [`n`,`l`]
         \\ rw [lookup_insert]
         \\ ho_match_mp_tac MEM_v_all_vs
         \\ drule MEM_ZIP2 \\ rw []
         \\ rw [EL_MEM]))
-  \\ (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [])
+  >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [])
+  >- (
+    qexists `z` \\ conj_tac
+    >- (
+      first_x_assum ho_match_mp_tac \\ rw []
+      \\ CCONTR_TAC
+      \\ metis_tac [INJ_DEF])
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ qexistsl [`n`, `t`, `a'`] \\ gvs []
+    \\ simp [lookup_insert]
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ simp [EL_MEM])
 QED
 
 Definition heap_deref_def:
@@ -3270,7 +3566,7 @@ Proof
     \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[]
     \\ qpat_x_assum `heap_lookup _ _ = SOME (RefBlock zs)` assume_tac
     \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[]
-    THEN1 fs[RefBlock_def,isRef_def]
+    THEN1 fs[RefBlock_def,isRef_def,isMutTag_def]
     \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac
     \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] \\ disch_then (assume_tac o GSYM)
     \\ fs[]
@@ -3323,7 +3619,7 @@ Proof
        \\ rw []
        \\ ho_match_mp_tac MEM_in_all_ts
        \\ qexists_tac `p_2` \\ rw []
-       \\ rw [all_vs_def] \\ disj1_tac
+       \\ rw [all_vs_def] \\ ntac 2 disj1_tac
        \\ map_every qexists_tac [`n`,`LUPDATE (HD xs) i xs1`]
        \\ rw [FLOOKUP_UPDATE,FLOOKUP_DEF]
        \\ ho_match_mp_tac MEM_v_all_vs
@@ -3351,13 +3647,185 @@ Proof
         \\ rw []
         \\ ho_match_mp_tac MEM_in_all_ts
         \\ qexists_tac `p_2` \\ rw []
-        \\ rw [all_vs_def] \\ disj1_tac
+        \\ rw [all_vs_def] \\ ntac 2 disj1_tac
+        \\ map_every qexists_tac [`n`,`l`]
+        \\ rw [lookup_insert]
+        \\ ho_match_mp_tac MEM_v_all_vs
+        \\ drule MEM_ZIP2 \\ rw []
+        \\ rw [EL_MEM]))
+  >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [])
+  >- (
+    qexists `z` \\ conj_tac
+    >- (
+      first_x_assum ho_match_mp_tac \\ rw []
+      \\ CCONTR_TAC
+      \\ metis_tac [INJ_DEF])
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ qexistsl [`n`, `t`, `a'`] \\ gvs []
+    \\ simp [lookup_insert]
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ simp [EL_MEM])
+QED
+
+Definition thunk_deref_def:
+  (thunk_deref a heap =
+    case heap_lookup a heap of
+    | SOME (DataElement xs l (ThunkTag NotEvaluated,[])) => SOME xs
+    | _ => NONE)
+End
+
+Theorem update_thunk_thm:
+  abs_ml_inv conf (h::RefPtr b ptr::stack) refs
+             (roots,heap,be,a,sp,sp1,gens) limit ts ∧
+  (lookup ptr refs = SOME (Thunk NotEvaluated v)) ⇒
+    ?p r roots2 v1 heap2 u.
+      (roots = r :: Pointer p u :: roots2) ∧
+      (thunk_deref p heap = SOME v1) ∧
+      (heap_store p [ThunkBlock ev r] heap = (heap2,T)) ∧
+      abs_ml_inv conf (h::(RefPtr b ptr)::stack)
+        (insert ptr (Thunk ev h) refs)
+        (roots,heap2,be,a,sp,sp1,gens) limit ts
+Proof
+  simp_tac std_ss [abs_ml_inv_def]
+  \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def]
+  \\ gvs [GSYM CONS_APPEND]
+  \\ full_simp_tac std_ss [v_inv_def]
+  \\ Cases_on `x'` \\ gvs []
+  \\ full_simp_tac std_ss []
+  \\ `reachable_refs (h::RefPtr b ptr::stack) refs ptr` by
+   (full_simp_tac std_ss [reachable_refs_def] \\ qexists_tac `RefPtr b ptr`
+    \\ full_simp_tac (srw_ss()) [get_refs_def])
+  \\ res_tac \\ POP_ASSUM MP_TAC \\ simp_tac std_ss [Once bc_ref_inv_def]
+  \\ Cases_on `FLOOKUP f ptr` \\ full_simp_tac (srw_ss()) []
+  \\ rpt strip_tac \\ gvs []
+  \\ gvs [FLOOKUP_DEF]
+  \\ `thunk_deref (f ' ptr) heap = SOME [z]` by (
+       fs[thunk_deref_def,ThunkBlock_def,FLOOKUP_DEF] )
+  \\ imp_res_tac heap_store_ThunkBlock
+  \\ pop_assum $ qspecl_then [`x`, `ev`] mp_tac
+  \\ full_simp_tac std_ss [] \\ simp[LENGTH_LUPDATE]
+  \\ strip_tac \\ full_simp_tac std_ss []
+  \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF]
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [roots_ok_def] \\ fs [] \\ metis_tac [])
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [heap_ok_def] \\ rpt strip_tac \\ res_tac
+    \\ full_simp_tac (srw_ss()) [ThunkBlock_def] \\ srw_tac [] []
+    \\ Q.ABBREV_TAC `p1 = ptr'` \\ POP_ASSUM (K ALL_TAC)
+    \\ Cases_on `p1 = f ' ptr` \\ full_simp_tac std_ss []
+    THEN1 (EVAL_TAC \\ simp_tac std_ss [])
+    \\ full_simp_tac std_ss [roots_ok_def,MEM_APPEND,MEM]
+    \\ imp_res_tac MEM_LUPDATE_E >> fs[])
+  \\ strip_tac THEN1
+   (fs [gc_kind_inv_def] \\ every_case_tac \\ fs[]
+    \\ conj_tac THEN1
+     (match_mp_tac update_thunk_gen_state_ok
+      \\ asm_exists_tac \\ fs []
+      \\ rpt_drule heap_lookup_heap_split
+      \\ IF_CASES_TAC \\ fs [] \\ strip_tac
+      \\ fs [EVERY_MEM] \\ res_tac
+      \\ fs [ThunkBlock_def,isRef_def,isMutTag_def])
+    \\ drule heap_split_heap_length \\ strip_tac \\ qpat_x_assum `_ ++ _ = _` (assume_tac o GSYM)
+    \\ fs[] \\ fs[heap_lookup_APPEND] \\ every_case_tac \\ fs[] \\ rfs[]
+    \\ qpat_x_assum `heap_lookup _ _ = SOME (ThunkBlock NotEvaluated z)` assume_tac
+    \\ drule heap_lookup_SPLIT \\ strip_tac \\ fs[] \\ rveq \\ fs[]
+    THEN1 fs[ThunkBlock_def,isRef_def,isMutTag_def]
+    \\ qpat_x_assum `heap_store _ _ _ = _` mp_tac
+    \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,APPEND,heap_store_lemma] \\ disch_then (assume_tac o GSYM)
+    \\ fs[]
+    \\ `f ' ptr = heap_length(h1 ++ ha)` by fs[heap_length_APPEND]
+    \\ fs[heap_store_lemma]
+    \\ qpat_x_assum `heap_length h1 = _` (assume_tac o GSYM)
+    \\ fs[]
+    \\ SIMP_TAC std_ss [GSYM APPEND_ASSOC,gen_gc_partialTheory.heap_split_length]
+    \\ fs[isRef_def,ThunkBlock_def,isMutTag_def])
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [unused_space_inv_def] \\ rpt strip_tac
+    \\ res_tac \\ Cases_on `a = f ' ptr` \\ full_simp_tac (srw_ss()) []
+    THEN1 full_simp_tac (srw_ss()) [ThunkBlock_def]
+    \\ imp_res_tac data_up_to_heap_store \\ fs [])
+  \\ qexists_tac `f` \\ full_simp_tac std_ss []
+  \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk ev h) refs)
+                                       (h::RefPtr b ptr::stack))`
+  \\ full_simp_tac std_ss []
+  \\ MP_TAC v_inv_Thunk
+  \\ full_simp_tac std_ss [] \\ rpt strip_tac
+  THEN1 (fs [SUBSET_DEF])
+  THEN1 (fs [INJ_DEF,DRESTRICT_DEF])
+  THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF])
+  THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF,SUBSET_DEF,IN_INTER])
+  >- (ho_match_mp_tac v_inv_tf_restrict
+     \\ rw []
+     \\ ho_match_mp_tac MEM_in_all_ts
+     \\ goal_assum $ drule_at Any \\ gvs []
+     \\ ho_match_mp_tac MEM_stack_all_vs
+     \\ rw [EL_MEM])
+  >- (match_mp_tac EVERY2_MEM_MONO
+     \\ imp_res_tac LIST_REL_APPEND_IMP
+     \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
+     \\ simp[FORALL_PROD] \\ rw[]
+     \\ ho_match_mp_tac v_inv_tf_restrict
+     \\ rw []
+     \\ ho_match_mp_tac MEM_in_all_ts
+     \\ qexists_tac `p_1` \\ rw []
+     \\ ho_match_mp_tac MEM_stack_all_vs
+     \\ qmatch_asmsub_abbrev_tac `MEM (_,_) (ZIP (l,_))`
+     \\ drule MEM_ZIP2 \\ rw []
+     \\ rw [EL_MEM])
+  \\ Cases_on `n = ptr` THEN1 (
+    full_simp_tac (srw_ss()) [bc_ref_inv_def]
+    \\ srw_tac [] [] \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,ThunkBlock_def]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ ho_match_mp_tac MEM_stack_all_vs
+    \\ rw [EL_MEM])
+  \\ `reachable_refs (h::RefPtr b ptr::stack) refs n` by (
+    match_mp_tac (GEN_ALL (MP_CANON reachable_refs_Thunk_UPDATE))
+    \\ metis_tac [])
+  \\ full_simp_tac (srw_ss()) [bc_ref_inv_def]
+  \\ res_tac
+  \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) []
+  \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) []
+  \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,FAPPLY_FUPDATE_THM] \\ rw [lookup_insert]
+  \\ Cases_on `x''` \\ full_simp_tac (srw_ss()) []
+  >- (qexists_tac `zs` \\ conj_tac
+     >- (first_x_assum ho_match_mp_tac \\ rw [] \\ CCONTR_TAC \\ metis_tac [INJ_DEF])
+     >- (match_mp_tac EVERY2_MEM_MONO
+        \\ imp_res_tac LIST_REL_APPEND_IMP
+        \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
+        \\ simp[FORALL_PROD] \\ rw[]
+        \\ ho_match_mp_tac v_inv_tf_restrict
+        \\ rw []
+        \\ ho_match_mp_tac MEM_in_all_ts
+        \\ qexists_tac `p_2` \\ rw []
+        \\ rw [all_vs_def] \\ ntac 2 disj1_tac
         \\ map_every qexists_tac [`n`,`l`]
         \\ rw [lookup_insert]
         \\ ho_match_mp_tac MEM_v_all_vs
         \\ drule MEM_ZIP2 \\ rw []
         \\ rw [EL_MEM]))
-  \\ full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac []
+  >- (full_simp_tac (srw_ss()) [INJ_DEF] \\ metis_tac [])
+  >- (
+    qexists `z'` \\ conj_tac
+    >- (
+      first_x_assum ho_match_mp_tac \\ rw []
+      \\ CCONTR_TAC
+      \\ metis_tac [INJ_DEF])
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ goal_assum $ drule_at Any \\ gvs []
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ qexistsl [`n`, `t`, `a'`] \\ gvs []
+    \\ simp [lookup_insert]
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ simp [EL_MEM])
 QED
 
 (* update byte ref *)
@@ -3515,7 +3983,7 @@ Proof
         \\ qpat_x_assum `_ = r'` (assume_tac o GSYM) \\ fs[isRef_def]
         \\ qpat_x_assum `_ = q'` (assume_tac o GSYM) \\ fs[isRef_def]
         \\ rveq \\ fs[isRef_def])
-    >- (rveq \\ fs[isRef_def]))
+    >- (rveq \\ fs[isRef_def, isMutTag_def]))
   THEN1 (imp_res_tac unused_space_inv_byte_update \\ fs [])
   THEN1 (fs [INJ_DEF,DRESTRICT_DEF])
   THEN1 (fs [SUBSET_DEF,DRESTRICT_DEF])
@@ -3564,7 +4032,7 @@ Proof
     \\ rw []
     \\ ho_match_mp_tac MEM_in_all_ts
     \\ qexists_tac `p_2` \\ rw []
-    \\ rw [all_vs_def] \\ disj1_tac
+    \\ rw [all_vs_def] \\ ntac 2 disj1_tac
     \\ map_every qexists_tac [`n`,`l`]
     \\ rw [lookup_insert]
     \\ ho_match_mp_tac MEM_v_all_vs
@@ -3573,11 +4041,30 @@ Proof
     \\ fs [heap_lookup_def,heap_lookup_APPEND,Bytes_def,
            el_length_def,SUM_APPEND,RefBlock_def,heap_length_APPEND]
     \\ rw [] \\ fs [] \\ rfs [heap_length_def,el_length_def] \\ fs [NOT_LESS])
-  \\ Cases_on `x = heap_length ha`
-  THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac [])
-  \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND]
-  \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def]
-  \\ metis_tac[]
+  THEN1
+   (Cases_on `x = heap_length ha`
+    THEN1 (fs [INJ_DEF,FLOOKUP_DEF] \\ metis_tac [])
+    \\ fs [heap_lookup_APPEND,Bytes_def,heap_length_def,el_length_def,SUM_APPEND]
+    \\ rfs [] \\ rw [] \\ fs [] \\ rfs [heap_lookup_def]
+    \\ metis_tac[])
+  THEN1
+   (once_rewrite_tac [CONJ_COMM] \\ qexists_tac `z` \\ fs []
+    \\ conj_tac
+    THEN1
+     (ho_match_mp_tac v_inv_tf_restrict
+      \\ conj_tac
+      >- metis_tac [v_inv_IMP]
+      \\ rw []
+      \\ ho_match_mp_tac MEM_in_all_ts
+      \\ goal_assum $ drule_at Any \\ gvs []
+      \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+      \\ qexistsl [`n`, `t'`, `a'`]
+      \\ rw [lookup_insert]
+      \\ ho_match_mp_tac MEM_v_all_vs
+      \\ rw [EL_MEM])
+    \\ fs [heap_lookup_def,heap_lookup_APPEND,Bytes_def,
+           el_length_def,SUM_APPEND,ThunkBlock_def,heap_length_APPEND]
+    \\ rw [] \\ fs [] \\ rfs [heap_length_def,el_length_def] \\ fs [NOT_LESS])
 QED
 
 val heap_store_unused_thm = prove(
@@ -3788,6 +4275,231 @@ Proof
   \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) []
   \\ full_simp_tac (srw_ss()) [FDOM_FUPDATE,FAPPLY_FUPDATE_THM,FLOOKUP_DEF,lookup_insert]
   \\ reverse (Cases_on `x'`) \\ full_simp_tac (srw_ss()) []
+  >- (
+    `isSomeDataElement (heap_lookup (f ' n) heap)` by
+      (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC
+       \\ simp_tac (srw_ss()) [] \\ NO_TAC)
+    \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def]
+    \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC
+    \\ `n IN (domain refs)` by fs [domain_lookup]
+    \\ qpat_x_assum `lookup n refs  = SOME (Thunk t a')` ASSUME_TAC
+    \\ full_simp_tac (srw_ss()) []
+    \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ res_tac \\ full_simp_tac (srw_ss()) []
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP
+       \\ full_simp_tac (srw_ss()) [])
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `a'` \\ rw []
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ qexistsl [`n`,`t`, `a'`]
+    \\ fs [lookup_insert]
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ rw [])
+  THEN1 (imp_res_tac heap_store_rel_lemma \\ fs [Bytes_def] \\ metis_tac[])
+  \\ `isSomeDataElement (heap_lookup (f ' n) heap)` by
+    (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC
+     \\ simp_tac (srw_ss()) [] \\ NO_TAC)
+  \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def]
+  \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC
+  \\ `n IN (domain refs)` by fs [domain_lookup]
+  \\ qpat_x_assum `lookup n refs  = SOME (ValueArray l)` ASSUME_TAC
+  \\ full_simp_tac (srw_ss()) []
+  \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def]
+  \\ imp_res_tac heap_store_rel_lemma
+  \\ res_tac \\ full_simp_tac (srw_ss()) []
+  \\ qpat_x_assum `EVERY2 PPP zs l` MP_TAC
+  \\ match_mp_tac EVERY2_IMP_EVERY2
+  \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) []
+  \\ rpt strip_tac
+  \\ ho_match_mp_tac v_inv_tf_restrict
+  \\ conj_tac
+  >- (match_mp_tac v_inv_SUBMAP
+     \\ full_simp_tac (srw_ss()) [])
+  \\ rw []
+  \\ ho_match_mp_tac MEM_in_all_ts
+  \\ qexists_tac `y` \\ rw []
+  \\ rw [all_vs_def] \\ ntac 2 disj1_tac
+  \\ map_every qexists_tac [`n`,`l`]
+  \\ fs [lookup_insert]
+  \\ ho_match_mp_tac MEM_v_all_vs
+  \\ rw []
+QED
+
+Theorem new_thunk_thm:
+   abs_ml_inv conf (v::stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts ∧
+    ¬(ptr IN (domain refs)) ∧ 2 ≤ sp ⇒
+    ∃p r roots2 heap2.
+      (roots = r::roots2) ∧
+      (heap_store_unused a (sp+sp1) (ThunkBlock ev r) heap = (heap2,T)) /\
+      abs_ml_inv conf (v::(RefPtr F ptr)::stack) (insert ptr (Thunk ev v) refs)
+                 (r::Pointer (a+sp+sp1-2) (Word 0w)::roots2,heap2,be,a,
+                  sp - 2,sp1,gens) limit ts
+Proof
+  simp_tac std_ss [abs_ml_inv_def]
+  \\ rpt strip_tac \\ full_simp_tac std_ss [bc_stack_ref_inv_def]
+  \\ imp_res_tac EVERY2_APPEND_IMP_APPEND
+  \\ full_simp_tac (srw_ss()) []
+  \\ imp_res_tac EVERY2_IMP_LENGTH
+  \\ `el_length (ThunkBlock ev x) <= sp + sp1` by (
+    full_simp_tac std_ss
+    [el_length_def,ThunkBlock_def] \\ fs [])
+  \\ qpat_x_assum `unused_space_inv a (sp+sp1) heap` (fn th =>
+    MATCH_MP (IMP_heap_store_unused
+    |> REWRITE_RULE [GSYM AND_IMP_INTRO] |> GEN_ALL) th
+    |> ASSUME_TAC)
+  \\ POP_ASSUM (MP_TAC o Q.SPEC `ThunkBlock ev x`) \\ match_mp_tac IMP_IMP
+  \\ strip_tac THEN1 full_simp_tac std_ss [ThunkBlock_def,el_length_def]
+  \\ strip_tac \\ full_simp_tac std_ss []
+  \\ `unused_space_inv a (sp + sp1 - 2) heap2`
+    by fs [ThunkBlock_def,el_length_def]
+  \\ full_simp_tac std_ss [] \\ strip_tac THEN1
+   (full_simp_tac std_ss [roots_ok_def,MEM,heap_store_rel_def] \\ rpt strip_tac
+    \\ full_simp_tac (srw_ss()) [ThunkBlock_def,el_length_def]
+    \\ full_simp_tac (srw_ss()) [isSomeDataElement_def]
+    \\ fs [] \\ metis_tac [])
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [heap_ok_def,ThunkBlock_def,isForwardPointer_def]
+    \\ once_rewrite_tac [EQ_SYM_EQ] \\ rpt strip_tac THEN1
+     (POP_ASSUM MP_TAC \\ full_simp_tac (srw_ss()) []
+      \\ once_rewrite_tac [EQ_SYM_EQ] \\ rpt strip_tac
+      \\ full_simp_tac (srw_ss()) [roots_ok_def,MEM]
+      \\ metis_tac [heap_store_rel_def])
+    \\ res_tac \\ full_simp_tac std_ss [heap_store_rel_def])
+  \\ conj_tac THEN1
+   (fs [gc_kind_inv_def] \\ Cases_on `conf.gc_kind` \\ fs []
+    \\ conj_tac THEN1
+     (drule heap_store_unused_gen_state_ok
+      \\ fs [EVAL ``el_length (ThunkBlock ev x)``])
+    \\ drule (GEN_ALL heap_store_unused_thm)
+    \\ disch_then drule \\ fs []
+    \\ strip_tac \\ fs [] \\ rveq \\ fs []
+    \\ fs [EVAL ``el_length (ThunkBlock ev x)``]
+    \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+    \\ once_rewrite_tac [heap_split_APPEND_if] \\ fs []
+    \\ full_simp_tac std_ss [GSYM APPEND_ASSOC]
+    \\ once_rewrite_tac [heap_split_APPEND_if]
+    \\ fs [heap_length_heap_expand,ThunkBlock_def]
+    \\ fs [heap_split_def]
+    \\ gvs [isRef_def,isMutTag_def]
+    \\ EVAL_TAC \\ rw [] \\ EVAL_TAC)
+  \\ `~(ptr IN FDOM f)` by (full_simp_tac (srw_ss()) [SUBSET_DEF] \\ metis_tac [])
+  \\ conj_tac THEN1 fs []
+  \\ qexists_tac `f |+ (ptr,a+sp+sp1-2)`
+  \\ qexists_tac `DRESTRICT tf (all_ts (insert ptr (Thunk ev v) refs) (v::RefPtr F ptr::stack))`
+  \\ strip_tac THEN1
+   (full_simp_tac (srw_ss()) [FDOM_FUPDATE]
+    \\ `(FAPPLY (f |+ (ptr,a + sp + sp1 - 2))) =
+          (ptr =+ (a+sp+sp1-2)) (FAPPLY f)` by
+     (full_simp_tac std_ss [FUN_EQ_THM,FAPPLY_FUPDATE_THM,APPLY_UPDATE_THM]
+      \\ metis_tac []) \\ full_simp_tac std_ss []
+    \\ match_mp_tac (METIS_PROVE [] ``!y. (x = y) /\ f y ==> f x``)
+    \\ qexists_tac `(a + sp + sp1 - 2) INSERT
+         {a | isSomeDataElement (heap_lookup a heap)}`
+    \\ strip_tac
+    THEN1 (fs [ThunkBlock_def,isDataElement_def,el_length_def])
+    \\ match_mp_tac INJ_UPDATE \\ full_simp_tac std_ss []
+    \\ full_simp_tac (srw_ss()) []
+    \\ full_simp_tac std_ss [ThunkBlock_def,el_length_def] \\ fs [])
+  \\ strip_tac THEN1
+     (full_simp_tac (srw_ss()) [SUBSET_DEF,FDOM_FUPDATE] \\ metis_tac [])
+  \\ strip_tac
+  THEN1 (fs [INJ_DEF,DRESTRICT_DEF,heap_store_rel_def])
+  \\ strip_tac
+  THEN1 (fs [DRESTRICT_DEF,SUBSET_DEF])
+  \\ strip_tac
+  THEN1 (fs [DRESTRICT_DEF,SUBSET_DEF,IN_INTER])
+  \\ Q.ABBREV_TAC `f1 = f |+ (ptr,a + sp + sp1 - 2)`
+  \\ `f SUBMAP f1` by
+   (Q.UNABBREV_TAC `f1` \\ full_simp_tac (srw_ss()) [SUBMAP_DEF,FAPPLY_FUPDATE_THM]
+    \\ metis_tac [])
+  \\ strip_tac THEN1
+   (full_simp_tac std_ss [LIST_REL_def]
+    \\ match_mp_tac (METIS_PROVE [] ``p2 /\ (p1 /\ p3) ==> p1 /\ p2 /\ p3``)
+    \\ strip_tac THEN1 (UNABBREV_ALL_TAC \\ fs [v_inv_def])
+    \\ full_simp_tac (srw_ss()) [v_inv_def,FAPPLY_FUPDATE_THM]
+    \\ full_simp_tac std_ss [EVERY2_EQ_EL]
+    \\ imp_res_tac EVERY2_IMP_LENGTH
+    \\ conj_tac
+    >- (rw []
+       \\ ho_match_mp_tac v_inv_tf_restrict
+       \\ rw []
+       >- (ho_match_mp_tac v_inv_SUBMAP \\ rw [])
+       \\ ho_match_mp_tac MEM_in_all_ts
+       \\ qexists_tac `v` \\ rw []
+       \\ rw [all_vs_def] \\ disj2_tac
+       \\ ho_match_mp_tac MEM_v_all_vs
+       \\ rw [MEM_APPEND,EL_MEM])
+   >- (rw []
+       \\ ho_match_mp_tac v_inv_tf_restrict
+       \\ rw []
+       >- (ho_match_mp_tac v_inv_SUBMAP \\ rw [])
+       \\ ho_match_mp_tac MEM_in_all_ts
+       \\ qexists_tac `EL n stack` \\ rw []
+       \\ rw [all_vs_def] \\ disj2_tac
+       \\ ho_match_mp_tac MEM_v_all_vs
+       \\ rw [MEM_APPEND,EL_MEM]))
+  \\ rpt strip_tac
+  \\ Cases_on `n = ptr` THEN1
+   (Q.UNABBREV_TAC `f1` \\ asm_simp_tac (srw_ss()) [bc_ref_inv_def,FDOM_FUPDATE,
+      FAPPLY_FUPDATE_THM] \\ fs [el_length_def,RefBlock_def,ThunkBlock_def]
+    \\ full_simp_tac (srw_ss()) [FLOOKUP_DEF,EVERY2_EQ_EL]
+    \\ rpt strip_tac
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP \\ full_simp_tac (srw_ss()) [])
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `v` \\ rw []
+    \\ rw [all_vs_def] \\ disj2_tac
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ rw [MEM_APPEND,EL_MEM])
+  \\ `reachable_refs (v::RefPtr F ptr::stack) refs n`
+    by imp_res_tac reachable_refs_Thunk_UPDATE
+  \\ qpat_x_assum `reachable_refs (v::RefPtr F ptr::stack)
+        (insert ptr _ refs) n` (K ALL_TAC)
+  \\ `reachable_refs (v::stack) refs n` by
+    (full_simp_tac std_ss [reachable_refs_def]
+     \\ reverse (Cases_on `x' = RefPtr F ptr`)
+     THEN1 (full_simp_tac std_ss [MEM,MEM_APPEND] \\ metis_tac [])
+     \\ full_simp_tac std_ss [get_refs_def,MEM]
+     \\ srw_tac [] []
+     \\ imp_res_tac RTC_NRC
+     \\ Cases_on `n'` \\ full_simp_tac std_ss [NRC]
+     \\ full_simp_tac std_ss [ref_edge_def,lookup_def]
+     \\ every_case_tac \\ rev_full_simp_tac std_ss [GSYM lookup_NONE_domain])
+  \\ res_tac \\ Q.UNABBREV_TAC `f1` \\ full_simp_tac std_ss [bc_ref_inv_def]
+  \\ Cases_on `FLOOKUP f n` \\ full_simp_tac (srw_ss()) []
+  \\ Cases_on `lookup n refs` \\ full_simp_tac (srw_ss()) []
+  \\ full_simp_tac (srw_ss()) [FDOM_FUPDATE,FAPPLY_FUPDATE_THM,FLOOKUP_DEF,lookup_insert]
+  \\ reverse (Cases_on `x''`) \\ full_simp_tac (srw_ss()) []
+  >- (
+    `isSomeDataElement (heap_lookup (f ' n) heap)` by
+      (full_simp_tac std_ss [ThunkBlock_def] \\ EVAL_TAC
+       \\ simp_tac (srw_ss()) [] \\ NO_TAC)
+    \\ res_tac \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) [RefBlock_def]
+    \\ qpat_x_assum `n IN FDOM f` ASSUME_TAC
+    \\ `n IN (domain refs)` by fs [domain_lookup]
+    \\ qpat_x_assum `lookup n refs  = SOME (Thunk t a')` ASSUME_TAC
+    \\ full_simp_tac (srw_ss()) []
+    \\ srw_tac [] [] \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def]
+    \\ imp_res_tac heap_store_rel_lemma
+    \\ res_tac \\ full_simp_tac (srw_ss()) []
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ conj_tac
+    >- (match_mp_tac v_inv_SUBMAP
+       \\ full_simp_tac (srw_ss()) [])
+    \\ rw []
+    \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `a'` \\ rw []
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ qexistsl [`n`,`t`, `a'`]
+    \\ fs [lookup_insert]
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ rw [])
   THEN1 (imp_res_tac heap_store_rel_lemma \\ fs [Bytes_def] \\ metis_tac[])
   \\ `isSomeDataElement (heap_lookup (f ' n) heap)` by
     (full_simp_tac std_ss [RefBlock_def] \\ EVAL_TAC
@@ -3811,7 +4523,7 @@ Proof
   \\ rw []
   \\ ho_match_mp_tac MEM_in_all_ts
   \\ qexists_tac `y` \\ rw []
-  \\ rw [all_vs_def] \\ disj1_tac
+  \\ rw [all_vs_def] \\ ntac 2 disj1_tac
   \\ map_every qexists_tac [`n`,`l`]
   \\ fs [lookup_insert]
   \\ ho_match_mp_tac MEM_v_all_vs
@@ -3840,6 +4552,10 @@ Theorem deref_thm:
           ?y. (heap_el r n heap = (y,T)) /\
                 abs_ml_inv conf (EL n vs::RefPtr b ptr::stack) refs
                   (y::roots,heap,be,a,sp,sp1,gens) limit ts
+      | Thunk m v =>
+      ?y. (heap_el r 0 heap = (y,T)) /\
+            abs_ml_inv conf (v::RefPtr b ptr::stack) refs
+              (y::roots,heap,be,a,sp,sp1,gens) limit ts
 Proof
   full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def]
   \\ rpt strip_tac \\ Cases_on `roots` \\ full_simp_tac (srw_ss()) [LIST_REL_def]
@@ -3853,46 +4569,85 @@ Proof
   \\ `ptr IN (domain refs)` by fs [SUBSET_DEF]
   \\ full_simp_tac (srw_ss()) [domain_lookup]
   \\ reverse (Cases_on `v`) \\ full_simp_tac (srw_ss()) []
-  \\ NTAC 3 strip_tac
-  \\ imp_res_tac EVERY2_IMP_LENGTH
-  \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def]
-  \\ srw_tac [] [] THEN1
-   (full_simp_tac std_ss [roots_ok_def,heap_ok_def]
-    \\ imp_res_tac heap_lookup_MEM
-    \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ]
-    \\ rpt strip_tac \\ res_tac
-    \\ full_simp_tac std_ss [RefBlock_def]
-    \\ res_tac \\ full_simp_tac std_ss [MEM]
+  >- (
+    strip_tac
+    \\ imp_res_tac EVERY2_IMP_LENGTH
+    \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def,ThunkBlock_def]
+    \\ srw_tac [] [] THEN1
+     (full_simp_tac std_ss [roots_ok_def,heap_ok_def]
+      \\ imp_res_tac heap_lookup_MEM
+      \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ]
+      \\ rpt strip_tac \\ res_tac
+      \\ full_simp_tac std_ss [RefBlock_def,ThunkBlock_def]
+      \\ res_tac \\ full_simp_tac std_ss [MEM]
+      \\ FIRST_X_ASSUM match_mp_tac
+      \\ metis_tac [MEM_EL])
+    \\ qexists_tac `f` \\ full_simp_tac std_ss []
+    \\ qexists_tac `tf` \\ full_simp_tac std_ss []
+    \\ conj_tac
+    >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (a'::RefPtr b ptr::stack)`
+        suffices_by metis_tac []
+        \\ rw [FUN_EQ_THM,all_ts_def]
+        \\ EQ_TAC
+        >- metis_tac []
+        \\ rw []
+        >- metis_tac []
+        >- (qexists_tac `a'` \\ rw [] \\ disj1_tac
+           \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF,find_ref_def])
+        \\  metis_tac [])
+    \\ imp_res_tac EVERY2_IMP_EL
+    \\ full_simp_tac std_ss []
+    \\ rpt strip_tac
     \\ FIRST_X_ASSUM match_mp_tac
-    \\ metis_tac [MEM_EL])
-  \\ qexists_tac `f` \\ full_simp_tac std_ss []
-  \\ qexists_tac `tf` \\ full_simp_tac std_ss []
-  \\ conj_tac
-  >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (EL n l::RefPtr b ptr::stack)`
-      suffices_by metis_tac []
-      \\ rw [FUN_EQ_THM,all_ts_def]
-      \\ EQ_TAC
-      >- metis_tac []
-      \\ rw []
-      >- metis_tac []
-      >- (qexists_tac `EL n l` \\ rw [] \\ disj1_tac
-         \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF])
-      \\  metis_tac [])
-  \\ imp_res_tac EVERY2_IMP_EL
-  \\ full_simp_tac std_ss []
-  \\ rpt strip_tac
-  \\ FIRST_X_ASSUM match_mp_tac
-  \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC)
-  \\ full_simp_tac std_ss [reachable_refs_def]
-  \\ reverse (Cases_on `x = EL n l`)
-  THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac [])
-  \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def]
-  \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC
-  \\ qexists_tac `r` \\ full_simp_tac std_ss []
-  \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def]
-  \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS]
-  \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss []
-  \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac []
+    \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC)
+    \\ full_simp_tac std_ss [reachable_refs_def]
+    \\ reverse (Cases_on `x = a'`)
+    THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac [])
+    \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def]
+    \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC
+    \\ qexists_tac `r` \\ full_simp_tac std_ss []
+    \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def])
+  >- (
+    NTAC 3 strip_tac
+    \\ imp_res_tac EVERY2_IMP_LENGTH
+    \\ asm_simp_tac (srw_ss()) [heap_el_def,RefBlock_def]
+    \\ srw_tac [] [] THEN1
+     (full_simp_tac std_ss [roots_ok_def,heap_ok_def]
+      \\ imp_res_tac heap_lookup_MEM
+      \\ strip_tac \\ once_rewrite_tac [MEM] \\ once_rewrite_tac [EQ_SYM_EQ]
+      \\ rpt strip_tac \\ res_tac
+      \\ full_simp_tac std_ss [RefBlock_def]
+      \\ res_tac \\ full_simp_tac std_ss [MEM]
+      \\ FIRST_X_ASSUM match_mp_tac
+      \\ metis_tac [MEM_EL])
+    \\ qexists_tac `f` \\ full_simp_tac std_ss []
+    \\ qexists_tac `tf` \\ full_simp_tac std_ss []
+    \\ conj_tac
+    >- (`all_ts refs (RefPtr b ptr::stack) = all_ts refs (EL n l::RefPtr b ptr::stack)`
+        suffices_by metis_tac []
+        \\ rw [FUN_EQ_THM,all_ts_def]
+        \\ EQ_TAC
+        >- metis_tac []
+        \\ rw []
+        >- metis_tac []
+        >- (qexists_tac `EL n l` \\ rw [] \\ disj1_tac
+           \\ metis_tac [EL_MEM,FRANGE_FLOOKUP,FLOOKUP_DEF,find_ref_def])
+        \\  metis_tac [])
+    \\ imp_res_tac EVERY2_IMP_EL
+    \\ full_simp_tac std_ss []
+    \\ rpt strip_tac
+    \\ FIRST_X_ASSUM match_mp_tac
+    \\ qpat_x_assum `reachable_refs (RefPtr b ptr::stack) refs ptr` (K ALL_TAC)
+    \\ full_simp_tac std_ss [reachable_refs_def]
+    \\ reverse (Cases_on `x = EL n l`)
+    THEN1 (full_simp_tac std_ss [MEM] \\ metis_tac [])
+    \\ qexists_tac `RefPtr b ptr` \\ simp_tac std_ss [MEM,get_refs_def]
+    \\ once_rewrite_tac [RTC_CASES1] \\ DISJ2_TAC
+    \\ qexists_tac `r` \\ full_simp_tac std_ss []
+    \\ full_simp_tac (srw_ss()) [ref_edge_def,FLOOKUP_DEF,get_refs_def]
+    \\ full_simp_tac (srw_ss()) [MEM_FLAT,MEM_MAP,PULL_EXISTS]
+    \\ qexists_tac `(EL n l)` \\ full_simp_tac std_ss []
+    \\ full_simp_tac std_ss [MEM_EL] \\ metis_tac [])
 QED
 
 (* el *)
@@ -4038,6 +4793,7 @@ Proof
       \\ rw [FUN_EQ_THM,all_ts_def]
       \\ EQ_TAC
       >- (rw [] \\ fs [lookup_insert] \\ every_case_tac \\ fs []
+         \\ goal_assum $ drule_at Any \\ gvs []
          \\ metis_tac [])
       \\ rw []
       >- (`ptr ≠ n` by (CCONTR_TAC \\ fs[GSYM lookup_NONE_domain])
@@ -4081,71 +4837,18 @@ Proof
   \\ TOP_CASE_TAC \\ fs [] \\ rveq \\ fs []
   \\ TOP_CASE_TAC \\ fs [] \\ rveq \\ fs []
   \\ fs [Bytes_def,isDataElement_def,LET_THM,heap_store_rel_def,
-         isSomeDataElement_def,PULL_EXISTS,RefBlock_def,lookup_NONE_domain] \\ rw []
+         isSomeDataElement_def,PULL_EXISTS,RefBlock_def,lookup_NONE_domain,
+         ThunkBlock_def] \\ rw []
   \\ res_tac
   \\ qpat_x_assum `EVERY2 PPP zs l` MP_TAC
   \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS]
-  \\ match_mp_tac EVERY2_IMP_EVERY2
+  \\ TRY (match_mp_tac EVERY2_IMP_EVERY2)
   \\ full_simp_tac std_ss [] \\ simp_tac (srw_ss()) []
   \\ rpt strip_tac
   \\ match_mp_tac v_inv_SUBMAP \\ fs []
   \\ fs [heap_store_rel_def,isSomeDataElement_def,PULL_EXISTS]
 QED
 
-(* pop *)
-
-Theorem pop_thm:
-   abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ts /\
-    (LENGTH xs = LENGTH rs) ==>
-    abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts
-Proof
-  full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def] \\ rpt strip_tac
-  \\ full_simp_tac std_ss [roots_ok_def,MEM_APPEND]
-  THEN1 (rw [] \\ res_tac \\ fs [])
-  \\ qexists_tac `f` \\ full_simp_tac std_ss []
-  \\ qexists_tac `DRESTRICT tf (all_ts refs stack)` \\ full_simp_tac std_ss []
-  \\ conj_tac
-  >- fs [INJ_DEF,DRESTRICT_DEF]
-  \\ conj_tac
-  >- fs [SUBSET_DEF,DRESTRICT_DEF]
-  \\ conj_tac
-  >- fs [SUBSET_DEF,DRESTRICT_DEF,IN_INTER]
-  \\ conj_tac
-  >- (match_mp_tac EVERY2_MEM_MONO
-     \\ imp_res_tac LIST_REL_APPEND_IMP
-     \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
-     \\ simp[FORALL_PROD] \\ rw[]
-     \\ ho_match_mp_tac v_inv_tf_restrict
-     \\ rw []
-     \\ ho_match_mp_tac MEM_in_all_ts
-     \\ qexists_tac `p_1` \\ rw []
-     \\ ho_match_mp_tac MEM_stack_all_vs
-     \\ drule MEM_ZIP2 \\ rw []
-     \\ rw [EL_MEM])
-  \\ fs[reachable_refs_def,PULL_EXISTS]
-  \\ rw[]
-  \\ fs[bc_ref_inv_def]
-  \\ fsrw_tac[boolSimps.DNF_ss][]
-  \\ first_x_assum rpt_drule
-  \\ BasicProvers.TOP_CASE_TAC \\ fs[]
-  \\ BasicProvers.TOP_CASE_TAC \\ fs[]
-  \\ BasicProvers.TOP_CASE_TAC \\ fs[] \\ rw[]
-  \\ fs[RefBlock_def,Bytes_def]
-  \\ match_mp_tac EVERY2_MEM_MONO
-  \\ imp_res_tac LIST_REL_APPEND_IMP
-  \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
-  \\ simp[FORALL_PROD] \\ rw[]
-  \\ ho_match_mp_tac v_inv_tf_restrict
-  \\ rw []
-  \\ ho_match_mp_tac MEM_in_all_ts
-  \\ qexists_tac `p_2` \\ rw []
-  \\ rw [all_vs_def] \\ disj1_tac
-  \\ map_every qexists_tac [`n`,`l`] \\ rw []
-  \\ ho_match_mp_tac MEM_v_all_vs
-  \\ drule MEM_ZIP2 \\ rw []
-  \\ rw [EL_MEM]
-QED
-
 (* equality *)
 
 Theorem ref_eq_thm:
@@ -4207,7 +4910,8 @@ QED
 (* permute stack *)
 
 Theorem all_ts_permute:
-  ∀(refs : v ref num_map) stack stack'. PERM stack stack' ⇒ all_ts refs stack = all_ts refs stack'
+  ∀(refs : v ref num_map) stack stack'.
+    PERM stack stack' ⇒ all_ts refs stack = all_ts refs stack'
 Proof
   strip_tac
   \\ ho_match_mp_tac PERM_IND
@@ -4283,20 +4987,43 @@ Proof
   \\ fs[bc_ref_inv_def]
   \\ Cases_on `FLOOKUP f n` \\ fs []
   \\ Cases_on `lookup n refs` \\ fs []
-  \\ Cases_on `x'` \\ rw []
-  \\ qexists_tac `zs` \\ rw []
-  \\ match_mp_tac EVERY2_MEM_MONO
-  \\ imp_res_tac LIST_REL_APPEND_IMP
-  \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
-  \\ simp[FORALL_PROD] \\ rw[]
-  \\ ho_match_mp_tac v_inv_tf_restrict
-  \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
-  \\ qexists_tac `p_2` \\ rw []
-  \\ rw [all_vs_def] \\ disj1_tac
-  \\ map_every qexists_tac [`n`,`l`] \\ rw []
-  \\ ho_match_mp_tac MEM_v_all_vs
-  \\ drule MEM_ZIP2 \\ rw []
-  \\ rw [EL_MEM]
+  \\ rename [‘lookup n refs = SOME x_ref’]
+  \\ Cases_on ‘x_ref’ \\ rw []
+  >~ [‘RefBlock’] >-
+   (qexists_tac `zs` \\ rw []
+    \\ match_mp_tac EVERY2_MEM_MONO
+    \\ imp_res_tac LIST_REL_APPEND_IMP
+    \\ first_assum(part_match_exists_tac(last o strip_conj) o concl)
+    \\ simp[FORALL_PROD] \\ rw[]
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ qexists_tac `p_2` \\ rw []
+    \\ rw [all_vs_def] \\ rpt disj1_tac
+    \\ map_every qexists_tac [`n`,`l`] \\ rw []
+    \\ ho_match_mp_tac MEM_v_all_vs
+    \\ drule MEM_ZIP2 \\ rw []
+    \\ rw [EL_MEM])
+  >~ [‘ThunkBlock’] >-
+   (qexists_tac `z` \\ rw []
+    \\ ho_match_mp_tac v_inv_tf_restrict
+    \\ rw [] \\ ho_match_mp_tac MEM_in_all_ts
+    \\ pop_assum $ irule_at $ Pos last
+    \\ rw [all_vs_def] \\ disj1_tac \\ disj2_tac
+    \\ first_x_assum $ irule_at $ Pos hd
+    \\ irule MEM_v_all_vs \\ simp [])
+QED
+
+(* pop *)
+
+Theorem pop_thm:
+   abs_ml_inv conf (xs ++ stack) refs (rs ++ roots,heap,be,a,sp,sp1,gens) limit ts /\
+    (LENGTH xs = LENGTH rs) ==>
+    abs_ml_inv conf (stack) refs (roots,heap,be,a,sp,sp1,gens) limit ts
+Proof
+  strip_tac
+  \\ irule (abs_ml_inv_stack_permute |> Q.SPECL [‘xs’,‘[]’] |> SRULE [])
+  \\ qexists_tac ‘ZIP(xs,rs)’
+  \\ simp [MAP_ZIP]
 QED
 
 (* duplicate *)
@@ -4349,7 +5076,9 @@ Theorem split1_thm:
     ?rs1 roots1. (roots = rs1 ++ roots1) /\ (LENGTH rs1 = LENGTH xs1)
 Proof
   full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC]
-  \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []
+  \\ rpt strip_tac
+  \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH)
+  \\ metis_tac []
 QED
 
 Theorem split2_thm:
@@ -4358,7 +5087,9 @@ Theorem split2_thm:
       (LENGTH rs1 = LENGTH xs1) /\ (LENGTH rs2 = LENGTH xs2)
 Proof
   full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC]
-  \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []
+  \\ rpt strip_tac
+  \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH)
+  \\ metis_tac []
 QED
 
 Theorem split3_thm:
@@ -4368,7 +5099,9 @@ Theorem split3_thm:
       (LENGTH rs3 = LENGTH xs3)
 Proof
   full_simp_tac std_ss [abs_ml_inv_def,bc_stack_ref_inv_def,GSYM APPEND_ASSOC]
-  \\ rpt strip_tac \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH) \\ metis_tac []
+  \\ rpt strip_tac
+  \\ NTAC 5 (imp_res_tac LIST_REL_SPLIT1 \\ imp_res_tac LIST_REL_LENGTH)
+  \\ metis_tac []
 QED
 
 Theorem abs_ml_inv_Num:
@@ -4452,6 +5185,11 @@ Proof
   EVAL_TAC
 QED
 
+Definition thunk_tag_to_bits_def:
+  thunk_tag_to_bits Evaluated = 1w ∧
+  thunk_tag_to_bits NotEvaluated = 0w
+End
+
 Definition word_payload_def:
   (word_payload ys l (BlockTag n) qs conf =
      (* header: ...00[11] here i in ...i[11] must be 0 for the GC *)
@@ -4465,6 +5203,11 @@ Definition word_payload_def:
      (make_header conf 2w (LENGTH ys),
       MAP (word_addr conf) ys,
       (qs = []) /\ (LENGTH ys = l))) /\
+  (word_payload ys l (ThunkTag e) qs conf =
+     (* header: ...e110[11] here i in ...i[11] must be 0 for the GC *)
+     (make_header conf (thunk_tag_to_bits e << 3 || 6w) (LENGTH ys),
+      MAP (word_addr conf) ys,
+      (qs = []) /\ (LENGTH ys = 1) ∧ l = 1)) /\
   (word_payload ys l Word64Tag qs conf =
      (* header: ...011[11] here i in ...i[11] must be 1 for the GC *)
      (make_header conf 3w l,
@@ -4944,17 +5687,33 @@ Proof
   >- (Cases_on `v` \\ fs [v_all_ts_def]
      >- (rw [] \\ drule_then assume_tac v_all_vs_MEM2 \\ rw []
         \\ qexists_tac `x` \\ rw []
-        >- metis_tac []
+        >- metis_tac [find_ref_def]
         \\ ho_match_mp_tac v_all_vs_ts_MEM
         \\ qexists_tac `Block n0 n' l'`
         \\ rw [v_all_ts_def])
      \\ drule_then assume_tac v_all_vs_MEM2 \\ rw []
      \\ qexists_tac `x'` \\ rw [v_all_ts_def]
-     >- metis_tac []
+     >- metis_tac [find_ref_def]
      \\ rw [] \\ ho_match_mp_tac v_all_vs_ts_MEM
      \\ qexists_tac `Block n0 n' l'` \\ rw [v_all_ts_def])
   >- metis_tac []
   >- metis_tac []
+  >- (Cases_on `v` \\ fs [v_all_ts_def]
+     >- (rw []
+        \\ drule_then assume_tac v_all_vs_MEM2
+        \\ rw []
+        \\ qexists_tac `x'` \\ rw []
+        >- metis_tac [find_ref_def]
+        \\ ho_match_mp_tac v_all_vs_ts
+        \\ metis_tac [])
+    \\ drule_then assume_tac v_all_vs_MEM2 \\ rw []
+    \\ qexists_tac `x'`\\ rw [v_all_ts_def]
+    >- metis_tac [find_ref_def]
+    \\ ho_match_mp_tac v_all_vs_ts_MEM
+    \\ qexists_tac `Block n0 n' l`
+    \\ rw [v_all_ts_def])
+  >- metis_tac []
+  >- metis_tac []
   >- (Cases_on `v` \\ fs [v_all_ts_def]
      >- (rw []
         \\ drule_then assume_tac v_all_vs_MEM2
@@ -5239,7 +5998,7 @@ val gc_kind_update_Ref = prove(
     \\ fs [MEM_APPEND,METIS_PROVE [] ``(!x. p x \/ q x ==> d x) <=>
                                        (!x. p x ==> d x) /\
                                        (!x. q x ==> d x)``]
-    \\ fs [isRef_def])
+    \\ fs [isRef_def, isMutTag_def])
   \\ fs [heap_split_SOME_APPEND]
   \\ CASE_TAC \\ rw [] \\ fs [isRef_def]
   \\ fs [heap_split_def,el_length_def] \\ rfs []
@@ -5485,6 +6244,139 @@ Proof
   \\ fs [GSYM EXP_ADD,dimword_def]
 QED
 
+Theorem memory_rel_UpdateThunk_NotEvaluated:
+   memory_rel c be ts refs sp st m dm
+     ((h,w)::(RefPtr bl nn,ptr)::vars) /\
+    lookup nn refs = SOME (Thunk NotEvaluated v) /\
+    good_dimindex (:'a) ==>
+    ?ptr_w x:'a word.
+      ptr = Word ptr_w /\
+      get_real_addr c st ptr_w = SOME x /\
+      (x + bytes_in_word) IN dm /\
+      memory_rel c be ts (insert nn (Thunk NotEvaluated h) refs) sp st
+        ((x + bytes_in_word =+ w) m) dm
+        ((h,w)::(RefPtr bl nn,ptr)::vars)
+Proof
+  rewrite_tac [CONJ_ASSOC]
+  \\ once_rewrite_tac [CONJ_COMM]
+  \\ fs [memory_rel_def,PULL_EXISTS] \\ rw []
+  \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac
+  \\ rpt_drule (update_thunk_thm |> GEN_ALL)
+  \\ disch_then $ qspec_then `NotEvaluated` mp_tac
+  \\ fs [LENGTH_EQ_1,PULL_EXISTS]
+  \\ rpt strip_tac \\ fs [] \\ clean_tac
+  \\ rewrite_tac [GSYM CONJ_ASSOC]
+  \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``]
+  \\ asm_exists_tac \\ fs [word_addr_def]
+  \\ fs [thunk_deref_def] \\ every_case_tac \\ fs [] \\ clean_tac
+  \\ fs [heap_in_memory_store_def]
+  \\ rpt_drule get_real_addr_get_addr \\ fs []
+  \\ disch_then kall_tac
+  \\ `LENGTH l = 1 ∧ n = 1` by
+    (qpat_x_assum `abs_ml_inv _ _ _ _ _ _` kall_tac
+     \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def]
+     \\ clean_tac
+     \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def]
+     \\ `reachable_refs (h::RefPtr bl nn::MAP FST vars) refs nn` by (
+       fs [reachable_refs_def] \\ qexists_tac `RefPtr bl nn` \\ fs []
+       \\ fs [get_refs_def] \\ NO_TAC) \\ res_tac
+     \\ pop_assum mp_tac
+     \\ simp_tac std_ss [bc_ref_inv_def]
+     \\ fs [FLOOKUP_DEF,ThunkBlock_def]
+     \\ rw [] \\ simp [LENGTH])
+  \\ fs [] \\ fs [get_real_offset_thm]
+  \\ Cases_on `l` \\ gvs []
+  \\ fs [GSYM ThunkBlock_def]
+  \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND]
+  \\ fs [heap_store_ThunkBlock_thm,LENGTH_LUPDATE] \\ clean_tac
+  \\ fs [heap_length_APPEND]
+  \\ fs [heap_length_def,el_length_def,ThunkBlock_def]
+  \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def]
+  \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR,SEP_CLAUSES]
+  \\ fs [word_list_def,SEP_CLAUSES]
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,LUPDATE_LENGTH]
+  \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES,heap_length_def]
+  \\ fs [el_length_def,SUM_APPEND]
+  \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]
+  \\ SEP_R_TAC \\ fs []
+  \\ SEP_W_TAC \\ fs [AC STAR_ASSOC STAR_COMM]
+QED
+
+Triviality thunk_tag_bits_lemma:
+  (thunk_tag_to_bits Evaluated ≪ 3 ‖ 6w) = 14w:'a word
+Proof
+  simp [thunk_tag_to_bits_def,WORD_MUL_LSL]
+QED
+
+Theorem memory_rel_UpdateThunk_Evaluated:
+   memory_rel c be ts refs sp st m dm
+     ((h,w)::(RefPtr bl nn,ptr)::vars) /\
+    lookup nn refs = SOME (Thunk NotEvaluated v) /\
+    encode_header c (8 + 6) 1 = SOME hdr /\
+    good_dimindex (:'a) ==>
+    ?ptr_w x:'a word.
+      ptr = Word ptr_w /\
+      get_real_addr c st ptr_w = SOME x /\
+      x IN dm /\ (x + bytes_in_word) IN dm /\
+      memory_rel c be ts (insert nn (Thunk Evaluated h) refs) sp st
+        (m =++ [x, Word hdr; x + bytes_in_word,w]) dm
+        ((h,w)::(RefPtr bl nn,ptr)::vars)
+Proof
+  rewrite_tac [CONJ_ASSOC]
+  \\ once_rewrite_tac [CONJ_COMM]
+  \\ fs [memory_rel_def,PULL_EXISTS] \\ rw []
+  \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac
+  \\ rpt_drule (update_thunk_thm |> GEN_ALL)
+  \\ disch_then $ qspec_then `Evaluated` mp_tac \\ simp []
+  \\ fs [LENGTH_EQ_1,PULL_EXISTS]
+  \\ rpt strip_tac \\ fs [] \\ clean_tac
+  \\ rewrite_tac [GSYM CONJ_ASSOC]
+  \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``]
+  \\ asm_exists_tac \\ fs [word_addr_def]
+  \\ fs [thunk_deref_def, AllCaseEqs()] \\ fs [] \\ clean_tac
+  \\ fs [heap_in_memory_store_def]
+  \\ rpt_drule get_real_addr_get_addr \\ fs []
+  \\ disch_then kall_tac
+  \\ rename1 `SOME (DataElement l1 n1 (ThunkTag NotEvaluated,[]))`
+  \\ `LENGTH l1 = 1 ∧ n1 = 1` by
+    (qpat_x_assum `abs_ml_inv _ _ _ _ _ _` kall_tac
+     \\ fs [abs_ml_inv_def,bc_stack_ref_inv_def,v_inv_def]
+     \\ clean_tac
+     \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def]
+     \\ `reachable_refs (h::RefPtr bl nn::MAP FST vars) refs nn` by (
+       fs [reachable_refs_def] \\ qexists_tac `RefPtr bl nn` \\ fs []
+       \\ fs [get_refs_def] \\ NO_TAC) \\ res_tac
+     \\ pop_assum mp_tac
+     \\ simp_tac std_ss [bc_ref_inv_def]
+     \\ fs [FLOOKUP_DEF,ThunkBlock_def]
+     \\ rw [] \\ simp [LENGTH])
+  \\ fs [] \\ fs [get_real_offset_thm]
+  \\ Cases_on `l1` \\ gvs []
+  \\ fs [GSYM ThunkBlock_def]
+  \\ imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND]
+  \\ fs [heap_store_ThunkBlock_thm,LENGTH_LUPDATE] \\ clean_tac
+  \\ fs [heap_length_APPEND]
+  \\ fs [heap_length_def,el_length_def,ThunkBlock_def]
+  \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def,
+         UPDATE_LIST_def]
+  \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR,SEP_CLAUSES]
+  \\ fs [word_list_def,SEP_CLAUSES]
+  \\ full_simp_tac std_ss [GSYM APPEND_ASSOC,APPEND,LUPDATE_LENGTH]
+  \\ fs [word_list_def,word_list_APPEND,SEP_CLAUSES,heap_length_def]
+  \\ fs [el_length_def,SUM_APPEND]
+  \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]
+  \\ SEP_R_TAC \\ fs []
+  \\ conj_tac
+  >- (
+    drule encode_header_IMP \\ gvs []
+    \\ strip_tac
+    \\ gvs [encode_header_def,thunk_tag_bits_lemma])
+  \\ SEP_W_TAC
+  \\ fs [encode_header_def,AC STAR_ASSOC STAR_COMM,thunk_tag_bits_lemma]
+QED
+
 Theorem word_list_exists_thm:
    (word_list_exists a 0 = emp) /\
     (word_list_exists a (SUC n) =
@@ -5958,6 +6850,80 @@ Proof
   \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]
 QED
 
+Theorem memory_rel_AllocThunk:
+  memory_rel c be ts refs sp st m dm ((v,w)::vars) /\
+  encode_header c (case ev of
+                   | Evaluated => 14
+                   | NotEvaluated => 6) 1 = SOME hd /\
+   ~(new IN (domain refs)) /\
+   2 ≤ sp /\ good_dimindex (:'a) ==>
+   ?eoh (curr:'a word) trig m1.
+     FLOOKUP st EndOfHeap = SOME (Word eoh) /\
+     FLOOKUP st TriggerGC = SOME (Word trig) /\
+     FLOOKUP st CurrHeap = SOME (Word curr) /\
+     let w' = eoh - bytes_in_word * 2w in
+     let w1 = trig - bytes_in_word * 2w in
+       store_list w' [Word hd; w] m dm = SOME m1 /\
+       memory_rel c be ts (insert new (Thunk ev v) refs) (sp - 2)
+         (st |+ (EndOfHeap,Word w') |+ (TriggerGC,Word w1)) m1 dm
+         ((RefPtr F new,make_ptr c (w' - curr) 0w 1)::vars)
+Proof
+  simp_tac std_ss [LET_THM]
+  \\ rewrite_tac [CONJ_ASSOC]
+  \\ once_rewrite_tac [CONJ_COMM]
+  \\ fs [memory_rel_def,PULL_EXISTS] \\ rw []
+  \\ fs [word_ml_inv_def,PULL_EXISTS] \\ clean_tac
+  \\ drule (GEN_ALL new_thunk_thm)
+  \\ disch_then (qspecl_then [`new`, `ev`] strip_assume_tac)
+  \\ rfs [] \\ fs [] \\ clean_tac
+  \\ rewrite_tac [GSYM CONJ_ASSOC]
+  \\ once_rewrite_tac [METIS_PROVE [] ``b1 /\ b2 /\ b3 <=> b2 /\ b1 /\ b3:bool``]
+  \\ qmatch_asmsub_abbrev_tac `abs_ml_inv _ (v::l1) _ (v'::l2,_,_,_,_,_,_) _ _`
+  \\ `abs_ml_inv c ([v]++l1) (insert new (Thunk ev v) refs)
+                 ([v']++l2,heap2,be,a,sp'-2,sp1,gens) limit ts` by gvs []
+  \\ unabbrev_all_tac
+  \\ drule pop_thm \\ fs []
+  \\ strip_tac \\ asm_exists_tac \\ fs [word_addr_def]
+  \\ fs [heap_in_memory_store_def,FLOOKUP_UPDATE]
+  \\ imp_res_tac heap_store_unused_IMP_length \\ fs []
+  \\ `2 <= sp' + sp1` by decide_tac
+  \\ pop_assum mp_tac \\ simp_tac std_ss [LESS_EQ_EXISTS]
+  \\ strip_tac \\ clean_tac \\ fs []
+  \\ fs [GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]
+  \\ fs [LIST_REL_APPEND_EQ]
+  \\ fs [WORD_LEFT_ADD_DISTRIB,get_addr_def,make_ptr_def,get_lowerbits_def]
+  \\ fs [bytes_in_word_mul_eq_shift]
+  \\ fs [GSYM bytes_in_word_mul_eq_shift,GSYM word_add_n2w]
+  \\ fs [heap_store_unused_def,el_length_def]
+  \\ fs [GSYM word_add_n2w,wordsTheory.n2w_sub,WORD_LEFT_ADD_DISTRIB]
+  \\ every_case_tac \\fs []
+  \\ (
+    imp_res_tac heap_lookup_SPLIT \\ fs [] \\ clean_tac
+    \\ full_simp_tac std_ss [APPEND,GSYM APPEND_ASSOC]
+    \\ fs [heap_store_lemma] \\ clean_tac \\ fs []
+    \\ fs [word_heap_APPEND,word_heap_def,word_el_def,word_payload_def,
+           SEP_CLAUSES,word_heap_heap_expand,ThunkBlock_def,el_length_def,
+           heap_length_APPEND,heap_length_heap_expand,thunk_tag_to_bits_def]
+    \\ fs [word_list_exists_ADD |> Q.SPECL [`sp'`,`sp1`]]
+    \\ qmatch_goalsub_abbrev_tac `make_header c nn 1`
+    \\ `make_header c nn 1 = hd` by
+         (fs [Abbr`nn`,encode_header_def] \\ every_case_tac \\ fs []
+          \\ fs [WORD_MUL_LSL,word_mul_n2w,EXP_ADD] \\ NO_TAC)
+    \\ fs [Abbr`nn`] \\ drule encode_header_IMP \\ fs [] \\ strip_tac
+    \\ fs [SEP_CLAUSES,STAR_ASSOC]
+    \\ `2 = LENGTH [Word hd; word_addr c v']` by fs []
+    \\ full_simp_tac std_ss []
+    \\ assume_tac store_list_thm
+    \\ SEP_F_TAC \\ strip_tac \\ fs []
+    \\ fs [EVERY2_f_EQ] \\ clean_tac \\ fs []
+    \\ fs [el_length_def,heap_length_APPEND,heap_length_heap_expand,
+           GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]
+    \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC]
+    \\ pop_assum mp_tac \\ CONV_TAC (DEPTH_CONV ETA_CONV)
+    \\ fs [ADD1,GSYM word_add_n2w,WORD_LEFT_ADD_DISTRIB]
+    \\ fs [AC STAR_ASSOC STAR_COMM] \\ fs [STAR_ASSOC])
+QED
+
 Theorem memory_rel_write:
    memory_rel c be ts refs sp st m dm vars ==>
     ?(free:'a word).
@@ -7224,6 +8190,39 @@ Proof
   \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index]
 QED
 
+Theorem memory_rel_Thunk_IMP:
+   memory_rel c be ts refs sp st m dm ((RefPtr bl p,v:'a word_loc)::vars) /\
+    lookup p refs = SOME (Thunk ev x) /\ good_dimindex (:'a) ==>
+    ?w a x.
+      v = Word w /\ w ' 0 /\ word_bit 3 x /\ ~word_bit 2 x /\ word_bit 4 x /\
+      get_real_simple_addr c st w = SOME a /\
+      get_real_addr c st w = SOME a /\
+      m a = Word x /\ a IN dm /\
+      decode_length c x = 1w /\
+      (word_bit 5 x ⇔ ev = Evaluated)
+Proof
+  fs [memory_rel_def,word_ml_inv_def,PULL_EXISTS,abs_ml_inv_def,
+      bc_stack_ref_inv_def,v_inv_def,word_addr_def] \\ rw [get_addr_0]
+  \\ `bc_ref_inv c p refs (f,tf,heap,be)` by
+    (first_x_assum match_mp_tac \\ fs [reachable_refs_def]
+     \\ qexists_tac `RefPtr bl p` \\ fs [get_refs_def])
+  \\ pop_assum mp_tac \\ simp [bc_ref_inv_def]
+  \\ fs [FLOOKUP_DEF] \\ rw []
+  \\ fs [word_addr_def,heap_in_memory_store_def]
+  \\ rpt_drule get_real_addr_get_addr \\ disch_then kall_tac
+  \\ imp_res_tac heap_lookup_SPLIT \\ clean_tac
+  \\ fs [word_heap_APPEND,word_heap_def,ThunkBlock_def,word_el_def,
+         word_payload_def,word_list_def]
+  \\ full_simp_tac (std_ss++sep_cond_ss) [cond_STAR]
+  \\ imp_res_tac EVERY2_LENGTH \\ SEP_R_TAC \\ fs [get_addr_0]
+  \\ fs [make_header_def,word_bit_def,word_or_def,fcpTheory.FCP_BETA]
+  \\ fs [good_dimindex_def]
+  \\ fs [fcpTheory.FCP_BETA,word_lsl_def,word_index]
+  \\ Cases_on ‘ev’
+  \\ fs [thunk_tag_to_bits_def]
+  \\ EVAL_TAC
+QED
+
 val expand_num =
   DECIDE ``4 = SUC 3 /\ 3 = SUC 2 /\ 2 = SUC 1 /\ 1 = SUC 0 /\
            5 = SUC 4 /\ 6 = SUC 5 /\ 7 = SUC 6 /\ 8 = SUC 7``
@@ -7850,7 +8849,7 @@ Theorem memory_rel_RefPtr_IMP':
   memory_rel c be ts refs sp st m dm ((RefPtr bl p,v)::vars) ∧
   good_dimindex (:α) ⇒
   ∃w a x.
-    v = Word w ∧ w ' 0 ∧ (word_bit 4 x ⇒ word_bit 2 x) ∧
+    v = Word w ∧ w ' 0 ∧ (* (word_bit 4 x ⇒ word_bit 2 x) ∧ *)
     (word_bit 3 x ⇔ ¬word_bit 2 x) ∧
     data_to_word_memoryProof$get_real_addr c st w = SOME a ∧
     get_real_simple_addr c st w = SOME a ∧
@@ -7858,15 +8857,16 @@ Theorem memory_rel_RefPtr_IMP':
 Proof
   strip_tac \\ drule memory_rel_RefPtr_IMP_lemma \\ strip_tac
   \\ Cases_on `res` \\ fs []
-  THEN1 (rpt_drule memory_rel_ValueArray_IMP \\ rw [] \\ fs [])
-  THEN1 (rpt_drule memory_rel_ByteArray_IMP \\ rw [] \\ fs [])
+  THEN1 (drule_all memory_rel_ValueArray_IMP \\ rw [] \\ fs [])
+  THEN1 (drule_all memory_rel_ByteArray_IMP \\ rw [] \\ fs [])
+  THEN1 (drule_all memory_rel_Thunk_IMP \\ rw [] \\ fs [])
 QED
 
 Theorem memory_rel_RefPtr_IMP:
    memory_rel c be ts refs sp st m dm ((RefPtr bl p,v:'a word_loc)::vars) /\
     good_dimindex (:'a) ==>
     ?w a x.
-      v = Word w /\ w ' 0 /\ (word_bit 4 x ==> word_bit 2 x) /\
+      v = Word w /\ w ' 0 /\ (* (word_bit 4 x ==> word_bit 2 x) /\ *)
       (word_bit 3 x <=> ~word_bit 2 x) /\
       get_real_addr c st w = SOME a /\ m a = Word x /\ a IN dm
 Proof
@@ -9936,9 +10936,11 @@ Proof
       every_case_tac \\ fs[]
       \\ drule (GEN_ALL memory_rel_ValueArray_IMP) \\ fs[]
       \\ drule (GEN_ALL memory_rel_ByteArray_IMP) \\ fs[]
+      \\ drule (GEN_ALL memory_rel_Thunk_IMP) \\ fs[]
       \\ qhdtm_x_assum`memory_rel`kall_tac
       \\ drule (GEN_ALL memory_rel_ValueArray_IMP) \\ fs[]
       \\ drule (GEN_ALL memory_rel_ByteArray_IMP) \\ fs[]
+      \\ drule (GEN_ALL memory_rel_Thunk_IMP) \\ fs[]
       \\ strip_tac \\ fs[])
     \\ fs[] \\ clean_tac \\ fs[] \\ clean_tac
     \\ rpt_drule memory_rel_ByteArray_words_IMP
@@ -12317,7 +13319,7 @@ Proof
       (fs [reachable_refs_def] \\ rveq
        \\ metis_tac [list_to_v_get_refs])
     \\ simp [bc_ref_inv_def] \\ fs []
-    \\ fs [RefBlock_def, Bytes_def]
+    \\ fs [RefBlock_def, Bytes_def, ThunkBlock_def]
     \\ ntac 3 TOP_CASE_TAC \\ fs []
     \\ unlength_tac [heap_lookup_APPEND, heap_length_APPEND]
     \\ `0 < heap_length Allocd /\ heap_length Allocd <= sp + sp1` by fs []
@@ -12341,6 +13343,17 @@ Proof
       \\ NO_TAC)
     \\ TRY
      (first_x_assum drule \\ rw [])
+    \\ unlength_tac []
+    \\ TRY
+     (qmatch_goalsub_abbrev_tac `v_inv _ _ (_,ab1,ab2)`
+      \\ `LIST_REL (λz y. v_inv conf y (z,ab1,ab2)) [z] [a]` suffices_by gvs []
+      \\ unabbrev_all_tac
+      \\ first_x_assum irule \\ gvs []
+      \\ pop_assum (mp_then Any ho_match_mp_tac (GEN_ALL v_inv_SUBMAP))
+      \\ rw [heap_store_rel_def]
+      \\ ho_match_mp_tac bind_each_SUBMAP
+      \\ fs [SUBSET_DEF]
+      \\ NO_TAC)
     \\ unlength_tac [])
   \\ reverse conj_tac
   >-
@@ -13882,14 +14895,14 @@ Proof
          >-
           (simp [AllCaseEqs()]
            \\ rw [] \\ gvs [SF SFY_ss]
-           \\ gvs [Bytes_def,isRef_def])
+           \\ gvs [Bytes_def,isRef_def,isMutTag_def])
          \\ gvs [heap_split_def,el_length_Bytes]
          \\ IF_CASES_TAC \\ gvs []
-         >- (rw [] \\ gvs [isRef_def,Bytes_def])
+         >- (rw [] \\ gvs [isRef_def,Bytes_def,isMutTag_def])
          \\ IF_CASES_TAC \\ gvs []
          \\ simp [AllCaseEqs()]
          \\ rpt strip_tac \\ gvs []
-         \\ gvs [Bytes_def,isRef_def])
+         \\ gvs [Bytes_def,isRef_def,isMutTag_def])
       \\ ‘unused_space_inv a (sp' + sp1) heap1’ by
         (gvs [unused_space_inv_def,SF DNF_ss]
          \\ gvs [data_up_to_def]
@@ -13903,17 +14916,23 @@ Proof
          \\ IF_CASES_TAC \\ simp []
          \\ simp [AllCaseEqs()]
          \\ rw [] \\ gvs [SF SFY_ss]
-         \\ gvs [Bytes_def,isRef_def])
+         \\ gvs [Bytes_def,isRef_def,isMutTag_def])
       \\ ‘all_ts (insert p2 (ByteArray fl2 res_vals) refs) =
           all_ts refs’ by
         (gvs [all_ts_def,FUN_EQ_THM,lookup_insert,CaseEq"bool"]
-         \\ ‘∀n l. lookup n refs = SOME (ValueArray l) ⇔
-                     lookup n refs = SOME (ValueArray l) ∧ n ≠ p2’ by
-           (rw [] \\ eq_tac \\ rw [] \\ gvs []
-            \\ CCONTR_TAC \\ gvs [])
-            \\ rpt gen_tac
-         \\ pop_assum (fn th => CONV_TAC (RAND_CONV $ ONCE_REWRITE_CONV [th]))
-         \\ simp [AC CONJ_ASSOC CONJ_COMM])
+         \\ rpt gen_tac
+         \\ eq_tac \\ gvs []
+         >- (rw [] \\ gvs [find_ref_def] \\ metis_tac [])
+         \\ rw [] \\ gvs []
+         >- (
+          goal_assum $ drule_at Any \\ gvs []
+          \\ Cases_on `r` \\ gvs []
+          \\ (
+            disj1_tac \\ gvs []
+            \\ qmatch_asmsub_abbrev_tac `lookup n refs = SOME rv`
+            \\ qexistsl [`n`, `rv`] \\ gvs [Abbr`rv`]
+            \\ CCONTR_TAC \\ gvs []))
+          \\ metis_tac [])
       \\ ‘∀v x. v_inv c v (x,f,tf,heap1) = v_inv c v (x,f,tf,heap0)’ by
         (ho_match_mp_tac v_inv_alt_ind
          \\ simp [v_inv_def,Bignum_def,i2mw_def,Word64Rep_def]
diff --git a/compiler/backend/proofs/flat_elimProofScript.sml b/compiler/backend/proofs/flat_elimProofScript.sml
index 1a5d05f25a..7765e0ad0c 100644
--- a/compiler/backend/proofs/flat_elimProofScript.sml
+++ b/compiler/backend/proofs/flat_elimProofScript.sml
@@ -216,6 +216,8 @@ Definition find_refs_globals_def:
         union (find_v_globals a) (find_refs_globals t)) ∧
     (find_refs_globals (Varray l::t) =
         union (find_v_globalsL l) (find_refs_globals t)) ∧
+    (find_refs_globals (Thunk _ a::t) =
+        union (find_v_globals a) (find_refs_globals t)) ∧
     (find_refs_globals (_::t) = find_refs_globals t) ∧
     (find_refs_globals [] = LN)
 End
@@ -228,10 +230,13 @@ Theorem find_refs_globals_MEM:
       ⇒ (∀ a . MEM (Refv a) refs
             ⇒ domain (find_v_globals a) ⊆ R) ∧
         (∀ vs . MEM (Varray vs) refs
-            ⇒ domain (find_v_globalsL vs) ⊆ R)
+            ⇒ domain (find_v_globalsL vs) ⊆ R) ∧
+        (∀ m a . MEM (Thunk m a) refs
+            ⇒ domain (find_v_globals a) ⊆ R)
 Proof
     Induct >> rw[] >> fs[find_refs_globals_def, domain_union] >>
-    Cases_on `h` >> fs[find_refs_globals_def, domain_union]
+    Cases_on `h` >> fs[find_refs_globals_def, domain_union] >>
+    first_x_assum drule >> gvs []
 QED
 
 Theorem find_refs_globals_EL:
@@ -239,7 +244,9 @@ Theorem find_refs_globals_EL:
     (∀ a . EL n refs = Refv a
             ⇒ domain (find_v_globals a) ⊆ R) ∧
     (∀ vs . EL n refs = Varray vs
-            ⇒ domain (find_v_globalsL vs) ⊆ R)
+            ⇒ domain (find_v_globalsL vs) ⊆ R) ∧
+    (∀ m a . EL n refs = Thunk m a
+            ⇒ domain (find_v_globals a) ⊆ R)
 Proof
   metis_tac [EL_MEM, find_refs_globals_MEM]
 QED
@@ -255,7 +262,10 @@ Theorem find_refs_globals_LUPDATE:
         ⇒ domain (find_refs_globals (LUPDATE (Varray vs) n  refs))
             ⊆ domain reachable) ∧
     (∀ ws. domain (find_refs_globals (LUPDATE (W8array ws) n refs))
-        ⊆ domain reachable)
+        ⊆ domain reachable) ∧
+    (∀ m a. domain (find_v_globals a) ⊆ domain reachable
+        ⇒ domain (find_refs_globals (LUPDATE (Thunk m a) n refs))
+            ⊆ domain reachable)
 Proof
     Induct_on `refs` >> rw[] >> Cases_on `h` >>
     fs[find_refs_globals_def, domain_union] >>
@@ -964,6 +974,51 @@ Proof
         )
       )
     >- (
+      Cases_on `op = ThunkOp ForceThunk` >> gvs []
+      >- (
+        gvs [AllCaseEqs(), dec_clock_def, dest_GlobalVarLookup_def, PULL_EXISTS]
+        >- (
+          gvs [oneline dest_thunk_def, AllCaseEqs(),
+               semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def,
+               EVERY_EL] >>
+          first_x_assum drule >> gvs [] >> rw [] >>
+          gvs [find_sem_prim_res_globals_def, find_v_globals_def] >>
+          drule_all find_refs_globals_EL >> rw [])
+        >- (
+          gvs [oneline dest_thunk_def, AllCaseEqs(),
+               semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >>
+          simp [PULL_EXISTS] >>
+          last_x_assum $ qspecl_then
+            [`reachable`, `new_removed_state`] mp_tac >>
+          impl_tac
+          >- (
+            gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def,
+                 find_env_globals_def, find_v_globals_def, has_Eval_def,
+                 EVERY_EL] >>
+            first_x_assum drule >> rw [] >>
+            drule_all find_refs_globals_EL >> rw []) >>
+          rw [] >>
+          goal_assum drule >> simp [] >>
+          gvs [oneline update_thunk_def, AllCaseEqs(),
+               semanticPrimitivesTheory.store_assign_def,
+               find_sem_prim_res_globals_def, find_v_globals_def] >>
+          rw []
+          >- (drule_all find_refs_globals_LUPDATE >> gvs []) >>
+          gvs [EVERY_EL, EL_LUPDATE] >> rw [])
+        >- (
+          gvs [oneline dest_thunk_def, AllCaseEqs(),
+               semanticPrimitivesTheory.store_lookup_def, flat_state_rel_def] >>
+          last_x_assum $ qspecl_then
+            [`reachable`, `new_removed_state`] mp_tac >>
+          impl_tac
+          >- (
+            gvs [AppUnit_def, find_lookups_def, dest_GlobalVarLookup_def,
+                 find_env_globals_def, find_v_globals_def, has_Eval_def,
+                 EVERY_EL] >>
+            first_x_assum drule >> rw [] >>
+            drule_all find_refs_globals_EL >> rw []) >>
+          rw [] >>
+          goal_assum drule >> simp [])) >>
       Cases_on `do_app q op (REVERSE a)` >> fs[] >>
       PairCases_on `x` >> fs[] >> rveq >>
       drule (GEN_ALL do_app_SOME_flat_state_rel) >>
diff --git a/compiler/backend/proofs/flat_patternProofScript.sml b/compiler/backend/proofs/flat_patternProofScript.sml
index 8b8586828d..b5e0ed8b35 100644
--- a/compiler/backend/proofs/flat_patternProofScript.sml
+++ b/compiler/backend/proofs/flat_patternProofScript.sml
@@ -1757,6 +1757,64 @@ Proof
       \\ fs [option_case_eq] \\ rveq \\ fs []
       \\ rfs [env_rel_def, PULL_EXISTS, OPTREL_def]
     )
+    \\ Cases_on `op = ThunkOp ForceThunk`
+    >- (
+      gvs [AllCaseEqs(), dec_clock_def, PULL_EXISTS]
+      >- (
+        gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS,
+             store_lookup_def]
+        \\ rgs [Once v_rel_cases]
+        \\ gvs [state_rel_def, LIST_REL_EL_EQN]
+        \\ `sv_rel v_rel (Thunk Evaluated v) (EL n t2.refs)` by (
+          qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw [])
+        \\ gvs []
+        \\ Cases_on `EL n t2.refs` \\ gvs [])
+      >- (
+        gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS,
+             store_lookup_def]
+        \\ rgs [Once v_rel_cases]
+        \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧
+                v_rel v a` by (
+          gvs [state_rel_def, LIST_REL_EL_EQN]
+          \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw []
+          \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs []
+        \\ simp [PULL_EXISTS]
+        \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def]
+        \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, `t2`] mp_tac
+        \\ impl_tac
+        >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def]
+        \\ rw [] \\ gvs []
+        \\ gvs [oneline update_thunk_def, AllCaseEqs()]
+        \\ gvs [store_assign_def, store_v_same_type_def]
+        \\ gvs [state_rel_def, LIST_REL_EL_EQN, EL_LUPDATE]
+        \\ rw []
+        >- (
+          qpat_x_assum `v_rel v'' y` mp_tac
+          \\ gvs [oneline dest_thunk_def, AllCaseEqs()]
+          \\ rw [Once v_rel_cases]
+          \\ gvs [store_lookup_def]
+          \\ qpat_x_assum `∀n. n < LENGTH t2'.refs ⇒ _`
+               $ qspec_then `n'` assume_tac \\ gvs []
+          \\ Cases_on `EL n' t2'.refs` \\ gvs [])
+        >- (
+          first_x_assum drule \\ rw []
+          \\ Cases_on `EL n s''.refs` \\ Cases_on `EL n t2'.refs` \\ gvs []))
+      >- (
+        gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS,
+             store_lookup_def]
+        \\ rgs [Once v_rel_cases]
+        \\ `∃a. EL n t2.refs = Thunk NotEvaluated a ∧
+                v_rel v a` by (
+          gvs [state_rel_def, LIST_REL_EL_EQN]
+          \\ qpat_x_assum `∀n. n < LENGTH t2.refs ⇒ _` drule \\ rw []
+          \\ Cases_on `EL n t2.refs` \\ gvs []) \\ gvs []
+        \\ gvs [AppUnit_def, compile_exp_def, PULL_EXISTS, dec_name_to_num_def]
+        \\ last_x_assum $ qspecl_then [`1`, `<|v := [("f",a)]|>`, `t2`] mp_tac
+        \\ impl_tac
+        >- gvs [env_rel_def, ALOOKUP_rel_def, OPTREL_def, state_rel_def]
+        \\ rw [] \\ gvs []
+        \\ gvs [evaluate_def, do_opapp_def, AllCaseEqs()]
+        \\ gvs [state_rel_def, LIST_REL_EL_EQN]))
     \\ fs [option_case_eq, pair_case_eq]
     \\ rveq \\ fs []
     \\ drule_then (drule_then drule) do_app_thm_REVERSE
diff --git a/compiler/backend/proofs/flat_to_closProofScript.sml b/compiler/backend/proofs/flat_to_closProofScript.sml
index a1d2057688..d019b123dc 100644
--- a/compiler/backend/proofs/flat_to_closProofScript.sml
+++ b/compiler/backend/proofs/flat_to_closProofScript.sml
@@ -80,6 +80,7 @@ Definition store_rel_def:
     !i. if LENGTH refs <= i then FLOOKUP t_refs i = NONE else
           case EL i refs of
           | Refv v => (?x. FLOOKUP t_refs i = SOME (ValueArray [x]) /\ v_rel v x)
+          | Thunk m v => (?x. FLOOKUP t_refs i = SOME (Thunk m x) /\ v_rel v x)
           | Varray vs => (?xs. FLOOKUP t_refs i = SOME (ValueArray xs) /\
                                LIST_REL v_rel vs xs)
           | W8array bs => FLOOKUP t_refs i = SOME (ByteArray bs)
@@ -128,6 +129,15 @@ Proof
   \\ fs [flatSemTheory.list_to_v_def,list_to_v_def,v_rel_def]
 QED
 
+Theorem lookup_refv:
+  state_rel s1 t1 /\ store_lookup i s1.refs = SOME (Refv v) ==>
+  ?w. FLOOKUP t1.refs i = SOME (ValueArray [w]) /\ v_rel v w
+Proof
+  gvs [state_rel_def,store_rel_def] \\ rw []
+  \\ gvs [store_lookup_def]
+  \\ first_x_assum (qspec_then `i` mp_tac) \\ gvs []
+QED
+
 Theorem lookup_byte_array:
   state_rel s1 t1 /\ store_lookup i s1.refs = SOME (W8array bytes) ==>
   FLOOKUP t1.refs i = SOME (ByteArray bytes)
@@ -146,6 +156,15 @@ Proof
   \\ first_x_assum (qspec_then `i` mp_tac) \\ fs []
 QED
 
+Theorem lookup_thunk:
+  state_rel s1 t1 /\ store_lookup i s1.refs = SOME (Thunk m v) ==>
+  ?w. FLOOKUP t1.refs i = SOME (Thunk m w) /\ v_rel v w
+Proof
+  gvs [state_rel_def,store_rel_def] \\ rw []
+  \\ gvs [store_lookup_def]
+  \\ first_x_assum (qspec_then `i` mp_tac) \\ gvs []
+QED
+
 Triviality env_rel_CONS_upd:
   env_rel (env with v updated_by f) m db /\ v_rel v1 v2 ==>
   env_rel (env with v updated_by (\xs. (n,v1) :: f xs)) (SOME n :: m) (v2 :: db)
@@ -550,7 +569,7 @@ Theorem state_rel_LEAST:
 Proof
   fs [state_rel_def,store_rel_def] \\ rw []
   \\ ho_match_mp_tac
-    (whileTheory.LEAST_ELIM
+    (WhileTheory.LEAST_ELIM
      |> ISPEC ``\x. x = LENGTH s1.refs``
      |> CONV_RULE (DEPTH_CONV BETA_CONV))
   \\ fs [] \\ rpt strip_tac \\ fs [FLOOKUP_DEF]
@@ -566,7 +585,9 @@ Proof
 QED
 
 Theorem compile_op_evaluates_args:
-  evaluate (xs,db,t) = (Rerr err,t1) /\ op <> Opapp /\ op <> Eval ==>
+  evaluate (xs,db,t) = (Rerr err,t1) /\
+  op <> Opapp /\ op <> Eval /\ op <> ThunkOp ForceThunk
+  ==>
   evaluate ([compile_op tra op xs],db,t) = (Rerr err,t1)
 Proof
   Cases_on `op`
@@ -594,7 +615,7 @@ val op_goal =
     state_rel s1 (t1:('c,'ffi) closSem$state) /\
     evaluate (xs,db,t) = (Rval ws,t1) /\
     LIST_REL v_rel vs (REVERSE ws) /\
-    LENGTH xs = LENGTH vs /\ op <> Opapp ==>
+    LENGTH xs = LENGTH vs /\ op <> Opapp /\ op <> ThunkOp ForceThunk ==>
     ∃res2' t1.
       evaluate ([compile_op tt op xs],db,t) = (res2',t1) ∧
       state_rel s2 t1 ∧
@@ -1271,11 +1292,51 @@ Proof
   simp [compile_op_def, flatSemTheory.do_app_def]
 QED
 
+Theorem op_thunk:
+  ∀th_op. op = ThunkOp th_op ==> ^op_goal
+Proof
+  rpt strip_tac \\ rveq
+  \\ gvs [flatSemTheory.do_app_def, compile_op_def, evaluate_def, do_app_def]
+  \\ Cases_on `vs` \\ gvs []
+  \\ Cases_on `th_op` \\ gvs []
+  >- (
+    Cases_on `t'` \\ gvs []
+    \\ pairarg_tac \\ gvs []
+    \\ rw []
+    >- (
+      gvs [store_alloc_def]
+      \\ drule state_rel_LEAST \\ rw []
+      \\ gvs [state_rel_def, store_rel_def] \\ rw []
+      >- (
+        gvs [FLOOKUP_UPDATE]
+        \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs [])
+    \\ rw [EL_APPEND, FLOOKUP_UPDATE] \\ gvs []
+    \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs [])
+    >- (simp [Once v_rel_cases] \\ gvs [store_alloc_def, state_rel_LEAST]))
+  \\ gvs [AllCaseEqs(), PULL_EXISTS]
+  \\ qpat_x_assum `v_rel (Loc _ _) _` mp_tac
+  \\ rw [Once v_rel_cases]
+  \\ qpat_x_assum `store_assign _ _ _ = _` mp_tac
+  \\ simp [store_assign_def, store_v_same_type_def]
+  \\ ntac 2 CASE_TAC \\ rw [GSYM PULL_EXISTS]
+  >- (
+    gvs [state_rel_def, store_rel_def]
+    \\ first_x_assum (qspec_then `lnum` mp_tac) \\ gvs [] \\ rw []
+    \\ simp [SF SFY_ss])
+  >- (
+    gvs [state_rel_def, store_rel_def]
+    \\ rw [FLOOKUP_UPDATE, EL_LUPDATE]
+    >- (last_x_assum $ qspec_then `i` assume_tac \\ gvs [])
+    \\ CASE_TAC \\ rw []
+    \\ last_x_assum $ qspec_then `i` assume_tac \\ gvs [])
+  >- simp [Once v_rel_cases, Unit_def, EVAL ``tuple_tag``]
+QED
+
 Theorem compile_op_correct:
   ^op_goal
 Proof
   EVERY (map assume_tac
-    [op_refs, op_chars, op_ints, op_words, op_str, op_shifts,
+    [op_refs, op_chars, op_ints, op_words, op_str, op_shifts, op_thunk,
      op_floats, op_eq_gc, op_byte_arrays, op_vectors, op_arrays,
      op_globals, op_blocks, op_ffi, op_byte_copy, op_eval, op_id])
   \\ `?this_is_case. this_is_case op` by (qexists_tac `K T` \\ fs [])
@@ -1392,6 +1453,39 @@ Proof
   \\ fs [LENGTH_EQ_NUM_compute]
 QED
 
+Triviality rel_update_thunk:
+  state_rel s1 s2 ∧
+  LIST_REL v_rel vs ys ⇒
+    (update_thunk [Loc v ptr] s1.refs vs = SOME refs1 ⇒
+       ∃refs2. update_thunk [RefPtr v ptr] s2.refs ys = SOME refs2 ∧
+               state_rel (s1 with refs := refs1) (s2 with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline flatSemTheory.update_thunk_def, oneline update_thunk_def,
+          AllCaseEqs()] \\ rw []
+  \\ gvs [store_assign_def, store_v_same_type_def]
+  \\ Cases_on `EL ptr s1.refs` \\ gvs []
+  \\ Cases_on `t` \\ gvs []
+  \\ `∃b. FLOOKUP s2.refs ptr = SOME (Thunk NotEvaluated b)` by (
+    gvs [state_rel_def, store_rel_def]
+    \\ last_x_assum $ qspec_then `ptr` assume_tac \\ gvs [])
+  \\ gvs [oneline flatSemTheory.dest_thunk_def, oneline dest_thunk_def,
+          AllCaseEqs()]
+  \\ gvs [Once v_rel_cases, store_thunk_def, AllCaseEqs(), PULL_EXISTS]
+  \\ (
+    TRY (drule_all lookup_refv \\ rw [] \\ gvs [])
+    \\ TRY (drule_all lookup_byte_array \\ rw [] \\ gvs [])
+    \\ TRY (drule_all lookup_array \\ rw [] \\ gvs [])
+    \\ gvs [state_rel_def, store_rel_def, FLOOKUP_UPDATE, EL_LUPDATE] \\ rw []
+    >- (
+      rename1 `FLOOKUP s2.refs idx = _`
+      \\ last_x_assum $ qspec_then `idx` assume_tac \\ gvs [])
+    >- (simp [Once v_rel_cases] \\ metis_tac [])
+    >- (
+      rename1 `EL idx s1.refs`
+      \\ last_x_assum $ qspec_then `idx` assume_tac \\ gvs []))
+QED
+
 Theorem compile_App:
   ^(get_goal "flatLang$App")
 Proof
@@ -1403,6 +1497,22 @@ Proof
   \\ disch_then drule
   \\ impl_tac THEN1 (CCONTR_TAC \\ fs [])
   \\ strip_tac
+  \\ Cases_on `op = ThunkOp ForceThunk` >- (
+    gvs [dest_nop_def, compile_op_def, evaluate_def, AllCaseEqs(), PULL_EXISTS]
+    \\ gvs [oneline flatSemTheory.dest_thunk_def, oneline dest_thunk_def,
+            AllCaseEqs(), PULL_EXISTS]
+    \\ rgs [Once v_rel_cases]
+    \\ drule_all lookup_thunk \\ rw [] \\ gvs []
+    \\ imp_res_tac state_rel_IMP_clock \\ gvs [PULL_EXISTS]
+    \\ imp_res_tac state_rel_dec_clock
+    \\ last_x_assum $ drule_then $ qspecl_then [`[SOME "f"]`, `[w]`] mp_tac
+    \\ (
+      impl_tac
+      >- gvs [env_rel_def, findi_def, flatSemTheory.AppUnit_def]
+      \\ rw [AppUnit_def, flatSemTheory.AppUnit_def, dest_nop_def, compile_op_def,
+             arg2_def, findi_def, SmartCons_def, compile_def]
+      \\ goal_assum drule \\ gvs []
+      \\ drule_all rel_update_thunk \\ rw []))
   \\ Cases_on `op = Opapp` \\ fs []
   THEN1
    (fs [compile_op_def,dest_nop_def] \\ rveq
@@ -1886,7 +1996,8 @@ Proof
 QED
 
 val cases_op = Cases >|
-  map (MAP_EVERY Cases_on) [[], [], [`i`], [`w`], [`b`], [`g`], [`m`], []];
+  map (MAP_EVERY Cases_on)
+      [[`n`], [`s`], [`i`], [`w`], [`b`], [`g`], [`m`], [], [`t`]];
 
 Theorem clos_FINITE_BAG_set_globals[simp]:
   (∀e. FINITE_BAG (closProps$set_globals e)) ∧
@@ -2118,6 +2229,7 @@ Proof
   \\ simp ([CopyByteAw8_def, CopyByteStr_def] @ props_defs)
   \\ simp [arg1_def, arg2_def]
   \\ EVERY_CASE_TAC
+  \\ TRY (Cases_on `t'` \\ gvs [])
   \\ fs props_defs
   \\ imp_res_tac EVERY_IMP_HD
   \\ fs [NULL_LENGTH, EVERY_REVERSE]
diff --git a/compiler/backend/proofs/lab_to_targetProofScript.sml b/compiler/backend/proofs/lab_to_targetProofScript.sml
index f50225ac52..4c62fb6763 100644
--- a/compiler/backend/proofs/lab_to_targetProofScript.sml
+++ b/compiler/backend/proofs/lab_to_targetProofScript.sml
@@ -10349,7 +10349,7 @@ val semantics_compile_lemma = Q.prove(
   rw[]>>
   gvs[find_index_LEAST_EL] >>
   qpat_x_assum `(LEAST n'. _) = n` mp_tac >>
-  DEEP_INTRO_TAC whileTheory.LEAST_ELIM >>
+  DEEP_INTRO_TAC WhileTheory.LEAST_ELIM >>
   conj_tac
   >- (fs[MEM_EL] >> metis_tac[]) >>
   simp[] >>
diff --git a/compiler/backend/proofs/source_evalProofScript.sml b/compiler/backend/proofs/source_evalProofScript.sml
index 514921126e..6a9da3db26 100644
--- a/compiler/backend/proofs/source_evalProofScript.sml
+++ b/compiler/backend/proofs/source_evalProofScript.sml
@@ -621,6 +621,16 @@ Proof
   \\ simp [Once do_app_cases] \\ rw [listTheory.SWAP_REVERSE_SYM]
   \\ fs [CaseEq "ffi_result", option_case_eq] \\ rveq \\ fs []
   \\ simp [do_app_def]
+  >~ [`thunk_op`]
+  >- (
+    gvs [AllCaseEqs(), PULL_EXISTS, thunk_op_def]
+    >- (
+      rpt (pairarg_tac \\ gvs [])
+      \\ gvs [store_alloc_def, LIST_REL_EL_EQN])
+    \\ Cases_on ‘xs’ \\ gvs []
+    \\ drule_then (drule_then (qsubterm_then `store_assign _ _` mp_tac))
+         store_assign \\ rw []
+    \\ gvs [])
   \\ simp [div_exn_v_def, sub_exn_v_def, chr_exn_v_def,
         EVERY2_refl, MEM_MAP, PULL_EXISTS]
   \\ TRY (drule_then imp_res_tac (CONJUNCT1 do_eq))
@@ -957,7 +967,7 @@ val eval_simulation_setup = setup (`
   \\ rveq \\ fs []
   );
 
-Triviality eval_simulation_App:
+Theorem eval_simulation_App:
   ^(#get_goal eval_simulation_setup `Case ([App _ _])`)
 Proof
   rw []
@@ -1003,6 +1013,131 @@ Proof
     \\ simp [LIST_REL_MAP1, SIMP_RULE (bool_ss ++ ETA_ss) [] LIST_REL_MAP2]
     \\ simp [ELIM_UNCURRY, EVERY2_refl]
   )
+  >~ [`getOpClass op = Force`]
+  >- (
+    gvs [AllCaseEqs(), dec_clock_def]
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def]
+      \\ gvs [s_rel_def, LIST_REL_EL_EQN]
+      \\ `∃a. EL n refs'' = Thunk Evaluated a ∧
+              v_rel orac_s'' v a` by (
+        first_x_assum drule \\ rw []
+        \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs []
+      \\ simp [state_component_equality])
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def]
+      \\ simp[PULL_EXISTS]
+      \\ gvs [s_rel_def, LIST_REL_EL_EQN]
+      \\ `∃a. EL n refs'' = Thunk NotEvaluated a ∧
+              v_rel orac_s'' v a` by (
+        first_x_assum drule \\ rw []
+        \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs []
+      \\ gvs[do_opapp_cases] \\ irule_at Any EQ_REFL >> simp[])
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def]
+      \\ `n < LENGTH t''.refs ∧
+          ∃a. EL n t''.refs = Thunk NotEvaluated a ∧
+          v_rel (orac_s t''.eval_state) v a` by (
+        gvs [s_rel_def, LIST_REL_EL_EQN]
+        \\ first_x_assum drule \\ rw []
+        \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >>
+        gvs[do_opapp_cases, PULL_EXISTS]
+        >- (
+          imp_res_tac s_rel_def >> gvs[] >>
+          drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >>
+          last_x_assum dxrule >> simp[] >>
+          qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >>
+          disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac
+          >- (unabbrev_all_tac >> irule env_rel_add_nsBind >> simp[]) >>
+          strip_tac >> gvs[] >>
+          gvs[oneline update_thunk_def, AllCaseEqs()] >>
+          gvs[store_assign_def, s_rel_def, state_component_equality] >>
+          reverse $ rw[] >> insts_tac
+          >- (irule EVERY2_LUPDATE_same >> gvs[])
+          >- (
+            gvs[LIST_REL_EL_EQN, store_v_same_type_def] >>
+            first_x_assum drule >> simp[sv_rel_cases] >>
+            strip_tac >> gvs[]
+            )
+          >- gvs[LIST_REL_EL_EQN] >>
+          qpat_x_assum ‘dest_thunk _ _ = _’ mp_tac >> simp[oneline dest_thunk_def] >>
+          qpat_x_assum ‘v_rel _ _ _’ mp_tac >> simp[Once v_rel_cases] >> strip_tac >> gvs[]
+          >- gvs[oneline v_to_env_id_def, AllCaseEqs()] >>
+          simp[store_lookup_def] >> gvs[LIST_REL_EL_EQN] >>
+          IF_CASES_TAC >> gvs[] >>
+          first_x_assum drule >> simp[sv_rel_cases] >> strip_tac >> gvs[] >>
+          TOP_CASE_TAC >> gvs[]
+          )
+        >- (
+          imp_res_tac s_rel_def >> gvs[] >>
+          drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >>
+          last_x_assum dxrule >> simp[] >>
+          qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >>
+          disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac
+          >- (
+            unabbrev_all_tac >> simp[build_rec_env_merge, nsAppend_to_nsBindList] >>
+            irule env_rel_add_nsBind >> simp[] >>
+            irule env_rel_add_nsBindList >>
+            simp[LIST_REL_MAP1, SRULE [SF ETA_ss] LIST_REL_MAP2, ELIM_UNCURRY] >>
+            simp[LIST_REL_EL_EQN]
+            ) >>
+          strip_tac >> gvs[] >>
+          gvs[oneline update_thunk_def, AllCaseEqs()] >>
+          gvs[store_assign_def, s_rel_def, state_component_equality] >>
+          reverse $ rw[] >> insts_tac
+          >- (irule EVERY2_LUPDATE_same >> gvs[])
+          >- (
+            gvs[LIST_REL_EL_EQN, store_v_same_type_def] >>
+            first_x_assum drule >> simp[sv_rel_cases] >>
+            strip_tac >> gvs[]
+            )
+          >- gvs[LIST_REL_EL_EQN] >>
+          qpat_x_assum ‘dest_thunk _ _ = _’ mp_tac >> simp[oneline dest_thunk_def] >>
+          qpat_x_assum ‘v_rel _ _ _’ mp_tac >> simp[Once v_rel_cases] >> strip_tac >> gvs[]
+          >- gvs[oneline v_to_env_id_def, AllCaseEqs()] >>
+          simp[store_lookup_def] >> gvs[LIST_REL_EL_EQN] >>
+          IF_CASES_TAC >> gvs[] >>
+          first_x_assum drule >> simp[sv_rel_cases] >> strip_tac >> gvs[] >>
+          TOP_CASE_TAC >> gvs[]
+          )
+      )
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), oneline store_lookup_def]
+      \\ `n < LENGTH t''.refs ∧
+          ∃a. EL n t''.refs = Thunk NotEvaluated a ∧
+          v_rel (orac_s t''.eval_state) v a` by (
+        gvs [s_rel_def, LIST_REL_EL_EQN]
+        \\ first_x_assum drule \\ rw []
+        \\ Cases_on `EL n refs''` \\ gvs [sv_rel_def]) \\ gvs [] >>
+        gvs[do_opapp_cases, PULL_EXISTS]
+        >- (
+          imp_res_tac s_rel_def >> gvs[] >>
+          irule_at Any OR_INTRO_THM2 >>
+          drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >>
+          last_x_assum dxrule >> simp[] >>
+          qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >>
+          disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac
+          >- (unabbrev_all_tac >> irule env_rel_add_nsBind >> simp[]) >>
+          strip_tac >> gvs[] >> insts_tac
+          )
+        >- (
+          imp_res_tac s_rel_def >> gvs[] >>
+          irule_at Any OR_INTRO_THM2 >>
+          drule s_rel_clock >> simp[dec_clock_def] >> strip_tac >>
+          last_x_assum dxrule >> simp[] >>
+          qmatch_goalsub_abbrev_tac ‘evaluate _ new_env’ >>
+          disch_then $ qspec_then ‘new_env’ mp_tac >> impl_tac
+          >- (
+            unabbrev_all_tac >> simp[build_rec_env_merge, nsAppend_to_nsBindList] >>
+            irule env_rel_add_nsBind >> simp[] >>
+            irule env_rel_add_nsBindList >>
+            simp[LIST_REL_MAP1, SRULE [SF ETA_ss] LIST_REL_MAP2, ELIM_UNCURRY] >>
+            simp[LIST_REL_EL_EQN]
+            ) >>
+          strip_tac >> gvs[] >> insts_tac
+          )
+      )
+    )
   \\ eval_cases_tac
   \\ drule_then (drule_then assume_tac) do_app_sim
   \\ insts_tac
@@ -1434,6 +1569,12 @@ Proof
   \\ simp [record_forward_refl]
   >- (
     Cases_on ‘getOpClass op’ \\ fs[]
+    >~ [`getOpClass op = Force`] >- (
+      full_simp_tac bool_ss [do_eval_res_def, bool_case_eq, pair_case_eq,
+          option_case_eq, result_case_eq, dec_clock_def]
+      \\ rveq \\ full_simp_tac bool_ss [PAIR_EQ]
+      \\ gvs [AllCaseEqs()]
+      \\ imp_res_tac record_forward_trans_sym)
     \\ full_simp_tac bool_ss [do_eval_res_def, bool_case_eq, pair_case_eq,
         option_case_eq, result_case_eq, dec_clock_def]
     \\ rveq \\ full_simp_tac bool_ss [PAIR_EQ]
@@ -1562,6 +1703,13 @@ Proof
     \\ agrees_impl_tac
     \\ simp []
   )
+  >~ [`getOpClass op = Force`] >- (
+    gvs [AllCaseEqs(), dec_clock_def]
+    \\ eval_cases_tac
+    \\ imp_res_simp_tac evaluate_is_record_forward
+    \\ imp_res_simp_tac insert_declare_env
+    \\ agrees_impl_tac
+    \\ simp [])
   \\ eval_cases_tac
   \\ gs[]
 QED
@@ -1692,7 +1840,17 @@ Proof
             \\ drule_then irule record_forward_trans)
         \\ NO_TAC)
   \\ simp [combine_dec_result_def]
-  \\ gs[]
+  >>~ [`getOpClass op = Force`]
+  >- (
+    gvs [AllCaseEqs(), dec_clock_def]
+    \\ drule_then (drule_then assume_tac) less_sub_1_cases \\ gvs []
+    \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs [])
+  >- (
+    gvs [AllCaseEqs(), dec_clock_def]
+    \\ imp_res_simp_tac evaluate_is_record_forward \\ gvs []
+    >- (drule_then irule record_forward_trans \\ gvs [])
+    >- (drule_then irule record_forward_trans \\ gvs [])
+    >- (disj2_tac \\ drule_then irule record_forward_trans \\ gvs []))
 QED
 
 (* Constructs the oracle from an evaluation by using the recorded
@@ -1783,7 +1941,7 @@ Proof
   \\ rw []
   \\ first_x_assum (qspec_then `j` mp_tac)
   \\ simp [extract_oracle_def]
-  \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO
+  \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO
   \\ rpt strip_tac
   >- (
     first_x_assum (qspec_then `k` mp_tac)
@@ -1851,8 +2009,8 @@ Triviality extract_oracle_SOME_SUC:
   IS_SOME (extract_oracle s env decs i)
 Proof
   simp [extract_oracle_def]
-  \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO
-  \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO
+  \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO
+  \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO
   \\ rw []
   \\ simp [UNCURRY]
   \\ res_tac
@@ -1867,7 +2025,7 @@ Triviality extract_oracle_0_st:
   FST (SND r) = ci.config_v ci.init_state
 Proof
   simp [extract_oracle_def]
-  \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO
+  \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO
   \\ simp [UNCURRY]
   \\ rw []
   \\ Cases_on `evaluate_decs (s with clock := n) env decs`
@@ -1910,7 +2068,7 @@ Proof
         SUC i < FST (FST ((orac_s t'.eval_state).oracle 0))`)
   >- (
     rpt (POP_ASSUM (mp_tac o REWRITE_RULE [extract_oracle_def]))
-    \\ DEEP_INTRO_TAC whileTheory.OLEAST_INTRO
+    \\ DEEP_INTRO_TAC WhileTheory.OLEAST_INTRO
     \\ rw []
     \\ metis_tac []
   )
@@ -2217,6 +2375,7 @@ Proof
       fs [astTheory.op_class_case_eq]
       \\ fs [bool_case_eq, Q.ISPEC `(a, b)` EQ_SYM_EQ]
       \\ gvs []
+      >~ [`getOpClass op = Force`] >- gvs [AllCaseEqs(), dec_clock_def]
       \\ fs [option_case_eq, pair_case_eq, bool_case_eq, result_case_eq]
       \\ insts_tac
       \\ fs [dec_clock_def]
diff --git a/compiler/backend/proofs/source_to_flatProofScript.sml b/compiler/backend/proofs/source_to_flatProofScript.sml
index 7967419521..fb3b03e786 100644
--- a/compiler/backend/proofs/source_to_flatProofScript.sml
+++ b/compiler/backend/proofs/source_to_flatProofScript.sml
@@ -703,7 +703,11 @@ Inductive sv_rel:
   (!genv vs vs'.
     LIST_REL (v_rel genv) vs vs'
     ⇒
-    sv_rel genv (Varray vs) (Varray vs'))
+    sv_rel genv (Varray vs) (Varray vs')) ∧
+  (!genv m v v'.
+    v_rel genv v v'
+    ⇒
+    sv_rel genv (Thunk m v) (Thunk m v'))
 End
 
 Triviality sv_rel_weak:
@@ -1323,6 +1327,26 @@ Proof
       fsrw_tac[][] >>
       srw_tac[][markerTheory.Abbrev_def, EL_LUPDATE] >>
       srw_tac[][v_rel_lems] >> CCONTR_TAC >> rfs [] >> rveq >> fs [])
+  >- ((* ThunkOp *)
+    srw_tac[][semanticPrimitivesPropsTheory.do_app_cases,
+              flatSemTheory.do_app_def, thunk_op_def] >>
+    gvs[AllCaseEqs(), PULL_EXISTS]
+    >- (
+      ntac 2 (pairarg_tac >> gvs[]) >>
+      gvs[store_alloc_def] >>
+      srw_tac[][sv_rel_cases, result_rel_cases, v_rel_eqns] >>
+      gvs[LIST_REL_EL_EQN])
+    >- (
+      gvs[store_assign_def, store_v_same_type_def] >>
+      Cases_on `EL lnum q` >> gvs[] >> Cases_on `t'` >> gvs[] >>
+      qpat_x_assum `v_rel _ (Loc _ _) y` mp_tac >> rw[Once v_rel_cases] >>
+      gvs [LIST_REL_EL_EQN, REWRITE_RULE [ADD1] LUPDATE_def, EL_LUPDATE]
+      >- (rw[] >> simp [Once sv_rel_cases])
+      >- simp[Once result_rel_cases, Once v_rel_cases]
+      >- (
+        rw[REWRITE_RULE [ADD1] EL] >>
+        first_x_assum drule >> gvs[] >>
+        CASE_TAC >> rw[Once sv_rel_cases])))
   >~ [‘ListAppend’] >- (
     simp [semanticPrimitivesPropsTheory.do_app_cases, flatSemTheory.do_app_def] >>
     rw [] >>
@@ -4003,7 +4027,7 @@ Proof
   \\ fs []
 QED
 
-Triviality compile_correct_App:
+Theorem compile_correct_App:
   ^(#get_goal compile_correct_setup `Case [App _ _]`)
 Proof
   rpt disch_tac
@@ -4187,8 +4211,146 @@ Proof
     \\ fs [invariant_def, s_rel_cases]
   ) >>
   Cases_on ‘getOpClass op’ >> gs[]
-  >- (Cases_on ‘op’ >> gs[astTheory.getOpClass_def])
-  >- (Cases_on ‘op’ >> gs[astTheory.getOpClass_def]) >>
+  >- (
+    Cases_on ‘op’ >> gs[astTheory.getOpClass_def] >>
+    Cases_on ‘t'’ >> gvs[])
+  >- (
+    Cases_on ‘op’ >> gs[astTheory.getOpClass_def] >>
+    Cases_on ‘t'’ >> gvs[])
+  >~ [‘getOpClass op = Force’]
+  >- (
+    Cases_on ‘op’ >> gvs[astTheory.getOpClass_def] >>
+    Cases_on ‘t'’ >> gvs[] >>
+    gvs[AllCaseEqs(), evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def,
+        PULL_EXISTS] >> rw[]
+    >- (
+      gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse,
+          AllCaseEqs()] >>
+      qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >>
+      rw[Once result_rel_cases] >>
+      gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >>
+      rgs[Once v_rel_cases] >> gvs[] >>
+      simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >>
+      gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >>
+      `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >>
+      gvs[] >>
+      `∃v''. EL n (TL s'_i1.refs) = Thunk Evaluated v'' ∧
+             v_rel genv' v v''` by (
+        first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >>
+      simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases] >>
+      goal_assum drule >> rw[])
+    >- (
+      gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse,
+          AllCaseEqs()] >>
+      qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >>
+      rw[Once result_rel_cases] >>
+      gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >>
+      rgs[Once v_rel_cases] >> gvs[] >>
+      simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >>
+      gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >>
+      `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >>
+      gvs[] >>
+      `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧
+             v_rel genv' v v'` by (
+        first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >>
+      simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >>
+      simp[AppUnit_def, dec_clock_def] >>
+      ntac 5 $ simp[Once evaluate_def] >>
+      drule do_opapp >> simp[PULL_EXISTS] >>
+      disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >>
+      goal_assum drule >> simp[]
+      )
+    >- (
+      gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse,
+          AllCaseEqs()] >>
+      qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >>
+      rw[Once result_rel_cases] >>
+      gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >>
+      rgs[Once v_rel_cases] >> gvs[] >>
+      simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >>
+      gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >>
+      `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >>
+      gvs[] >>
+      `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧
+             v_rel genv' v v'` by (
+        first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >>
+      simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >>
+      simp[AppUnit_def, dec_clock_def] >>
+      ntac 5 $ simp[Once evaluate_def] >>
+      drule do_opapp >> simp[PULL_EXISTS] >>
+      disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >>
+      dxrule invariant_dec_clock >> strip_tac >>
+      gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >>
+      last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >>
+      gvs[Once result_rel_cases] >>
+      gvs[oneline semanticPrimitivesTheory.update_thunk_def,
+          oneline flatSemTheory.update_thunk_def, AllCaseEqs()] >>
+      `dest_thunk [y] s'_i1'.refs = NotThunk` by (
+        qpat_x_assum `v_rel _ v'3' y` mp_tac >>
+        Cases_on `v'3'` >> Cases_on `y` >>
+        rw[Once v_rel_cases, dest_thunk_def, Boolv_def] >>
+        gvs[semanticPrimitivesTheory.dest_thunk_def, store_lookup_def] >>
+        reverse $ rw []
+        >- (Cases_on `s'_i1'.refs` >> gvs []) >>
+        `n' < LENGTH (TL s'_i1'.refs)` by (Cases_on `s'_i1'.refs` >> gvs[]) >>
+        gvs[] >>
+        first_x_assum drule >> simp[REWRITE_RULE [ADD1] EL] >>
+        Cases_on `EL n' st2.refs` >> Cases_on `EL n' (TL s'_i1'.refs)` >>
+        rw[Once sv_rel_cases] >> gvs[] >> Cases_on `t'` >> gvs[]) >> gvs[] >>
+      Cases_on `s'_i1'.refs` >> gvs[] >>
+      qexists `genv'3'` >> gvs[] >>
+      imp_res_tac SUBMAP_TRANS >> gvs[] >>
+      imp_res_tac subglobals_trans >> gvs[] >>
+      gvs[store_assign_def, store_v_same_type_def, REWRITE_RULE [ADD1] EL] >>
+      rw[]
+      >- (
+        first_x_assum drule >>
+        Cases_on `EL n st2.refs` >> Cases_on `EL n t'` >> gvs[] >>
+        rw[Once sv_rel_cases])
+      >- rw[REWRITE_RULE [ADD1] LUPDATE_def]
+      >- rw[REWRITE_RULE [ADD1] LUPDATE_def]
+      >- (
+        rw[REWRITE_RULE [ADD1] LUPDATE_def, EL_LUPDATE] >>
+        simp[Once sv_rel_cases])
+      >- (
+        rw[REWRITE_RULE [ADD1] LUPDATE_def] >>
+        gvs[invariant_def] >>
+        rw[REWRITE_RULE [ADD1] LUPDATE_def] >>
+        gvs[s_rel_cases, LIST_REL_EL_EQN] >>
+        rw[EL_LUPDATE] >> simp[Once sv_rel_cases])
+      >- (
+        gvs[evaluateTheory.dec_clock_def] >>
+        drule_then irule orac_forward_rel_trans >> gvs[])
+      )
+    >- (
+      gvs[astOp_to_flatOp_def, evaluate_def, compile_exps_reverse,
+          AllCaseEqs()] >>
+      qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >>
+      rw[Once result_rel_cases] >>
+      gvs[oneline semanticPrimitivesTheory.dest_thunk_def, AllCaseEqs()] >>
+      rgs[Once v_rel_cases] >> gvs[] >>
+      simp[dest_thunk_def, AllCaseEqs(), PULL_EXISTS] >>
+      gvs[store_lookup_def, s_rel_cases, LIST_REL_EL_EQN] >>
+      `n + 1 < LENGTH s'_i1.refs` by (Cases_on `s'_i1.refs` >> gvs[]) >>
+      gvs[] >>
+      `∃v'. EL n (TL s'_i1.refs) = Thunk NotEvaluated v' ∧
+             v_rel genv' v v'` by (
+        first_x_assum drule >> gvs[] >> rw[Once sv_rel_cases]) >>
+      simp[REWRITE_RULE [ADD1] EL, Once result_rel_cases, PULL_EXISTS] >>
+      simp[AppUnit_def, dec_clock_def] >>
+      ntac 5 $ simp[Once evaluate_def] >>
+      drule do_opapp >> simp[PULL_EXISTS] >>
+      disch_then drule >> simp[Once v_rel_cases] >> strip_tac >> gvs[] >>
+      dxrule invariant_dec_clock >> strip_tac >>
+      gvs[evaluateTheory.dec_clock_def, flatSemTheory.dec_clock_def] >>
+      last_x_assum drule_all >> disch_then $ qspec_then ‘t1’ assume_tac >> gvs[] >>
+      qpat_x_assum `result_rel _ _ _ r_i1` mp_tac >> rw[Once result_rel_cases] >>
+      goal_assum drule >> simp[] >>
+      imp_res_tac SUBMAP_TRANS >> gvs[] >>
+      imp_res_tac subglobals_trans >> gvs[] >>
+      drule_then irule orac_forward_rel_trans >> gvs[]
+      )
+    ) >>
   fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, option_case_eq, pair_case_eq] >>
   rw [] >>
   rveq >> fs [] >>
@@ -4199,12 +4361,14 @@ Proof
   rpt (disch_then drule) >>
   (impl_tac >- fs [invariant_def, s_rel_cases]) >>
   rw [] >>
-  `astOp_to_flatOp op ≠ Opapp ∧ astOp_to_flatOp op ≠ Eval`
+  `astOp_to_flatOp op ≠ Opapp ∧ astOp_to_flatOp op ≠ Eval ∧
+   astOp_to_flatOp op ≠ ThunkOp ForceThunk`
   by (
     rw [astOp_to_flatOp_def] >>
     Cases_on `op` >>
     simp [] >>
-    fs []) >>
+    fs [astTheory.getOpClass_def] >>
+    Cases_on `t'` >> gvs []) >>
   fs [evaluate_def, compile_exps_reverse] >>
   imp_res_tac do_app_state_unchanged >>
   imp_res_tac do_app_const >>
diff --git a/compiler/backend/proofs/word_gcFunctionsScript.sml b/compiler/backend/proofs/word_gcFunctionsScript.sml
index 9f9e59036b..955a7d6ae8 100644
--- a/compiler/backend/proofs/word_gcFunctionsScript.sml
+++ b/compiler/backend/proofs/word_gcFunctionsScript.sml
@@ -307,7 +307,7 @@ Definition word_gen_gc_partial_full_def:
 End
 
 Definition is_ref_header_def:
-  is_ref_header (v:'a word) <=> ((v && 0b11100w) = 0b01000w)
+  is_ref_header (v:'a word) <=> ((v && 0b1100w) = 0b01000w)
 End
 
 Definition word_gen_gc_move_def:
diff --git a/compiler/backend/reg_alloc/parmoveScript.sml b/compiler/backend/reg_alloc/parmoveScript.sml
index b26725dd1f..aafb2923df 100644
--- a/compiler/backend/reg_alloc/parmoveScript.sml
+++ b/compiler/backend/reg_alloc/parmoveScript.sml
@@ -557,9 +557,9 @@ val tac =
       rw[dstep_cases] >>
       TRY(map_every qexists_tac[`FST(LAST t')`,`SND(LAST t')`,`FRONT t'`]) >>
       rw[APPEND_FRONT_LAST] >>
-      fs[whileTheory.OLEAST_def,MEM_MAP,MEM_EL] >>
+      fs[WhileTheory.OLEAST_def,MEM_MAP,MEM_EL] >>
       metis_tac[] ) >>
-  fs[whileTheory.OLEAST_def] >>
+  fs[WhileTheory.OLEAST_def] >>
   BasicProvers.CASE_TAC >- (
       fs[DROP_NIL] >> rw[] >>
       pop_assum mp_tac >>
@@ -628,7 +628,7 @@ Termination
        fs[NULL_LENGTH,LENGTH_NIL] >>
        simp[LENGTH_FRONT,PRE_SUB1,LENGTH_NOT_NULL,NULL_LENGTH,LENGTH_NIL] >>
        NO_TAC) >>
-     fs[whileTheory.OLEAST_def] >> rw[] >>
+     fs[WhileTheory.OLEAST_def] >> rw[] >>
      pop_assum mp_tac >>
      numLib.LEAST_ELIM_TAC >>
      conj_tac >- metis_tac[] >>
diff --git a/compiler/backend/semantics/bviPropsScript.sml b/compiler/backend/semantics/bviPropsScript.sml
index 9ff133d8b1..a4608f27c4 100644
--- a/compiler/backend/semantics/bviPropsScript.sml
+++ b/compiler/backend/semantics/bviPropsScript.sml
@@ -129,7 +129,8 @@ val evaluate_LENGTH = Q.prove(
   HO_MATCH_MP_TAC evaluate_ind \\ REPEAT STRIP_TAC
   \\ FULL_SIMP_TAC (srw_ss()) [evaluate_def,case_elim_thms]
   \\ rw[] \\ fs[]
-  \\ every_case_tac \\ fs[])
+  \\ every_case_tac \\ fs[]
+  \\ first_x_assum drule \\ rw [])
   |> SIMP_RULE std_ss [];
 
 Theorem evaluate_LENGTH =
@@ -350,6 +351,7 @@ Proof
     \\ MP_TAC (do_app_inv_clock |> Q.INST [`s`|->`s5`])
     \\ Cases_on `do_app op (REVERSE a) s5` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] []
     \\ Cases_on `a'` \\ full_simp_tac(srw_ss())[] \\ SRW_TAC [] [])
+  THEN1 gvs [AllCaseEqs(), NOT_LESS, dec_clock_def, inc_clock_def]
   THEN1
    (Cases_on `dest = NONE /\ IS_SOME handler` \\ full_simp_tac(srw_ss())[]
     \\ Cases_on `evaluate (xs,env,s1)` \\ full_simp_tac(srw_ss())[]
@@ -410,16 +412,23 @@ Proof
        qmatch_goalsub_rename_tac`a1 + (a2 + a3)`
     \\ qexists_tac`a3+a2+a1`
     \\ simp[GENLIST_APPEND,FOLDL_APPEND] \\ NO_TAC)
-  \\ Cases_on`op=Install`
   >- (
-    fs[do_app_def,do_install_def,case_eq_thms,bool_case_eq]
-    \\ pairarg_tac \\ fs[] \\ rveq
-    \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] \\ rveq
-    \\ fs[shift_seq_def]
-    \\ qexists_tac`1+n` \\ rfs[GENLIST_APPEND,FOLDL_APPEND] )
-  \\ imp_res_tac do_app_code \\ rfs[]
-  \\ imp_res_tac do_app_oracle \\ rfs[]
-  \\ qexists_tac`n` \\ fs[]
+    Cases_on`op=Install`
+    >- (
+      fs[do_app_def,do_install_def,case_eq_thms,bool_case_eq]
+      \\ pairarg_tac \\ fs[] \\ rveq
+      \\ fs[case_eq_thms,pair_case_eq,bool_case_eq] \\ rveq
+      \\ fs[shift_seq_def]
+      \\ qexists_tac`1+n` \\ rfs[GENLIST_APPEND,FOLDL_APPEND] )
+    \\ imp_res_tac do_app_code \\ rfs[]
+    \\ imp_res_tac do_app_oracle \\ rfs[]
+    \\ qexists_tac`n` \\ fs[])
+  >- (
+    gvs [AllCaseEqs(), FUN_EQ_THM]
+    >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’,
+        ‘s.clock ≠ 0’]
+    >- (qexists ‘n'’ \\ gvs [])
+    \\ qexists `0` \\ gvs [])
 QED
 
 Theorem evaluate_code_mono:
@@ -473,6 +482,7 @@ Theorem do_app_with_code:
    do_app op vs (s with code := c) = Rval (r,s' with code := c)
 Proof
   rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq]
+  >~ [`ThunkOp`] >- gvs[bvlSemTheory.do_app_def, AllCaseEqs(), bvl_to_bvi_def]
   \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms]
   \\ TRY (pairarg_tac \\ fs [])
   \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[]
@@ -485,6 +495,7 @@ Theorem do_app_with_code_err:
    do_app op vs (s with code := c) = Rerr e
 Proof
   rw [do_app_def,do_app_aux_def,case_eq_thms,pair_case_eq]
+  >>~- ([`ThunkOp`], gvs [bvlSemTheory.do_app_def, AllCaseEqs()])
   \\ fs[bvl_to_bvi_def,bvi_to_bvl_def,bvlSemTheory.do_app_def,case_eq_thms]
   \\ TRY (pairarg_tac \\ fs [])
   \\ rw[] \\ fs[] \\ rw[] \\ fs[case_eq_thms,pair_case_eq] \\ rw[]
@@ -559,6 +570,7 @@ Proof
       srw_tac[][] >>
       `s.clock + ck - 1 = s.clock - 1 + ck` by (srw_tac [ARITH_ss] [ADD1]) >>
       metis_tac [])
+  >- gvs [AllCaseEqs(), dec_clock_def, inc_clock_def]
   >- (Cases_on `evaluate (xs,env,s1)` >>
       full_simp_tac(srw_ss())[] >>
       Cases_on `q` >>
@@ -601,7 +613,7 @@ Theorem evaluate_io_events_mono:
 Proof
   recInduct evaluate_ind >>
   srw_tac[][evaluate_def] >>
-  every_case_tac >> full_simp_tac(srw_ss())[] >>
+  gvs [AllCaseEqs()] >>
   srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >>
   metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono]
 QED
@@ -724,6 +736,7 @@ Definition get_code_labels_def:
   (get_code_labels (Let es e) = BIGUNION (set (MAP get_code_labels es)) ∪ get_code_labels e) ∧
   (get_code_labels (Raise e) = get_code_labels e) ∧
   (get_code_labels (Tick e) = get_code_labels e) ∧
+  (get_code_labels (Force loc v) = {loc}) ∧
   (get_code_labels (Call _ d es h) =
     (case d of NONE => {} | SOME n => {n}) ∪
     (case h of NONE => {} | SOME e => get_code_labels e) ∪
diff --git a/compiler/backend/semantics/bviSemScript.sml b/compiler/backend/semantics/bviSemScript.sml
index 9c1689df15..9b177cb160 100644
--- a/compiler/backend/semantics/bviSemScript.sml
+++ b/compiler/backend/semantics/bviSemScript.sml
@@ -162,6 +162,24 @@ Definition do_app_def:
                     | Rval (v,t) => Rval (v, bvl_to_bvi t s))
 End
 
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk (RefPtr _ ptr) refs =
+    (case FLOOKUP refs ptr of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk vs refs = NotThunk
+End
+
+
 (* The evaluation is defined as a clocked functional version of
    a conventional big-step operational semantics. *)
 
@@ -206,14 +224,30 @@ Definition evaluate_def:
      | (Rval vs,s) => (Rerr(Rraise (HD vs)),s)
      | res => res) /\
   (evaluate ([Op op xs],env,s) =
-     case evaluate (xs,env,s) of
-     | (Rval vs,s) => (case do_app op (REVERSE vs) s of
-                          | Rerr e => (Rerr e,s)
-                          | Rval (v,s) => (Rval [v],s))
+     case fix_clock s (evaluate (xs,env,s)) of
+     | (Rval vs,s) =>
+         (case do_app op (REVERSE vs) s of
+          | Rerr e => (Rerr e,s)
+          | Rval (v,s) => (Rval [v],s))
      | res => res) /\
   (evaluate ([Tick x],env,s) =
      if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else
        evaluate ([x],env,dec_clock 1 s)) /\
+  (evaluate ([Force force_loc n],env,s) =
+     if ~(n < LENGTH env) then (Rerr(Rabort Rtype_error),s) else
+       let thunk_v = EL n env in
+         case dest_thunk thunk_v s.refs of
+         | BadRef => (Rerr (Rabort Rtype_error),s)
+         | NotThunk => (Rerr (Rabort Rtype_error),s)
+         | IsThunk Evaluated v => (Rval [v],s)
+         | IsThunk NotEvaluated f =>
+             (case find_code (SOME force_loc) [thunk_v; f] s.code of
+              | NONE => (Rerr(Rabort Rtype_error),s)
+              | SOME (args,exp) =>
+                  if s.clock = 0 then
+                    (Rerr(Rabort Rtimeout_error),s with clock := 0)
+                  else
+                    evaluate ([exp],args,dec_clock 1 s))) /\
   (evaluate ([Call ticks dest xs handler],env,s1) =
      if IS_NONE dest /\ IS_SOME handler then (Rerr(Rabort Rtype_error),s1) else
      case fix_clock s1 (evaluate (xs,env,s1)) of
diff --git a/compiler/backend/semantics/bvlPropsScript.sml b/compiler/backend/semantics/bvlPropsScript.sml
index 21e75d6187..3902a2b7ee 100644
--- a/compiler/backend/semantics/bvlPropsScript.sml
+++ b/compiler/backend/semantics/bvlPropsScript.sml
@@ -83,8 +83,7 @@ Theorem do_app_Rval_swap:
        <| globals := x1.globals; refs := x1.refs;
           clock := x1.clock; ffi := x1.ffi |>)
 Proof
-  rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs []
-  \\ gvs [EVERY_MEM] \\ rw [] \\ res_tac \\ fs []
+  rw[do_app_cases_val] \\ rfs[SUBSET_DEF] \\ fs [] \\ gvs [AllCaseEqs()]
 QED
 
 Theorem do_app_with_code:
@@ -118,9 +117,7 @@ Theorem do_app_Rerr_swap:
 Proof
   Cases_on `op` \\ rw[do_app_cases_err] \\ rfs[SUBSET_DEF] \\ fs []
   \\ TRY (strip_tac \\ res_tac \\ fs [])
-  \\ gvs [EXISTS_MEM]
-  \\ last_x_assum $ irule_at Any \\ fs []
-  \\ strip_tac \\ res_tac \\ fs []
+  \\ gvs [AllCaseEqs()]
 QED
 
 Theorem do_app_with_code_err_not_Install:
@@ -131,8 +128,7 @@ Theorem do_app_with_code_err_not_Install:
                          ; compile_oracle := co |>) = Rerr e
 Proof
   rw [Once do_app_cases_err] >> rw [do_app_def] >> fs [SUBSET_DEF] >>
-  fs [do_install_def,case_eq_thms,UNCURRY] >>
-  gvs [EVERY_MEM,EXISTS_MEM]
+  gvs [AllCaseEqs()]
 QED
 
 Theorem do_app_with_code_err:
@@ -145,12 +141,14 @@ Proof
   rveq \\ fs [PULL_EXISTS]
   \\ CCONTR_TAC \\ fs []
   THEN1 gvs [EVERY_MEM,EXISTS_MEM]
-  \\ rename1 `s.compile _ args = _`
-  \\ qpat_x_assum `args = _` (fn th => fs [GSYM th])
-  \\ Cases_on `s.compile (FST (s.compile_oracle 0)) args` \\ fs []
-  \\ PairCases_on `x` \\ fs []
-  \\ Cases_on `v6` \\ fs []
-  \\ rveq \\ fs [] \\ rfs []
+  \\ TRY (
+    rename1 `s.compile _ args = _`
+    \\ qpat_x_assum `args = _` (fn th => fs [GSYM th])
+    \\ Cases_on `s.compile (FST (s.compile_oracle 0)) args` \\ fs []
+    \\ PairCases_on `x` \\ fs []
+    \\ Cases_on `v6` \\ fs []
+    \\ rveq \\ fs [] \\ rfs [])
+  \\ gvs [AllCaseEqs()]
 QED
 
 Theorem initial_state_simp[simp]:
@@ -337,22 +335,32 @@ Proof
      (qexists_tac `n+n'` \\ fs [shift_seq_def]
       \\ rewrite_tac [GENLIST_APPEND,FOLDL_APPEND,MAP_APPEND])
     \\ metis_tac [])
-  THEN1
-   (reverse (fs [case_eq_thms] \\ rw [] \\ fs [])
-    THEN1 metis_tac [] THEN1 metis_tac []
-    \\ reverse (Cases_on `op = Install`)
-    THEN1 (imp_res_tac do_app_const \\ qexists_tac `n` \\ fs [])
-    \\ fs [do_app_def,do_install_def,case_eq_thms,UNCURRY] \\ rveq \\ fs []
-    \\ qexists_tac `SUC n`
-    \\ fs [shift_seq_def,FUN_EQ_THM,ADD1]
-    \\ once_rewrite_tac [ADD_COMM]
-    \\ rewrite_tac [GENLIST_APPEND,MAP_APPEND,EVAL ``GENLIST f 1``]
-    \\ fs [FOLDL_APPEND] \\ rfs [])
+  THEN1 (
+    fs [case_eq_thms] \\ reverse $ rw [] \\ gvs [dec_clock_def]
+    >- (metis_tac [])
+    >- (metis_tac [])
+    \\ Cases_on `op` \\ gvs [do_app_def, AllCaseEqs()]
+    >~ [`do_install`] >-
+     (gvs [do_install_def, AllCaseEqs()]
+      \\ pairarg_tac \\ gvs [AllCaseEqs(), shift_seq_def]
+      \\ qmatch_goalsub_rename_tac `nn + _`
+      \\ qexists `nn + 1` \\ gvs []
+      \\ once_rewrite_tac [ADD_COMM]
+      \\ gvs [GENLIST_APPEND]
+      \\ simp [GSYM SNOC_APPEND, FOLDL_SNOC])
+    \\ rpt (pairarg_tac \\ gvs [])
+    \\ metis_tac [])
   THEN1
    (fs [case_eq_thms] \\ rw [] \\ fs []
     THEN1 (qexists_tac `0` \\ fs [shift_seq_def,FUN_EQ_THM])
     \\ pop_assum (assume_tac o GSYM) \\ fs []
     \\ qexists_tac `n` \\ fs [dec_clock_def])
+  THEN1
+   (rw [] \\ gvs [AllCaseEqs(), NOT_LESS]
+    >~ [‘dest_thunk _ _ = IsThunk NotEvaluated _’, ‘find_code _ _ _ = SOME _’,
+        ‘s.clock ≠ 0’]
+    >- (qexists ‘n'’ \\ gvs [shift_seq_def, dec_clock_def])
+    \\ qexists ‘0’ \\ gvs [shift_seq_def, FUN_EQ_THM])
   \\ fs [case_eq_thms] \\ rw [] \\ fs []
   \\ TRY (qexists_tac `n` \\ fs [] \\ NO_TAC)
   \\ pop_assum (assume_tac o GSYM) \\ fs []
@@ -394,7 +402,7 @@ Theorem evaluate_MAP_Const:
       evaluate (MAP (K (Op (IntOp (Const i)) [])) (exps:'a list),env,t1) =
         (Rval (MAP (K (Number i)) exps),t1)
 Proof
-  Induct \\ full_simp_tac(srw_ss())[evaluate_def,evaluate_CONS,do_app_def,do_int_app_def]
+  Induct \\ full_simp_tac(srw_ss())[evaluate_def,Once evaluate_CONS,do_app_def,do_int_app_def]
 QED
 
 Theorem evaluate_Bool[simp]:
@@ -403,7 +411,7 @@ Proof
   EVAL_TAC
 QED
 
-fun split_tac q = Cases_on q \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) []
+fun split_tac q = Cases_on q \\ Cases_on `q` \\ FULL_SIMP_TAC (srw_ss()) [];
 
 Theorem evaluate_expand_env:
    !xs a s env.
@@ -421,6 +429,10 @@ Proof
   THEN1 (split_tac `evaluate ([x1],env,s1)` \\ BasicProvers.CASE_TAC >> simp[])
   THEN1 (split_tac `evaluate (xs,env,s)`)
   THEN1 (SRW_TAC [] [])
+  THEN1
+   (rw [] \\ every_case_tac \\ gvs [oneline dest_thunk_def,AllCaseEqs()]
+    \\ Cases_on `n < LENGTH env`
+    \\ gvs [rich_listTheory.EL_APPEND1])
   THEN1 (split_tac `evaluate (xs,env,s1)`)
 QED
 
@@ -493,7 +505,7 @@ Theorem do_app_change_clock:
    (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck))
 Proof
   rw [do_app_cases_val,UNCURRY,do_install_def]
-  \\ every_case_tac \\ fs []
+  \\ every_case_tac \\ fs [state_component_equality]
 QED
 
 Theorem do_app_change_clock_err:
@@ -534,33 +546,23 @@ Proof
   >- (Cases_on `evaluate ([x1],env,s1)` >> full_simp_tac(srw_ss())[] >>
       Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >>
       Cases_on`e`>>full_simp_tac(srw_ss())[]>>srw_tac[][]>>full_simp_tac(srw_ss())[])
-  >- (Cases_on `evaluate (xs,env,s)` >> full_simp_tac(srw_ss())[] >>
-      Cases_on `q` >> full_simp_tac(srw_ss())[] >> srw_tac[][] >> full_simp_tac(srw_ss())[] >>
-      srw_tac[][inc_clock_def] >>
-      BasicProvers.EVERY_CASE_TAC >>
-      gvs [] >>
-      imp_res_tac do_app_const >>
-      imp_res_tac do_app_change_clock >>
-      imp_res_tac do_app_change_clock_err >>
-      fs [])
+  >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >>
+      imp_res_tac do_app_const >> gvs [] >>
+      imp_res_tac do_app_change_clock >> gvs [] >>
+      imp_res_tac do_app_change_clock_err >> gvs [])
   >- (srw_tac[][] >>
       full_simp_tac(srw_ss())[inc_clock_def, dec_clock_def] >>
       srw_tac[][] >>
       `s.clock + ck - 1 = s.clock - 1 + ck` by (srw_tac [ARITH_ss] [ADD1]) >>
       metis_tac [])
-  >- (Cases_on `evaluate (xs,env,s1)` >>
-      full_simp_tac(srw_ss())[] >>
-      Cases_on `q` >>
-      full_simp_tac(srw_ss())[] >>
-      srw_tac[][] >>
-      BasicProvers.EVERY_CASE_TAC >>
-      full_simp_tac(srw_ss())[] >>
-      srw_tac[][] >>
-      rev_full_simp_tac(srw_ss())[inc_clock_def, dec_clock_def] >>
-      srw_tac[][]
-      >- decide_tac >>
-      `r.clock + ck - (ticks + 1) = r.clock - (ticks + 1) + ck` by srw_tac [ARITH_ss] [ADD1] >>
-      metis_tac [])
+  >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >>
+      imp_res_tac do_app_const >> gvs [] >>
+      imp_res_tac do_app_change_clock >> gvs [] >>
+      imp_res_tac do_app_change_clock_err >> gvs [])
+  >- (gvs [AllCaseEqs(), inc_clock_def, dec_clock_def] >>
+      imp_res_tac do_app_const >> gvs [] >>
+      imp_res_tac do_app_change_clock >> gvs [] >>
+      imp_res_tac do_app_change_clock_err >> gvs [])
 QED
 
 Theorem evaluate_add_clock_initial_state:
@@ -593,7 +595,7 @@ Theorem evaluate_io_events_mono:
 Proof
   recInduct evaluate_ind >>
   srw_tac[][evaluate_def] >>
-  every_case_tac >> full_simp_tac(srw_ss())[] >>
+  gvs [AllCaseEqs()] >>
   srw_tac[][] >> rev_full_simp_tac(srw_ss())[] >>
   metis_tac[IS_PREFIX_TRANS,do_app_io_events_mono]
 QED
@@ -762,6 +764,7 @@ Proof
   \\ IMP_RES_TAC SUBSET_TRANS
   \\ full_simp_tac(srw_ss())[dec_clock_def] \\ full_simp_tac(srw_ss())[]
   \\ IMP_RES_TAC do_app_refs_SUBSET \\ full_simp_tac(srw_ss())[SUBSET_DEF]
+  \\ rw [] \\ rpt (CASE_TAC \\ rw [])
 QED
 
 Theorem evaluate_refs_SUBSET:
@@ -813,6 +816,7 @@ Definition bVarBound_def[simp]:
   (bVarBound n [Raise x1] <=> bVarBound n [x1]) /\
   (bVarBound n [Tick x1] <=>  bVarBound n [x1]) /\
   (bVarBound n [Op op xs] <=> bVarBound n xs) /\
+  (bVarBound n [Force loc v] <=> v < n) /\
   (bVarBound n [Handle x1 x2] <=>
      bVarBound n [x1] /\ bVarBound (n + 1) [x2]) /\
   (bVarBound n [Call ticks dest xs] <=> bVarBound n xs)
@@ -833,6 +837,7 @@ Definition bEvery_def[simp]:
      bEvery P xs /\ bEvery P [x2]) /\
   (bEvery P [Raise x1] <=> P (Raise x1) /\ bEvery P [x1]) /\
   (bEvery P [Tick x1] <=> P (Tick x1) /\ bEvery P [x1]) /\
+  (bEvery P [Force m n] <=> P (Force m n)) /\
   (bEvery P [Op op xs] <=> P (Op op xs) /\ bEvery P xs) /\
   (bEvery P [Handle x1 x2] <=> P (Handle x1 x2) /\
      bEvery P [x1] /\ bEvery P [x2]) /\
@@ -864,6 +869,7 @@ Definition get_code_labels_def:
   (get_code_labels (Raise e) = get_code_labels e) ∧
   (get_code_labels (Handle e1 e2) = get_code_labels e1 ∪ get_code_labels e2) ∧
   (get_code_labels (Tick e) = get_code_labels e) ∧
+  (get_code_labels (Force loc v) = {loc}) ∧
   (get_code_labels (Call _ d es) = (case d of NONE => {} | SOME n => {n}) ∪ BIGUNION (set (MAP get_code_labels es))) ∧
   (get_code_labels (Op op es) = closLang$assign_get_code_label op ∪ BIGUNION (set (MAP get_code_labels es)))
 Termination
diff --git a/compiler/backend/semantics/bvlSemScript.sml b/compiler/backend/semantics/bvlSemScript.sml
index 3e9a0e19e0..765873b4b7 100644
--- a/compiler/backend/semantics/bvlSemScript.sml
+++ b/compiler/backend/semantics/bvlSemScript.sml
@@ -20,6 +20,7 @@ Datatype:
                   F = compare-by-pointer, mutable *)
                (* in closLang all are ByteArray F,
                   ByteArray T introduced in BVL to implement ByteVector *)
+      | Thunk thunk_mode 'a
 End
 
 (* these parts are shared by bytecode and, if bytecode is to be supported, need
@@ -457,6 +458,17 @@ Definition do_app_def:
            | _ => Error)
          | _ => Error)
     | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s))
+    | (ThunkOp th_op, vs) =>
+        (case (th_op,vs) of
+         | (AllocThunk m, [v]) =>
+             (let ptr = (LEAST ptr. ~(ptr IN FDOM s.refs)) in
+                Rval (RefPtr F ptr, s with refs := s.refs |+ (ptr,Thunk m v)))
+         | (UpdateThunk m, [RefPtr _ ptr; v]) =>
+             (case FLOOKUP s.refs ptr of
+              | SOME (Thunk NotEvaluated _) =>
+                 Rval (Unit, s with refs := s.refs |+ (ptr,Thunk m v))
+              | _ => Error)
+         | _ => Error)
     | _ => Error
 End
 
@@ -484,6 +496,25 @@ Definition find_code_def:
        | other => NONE)
 End
 
+(* Functions for working with thunks *)
+
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk (RefPtr _ ptr) refs =
+    (case FLOOKUP refs ptr of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk _ refs = NotThunk
+End
+
 (* The evaluation is defined as a clocked functional version of
    a conventional big-step operational semantics. *)
 
@@ -537,13 +568,30 @@ Definition evaluate_def:
      | (Rerr(Rraise v),s) => evaluate ([x2],v::env,s)
      | res => res) /\
   (evaluate ([Op op xs],env,s) =
-     case evaluate (xs,env,s) of
-     | (Rval vs,s) => (case do_app op (REVERSE vs) s of
-                          | Rerr err => (Rerr err,s)
-                          | Rval (v,s) => (Rval [v],s))
+     case fix_clock s (evaluate (xs,env,s)) of
+     | (Rval vs,s) =>
+         (case do_app op (REVERSE vs) s of
+          | Rerr err => (Rerr err,s)
+          | Rval (v,s) => (Rval [v],s))
      | res => res) /\
   (evaluate ([Tick x],env,s) =
-     if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s) else evaluate ([x],env,dec_clock 1 s)) /\
+     if s.clock = 0 then (Rerr(Rabort Rtimeout_error),s)
+     else evaluate ([x],env,dec_clock 1 s)) /\
+  (evaluate ([Force force_loc n],env,s) =
+     if ~(n < LENGTH env) then (Rerr(Rabort Rtype_error),s) else
+       let thunk_v = EL n env in
+         case dest_thunk thunk_v s.refs of
+         | BadRef => (Rerr (Rabort Rtype_error),s)
+         | NotThunk => (Rerr (Rabort Rtype_error),s)
+         | IsThunk Evaluated v => (Rval [v],s)
+         | IsThunk NotEvaluated f =>
+             (case find_code (SOME force_loc) [thunk_v; f] s.code of
+              | NONE => (Rerr(Rabort Rtype_error),s)
+              | SOME (args,exp) =>
+                  if s.clock = 0 then
+                    (Rerr(Rabort Rtimeout_error),s with clock := 0)
+                  else
+                    evaluate ([exp],args,dec_clock 1 s))) /\
   (evaluate ([Call ticks dest xs],env,s1) =
      case fix_clock s1 (evaluate (xs,env,s1)) of
      | (Rval vs,s) =>
diff --git a/compiler/backend/semantics/closPropsScript.sml b/compiler/backend/semantics/closPropsScript.sml
index cb6db81008..008c60d4e5 100644
--- a/compiler/backend/semantics/closPropsScript.sml
+++ b/compiler/backend/semantics/closPropsScript.sml
@@ -68,11 +68,11 @@ QED
 
 Theorem evaluate_better_ind:
   (∀xs s1.
-    (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  exp3_size ys < exp3_size xs) ⇒ P1 ys s2) ⇒
-    (∀args s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  LENGTH args < exp3_size xs) ⇒ P2 args s2) ⇒
+    (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  exp3_alt_size ys < exp3_alt_size xs) ⇒ P1 ys s2) ⇒
+    (∀args s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  LENGTH args < exp3_alt_size xs) ⇒ P2 args s2) ⇒
     P1 xs s1) ∧
   (∀args s1.
-    (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  exp3_size ys < LENGTH args) ⇒ P1 ys s2) ⇒
+    (∀ys s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  exp3_alt_size ys < LENGTH args) ⇒ P1 ys s2) ⇒
     (∀args' s2. s2.clock ≤ s1.clock ∧ (s2.clock = s1.clock ⇒  LENGTH args' < LENGTH args) ⇒ P2 args' s2) ⇒
     P2 args s1) ⇒
   (∀(xs:closLang$exp list) (s1:('c,'ffi) closSem$state). P1 xs s1) ∧
@@ -88,7 +88,7 @@ Proof
   \\ strip_tac
   \\ pop_assum mp_tac
   \\ qid_spec_tac ‘s1’
-  \\ completeInduct_on ‘case x of INL xs => exp3_size xs | INR args => LENGTH args’
+  \\ completeInduct_on ‘case x of INL xs => exp3_alt_size xs | INR args => LENGTH args’
   \\ rw []
   \\ gvs [forall_sum,SF DNF_ss, AND_IMP_INTRO, GSYM CONJ_ASSOC]
   \\ Cases_on ‘x’ \\ simp []
@@ -102,12 +102,14 @@ QED
 Definition ref_rel_def[simp]:
   (ref_rel R (ValueArray vs) (ValueArray ws) ⇔ LIST_REL R vs ws) ∧
   (ref_rel R (ByteArray as) (ByteArray bs) ⇔ as = bs) ∧
+  (ref_rel R (Thunk ma a) (Thunk mb b) ⇔ ma = mb ∧ R a b) ∧
   (ref_rel _ _ _ = F)
 End
 
 Theorem ref_rel_simp[simp]:
    (ref_rel R (ValueArray vs) y ⇔ ∃ws. y = ValueArray ws ∧ LIST_REL R vs ws) ∧
-   (ref_rel R (ByteArray bs) y ⇔ y = ByteArray bs)
+   (ref_rel R (ByteArray bs) y ⇔ y = ByteArray bs) ∧
+   (ref_rel R (Thunk m a) y ⇔ ∃b. y = Thunk m b ∧ R a b)
 Proof
   Cases_on`y`>>simp[ref_rel_def] >> srw_tac[][EQ_IMP_THM]
 QED
@@ -205,6 +207,9 @@ Definition contains_App_SOME_def:
      contains_App_SOME max_app [x1]) /\
   (contains_App_SOME max_app [Tick _ x1] ⇔
      contains_App_SOME max_app [x1]) /\
+  (contains_App_SOME max_app [Op _ (ThunkOp ForceThunk) xs] ⇔
+     max_app < 1 ∨
+     contains_App_SOME max_app xs) /\
   (contains_App_SOME max_app [Op _ op xs] ⇔
      contains_App_SOME max_app xs) /\
   (contains_App_SOME max_app [App _ loc_opt x1 x2] ⇔
@@ -949,6 +954,7 @@ Theorem EVERY_pure_correct = Q.prove(`
   >- (full_simp_tac (srw_ss() ++ ETA_ss) [] >> every_case_tac >> full_simp_tac(srw_ss())[])
   >- (full_simp_tac(srw_ss())[] >> every_case_tac >> full_simp_tac(srw_ss())[])
   >- (Cases_on`op=Install` >- fs[pure_op_def] >>
+      Cases_on `op = ThunkOp ForceThunk` >- fs[pure_op_def] >>
       fsrw_tac[ETA_ss][]
       \\ PURE_CASE_TAC \\ fs[]
       \\ PURE_CASE_TAC \\ fs[]
@@ -1195,6 +1201,24 @@ Proof
   imp_res_tac dest_closure_full_length >> lfs[]
 QED
 
+Theorem evaluate_app_clock0_timeout:
+   s0.clock = 0 ∧ args ≠ [] ∧
+   evaluate_app lopt r args s0 = (Rerr e, s) ∧
+   e ≠ Rabort Rtype_error ⇒
+     e = Rabort Rtimeout_error
+Proof
+  strip_tac >> `∃a1 args0. args = a1::args0` by (Cases_on `args` >> full_simp_tac(srw_ss())[]) >>
+  qpat_x_assum `evaluate_app _ _ _ _ = _` mp_tac >>
+  simp[evaluate_def] >>
+  Cases_on `dest_closure s0.max_app lopt r (a1::args0)` >> simp[] >>
+  rename1 `dest_closure s0.max_app lopt r (a1::args0) = SOME c` >>
+  Cases_on `c` >> simp[] >>
+  rename1 `dest_closure max_app lopt r (a1::args0) = SOME (Full_app b env rest)` >>
+  srw_tac[][] >>
+  `SUC (LENGTH args0) ≤ LENGTH rest` by simp[] >>
+  imp_res_tac dest_closure_full_length >> lfs[]
+QED
+
 Theorem evaluate_app_clock_drop:
    ∀args f lopt s0 s vs.
      evaluate_app lopt f args s0 = (Rval vs, s) ⇒
@@ -1557,9 +1581,10 @@ Proof
   full_simp_tac(srw_ss())[LET_THM,
      semanticPrimitivesTheory.store_alloc_def,
      semanticPrimitivesTheory.store_lookup_def,
-     semanticPrimitivesTheory.store_assign_def,ffiTheory.call_FFI_def] >>
-  srw_tac[][] >>
-  fs [case_eq_thms] \\ rveq \\ fs []
+     semanticPrimitivesTheory.store_assign_def,ffiTheory.call_FFI_def]
+  >>~- ([`ThunkOp _`], gvs [AllCaseEqs()])
+  \\ srw_tac[][]
+  \\ fs [case_eq_thms] \\ rveq \\ fs []
   \\ rpt (pop_assum (mp_tac o GSYM))
   \\ fs [case_eq_thms] \\ rveq \\ fs []
   \\ rw [] \\ rpt (pop_assum (mp_tac o GSYM)) \\ rw []
@@ -1729,6 +1754,7 @@ val tac =
   rveq >>
   fsrw_tac[ARITH_ss][AC ADD_ASSOC ADD_COMM] >>
   rveq >> fs[] >>
+  gvs[AppUnit_def] >>
   metis_tac[evaluate_io_events_mono,with_clock_ffi,FST,SND,IS_PREFIX_TRANS,lemma,Boolv_11,lemma2,lemma3]
 
 Theorem evaluate_add_to_clock_io_events_mono:
@@ -1773,9 +1799,12 @@ Theorem evaluate_timeout_clocks0:
 Proof
   ho_match_mp_tac evaluate_ind >> rpt conj_tac >>
   dsimp[evaluate_def, case_eq_thms, pair_case_eq, bool_case_eq] >>
-  rw[] >> pop_assum mp_tac >>
-  simp_tac (srw_ss()) [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq,UNCURRY,LET_THM] >>
-  rw[] >> fs []
+  rw[] >> pop_assum mp_tac
+  >~ [`do_install`] >- (
+    simp_tac (srw_ss()) [do_install_def,case_eq_thms,bool_case_eq,pair_case_eq,UNCURRY,LET_THM] >>
+    rw[] >> fs [])
+  >~ [`dest_thunk`] >- (
+    gvs [oneline dest_thunk_def, AllCaseEqs()] \\ rw [] \\ gvs [])
 QED
 
 val _ = export_rewrites ["closLang.exp_size_def"]
@@ -1893,6 +1922,9 @@ Definition esgc_free_def:
   (esgc_free (Letrec _ _ _ binds bod) ⇔
     elist_globals (MAP SND binds) = {||} ∧ esgc_free bod) ∧
   (esgc_free (Op _ _ args) ⇔ EVERY esgc_free args)
+Termination
+  WF_REL_TAC `measure exp_size` >> simp[] >> rpt strip_tac >>
+   imp_res_tac exp_size_MEM >> simp[]
 End
 
 Theorem esgc_free_def[simp,compute,allow_rebind] =
@@ -1903,6 +1935,7 @@ Definition ssgc_free_def:
   ssgc_free ^s ⇔
     (∀n m e. FLOOKUP s.code n = SOME (m,e) ⇒ set_globals e = {||}) ∧
     (∀n vl. FLOOKUP s.refs n = SOME (ValueArray vl) ⇒ EVERY vsgc_free vl) ∧
+    (∀n m v. FLOOKUP s.refs n = SOME (Thunk m v) ⇒ vsgc_free v) ∧
     (∀v. MEM (SOME v) s.globals ⇒ vsgc_free v) ∧
     (∀n exp aux. SND (s.compile_oracle n) = (exp, aux) ⇒ EVERY esgc_free exp ∧
          elist_globals (MAP (SND o SND) aux) = {||})
@@ -2019,6 +2052,11 @@ Definition simple_state_rel_def:
       ∃w1.
         FLOOKUP s.refs ptr = SOME (ValueArray w1) ∧
         LIST_REL vr w1 w) /\
+    (∀m v t s ptr.
+      FLOOKUP t.refs ptr = SOME (Thunk m v) ∧ sr s t ⇒
+      ∃w.
+        FLOOKUP s.refs ptr = SOME (Thunk m w) ∧
+        vr w v) /\
     (!s t. sr s t ==> s.ffi = t.ffi /\ FDOM s.refs = FDOM t.refs /\
                       LIST_REL (OPTREL vr) s.globals t.globals) /\
     (!f s t.
@@ -2031,6 +2069,10 @@ Definition simple_state_rel_def:
       sr s t /\ LIST_REL vr xs ys ==>
       sr (s with refs := s.refs |+ (p,ValueArray xs))
          (t with refs := t.refs |+ (p,ValueArray ys))) /\
+    (!s t p m v w.
+      sr s t /\ vr v w ==>
+      sr (s with refs := s.refs |+ (p,Thunk m v))
+         (t with refs := t.refs |+ (p,Thunk m w))) /\
     (!s t xs ys.
       sr s t /\ LIST_REL (OPTREL vr) xs ys ==>
       sr (s with globals := xs) (t with globals := ys))
@@ -2059,12 +2101,18 @@ val simple_state_rel_update_bytes = prove(
        (t with refs := t.refs |+ (p,ByteArray bs))``,
   fs [simple_state_rel_def]);
 
-val simple_state_rel_update = prove(
+val simple_state_rel_update_values = prove(
   ``simple_state_rel vr sr /\ sr s t /\ LIST_REL vr xs ys ==>
     sr (s with refs := s.refs |+ (p,ValueArray xs))
        (t with refs := t.refs |+ (p,ValueArray ys))``,
   fs [simple_state_rel_def]);
 
+val simple_state_rel_update_thunks = prove(
+  ``simple_state_rel vr sr /\ sr s t /\ vr v w ==>
+    sr (s with refs := s.refs |+ (p,Thunk m v))
+       (t with refs := t.refs |+ (p,Thunk m w))``,
+  fs [simple_state_rel_def]);
+
 val simple_state_rel_update_globals = prove(
   ``simple_state_rel vr sr /\ sr s t /\ LIST_REL (OPTREL vr) xs ys ==>
     sr (s with globals := xs) (t with globals := ys)``,
@@ -2195,6 +2243,8 @@ Theorem simple_state_rel_FLOOKUP_refs_IMP:
     | SOME (ByteArray bs) => FLOOKUP s.refs p = SOME (ByteArray bs)
     | SOME (ValueArray vs) =>
         ?xs. FLOOKUP s.refs p = SOME (ValueArray xs) /\ LIST_REL vr xs vs
+    | SOME (Thunk m w) =>
+        ?v. FLOOKUP s.refs p = SOME (Thunk m v) /\ vr v w
 Proof
   fs [simple_state_rel_def] \\ Cases_on `x` \\ rw []
   \\ res_tac \\ fs [] \\ rename1 `_ = SOME yy` \\ Cases_on `yy` \\ fs []
@@ -2363,6 +2413,19 @@ Proof
     \\ rw [Once $oneline  do_int_app_def, AllCaseEqs(), PULL_EXISTS]
     \\ fs[] \\ rveq \\ simp[oneline do_int_app_def]
     \\ res_tac >> fs[isClos_cases])
+  \\ Cases_on `?i. opp = ThunkOp i`
+  THEN1
+   (Cases_on `do_app opp ys t` \\ fs[] \\ rveq \\ pop_assum mp_tac
+    \\ rw [do_app_def, case_eq_thms, pair_case_eq, bool_case_eq, PULL_EXISTS]
+    \\ gvs [AllCaseEqs(), PULL_EXISTS]
+    \\ gvs [simple_val_rel_def, Unit_def, AllCaseEqs(), PULL_EXISTS]
+    \\ rveq \\ fs []
+    \\ `FDOM s.refs = FDOM t.refs` by fs [simple_state_rel_def] \\ fs []
+    \\ drule (GEN_ALL simple_state_rel_FLOOKUP_refs_IMP)
+    \\ disch_then drule \\ disch_then imp_res_tac \\ fs []
+    \\ TRY (res_tac \\ fs [isClos_cases] \\ NO_TAC)
+    \\ match_mp_tac (GEN_ALL simple_state_rel_update_thunks)
+    \\ asm_exists_tac \\ fs [])
   \\ Cases_on `?w. opp = WordOp w`
   THEN1
    (Cases_on `do_app opp ys t` \\ fs[] \\ rveq \\ pop_assum mp_tac
@@ -2494,7 +2557,7 @@ Proof
     >~[`w2n`]
     >- (IF_CASES_TAC >> gvs[])
     \\ `FDOM s.refs = FDOM t.refs` by fs [simple_state_rel_def] \\ fs []
-    \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update))
+    \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_values))
     \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_bytes))
     \\ asm_exists_tac \\ fs [LIST_REL_REPLICATE_same])
   \\ Cases_on `?m. opp = MemOp m ∧ (m = UpdateByte \/ m = Update) \/ ?n. opp = FFI n` THEN1
@@ -2513,7 +2576,7 @@ Proof
     \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_ffi))
     \\ TRY (asm_exists_tac \\ fs [])
     \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_bytes))
-    \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update))
+    \\ TRY (match_mp_tac (GEN_ALL simple_state_rel_update_values))
     \\ asm_exists_tac \\ fs []
     \\ match_mp_tac EVERY2_LUPDATE_same \\ fs [])
   \\ Cases_on `?b. opp = MemOp (CopyByte b)` THEN1
@@ -3123,7 +3186,9 @@ Proof
     \\ imp_res_tac do_app_adj_orac_Rval
     \\ imp_res_tac do_app_adj_orac_Rerr
     \\ fs [adj_orac_rel_def] \\ fsrw_tac [SATISFY_ss] []
-  )
+    \\ gvs [AllCaseEqs(), AppUnit_def, dec_clock_def]
+    \\ rveq \\ fs[]
+    \\ fs [adj_orac_rel_def] \\ fsrw_tac [SATISFY_ss] [])
   \\ TRY (
        fs[closSemTheory.evaluate_def,
           bool_case_eq,
@@ -3303,6 +3368,18 @@ Proof
   \\ pop_assum (assume_tac o SPEC_ALL) \\ rfs []
 QED
 
+Triviality SUBMAP_refs_clocks_eqs:
+  SUBMAP_rel s1 s2 ⇒ s1.refs = s2.refs ∧ s1.clock = s2.clock
+Proof
+  rw [SUBMAP_rel_def, state_component_equality]
+QED
+
+Triviality SUBMAP_dec_clock:
+  SUBMAP_rel s1 s2 ⇒ SUBMAP_rel (dec_clock 1 s1) (dec_clock 1 s2)
+Proof
+  rw [SUBMAP_rel_def, dec_clock_def, state_component_equality]
+QED
+
 Theorem evaluate_code_SUBMAP:
    (∀p x y (z1:('c, 'ffi)closSem$state) r s1 s2 (z2:('c,'ffi)closSem$state).
     p = (x,y,z1) ∧
@@ -3392,6 +3469,16 @@ Proof
     \\ fs[PULL_EXISTS]
     \\ res_tac \\ fs[]
     \\ NO_TAC )
+  \\ Cases_on`op = ThunkOp ForceThunk`
+  \\ fs[CaseEq"prod",CaseEq"semanticPrimitives$result",PULL_EXISTS]
+  \\ rveq \\ fs[]
+  >- (
+    gvs [oneline dest_thunk_def, AllCaseEqs(), PULL_EXISTS]
+    \\ imp_res_tac SUBMAP_refs_clocks_eqs \\ gvs [PULL_EXISTS]
+    \\ imp_res_tac SUBMAP_dec_clock \\ gvs []
+    \\ last_x_assum drule \\ rw []
+    \\ goal_assum drule \\ rw []
+    \\ gvs [SUBMAP_rel_def, state_component_equality])
   \\ imp_res_tac do_app_SUBMAP_Rval
   \\ fs[]
   \\ imp_res_tac do_app_SUBMAP_Rerr
diff --git a/compiler/backend/semantics/closSemScript.sml b/compiler/backend/semantics/closSemScript.sml
index ed642b813b..7497f1d497 100644
--- a/compiler/backend/semantics/closSemScript.sml
+++ b/compiler/backend/semantics/closSemScript.sml
@@ -13,6 +13,7 @@ Libs
 Datatype:
   ref = ValueArray ('a list)
       | ByteArray (word8 list)
+      | Thunk thunk_mode 'a
 End
 
 (* --- Semantics of ClosLang --- *)
@@ -434,6 +435,17 @@ Definition do_app_def:
              Rval (Boolv (0 <= i /\ i < & LENGTH ws),s)
          | _ => Error)
     | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s))
+    | (ThunkOp th_op, vs) =>
+        (case (th_op,vs) of
+         | (AllocThunk m, [v]) =>
+             (let ptr = (LEAST ptr. ~(ptr IN FDOM s.refs)) in
+                Rval (RefPtr F ptr, s with refs := s.refs |+ (ptr,Thunk m v)))
+         | (UpdateThunk m, [RefPtr _ ptr; v]) =>
+             (case FLOOKUP s.refs ptr of
+              | SOME (Thunk NotEvaluated _) =>
+                 Rval (Unit, s with refs := s.refs |+ (ptr,Thunk m v))
+              | _ => Error)
+         | _ => Error)
     | _ => Error
 End
 
@@ -564,7 +576,8 @@ Theorem case_eq_thms = LIST_CONJ (
   closLangTheory.word_op_case_eq ::
   closLangTheory.block_op_case_eq ::
   closLangTheory.glob_op_case_eq ::
-  closLangTheory.mem_op_case_eq :: map CaseEq
+  closLangTheory.mem_op_case_eq ::
+  astTheory.thunk_op_case_eq :: map CaseEq
   ["list","option","v","ref",
    "result","error_result","eq_result","app_kind","word_size"]);
 
@@ -582,6 +595,81 @@ Proof
   \\ pairarg_tac \\ gvs[case_eq_thms,pair_case_eq,bool_case_eq]
 QED
 
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk [RefPtr _ ptr] refs =
+    (case FLOOKUP refs ptr of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk vs refs = NotThunk
+End
+
+Definition store_thunk_def:
+  store_thunk ptr v refs =
+    case FLOOKUP refs ptr of
+    | SOME (Thunk NotEvaluated _) => SOME (refs |+ (ptr,v))
+    | _ => NONE
+End
+
+Definition update_thunk_def:
+  update_thunk [RefPtr _ ptr] refs [v] =
+    (case dest_thunk [v] refs of
+     | NotThunk => store_thunk ptr (Thunk Evaluated v) refs
+     | _ => NONE) ∧
+  update_thunk _ _ _ = NONE
+End
+
+Definition AppUnit_def:
+  AppUnit x = closLang$App None NONE x [Op None (BlockOp (Cons 0)) []]
+End
+
+Definition exp_alt_size_def[simp]:
+  exp_alt_size (Var a0 a1) = 1 + (tra_size a0 + a1) ∧
+  exp_alt_size (If a0 a1 a2 a3) =
+  1 + (tra_size a0 + (exp_alt_size a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧
+  exp_alt_size (Let a0 a1 a2) =
+  1 + (tra_size a0 + (exp3_alt_size a1 + exp_alt_size a2)) ∧
+  exp_alt_size (Raise a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧
+  exp_alt_size (Handle a0 a1 a2) =
+  1 + (tra_size a0 + (exp_alt_size a1 + exp_alt_size a2)) ∧
+  exp_alt_size (Tick a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧
+  exp_alt_size (Call a0 a1 a2 a3) =
+  1 + (tra_size a0 + (a1 + (a2 + exp3_alt_size a3))) ∧
+  exp_alt_size (App a0 a1 a2 a3) =
+  1 +
+  (tra_size a0 + (option_size (λx. x) a1 + (exp_alt_size a2 + exp3_alt_size a3))) ∧
+  exp_alt_size (Fn a0 a1 a2 a3 a4) =
+  1 +
+  (mlstring_size a0 +
+   (option_size (λx. x) a1 +
+    (option_size (list_size (λx. x)) a2 + (a3 + exp_alt_size a4)))) ∧
+  exp_alt_size (Letrec a0 a1 a2 a3 a4) =
+  1 +
+  (list_size mlstring_size a0 +
+   (option_size (λx. x) a1 +
+    (option_size (list_size (λx. x)) a2 + (exp1_alt_size a3 + exp_alt_size a4)))) ∧
+  exp_alt_size (Op a0 a1 a2) = 1 + (tra_size a0 + (op_size a1 + exp3_alt_size a2))
+    + (if a1 = ThunkOp ForceThunk then 100 else 0) ∧
+  exp1_alt_size [] = 0 ∧
+  exp1_alt_size (a0::a1) = 1 + (exp2_alt_size a0 + exp1_alt_size a1) ∧
+  exp2_alt_size (a0,a1) = 1 + (a0 + exp_alt_size a1) ∧ exp3_alt_size [] = 0 ∧
+  exp3_alt_size (a0::a1) = 1 + (exp_alt_size a0 + exp3_alt_size a1)
+End
+
+Triviality exp3_alt_size[simp]:
+  exp3_alt_size xs = list_size exp_alt_size xs
+Proof
+  Induct_on `xs` \\ simp []
+QED
+
 Definition evaluate_def[nocompute]:
   (evaluate ([],env:closSem$v list,^s) = (Rval [],s)) /\
   (evaluate (x::y::xs,env,s) =
@@ -622,6 +710,18 @@ Definition evaluate_def[nocompute]:
              | (Rval vs,s) => (Rval [LAST vs],s)
              | res => res)
         | (Rerr err,s) => (Rerr err,s))
+       else if op = ThunkOp ForceThunk then
+         (case dest_thunk vs s.refs of
+          | BadRef => (Rerr (Rabort Rtype_error),s)
+          | NotThunk => (Rerr (Rabort Rtype_error),s)
+          | IsThunk Evaluated v => (Rval [v],s)
+          | IsThunk NotEvaluated f =>
+             (case evaluate ([AppUnit (Var None 0)],[f],s) of
+              | (Rval vs2,s) =>
+                 (case update_thunk vs s.refs vs2 of
+                  | NONE => (Rerr (Rabort Rtype_error),s)
+                  | SOME refs => (Rval vs2,s with refs := refs))
+              | (Rerr e,s) => (Rerr e,s)))
        else
        (case do_app op (REVERSE vs) s of
         | Rerr err => (Rerr err,s)
@@ -692,7 +792,7 @@ Definition evaluate_def[nocompute]:
            | res => res)
 Termination
   WF_REL_TAC `(inv_image (measure I LEX measure I LEX measure I)
-                (\x. case x of INL (xs,env,s) => (s.clock,list_size exp_size xs,0)
+                (\x. case x of INL (xs,env,s) => (s.clock,list_size exp_alt_size xs,0)
                              | INR (l,f,args,s) => (s.clock,0,LENGTH args)))`
   \\ rpt strip_tac
   \\ simp[dec_clock_def]
@@ -703,7 +803,8 @@ Termination
   \\ imp_res_tac dest_closure_length
   \\ imp_res_tac LESS_EQ_dec_clock
   \\ FULL_SIMP_TAC (srw_ss()) []
-  \\ decide_tac
+  \\ simp [AppUnit_def]
+  \\ IF_CASES_TAC \\ gvs []
 End
 
 Theorem evaluate_app_NIL[simp] =
diff --git a/compiler/backend/semantics/dataPropsScript.sml b/compiler/backend/semantics/dataPropsScript.sml
index a7a5ff09c0..058ffae967 100644
--- a/compiler/backend/semantics/dataPropsScript.sml
+++ b/compiler/backend/semantics/dataPropsScript.sml
@@ -24,7 +24,9 @@ Definition approx_of_def:
      | NONE => 0
      | SOME (ByteArray _ bs) => LENGTH bs DIV (arch_size lims DIV 8) + 2
      | SOME (ValueArray vs) =>
-         approx_of lims vs (delete r refs) + LENGTH vs + 1) /\
+         approx_of lims vs (delete r refs) + LENGTH vs + 1
+     | SOME (Thunk _ v) =>
+         approx_of lims [v] (delete r refs) + 2) /\
   (approx_of lims [Block ts tag []] refs = 0) /\
   (approx_of lims [Block ts tag vs] refs =
     approx_of lims vs refs + LENGTH vs + 1)
@@ -229,7 +231,8 @@ QED
 fun cases_on_op_fs q = Cases_on q \\ full_simp_tac(srw_ss()) []
   >>> SELECT_LT_THEN (Q.RENAME_TAC [‘BlockOp b_’]) (Cases_on `b_`)
   >>> SELECT_LT_THEN (Q.RENAME_TAC [‘GlobOp g_’]) (Cases_on `g_`)
-  >>> SELECT_LT_THEN (Q.RENAME_TAC [‘MemOp m_’]) (Cases_on `m_`);
+  >>> SELECT_LT_THEN (Q.RENAME_TAC [‘MemOp m_’]) (Cases_on `m_`)
+  >>> SELECT_LT_THEN (Q.RENAME_TAC [‘ThunkOp t_’]) (Cases_on `t_`);
 
 (*fs[] is slower than full_simp_tac(srw_ss())[]*)
 val do_app_with_stack = time Q.prove(
@@ -250,6 +253,7 @@ val do_app_with_stack = time Q.prove(
       semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
       pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def,UNCURRY_EQ]
     \\ rveq \\ full_simp_tac(srw_ss()) []
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`)
   \\ full_simp_tac(srw_ss())[allowed_op_def]
   \\ rw [state_component_equality] \\ simp [Once CONJ_COMM]
   \\ rw [EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def,PULL_EXISTS]);
@@ -275,6 +279,7 @@ val do_app_with_stack_and_locals = time Q.prove(
         semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
         pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def,UNCURRY_EQ]
     \\ rveq \\ full_simp_tac(srw_ss()) [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`)
   \\ full_simp_tac(srw_ss())[allowed_op_def]
   \\ rw [state_component_equality] \\ simp [Once CONJ_COMM]
   \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]);
@@ -294,6 +299,7 @@ Proof
       semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
       pair_case_eq,consume_space_def,check_lim_def]
     \\ rveq \\ full_simp_tac(srw_ss()) [] \\ rw [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_` \\ gvs [])
 QED
 
 (*fs[] is slower than full_simp_tac(srw_ss())[]*)
@@ -311,6 +317,7 @@ Proof
       semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
       pair_case_eq,consume_space_def,check_lim_def,UNCURRY_EQ]
     \\ rveq \\ fs [] \\ rw [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_` \\ gvs [])
 QED
 
 (*fs[] is slower than full_simp_tac(srw_ss())[]*)
@@ -333,6 +340,7 @@ val do_app_with_locals = time Q.prove(
       semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
       pair_case_eq,consume_space_def,check_lim_def,UNCURRY_EQ]
     \\ rveq \\ full_simp_tac(srw_ss()) [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
   \\ full_simp_tac(srw_ss()) [allowed_op_def]
   \\ rw [state_component_equality] \\ simp [Once CONJ_COMM]
   \\ rw[EQ_IMP_THM] \\ fs[stack_consumed_def,allowed_op_def]);
@@ -449,6 +457,7 @@ val do_app_swap_tac =
               , consume_space_def
               , stack_consumed_def
               , size_of_heap_with_safe
+              , MAX_DEF
               , check_lim_def]
   \\ TRY (full_simp_tac(srw_ss())[LET_DEF,UNCURRY_EQ,list_case_eq,option_case_eq,v_case_eq,bool_case_eq,bvlSemTheory.ref_case_eq
         , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq, state_component_equality
@@ -456,7 +465,9 @@ val do_app_swap_tac =
         , limits_component_equality,stack_consumed_def]
           \\ full_simp_tac(srw_ss())  [data_spaceTheory.op_space_req_def,stack_consumed_def]
           \\ rev_full_simp_tac(srw_ss())[data_spaceTheory.op_space_req_def]
-          \\ simp [Once CONJ_COMM] \\ NO_TAC));
+          \\ simp [Once CONJ_COMM] \\ NO_TAC)
+  \\ rpt(PURE_TOP_CASE_TAC \\ fs[] \\ rveq) \\ fs[state_component_equality,stack_consumed_def]
+  \\ gvs [AllCaseEqs()]);
 
 
 Theorem do_app_aux_safe_peak_swap:
@@ -661,11 +672,13 @@ Proof
   >- basic_tac
   >- basic_tac
   (* Assign *)
-  >- (TOP_CASE_TAC \\ fs [evaluate_def]
+  >- (
+     TOP_CASE_TAC \\ fs [evaluate_def]
      \\ full_cases >> full_fs
      \\ fs [] \\ rfs[]
      \\ rveq \\ fs []
      \\ every_case_tac \\ fs [] \\ rveq \\ fs []
+     \\ gvs [AllCaseEqs(), PULL_EXISTS]
      \\ TRY (simp[state_component_equality] \\ NO_TAC)
      \\ TRY (drule do_app_sm_safe_peak_swap
      \\ disch_then (qspecl_then [`smx`, `safe`, `peak`] strip_assume_tac)
@@ -721,7 +734,56 @@ Proof
   >- (fs [evaluate_def]
       \\ every_case_tac
       \\ full_fs >> metis_tac [])
-
+  (* Force *)
+  >- (
+    reverse $ gvs [evaluate_def, flush_state_def, set_var_def, dec_clock_def,
+                   call_env_def, push_env_def, AllCaseEqs()]
+    >- (
+      IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS]
+      \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’
+      >- (
+        first_x_assum
+          $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [AllCaseEqs()] \\ metis_tac [])
+      >- (
+        first_x_assum
+          $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [AllCaseEqs()] \\ metis_tac []))
+    >- (
+      IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS]
+      \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’
+      >- (
+        first_x_assum
+          $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [pop_env_def, AllCaseEqs()])
+      >- (
+        first_x_assum
+            $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [pop_env_def, AllCaseEqs()]))
+    >- (
+      IF_CASES_TAC \\ gvs [AllCaseEqs(), PULL_EXISTS]
+      \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘peak_heap_length_fupd (K phlnew)’
+      >- (
+        first_x_assum
+          $ qspecl_then [‘T’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [pop_env_def, AllCaseEqs()])
+      >- (
+        first_x_assum
+            $ qspecl_then [‘F’, ‘smnew’,‘ssnew’,‘phlnew’] strip_assume_tac
+        \\ simp [set_var_def] \\ rw [state_component_equality]
+        \\ gvs [pop_env_def, AllCaseEqs()]))
+    \\ metis_tac [])
   (* Call *)
   (* to save the outer if to have minimised duplication
      trade-off then is to use explixit cases insteade ofIF_CASES_TAC *)
@@ -977,6 +1039,97 @@ Proof
      \\ Cases_on `get_var n s.locals` \\ fs[]
      \\ Cases_on `isBool T x` \\ fs[get_var_def]
      \\ Cases_on `isBool F x` \\ fs[get_var_def])
+  (* Force *)
+  >- (
+    gvs [evaluate_def]
+    \\ TOP_CASE_TAC \\ gvs [] \\ rw []
+    \\ gvs [AllCaseEqs(), flush_state_def, set_var_def, PULL_EXISTS]
+    >- simp [state_component_equality]
+    >- simp [state_component_equality]
+    >- simp [state_component_equality]
+    >- (
+      rpt (PURE_CASE_TAC \\ gvs [])
+      \\ gvs [call_env_def,flush_state_def,dec_clock_def,jump_exc_def,
+              AllCaseEqs(), PULL_EXISTS]
+      \\ rw []
+      \\ first_x_assum drule \\ strip_tac
+      \\ qmatch_goalsub_abbrev_tac `evaluate
+            (q', s with <|locals:= _; locals_size := _;  stack := _;
+                          stack_max := smnew; clock := _;
+                          safe_for_space := ssnew |>)`
+      \\ gvs[]
+      \\ first_x_assum $ qspec_then ‘ss’ strip_assume_tac \\ gvs []
+      \\ drule evaluate_smx_safe_peak_swap_aux \\ gvs []
+      \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac
+      \\ rw [] \\ gvs []
+      \\ simp [state_component_equality])
+    >- gvs [call_env_def, push_env_def, dec_clock_def, state_component_equality]
+    >- (
+      rw []
+      >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def,
+              AllCaseEqs()]
+      >- gvs [call_env_def, push_env_def, dec_clock_def, pop_env_def,
+              AllCaseEqs()]
+      \\ gvs [call_env_def, push_env_def, dec_clock_def]
+      \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+      \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K new_stack)’
+      \\ first_x_assum $ qspecl_then [‘new_stack’,‘ss’] mp_tac
+      \\ qunabbrev_tac ‘new_stack’
+      \\ simp []
+      \\ strip_tac
+      \\ drule evaluate_smx_safe_peak_swap_aux
+      \\ disch_then $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac
+      \\ simp[]
+      \\ strip_tac \\ gvs []
+      \\ gvs [pop_env_def, AllCaseEqs(), PULL_EXISTS]
+      \\ simp[state_component_equality])
+    >- (
+      rpt (TOP_CASE_TAC \\ gvs [])
+      >- (
+        gvs [push_env_def, call_env_def, dec_clock_def]
+        \\ Ho_Rewrite.PURE_REWRITE_TAC [GSYM PULL_EXISTS, CONJ_ASSOC]
+        \\ simp [GSYM PULL_EXISTS, CONJ_ASSOC]
+        \\ conj_tac
+        >- (
+          qmatch_asmsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+          \\ qmatch_asmsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+          \\ gvs [pop_env_def, AllCaseEqs()]
+          \\ gvs [jump_exc_def, AllCaseEqs()]
+          \\ Cases_on ‘s.handler = LENGTH s.stack’ \\ gvs [LASTN_LEMMA]
+          \\ ‘s.handler < LENGTH s.stack’ by DECIDE_TAC \\ gvs []
+          \\ simp [PULL_EXISTS]
+          \\ gvs [LASTN_CONS])
+        \\ rpt strip_tac
+        \\ qmatch_goalsub_abbrev_tac `evaluate
+            (q', s with <|locals:= _; locals_size := _;  stack := _;
+                          stack_max := smnew; clock := _;
+                          safe_for_space := ssnew |>)`
+        \\ first_x_assum $ qspecl_then [‘Env lsz env::xs’] mp_tac
+        \\ gvs [jump_exc_def, AllCaseEqs()]
+        \\ gvs [LASTN_CONS]
+        \\ disch_then $ qspec_then ‘ss’ strip_assume_tac
+        \\ drule evaluate_smx_safe_peak_swap_aux
+        \\ disch_then
+          $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac
+        \\ simp[]
+        \\ strip_tac \\ gvs []
+        \\ simp [state_component_equality])
+      \\ (
+        rw []
+        \\ gvs [call_env_def, push_env_def, dec_clock_def]
+        \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+        \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+        \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K (el1::_))’
+        \\ last_x_assum $ qspec_then ‘el1::xs’ mp_tac
+        \\ qunabbrev_tac ‘el1’
+        \\ simp [] \\ disch_then $ qspec_then ‘ss’ strip_assume_tac
+        \\ drule evaluate_smx_safe_peak_swap_aux
+        \\ disch_then
+            $ qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’] mp_tac
+        \\ simp []
+        \\ strip_tac \\ fs[]
+        \\ simp[state_component_equality])))
   (* Call *)
   >- (fs[evaluate_def]
      \\ Cases_on `get_vars args s.locals` \\ fs[]
@@ -1504,6 +1657,48 @@ Proof
      \\ IMP_RES_TAC locals_ok_get_var \\ full_simp_tac(srw_ss())[]
      \\ Cases_on `isBool T x` \\ full_simp_tac(srw_ss())[]
      \\ Cases_on `isBool F x` \\ full_simp_tac(srw_ss())[])
+  (* Force *)
+  >- (
+    Cases_on ‘get_var src s.locals’ \\ gvs []
+    \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs []
+    \\ Cases_on ‘t’ \\ gvs []
+    >- (
+      imp_res_tac locals_ok_get_var \\ gvs []
+      \\ Cases_on ‘ret’ \\ gvs []
+      >- gvs [flush_state_def, state_component_equality, locals_ok_def]
+      \\ Cases_on ‘x'’ \\ gvs [set_var_def]
+      \\ Cases_on ‘cut_env r s.locals’ \\ gvs []
+      \\ imp_res_tac locals_ok_cut_env \\ gvs []
+      \\ gvs [state_component_equality, locals_ok_def])
+    \\ imp_res_tac locals_ok_get_var \\ gvs []
+    \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’
+    \\ gvs []
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘r’ \\ gvs []
+    \\ Cases_on ‘ret’ \\ gvs []
+    >- (
+      IF_CASES_TAC \\ gvs []
+      >- (simp [state_component_equality] \\ metis_tac [locals_ok_refl])
+      \\ ‘call_env q r' (dec_clock (s with locals := l)) =
+          call_env q r' (dec_clock s)’
+         by fs[state_component_equality, dec_clock_def, call_env_def,
+               flush_state_def]
+      \\ fs[]
+      \\ fs[call_env_def,locals_ok_def,lookup_def,fromList_def, flush_state_def]
+      \\ qexistsl [‘s2.locals’,‘s2.safe_for_space’,‘s2.peak_heap_length’,
+                   ‘s2.stack_max’]
+      \\ gvs [locals_ok_refl]
+      \\ rw [state_component_equality])
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘cut_env r s.locals’ \\ gvs []
+    \\ imp_res_tac locals_ok_cut_env \\ gvs []
+    \\ ‘call_env q r' (push_env x' F (dec_clock (s with locals := l))) =
+        call_env q r' (push_env x' F (dec_clock s))’
+       by fs [state_component_equality, dec_clock_def, call_env_def,
+              push_env_def, flush_state_def]
+    \\ qexistsl [‘s2.locals’,‘s2.safe_for_space’,‘s2.peak_heap_length’,
+                 ‘s2.stack_max’]
+    \\ rw [state_component_equality, locals_ok_refl])
   (* Call *)
   >- (Cases_on `get_vars args s.locals` \\ fs []
      \\ IMP_RES_TAC locals_ok_get_vars \\ fs []
@@ -1658,6 +1853,7 @@ Proof
       semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
       pair_case_eq,consume_space_def,size_of_heap_with_clock,check_lim_def]
     \\ rveq \\ fs [] \\ rw [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
 QED
 
 Theorem do_app_change_clock:
@@ -1665,6 +1861,7 @@ Theorem do_app_change_clock:
    (do_app op args (s1 with clock := ck) = Rval (res,s2 with clock := ck))
 Proof
   fs[do_app_with_clock]
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
 QED
 
 Theorem do_app_change_clock_err:
@@ -1672,6 +1869,7 @@ Theorem do_app_change_clock_err:
   (do_app op args (s1 with clock := ck) = Rerr e)
 Proof
   fs[do_app_with_clock]
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
 QED
 
 Theorem cut_state_eq_some:
@@ -1704,11 +1902,11 @@ Proof
      \\ fs[get_var_def,set_var_def]
      \\ srw_tac[][] >> fs[])
   >- (fs [do_app_aux_def,list_case_eq,option_case_eq,v_case_eq,cut_state_opt_def,cut_state_def
-         , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq
-         , with_fresh_ts_def,bvlSemTheory.ref_case_eq
-         , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq
-         , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq
-         , pair_case_eq,consume_space_def]
+          , bool_case_eq,ffiTheory.call_FFI_def,semanticPrimitivesTheory.result_case_eq
+          , with_fresh_ts_def,bvlSemTheory.ref_case_eq
+          , ffiTheory.ffi_result_case_eq,ffiTheory.oracle_result_case_eq
+          , semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq
+          , pair_case_eq,consume_space_def]
      \\ rveq \\ fs [call_env_def,flush_state_def,do_app_with_clock,do_app_with_locals]
      \\ imp_res_tac do_app_const \\ fs [set_var_def,state_component_equality]
      \\ PairCases_on `y` \\ fs []
@@ -1743,6 +1941,11 @@ Proof
      \\ every_case_tac >> fs[] >> srw_tac[][]
      \\ rfs[] >> srw_tac[][])
   >- (every_case_tac >> fs[] >> srw_tac[][])
+  >- (
+    gvs [AllCaseEqs(), PULL_EXISTS]
+    \\ gvs [flush_state_def, set_var_def, call_env_def, dec_clock_def,
+            push_env_def, pop_env_def]
+    \\ gvs [AllCaseEqs(), PULL_EXISTS])
   >- (every_case_tac >> fs[] >> srw_tac[][] >> rfs[]
      \\ fsrw_tac[ARITH_ss][call_env_def,flush_state_def,dec_clock_def,push_env_def,pop_env_def,set_var_def,LET_THM]
      \\ TRY(first_x_assum(qspec_then`ck`mp_tac) >> simp[]
@@ -1796,6 +1999,7 @@ Proof
               semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
               pair_case_eq,consume_space_def,check_lim_def] >>
   rveq >> fs [])
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
 QED
 
 Theorem call_env_const[simp]:
@@ -1961,6 +2165,7 @@ Definition get_code_labels_def:
   (get_code_labels (Call r d a h) =
     (case d of SOME x => {x} | _ => {}) ∪
     (case h of SOME (n,p) => get_code_labels p | _ => {})) ∧
+  (get_code_labels (Force _ loc _) = {loc}) ∧
   (get_code_labels (Seq p1 p2) = get_code_labels p1 ∪ get_code_labels p2) ∧
   (get_code_labels (If _ p1 p2) = get_code_labels p1 ∪ get_code_labels p2) ∧
   (get_code_labels (Assign _ op _ _) = closLang$assign_get_code_label op) ∧
@@ -2019,6 +2224,7 @@ Proof
       pair_case_eq,consume_space_def,op_space_reset_def,data_spaceTheory.op_space_req_def,
       UNCURRY_EQ]
   \\ rw [] \\ fs [state_component_equality] \\ rw []
+  \\ TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) \\ gvs []
 QED
 
 Theorem evaluate_safe_for_space_mono:
@@ -2026,6 +2232,11 @@ Theorem evaluate_safe_for_space_mono:
     evaluate (prog,s) = (res,s1) /\ s1.safe_for_space ==> s.safe_for_space
 Proof
   recInduct evaluate_ind \\ fs [evaluate_def] \\ rw[]
+  >>~- ([‘dest_thunk’],
+    gvs [AllCaseEqs()]
+    \\ gvs [flush_state_def, set_var_def, call_env_def, dec_clock_def, push_env_def,
+            pop_env_def]
+    \\ gvs [AllCaseEqs()])
   \\ fs [CaseEq"option",cut_state_opt_def,CaseEq"result",pair_case_eq,
          cut_state_def,jump_exc_def,CaseEq"stack",CaseEq"list"]
   \\ fs [] \\ rveq \\ fs [set_var_def,call_env_def,flush_state_def,dec_clock_def,add_space_def]
@@ -2067,8 +2278,7 @@ Proof
   >- trivial_tac
   >- (trivial_tac >> EVAL_TAC)
   (* Assign *)
-  >- (
-     fs [evaluate_def]
+  >- (fs [evaluate_def]
      \\ full_cases >> full_fs
      \\ fs [] \\ rfs[]
      \\ rveq \\ fs []
@@ -2099,6 +2309,57 @@ Proof
      \\ fs[]
      \\ rw[state_component_equality])
   >- basic_tac
+  (* Force *)
+  >- (
+    gvs [evaluate_def]
+    \\ Cases_on ‘get_var src s.locals’ \\ gvs []
+    >- gvs [state_component_equality]
+    \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs []
+    >- gvs [state_component_equality]
+    >- gvs [state_component_equality]
+    \\ Cases_on ‘t’ \\ gvs []
+    >- (
+      Cases_on ‘ret’ \\ gvs []
+      >- gvs [flush_state_def, state_component_equality]
+      \\ Cases_on ‘x'’ \\ gvs []
+      \\ Cases_on ‘cut_env r' s.locals’ \\ gvs []
+      \\ gvs [set_var_def, state_component_equality])
+    \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’
+    \\ gvs []
+    >- gvs [state_component_equality]
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘r'’ \\ gvs []
+    \\ Cases_on ‘ret’ \\ gvs []
+    >- (
+      IF_CASES_TAC \\ gvs []
+      >- simp [state_component_equality]
+      \\ gvs [dec_clock_def]
+      \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’
+      \\ gvs [call_env_def]
+      \\ Cases_on ‘q''’ \\ gvs []
+      \\ first_x_assum $ qspec_then ‘limits'’ strip_assume_tac
+      \\ qpat_abbrev_tac ‘smnew = OPTION_MAP2 MAX _ _’
+      \\ qpat_abbrev_tac ‘ssnew = (_ ∧ _)’
+      \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’]
+                                 strip_assume_tac)
+                    evaluate_smx_safe_peak_swap
+      \\ gvs [state_component_equality])
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘cut_env r' s.locals’ \\ gvs []
+    >- gvs [state_component_equality]
+    \\ IF_CASES_TAC \\ gvs []
+    >- gvs [state_component_equality, call_env_def, push_env_def, dec_clock_def]
+    \\ gvs [push_env_def, call_env_def, dec_clock_def]
+    \\ gvs [AllCaseEqs(), PULL_EXISTS]
+    \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+    \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+    \\ res_tac
+    \\ first_x_assum $ qspec_then ‘limits'’ strip_assume_tac
+    \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’]
+                               strip_assume_tac)
+                  evaluate_smx_safe_peak_swap \\ gvs []
+    \\ gvs [set_var_def, pop_env_def, state_component_equality]
+    \\ gvs [AllCaseEqs()])
   (* Call *)
   >> fs [evaluate_def]
   >> Cases_on `get_vars args s.locals` >> fs [] >> rveq >> fs []
@@ -2273,6 +2534,68 @@ Proof
      \\ fs[]
      \\ rw[state_component_equality])
   >- basics_tac
+  (* Force *)
+  >- (
+    gvs [evaluate_def]
+    \\ Cases_on ‘get_var src s.locals’ \\ gvs []
+    >- gvs [state_component_equality]
+    \\ Cases_on ‘dest_thunk x s.refs’ \\ gvs []
+    >- gvs [state_component_equality]
+    >- gvs [state_component_equality]
+    \\ Cases_on ‘t’ \\ gvs []
+    >- (
+      Cases_on ‘ret’ \\ gvs []
+      >- gvs [flush_state_def, state_component_equality]
+      \\ Cases_on ‘x'’ \\ gvs []
+      \\ Cases_on ‘cut_env r' s.locals’ \\ gvs []
+      \\ gvs [set_var_def, state_component_equality])
+    \\ Cases_on ‘find_code (SOME loc) [x; v] s.code s.stack_frame_sizes’
+    \\ gvs []
+    >- (
+      drule_then (qspec_then ‘sfs’ strip_assume_tac) find_code_upto_size
+      \\ rw [state_component_equality])
+    \\ drule_then (qspec_then ‘sfs’ strip_assume_tac) find_code_upto_size
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘r'’ \\ gvs []
+    \\ Cases_on ‘ret’ \\ gvs []
+    >- (
+      IF_CASES_TAC \\ gvs []
+      >- simp [state_component_equality]
+      \\ gvs [dec_clock_def]
+      \\ Cases_on ‘evaluate (q',call_env q r'' (s with clock := s.clock − 1))’
+      \\ gvs [call_env_def]
+      \\ Cases_on ‘q''’ \\ gvs []
+      \\ res_tac
+      \\ first_x_assum $ qspecl_then [‘sfs’,‘other_size’] strip_assume_tac
+      \\ qpat_abbrev_tac ‘smnew = OPTION_MAP2 MAX _ _’
+      \\ qpat_abbrev_tac ‘ssnew = (_ ∧ _)’
+      \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’]
+                                 strip_assume_tac)
+                    evaluate_smx_safe_peak_swap
+      \\ gvs [] \\ rw [state_component_equality])
+    \\ Cases_on ‘x'’ \\ gvs []
+    \\ Cases_on ‘cut_env r' s.locals’ \\ gvs []
+    >- gvs [state_component_equality]
+    \\ IF_CASES_TAC \\ gvs []
+    >- gvs [state_component_equality, call_env_def, push_env_def, dec_clock_def]
+    \\ gvs [push_env_def, call_env_def, dec_clock_def]
+    \\ fs [AllCaseEqs(), PULL_EXISTS] \\ rveq
+    \\ qmatch_goalsub_abbrev_tac ‘stack_max_fupd (K smnew)’
+    \\ qmatch_goalsub_abbrev_tac ‘safe_for_space_fupd (K ssnew)’
+    \\ qmatch_goalsub_abbrev_tac ‘stack_fupd (K (topstack::_))’
+    \\ first_x_assum drule
+    \\ disch_then (mp_tac o CONV_RULE (RESORT_FORALL_CONV rev))
+    \\ disch_then $ qspecl_then [‘xs’,‘topstack’] mp_tac
+    \\ simp[Abbr ‘topstack’, stack_frame_size_rel_def]
+    \\ disch_then $ qspecl_then [‘sfs’,‘other_size’] strip_assume_tac
+    \\ drule_then (qspecl_then [‘smnew’,‘ssnew’,‘s.peak_heap_length’]
+                               strip_assume_tac)
+                  evaluate_smx_safe_peak_swap \\ gvs []
+    \\ simp [set_var_def] \\ rw [state_component_equality]
+    \\ gvs [pop_env_def, AllCaseEqs()]
+    \\ imp_res_tac LIST_REL_LENGTH \\ gvs []
+    \\ fs [pop_env_def, CaseEq"list", CaseEq"stack"] \\ rveq \\ fs[]
+    \\ rfs [] \\ Cases_on ‘y’ \\ fs [stack_frame_size_rel_def])
   (* Call *)
   >> fs [evaluate_def]
   >> Cases_on `get_vars args s.locals` >> fs [] >> rveq >> fs []
@@ -2488,7 +2811,16 @@ Proof
       Cases_on `evaluate (c1,s)` >> res_tac >>
       fs[] >> metis_tac[option_le_trans])
   >- ((* If *)
-      fs[evaluate_def,CaseEq"option",CaseEq"bool"]) >>
+      fs[evaluate_def,CaseEq"option",CaseEq"bool"])
+  >- ((* Force *)
+    gvs [evaluate_def, AllCaseEqs(), PULL_EXISTS]
+    \\ gvs [flush_state_def, set_var_def, dec_clock_def, call_env_def,
+            push_env_def, pop_env_def, AllCaseEqs()]
+    \\ (
+      (match_mp_tac option_le_trans \\ HINT_EXISTS_TAC \\ rw []
+       \\ Cases_on ‘s.stack_max’ \\ rw [OPTION_MAP2_DEF, IS_SOME_EXISTS])
+      ORELSE (
+        Cases_on ‘s.stack_max’ \\ rw [OPTION_MAP2_DEF,IS_SOME_EXISTS]))) >>
   (* Call *)
   fs[evaluate_def,CaseEq"option",CaseEq"bool",CaseEq"prod",flush_state_def,
      CaseEq "result", CaseEq "error_result"] >>
@@ -2582,6 +2914,7 @@ Proof
      pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def,
      CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def] >>
     rveq >> fs[])
+  >> TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`)
   >> gvs []
 QED
 
@@ -2621,7 +2954,8 @@ Proof
      semanticPrimitivesTheory.eq_result_case_eq,astTheory.word_size_case_eq,
      pair_case_eq,consume_space_def,op_space_reset_def,check_lim_def,
      CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def] >>
-  rveq >> fs[]
+  rveq >> fs[] >>
+  TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) >> gvs []
 QED
 
 Theorem pop_env_safe_for_space:
@@ -2724,7 +3058,41 @@ Proof
       imp_res_tac evaluate_safe_for_space_mono >>
       res_tac >>
       fs[] >> rfs[] >>
-      fs[cc_co_only_diff_def]) >>
+      fs[cc_co_only_diff_def])
+  >- ((* Force *)
+  qhdtm_assum ‘cc_co_only_diff’
+              (strip_assume_tac o REWRITE_RULE [cc_co_only_diff_def])
+  \\ gvs [evaluate_def]
+  \\ TOP_CASE_TAC \\ gvs []
+  \\ TOP_CASE_TAC \\ gvs [CaseEq "prod"]
+  \\ TOP_CASE_TAC
+  >- (
+   gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def]
+   \\ gvs [cc_co_only_diff_def,state_component_equality,set_var_def])
+  \\ gvs [CaseEq "prod"]
+  \\ ntac 4 (TOP_CASE_TAC \\ gvs [])
+  >- (
+   IF_CASES_TAC \\ gvs []
+   >- simp [cc_co_only_diff_def]
+   \\ gvs [AllCaseEqs(), PULL_EXISTS, flush_state_def]
+   \\ first_x_assum (qspec_then ‘call_env q r' (dec_clock t)’ mp_tac)
+   \\ gvs [cc_co_only_diff_def, call_env_def, dec_clock_def]
+   \\ rw [] \\ gvs [])
+  \\ ntac 2 (TOP_CASE_TAC \\ gvs [])
+  \\ IF_CASES_TAC \\ gvs []
+  >- gvs [cc_co_only_diff_def, call_env_def, push_env_def, dec_clock_def]
+  \\ TOP_CASE_TAC \\ gvs []
+  \\ gvs [CaseEq"prod"]
+  \\ drule_then (qspecl_then [‘x'’,‘r'’,‘F’,‘q’] strip_assume_tac)
+                cc_co_only_diff_call_env
+  \\ gvs [CaseEq "option", CaseEq "result", CaseEq "error_result"]
+  \\ gvs [set_var_def, PULL_EXISTS]
+  \\ imp_res_tac pop_env_safe_for_space \\ gvs []
+  \\ res_tac \\ gvs []
+  >- gvs [pop_env_def, cc_co_only_diff_def, AllCaseEqs()]
+  >- (
+    drule_all_then strip_assume_tac pop_env_cc_co_only_diff
+    \\ goal_assum drule \\ fs[cc_co_only_diff_def])) >>
   (* Call *)
   qhdtm_assum `cc_co_only_diff` (strip_assume_tac o REWRITE_RULE[cc_co_only_diff_def]) >>
   fs[evaluate_def] >>
@@ -2803,7 +3171,9 @@ Proof
      CaseEq"closLang$op",ELIM_UNCURRY,size_of_heap_def,stack_to_vs_def,
      stack_consumed_def
     ] >>
-  rveq >> fs[stack_consumed_def,allowed_op_def] >>
+  rveq >>
+  fs[stack_consumed_def,allowed_op_def,data_spaceTheory.op_space_req_def] >>
+  TRY (rename [‘lookup _ _ = SOME (Thunk m_ _)’] \\ Cases_on `m_`) >> gvs [] >>
   imp_res_tac the_le_IMP_option_le >>
   fs[option_le_max,option_le_max_right] >>
   rpt (pop_assum mp_tac)>>
@@ -2844,7 +3214,20 @@ Proof
       metis_tac[option_le_trans,evaluate_safe_for_space_mono])
   >- ((* If *)
       fs[evaluate_def,CaseEq"option",CaseEq"bool"] >>
-      rveq >> fs[]) >>
+      rveq >> fs[])
+  >- ((* Force *)
+    ntac 3 (pop_assum mp_tac)
+    \\ rw [evaluate_def, AllCaseEqs(), flush_state_def, pop_env_def,
+           PULL_EXISTS]
+    \\ TRY(first_x_assum ACCEPT_TAC)
+    \\ TRY(first_x_assum drule \\ rpt (disch_then drule))
+    \\ imp_res_tac evaluate_stack_limit
+    \\ imp_res_tac evaluate_option_le_stack_max
+    \\ imp_res_tac evaluate_safe_for_space_mono
+    \\ rpt (PRED_ASSUM is_forall kall_tac)
+    \\ gvs [call_env_def, dec_clock_def, push_env_def, set_var_def]
+    \\ imp_res_tac the_le_IMP_option_le
+    \\ gvs [option_le_max]) >>
   (* Call *)
   ntac 3 (pop_assum mp_tac) >>
   rw[evaluate_def,CaseEq"option",CaseEq"bool",CaseEq"prod",flush_state_def,
diff --git a/compiler/backend/semantics/dataSemScript.sml b/compiler/backend/semantics/dataSemScript.sml
index e39462cc31..b89bcaa3fa 100644
--- a/compiler/backend/semantics/dataSemScript.sml
+++ b/compiler/backend/semantics/dataSemScript.sml
@@ -122,7 +122,9 @@ Definition size_of_def:
      | NONE => (0, refs, seen)
      | SOME (ByteArray _ bs) => (LENGTH bs DIV (arch_size lims DIV 8) + 2, delete r refs, seen)
      | SOME (ValueArray vs) => let (n,refs,seen) = size_of lims vs (delete r refs) seen in
-                                 (n + LENGTH vs + 1, refs, seen)) /\
+                                 (n + LENGTH vs + 1, refs, seen)
+     | SOME (Thunk _ v) => let (n,refs,seen) = size_of lims [v] (delete r refs) seen in
+                             (n + 2, refs, seen)) /\
   (size_of lims [Block ts tag []]) refs seen = (0, refs, seen) /\
   (size_of lims [Block ts tag vs] refs seen =
      if IS_SOME (sptree$lookup ts seen) then (0, refs, seen) else
@@ -995,6 +997,18 @@ Definition do_app_aux_def:
            | _ => Error)
          | _ => Error)
     | (MemOp ConfigGC,[Number _; Number _]) => (Rval (Unit, s))
+    | (ThunkOp th_op,vs) =>
+        (case (th_op,vs) of
+         | (AllocThunk m, [v]) =>
+             (let ptr = (LEAST ptr. ptr ∉ domain s.refs) in
+                Rval (RefPtr F ptr,
+                      s with refs := insert ptr (Thunk m v) s.refs))
+         | (UpdateThunk m, [RefPtr _ ptr; v]) =>
+             (case lookup ptr s.refs of
+              | SOME (Thunk NotEvaluated _) =>
+                 Rval (Unit,s with refs := insert ptr (Thunk m v) s.refs)
+              | _ => Error)
+         | _ => Error)
     | _ => Error
 End
 
@@ -1194,6 +1208,23 @@ Definition install_sfs_def[simp]:
   install_sfs op ^s = s with safe_for_space := (op ≠ closLang$Install ∧ s.safe_for_space)
 End
 
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk (RefPtr _ ptr) refs =
+    (case lookup ptr refs of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk v refs = NotThunk
+End
+
 Definition evaluate_def:
   (evaluate (Skip,^s) = (NONE,s)) /\
   (evaluate (Move dest src,s) =
@@ -1239,6 +1270,49 @@ Definition evaluate_def:
      | SOME x => if isBool T x then evaluate (c1,s) else
                  if isBool F x then evaluate (c2,s) else
                    (SOME (Rerr(Rabort Rtype_error)),s)) /\
+  (evaluate (Force ret loc src,s) =
+     case get_var src s.locals of
+     | NONE => (SOME (Rerr(Rabort Rtype_error)),s)
+     | SOME thunk_v =>
+       (case dest_thunk thunk_v s.refs of
+        | BadRef => (SOME (Rerr (Rabort Rtype_error)),s)
+        | NotThunk => (SOME (Rerr (Rabort Rtype_error)),s)
+        | IsThunk Evaluated v =>
+          (case ret of
+           | NONE => (SOME (Rval v),flush_state F s)
+           | SOME (dest,names) =>
+             (case cut_env names s.locals of
+              | NONE => (SOME (Rerr(Rabort Rtype_error)),s)
+              | SOME env => (NONE, set_var dest v (s with locals := env))))
+        | IsThunk NotEvaluated f =>
+           (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of
+            | NONE => (SOME (Rerr (Rabort Rtype_error)),s)
+            | SOME (args1,prog,ss) =>
+              (case ret of
+               | NONE =>
+                  (if s.clock = 0 then
+                     (SOME (Rerr(Rabort Rtimeout_error)),
+                           s with <| stack := [] ; locals := LN |>)
+                   else
+                     (case evaluate (prog, call_env args1 ss (dec_clock s)) of
+                      | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s)
+                      | (SOME res,s) => (SOME res,s)))
+               | SOME (dest,names) =>
+                 (case cut_env names s.locals of
+                  | NONE => (SOME (Rerr(Rabort Rtype_error)),s)
+                  | SOME env =>
+                      let s1 = call_env args1 ss (push_env env F (dec_clock s)) in
+                        if s.clock = 0 then
+                          (SOME (Rerr(Rabort Rtimeout_error)),
+                           s1 with <| stack := [] ; locals := LN |>)
+                        else
+                          (case fix_clock s1 (evaluate (prog, s1)) of
+                           | (SOME (Rval x),s2) =>
+                             (case pop_env s2 of
+                              | NONE => (SOME (Rerr(Rabort Rtype_error)),s2)
+                              | SOME s1 => (NONE, set_var dest x s1))
+                           | (NONE,s) => (SOME (Rerr(Rabort Rtype_error)),s)
+                           | res => res)))))) /\
   (evaluate (Call ret dest args handler,s) =
      case get_vars args s.locals of
      | NONE => (SOME (Rerr(Rabort Rtype_error)),s)
@@ -1280,14 +1354,13 @@ Definition evaluate_def:
                          | res => res)))))
 Termination
   WF_REL_TAC `(inv_image (measure I LEX measure prog_size)
-                          (\(xs,s). (s.clock,xs)))`
+                         (\(xs,s). (s.clock,xs)))`
   \\ rpt strip_tac
   \\ simp[dec_clock_def]
   \\ imp_res_tac fix_clock_IMP
   \\ imp_res_tac (GSYM fix_clock_IMP)
   \\ FULL_SIMP_TAC (srw_ss()) [set_var_def,push_env_clock, call_env_def,LET_THM]
-  >- fs [LESS_OR_EQ,dec_clock_def]
-  \\ decide_tac
+  \\ fs [dec_clock_def]
 End
 
 val evaluate_ind = theorem"evaluate_ind";
diff --git a/compiler/backend/semantics/data_monadScript.sml b/compiler/backend/semantics/data_monadScript.sml
index 6de37fe07a..f97461f361 100644
--- a/compiler/backend/semantics/data_monadScript.sml
+++ b/compiler/backend/semantics/data_monadScript.sml
@@ -121,6 +121,50 @@ Definition assign_def:
           | Rval (v,s) => (NONE, set_var dest v (install_sfs op s))
 End
 
+Definition force_def:
+  force ret loc src s =
+    case get_var src s.locals of
+    | NONE => fail s
+    | SOME thunk_v =>
+      (case dest_thunk thunk_v s.refs of
+       | BadRef => fail s
+       | NotThunk => fail s
+       | IsThunk Evaluated v =>
+         (case ret of
+          | NONE => (SOME (Rval v),flush_state F s)
+          | SOME (dest,names) =>
+            (case cut_env names s.locals of
+             | NONE => fail s
+             | SOME env => (NONE, set_var dest v (s with locals := env))))
+      | IsThunk NotEvaluated f =>
+        (case find_code (SOME loc) [thunk_v; f] s.code s.stack_frame_sizes of
+         | NONE => fail s
+         | SOME (args1,prog,ss) =>
+           (case ret of
+            | NONE =>
+              (if s.clock = 0 then
+                 timeout (s with <| stack := []; locals := LN |>)
+               else
+                 (case evaluate (prog, call_env args1 ss (dec_clock s)) of
+                  | (NONE,s) => fail s
+                  | (SOME res,s) => (SOME res,s)))
+            | SOME (dest,names) =>
+              (case cut_env names s.locals of
+               | NONE => fail s
+               | SOME env =>
+                   let s1 = call_env args1 ss (push_env env F (dec_clock s)) in
+                     if s.clock = 0 then
+                       timeout (s1 with <| stack := []; locals := LN |>)
+                     else
+                       (case evaluate (prog, s1) of
+                        | (SOME (Rval x),s2) =>
+                          (case pop_env s2 of
+                           | NONE => fail s2
+                           | SOME s1 => (NONE, set_var dest x s1))
+                        | (NONE,s) => fail s
+                        | res => res)))))
+End
+
 Overload ":≡" = ``assign``
 val _ = set_fixity ":≡" (Infixl 480);
 
@@ -157,6 +201,7 @@ Definition to_shallow_def:
   to_shallow (Assign n op vars cutset) = assign n (op, vars, cutset) /\
   to_shallow (Seq p1 p2) = bind (to_shallow p1) (to_shallow p2) /\
   to_shallow (Return n) = return n /\
+  to_shallow (Force ret loc src) = force ret loc src /\
   to_shallow (Call NONE       dest args NONE) = tailcall dest args /\
   to_shallow (Call NONE       dest args (SOME x)) = fail /\
   to_shallow (Call (SOME ret) dest args handler) = call ret dest args handler /\
@@ -194,7 +239,9 @@ Proof
   >- (fs [get_var_def] \\ rw []
      \\ CASE_TAC \\ fs [call_env_def,fromList_def])
   (* Tick *)
-  \\ rw[tick_def,timeout_def,call_env_def,state_component_equality,fromList_def]
+  >- rw[tick_def,timeout_def,call_env_def,state_component_equality,fromList_def]
+  (* Force *)
+  >- rw [force_def, timeout_def]
 QED
 
 Overload monad_unitbind[local] = ``bind``
diff --git a/compiler/backend/semantics/flatPropsScript.sml b/compiler/backend/semantics/flatPropsScript.sml
index eb44ee5681..c77444d478 100644
--- a/compiler/backend/semantics/flatPropsScript.sml
+++ b/compiler/backend/semantics/flatPropsScript.sml
@@ -365,13 +365,10 @@ Triviality do_app_add_to_clock_NONE:
    ==>
    do_app (s with clock := s.clock + k) op es = NONE
 Proof
-  Cases_on `op`
-  \\ disch_then (mp_tac o SIMP_RULE (srw_ss()) [do_app_def, case_eq_thms])
-  \\ rw []
-  \\ rw [do_app_def]
-  \\ fs [case_eq_thms, pair_case_eq] \\ rw [] \\ fs []
-  \\ rpt (pairarg_tac \\ fs [])
-  \\ fs [bool_case_eq, case_eq_thms]
+  strip_tac
+  \\ Cases_on ‘op’
+  \\ gvs [do_app_def,AllCaseEqs(),semanticPrimitivesTheory.store_alloc_def]
+  \\ rw [] \\ gvs []
   \\ fs [IS_SOME_EXISTS,CaseEq"option",CaseEq"store_v"]
 QED
 
@@ -397,6 +394,11 @@ Proof
   \\ rw [] \\ fs [pmatch_ignore_clock]
   \\ fs [case_eq_thms, pair_case_eq, bool_case_eq, CaseEq"match_result"] \\ rw []
   \\ fs [dec_clock_def]
+  >-
+   (gvs [CaseEq "sum",CaseEq"bool"]
+    \\ gvs [CaseEq"prod"]
+    \\ Cases_on ‘v1 = Rerr (Rabort Rtimeout_error)’ \\ gvs []
+    \\ gvs [AllCaseEqs()])
   \\ map_every imp_res_tac
       [do_app_add_to_clock_NONE,
        do_app_add_to_clock] \\ fs []
@@ -417,13 +419,10 @@ Theorem do_app_io_events_mono:
    do_app ^s op vs = SOME (t, r) ⇒
    s.ffi.io_events ≼ t.ffi.io_events
 Proof
-  rw [do_app_def] \\ fs [case_eq_thms, pair_case_eq, bool_case_eq]
-  \\ rw [] \\ fs []
-  \\ rpt (pairarg_tac \\ fs []) \\ rw []
-  \\ fs [semanticPrimitivesTheory.store_assign_def,
-         semanticPrimitivesTheory.store_lookup_def,
-         ffiTheory.call_FFI_def]
-  \\ rw [] \\ every_case_tac \\ fs [] \\ rw []
+  rw [do_app_def] \\ gvs [AllCaseEqs()]
+  \\ gvs [semanticPrimitivesTheory.store_alloc_def,
+          ffiTheory.call_FFI_def]
+  \\ gvs [AllCaseEqs()]
 QED
 
 Theorem evaluate_io_events_mono:
@@ -481,6 +480,7 @@ Proof
   \\ rw [] \\ fs [] \\ rw [] \\ fs []
   \\ rfs []
   \\ fsrw_tac [SATISFY_ss] [IS_PREFIX_TRANS]
+  \\ gvs [AppUnit_def]
   \\ metis_tac [IS_PREFIX_TRANS, FST, PAIR,
                 evaluate_io_events_mono,
                 with_clock_ffi,
@@ -1163,7 +1163,6 @@ Proof
   \\ rfs [EL_MAP]
 QED
 
-
 val sv_rel_cases = semanticPrimitivesPropsTheory.sv_rel_cases
 
 Theorem simple_do_app_thm:
@@ -1181,6 +1180,18 @@ Proof
   \\ simp [Once do_app_def]
   \\ simp [case_eq_thms, bool_case_eq, pair_case_eq]
   \\ simp_tac bool_ss [PULL_EXISTS, DISJ_IMP_THM, FORALL_AND_THM]
+  \\ Cases_on ‘∃t. op = ThunkOp t’
+  >-
+   (gvs [] \\ gvs [AllCaseEqs()] \\ rw [] \\ gvs [do_app_def]
+    \\ rpt (pairarg_tac \\ gvs [])
+    >-
+     (drule_then (drule_then drule) simple_state_rel_store_alloc
+      \\ simp [Once sv_rel_cases,PULL_EXISTS]
+      \\ disch_then drule \\ strip_tac \\ gvs [])
+    >-
+     (drule_then (drule_then drule) simple_state_rel_store_assign
+      \\ simp [Once sv_rel_cases,PULL_EXISTS]
+      \\ disch_then drule \\ strip_tac \\ gvs []))
   \\ Cases_on `?x. op = FFI x`
   >- (
     fs [GSYM AND_IMP_INTRO]
@@ -1379,6 +1390,7 @@ Theorem flat_evaluate_def = flat_evaluate_def
 Definition store_v_vs_def[simp]:
   store_v_vs (Varray vs) = vs /\
   store_v_vs (Refv v) = [v] /\
+  store_v_vs (Thunk m v) = [v] /\
   store_v_vs (W8array xs) = []
 End
 
diff --git a/compiler/backend/semantics/flatSemScript.sml b/compiler/backend/semantics/flatSemScript.sml
index 17fd500b2e..c25f9fda9a 100644
--- a/compiler/backend/semantics/flatSemScript.sml
+++ b/compiler/backend/semantics/flatSemScript.sml
@@ -542,6 +542,16 @@ Definition do_app_def:
        | _ => NONE)
   | (Id, [v1]) =>
     SOME (s, Rval v1)
+  | (ThunkOp th_op, vs) =>
+     (case (th_op,vs) of
+      | (AllocThunk m, [v]) =>
+          (let (r,n) = store_alloc (Thunk m v) s.refs in
+             SOME (s with refs := r, Rval (Loc F n)))
+      | (UpdateThunk m, [Loc _ lnum; v]) =>
+          (case store_assign lnum (Thunk m v) s.refs of
+           | SOME r => SOME (s with refs := r, Rval (Conv NONE []))
+           | NONE => NONE)
+      | _ => NONE)
   | _ => NONE
 End
 
@@ -646,15 +656,6 @@ Proof
   Cases_on `x` \\ fs [fix_clock_def] \\ rw [] \\ fs []
 QED
 
-Theorem pmatch_rows_Match_exp_size:
-  !pes s v env e.
-    pmatch_rows pes s v = Match (env',p,e) ==>
-    exp_size e < exp3_size pes
-Proof
-  Induct \\ fs [pmatch_rows_def,FORALL_PROD,CaseEq"match_result",CaseEq"bool"]
-  \\ rw [] \\ res_tac \\ fs [exp_size_def]
-QED
-
 Definition is_fresh_type_def:
   is_fresh_type type_id ctors ⇔
     !ctor. ctor ∈ ctors ⇒ !arity id. ctor ≠ ((id, SOME type_id), arity)
@@ -684,6 +685,92 @@ Definition do_eval_def:
     | _ => NONE)
 End
 
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk [Loc _ n] st =
+    (case store_lookup n st of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk vs st = NotThunk
+End
+
+Definition update_thunk_def:
+  update_thunk [Loc _ n] st [v] =
+    (case dest_thunk [v] st of
+     | NotThunk => store_assign n (Thunk Evaluated v) st
+     | _ => NONE) ∧
+  update_thunk _ st _ = NONE
+End
+
+Definition AppUnit_def:
+  AppUnit x = flatLang$App None Opapp [x; Con None NONE []]
+End
+
+Definition exp_alt_size_def[simp]:
+  exp_alt_size (Raise a0 a1) = 1 + (tra_size a0 + exp_alt_size a1) ∧
+  exp_alt_size (Handle a0 a1 a2) =
+  1 + (tra_size a0 + (exp_alt_size a1 + exp3_alt_size a2)) ∧
+  exp_alt_size (Lit a0 a1) = 1 + (tra_size a0 + lit_size a1) ∧
+  exp_alt_size (Con a0 a1 a2) =
+  1 +
+  (tra_size a0 +
+   (option_size (pair_size (λx. x) (option_size (λx. x))) a1 +
+    exp6_alt_size a2)) ∧
+  exp_alt_size (Var_local a0 a1) = 1 + (tra_size a0 + list_size char_size a1) ∧
+  exp_alt_size (Fun a0 a1 a2) =
+  1 + (list_size char_size a0 + (list_size char_size a1 + exp_alt_size a2)) ∧
+  exp_alt_size (App a0 a1 a2) =
+  1 + (tra_size a0 + (op_size a1 + exp6_alt_size a2))
+    + (if a1 = ThunkOp ForceThunk then 100 else 0) ∧
+  exp_alt_size (If a0 a1 a2 a3) =
+  1 + (tra_size a0 + (exp_alt_size a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧
+  exp_alt_size (Mat a0 a1 a2) =
+  1 + (tra_size a0 + (exp_alt_size a1 + exp3_alt_size a2)) ∧
+  exp_alt_size (Let a0 a1 a2 a3) =
+  1 +
+  (tra_size a0 +
+   (option_size (list_size char_size) a1 + (exp_alt_size a2 + exp_alt_size a3))) ∧
+  exp_alt_size (Letrec a0 a1 a2) =
+  1 + (list_size char_size a0 + (exp1_alt_size a1 + exp_alt_size a2)) ∧
+  exp1_alt_size [] = 0 ∧
+  exp1_alt_size (a0::a1) = 1 + (exp2_alt_size a0 + exp1_alt_size a1) ∧
+  exp2_alt_size (a0,a1) = 1 + (list_size char_size a0 + exp4_alt_size a1) ∧
+  exp3_alt_size [] = 0 ∧
+  exp3_alt_size (a0::a1) = 1 + (exp5_alt_size a0 + exp3_alt_size a1) ∧
+  exp4_alt_size (a0,a1) = 1 + (list_size char_size a0 + exp_alt_size a1) ∧
+  exp5_alt_size (a0,a1) = 1 + (pat_size a0 + exp_alt_size a1) ∧ exp6_alt_size [] = 0 ∧
+  exp6_alt_size (a0::a1) = 1 + (exp_alt_size a0 + exp6_alt_size a1)
+End
+
+Theorem exp6_alt_size:
+  exp6_alt_size xs = LENGTH xs + SUM (MAP exp_alt_size xs)
+Proof
+  Induct_on `xs` \\ simp []
+QED
+
+Theorem pmatch_rows_Match_exp_alt_size:
+  !pes s v env e.
+    pmatch_rows pes s v = Match (env',p,e) ==>
+    exp_alt_size e < exp3_alt_size pes
+Proof
+  Induct \\ fs [pmatch_rows_def,FORALL_PROD,CaseEq"match_result",CaseEq"bool"]
+  \\ rw [] \\ res_tac \\ fs []
+QED
+
+Definition dec_alt_size_def[simp]:
+  dec_alt_size (Dlet a) = 1 + exp_alt_size a ∧
+  dec_alt_size (Dtype a0 a1) = 1 + (a0 + spt_size (λx. x) a1) ∧
+  dec_alt_size (Dexn a0 a1) = 1 + (a0 + a1)
+End
+
 Definition evaluate_def:
   (evaluate (env:v flatSem$environment) ^s ([]:flatLang$exp list) =
     (s,Rval [])) ∧
@@ -748,10 +835,23 @@ Definition evaluate_def:
                | (s, NONE) => (s, Rval [retv])
                | (s, SOME e) => (s, Rerr e))
           | NONE => (s, Rerr (Rabort Rtype_error)))
+       else if op = ThunkOp ForceThunk then
+         (case dest_thunk vs s.refs of
+          | BadRef => (s, Rerr (Rabort Rtype_error))
+          | NotThunk => (s, Rerr (Rabort Rtype_error))
+          | IsThunk Evaluated v => (s, Rval [v])
+          | IsThunk NotEvaluated f =>
+             (case evaluate <| v := [("f",f)] |> s
+                    [AppUnit (Var_local None "f")] of
+              | (s, Rval vs2) =>
+                  (case update_thunk vs s.refs vs2 of
+                   | NONE => (s, Rerr (Rabort Rtype_error))
+                   | SOME refs => (s with refs := refs, Rval vs2))
+              | (s, Rerr e) => (s, Rerr e)))
        else
-       (case (do_app s op (REVERSE vs)) of
-        | NONE => (s, Rerr (Rabort Rtype_error))
-        | SOME (s',r) => (s', evaluate$list_result r))
+        (case (do_app s op (REVERSE vs)) of
+         | NONE => (s, Rerr (Rabort Rtype_error))
+         | SOME (s',r) => (s', evaluate$list_result r))
    | res => res) ∧
   (evaluate env s [If _ e1 e2 e3] =
    case fix_clock s (evaluate env s [e1]) of
@@ -807,16 +907,16 @@ Definition evaluate_def:
 Termination
   wf_rel_tac `inv_image ($< LEX $<)
     (\x. case x of
-        | INL (env,s,exps) => (s.clock, SUM (MAP exp_size exps) + LENGTH exps)
-        | (INR(INL(s,d))) => (s.clock,dec_size d + 1)
-        | (INR(INR(s,ds))) => (s.clock,SUM (MAP dec_size ds) + LENGTH ds + 1))`
-  \\ simp [exp_size_def, dec_clock_def]
+        | INL (env,s,exps) => (s.clock, SUM (MAP exp_alt_size exps) + LENGTH exps)
+        | (INR(INL(s,d))) => (s.clock,dec_alt_size d + 1)
+        | (INR(INR(s,ds))) => (s.clock,SUM (MAP dec_alt_size ds) + LENGTH ds + 1))`
+  \\ simp [dec_clock_def]
   \\ rw []
   \\ imp_res_tac fix_clock_IMP
   \\ imp_res_tac do_if_either_or
-  \\ imp_res_tac pmatch_rows_Match_exp_size
+  \\ imp_res_tac pmatch_rows_Match_exp_alt_size
   \\ fs []
-  \\ simp [MAP_REVERSE, SUM_REVERSE, exp6_size]
+  \\ simp [MAP_REVERSE, SUM_REVERSE, exp6_alt_size, AppUnit_def, char_size_def]
 End
 
 val op_thms = { nchotomy = op_nchotomy, case_def = op_case_def};
@@ -855,9 +955,8 @@ QED
 
 Theorem do_app_cases =
   ``do_app st op vs = SOME (st',v)`` |>
-  (SIMP_CONV (srw_ss()++COND_elim_ss) [PULL_EXISTS, do_app_def, eqs, pair_case_eq, pair_lam_lem] THENC
-   SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, eqs] THENC
-   ALL_CONV)
+  (SIMP_CONV (srw_ss()++COND_elim_ss) [PULL_EXISTS, do_app_def, eqs, pair_case_eq, pair_lam_lem, CaseEq "thunk_op"] THENC
+   SIMP_CONV (srw_ss()++COND_elim_ss) [LET_THM, eqs])
 
 Theorem do_app_const:
    do_app s op vs = SOME (s',r) ⇒ s.clock = s'.clock ∧ s.c = s'.c
diff --git a/compiler/backend/serialiser/backend_enc_decScript.sml b/compiler/backend/serialiser/backend_enc_decScript.sml
index 47490f022e..8f4e5b7175 100644
--- a/compiler/backend/serialiser/backend_enc_decScript.sml
+++ b/compiler/backend/serialiser/backend_enc_decScript.sml
@@ -201,6 +201,8 @@ val _ = reg_enc_dec closLang_const_enc'_thm;
 
 val res = define_enc_dec “:opw”;
 val res = define_enc_dec “:ast$shift”;
+val res = define_enc_dec “:ast$thunk_mode”
+val res = define_enc_dec “:ast$thunk_op”;
 val res = define_enc_dec “:fp_cmp”;
 val res = define_enc_dec “:fp_uop”;
 val res = define_enc_dec “:fp_bop”;
diff --git a/compiler/backend/source_to_flatScript.sml b/compiler/backend/source_to_flatScript.sml
index 5264aaed48..c089e07fce 100644
--- a/compiler/backend/source_to_flatScript.sml
+++ b/compiler/backend/source_to_flatScript.sml
@@ -131,6 +131,7 @@ Definition astOp_to_flatOp_def:
   | ConfigGC => flatLang$ConfigGC
   | FFI string => flatLang$FFI string
   | Eval => Eval
+  | ThunkOp t => ThunkOp t
   (* default element *)
   | _ => flatLang$ConfigGC
 End
diff --git a/compiler/backend/stack_allocScript.sml b/compiler/backend/stack_allocScript.sml
index 745c2ac95e..bd0f7c88cd 100644
--- a/compiler/backend/stack_allocScript.sml
+++ b/compiler/backend/stack_allocScript.sml
@@ -150,9 +150,9 @@ Definition word_gen_gc_move_code_def:
                       (* get len+1w *)
                       right_shift_inst 1 (dimindex (:'a) - conf.len_size);
                       add_1_inst 1;
-                      const_inst 2 28w;
+                      const_inst 2 0b1100w;
                       and_inst 6 2;
-                      If Equal 6 (Imm 8w)
+                      If Equal 6 (Imm 8w) (* is_ref_header *)
                         (list_Seq [
                           Set (Temp 0w) 3;
                           Set (Temp 1w) 4;
diff --git a/compiler/bootstrap/translation/sexp_parserProgScript.sml b/compiler/bootstrap/translation/sexp_parserProgScript.sml
index 94cbc4bb37..e89acab695 100644
--- a/compiler/bootstrap/translation/sexp_parserProgScript.sml
+++ b/compiler/bootstrap/translation/sexp_parserProgScript.sml
@@ -278,6 +278,9 @@ val sexplit_side = Q.prove(
 
 val r = translate sexppat_alt_def;
 
+val r = translate encode_thunk_mode_def;
+val r = translate decode_thunk_mode_def;
+
 val r = translate (fromSexpTheory.sexpop_def
                    |> REWRITE_RULE [decode_control_eq]);
 
diff --git a/compiler/bootstrap/translation/to_word32ProgScript.sml b/compiler/bootstrap/translation/to_word32ProgScript.sml
index aec9496345..8cbca4f2c7 100644
--- a/compiler/bootstrap/translation/to_word32ProgScript.sml
+++ b/compiler/bootstrap/translation/to_word32ProgScript.sml
@@ -310,6 +310,9 @@ val data_to_word_assign_side = Q.prove(`
   metis_tac[word_op_type_nchotomy,option_nchotomy,NOT_NONE_SOME,list_distinct]) |> update_precondition
 *)
 
+val _ = translate (data_to_wordTheory.force_thunk_def
+                    |> SRULE [bytes_in_word_def] |> conv32 |> wcomp_simp);
+
 Theorem comp_ind =
   data_to_wordTheory.comp_ind|> conv32|> wcomp_simp
 (* Inlines the let k = 8 manually *)
diff --git a/compiler/bootstrap/translation/to_word64ProgScript.sml b/compiler/bootstrap/translation/to_word64ProgScript.sml
index f1930ef39f..1539126a7f 100644
--- a/compiler/bootstrap/translation/to_word64ProgScript.sml
+++ b/compiler/bootstrap/translation/to_word64ProgScript.sml
@@ -300,6 +300,9 @@ val data_to_word_assign_side = Q.prove(`
   metis_tac[word_op_type_nchotomy,option_nchotomy,NOT_NONE_SOME,list_distinct]) |> update_precondition
 *)
 
+val _ = translate (data_to_wordTheory.force_thunk_def
+                    |> SRULE [bytes_in_word_def] |> conv64 |> wcomp_simp);
+
 Theorem comp_ind =
   data_to_wordTheory.comp_ind|> conv64|> wcomp_simp
 (* Inlines the let k = 8 manually *)
diff --git a/compiler/dafny/translation/dafny_compilerProgScript.sml b/compiler/dafny/translation/dafny_compilerProgScript.sml
index b5ee884288..236a89cfa0 100644
--- a/compiler/dafny/translation/dafny_compilerProgScript.sml
+++ b/compiler/dafny/translation/dafny_compilerProgScript.sml
@@ -227,6 +227,7 @@ val r = translate fromSexpTheory.optsexp_def;
 val r = translate fromSexpTheory.idsexp_def;
 val r = translate fromSexpTheory.typesexp_def;
 val r = translate fromSexpTheory.patsexp_def;
+val r = translate fromSexpTheory.encode_thunk_mode_def;
 (* TODO 101 automatically added string IMPLODEs *)
 val r = translate fromSexpTheory.opsexp_def;
 val r = translate fromSexpTheory.lopsexp_def;
diff --git a/compiler/inference/inferScript.sml b/compiler/inference/inferScript.sml
index b60f8fdf8a..6475a7b42c 100644
--- a/compiler/inference/inferScript.sml
+++ b/compiler/inference/inferScript.sml
@@ -649,7 +649,10 @@ Definition op_to_string_def:
   (op_to_string Eval = (implode "Eval", 6)) ∧
   (op_to_string Env_id = (implode "Env_id", 1)) ∧
   (op_to_string ListAppend = (implode "ListAppend", 2)) ∧
-  (op_to_string (FFI _) = (implode "FFI", 2))
+  (op_to_string (FFI _) = (implode "FFI", 2)) ∧
+  (op_to_string (ThunkOp ForceThunk) = (implode "ForceThunk", 1)) ∧
+  (op_to_string (ThunkOp (AllocThunk _)) = (implode "AllocThunk", 1)) ∧
+  (op_to_string (ThunkOp (UpdateThunk _)) = (implode "UpdateThunk", 2))
 End
 
 Overload Tem[local,inferior] = ``Infer_Tapp []``
@@ -789,6 +792,7 @@ constrain_op l op ts s =
    | (AallocFixed, _) => failwith l (implode "Unsafe ops do not have a type")  s(* not actually unsafe *)
    | (Eval, _) => failwith l (implode "Unsafe ops do not have a type") s
    | (Env_id, _) => failwith l (implode "Unsafe ops do not have a type") s
+   | (ThunkOp _, _) => failwith l (implode "Thunk ops do not have a type") s
    | _ => failwith l (op_n_args_msg op (LENGTH ts)) s
 End
 
@@ -812,11 +816,12 @@ Theorem constrain_op_error_msg_sanity:
   LENGTH args = SND (op_to_string op) ∧
   constrain_op l op args s = (Failure (l',msg), s')
   ⇒
-  IS_PREFIX (explode msg) "Type mismatch" \/
-  IS_PREFIX (explode msg) "Unsafe"
+  IS_PREFIX (explode msg) "Type mismatch" ∨
+  IS_PREFIX (explode msg) "Unsafe" ∨
+  IS_PREFIX (explode msg) "Thunk"
 Proof
  rpt strip_tac >>
- qmatch_abbrev_tac `IS_PREFIX _ m1 \/ IS_PREFIX _ m2` >>
+ qmatch_abbrev_tac `IS_PREFIX _ m1 \/ IS_PREFIX _ m2 \/ IS_PREFIX _ m3` >>
  cases_on `op` >>
  fs [op_to_string_def, constrain_op_dtcase_def, op_simple_constraints_def] >>
  gvs [LENGTH_EQ_NUM_compute] >>
diff --git a/compiler/inference/unifyScript.sml b/compiler/inference/unifyScript.sml
index cb8bad59da..5b9df80eef 100644
--- a/compiler/inference/unifyScript.sml
+++ b/compiler/inference/unifyScript.sml
@@ -804,7 +804,7 @@ Theorem cvwalk_tcallish:
   ∀x. (λn. cwfs s) x ⇒
       cvwalk s x = TAILCALL (cvwalk_code s) (cvwalk s) x
 Proof
-  simp[whileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE,
+  simp[WhileTheory.TAILCALL_def, cvwalk_code_def, sum_CASE_option_CASE,
        sum_CASE_infer_CASE, FORALL_PROD] >>
   simp[Once (DISCH_ALL cvwalk_thm), cwfs_def]
 QED
@@ -812,7 +812,7 @@ QED
 Theorem cvwalk_cleaned:
   ∀x. (λn. cwfs s) x ⇒ cvwalk s x = TAILREC (cvwalk_code s) x
 Proof
-  match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >>
+  match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >>
   rpt conj_tac
   >- ACCEPT_TAC cvwalk_preserves_precond
   >- (rpt strip_tac >> qexists_tac ‘cvwalkR s’ >> conj_tac
@@ -831,7 +831,7 @@ Proof simp[FUN_EQ_THM]
 QED
 
 Theorem tcvwalk_thm =
-        tcvwalk_def |> SRULE[Once whileTheory.TAILREC, cvwalk_code_def]
+        tcvwalk_def |> SRULE[Once WhileTheory.TAILREC, cvwalk_code_def]
                     |> SRULE[sum_CASE_option_CASE, sum_CASE_infer_CASE]
                     |> SRULE[GSYM tcvwalk_def, cvwalk_eta,
                              GSYM (SRULE [FUN_EQ_THM] cvwalk_code_def)]
@@ -1180,7 +1180,7 @@ Theorem kcocwl_tcallish:
   ∀x. (λv. cwfs s) x ⇒
       kcocwl s n x = TAILCALL (kcocwl_code s n) (kcocwl s n) x
 Proof
-  simp[FORALL_PROD, whileTheory.TAILCALL_def, kcocwl_code_def,
+  simp[FORALL_PROD, WhileTheory.TAILCALL_def, kcocwl_code_def,
        sum_CASE_list_CASE, sum_CASE_infer_CASE, sum_CASE_COND] >>
   rpt strip_tac >> rename [‘kcocwl s n wl ⇔ _’] >>
   Cases_on ‘wl’ >> simp[Once kcocwl_thm, SimpLHS] >>
@@ -1190,7 +1190,7 @@ QED
 Theorem kcocwl_cleaned:
   ∀x. (λv. cwfs s) x ⇒ kcocwl s n x = TAILREC (kcocwl_code s n) x
 Proof
-  match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
+  match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
   >- ACCEPT_TAC kcocwl_preserves_precond
   >- (qx_gen_tac ‘wl’ >> strip_tac >>
       qexists ‘kcocwlR s n’ >> conj_tac
@@ -1216,7 +1216,7 @@ Theorem disj2cond[local] = DECIDE “p ∨ q ⇔ if p then T else q”
 
 Theorem tcocwl_thm =
         tcocwl_def
-          |> SRULE[Once whileTheory.TAILREC, sum_CASE_list_CASE,
+          |> SRULE[Once WhileTheory.TAILREC, sum_CASE_list_CASE,
                    sum_CASE_infer_CASE, sum_CASE_COND, kcocwl_code_def]
           |> SRULE [GSYM tcocwl_def, GSYM kcocwl_code_def]
           |> PURE_REWRITE_RULE [disj2cond]
@@ -1457,7 +1457,7 @@ Theorem kcwalkstarwl_tcallish:
       (λ(v,its,k). kcwalkstarwl s v its k) x =
       TAILCALL (kcwalkstarwl_code s) (λ(v,its,k). kcwalkstarwl s v its k) x
 Proof
-  simp[whileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD,
+  simp[WhileTheory.TAILCALL_def, kcwalkstarwl_code_def, FORALL_PROD,
        sum_CASE_COND, sum_CASE_list_CASE, sum_CASE_infer_CASE,
        sum_CASE_wstarcont_CASE] >>
   simp[Once $ DISCH_ALL kcwalkstarwl_thm]
@@ -1467,7 +1467,7 @@ Theorem kcwalkstarwl_cleaned:
   ∀x. (λ(v,its,k). cwfs s) x ⇒
       (λ(v,its,k). kcwalkstarwl s v its k) x = TAILREC (kcwalkstarwl_code s) x
 Proof
-  match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
+  match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
   >- ACCEPT_TAC kcwalkstarwl_preserves_precond
   >- (qx_gen_tac ‘trip’ >> strip_tac >>
       qexists ‘kcwalkstarwlR s’ >> conj_tac
@@ -1491,7 +1491,7 @@ End
 
 Theorem tcwalkstarwl_thm =
         tcwalkstarwl_def
-          |> SRULE[Once whileTheory.TAILREC]
+          |> SRULE[Once WhileTheory.TAILREC]
           |> SRULE[kcwalkstarwl_code_def, sum_CASE_COND,
                    sum_CASE_wstarcont_CASE,
                    sum_CASE_list_CASE, sum_CASE_infer_CASE]
@@ -1600,7 +1600,7 @@ Theorem kcunifywl_tcallish:
       (λ(s,k). kcunifywl s k) x =
       TAILCALL cunify_code (λ(s,k). kcunifywl s k) x
 Proof
-  simp[whileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE,
+  simp[WhileTheory.TAILCALL_def, FORALL_PROD, sum_CASE_list_CASE,
        cunify_code_def, sum_CASE_pair_CASE, sum_CASE_infer_CASE,
        sum_CASE_COND] >>
   qx_genl_tac [‘s’, ‘k’] >> strip_tac >>
@@ -1992,7 +1992,7 @@ Theorem kcunifywl_cleaned:
   ∀x. (λ(s,wl). cwfs s) x ⇒
       (λ(s,wl). kcunifywl s wl) x = TAILREC cunify_code x
 Proof
-  match_mp_tac whileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
+  match_mp_tac WhileTheory.TAILREC_GUARD_ELIMINATION >> rpt conj_tac
   >- ACCEPT_TAC kcunifywl_preserves_precond
   >- (rpt strip_tac >> qexists ‘kcunifywlR’ >> conj_tac
       >- (irule $ iffLR WF_EQ_WFP >> simp[WF_kcunifywlR]) >>
@@ -2005,7 +2005,7 @@ Definition tcunify_def:
 End
 
 Theorem tcunify_thm =
-        tcunify_def |> SRULE[Once whileTheory.TAILREC]
+        tcunify_def |> SRULE[Once WhileTheory.TAILREC]
                     |> SRULE[cunify_code_def,
                              sum_CASE_list_CASE, sum_CASE_pair_CASE,
                              sum_CASE_infer_CASE, sum_CASE_COND]
diff --git a/compiler/parsing/fromSexpScript.sml b/compiler/parsing/fromSexpScript.sml
index ee7144888d..aa33e2187f 100644
--- a/compiler/parsing/fromSexpScript.sml
+++ b/compiler/parsing/fromSexpScript.sml
@@ -657,6 +657,18 @@ Proof
   rw[FUN_EQ_THM,sexppat_alt_intro]
 QED
 
+Definition decode_thunk_mode_def:
+  decode_thunk_mode s =
+    if s = "Evaluated" then SOME Evaluated
+    else if s = "NotEvaluated" then SOME NotEvaluated
+    else NONE
+End
+
+Definition encode_thunk_mode_def:
+  encode_thunk_mode Evaluated = "Evaluated" ∧
+  encode_thunk_mode NotEvaluated = "NotEvaluated"
+End
+
 Definition sexpop_def:
   (sexpop (SX_SYM s) =
   if s = "OpnPlus" then SOME (Opn Plus) else
@@ -736,12 +748,20 @@ Definition sexpop_def:
   if s = "Aupdate" then SOME Aupdate else
   if s = "Asubunsafe" then SOME Asub_unsafe else
   if s = "Aupdateunsafe" then SOME Aupdate_unsafe else
+  if s = "ForceThunk" then SOME (ThunkOp ForceThunk) else
   if s = "ConfigGC" then SOME ConfigGC else
   if s = "Eval" then SOME Eval else
   if s = "Envid" then SOME Env_id else NONE) ∧
   (sexpop (SX_CONS (SX_SYM s) (SX_STR s')) =
      if s = "FFI" then OPTION_MAP FFI (decode_control s') else NONE
    ) ∧
+  (sexpop (SX_CONS (SX_SYM s) (SX_SYM t)) =
+     case decode_thunk_mode t of
+     | NONE => NONE
+     | SOME m =>
+         if s = "AllocThunk" then SOME (ThunkOp (AllocThunk m)) else
+         if s = "UpdateThunk" then SOME (ThunkOp (UpdateThunk m)) else NONE
+   ) ∧
   (sexpop (SX_CONS (SX_SYM s) (SX_NUM n)) =
     if s = "Shift8Lsl" then SOME (Shift W8 Lsl n) else
     if s = "Shift8Lsr" then SOME (Shift W8 Lsr n) else
@@ -1363,13 +1383,23 @@ Definition opsexp_def:
   (opsexp ConfigGC = SX_SYM "ConfigGC") ∧
   (opsexp Eval = SX_SYM "Eval") ∧
   (opsexp Env_id = SX_SYM "Envid") ∧
-  (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s))
+  (opsexp (FFI s) = SX_CONS (SX_SYM "FFI") (SEXSTR s)) ∧
+  (opsexp (ThunkOp ForceThunk) = SX_SYM "ForceThunk")  ∧
+  (opsexp (ThunkOp (AllocThunk m)) =
+    SX_CONS (SX_SYM "AllocThunk") (SX_SYM (encode_thunk_mode m))) ∧
+  (opsexp (ThunkOp (UpdateThunk m)) =
+    SX_CONS (SX_SYM "UpdateThunk") (SX_SYM (encode_thunk_mode m)))
 End
 
 Theorem sexpop_opsexp[simp]:
    sexpop (opsexp op) = SOME op
 Proof
-  Cases_on`op`>>rw[sexpop_def,opsexp_def]>>
+  Cases_on ‘∃t. op = ThunkOp t’
+  >- (gvs [] \\ Cases_on ‘t’
+      \\ gvs [sexpop_def,opsexp_def]
+      \\ rw [] \\ gvs [AllCaseEqs()]
+      \\ Cases_on ‘t'’ \\ gvs [encode_thunk_mode_def,decode_thunk_mode_def]) >>
+  Cases_on`op`>>fs []>>rw[sexpop_def,opsexp_def] >>
   TRY(MAP_FIRST rename1 [
         ‘Opn c1’, ‘Opb c1’, ‘Opw c2 c1’, ‘Chopb c1’, ‘Shift c1 c2 _’,
         ‘FP_cmp c1’, ‘FP_uop c1’, ‘FP_bop c1’, ‘FP_top c1’,
@@ -1900,6 +1930,7 @@ Proof
   \\ Cases_on ‘s1’ \\ gvs[sexpop_def]
   \\ Cases_on ‘s2’
   \\ gvs[sexpop_def, AllCaseEqs(), opsexp_def, encode_decode_control]
+  \\ gvs [encode_thunk_mode_def,decode_thunk_mode_def,AllCaseEqs()]
 QED
 
 Theorem lopsexp_sexplop:
@@ -2080,6 +2111,9 @@ Proof
   \\ TRY(Cases_on`s`) \\ simp[opsexp_def]
   \\ TRY(Cases_on`f`) \\ simp[opsexp_def]
   \\ TRY(Cases_on`r`) \\ simp[opsexp_def]
+  \\ TRY(Cases_on`t`) \\ simp[opsexp_def]
+  \\ TRY(Cases_on`t'`) \\ simp[encode_thunk_mode_def]
+  \\ TRY(Cases_on`b`) \\ simp[opsexp_def]
   \\ EVAL_TAC
 QED
 
diff --git a/compiler/repl/evaluate_initScript.sml b/compiler/repl/evaluate_initScript.sml
index e05c56a63a..1a32857a8d 100644
--- a/compiler/repl/evaluate_initScript.sml
+++ b/compiler/repl/evaluate_initScript.sml
@@ -63,7 +63,8 @@ End
 Theorem ref_ok_thm:
   ref_ok s (Refv v) = v_ok s v ∧
   ref_ok s (Varray vs) = EVERY (v_ok s) vs ∧
-  ref_ok s (W8array a) = T
+  ref_ok s (W8array a) = T ∧
+  ref_ok s (Thunk _ v) = v_ok s v
 Proof
   rw [ref_ok_def, ref_rel_def, v_ok_def, LIST_REL_EL_EQN, EVERY_EL]
 QED
@@ -656,20 +657,119 @@ Proof
     gvs[do_app_cases, v_ok_thm]
     \\ ‘s with <| refs := s.refs; ffi := s.ffi |> = s’ suffices_by gs[]
     \\ gs[state_component_equality])
+  \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[]
+  >- (
+    gvs [do_app_cases, v_ok_thm, thunk_op_def, AllCaseEqs()]
+    \\ pairarg_tac \\ gvs []
+    \\ gvs [store_alloc_def, state_ok_def, v_ok_thm, state_rel_def, EVERY_EL,
+            INJ_IFF, FLOOKUP_FUN_FMAP, EL_APPEND_EQN]
+    \\ rw [] \\ gvs [FUN_FMAP_DEF, ref_rel_def, NOT_LESS, LESS_OR_EQ,
+                     ref_ok_def]
+    >- (
+      irule ref_rel_mono
+      \\ first_assum (irule_at Any) \\ rw []
+      \\ irule_at Any v_rel_update
+      \\ first_assum (irule_at Any)
+      \\ gvs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO])
+    \\ gvs [v_ok_def]
+    \\ irule_at Any v_rel_update
+    \\ first_assum (irule_at Any)
+    \\ gvs [FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO])
+  \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[]
+  >- (
+    gvs [do_app_cases, thunk_op_def, AllCaseEqs(), v_ok_thm, store_assign_def,
+         state_ok_def, v_ok_def, state_rel_def, FLOOKUP_FUN_FMAP]
+    \\ rw [v_rel_def, EL_LUPDATE, ref_rel_def])
+  \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs[]
+  >- gvs [do_app_def, AllCaseEqs(), thunk_op_def]
   \\ Cases_on ‘op’ \\ gs []
+  \\ Cases_on ‘t’ \\ gs []
 QED
 
 Theorem do_app_ok[allow_rebind] = SIMP_RULE (srw_ss()) [LET_THM] do_app_ok;
 
+Theorem dest_thunk_ok:
+  state_ok s ∧
+  dest_thunk vs s.refs = IsThunk m v ∧
+  do_opapp [v; Conv NONE []] = SOME (env,e) ⇒
+    state_ok (dec_clock s) ∧ env_ok (dec_clock s) env
+Proof
+  rw []
+  >- gvs [dec_clock_def, state_ok_def, state_rel_def]
+  \\ gvs [do_opapp_def, AllCaseEqs()]
+  >- (
+    gvs [dec_clock_def, env_ok_def, env_rel_def]
+    \\ irule_at Any nsAll2_nsBind \\ gvs []
+    \\ conj_tac >- simp [v_rel_def]
+    \\ gvs [state_ok_def, state_rel_def, FLOOKUP_FUN_FMAP]
+    \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def]
+    \\ first_x_assum drule \\ rw [ref_rel_def, v_rel_def, env_rel_def])
+  \\ simp [env_ok_def, env_rel_def, dec_clock_def]
+  \\ irule_at Any nsAll2_nsBind \\ gvs []
+  \\ conj_tac >- simp [v_rel_def]
+  \\ simp [semanticPrimitivesPropsTheory.build_rec_env_merge]
+  \\ irule_at Any nsAll2_nsAppend \\ gvs []
+  \\ irule_at Any nsAll2_alist_to_ns \\ gvs []
+  \\ gs [EVERY2_MAP, LAMBDA_PROD, v_rel_def, env_rel_def]
+  \\ rw [ELIM_UNCURRY, LIST_REL_EL_EQN]
+  \\ gvs [state_ok_def, state_rel_def, FLOOKUP_FUN_FMAP]
+  \\ gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def]
+  \\ first_x_assum drule \\ rw [ref_rel_def, v_rel_def, env_rel_def]
+QED
+
 Theorem evaluate_ok_Op:
   op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App")
 Proof
   strip_tac
-  \\ ‘~ (getOpClass op = EvalOp)’ by (Cases_on ‘op’ \\ gs[])
-  \\ ‘~ (getOpClass op = FunApp)’ by (Cases_on ‘op’ \\ gs[])
+  \\ ‘~ (getOpClass op = EvalOp)’ by (
+    Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[])
+  \\ ‘~ (getOpClass op = FunApp)’ by (
+    Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t’ \\ gs[])
   \\ rpt strip_tac
   \\ gs[evaluate_def, Excl "getOpClass_def"]
   \\ Cases_on ‘getOpClass op’ \\ gs[Excl "getOpClass_def"]
+  >>~ [‘getOpClass op = Force’]
+  >- (
+    Cases_on ‘op’ \\ full_simp_tac (srw_ss()) []
+    \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs []
+    >- (
+      drule_all dest_thunk_ok \\ rw [] \\ gvs []
+      \\ qpat_x_assum ‘state_ok st2’ mp_tac
+      \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP]
+      >- simp [INJ_DEF, FUN_FMAP_DEF]
+      \\ rw []
+      \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def,
+              EL_LUPDATE]
+      \\ IF_CASES_TAC \\ gvs [ref_rel_def, v_ok_def])
+    >- (drule_all dest_thunk_ok \\ gvs []))
+  >- (
+    Cases_on ‘op’ \\ full_simp_tac (srw_ss()) []
+    \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs []
+    \\ (
+      drule_all dest_thunk_ok \\ rw [] \\ gvs []
+      \\ imp_res_tac (CONJUNCT1 evaluate_next_type_stamp_mono)
+      \\ imp_res_tac (CONJUNCT1 evaluate_next_exn_stamp_mono)
+      \\ imp_res_tac (CONJUNCT1 evaluate_refs_length_mono)
+      \\ gvs [dec_clock_def, env_ok_def]
+      \\ irule env_rel_update
+      \\ first_assum (irule_at Any)
+      \\ gvs [oneline update_thunk_def, AllCaseEqs(), store_assign_def,
+              FUN_FMAP_SUBMAP_SUBSET, COUNT_MONO]))
+  >- (
+    Cases_on ‘op’ \\ full_simp_tac (srw_ss()) []
+    \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs []
+    >- (
+      gvs [oneline dest_thunk_def, AllCaseEqs(), store_lookup_def]
+      \\ qpat_x_assum ‘state_ok st'’ mp_tac
+      \\ rw [state_ok_def, state_rel_def] \\ gvs [FLOOKUP_FUN_FMAP]
+      \\ first_x_assum drule \\ rw [ref_rel_def, v_ok_def])
+    \\ drule_all dest_thunk_ok \\ rw [] \\ gvs []
+    \\ gvs [EVERY_EL, v_ok_def, oneline update_thunk_def, AllCaseEqs(),
+            store_assign_def])
+  >- (
+    Cases_on ‘op’ \\ full_simp_tac (srw_ss()) []
+    \\ Cases_on ‘t'’ \\ full_simp_tac (srw_ss()) [AllCaseEqs()] \\ gvs []
+    \\ drule_all dest_thunk_ok \\ gvs [])
   \\ gvs [CaseEqs ["prod", "result", "option"]]
   \\ dxrule_then assume_tac (iffRL EVERY_REVERSE)
   \\ drule_all_then assume_tac do_app_ok \\ gs []
diff --git a/compiler/repl/evaluate_skipScript.sml b/compiler/repl/evaluate_skipScript.sml
index 32cbfa4b06..11f8e8c972 100644
--- a/compiler/repl/evaluate_skipScript.sml
+++ b/compiler/repl/evaluate_skipScript.sml
@@ -90,10 +90,11 @@ Theorem env_rel_def =
   “env_rel fr ft fe env1 env2” |> SIMP_CONV std_ss [Once v_rel_cases];
 
 Definition ref_rel_def:
-  ref_rel f (Refv v)    (Refv w)    = f v w            ∧
-  ref_rel f (Varray vs) (Varray ws) = LIST_REL f vs ws ∧
-  ref_rel f (W8array a) (W8array b) = (a = b)          ∧
-  ref_rel f _           _           = F
+  ref_rel f (Refv v)      (Refv w)      = f v w                 ∧
+  ref_rel f (Varray vs)   (Varray ws)   = LIST_REL f vs ws      ∧
+  ref_rel f (W8array a)   (W8array b)   = (a = b)               ∧
+  ref_rel f (Thunk m1 v1) (Thunk m2 v2) = ((m1 = m2) ∧ f v1 v2) ∧
+  ref_rel f _           _               = F
 End
 
 Theorem ref_rel_mono:
@@ -630,43 +631,44 @@ Theorem state_rel_store_assign:
   state_rel l fr ft fe s t ∧
   FLOOKUP fr n = SOME m ∧
   ref_rel (v_rel fr ft fe) v w ⇒
-    OPTREL (λr1 r2.
-      state_rel l fr ft fe
-        (s with <| refs := r1 |>) (t with refs := r2))
-           (store_assign n v s.refs)
-           (store_assign m w t.refs)
-Proof
-  rw [OPTREL_def, store_assign_def, state_rel_def]
-  \\ ‘n < LENGTH s.refs ∧ m < LENGTH t.refs’
-    by (qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
-        \\ qpat_x_assum ‘FLOOKUP fr n = _’ mp_tac
-        \\ rw [INJ_DEF, flookup_thm]
-        \\ first_x_assum drule \\ gs [])
-  \\ gs []
-  \\ first_assum (qspec_then ‘n’ mp_tac)
-  \\ IF_CASES_TAC \\ gs []
-  \\ rw []
-  \\ ‘store_v_same_type (EL n s.refs) (EL m t.refs)’
-    by (rw [store_v_same_type_def]
-        \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [ref_rel_def])
-  \\ ‘store_v_same_type v w’
-    by (rw [store_v_same_type_def]
-        \\ CASE_TAC \\ gs [] \\ CASE_TAC \\ gs [ref_rel_def])
-  \\ ‘store_v_same_type (EL n s.refs) v = store_v_same_type (EL m t.refs) w’
-    by (rw [EQ_IMP_THM] \\ gs [store_v_same_type_def]
-        \\ Cases_on ‘EL n s.refs’ \\ Cases_on ‘EL m t.refs’
-        \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gs [])
-  \\ csimp []
-  \\ simp [DISJ_EQ_IMP]
-  \\ strip_tac \\ gs []
-  \\ qx_gen_tac ‘n1’
-  \\ first_x_assum (qspec_then ‘n1’ assume_tac)
-  \\ rw [] \\ gs [EL_LUPDATE]
-  \\ rw [] \\ gs [ref_rel_def]
-  \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
-  \\ qpat_x_assum ‘FLOOKUP fr n1 = SOME _’ mp_tac
-  \\ qpat_x_assum ‘FLOOKUP fr n = SOME _’ mp_tac
-  \\ rw [flookup_thm, INJ_DEF] \\ gs []
+    OPTREL
+      (λr1 r2. state_rel l fr ft fe (s with refs := r1) (t with refs := r2))
+      (store_assign n v s.refs)
+      (store_assign m w t.refs)
+Proof
+  rw [OPTREL_def] \\ gvs []
+  \\ ‘n < LENGTH s.refs ∧ m < LENGTH t.refs’ by (
+    gvs [state_rel_def]
+    \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
+    \\ qpat_x_assum ‘FLOOKUP fr n = _’ mp_tac
+    \\ rw [INJ_DEF, flookup_thm]
+    \\ first_x_assum drule \\ rw [])
+  \\ Cases_on ‘store_assign n v s.refs’ \\ gvs []
+  >- (
+    gvs [store_assign_def, NOT_LESS]
+    \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [ref_rel_def]
+    \\ Cases_on ‘EL n s.refs’ \\ Cases_on ‘EL m t.refs’
+    \\ gvs [store_v_same_type_def, state_rel_def]
+    \\ first_x_assum $ qspec_then `n` assume_tac \\ gvs [ref_rel_def])
+  \\ gvs [store_assign_def]
+  \\ Cases_on ‘v’ \\ Cases_on ‘w’ \\ gvs [ref_rel_def]
+  \\ (
+    Cases_on ‘EL n s.refs’ \\ gvs [Once store_v_same_type_def]
+    \\ gvs [state_rel_def, EL_LUPDATE] \\ rw []
+    >- (
+      first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs []
+      \\ Cases_on ‘EL m t.refs’ \\ gvs [ref_rel_def, store_v_same_type_def])
+    >- simp [ref_rel_def]
+    >- (
+      first_x_assum $ qspec_then ‘n'’ assume_tac \\ gvs []
+      \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
+      \\ qpat_x_assum ‘FLOOKUP fr n = SOME m’ mp_tac
+      \\ qpat_x_assum ‘FLOOKUP fr n' = SOME m'’ mp_tac
+      \\ rw [INJ_DEF, FLOOKUP_DEF] \\ gvs [])
+    >- (
+      gvs [NOT_LESS]
+      \\ qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
+      \\ rw [INJ_DEF, FLOOKUP_DEF] \\ gvs []))
 QED
 
 Theorem v_rel_v_to_list:
@@ -1712,7 +1714,61 @@ Proof
                                     "store_v", "v"]]
     \\ rpt (irule_at Any SUBMAP_REFL) \\ gs []
     \\ first_assum (irule_at Any) \\ gs [])
+  \\ Cases_on ‘∃m. op = ThunkOp (AllocThunk m)’ \\ gs[]
+  >- (
+    Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def]
+    \\ rpt (pairarg_tac \\ gvs [])
+    >- metis_tac [SUBMAP_REFL]
+    >- metis_tac [SUBMAP_REFL]
+    \\ qexists ‘fr |+ (LENGTH s.refs,LENGTH t.refs)’ \\ gvs []
+    \\ rpt (irule_at Any SUBMAP_REFL \\ gvs [])
+    \\ gvs [store_alloc_def]
+    \\ rename1 ‘v_rel _ _ _ v y’
+    \\ qexistsl [‘t with refs := t.refs ++ [Thunk m y]’,
+                 ‘s with refs := s.refs ++ [Thunk m v]’]
+    \\ gvs [state_rel_def]
+    \\ rw []
+    >- (
+      qpat_x_assum ‘INJ ($' fr) _ _’ mp_tac
+      \\ simp [INJ_DEF, FAPPLY_FUPDATE_THM]
+      \\ rw [] \\ gvs []
+      \\ ntac 2 (first_x_assum drule \\ gvs []))
+    >- gvs [count_add1]
+    >- (
+      gvs [FLOOKUP_UPDATE] \\ rw []
+      \\ first_x_assum drule \\ rw [])
+    >- (first_x_assum drule \\ rw [])
+    >- (
+      gvs [FLOOKUP_UPDATE, EL_APPEND_EQN] \\ rw [] \\ gvs []
+      >- (
+        simp [oneline ref_rel_def]
+        \\ irule v_rel_update \\ gvs []
+        \\ first_x_assum $ irule_at Any \\ gvs [])
+      >- (
+        first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs []
+        \\ irule ref_rel_mono \\ gvs []
+        \\ first_x_assum $ irule_at Any \\ rw []
+        \\ irule v_rel_update \\ gvs []
+        \\ first_x_assum $ irule_at Any \\ gvs []))
+    >- (
+      gvs [FLOOKUP_UPDATE]
+      \\ first_x_assum $ qspec_then ‘n’ assume_tac \\ gvs [])
+    >- gvs [v_rel_def, FLOOKUP_UPDATE])
+  \\ Cases_on ‘∃m. op = ThunkOp (UpdateThunk m)’ \\ gs[]
+  >- (
+    Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def, OPTREL_def]
+    \\ rpt (irule_at Any SUBMAP_REFL) \\ gs [v_rel_def]
+    \\ rename1 ‘v_rel fr ft fe v w’
+    \\ ‘ref_rel (v_rel fr ft fe) (Thunk m v) (Thunk m w)’
+      by gs [ref_rel_def]
+    \\ drule_all state_rel_store_assign \\ rw [OPTREL_def]
+    \\ first_assum (irule_at Any) \\ gs [])
+  \\ Cases_on ‘op = ThunkOp ForceThunk’ \\ gs []
+  >- (
+    Cases_on ‘res’ \\ gvs [do_app_def, AllCaseEqs(), thunk_op_def]
+    \\ rpt (irule_at Any SUBMAP_REFL \\ gvs []))
   \\ Cases_on ‘op’ \\ gs []
+  \\ Cases_on ‘t'’ \\ gs []
 QED
 
 (* TODO Move up *)
@@ -1738,12 +1794,151 @@ Proof
   \\ Cases_on ‘e1’ \\ Cases_on ‘e2’ \\ gs []
 QED
 
+Definition thunk_rel_def:
+  thunk_rel f BadRef BadRef = T ∧
+  thunk_rel f NotThunk NotThunk = T ∧
+  thunk_rel f (IsThunk m1 v1) (IsThunk m2 v2) = (m1 = m2 ∧ f v1 v2) ∧
+  thunk_rel _ _ _ = F
+End
+
+Theorem state_rel_dest_thunk:
+  state_rel l fr ft fe s t ∧
+  LIST_REL (v_rel fr ft fe) vs ws ∧
+  dest_thunk vs s.refs = t1 ⇒
+    ∃t2. dest_thunk ws t.refs = t2 ∧ thunk_rel (v_rel fr ft fe) t1 t2
+Proof
+  rw []
+  \\ Cases_on ‘dest_thunk vs s.refs’
+  \\ Cases_on ‘dest_thunk ws t.refs’
+  \\ gvs [thunk_rel_def, oneline dest_thunk_def, AllCaseEqs(), v_rel_def]
+  \\ drule_all state_rel_store_lookup \\ rw [OPTREL_def, ref_rel_def]
+QED
+
+Theorem state_rel_update_thunk_NONE:
+  fr1 ⊑ fr2 ∧
+  state_rel l fr2 ft2 fe2 s t ∧
+  LIST_REL (v_rel fr1 ft1 fe1) vs1 ws1 ∧
+  LIST_REL (v_rel fr2 ft2 fe2) vs2 ws2 ∧
+  update_thunk vs1 s.refs vs2 = NONE ⇒
+    update_thunk ws1 t.refs ws2 = NONE
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs(), v_rel_def]
+  \\ ‘LIST_REL (v_rel fr2 ft2 fe2) [v] [y']’ by gvs []
+  \\ drule_all state_rel_dest_thunk \\ rw [] \\ gvs []
+  \\ Cases_on ‘dest_thunk [y'] t.refs’ \\ gvs [thunk_rel_def]
+  \\ ‘FLOOKUP fr2 n = SOME l2’ by (drule_all FLOOKUP_SUBMAP \\ rw [])
+  \\ ‘ref_rel (v_rel fr2 ft2 fe2) (Thunk Evaluated v) (Thunk Evaluated y')’
+    by gvs [ref_rel_def]
+  \\ drule_all state_rel_store_assign \\ rw [OPTREL_def]
+QED
+
+Theorem state_rel_update_thunk_SOME:
+  fr1 ⊑ fr2 ∧
+  state_rel l fr2 ft2 fe2 s t ∧
+  update_thunk vs1 s.refs vs2 = SOME refs1 ∧
+  LIST_REL (v_rel fr1 ft1 fe1) vs1 a1 ∧
+  LIST_REL (v_rel fr2 ft2 fe2) vs2 a2 ⇒
+    ∃refs2.
+      (update_thunk a1 t.refs a2 = SOME refs2 ∧
+       state_rel l fr2 ft2 fe2 (s with refs := refs1) (t with refs := refs2))
+Proof
+  rw []
+  \\ gvs [oneline update_thunk_def, AllCaseEqs(), v_rel_def]
+  \\ ‘LIST_REL (v_rel fr2 ft2 fe2) [v] [y']’ by gvs []
+  \\ drule_all state_rel_dest_thunk \\ rw [] \\ gvs []
+  \\ Cases_on ‘dest_thunk [y'] t.refs’ \\ gvs [thunk_rel_def]
+  \\ ‘FLOOKUP fr2 n = SOME l2’ by (drule_all FLOOKUP_SUBMAP \\ rw [])
+  \\ ‘ref_rel (v_rel fr2 ft2 fe2) (Thunk Evaluated v) (Thunk Evaluated y')’
+    by gvs [ref_rel_def]
+  \\ drule_all state_rel_store_assign \\ rw [OPTREL_def] \\ gvs []
+QED
+
 Theorem evaluate_update_Op:
   op ≠ Opapp ∧ op ≠ Eval ⇒ ^(get_goal "App")
 Proof
   rw [evaluate_def] \\ Cases_on ‘getOpClass op’
-  >- (Cases_on ‘op’ \\ gs[])
-  >- (Cases_on ‘op’ \\ gs[])
+  >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[])
+  >- (Cases_on ‘op’ \\ gs[] \\ Cases_on ‘t'’ \\ gs[])
+  >- (
+    Cases_on ‘op’ \\ gvs [] \\ Cases_on ‘t'’ \\ gvs []
+    \\ qpat_x_assum ‘_ = (s1,res)’ mp_tac
+    \\ TOP_CASE_TAC \\ gvs []
+    \\ reverse TOP_CASE_TAC \\ gvs []
+    >- (
+      strip_tac
+      \\ first_x_assum drule_all \\ rw [] \\ gvs []
+      \\ qpat_x_assum ‘res_rel _ _ (Rerr _) res1’ mp_tac
+      \\ Cases_on ‘res1’ \\ rw [res_rel_def]
+      \\ metis_tac [])
+    \\ first_x_assum drule_all \\ strip_tac \\ gvs []
+    \\ Cases_on ‘res1’ \\ gvs [res_rel_def]
+    \\ TOP_CASE_TAC \\ gvs []
+    \\ imp_res_tac EVERY2_REVERSE
+    \\ drule_all state_rel_dest_thunk \\ simp [oneline thunk_rel_def]
+    \\ TOP_CASE_TAC \\ gvs []
+    >~ [‘BadRef’] >- metis_tac []
+    >~ [‘NotThunk’] >- metis_tac []
+    \\ strip_tac \\ gvs []
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (rw [] \\ gvs [] \\ metis_tac [])
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (
+      strip_tac \\ gvs []
+      \\ qpat_x_assum ‘v_rel _ _ _ v v'’ mp_tac
+      \\ gvs [do_opapp_def, AllCaseEqs(), PULL_EXISTS]
+      \\ rw [Once v_rel_cases]
+      \\ metis_tac [])
+    \\ Cases_on ‘do_opapp [v'; Conv NONE []]’ \\ gvs []
+    >- (
+      CCONTR_TAC \\ gvs []
+      \\ qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac
+      \\ gvs [do_opapp_def, AllCaseEqs(), PULL_EXISTS]
+      \\ rgs [Once v_rel_cases])
+    \\ Cases_on ‘x’ \\ Cases_on ‘x'’ \\ gvs []
+    \\ ‘q.clock = t1.clock’ by gvs [state_rel_def] \\ gvs []
+    \\ TOP_CASE_TAC \\ gvs []
+    >- (rw [] \\ gvs [] \\ metis_tac [])
+    \\ TOP_CASE_TAC \\ gvs []
+    \\ ‘state_rel l fr1 ft1 fe1 (dec_clock q) (dec_clock t1)’
+      by gvs [dec_clock_def, state_rel_def]
+    \\ first_x_assum drule
+    \\ disch_then $ qspec_then ‘q''’ mp_tac
+    \\ impl_tac \\ gvs []
+    >- (
+      qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac
+      \\ gvs [do_opapp_def, AllCaseEqs()]
+      \\ rgs [Once v_rel_cases] \\ gvs []
+      \\ gvs [env_rel_def]
+      \\ irule nsAll2_nsBind \\ gvs [v_rel_def]
+      \\ gvs [semanticPrimitivesPropsTheory.build_rec_env_merge]
+      \\ irule nsAll2_nsAppend \\ gs []
+      \\ irule nsAll2_alist_to_ns
+      \\ gs [EVERY2_MAP, LAMBDA_PROD, v_rel_def]
+      \\ rw [LIST_REL_EL_EQN, ELIM_UNCURRY, env_rel_def])
+    \\ strip_tac \\ gvs []
+    \\ qpat_x_assum ‘v_rel _ _ _ v v'’ assume_tac
+    \\ gvs [do_opapp_def]
+    \\ gvs [CaseEq"v", CaseEq"option", CaseEq"prod"]
+    \\ rgs [Once v_rel_cases] \\ gvs []
+    \\ (
+      reverse TOP_CASE_TAC \\ gvs []
+      >- (
+        rw [] \\ gvs []
+        \\ TOP_CASE_TAC \\ gvs []
+        \\ metis_tac [SUBMAP_TRANS])
+      \\ TOP_CASE_TAC \\ gvs []
+      >- (
+        rw [] \\ gvs []
+        \\ TOP_CASE_TAC \\ gvs []
+        \\ imp_res_tac EVERY2_REVERSE
+        \\ drule_all state_rel_update_thunk_NONE \\ rw [] \\ gvs []
+        \\ metis_tac [SUBMAP_TRANS])
+      \\ strip_tac \\ gvs []
+      \\ TOP_CASE_TAC \\ gvs []
+      \\ imp_res_tac EVERY2_REVERSE
+      \\ drule_all state_rel_update_thunk_SOME \\ rw [] \\ gvs []
+      \\ metis_tac [SUBMAP_TRANS]))
   >- (
     gvs [CaseEqs ["prod", "result", "option"], PULL_EXISTS]
     \\ first_x_assum (drule_all_then strip_assume_tac)
diff --git a/compiler/scheme/translation/to_sexpProgScript.sml b/compiler/scheme/translation/to_sexpProgScript.sml
index 3c765f8087..f7225605e2 100644
--- a/compiler/scheme/translation/to_sexpProgScript.sml
+++ b/compiler/scheme/translation/to_sexpProgScript.sml
@@ -34,6 +34,7 @@ val r = translate fromSexpTheory.optsexp_def;
 val r = translate fromSexpTheory.idsexp_def;
 val r = translate fromSexpTheory.typesexp_def;
 val r = translate fromSexpTheory.patsexp_def;
+val r = translate fromSexpTheory.encode_thunk_mode_def;
 val r = translate fromSexpTheory.opsexp_def;
 val r = translate fromSexpTheory.lopsexp_def;
 val r = translate fromSexpTheory.expsexp_def;
diff --git a/cv_translator/backend_32_cvScript.sml b/cv_translator/backend_32_cvScript.sml
index 88e6afc687..5eecf3ad42 100644
--- a/cv_translator/backend_32_cvScript.sml
+++ b/cv_translator/backend_32_cvScript.sml
@@ -542,6 +542,8 @@ val _ = cv_trans (data_to_wordTheory.assign_def |> arch_spec |> SRULE
    data_to_wordTheory.arg3_def,
    data_to_wordTheory.arg4_def])
 
+val _ = cv_trans (data_to_wordTheory.force_thunk_def |> arch_spec);
+
 val pre = data_to_wordTheory.comp_def |> arch_spec |> SRULE [to_adjust_vars] |> cv_trans_pre "";
 Theorem data_to_word_comp_pre[cv_pre,local]:
   ∀c secn l p. data_to_word_comp_pre c secn l p
@@ -573,4 +575,3 @@ Proof
 QED
 
 val _ = word_allocTheory.get_heuristics_def |> arch_spec |> cv_auto_trans;
-
diff --git a/cv_translator/backend_64_cvScript.sml b/cv_translator/backend_64_cvScript.sml
index 7b29d5be5d..b98843126d 100644
--- a/cv_translator/backend_64_cvScript.sml
+++ b/cv_translator/backend_64_cvScript.sml
@@ -542,6 +542,8 @@ val _ = cv_trans (data_to_wordTheory.assign_def |> arch_spec |> SRULE
    data_to_wordTheory.arg3_def,
    data_to_wordTheory.arg4_def])
 
+val _ = cv_trans (data_to_wordTheory.force_thunk_def |> arch_spec);
+
 val pre = data_to_wordTheory.comp_def |> arch_spec |> SRULE [to_adjust_vars] |> cv_trans_pre "";
 Theorem data_to_word_comp_pre[cv_pre,local]:
   ∀c secn l p. data_to_word_comp_pre c secn l p
@@ -573,4 +575,3 @@ Proof
 QED
 
 val _ = word_allocTheory.get_heuristics_def |> arch_spec |> cv_auto_trans;
-
diff --git a/cv_translator/to_data_cvScript.sml b/cv_translator/to_data_cvScript.sml
index 534a5d5728..18f058b1ce 100644
--- a/cv_translator/to_data_cvScript.sml
+++ b/cv_translator/to_data_cvScript.sml
@@ -2193,7 +2193,7 @@ val _ = cv_auto_trans backend_asmTheory.to_bvl_def;
 (* Bring everything from bvl to the front -- everything because this file is
    too big for me to try everything separately. *)
 val bvl_names =
-  ["Var", "If", "Let", "Raise", "Handle", "Tick", "Call", "Op", "Bool",
+  ["Var", "If", "Let", "Raise", "Handle", "Tick", "Force", "Call", "Op", "Bool",
    "mk_tick"];
 val _ = app (fn name =>
   temp_bring_to_front_overload name {Name=name, Thy="bvl"}) bvl_names;
diff --git a/examples/filterProgScript.sml b/examples/filterProgScript.sml
index 4b9b7dab74..331256848e 100644
--- a/examples/filterProgScript.sml
+++ b/examples/filterProgScript.sml
@@ -998,7 +998,7 @@ Proof
      impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >>
      simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >>
      Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >>
-     disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >>
+     disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >>
      rename1 `LNTH n0` >>
      qmatch_goalsub_abbrev_tac `LGENLIST f` >>
      Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >>
@@ -1047,7 +1047,7 @@ Proof
      impl_tac >- rw[every_LNTH,LNTH_LGENLIST,next_filter_events,LFINITE_fromList] >>
      simp[SimpL ``$==>``,exists_LNTH,LNTH_LGENLIST] >>
      Ho_Rewrite.PURE_ONCE_REWRITE_TAC [cut_at_null_simplify] >>
-     disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[whileTheory.LEAST_EXISTS]) >>
+     disch_then(strip_assume_tac o Ho_Rewrite.REWRITE_RULE[WhileTheory.LEAST_EXISTS]) >>
      rename1 `LNTH n0` >>
      qmatch_goalsub_abbrev_tac `LGENLIST f` >>
      Q.ISPECL_THEN [`n0`,`f`] assume_tac (GEN_ALL LGENLIST_CHUNK_GENLIST) >>
diff --git a/misc/Holmakefile b/misc/Holmakefile
index f01a823001..df0cd89120 100644
--- a/misc/Holmakefile
+++ b/misc/Holmakefile
@@ -1,4 +1,4 @@
-INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/fun-op-sem/lprefix_lub \
+INCLUDES = $(CAKEMLDIR)/developers $(HOLDIR)/examples/machine-code/hoare-triple $(HOLDIR)/examples/pl-semantics/lprefix_lub \
 	$(HOLDIR)/examples/formal-languages/context-free
 
 all: $(DEFAULT_TARGETS) README.md
diff --git a/misc/miscScript.sml b/misc/miscScript.sml
index 57988b3c7d..e977841ced 100644
--- a/misc/miscScript.sml
+++ b/misc/miscScript.sml
@@ -2316,8 +2316,8 @@ QED
 Theorem OLEAST_SOME_IMP:
    $OLEAST P = SOME i ⇒ P i ∧ (∀n. n < i ⇒ ¬P n)
 Proof
-  simp[whileTheory.OLEAST_def]
-  \\ metis_tac[whileTheory.LEAST_EXISTS_IMP]
+  simp[WhileTheory.OLEAST_def]
+  \\ metis_tac[WhileTheory.LEAST_EXISTS_IMP]
 QED
 
 Theorem EXP2_EVEN:
diff --git a/pancake/semantics/panItreeSemScript.sml b/pancake/semantics/panItreeSemScript.sml
index ce4ce941b4..3454f575ca 100644
--- a/pancake/semantics/panItreeSemScript.sml
+++ b/pancake/semantics/panItreeSemScript.sml
@@ -714,7 +714,7 @@ Theorem ltree_lift_state_simps:
      ltree_lift_state f st' ((g ∘ (SND ek)) a)
 Proof
   rpt conj_tac >>
-  rw[ltree_lift_state_def, Once whileTheory.WHILE] >>
+  rw[ltree_lift_state_def, Once WhileTheory.WHILE] >>
   rw[ELIM_UNCURRY] >>
   PURE_TOP_CASE_TAC >> rw[]
 QED
diff --git a/semantics/Holmakefile b/semantics/Holmakefile
index 72475f54c9..26d96b954e 100644
--- a/semantics/Holmakefile
+++ b/semantics/Holmakefile
@@ -1,5 +1,5 @@
 INCLUDES = $(HOLDIR)/examples/formal-languages/context-free\
-					 $(HOLDIR)/examples/fun-op-sem/lprefix_lub\
+					 $(HOLDIR)/examples/pl-semantics/lprefix_lub\
 					 $(CAKEMLDIR)/developers $(CAKEMLDIR)/misc\
 					 ffi
 
diff --git a/semantics/alt_semantics/bigStepScript.sml b/semantics/alt_semantics/bigStepScript.sml
index e5c1cd536d..c7280d46cc 100644
--- a/semantics/alt_semantics/bigStepScript.sml
+++ b/semantics/alt_semantics/bigStepScript.sml
@@ -40,7 +40,10 @@ Inductive opClass:
 (* FunApp *)
 (opClass Opapp FunApp) ∧
 (* Eval *)
-(opClass Eval EvalOp)
+(opClass Eval EvalOp) ∧
+(* Thunks *)
+(opClass (ThunkOp ForceThunk) Force) ∧
+(∀op. op ≠ ForceThunk ⇒ opClass (ThunkOp op) Simple)
 End
 
 (* ------------------------ Big step semantics -------------------------- *)
@@ -153,10 +156,88 @@ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error)))
 ==>
 evaluate ck env s1 (App op es) (( s2 with<| refs := refs'; ffi :=ffi' |>), res))
 
+∧
+
+(∀ck env op es vs s1 s2.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = BadRef
+ ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error)))
+
+∧
+
+(∀ck env op es vs s1 s2.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = NotThunk
+ ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error)))
+
+∧
+
+(∀ck env op es vs s1 s2 f.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧
+  do_opapp [f; Conv NONE []] = NONE
+ ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error)))
+
+∧
+
+(∀ck env op es vs v s1 s2.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk Evaluated v
+ ⇒ evaluate ck env s1 (App op es) (s2, Rval v))
+
+∧
+
+(∀ck env op es vs s1 s2 f env_e.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧
+  do_opapp [f; Conv NONE []] = SOME env_e ∧
+  ck ∧ s2.clock = 0
+ ⇒ evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtimeout_error)))
+
+∧
+
+(∀ck env op es vs s1 s2 f env' e s3 err.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧
+  do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+  (ck ⇒ s2.clock ≠ 0) ∧
+  evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err)
+ ⇒ evaluate ck env s1 (App op es) (s3, Rerr err))
+
+∧
+
+(∀ck env op es vs s1 s2 f env' e s3 vs2.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧
+  do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+  (ck ⇒ s2.clock ≠ 0) ∧
+  evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧
+  update_thunk (REVERSE vs) s3.refs [vs2] = NONE
+ ⇒ evaluate ck env s1 (App op es) (s3, Rerr (Rabort Rtype_error)))
+
+∧
+
+(∀ck env op es vs s1 s2 f env' e s3 vs2 refs.
+  evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) ∧
+  opClass op Force ∧
+  dest_thunk (REVERSE vs) s2.refs = IsThunk NotEvaluated f ∧
+  do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+  (ck ⇒ s2.clock ≠ 0) ∧
+  evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval vs2) ∧
+  update_thunk (REVERSE vs) s3.refs [vs2] = SOME refs
+ ⇒ evaluate ck env s1 (App op es) (s3 with refs := refs, Rval vs2))
+
 /\ (! ck env op es vs s1 s2.
       evaluate_list ck env s1 (REVERSE es) (s2, Rval vs) /\
       do_app (s2.refs,s2.ffi) op (REVERSE vs) = NONE /\
-      ¬opClass op FunApp
+      ¬opClass op FunApp ∧ ¬opClass op Force
 ==>
       evaluate ck env s1 (App op es) (s2, Rerr (Rabort Rtype_error)))
 
diff --git a/semantics/alt_semantics/itree_semanticsScript.sml b/semantics/alt_semantics/itree_semanticsScript.sml
index c9c5db870d..6000de91f0 100644
--- a/semantics/alt_semantics/itree_semanticsScript.sml
+++ b/semantics/alt_semantics/itree_semanticsScript.sml
@@ -15,6 +15,19 @@ End
 
 Overload flit[local] = “λw. Litv (Float64 w)”
 
+Definition thunk_op_def:
+  thunk_op (s: v store_v list) th_op vs =
+    case (th_op,vs) of
+    | (AllocThunk m, [v]) =>
+        (let (s',n) = store_alloc (Thunk m v) s in
+           SOME (s', Rval (Loc F n)))
+    | (UpdateThunk m, [Loc _ lnum; v]) =>
+        (case store_assign lnum (Thunk m v) s of
+         | SOME s' => SOME (s', Rval (Conv NONE []))
+         | NONE => NONE)
+    | _ => NONE
+End
+
 Definition do_app_def:
   do_app s op vs = case (op, vs) of
       (ListAppend, [x1; x2]) => (
@@ -346,6 +359,7 @@ Definition do_app_def:
             Rval (Conv NONE [nat_to_v gen; nat_to_v id]))
     | (Env_id, [Conv NONE [gen; id]]) => SOME (s,
             Rval (Conv NONE [gen; id]))
+    | (ThunkOp th_op, vs) => thunk_op s th_op vs
     | _ => NONE
 End
 
@@ -356,6 +370,7 @@ Datatype:
   ctxt_frame = Craise
              | Chandle ((pat # exp) list)
              | Capp op (v list) (exp list)
+             | Cforce num
              | Clog lop exp
              | Cif exp exp
              | Cmat_check ((pat # exp) list) v
@@ -393,6 +408,17 @@ Definition application_def:
        (case do_opapp vs of
           SOME (env,e) => (Estep (env, s, Exp e, c):estep_result)
         | NONE => Etype_error)
+   | Force =>
+      (case vs of
+         [Loc b n] => (
+            case dest_thunk [Loc b n] s of
+            | BadRef => Etype_error
+            | NotThunk => Etype_error
+            | IsThunk Evaluated v => return env s v c
+            | IsThunk NotEvaluated f =>
+                return env s f
+                  ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c))
+        | _ => Etype_error)
    | _ =>
        case op of
        | FFI n => (
@@ -419,6 +445,14 @@ Definition continue_def:
   continue s v ((Chandle pes, env)::c) = return env s v c ∧
   continue s v ((Capp op vs [], env) :: c) = application op env s (v::vs) c ∧
   continue s v ((Capp op vs (e::es), env) :: c) = push env s e (Capp op (v::vs) es) c ∧
+  continue s v ((Cforce n, env) :: c) = (
+    case dest_thunk [v] s of
+    | BadRef => Etype_error
+    | NotThunk => (
+        case store_assign n (Thunk Evaluated v) s of
+        | SOME s' => return env s' v c
+        | NONE => Etype_error)
+    | IsThunk v3 v4 => Etype_error) ∧
   continue s v ((Clog l e, env) :: c) = (
     case do_log l v e of
       SOME (Exp e) => Estep (env, s, Exp e, c)
diff --git a/semantics/alt_semantics/proofs/bigClockScript.sml b/semantics/alt_semantics/proofs/bigClockScript.sml
index 8d3fc867cb..9b42c6f429 100644
--- a/semantics/alt_semantics/proofs/bigClockScript.sml
+++ b/semantics/alt_semantics/proofs/bigClockScript.sml
@@ -36,10 +36,9 @@ Theorem big_unclocked_unchanged[local]:
      SND r1 ≠ Rerr (Rabort Rtimeout_error) ∧
      s.clock = (FST r1).clock)
 Proof
-  ho_match_mp_tac evaluate_ind >> rw [] >>
-  fs[do_app_cases] >>
-  rw [] >> fs [] >>
-  every_case_tac >> fs[] >> rveq >> fs[]
+  ho_match_mp_tac evaluate_ind \\ rw []
+  \\ gvs [AllCaseEqs()]
+  \\ gvs [do_app_cases,AllCaseEqs(),oneline thunk_op_def,store_alloc_def]
 QED
 
 Triviality lemma:
@@ -126,7 +125,40 @@ Proof
        qexists_tac ‘vs’ >>
        qexists_tac `s2 with clock := count'` >>
        rw[] >>
-       NO_TAC) >>
+       NO_TAC)
+  >>~ [‘dest_thunk’]
+  >- metis_tac[]
+  >- metis_tac[]
+  >- metis_tac[]
+  >- metis_tac[]
+  >- (
+    ntac 3 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[]
+    )
+  >- (
+    ntac 3 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[]
+    )
+  >- (
+    ntac 4 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    first_x_assum $ irule_at Any >> simp[]
+    )
+  >- (
+    ntac 4 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    first_x_assum $ irule_at Any >> simp[]
+    )
+  >- (
+    disj2_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    last_x_assum $ irule_at Any >> simp[]
+    )
+  >- (
+    disj2_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    last_x_assum $ irule_at Any >> simp[]
+    ) >>
   rfs [] >>
   metis_tac [with_clock_refs]
 QED
@@ -185,7 +217,25 @@ Proof
   TRY (qexists_tac ‘s2 with clock := extra + s2.clock’ >> qexists_tac ‘v’ >>
        gs[state_component_equality] >> NO_TAC) >>
   TRY (qexists_tac ‘s2 with clock := extra + s2.clock’ >>
-       gs[state_component_equality] >> NO_TAC) >>
+       gs[state_component_equality] >> NO_TAC)
+  >>~ [‘ThunkOp ForceThunk’]
+  >- (
+    ntac 3 disj2_tac >> disj1_tac >>
+    first_assum(match_exists_tac o (snd o strip_forall o concl)) >>
+    simp[]
+    )
+  >- (
+    ntac 4 disj2_tac >> disj1_tac >>
+    first_assum(match_exists_tac o (snd o strip_forall o concl)) >>
+    simp[] >>
+    first_assum(match_exists_tac o (snd o strip_forall o concl)) >>
+    simp[]
+    )
+  >- (
+    disj2_tac >>
+    last_x_assum $ qspec_then ‘extra’ $ irule_at Any >> simp[] >>
+    first_x_assum $ qspec_then ‘extra’ $ irule_at Any >> simp[]
+    ) >>
   disj1_tac >>
   CONV_TAC(STRIP_QUANT_CONV(move_conj_left(same_const``evaluate_list`` o fst o strip_comb))) >>
   first_assum(match_exists_tac o (snd o strip_forall o concl)) >>
@@ -247,7 +297,27 @@ Proof
   TRY (
     srw_tac[DNF_ss][] >>
     rewrite_tac[ CONJ_ASSOC] >> once_rewrite_tac [CONJ_COMM] >>
-    first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC) >>
+    first_assum(match_exists_tac o concl) >> simp[] >> NO_TAC)
+  >>~ [‘ThunkOp ForceThunk’]
+  >- (
+    gvs[] >> ntac 4 disj2_tac >> disj1_tac >>
+    dxrule $ cj 2 add_to_counter >> simp[] >>
+    disch_then $ qspec_then ‘c' + 1’ assume_tac >>
+    goal_assum drule >> simp[]
+    )
+  >- (
+    gvs[] >> ntac 4 disj2_tac >> disj1_tac >>
+    dxrule $ cj 2 add_to_counter >> simp[] >>
+    disch_then $ qspec_then ‘c' + 1’ assume_tac >>
+    rpt (goal_assum drule >> simp[])
+    )
+  >- (
+    gvs[] >> disj2_tac >>
+    dxrule $ cj 2 add_to_counter >> simp[] >>
+    disch_then $ qspec_then ‘c' + 1’ assume_tac >>
+    goal_assum $ drule_at Any >> simp[] >>
+    goal_assum $ drule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[]
+    ) >>
   metis_tac [add_to_counter, with_clock_with_clock, with_clock_clock,
              arithmeticTheory.ADD_COMM, arithmeticTheory.ADD_0, with_clock_refs,
              result_distinct, error_result_distinct, result_11]
@@ -519,11 +589,31 @@ Proof
           `s2.clock-1 < s2.clock` by srw_tac [ARITH_ss] [] >>
           metis_tac [pair_CASES, clock_monotone, LESS_OR_EQ,
                      LESS_TRANS, with_clock_clock]) >>
+      Cases_on ‘o' = ThunkOp ForceThunk’ >> gvs[]
+      >- ( (* Force *)
+        simp[opClass_cases] >> gvs[SF DNF_ss] >>
+        Cases_on ‘dest_thunk (REVERSE v) s2.refs’ >- metis_tac[] >- metis_tac[] >>
+        ntac 2 disj2_tac >>
+        Cases_on ‘t’ >> gvs[] >- metis_tac[] >>
+        rename1 ‘IsThunk _ f’ >>
+        Cases_on ‘do_opapp [f; Conv NONE []]’ >- metis_tac[] >>
+        rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >>
+        ntac 2 disj2_tac >>
+        Cases_on ‘s2.clock = 0’ >- metis_tac[] >>
+        disj2_tac >>
+        last_x_assum $ qspec_then ‘s2.clock - 1’ mp_tac >>
+        last_x_assum kall_tac >> impl_tac
+        >- (imp_res_tac clock_monotone >> gvs[]) >>
+        disch_then $ qspecl_then [‘env_e1’,‘env_e0’,‘s2’] $
+          qx_choosel_then [‘s3’,‘res’] assume_tac >>
+        reverse $ Cases_on ‘res’ >- metis_tac[] >>
+        disj2_tac >> Cases_on ‘update_thunk (REVERSE v) s3.refs [a]’ >> metis_tac[]
+        ) >>
       `(do_app (s2.refs,s2.ffi) o' (REVERSE v) = NONE) ∨
        (?s3 e2. do_app (s2.refs,s2.ffi) o' (REVERSE v) = SOME (s3,e2))`
         by metis_tac [optionTheory.option_nchotomy, pair_CASES]
       >- (rename [‘op ≠ Opapp’] >>
-          ‘¬opClass op FunApp’ by simp[opClass_cases] >> simp[] >>
+          ‘¬opClass op FunApp ∧ ¬opClass op Force’ by simp[opClass_cases] >> simp[] >>
           metis_tac[]) >>
       cases_on ‘opClass o' Simple’ >> gs[] >- metis_tac [pair_CASES]  >>
       ‘opClass o' EvalOp’ by (Cases_on ‘o'’ >> TRY (gs[opClass_cases] >> NO_TAC)) >>
@@ -633,7 +723,8 @@ Proof
   rw [] >>
   fs [] >>
   every_case_tac >> fs[] >> rveq >> fs[] >>
-  gs[] >> every_case_tac >> gs[]
+  gs[] >> every_case_tac >> gs[] >>
+  gvs[thunk_op_def, AllCaseEqs(), store_alloc_def]
 QED
 
 Theorem big_clocked_unclocked_equiv_timeout:
@@ -702,7 +793,34 @@ Proof
   >- metis_tac [pair_CASES, FST, clock_monotone, DECIDE “y + z ≤ x ⇒ (x = (x - z) + z:num)”] >~
   [‘opClass op Simple (* a *)’]
   >- (‘¬opClass op FunApp’ by gs[opClass_cases] >> simp[] >> disj1_tac >>
-      first_assum $ irule_at (Pat ‘evaluate_list _ _ _ _ _ ’) >> simp[]) >>
+      first_assum $ irule_at (Pat ‘evaluate_list _ _ _ _ _ ’) >> simp[])
+  >>~ [‘ThunkOp ForceThunk’]
+  >- simp[SF SFY_ss]
+  >- simp[SF SFY_ss]
+  >- simp[SF SFY_ss]
+  >- simp[SF SFY_ss]
+  >- simp[SF SFY_ss]
+  >- (
+    ntac 8 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    first_x_assum $ irule_at Any >> simp[] >>
+    qexists ‘s2.clock - extra’ >> simp[] >>
+    imp_res_tac clock_monotone >> gvs[]
+    )
+  >- (
+    ntac 7 disj2_tac >> disj1_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    first_x_assum $ irule_at Any >> simp[] >>
+    qexists ‘s2.clock - extra’ >> simp[] >>
+    imp_res_tac clock_monotone >> gvs[]
+    )
+  >- (
+    rpt disj2_tac >>
+    last_x_assum $ irule_at Any >> simp[] >>
+    first_x_assum $ irule_at $ Pat ‘evaluate _ _ _ _ _’ >> simp[] >>
+    qexists ‘s2.clock - extra’ >> simp[] >>
+    imp_res_tac clock_monotone >> gvs[]
+    ) >>
   metis_tac [pair_CASES, FST, clock_monotone, DECIDE “y + z ≤ x ⇒ (x = (x - z) + z:num)”,
              with_clock_refs]
 QED
diff --git a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml
index 8b0f7bb765..eb9cd5ce0f 100644
--- a/semantics/alt_semantics/proofs/bigSmallEquivScript.sml
+++ b/semantics/alt_semantics/proofs/bigSmallEquivScript.sml
@@ -43,6 +43,12 @@ Proof
   rw[do_opapp_def] >> ntac 3 (TOP_CASE_TAC >> gvs[])
 QED
 
+Triviality opClass_op_Force[simp]:
+  opClass op Force ⇔ op = ThunkOp ForceThunk
+Proof
+  Cases_on ‘op’ >> gvs[opClass_cases]
+QED
+
 val s = ``s:'ffi state``;
 val _ = temp_delsimps["getOpClass_def"]
 
@@ -258,7 +264,7 @@ Proof
     gvs[] >> Cases_on ‘es’ using SNOC_CASES >> gvs[]
     >- (
       gvs[Once small_eval_list_cases, to_small_st_def,
-          do_app_def, AllCaseEqs(), store_alloc_def] >>
+          do_app_def, AllCaseEqs(), store_alloc_def,thunk_op_def] >>
       simp[small_eval_def] >> irule_at Any RTC_SUBSET >>
       simp[e_step_reln_def, e_step_def, application_thm, do_app_def,
            store_alloc_def, return_def]
@@ -321,6 +327,242 @@ Proof
       simp[e_step_def, continue_def, application_thm, to_small_st_def]
       )
     )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES >>
+    gvs[Once small_eval_list_cases, oneline dest_thunk_def, AllCaseEqs()] >>
+    gvs[Once small_eval_list_cases, small_eval_def] >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, push_def] >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_def, continue_def, application_def, getOpClass_def, to_small_st_def,
+         dest_thunk_def]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      simp[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      simp[e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >>
+    irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[REVERSE_APPEND, oneline dest_thunk_def, AllCaseEqs(), to_small_st_def]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      simp[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+      simp[e_step_def, continue_def, application_def, getOpClass_def]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >>
+    irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+    simp[e_step_def, continue_def, application_def, getOpClass_def]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      simp[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >>
+    irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      irule_at Any small_eval_prefix >>
+      dxrule_at Any small_eval_err_add_ctxt >> simp[] >>
+      disch_then $ irule_at Any >>
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      irule_at Any RTC_RTC >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+      irule_at Any RTC_SUBSET >>
+      simp[e_step_reln_def, e_step_def, continue_def, application_def, getOpClass_def]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    irule_at Any small_eval_prefix >>
+    dxrule_at Any small_eval_err_add_ctxt >> simp[] >>
+    disch_then $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, e_step_def, push_def] >> TOP_CASE_TAC >> gvs[] >>
+    irule_at Any RTC_RTC >> pop_assum $ irule_at Any >>
+    irule_at Any RTC_RTC >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[REVERSE_APPEND, oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+    irule_at Any RTC_SUBSET >>
+    simp[e_step_reln_def, e_step_def, continue_def, application_def, getOpClass_def]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      simp[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      irule_at Any RTC_RTC >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[small_eval_def] >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      simp[e_step_def, continue_def] >> gvs[update_thunk_def, AllCaseEqs()]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >>
+    irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any RTC_RTC >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[small_eval_def] >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_reln_def, Once e_step_def, continue_def] >>
+    gvs[update_thunk_def, AllCaseEqs()]
+    )
+  >- (
+    gvs[] >> Cases_on ‘es’ using SNOC_CASES
+    >- (
+      gvs[Once small_eval_list_cases, dest_thunk_def, to_small_st_def] >>
+      simp[small_eval_def] >> irule_at Any RTC_REFL >>
+      simp[e_step_def, application_def, getOpClass_def]
+      ) >>
+    Cases_on ‘l’ >> gvs[REVERSE_SNOC]
+    >- (
+      ntac 2 $ gvs[Once small_eval_list_cases] >>
+      simp[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, push_def] >>
+      irule_at Any RTC_RTC >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+      irule_at Any $ cj 2 RTC_RULES >>
+      simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+      gvs[small_eval_def] >>
+      irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+      dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+      simp[e_step_reln_def, e_step_def, continue_def, return_def] >>
+      gvs[update_thunk_def, AllCaseEqs()]
+      ) >>
+    last_x_assum mp_tac >> once_rewrite_tac[GSYM APPEND] >>
+    rewrite_tac[small_eval_list_Rval_APPEND] >> strip_tac >> gvs[] >>
+    rev_dxrule e_step_to_App_mid >>
+    disch_then $ qspecl_then [‘h’,‘[]’,‘ThunkOp ForceThunk’,‘[]’] assume_tac >> gvs[] >>
+    simp[small_eval_def] >> irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, REVERSE_SNOC, push_def] >>
+    irule_at Any RTC_RTC >> first_x_assum $ irule_at Any >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any RTC_RTC >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_st_def] >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, application_def, getOpClass_def] >>
+    gvs[small_eval_def] >>
+    irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_reln_def, Once e_step_def, continue_def, return_def] >>
+    gvs[update_thunk_def, AllCaseEqs()]
+    )
   >- (
     gvs[small_eval_def] >> Cases_on ‘es’ using SNOC_CASES >> gvs[]
     >- (
@@ -621,13 +863,38 @@ Proof
       simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss, opClass_cases])
   >- (disj2_tac >> disj1_tac >>
       simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss, opClass_cases])
-  >- (‘~ opClass op FunApp’
+  >- (‘~ opClass op FunApp ∧ ¬ opClass op Force’
          by (Cases_on ‘op’ >> gs[opClass_cases]) >>
       gs[] >>
       disj1_tac >> irule_at Any EQ_REFL >>
-      simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss])
-  >- (gs[] >> disj2_tac >> disj1_tac >>
-      simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss])
+      rpt (goal_assum drule))
+  >- simp[SF SFY_ss]
+  >- (
+    disj2_tac >> disj1_tac >> simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]
+    )
+  >- (
+    ntac 2 disj2_tac >> disj1_tac >>
+    simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]
+    )
+  >- simp[SF SFY_ss]
+  >- simp[SF SFY_ss]
+  >- (
+    ntac 4 disj2_tac >> disj1_tac >>
+    simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]
+    )
+  >- (
+    ntac 4 disj2_tac >> disj1_tac >>
+    simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]
+    )
+  >- (
+    disj2_tac >>
+    simp[Once evaluate_cases, PULL_EXISTS] >>
+    irule_at Any EQ_REFL >> simp[SF SFY_ss]
+    )
+  >- (
+    disj2_tac >> disj1_tac >>
+    simp[Once evaluate_cases, PULL_EXISTS, SF SFY_ss]
+    )
   >- (rpt disj2_tac >> simp[Once evaluate_cases, SF SFY_ss])
 QED
 
@@ -662,6 +929,7 @@ Proof
         gvs[AllCaseEqs(), store_alloc_def, return_def] >>
         simp[Once evaluate_state_cases] >> gvs[Once evaluate_state_cases, getOpClass_def] >>
         goal_assum $ dxrule_at Any >> ntac 2 $ simp[Once evaluate_cases, opClass_cases] >>
+        gvs[AllCaseEqs(), thunk_op_def] >>
         simp[do_app_def, store_alloc_def] >> irule_at Any EQ_REFL
         ) >>
       gvs[SWAP_REVERSE_SYM] >> metis_tac[evaluate_state_app_cons]
@@ -678,28 +946,51 @@ Proof
       rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >>
       once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >>
       every_case_tac >> gvs[SF DNF_ss, SF SFY_ss]
-      >- (‘opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >>
-          ‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases]) >>
-          gs[] >>
-          disj1_tac >> qexists_tac `clk + 1` >> simp[SF SFY_ss])
-      >- (‘opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >>
-          ‘~ opClass op Simple’ by (Cases_on ‘op’ >> gs[opClass_cases]) >>
-          gs[] >> first_x_assum $ irule_at Any >> gs[])
+      >- (
+        gvs[getOpClass_opClass] >>
+        ‘op ≠ ThunkOp ForceThunk’ by gvs[opClass_cases] >> simp[] >>
+        disj1_tac >> qexists_tac `clk + 1` >> simp[SF SFY_ss]
+        )
+      >- (
+        gvs[getOpClass_opClass] >>
+        ‘op ≠ ThunkOp ForceThunk’ by gvs[opClass_cases] >> simp[] >>
+        first_x_assum $ irule_at Any >> gvs[]
+        )
       )
     >- (
-      rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >>
+      rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[]
+      >~ [‘getOpClass op = Force’]
+      >- (
+        ‘¬opClass op FunApp ∧ ¬opClass op Simple ∧ op = ThunkOp ForceThunk’
+          by gvs[getOpClass_opClass, opClass_cases] >>
+        simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()]
+        >- (
+          ntac 3 disj2_tac >> disj1_tac >> simp[Once evaluate_cases, SF SFY_ss]
+          ) >>
+        once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >>
+        gvs[evaluate_ctxts_cons] >>
+        gvs[evaluate_ctxt_cases, update_thunk_def, AllCaseEqs(), SF SFY_ss] >>
+        gvs[Once $ cj 2 evaluate_cases] >>
+        gvs[opClass_cases] >> metis_tac[]
+        ) >>
       once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >>
       every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >>
       Cases_on ‘op’ >>
-      gs[do_app_def, getOpClass_def, opClass_cases] >>
+      gs[do_app_def, getOpClass_def, opClass_cases, AllCaseEqs()] >>
       gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, SF SFY_ss]
       )
     >- (
-      rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[] >>
+      rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >> gs[]
+      >~ [‘getOpClass op = Force’]
+      >- (
+        ‘¬opClass op FunApp ∧ ¬opClass op Simple ∧ op = ThunkOp ForceThunk’
+          by gvs[getOpClass_opClass, opClass_cases] >>
+        simp[SF DNF_ss, GSYM DISJ_ASSOC] >> gvs[AllCaseEqs()]
+        ) >>
       once_rewrite_tac[cj 2 evaluate_cases] >> simp[] >>
       every_case_tac >> gvs[SF DNF_ss, SF SFY_ss] >>
       Cases_on ‘op’ >>
-      gs[do_app_def, getOpClass_def, opClass_cases] >>
+      gs[do_app_def, getOpClass_def, opClass_cases, AllCaseEqs()] >>
       gvs[evaluate_ctxts_cons] >> gvs[evaluate_ctxt_cases, SF SFY_ss]
       )
     >~ [`evaluate_match`]
@@ -765,13 +1056,20 @@ Proof
           gs[getOpClass_opClass]
           >- (Cases_on ‘op’ >> gs[getOpClass_def, to_small_st_def, do_app_def] >>
               simp[opClass_cases] >> simp[evaluate_list_NIL] >>
-              qexists_tac ‘s.clock’ >> gs[state_component_equality])
-          >- (gs[AllCaseEqs()] >>
+              qexists_tac ‘s.clock’ >> gs[state_component_equality] >>
+              gvs[AllCaseEqs()])
+          >- (
+              gs[AllCaseEqs()] >>
               ‘~ opClass op Simple’
                 by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def]) >>
               simp[evaluate_list_NIL] >>
-              qexists_tac ‘s.clock’ >> gs[state_component_equality])
-          >- (‘~ opClass op FunApp’
+              qexists ‘s.clock’ >> gvs[state_component_equality]
+              )
+          >- (
+            simp[evaluate_list_NIL, dest_thunk_def] >>
+            simp[state_component_equality]
+            )
+          >- (‘~ opClass op FunApp ∧ ¬ opClass op Force’
                 by (Cases_on ‘op’ >> gs[opClass_cases]) >>
               gs[AllCaseEqs(), evaluate_list_NIL, to_small_st_def, return_def]
               >- (qexists_tac ‘s.clock’ >> gs[state_component_equality]) >>
@@ -785,23 +1083,30 @@ Proof
   every_case_tac >>
   full_simp_tac(srw_ss())[evaluate_state_cases, push_def, return_def] >>
   srw_tac[][evaluate_ctxts_cons, evaluate_ctxt_cases, to_small_st_def] >>
-  srw_tac[][PULL_EXISTS] (* 15 *)
+  srw_tac[][PULL_EXISTS] (* 20 *)
   >- (
     full_simp_tac(srw_ss())[application_thm] >>
     rename1 ‘getOpClass op’ >> Cases_on ‘getOpClass op’ >>
-    gs[getOpClass_opClass] (* 3 *)
+    gs[getOpClass_opClass] (* 5 *)
     >- (Cases_on ‘op’ >> gs[getOpClass_def, to_small_st_def, do_app_def] >>
         rveq >> gs[opClass_cases] >> qexists_tac ‘s.clock’ >>
         simp[Once evaluate_cases] >>
         irule_at Any evaluate_ctxts_type_error_matchable >>
-        gs[state_component_equality])
+        gs[state_component_equality] >>
+        gvs[AllCaseEqs()])
     >- (‘~ opClass op Simple’
           by (Cases_on ‘op’ >> gs[opClass_cases]) >>
         every_case_tac >> gs[] >>
         qexists_tac ‘s.clock’ >> simp[evaluate_list_NIL] >>
-        irule evaluate_ctxts_type_error_matchable >>
+        irule_at Any evaluate_ctxts_type_error_matchable >>
         gs[state_component_equality])
-    >- (‘~ opClass op FunApp’
+    >- (
+      simp[evaluate_list_NIL] >>
+      irule_at Any evaluate_ctxts_type_error_matchable >>
+      gvs[AllCaseEqs(), dest_thunk_def] >>
+      gvs[state_component_equality, to_small_st_def]
+      )
+    >- (‘~ opClass op FunApp ∧ ¬opClass op Force’
           by (Cases_on ‘op’ >> gs[opClass_cases]) >>
         gs[] >>
         qexists_tac ‘s.clock’ >> simp[evaluate_list_NIL] >>
@@ -1456,7 +1761,7 @@ Proof
       gvs[Once small_eval_list_cases, to_small_res_def] >>
       last_x_assum $ assume_tac o GSYM >> simp[SF SFY_ss]
       ) >>
-    Cases_on ‘op’ >> gs[getOpClass_def] >>
+    Cases_on ‘op’ >> gs[getOpClass_def, AllCaseEqs()] >>
     gvs[to_small_res_def] >> dxrule e_step_over_App_Opapp >>
     disch_then $ qspecl_then [`env'`,`e`,`[]`] assume_tac >> gvs[] >>
     simp[Once RTC_CASES_RTC_TWICE, SF SFY_ss]
@@ -1471,13 +1776,43 @@ Proof
       gvs[Once small_eval_list_cases, to_small_res_def] >>
       last_x_assum $ assume_tac o GSYM >> simp[] >> irule_at Any $ cj 1 RTC_rules
       ) >>
-    Cases_on ‘op’ >> gs[getOpClass_def] >>
+    Cases_on ‘op’ >> gs[getOpClass_def, AllCaseEqs()] >>
     gvs[to_small_res_def] >> dxrule e_step_over_App_Opapp >>
     disch_then $ qspecl_then [`env'`,`e`,`[]`] assume_tac >> gvs[SF SFY_ss]
     )
   >- ( (* App - do_app timeout *)
     drule do_app_not_timeout >> simp[]
     )
+  >- ( (* Force - timeout *)
+    dxrule big_clocked_to_unclocked_list >> rw[] >>
+    dxrule $ cj 2 big_exp_to_small_exp >> rw[] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >>
+    imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any $ cj 2 RTC_rules >>
+    simp[e_step_reln_def, e_step_def, push_def, application_thm] >>
+    irule_at Any $ cj 2 RTC_RULES_RIGHT1 >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >>
+    gvs[dest_thunk_def, to_small_st_def]
+    )
+  >- ( (* Force *)
+    dxrule big_clocked_to_unclocked_list >> rw[] >>
+    dxrule $ cj 2 big_exp_to_small_exp >> rw[] >>
+    gvs[oneline dest_thunk_def, AllCaseEqs(), to_small_res_def] >>
+    imp_res_tac small_eval_list_length >> gvs[LENGTH_EQ_NUM_compute] >>
+    ntac 2 $ gvs[Once small_eval_list_cases] >>
+    irule_at Any $ cj 2 RTC_rules >>
+    simp[e_step_reln_def, e_step_def, push_def, application_thm] >>
+    irule_at Any RTC_RTC >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >>
+    gvs[dest_thunk_def, to_small_st_def] >>
+    irule_at Any $ cj 2 RTC_RULES >>
+    simp[e_step_reln_def, e_step_def, continue_def, application_thm, getOpClass_def] >>
+    dxrule e_step_add_ctxt >> simp[] >> disch_then $ irule_at Any
+    )
   >- ( (* App - before application *)
     irule_at Any $ cj 2 RTC_rules >>
     simp[e_step_reln_def, e_step_def, push_def, application_thm] >>
@@ -1907,11 +2242,31 @@ Proof
       ) >>
     Cases_on ‘opClass op Simple’ >> gvs[]
     >- (
+      ‘op ≠ ThunkOp ForceThunk’ by (Cases_on ‘op’ >> gvs[opClass_cases]) >> simp[] >>
       Cases_on ‘do_app (r0.refs,r0.ffi) op (REVERSE a ++ [v] ++ l)’ >> gvs[SF SFY_ss] >>
-      PairCases_on ‘x’ >> gvs[SF SFY_ss]) >>
+      PairCases_on ‘x’ >> gvs[SF SFY_ss]
+      ) >>
+    Cases_on ‘opClass op Force’ >> gvs[]
+    >- (
+      rename1 ‘evaluate_list _ _ _ _ (s2,Rval vs2)’ >>
+      Cases_on ‘dest_thunk (REVERSE vs2 ++ [v] ++ l) s2.refs’ >> gvs[SF SFY_ss] >>
+      rename1 ‘IsThunk t f’ >> Cases_on ‘t’ >> gvs[SF SFY_ss] >>
+      Cases_on ‘do_opapp [f; Conv NONE []]’ >> gvs[SF SFY_ss] >>
+      rename1 ‘SOME env_e’ >> PairCases_on ‘env_e’ >>
+      Cases_on ‘s2.clock = 0’ >> gvs[SF SFY_ss] >>
+      qspecl_then [‘s2 with clock := s2.clock - 1’,‘env_e0’,‘env_e1’]
+        assume_tac big_clocked_total >> gvs[] >>
+      rename1 ‘evaluate _ _ _ _ (s3, res)’ >>
+      Cases_on ‘res’ >> gvs[SF SFY_ss] >> rename1 ‘Rval v'’ >>
+      Cases_on ‘update_thunk (REVERSE vs2 ++ [v] ++ l) s3.refs [v']’ >> gvs[SF SFY_ss]
+      ) >>
     Cases_on ‘op’ >> gs[opClass_cases, do_app_def] >> disj1_tac >>
     first_x_assum $ irule_at Any >> every_case_tac >> gvs[SF SFY_ss]
   )
+  >- (
+    Cases_on ‘dest_thunk [v] s.refs’ >> gvs[] >>
+    Cases_on ‘store_assign n (Thunk Evaluated v) s.refs’ >> gvs[]
+    )
   >- (
     Cases_on ‘do_log l v e’ >> gvs[] >> Cases_on ‘x’ >> gvs[] >>
     metis_tac[big_clocked_total]
diff --git a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml
index d4ebad4f95..06902a4028 100644
--- a/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml
+++ b/semantics/alt_semantics/proofs/bigSmallInvariantsScript.sml
@@ -42,7 +42,68 @@ Inductive evaluate_ctxt:
       ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
           (s2 with <| ffi := new_ffi; refs := new_refs |>, res)) ∧
 
-  ((~opClass op FunApp) ∧
+  (opClass op Force ∧
+   evaluate_list ck env s1 es (s2, Rval vs2) ∧
+   (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = BadRef ∨
+    dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = NotThunk ∨
+    (dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧
+     do_opapp [f; Conv NONE []] = NONE))
+    ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
+        (s2, Rerr (Rabort Rtype_error))) ∧
+
+  (opClass op Force ∧
+   evaluate_list ck env s1 es (s2, Rval vs2) ∧
+   dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk Evaluated v'
+    ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v (s2, Rval v')) ∧
+
+  (opClass op Force ∧
+   evaluate_list T env s1 es (s2, Rval vs2) ∧
+   dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧
+   do_opapp [f; Conv NONE []] = SOME env_e ∧
+   s2.clock = 0
+    ⇒ evaluate_ctxt T env s1 (Capp op vs1 () es) v
+        (s2, Rerr (Rabort Rtimeout_error))) ∧
+
+  (opClass op Force ∧
+   evaluate_list ck env s1 es (s2, Rval vs2) ∧
+   dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧
+   do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+   (ck ⇒ s2.clock ≠ 0) ∧
+   evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rerr err)
+    ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
+        (s3, Rerr err)) ∧
+
+  (opClass op Force ∧
+   evaluate_list ck env s1 es (s2, Rval vs2) ∧
+   dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧
+   do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+   (ck ⇒ s2.clock ≠ 0) ∧
+   evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧
+   update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = NONE
+    ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
+        (s3, Rerr (Rabort Rtype_error))) ∧
+
+  (opClass op Force ∧
+   evaluate_list ck env s1 es (s2, Rval vs2) ∧
+   dest_thunk (REVERSE vs2 ++ [v] ++ vs1) s2.refs = IsThunk NotEvaluated f ∧
+   do_opapp [f; Conv NONE []] = SOME (env', e) ∧
+   (ck ⇒ s2.clock ≠ 0) ∧
+   evaluate ck env' (if ck then (s2 with clock := s2.clock - 1) else s2) e (s3, Rval v') ∧
+   update_thunk (REVERSE vs2 ++ [v] ++ vs1) s3.refs [v'] = SOME refs
+    ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
+        (s3 with refs := refs, Rval v')) ∧
+
+  (dest_thunk [v] s1.refs = BadRef ∨
+   dest_thunk [v] s1.refs = IsThunk a b ∨
+   (dest_thunk [v] s1.refs = NotThunk ∧
+    store_assign loc (Thunk Evaluated v) s1.refs = NONE)
+    ⇒ evaluate_ctxt ck env s1 (Cforce loc) v (s1, Rerr (Rabort Rtype_error))) ∧
+
+  (dest_thunk [v] s1.refs = NotThunk ∧
+   store_assign loc (Thunk Evaluated v) s1.refs = SOME refs
+    ⇒ evaluate_ctxt ck env s1 (Cforce loc) v (s1 with refs := refs, Rval v)) ∧
+
+  ((~opClass op FunApp ∧ ¬ opClass op Force) ∧
    evaluate_list ck env s1 es (s2, Rval vs2) ∧
    do_app (s2.refs, s2.ffi) op (REVERSE vs2 ++ [v] ++ vs1) = NONE
       ⇒ evaluate_ctxt ck env s1 (Capp op vs1 () es) v
diff --git a/semantics/alt_semantics/proofs/bigStepPropsScript.sml b/semantics/alt_semantics/proofs/bigStepPropsScript.sml
index 0f96ad76ee..6e1ef2720b 100644
--- a/semantics/alt_semantics/proofs/bigStepPropsScript.sml
+++ b/semantics/alt_semantics/proofs/bigStepPropsScript.sml
@@ -31,6 +31,14 @@ Proof
   srw_tac[][]
 QED
 
+Theorem opClass_11[simp]:
+  (opClass op Simple ⇒ ¬opClass op Force ∧ ¬opClass op FunApp) ∧
+  (opClass op Force ⇒ ¬opClass op Simple ∧ ¬opClass op FunApp) ∧
+  (opClass op FunApp ⇒ ¬opClass op Simple ∧ ¬opClass op Force)
+Proof
+  Cases_on ‘op’ >> gvs[opClass_cases]
+QED
+
 Theorem evaluate_ignores_types_exns_eval:
   (∀ck env ^st e r.
      evaluate ck env st e r ⇒
diff --git a/semantics/alt_semantics/proofs/determScript.sml b/semantics/alt_semantics/proofs/determScript.sml
index 7cb20b2eb3..06fe164aa0 100644
--- a/semantics/alt_semantics/proofs/determScript.sml
+++ b/semantics/alt_semantics/proofs/determScript.sml
@@ -38,7 +38,6 @@ Proof
   res_tac >>
   fs [] >>
   rw [] >>
-  ‘s with fp_state := s.fp_state = s’ by gs[state_component_equality] >>
   gs[] >> res_tac >> gs[] >>
   metis_tac []
 QED
diff --git a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml
index 28d9704153..249e85d299 100644
--- a/semantics/alt_semantics/proofs/funBigStepEquivScript.sml
+++ b/semantics/alt_semantics/proofs/funBigStepEquivScript.sml
@@ -62,7 +62,16 @@ Proof
     ntac 3 TOP_CASE_TAC >> gs[Excl"getOpClass_def"]
     >- prove_tac
     >- prove_tac
-    >- prove_tac) >>
+    >- (
+      qpat_x_assum ‘getOpClass _ = _’ kall_tac >>
+      simp[get_store_def] >>
+      TOP_CASE_TAC >> gvs[] >- prove_tac >- prove_tac >>
+      ntac 2 (TOP_CASE_TAC >> gvs[]) >- prove_tac >>
+      ntac 2 (TOP_CASE_TAC >> gvs[dec_clock_def]) >>
+      prove_tac
+      )
+    >- prove_tac
+    ) >>
   prove_tac
 QED
 
diff --git a/semantics/alt_semantics/proofs/interpScript.sml b/semantics/alt_semantics/proofs/interpScript.sml
index f7d852680e..85e684aa4a 100644
--- a/semantics/alt_semantics/proofs/interpScript.sml
+++ b/semantics/alt_semantics/proofs/interpScript.sml
@@ -138,12 +138,12 @@ val _ = temp_delsimps["getOpClass_def"]
 
 Theorem getOpClass_opClass:
   (getOpClass op = FunApp ⇔ opClass op FunApp) ∧
-  (getOpClass op = Simple ⇔ opClass op Simple)
+  (getOpClass op = Simple ⇔ opClass op Simple) ∧
+  (getOpClass op = Force ⇔ opClass op Force)
 Proof
-  Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]
+  Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases, AllCaseEqs()]
 QED
 
-
 Theorem run_eval_def:
   (!^st env l.
     run_eval env (Lit l)
@@ -207,6 +207,25 @@ Theorem run_eval_def:
                  do () <- dec_clock;
                     run_eval env' e3
                  od)
+        | Force =>
+            (case dest_thunk (REVERSE vs) st.refs of
+             | BadRef => raise (Rabort Rtype_error)
+             | NotThunk => raise (Rabort Rtype_error)
+             | IsThunk Evaluated v => return v
+             | IsThunk NotEvaluated f =>
+                case do_opapp [f; Conv NONE []] of
+                | SOME (env',e) => do
+                    () <- dec_clock;
+                    v2 <- run_eval env' e;
+                    ^st <- get_store;
+                    (case update_thunk (REVERSE vs) st.refs [v2] of
+                     | NONE => raise (Rabort Rtype_error)
+                     | SOME refs => do
+                        () <- set_store (st with refs := refs);
+                        return v2;
+                     od)
+                  od
+                | NONE => raise (Rabort Rtype_error))
         | Simple =>
             (case do_app (st.refs,st.ffi) op (REVERSE vs) of
              | NONE => raise (Rabort Rtype_error)
@@ -319,8 +338,17 @@ Proof
           rw [] >>
           rw [] >> fs[state_transformerTheory.UNIT_DEF] >>
           metis_tac [PAIR_EQ, pair_CASES, SND, FST, run_eval_spec]) >>
+      Cases_on ‘getOpClass op = Force’ >> gvs[]
+      >- (
+        gvs[getOpClass_opClass] >>
+        ‘¬opClass op FunApp ∧ ¬opClass op Simple’ by (Cases_on ‘op’ >> gvs[opClass_cases]) >>
+        simp[] >>
+        every_case_tac >> gvs[GSYM evaluate_run_eval_list, GSYM evaluate_run_eval] >>
+        gvs[LESS_OR_EQ] >> metis_tac[]
+        ) >>
       Cases_on ‘getOpClass op = Simple’ >> gs[]
-      >- (‘~ opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >>
+      >- (‘~ opClass op FunApp ∧ ¬opClass op Force’ by
+            (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases,AllCaseEqs()]) >>
           gs[getOpClass_opClass] >>
           every_case_tac >>
           rw [] >>
@@ -332,8 +360,9 @@ Proof
           rw [] >> fs[state_transformerTheory.UNIT_DEF] >>
           metis_tac [PAIR_EQ, pair_CASES, SND, FST, run_eval_spec]) >>
       ‘getOpClass op = EvalOp’
-        by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def]) >> gs[] >>
-      ‘~ opClass op FunApp’ by (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases]) >>
+        by (Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def,AllCaseEqs()]) >> gs[] >>
+      ‘~ opClass op FunApp’ by
+        (Cases_on ‘op’ >> gs[getOpClass_def, opClass_cases,AllCaseEqs()]) >>
       gs[] >> every_case_tac >> gs[remove_lambda_pair] >>
       fs [GSYM evaluate_run_eval_list] >>
       Cases_on ‘op’ >> gs[opClass_cases, getOpClass_def] >> gs[do_app_def]
diff --git a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml
index 16e76f824d..0edc1e831e 100644
--- a/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml
+++ b/semantics/alt_semantics/proofs/itree_semanticsEquivScript.sml
@@ -59,11 +59,15 @@ Proof
   rw[] >> reverse $ Cases_on `do_app (st,ffi) op vs` >> gvs[]
   >- (
     PairCases_on `x` >> gvs[semanticPrimitivesPropsTheory.do_app_cases] >>
-    simp[do_app_def, result_rel_cases] >> every_case_tac >> gvs[]
+    simp[do_app_def, result_rel_cases] >> every_case_tac >> gvs[] >>
+    gvs[semanticPrimitivesTheory.thunk_op_def, itree_semanticsTheory.thunk_op_def] >>
+    gvs[AllCaseEqs(), store_alloc_def]
     ) >>
   Cases_on `do_app st op vs` >> gvs[] >> PairCases_on `x` >>
   gvs[do_app_cases, semanticPrimitivesTheory.do_app_def, store_alloc_def] >>
-  every_case_tac >> gvs[]
+  every_case_tac >> gvs[] >>
+  gvs[semanticPrimitivesTheory.thunk_op_def, itree_semanticsTheory.thunk_op_def] >>
+  gvs[AllCaseEqs(), store_alloc_def]
 QED
 
 Theorem application_rel:
@@ -77,20 +81,29 @@ Proof
   drule do_app_rel >> disch_then $ qspecl_then [`vs`,`st`,`ffi`] assume_tac >>
   Cases_on ‘getOpClass op’
   >- (
-    Cases_on ‘op’ >> gs[getOpClass_def, application_def, cml_application_thm] >>
+    Cases_on ‘op’ >> gs[getOpClass_def, application_def, cml_application_thm]
+    >- gvs[AllCaseEqs()] >>
     simp[step_result_rel_cases, AllCaseEqs(), PULL_EXISTS] >>
     Cases_on ‘do_app (st,ffi) Eval vs’ >> gvs[] >>
     Cases_on ‘do_app st Eval vs’ >> gvs[] >>
     PairCases_on ‘x’ >> PairCases_on ‘x'’ >>
     gvs[result_rel_cases, SF smallstep_ss, SF itree_ss] >>
     gs[do_app_def, semanticPrimitivesTheory.do_app_def] >> every_case_tac >>
-    gs[])
+    gs[]
+    )
   >- (
     rw[application_def, cml_application_thm] >>
     simp[step_result_rel_cases, AllCaseEqs(), PULL_EXISTS] >>
     Cases_on `do_opapp vs` >> simp[] >>
     PairCases_on `x` >> simp[]
     )
+  >- (
+    gvs[oneline getOpClass_def, AllCaseEqs()] >>
+    simp[application_thm, cml_application_thm] >>
+    rpt (TOP_CASE_TAC >> gvs[step_result_rel_cases]) >>
+    simp[return_def] >> gvs[ctxt_rel_def] >>
+    simp[ctxt_frame_rel_cases]
+    )
   >- (
     rw[application_def, cml_application_thm] >>
     Cases_on `do_app (st,ffi) op vs` >> gvs[] >>
@@ -102,7 +115,8 @@ Proof
     gvs[result_rel_cases, SF smallstep_ss, SF itree_ss] >>
     gvs[step_result_rel_cases, AllCaseEqs(), ctxt_rel_def] >>
     simp[ctxt_frame_rel_cases] >>
-    gvs[do_app_def, AllCaseEqs(), store_alloc_def])
+    gvs[do_app_def, thunk_op_def, AllCaseEqs(), store_alloc_def]
+    )
 QED
 
 Theorem application_rel_FFI_type_error:
@@ -185,7 +199,7 @@ Proof
     gvs[estep_def, step_result_rel_cases] >> strip_tac >>
     gvs[SF smallstep_ss, SF itree_ss, ctxt_rel_def, ctxt_frame_rel_cases, get_ffi_def] >>
     gvs[GSYM ctxt_frame_rel_cases, GSYM step_result_rel_cases] >>
-    CASE_TAC >- gvs[continue_def, get_ffi_def] >>
+    TOP_CASE_TAC >- gvs[continue_def, get_ffi_def] >>
     PairCases_on `h` >> gvs[] >> PairCases_on `x` >> gvs[] >>
     rename1 `ctxt_frame_rel c1 c2` >> rename1 `(c1,env)` >>
     rename1 `LIST_REL _ rest1 rest2` >>
@@ -219,6 +233,7 @@ Proof
     >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases])
     >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases])
     >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases])
+    >- (EVERY_CASE_TAC >> gvs[get_ffi_def, ctxt_frame_rel_cases])
     >- (
       CASE_TAC >> simp[SF itree_ss] >>
       PairCases_on `h` >> simp[continue_def] >>
@@ -473,8 +488,9 @@ Theorem step_result_rel_single_FFI_error:
     Effi s conf ws lnum env (FST $ SND ea) (TL $ SND $ SND $ SND $ ea)
 Proof
   rpt $ PairCases >> rw[e_step_def] >> gvs[AllCaseEqs(), SF smallstep_ss] >>
-  gvs[cml_application_thm, AllCaseEqs(), SF smallstep_ss] >>
-  gvs[semanticPrimitivesPropsTheory.do_app_cases, AllCaseEqs()] >>
+  gvs[cml_application_thm, AllCaseEqs(), SF smallstep_ss, thunk_op_def] >>
+  gvs[semanticPrimitivesPropsTheory.do_app_cases,
+      semanticPrimitivesTheory.thunk_op_def, AllCaseEqs()] >>
   gvs[step_result_rel_cases, ctxt_rel_def] >>
   gvs[GSYM ctxt_rel_def, ctxt_frame_rel_cases] >> pairarg_tac >> gvs[] >>
   simp[SF itree_ss, application_def] >> gvs[call_FFI_def, AllCaseEqs()] >>
@@ -790,7 +806,8 @@ Theorem do_app_not_SharedMem:
 Proof
   rpt strip_tac >>
   gvs[DefnBase.one_line_ify NONE semanticPrimitivesTheory.do_app_def,
-    AllCaseEqs(),call_FFI_def] >>
+    AllCaseEqs(),call_FFI_def,store_alloc_def,
+    semanticPrimitivesTheory.thunk_op_def] >>
   rw[] >>
   pairarg_tac >> fs[]
 QED
diff --git a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml
index 7edc162cfa..a3e2353d97 100644
--- a/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml
+++ b/semantics/alt_semantics/proofs/itree_semanticsPropsScript.sml
@@ -66,6 +66,7 @@ Inductive ctxt_frame_rel:
   ctxt_frame_rel Craise (Craise ()) ∧
   ctxt_frame_rel (Chandle pes) (Chandle () pes) ∧
   ctxt_frame_rel (Capp op vs es) (Capp op vs () es) ∧
+  ctxt_frame_rel (Cforce n) (Cforce n) ∧
   ctxt_frame_rel (Clog lop e) (Clog lop () e) ∧
   ctxt_frame_rel (Cif e1 e2) (Cif () e1 e2) ∧
   ctxt_frame_rel (Cmat_check pes v) (Cmat_check () pes v) ∧
@@ -539,21 +540,35 @@ Theorem application_thm:
             | _ => Etype_error)
         | _ => Etype_error)
       | _ => ARB)
-    else
+    else (case getOpClass op of
+    | Force =>
+      (case vs of
+         [Loc b n] => (
+            case dest_thunk [Loc b n] s of
+            | BadRef => Etype_error
+            | NotThunk => Etype_error
+            | IsThunk Evaluated v => return env s v c
+            | IsThunk NotEvaluated f =>
+                return env s f
+                  ((Capp Opapp [Conv NONE []] [], env)::(Cforce n, env)::c))
+        | _ => Etype_error)
+    | _ =>
       case do_app s op vs of
       | NONE => Etype_error
       | SOME (v1,Rval v') => return env v1 v' c
-      | SOME (v1,Rraise v) => Estep (env,v1,Exn v,c)
+      | SOME (v1,Rraise v) => Estep (env,v1,Exn v,c))
 Proof
   rpt strip_tac >> Cases_on ‘getOpClass op’ >> gs[] >>
   TOP_CASE_TAC >> gs[application_def]
   >- (
-    Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >>
-    every_case_tac >> gs[])
-  >- (
-  Cases_on ‘op’ >> gs[application_def] >> every_case_tac >> gs[do_app_def] >>
+    Cases_on ‘op’ >> gs[application_def] >> every_case_tac >>
+    gs[itree_semanticsTheory.do_app_def] >>
+    every_case_tac >> gs[]) >>
+  Cases_on ‘op’ >> gs[application_def] >> every_case_tac >>
+  gs[itree_semanticsTheory.do_app_def, thunk_op_def] >>
   pop_assum $ mp_tac >>
-  rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def])
+  rpt (TOP_CASE_TAC >> gvs[SF itree_ss]) >> gs[store_alloc_def] >>
+  rpt (FULL_CASE_TAC >> gvs[store_alloc_def, store_assign_def])
 QED
 
 Theorem application_FFI_results:
diff --git a/semantics/alt_semantics/proofs/smallStepPropsScript.sml b/semantics/alt_semantics/proofs/smallStepPropsScript.sml
index aab02b6225..c3c0960719 100644
--- a/semantics/alt_semantics/proofs/smallStepPropsScript.sml
+++ b/semantics/alt_semantics/proofs/smallStepPropsScript.sml
@@ -705,11 +705,15 @@ Theorem small_eval_app_err:
 Proof
   ho_match_mp_tac small_eval_list_ind >> simp[] >> srw_tac[][] >>
   srw_tac[boolSimps.DNF_ss][Once RTC_CASES1,e_step_reln_def] >- (
-  srw_tac[][Once e_step_def,continue_def,application_thm] >>
+  srw_tac[][Once e_step_def,continue_def,application_thm,return_def] >>
   BasicProvers.CASE_TAC >>
   TRY BasicProvers.CASE_TAC >>
   Cases_on`s` >> fs[do_app_cases] >> rw[] >> fs[] >>
-  rpt TOP_CASE_TAC >> gs[do_app_cases]) >>
+  rpt TOP_CASE_TAC >> gs[do_app_cases] >>
+  (* ThunkOp cases *)
+  namedCases_on ‘v0’ ["", "hd tl"] >> gvs[] >> Cases_on ‘tl’ >> gvs[] >>
+  gvs[oneline thunk_op_def, AllCaseEqs()]
+  ) >>
   disj2_tac >>
   srw_tac[][Once e_step_def,continue_def,push_def] >>
   imp_res_tac e_step_add_ctxt >>
@@ -738,7 +742,11 @@ Proof
   BasicProvers.CASE_TAC >>
   TRY BasicProvers.CASE_TAC >>
   Cases_on`s` >> fs[do_app_cases] >> rw[] >> fs[] >>
-  rpt TOP_CASE_TAC >> gs[do_app_cases]) >>
+  rpt TOP_CASE_TAC >> gs[do_app_cases] >>
+  (* ThunkOp cases *)
+  namedCases_on ‘v0’ ["", "hd tl"] >> gvs[] >> Cases_on ‘tl’ >> gvs[] >>
+  gvs[oneline thunk_op_def, AllCaseEqs()]
+  ) >>
   disj2_tac >>
   srw_tac[][Once e_step_def,continue_def,push_def] >>
   imp_res_tac e_step_add_ctxt >>
diff --git a/semantics/alt_semantics/smallStepScript.sml b/semantics/alt_semantics/smallStepScript.sml
index 9c44435487..ab1ae92611 100644
--- a/semantics/alt_semantics/smallStepScript.sml
+++ b/semantics/alt_semantics/smallStepScript.sml
@@ -21,6 +21,7 @@ Datatype:
     Craise unit
   | Chandle unit ((pat # exp) list)
   | Capp op (v list) unit (exp list)
+  | Cforce num
   | Clog lop unit exp
   | Cif unit exp exp
   (* The value is raised if none of the patterns match *)
@@ -83,6 +84,17 @@ Definition application_def:
       (case do_opapp vs of
           SOME (env,e) => Estep (env, s, Exp e, c)
         | NONE => Eabort Rtype_error)
+     | Force => (
+        case vs of
+        | [Loc b n] => (
+            case dest_thunk [Loc b n] (FST s) of
+            | BadRef => Eabort Rtype_error
+            | NotThunk => Eabort Rtype_error
+            | IsThunk Evaluated v => Estep (env, s, Val v, c)
+            | IsThunk NotEvaluated f =>
+                Estep (env, s, Val f,
+                       (Capp Opapp [Conv NONE []] () [], env)::(Cforce n, env)::c))
+        | _ => Eabort Rtype_error)
      | _ =>
       (case do_app s op vs of
           SOME (s',r) =>
@@ -108,6 +120,14 @@ Definition continue_def:
         application op env s (v::vs) c
     | (Capp op vs ()  (e::es), env) :: c =>
         push env s e (Capp op (v::vs) ()  es) c
+    | (Cforce n, env) :: c => (
+        case dest_thunk [v] (FST s) of
+        | BadRef => Eabort Rtype_error
+        | NotThunk => (
+            case store_assign n (Thunk Evaluated v) (FST s) of
+            | SOME s' => return env (s', SND s) v c
+            | NONE => Eabort Rtype_error)
+        | IsThunk v3 v4 => Eabort Rtype_error)
     | (Clog l ()  e, env) :: c =>
         (case do_log l v e of
             SOME (Exp e) => Estep (env, s, Exp e, c)
diff --git a/semantics/astScript.sml b/semantics/astScript.sml
index 372d5fba09..a757e615b8 100644
--- a/semantics/astScript.sml
+++ b/semantics/astScript.sml
@@ -69,6 +69,17 @@ Datatype:
   word_size = W8 | W64
 End
 
+Datatype:
+  thunk_mode = Evaluated | NotEvaluated
+End
+
+Datatype:
+  thunk_op =
+    AllocThunk thunk_mode
+  | UpdateThunk thunk_mode
+  | ForceThunk
+End
+
 Datatype:
   op =
   (* Operations on integers *)
@@ -132,6 +143,8 @@ Datatype:
   | Aupdate_unsafe
   | Aw8sub_unsafe
   | Aw8update_unsafe
+  (* thunk operations *)
+  | ThunkOp thunk_op
   (* List operations *)
   | ListAppend
   (* Configure the GC *)
@@ -149,6 +162,7 @@ Datatype:
  op_class =
     EvalOp (* Eval primitive *)
   | FunApp (* function application *)
+  | Force (* forcing a thunk *)
   | Simple (* arithmetic operation, no finite-precision/reals *)
 End
 Definition getOpClass_def[simp]:
@@ -156,6 +170,7 @@ Definition getOpClass_def[simp]:
  case op of
   | Opapp => FunApp
   | Eval => EvalOp
+  | ThunkOp t => (if t = ForceThunk then Force else Simple)
   | _ => Simple
 End
 
diff --git a/semantics/evaluateScript.sml b/semantics/evaluateScript.sml
index cb41452150..8e05a164da 100644
--- a/semantics/evaluateScript.sml
+++ b/semantics/evaluateScript.sml
@@ -46,6 +46,11 @@ Proof
   Induct \\ fs [listTheory.list_size_def,listTheory.list_size_append]
 QED
 
+Definition sing_env_def:
+  sing_env n v =
+    <| v := nsBind n v nsEmpty; c := nsEmpty |> : v sem_env
+End
+
 Definition evaluate_def[nocompute]:
   evaluate st env [] = ((st:'ffi state),Rval [])
   ∧
@@ -97,13 +102,29 @@ Definition evaluate_def[nocompute]:
       FunApp =>
         (case do_opapp (REVERSE vs) of
           SOME (env',e) =>
-            if st'.clock =( 0 : num) then
+            if st'.clock = 0 then
               (st', Rerr (Rabort Rtimeout_error))
             else
               evaluate (dec_clock st') env'  [e]
         | NONE => (st', Rerr (Rabort Rtype_error))
         )
-     |EvalOp =>
+     | Force =>
+        (case dest_thunk (REVERSE vs) st'.refs of
+         | BadRef => (st', Rerr (Rabort Rtype_error))
+         | NotThunk => (st', Rerr (Rabort Rtype_error))
+         | IsThunk Evaluated v => (st', Rval [v])
+         | IsThunk NotEvaluated f =>
+            (case do_opapp [f; Conv NONE []] of
+             | SOME (env',e) =>
+                 if st'.clock = 0 then (st', Rerr (Rabort Rtimeout_error)) else
+                   (case evaluate (dec_clock st') env' [e] of
+                    | (st2, Rval vs2) =>
+                        (case update_thunk (REVERSE vs) st2.refs vs2 of
+                         | NONE => (st2, Rerr (Rabort Rtype_error))
+                         | SOME refs => (st2 with refs := refs, Rval vs2))
+                    | (st2, Rerr e) => (st2, Rerr e))
+             | NONE => (st', Rerr (Rabort Rtype_error))))
+     | EvalOp =>
         (case fix_clock st' (do_eval_res (REVERSE vs) st') of
           (st1, Rval (env1, decs)) =>
             if st1.clock = 0 then
diff --git a/semantics/lexer_funScript.sml b/semantics/lexer_funScript.sml
index c16257d395..4d272f1e94 100644
--- a/semantics/lexer_funScript.sml
+++ b/semantics/lexer_funScript.sml
@@ -134,14 +134,15 @@ Proof
   \\ REPEAT STRIP_TAC \\ POP_ASSUM MP_TAC
   \\ ONCE_REWRITE_TAC [read_string_def]
   \\ Cases_on `s` \\ SIMP_TAC (srw_ss()) []
-  \\ SRW_TAC [] [LENGTH] \\ RES_TAC \\ TRY DECIDE_TAC
-  \\ SRW_TAC [] [LENGTH] \\ Cases_on `t'`
-  \\ FULL_SIMP_TAC (srw_ss()) [] \\ CCONTR_TAC
-  \\ Q.PAT_X_ASSUM `(x1, l', x2) = xxx` MP_TAC
-  \\ SIMP_TAC std_ss [] \\ SRW_TAC [] []
-  \\ REPEAT STRIP_TAC \\ FULL_SIMP_TAC std_ss []
-  \\ RES_TAC \\ TRY DECIDE_TAC \\ CCONTR_TAC
-  \\ gvs[AllCaseEqs()] \\ drule read_char_as_3digits_reduces >> simp[]
+  \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1]
+  \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1]
+  \\ IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1]
+  \\ CASE_TAC \\ gvs []
+  \\ rpt (IF_CASES_TAC \\ gvs [SF SFY_ss,ADD1]
+          >- (rpt strip_tac \\ res_tac \\ gvs []))
+  \\ IF_CASES_TAC \\ gvs []
+  \\ gvs [AllCaseEqs()] \\ rw [] \\ gvs []
+  \\ drule read_char_as_3digits_reduces \\ simp[]
 QED
 
 Definition skip_comment_def:
diff --git a/semantics/proofs/evaluatePropsScript.sml b/semantics/proofs/evaluatePropsScript.sml
index 56c59a78d6..b2f01887a2 100644
--- a/semantics/proofs/evaluatePropsScript.sml
+++ b/semantics/proofs/evaluatePropsScript.sml
@@ -87,8 +87,8 @@ Theorem do_app_call_FFI_rel:
    do_app (r,ffi) op vs = SOME ((r',ffi'),res) ⇒
    call_FFI_rel^* ffi ffi'
 Proof
-  srw_tac[][do_app_cases] >> rw[] >>
-  FULL_CASE_TAC >>
+  srw_tac[][do_app_cases,thunk_op_def,AllCaseEqs(),store_alloc_def] >> rw[] >>
+  TRY FULL_CASE_TAC >>
   fs[option_case_eq] >>
   rpt (FULL_CASE_TAC \\ fs[]) >>
   match_mp_tac RTC_SUBSET >> rw[call_FFI_rel_def] >> fs[] >> every_case_tac
@@ -277,7 +277,9 @@ Theorem do_app_refs_length:
    LENGTH (FST refs_ffi) <= LENGTH (FST (FST res))
 Proof
   rw [] \\ Cases_on `refs_ffi` \\ Cases_on `op`
-  \\ gvs [do_app_def, AllCaseEqs(), store_assign_def, store_alloc_def]
+  \\ gvs [do_app_def,thunk_op_def,AllCaseEqs(),store_assign_def]
+  \\ fs [store_assign_def,store_alloc_def]
+  \\ rveq \\ fs [] \\ rveq \\ fs[]
 QED
 
 Theorem is_clock_io_mono_do_app_simple:
@@ -323,7 +325,7 @@ val step_tac =
     @ map ho_match_mp_tac [is_clock_io_mono_bind, is_clock_io_mono_check]
     @ [CHANGED_TAC (fs [Cong is_clock_io_mono_cong,
                         is_clock_io_mono_return, is_clock_io_mono_err,
-                        do_eval_res_def, dec_inc_clock]), TOP_CASE_TAC]))
+                        do_eval_res_def, dec_inc_clock]), TOP_CASE_TAC]));
 
 Theorem is_clock_io_mono_evaluate:
    (!(s : 'ffi state) env es. is_clock_io_mono (\s. evaluate s env es) s) /\
@@ -352,6 +354,12 @@ Proof
                                    is_clock_io_mono_do_app_simple]), CASE_TAC])
     \\ ho_match_mp_tac is_clock_io_mono_check \\ gs[] \\ rpt strip_tac
     \\ res_tac \\ gs[dec_inc_clock])
+  >- (
+    gvs [AllCaseEqs()]
+    \\ step_tac
+    \\ fs [is_clock_io_mono_def, dec_clock_def]
+    \\ gvs [oneline update_thunk_def, oneline dest_thunk_def, store_assign_def,
+            AllCaseEqs()])
   >- (assume_tac (SIMP_RULE std_ss [] is_clock_io_mono_do_app_simple) \\ fs[]))
  >- (step_tac \\ fs[is_clock_io_mono_def])
  >- (step_tac \\ fs[is_clock_io_mono_def])
@@ -770,7 +778,28 @@ Proof
   \\ rpt conj_tac \\ rpt gen_tac \\ strip_tac \\ rpt gen_tac
   \\ strip_tac
   \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def]
-  \\ TRY (Cases_on ‘getOpClass op’)
+  >~ [‘op:op’] >-
+   (Cases_on ‘getOpClass op = Force’ >-
+      (gvs []
+       \\ Cases_on `op` \\ gvs [] \\ Cases_on `t` \\ gvs []
+       \\ gvs [AllCaseEqs()]
+       \\ imp_res_tac evaluate_next_type_stamp_mono
+       \\ imp_res_tac evaluate_next_exn_stamp_mono
+       \\ rw []
+       \\ fs [build_tdefs_def])
+    \\ Cases_on ‘getOpClass op’ \\ fs []
+    \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def]
+    \\ rveq \\ fs []
+    \\ fs [Q.ISPEC `(_, _)` EQ_SYM_EQ]
+    \\ rveq \\ fs []
+    \\ imp_res_tac evaluate_next_type_stamp_mono
+    \\ imp_res_tac evaluate_next_exn_stamp_mono
+    \\ rw []
+    \\ fs [build_tdefs_def]
+    \\ qpat_x_assum `fix_clock _ _ = _` mp_tac
+    \\ rpt (TOP_CASE_TAC \\ gs[fix_clock_def])
+    \\ rpt strip_tac \\ rveq
+    \\ gs[fix_clock_def])
   \\ fs [evaluate_case_eqs, dec_clock_def, do_eval_res_def]
   \\ rveq \\ fs []
   \\ fs [Q.ISPEC `(_, _)` EQ_SYM_EQ]
@@ -802,8 +831,9 @@ Theorem do_app_ffi_unchanged:
   !ffi2. do_app (refs, ffi2) op vs = SOME ((refs',ffi2), r)
 Proof
   disch_then (strip_assume_tac o REWRITE_RULE [do_app_cases])
-  \\ rw [do_app_def] \\ gvs[AllCaseEqs()]
+  \\ rw [do_app_def] \\ gvs[thunk_op_def, AllCaseEqs()]
   >- metis_tac[]
+  >- (pairarg_tac \\ gvs [])
   \\ gvs [call_FFI_return_unchanged,
           Q.SPECL [`x`, `ExtCall ""`] ffiTheory.call_FFI_def]
 QED
@@ -840,6 +870,11 @@ Proof
   \\ rfs [dec_clock_def]
   \\ TRY (drule_then (drule_then assume_tac) io_events_mono_antisym)
   \\ fs []
+  \\ TRY (rename1 ‘_ = Force’
+          \\ Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[]
+          \\ gvs [AllCaseEqs()]
+          \\ imp_res_tac evaluate_io_events_mono_imp \\ gvs[]
+          \\ drule_all io_events_mono_antisym \\ gvs[])
   \\ TRY (imp_res_tac do_app_io_events_mono
           \\ imp_res_tac io_events_mono_trans
           \\ CHANGED_TAC
@@ -1024,6 +1059,9 @@ Proof
   \\ TRY (rename [`Case ([App _ _])`] ORELSE cheat)
   *)
   \\ TRY (rename [`Case ([App _ _])`]
+    \\ Cases_on ‘getOpClass op = Force’ >- (
+      Cases_on `op` \\ gvs[] \\ Cases_on `t` \\ gvs[]
+      \\ gvs[AllCaseEqs(), dec_clock_def])
     \\ Cases_on ‘getOpClass op’ \\ gs[]
     \\ rpt (MAP_FIRST (dxrule_then (strip_assume_tac o SIMP_RULE bool_ss []))
       [hd (RES_CANON pair_case_eq), hd (RES_CANON result_case_eq), hd (RES_CANON bool_case_eq)]
@@ -1127,8 +1165,8 @@ Theorem do_app_ffi_mono:
    ?l. ffi'.io_events = ffi.io_events ++ l
 Proof
   rw[]
-  \\ fs[semanticPrimitivesPropsTheory.do_app_cases]
-  \\ rw[] \\ fs[]
+  \\ gvs [semanticPrimitivesPropsTheory.do_app_cases,oneline thunk_op_def,
+          AllCaseEqs(),store_alloc_def]
   \\ fs[ffiTheory.call_FFI_def]
   \\ rpt(PURE_FULL_CASE_TAC >> fs[] >> rveq)
   \\ rveq \\ fs[ffiTheory.ffi_state_component_equality,DROP_LENGTH_NIL]
@@ -1143,7 +1181,8 @@ Theorem do_app_SOME_ffi_same_oracle_state:
 Proof
   simp [Once semanticPrimitivesPropsTheory.do_app_cases]
   \\ rw []
-  \\ fs [do_app_def]
+  \\ gvs [do_app_def,oneline thunk_op_def,AllCaseEqs(),store_alloc_def]
+  >- (CCONTR_TAC \\ gvs [])
   \\ simp [DROP_LENGTH_NIL]
   \\ fs[ffiTheory.call_FFI_def]
   \\ rpt(PURE_FULL_CASE_TAC >> fs[] >> rveq)
@@ -1172,10 +1211,9 @@ Theorem evaluate_history_irrelevance:
 Proof
   ho_match_mp_tac full_evaluate_ind
   \\ rw[full_evaluate_def]
-  \\ TRY (Cases_on ‘getOpClass op’ \\ gs[])
   \\ fs [do_eval_res_def,error_result_case_eq,option_case_eq,
          exp_or_val_case_eq,list_case_eq,match_result_case_eq,
-         pair_case_eq,result_case_eq,bool_case_eq]
+         pair_case_eq,result_case_eq,bool_case_eq,AllCaseEqs()]
   \\ rveq \\ fs []
   \\ simp [rich_listTheory.DROP_LENGTH_NIL_rwt]
   \\ fs [Q.ISPEC `(a, b)` EQ_SYM_EQ, dec_clock_def]
@@ -1366,4 +1404,3 @@ Proof
   \\ irule_at (Pos hd) EQ_REFL
   \\ gvs [dec_clock_def,ADD1]
 QED
-
diff --git a/semantics/proofs/semanticPrimitivesPropsScript.sml b/semantics/proofs/semanticPrimitivesPropsScript.sml
index 1a23172d87..43a524cbc7 100644
--- a/semantics/proofs/semanticPrimitivesPropsScript.sml
+++ b/semantics/proofs/semanticPrimitivesPropsScript.sml
@@ -274,7 +274,7 @@ Theorem do_app_NONE_ffi:
    do_app (refs,ffi) op args = NONE ⇒
    do_app (refs,ffi') op args = NONE
 Proof
-  Cases_on `op` \\ fs [do_app_def]
+  Cases_on `op` \\ fs [do_app_def,thunk_op_def]
   \\ gvs [AllCaseEqs()] \\ rpt strip_tac \\ gvs []
   \\ rpt (pairarg_tac \\ gvs[])
   \\ every_case_tac \\ fs[]
@@ -287,7 +287,7 @@ Theorem do_app_SOME_ffi_same:
    do_app (refs,ffi') op args = SOME ((refs',ffi'),r)
 Proof
   rw[]
-  \\ gvs [do_app_def,AllCaseEqs()]
+  \\ gvs [do_app_def,AllCaseEqs(),thunk_op_def]
   \\ rpt (pairarg_tac \\ gvs [])
   \\ fs[ffiTheory.call_FFI_def]
   \\ gvs [do_app_def,AllCaseEqs()]
@@ -301,7 +301,7 @@ Theorem do_app_ffi_unchanged:
     do_app (st, ffi) op vs = SOME ((st', ffi'), res)
   ⇒ ffi = ffi'
 Proof
-  rpt gen_tac >> simp[do_app_def] >>
+  rpt gen_tac >> simp[do_app_def,thunk_op_def] >>
   Cases_on ‘op’ >> simp[] >> Cases_on ‘vs’ >> simp[] >>
   dsimp[AllCaseEqs(), PULL_EXISTS] >>
   simp[store_alloc_def]
@@ -330,7 +330,7 @@ Theorem do_app_ffi_changed:
         [IO_event (ExtCall s) (MAP (λc. n2w $ ORD c) (EXPLODE conf))
                   (ZIP (ws,ws'))]
 Proof
-  simp[do_app_def] >>
+  simp[do_app_def,thunk_op_def] >>
   Cases_on ‘op’ >> simp[] >> Cases_on ‘vs’ >> simp[] >>
   dsimp[AllCaseEqs(), PULL_EXISTS, UNCURRY_EQ] >>
   simp[call_FFI_def, AllCaseEqs(), SF CONJ_ss] >>
@@ -344,16 +344,15 @@ Theorem do_app_not_timeout:
   a ≠ Rtimeout_error
 Proof
   Cases_on `s` >>
-  srw_tac[][do_app_cases] >>
-  every_case_tac >>
-  srw_tac[][]
+  srw_tac[][do_app_cases,thunk_op_def,AllCaseEqs(),store_alloc_def] >>
+  gvs []
 QED
 
 Theorem do_app_type_error:
   do_app s op es = SOME (x,Rerr (Rabort a)) ⇒ x = s
 Proof
   PairCases_on `s` >>
-  simp[do_app_def] >>
+  simp[do_app_def,thunk_op_def] >>
   Cases_on ‘op’ >> simp[] >> Cases_on ‘es’ >> simp[] >>
   dsimp[AllCaseEqs(), PULL_EXISTS, UNCURRY_EQ]
 QED
@@ -521,7 +520,8 @@ val _ = export_rewrites["every_result_def"]
 Definition map_sv_def:
   map_sv f (Refv v) = Refv (f v) ∧
   map_sv _ (W8array w) = (W8array w) ∧
-  map_sv f (Varray vs) = (Varray (MAP f vs))
+  map_sv f (Varray vs) = (Varray (MAP f vs)) ∧
+  map_sv f (Thunk m v) = (Thunk m (f v))
 End
 val _ = export_rewrites["map_sv_def"]
 
@@ -537,6 +537,7 @@ val _ = export_rewrites["dest_Refv_def","is_Refv_def"]
 Definition sv_every_def:
   sv_every P (Refv v) = P v ∧
   sv_every P (Varray vs) = EVERY P vs ∧
+  sv_every P (Thunk m v) = P v ∧
   sv_every P _ = T
 End
 val _ = export_rewrites["sv_every_def"]
@@ -545,6 +546,7 @@ Definition sv_rel_def:
   sv_rel R (Refv v1) (Refv v2) = R v1 v2 ∧
   sv_rel R (W8array w1) (W8array w2) = (w1 = w2) ∧
   sv_rel R (Varray vs1) (Varray vs2) = LIST_REL R vs1 vs2 ∧
+  sv_rel R (Thunk m1 v1) (Thunk m2 v2) = (m1 = m2 ∧ R v1 v2) ∧
   sv_rel R _ _ = F
 End
 val _ = export_rewrites["sv_rel_def"]
@@ -569,9 +571,10 @@ Theorem sv_rel_cases:
     sv_rel R x y ⇔
     (∃v1 v2. x = Refv v1 ∧ y = Refv v2 ∧ R v1 v2) ∨
     (∃w. x = W8array w ∧ y = W8array w) ∨
+    (∃m v1 v2. x = Thunk m v1 ∧ y = Thunk m v2 ∧ R v1 v2) ∨
     (?vs1 vs2. x = Varray vs1 ∧ y = Varray vs2 ∧ LIST_REL R vs1 vs2)
 Proof
-  Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM]
+  Cases >> Cases >> simp[sv_rel_def,EQ_IMP_THM] >> metis_tac []
 QED
 
 Theorem sv_rel_O:
@@ -590,7 +593,8 @@ QED
 Definition store_v_vs_def:
   store_v_vs (Refv v) = [v] ∧
   store_v_vs (Varray vs) = vs ∧
-  store_v_vs (W8array _) = []
+  store_v_vs (W8array _) = [] ∧
+  store_v_vs (Thunk _ v) = [v]
 End
 val _ = export_rewrites["store_v_vs_def"]
 
diff --git a/semantics/proofs/typeSoundScript.sml b/semantics/proofs/typeSoundScript.sml
index a800239160..9f72d3307c 100644
--- a/semantics/proofs/typeSoundScript.sml
+++ b/semantics/proofs/typeSoundScript.sml
@@ -1601,7 +1601,11 @@ Proof
      >> rw []
      >> metis_tac [store_type_extension_trans])
    >> `getOpClass op ≠ FunApp`
-     by (Cases_on `op` >> fs[getOpClass_def])
+     by (Cases_on `op` >> fs[getOpClass_def,AllCaseEqs()])
+   >> Cases_on ‘getOpClass op = Force’
+   >- (
+     Cases_on ‘op’ >> gvs[getOpClass_def,AllCaseEqs()]
+     >> Cases_on ‘ts’ >> fs[type_op_def])
    >> Cases_on ‘getOpClass op = EvalOp’
    >- (
      Cases_on ‘op’ >> gs[getOpClass_def]
@@ -1611,7 +1615,7 @@ Proof
    >> drule op_type_sound
    >> rpt (disch_then drule)
    >> disch_then (qspec_then `s1.ffi` mp_tac)
-   >> `getOpClass op = Simple` by (Cases_on `op` >> fs[getOpClass_def])
+   >> `getOpClass op = Simple` by (Cases_on `op` >> fs[getOpClass_def,AllCaseEqs()])
    >> rw []
    >> rename1 `do_app _ _ _ = SOME ((store1, ffi1), r1)`
    >> Cases_on `r1`
diff --git a/semantics/semanticPrimitivesScript.sml b/semantics/semanticPrimitivesScript.sml
index 073aa3028f..87d0bae134 100644
--- a/semantics/semanticPrimitivesScript.sml
+++ b/semantics/semanticPrimitivesScript.sml
@@ -171,14 +171,17 @@ Datatype:
   | W8array (word8 list)
   (* An array of values *)
   | Varray ('a list)
+  (* Thunk *)
+  | Thunk thunk_mode 'a
 End
 
 Definition store_v_same_type_def:
   store_v_same_type v1 v2 =
     case (v1:'a store_v, v2:'a store_v) of
-    | (Refv _, Refv _) => T
-    | (W8array _,W8array _) => T
-    | (Varray _,Varray _) => T
+    | (Refv _,    Refv _   ) => T
+    | (W8array _, W8array _) => T
+    | (Varray _,  Varray _ ) => T
+    | (Thunk NotEvaluated _, Thunk _ _) => T
     | _ => F
 End
 
@@ -360,8 +363,7 @@ Definition pmatch_def:
   (case store_lookup lnum s of
      NONE => Match_type_error
    | SOME (Refv v) => pmatch envC s p v env
-   | SOME (W8array v6) => Match_type_error
-   | SOME (Varray v7) => Match_type_error) ∧
+   | SOME _ => Match_type_error) ∧
   pmatch envC s (Pas p i) v env = pmatch envC s p v ((i,v)::env) ∧
   pmatch envC s (Ptannot p t) v env = pmatch envC s p v env ∧
   pmatch envC s _ _ env = Match_type_error ∧
@@ -766,6 +768,19 @@ Definition xor_bytes_def:
     | SOME rest => SOME (word_xor b1 b2 :: rest)
 End
 
+Definition thunk_op_def:
+  thunk_op (s: v store_v list, t: 'ffi ffi_state) th_op vs =
+    case (th_op,vs) of
+    | (AllocThunk m, [v]) =>
+        (let (s',n) = store_alloc (Thunk m v) s in
+           SOME ((s',t), Rval (Loc F n)))
+    | (UpdateThunk m, [Loc _ lnum; v]) =>
+        (case store_assign lnum (Thunk m v) s of
+         | SOME s' => SOME ((s',t), Rval (Conv NONE []))
+         | NONE => NONE)
+    | _ => NONE
+End
+
 Definition do_app_def:
   do_app (s: v store_v list, t: 'ffi ffi_state) op vs =
     case (op, vs) of
@@ -1113,6 +1128,7 @@ Definition do_app_def:
             Rval (Conv NONE [nat_to_v gen; nat_to_v id]))
     | (Env_id, [Conv NONE [gen; id]]) => SOME ((s, t),
             Rval (Conv NONE [gen; id]))
+    | (ThunkOp th_op, vs) => thunk_op (s,t) th_op vs
     | _ => NONE
 End
 
@@ -1169,3 +1185,35 @@ End
 val _ = set_fixity "+++" (Infixl 480);
 Overload "+++" = “extend_dec_env”;
 
+(* With `dest_thunk` we check 3 things:
+     - The values contain exactly one reference
+     - The reference is valid
+     - The reference points to a thunk
+   We distinguish between `BadRef` and `NotThunk` instead of returning an option
+   with `NONE` for both, because we want `update_thunk` to succeed when
+   `dest_thunk` fails but only when the reference actually exists and points to
+   something other than a thunk. *)
+Datatype:
+  dest_thunk_ret
+    = BadRef
+    | NotThunk
+    | IsThunk thunk_mode v
+End
+
+Definition dest_thunk_def:
+  dest_thunk [Loc _ n] st =
+    (case store_lookup n st of
+     | NONE => BadRef
+     | SOME (Thunk Evaluated v) => IsThunk Evaluated v
+     | SOME (Thunk NotEvaluated v) => IsThunk NotEvaluated v
+     | SOME _ => NotThunk) ∧
+  dest_thunk vs st = NotThunk
+End
+
+Definition update_thunk_def:
+  update_thunk [Loc _ n] st [v] =
+    (case dest_thunk [v] st of
+     | NotThunk => store_assign n (Thunk Evaluated v) st
+     | _ => NONE) ∧
+  update_thunk _ st _ = NONE
+End
diff --git a/translator/ml_optimiseScript.sml b/translator/ml_optimiseScript.sml
index f668843bfc..7e2f0d17af 100644
--- a/translator/ml_optimiseScript.sml
+++ b/translator/ml_optimiseScript.sml
@@ -160,12 +160,9 @@ Proof
     \\ asm_exists_tac
     \\ simp []
     \\ dxrule_then (qspec_then `ck2` mp_tac) evaluate_decs_add_to_clock
-    \\ rw [evaluateTheory.dec_clock_def]
-   )
+    \\ rw [evaluateTheory.dec_clock_def])
   THEN1
-   (
-   fs [error_result_case_eq]
-   )
+   (fs [error_result_case_eq])
   THEN1 (* App Opapp *)
    (rename1 `_ = (st1,Rval vs)`
     \\ `evaluate (s with clock := ck1) env (REVERSE xs) =
@@ -182,6 +179,19 @@ Proof
     \\ disch_then (qspec_then `st1.clock+1` assume_tac)
     \\ asm_exists_tac \\ fs []
     \\ fs [evaluateTheory.dec_clock_def,state_component_equality])
+  THEN1 (* App Force *)
+   (rename1 `_ = (st1,Rval vs)`
+    \\ `evaluate (s with clock := ck1) env (REVERSE xs) =
+          ((st1 with clock := s1.clock) with clock := st1.clock,Rval vs)`
+             by fs [state_component_equality]
+    \\ first_x_assum drule \\ simp [] \\ strip_tac
+    \\ drule evaluate_add_to_clock \\ fs []
+    \\ disch_then (qspec_then `st1.clock` assume_tac)
+    \\ asm_exists_tac \\ fs []
+    \\ gvs [AllCaseEqs(), dec_clock_def, PULL_EXISTS] >- metis_tac []
+    \\ qpat_x_assum `evaluate _ env' _ = _` assume_tac
+    \\ drule evaluate_add_to_clock \\ rw []
+    \\ metis_tac [])
   THEN1 (* App Simple *)
    (rename1 `_ = (st1,Rval vs)`
     \\ `evaluate (s with clock := ck1) env (REVERSE xs) =
diff --git a/translator/ml_translatorScript.sml b/translator/ml_translatorScript.sml
index 5ad1b4bb79..c601d59bdf 100644
--- a/translator/ml_translatorScript.sml
+++ b/translator/ml_translatorScript.sml
@@ -2854,6 +2854,7 @@ Definition no_change_refs_def:
         | Aupdate => F
         | Aupdate_unsafe => F
         | FFI _ => F
+        | ThunkOp _ => F
         | _ => T) ∧ EVERY no_change_refs es) /\
   no_change_refs _ = F
 Termination
@@ -2875,8 +2876,8 @@ Proof
   \\ fs [no_change_refs_def] \\ rw []
   \\ gvs [evaluate_def,AllCaseEqs(),semanticPrimitivesTheory.do_if_def]
   \\ fs [SF ETA_ss]
-  \\ gvs []
-  \\ fs [do_app_cases] \\ rveq \\ fs []
+  \\ gvs [do_app_def]
+  \\ gvs [AllCaseEqs(),thunk_op_def,store_alloc_def]
 QED
 
 Theorem eval_rel_no_change_refs:
diff --git a/translator/std_preludeScript.sml b/translator/std_preludeScript.sml
index 6ca46ff8de..2a46eeee37 100644
--- a/translator/std_preludeScript.sml
+++ b/translator/std_preludeScript.sml
@@ -4,7 +4,7 @@
 *)
 Theory std_prelude
 Ancestors
-  ast semanticPrimitives while evaluate ml_translator
+  ast semanticPrimitives While evaluate ml_translator
 Libs
   preamble ml_translatorLib ml_progLib