Skip to content

Commit

Permalink
Fix tmOptimizedBind to avoid quadratic blowup
Browse files Browse the repository at this point in the history
Oops.

Maybe now we can actually use it by default.
  • Loading branch information
JasonGross committed Apr 11, 2023
1 parent 07a2c66 commit 287b326
Showing 1 changed file with 10 additions and 2 deletions.
12 changes: 10 additions & 2 deletions template-coq/theories/TemplateMonad/Core.v
Original file line number Diff line number Diff line change
Expand Up @@ -70,17 +70,25 @@ Cumulative Inductive TemplateMonad@{t u} : Type@{t} -> Prop :=
.

(** This version of [tmBind] flattens nesting structure; using it in deeply recursive template programs can speed things up drastically *)
(** We use [tmBind] in the recursive position to avoid quadratic blowup in the number of [tmOptimizedBind]s *)
Fixpoint tmOptimizedBind@{t u} {A B : Type@{t}} (v : TemplateMonad@{t u} A) : (A -> TemplateMonad@{t u} B) -> TemplateMonad@{t u} B
:= match v with
| tmReturn x => fun f => f x
| tmBind v k => fun f => tmOptimizedBind v (fun v => tmOptimizedBind (k v) f)
| tmBind v k => fun f => tmOptimizedBind v (fun v => tmBind (k v) f)
| tmFail msg => fun _ => tmFail msg
| v => tmBind v
end.

(** Flatten nested [tmBind] *)
Fixpoint tmOptimize'@{t u} {A B : Type@{t}} (v : TemplateMonad@{t u} A) : (A -> TemplateMonad@{t u} B) -> TemplateMonad@{t u} B
:= match v with
| tmReturn x => fun f => f x
| tmBind v k => fun f => tmOptimize' v (fun v => tmOptimize' (k v) f)
| tmFail msg => fun _ => tmFail msg
| v => tmBind v
end.
Definition tmOptimize@{t u} {A : Type@{t}} (v : TemplateMonad@{t u} A) : TemplateMonad@{t u} A
:= tmOptimizedBind v tmReturn.
:= tmOptimize' v tmReturn.

(** This allow to use notations of MonadNotation *)
Definition TemplateMonad_UnoptimizedMonad@{t u} : Monad@{t u} TemplateMonad@{t u} :=
Expand Down

0 comments on commit 287b326

Please sign in to comment.