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
|
101
src/CPS.ml
101
src/CPS.ml
|
@ -6,6 +6,8 @@ module T = Tail
|
||||||
exception NotValue of S.term
|
exception NotValue of S.term
|
||||||
(** ^ Raised when trying to use a non-value term as such *)
|
(** ^ Raised when trying to use a non-value term as such *)
|
||||||
|
|
||||||
|
exception NotLightCPSable of S.term
|
||||||
|
|
||||||
let freshId =
|
let freshId =
|
||||||
(** Generates a fresh variable name string *)
|
(** Generates a fresh variable name string *)
|
||||||
let cId = ref 0 in
|
let cId = ref 0 in
|
||||||
|
@ -27,6 +29,17 @@ let letCont name varName body next =
|
||||||
(** Allocates a block for a continuation, then runs [next] *)
|
(** Allocates a block for a continuation, then runs [next] *)
|
||||||
T.LetBlo(name, T.Lam(T.NoSelf, [varName], body), 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
|
let rec cps_value (t: S.term) : T.value = match t with
|
||||||
| S.Var v -> T.VVar v
|
| S.Var v -> T.VVar v
|
||||||
| S.Lit v -> T.VLit 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
|
: T.term = match t with
|
||||||
| S.Var _ -> cps_value_as_term t cont
|
| S.Var _ -> cps_value_as_term t cont
|
||||||
| S.Lit _ -> cps_value_as_term t cont
|
| S.Lit _ -> cps_value_as_term t cont
|
||||||
| S.BinOp _ -> cps_value_as_term t cont
|
| S.BinOp (t1, op, t2) ->
|
||||||
| S.Lam (self, var, term) ->
|
(try cps_value_as_term t cont
|
||||||
let fName = freshBlockVarHinted nameHint
|
with NotValue _ -> (
|
||||||
and innerCont = freshBlockVar () in
|
let t1Var = freshVar ()
|
||||||
T.LetBlo(fName,
|
and t2Var = freshVar () in
|
||||||
T.Lam(self, [var; innerCont], cps_term_inner term innerCont None),
|
light_term t1Var t1 None @@
|
||||||
T.TailCall(T.vvar cont, T.vvars [fName]))
|
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) ->
|
| S.App (f, x) ->
|
||||||
let xCont = freshBlockVar ()
|
|
||||||
and fCont = freshBlockVar () in
|
|
||||||
let xVal = freshVarHinted nameHint
|
let xVal = freshVarHinted nameHint
|
||||||
and fVal = freshVar () in
|
and fVal = freshVar () in
|
||||||
|
|
||||||
letCont xCont xVal (
|
light_term xVal x None @@
|
||||||
letCont fCont fVal
|
light_term fVal f None @@
|
||||||
(T.TailCall(T.vvar fVal, T.vvars [xVal; cont])) @@
|
T.TailCall (T.vvar fVal, T.vvars [xVal; cont])
|
||||||
(cps_term_inner f fCont None)) @@
|
|
||||||
cps_term_inner x xCont None
|
|
||||||
|
|
||||||
| S.Print term ->
|
| S.Print term ->
|
||||||
let curCont = freshBlockVar ()
|
let termVal = freshVar () in
|
||||||
and termVal = freshVar () in
|
light_term termVal term None @@
|
||||||
letCont curCont termVal (
|
T.Print (T.vvar termVal,
|
||||||
T.Print(T.vvar termVal,
|
T.TailCall(T.vvar cont, T.vvars [termVal]))
|
||||||
T.TailCall(T.vvar cont, T.vvars [termVal])))
|
|
||||||
(cps_term_inner term curCont None)
|
|
||||||
| S.Let (var, value, next) ->
|
| S.Let (var, value, next) ->
|
||||||
let curCont = freshBlockVar () in
|
(* TODO still verbose here *)
|
||||||
letCont curCont var (cps_term_inner next cont None) @@
|
light_term var value (Some (Atom.hint var)) @@
|
||||||
cps_term_inner value curCont (Some (Atom.hint var))
|
cps_term_inner next cont None
|
||||||
| S.IfZero (expr, tIf, tElse) ->
|
| S.IfZero (expr, tIf, tElse) ->
|
||||||
let curCont = freshBlockVar ()
|
(* TODO still verbose here *)
|
||||||
and exprVal = freshVar () in
|
let exprVal = freshVar () in
|
||||||
letCont curCont exprVal (T.IfZero(T.vvar exprVal,
|
light_term exprVal expr None @@
|
||||||
|
(T.IfZero (T.vvar exprVal,
|
||||||
cps_term_inner tIf cont None,
|
cps_term_inner tIf cont None,
|
||||||
cps_term_inner tElse cont None)) @@
|
cps_term_inner tElse cont None))
|
||||||
cps_term_inner expr curCont 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 =
|
let cps_term (t: S.term): T.term =
|
||||||
(** Entry point. Transforms a [Lambda] term into a [Tail] term, applying a
|
(** 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
|
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