Lighter CPS: first tentative version

Try to lighten the CPS transformation, using fewer continuations when
there is no need for one

src/CPS.ml

@@ -3,10 +3,7 @@ module S = Lambda
 (* The target calculus. *)
 module T = Tail
 
-exception NotValue of S.term
-(** ^ Raised when trying to use a non-value term as such *)
-
-exception NotLightCPSable of S.term
+exception NotValue (** <- Raised when trying to use a non-value term as such *)
 
 let freshId =
     (** Generates a fresh variable name string *)
@@ -31,9 +28,9 @@ let letCont name 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.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
@@ -52,7 +49,7 @@ let rec cps_value (t: S.term) : T.value = match t with
 | S.Var v -> T.VVar v
 | S.Lit v -> T.VLit v
 | S.BinOp (l, op, r) -> T.VBinOp (cps_value l, op, cps_value r)
-| S.Let _ | S.Lam _ | S.App _ | S.Print _ | S.IfZero _ -> raise (NotValue t)
+| S.Let _ | S.Lam _ | S.App _ | S.Print _ | S.IfZero _ -> raise NotValue
 
 let cps_value_as_term (t: S.term) (cont: T.variable): T.term =
     T.TailCall(T.vvar cont, [cps_value t])
@@ -62,10 +59,12 @@ let rec cps_term_inner (t: S.term) (cont: T.variable) (nameHint: string option)
 | 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 _ as lambda ->
-        let fName = freshBlockVarHinted nameHint in
-        light_term fName lambda None @@
-            T.TailCall(T.vvar cont, T.vvars [fName])
+| 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.App (f, x) ->
         let xVal = freshVarHinted nameHint
         and fVal = freshVar () in
@@ -108,15 +107,7 @@ and light_term varName valExpr valHint next =
                     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)
+        | S.Lam _ | S.App _ | S.Print _ | S.IfZero _ -> assert false
     )
 
 

src/tests/redef.exp

@@ -1 +0,0 @@
-42

src/tests/redef.lambda

@@ -1,6 +0,0 @@
-let increase = fun x -> x + 1 in
-let increase = fun x ->
-    let lop = (increase x) in
-    lop + 1 in
-
-print (increase 40)