mpri-funcprog-project/ocaml/EvalCBNCPS.ml
2017-10-11 19:47:20 +02:00

164 lines
4.4 KiB
OCaml

(* -------------------------------------------------------------------------- *)
(* The type of lambda-terms, in de Bruijn's representation. *)
type var = int (* a de Bruijn index *)
type term =
| Var of var
| Lam of (* bind: *) term
| App of term * term
| Let of (* bind: *) term * term
(* -------------------------------------------------------------------------- *)
(* Under a call-by-name regime, in a function call, the actual argument is not
evaluated immediately; instead, a thunk is built (a pair of the argument
and the environment in which it must be evaluated). Thus, an environment is
a list of thunks. As in call-by-value, a closure is a pair of a term and an
environment. (Closures and thunks differ in that a closure binds a
variable, the formal argument, in the term. A thunk does not.) *)
type cvalue =
| Clo of (* bind: *) term * cenv
and cenv =
thunk list
and thunk =
| Thunk of term * cenv
(* -------------------------------------------------------------------------- *)
(* Environments. *)
let empty : cenv =
[]
exception RuntimeError
let lookup (e : cenv) (x : var) : thunk =
try
List.nth e x
with Failure _ ->
raise RuntimeError
(* -------------------------------------------------------------------------- *)
(* An environment-based big-step call-by-name interpreter. *)
let rec eval (e : cenv) (t : term) : cvalue =
match t with
| Var x ->
let Thunk (t, e) = lookup e x in
eval e t
| Lam t ->
Clo (t, e)
| App (t1, t2) ->
let cv1 = eval e t1 in
let Clo (u1, e') = cv1 in
eval (Thunk(t2, e) :: e') u1
| Let (t1, t2) ->
eval (Thunk (t1, e) :: e) t2
(* -------------------------------------------------------------------------- *)
(* The CPS-transformed interpreter. *)
let rec evalk (e : cenv) (t : term) (k : cvalue -> 'a) : 'a =
match t with
| Var x ->
let Thunk (t, e) = lookup e x in
evalk e t k
| Lam t ->
k (Clo (t, e))
| App (t1, t2) ->
evalk e t1 (fun cv1 ->
let Clo (u1, e') = cv1 in
evalk (Thunk(t2, e) :: e') u1 k)
| Let (t1, t2) ->
evalk (Thunk (t1, e) :: e) t2 k
let eval (e : cenv) (t : term) : cvalue =
evalk e t (fun cv -> cv)
(* -------------------------------------------------------------------------- *)
(* The CPS-transformed, defunctionalized interpreter. *)
type kont =
| AppL of { e: cenv; t2: term; k: kont }
| Init
let rec evalkd (e : cenv) (t : term) (k : kont) : cvalue =
match t with
| Var x ->
let Thunk (t, e) = lookup e x in
evalkd e t k
| Lam t ->
apply k (Clo (t, e))
| App (t1, t2) ->
evalkd e t1 (AppL { e; t2; k })
| Let (t1, t2) ->
evalkd (Thunk (t1, e) :: e) t2 k
and apply (k : kont) (cv : cvalue) : cvalue =
match k with
| AppL { e; t2; k } ->
let cv1 = cv in
let Clo (u1, e') = cv1 in
evalkd (Thunk(t2, e) :: e') u1 k
| Init ->
cv
let eval (e : cenv) (t : term) : cvalue =
evalkd e t Init
(* -------------------------------------------------------------------------- *)
(* Because [apply] has only one call site, it can be inlined, yielding a
slightly more compact and readable definition. *)
let rec evalkd (e : cenv) (t : term) (k : kont) : cvalue =
match t, k with
| Var x, _ ->
let Thunk (t, e) = lookup e x in
evalkd e t k
| Lam t, AppL { e; t2; k } ->
let cv1 = Clo (t, e) in
let Clo (u1, e') = cv1 in
evalkd (Thunk(t2, e) :: e') u1 k
| Lam t, Init ->
Clo (t, e)
| App (t1, t2), _ ->
evalkd e t1 (AppL { e; t2; k })
| Let (t1, t2), _ ->
evalkd (Thunk (t1, e) :: e) t2 k
let eval (e : cenv) (t : term) : cvalue =
evalkd e t Init
(* -------------------------------------------------------------------------- *)
(* The type [kont] is isomorphic to [(cenv * term) list]. Using the latter
type makes the code slightly prettier, although slightly less efficient. *)
(* At this point, one recognizes Krivine's machine. *)
let rec evalkd (e : cenv) (t : term) (k : (cenv * term) list) : cvalue =
match t, k with
| Var x, _ ->
let Thunk (t, e) = lookup e x in
evalkd e t k
| Lam t, (e, t2) :: k ->
let cv1 = Clo (t, e) in
let Clo (u1, e') = cv1 in
evalkd (Thunk(t2, e) :: e') u1 k
| Lam t, [] ->
Clo (t, e)
| App (t1, t2), _ ->
evalkd e t1 ((e, t2) :: k)
| Let (t1, t2), _ ->
evalkd (Thunk (t1, e) :: e) t2 k
let eval (e : cenv) (t : term) : cvalue =
evalkd e t []