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

Attempt to have better variable names in CPS

Browse source
This commit is contained in:
Théophile Bastian 2018-01-29 15:46:53 +01:00
parent 4419abf57d
commit 438a875cea
1 changed files with 17 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
src/CPS.ml
View file

@ -14,8 +14,13 @@ let freshId =
let freshWithPrefix pre =
Atom.fresh (pre ^ (freshId ()) ^ "_")
let freshBlockVar () = freshWithPrefix "bl_"
let freshVar () = freshWithPrefix "v_"
let prefixHint prefix hint = match hint with
| Some h -> prefix ^ h
| None -> prefix
let freshBlockVarHinted hint = freshWithPrefix (prefixHint "bl_" hint)
let freshBlockVar () = freshBlockVarHinted None
let freshVarHinted hint = freshWithPrefix (prefixHint "v_" hint)
let freshVar () = freshVarHinted None
let letCont name varName body next =
(** Allocates a block for a continuation, then runs [next] *)
@ -30,40 +35,40 @@ let rec cps_value (t: S.term) : T.value = match t with
let cps_value_as_term (t: S.term) (cont: T.variable): T.term =
T.TailCall(T.vvar cont, [cps_value t])
let rec cps_term_inner (t: S.term) (cont: T.variable)
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 = freshBlockVar ()
let fName = freshBlockVarHinted nameHint
and innerCont = freshBlockVar () in
T.LetBlo(fName,
T.Lam(self, [var; innerCont], cps_term_inner term innerCont),
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 = freshVar ()
let xVal = freshVarHinted nameHint
and fVal = freshVar () in
letCont fCont fVal (T.TailCall(T.vvar fVal, T.vvars [xVal; cont])) @@
letCont xCont xVal (cps_term_inner f fCont) @@
cps_term_inner x xCont
letCont xCont xVal (cps_term_inner f fCont None) @@
cps_term_inner x xCont None
| 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)
(cps_term_inner term curCont None)
| S.Let (var, value, next) ->
let curCont = freshBlockVar () in
letCont curCont var (cps_term_inner next cont) @@
cps_term_inner value curCont
letCont curCont var (cps_term_inner next cont None) @@
cps_term_inner value curCont (Some (Atom.hint var))
let cps_term (t: S.term): T.term =
(** Entry point. Transforms a [Lambda] term into a [Tail] term, applying a
* continuation-passing-style transformation. *)
let exitBlock = freshBlockVar () in
letCont exitBlock (freshVar ()) T.Exit @@
cps_term_inner t exitBlock
cps_term_inner t exitBlock (Some "main_entry")