Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

More precise monad thunking #21

Merged
merged 1 commit into from
Dec 4, 2023
Merged

More precise monad thunking #21

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 4 additions & 4 deletions src/tac2compile.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -768,7 +768,7 @@ let rec pp_nontac_expr = function
pp_mk_closure_val (List.length nas)
(surround
(h (str "fun" ++ pp_binders nas ++ str " ->") ++ spc() ++
pp_expr e))
str "PV.tclUNIT () >>= fun () ->" ++ spc() ++ pp_expr e))
| Ctor (i, es) -> str "(ValBlk (" ++ int i ++ str ", [|" ++ pp_val_list es ++ str "|]))"
| PrjV (e, i) ->
surround
Expand Down Expand Up @@ -804,10 +804,10 @@ and pp_expr e =
else surround (pp_binds Id.print pp_expr nonvals ++ pp_head_expr e)
in
match e with
| Return _ | LetRec _ -> mainpp
| _ ->
| Match _ | CtorMut _ | PrjMut _ | Set _ ->
(* monad-thunk nontrivial computations *)
surround (str "PV.tclUNIT () >>= fun () ->" ++ spc() ++ mainpp)
| App _ | Return _ | LetNoRec _ | LetRec _ | Ext _ -> mainpp

and pp_head_expr = function
| Return e -> surround (str "PV.tclUNIT" ++ spc() ++ pp_nontac_expr e)
Expand Down Expand Up @@ -943,7 +943,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() ++
pp_expr e) ++ fnl() ++ fnl()
str "PV.tclUNIT () >>= fun () ->" ++ spc() ++ 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
16 changes: 14 additions & 2 deletions tests/compiler_bug_17.v
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,8 +14,20 @@ Ltac2 test2 () :=
ltac1:(assert False) >
[pop inner; pop outer|let outer := push () in pop outer].

Ltac2 Compile test2.
Ltac2 aux1 outer inner _ := pop inner; pop outer.
Ltac2 aux2 _ := let outer := push() in pop outer.

Ltac2 test3 :=
fun _ =>
let outer := push () in
let inner := push () in
let l :=
[aux1 outer inner; aux2],
None with t := fun _ => ltac1:(assert False) in
dispatch0 t l.

Ltac2 Compile test2 test3.

Goal True /\ True.
test2 ().
test3 ().
Abort.
Loading