Compare commits
8 commits
93e20cf208
...
2e551ab2c7
Author | SHA1 | Date | |
---|---|---|---|
2e551ab2c7 | |||
89e4cde17f | |||
20d09abe2a | |||
75522128da | |||
04d1ec3555 | |||
86b097171e | |||
251bfd4b7d | |||
0939615350 |
10 changed files with 83 additions and 30 deletions
3
.gitmodules
vendored
Normal file
3
.gitmodules
vendored
Normal file
|
@ -0,0 +1,3 @@
|
|||
[submodule "src/tests_shared"]
|
||||
path = src/tests_shared
|
||||
url = git@github.com:tobast/mpri18-funcprog-tests.git
|
99
src/CPS.ml
99
src/CPS.ml
|
@ -6,6 +6,8 @@ module T = Tail
|
|||
exception NotValue of S.term
|
||||
(** ^ Raised when trying to use a non-value term as such *)
|
||||
|
||||
exception NotLightCPSable of S.term
|
||||
|
||||
let freshId =
|
||||
(** Generates a fresh variable name string *)
|
||||
let cId = ref 0 in
|
||||
|
@ -27,6 +29,17 @@ 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 _ -> false
|
||||
(* A lambda itself may contain calls, but this call is not evaluated at
|
||||
* declaration time *)
|
||||
| S.App _ -> true
|
||||
| S.IfZero _ -> true (* Cannot optimize that with the current languages *)
|
||||
| S.Print _ -> true (* Cannot optimize that with the current languages *)
|
||||
| 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
|
||||
|
@ -40,43 +53,73 @@ let rec cps_term_inner (t: S.term) (cont: T.variable) (nameHint: string option)
|
|||
: T.term = match t with
|
||||
| S.Var _ -> cps_value_as_term t cont
|
||||
| S.Lit _ -> cps_value_as_term t cont
|
||||
| S.BinOp _ -> cps_value_as_term t cont
|
||||
| S.Lam (self, var, term) ->
|
||||
let fName = freshBlockVarHinted nameHint
|
||||
and innerCont = freshBlockVar () in
|
||||
T.LetBlo(fName,
|
||||
T.Lam(self, [var; innerCont], cps_term_inner term innerCont None),
|
||||
T.TailCall(T.vvar cont, T.vvars [fName]))
|
||||
| S.BinOp (t1, op, t2) ->
|
||||
(try cps_value_as_term t cont
|
||||
with NotValue _ -> (
|
||||
let t1Var = freshVar ()
|
||||
and t2Var = freshVar () in
|
||||
light_term t1Var t1 None @@
|
||||
light_term t2Var t2 None @@
|
||||
T.TailCall(T.vvar cont,
|
||||
[T.VBinOp(T.vvar t1Var, op, T.vvar t2Var)])
|
||||
))
|
||||
| S.Lam _ as lambda ->
|
||||
let fName = freshBlockVarHinted nameHint in
|
||||
light_term fName lambda 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(self, lamVar, lamBody) ->
|
||||
let lamCont = freshBlockVar () in
|
||||
T.LetBlo (
|
||||
varName, T.Lam(
|
||||
self, [lamVar; lamCont],
|
||||
cps_term_inner lamBody lamCont None),
|
||||
next)
|
||||
| S.App _ | S.Print _ | S.IfZero _ ->
|
||||
raise (NotLightCPSable valExpr)
|
||||
)
|
||||
|
||||
|
||||
let cps_term (t: S.term): T.term =
|
||||
(** Entry point. Transforms a [Lambda] term into a [Tail] term, applying a
|
||||
|
|
1
src/tests/if_fib.exp
Symbolic link
1
src/tests/if_fib.exp
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/if_fib.exp
|
1
src/tests/if_fib.lambda
Symbolic link
1
src/tests/if_fib.lambda
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/if_fib.lambda
|
1
src/tests/if_nested.exp
Symbolic link
1
src/tests/if_nested.exp
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/if_nested.exp
|
1
src/tests/if_nested.lambda
Symbolic link
1
src/tests/if_nested.lambda
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/if_nested.lambda
|
|
@ -1,2 +1,2 @@
|
|||
let sum = fun x -> fun y -> x + y in
|
||||
print(40 + 2)
|
||||
print(sum 40 2)
|
||||
|
|
1
src/tests/ren.exp
Symbolic link
1
src/tests/ren.exp
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/ren.exp
|
1
src/tests/ren.lambda
Symbolic link
1
src/tests/ren.lambda
Symbolic link
|
@ -0,0 +1 @@
|
|||
../tests_shared/ren.lambda
|
1
src/tests_shared
Submodule
1
src/tests_shared
Submodule
|
@ -0,0 +1 @@
|
|||
Subproject commit ab7549347e5b6b51183c5704048c6768aab23d86
|
Loading…
Reference in a new issue