Lighter CPS: first tentative version
Try to lighten the CPS transformation, using fewer continuations when there is no need for one
This commit is contained in:
parent
0663d7fa10
commit
a7f19221d0
1 changed files with 56 additions and 22 deletions
76
src/CPS.ml
76
src/CPS.ml
|
@ -27,6 +27,25 @@ let letCont name varName body next =
|
|||
(** Allocates a block for a continuation, then runs [next] *)
|
||||
T.LetBlo(name, T.Lam(T.NoSelf, [varName], body), next)
|
||||
|
||||
let rec has_calls (t: S.term): bool = match t with
|
||||
| S.Var _ | S.Lit _ | S.BinOp _ -> false
|
||||
| S.Lam _ -> true (* TODO *)
|
||||
(* A lambda itself may contain calls, but this call is not evaluated at
|
||||
* declaration time *)
|
||||
| S.App _ -> true
|
||||
| S.IfZero (cond, tIf, tElse) ->
|
||||
(* Cannot optimize continuation creation
|
||||
List.exists has_calls [cond; tIf; tElse]
|
||||
*)
|
||||
true
|
||||
| S.Print value ->
|
||||
(* Cannot optimize continuation creation
|
||||
has_calls value
|
||||
*)
|
||||
true
|
||||
| S.Let (_, value, next) ->
|
||||
List.exists has_calls [value; next]
|
||||
|
||||
let rec cps_value (t: S.term) : T.value = match t with
|
||||
| S.Var v -> T.VVar v
|
||||
| S.Lit v -> T.VLit v
|
||||
|
@ -48,35 +67,50 @@ let rec cps_term_inner (t: S.term) (cont: T.variable) (nameHint: string option)
|
|||
T.Lam(self, [var; innerCont], cps_term_inner term innerCont None),
|
||||
T.TailCall(T.vvar cont, T.vvars [fName]))
|
||||
| S.App (f, x) ->
|
||||
let xCont = freshBlockVar ()
|
||||
and fCont = freshBlockVar () in
|
||||
let xVal = freshVarHinted nameHint
|
||||
and fVal = freshVar () in
|
||||
|
||||
letCont xCont xVal (
|
||||
letCont fCont fVal
|
||||
(T.TailCall(T.vvar fVal, T.vvars [xVal; cont])) @@
|
||||
(cps_term_inner f fCont None)) @@
|
||||
cps_term_inner x xCont None
|
||||
|
||||
light_term xVal x None @@
|
||||
light_term fVal f None @@
|
||||
T.TailCall (T.vvar fVal, T.vvars [xVal; cont])
|
||||
| S.Print term ->
|
||||
let curCont = freshBlockVar ()
|
||||
and termVal = freshVar () in
|
||||
letCont curCont termVal (
|
||||
let termVal = freshVar () in
|
||||
light_term termVal term None @@
|
||||
T.Print (T.vvar termVal,
|
||||
T.TailCall(T.vvar cont, T.vvars [termVal])))
|
||||
(cps_term_inner term curCont None)
|
||||
T.TailCall(T.vvar cont, T.vvars [termVal]))
|
||||
| S.Let (var, value, next) ->
|
||||
let curCont = freshBlockVar () in
|
||||
letCont curCont var (cps_term_inner next cont None) @@
|
||||
cps_term_inner value curCont (Some (Atom.hint var))
|
||||
(* TODO still verbose here *)
|
||||
light_term var value (Some (Atom.hint var)) @@
|
||||
cps_term_inner next cont None
|
||||
| S.IfZero (expr, tIf, tElse) ->
|
||||
let curCont = freshBlockVar ()
|
||||
and exprVal = freshVar () in
|
||||
letCont curCont exprVal (T.IfZero(T.vvar exprVal,
|
||||
(* TODO still verbose here *)
|
||||
let exprVal = freshVar () in
|
||||
light_term exprVal expr None @@
|
||||
(T.IfZero (T.vvar exprVal,
|
||||
cps_term_inner tIf cont None,
|
||||
cps_term_inner tElse cont None)) @@
|
||||
cps_term_inner expr curCont None
|
||||
cps_term_inner tElse cont None))
|
||||
|
||||
and light_term varName valExpr valHint next =
|
||||
match has_calls valExpr with
|
||||
| true ->
|
||||
let contName = freshBlockVar () in
|
||||
letCont contName varName next @@
|
||||
cps_term_inner valExpr contName valHint
|
||||
| false -> (match valExpr with
|
||||
(* This term has no calls: no need to CPS-transform it *)
|
||||
| S.Var _ | S.Lit _ | S.BinOp _ ->
|
||||
T.LetVal (
|
||||
varName,
|
||||
cps_value valExpr,
|
||||
next)
|
||||
| S.Let (subLetVar, subLetVal, subLetNext) ->
|
||||
T.LetVal (
|
||||
subLetVar,
|
||||
cps_value subLetVal,
|
||||
light_term varName subLetNext valHint next)
|
||||
| S.Lam _ | S.App _ | S.Print _ | S.IfZero _ -> assert false
|
||||
)
|
||||
|
||||
|
||||
let cps_term (t: S.term): T.term =
|
||||
(** Entry point. Transforms a [Lambda] term into a [Tail] term, applying a
|
||||
|
|
Loading…
Reference in a new issue