Skip to content

Commit

Permalink
Put safety thunking in auxiliary function
Browse files Browse the repository at this point in the history
  • Loading branch information
SkySkimmer committed Dec 19, 2023
1 parent 8e17108 commit ef509c4
Showing 1 changed file with 7 additions and 2 deletions.
9 changes: 7 additions & 2 deletions src/tac2compile.ml
Original file line number Diff line number Diff line change
Expand Up @@ -757,6 +757,11 @@ let pp_valexpr_of_bound pp = function
| Valexpr -> pp
| Function {arity} -> pp_mk_closure_val arity pp

(* cf https://github.com/SkySkimmer/coq-ltac2-compiler/issues/17 *)
let add_safety_thunk pp =
str "PV.tclUNIT () >>= fun () ->" ++ spc()
++ pp

(* produce a ocaml term of type valexpr *)
let rec pp_nontac_expr = function
| Atm (AtmInt i) | Ctor (i, []) -> str "(ValInt " ++ (if i >= 0 then int i else surround (int i)) ++ str")"
Expand All @@ -768,7 +773,7 @@ let rec pp_nontac_expr = function
pp_mk_closure_val (List.length nas)
(surround
(h (str "fun" ++ pp_binders nas ++ str " ->") ++ spc() ++
str "PV.tclUNIT () >>= fun () ->" ++ spc() ++ pp_expr e))
add_safety_thunk (pp_expr e)))
| Ctor (i, es) -> str "(ValBlk (" ++ int i ++ str ", [|" ++ pp_val_list es ++ str "|]))"
| PrjV (e, i) ->
surround
Expand Down Expand Up @@ -943,7 +948,7 @@ let pp_one_constant (kn, knid, na, bnd, e) =
| Fun (nas, e) ->
hv 2
(str "let " ++ h (str na ++ pp_binders nas) ++ str " =" ++ spc() ++
str "PV.tclUNIT () >>= fun () ->" ++ spc() ++ pp_expr e) ++ fnl() ++ fnl()
add_safety_thunk (pp_expr e)) ++ fnl() ++ fnl()
| _ -> hv 2 (str "let " ++ str na ++ str " =" ++ spc() ++ pp_nontac_expr e) ++ fnl() ++ fnl()
in
let pp_set_compiled =
Expand Down

0 comments on commit ef509c4

Please sign in to comment.