tobast/mpri-funcprog-project
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Lighter CPS: first tentative version

Browse source 
Try to lighten the CPS transformation, using fewer continuations when
there is no need for one
This commit is contained in:
Théophile Bastian 2018-02-16 15:00:01 +01:00
parent 0663d7fa10
commit a7f19221d0
1 changed files with 56 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

78
src/CPS.ml
View file

@ -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 (
T.Print(T.vvar termVal,
T.TailCall(T.vvar cont, T.vvars [termVal])))
(cps_term_inner term curCont None)
let termVal = freshVar () in
light_term termVal term None @@
T.Print (T.vvar termVal,
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