Compare commits
3 commits
0a4d788513
...
243e02af49
Author | SHA1 | Date | |
---|---|---|---|
Théophile Bastian | 243e02af49 | ||
Théophile Bastian | 63f8b6b61a | ||
Théophile Bastian | b1e82638b2 |
78
src/CPS.ml
78
src/CPS.ml
|
@ -26,6 +26,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
|
||||
|
@ -47,35 +66,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
|
||||
|
|
|
@ -27,9 +27,9 @@ let rec clean_term map_env = function
|
|||
clean_value map_env value,
|
||||
clean_term map_env next)
|
||||
| S.LetVal (name, S.VVar subVar, next) ->
|
||||
clean_term (Env.add name subVar map_env) next
|
||||
clean_term (Env.add name (clean_var map_env subVar) map_env) next
|
||||
| S.LetVal (name, value, next) ->
|
||||
S.LetVal (name, value, clean_term map_env next)
|
||||
S.LetVal (name, clean_value map_env value, clean_term map_env next)
|
||||
| S.LetBlo (name, S.Con(tag, args), next) ->
|
||||
S.LetBlo(
|
||||
name,
|
||||
|
@ -48,7 +48,7 @@ let rec clean_term map_env = function
|
|||
and clean_branch map_env (S.Branch(tag, args, body)) =
|
||||
S.Branch(
|
||||
tag,
|
||||
args,
|
||||
List.map (clean_var map_env) args,
|
||||
clean_term map_env body)
|
||||
|
||||
let clean_function (S.Fun(name, args, body)) =
|
||||
|
|
Loading…
Reference in a new issue