Clean unused values from pattern matching

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

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "src/tests_shared"]
+	path = src/tests_shared
+	url = git@github.com:tobast/mpri18-funcprog-tests.git

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.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) ->
-        let xCont = freshBlockVar ()
-        and fCont = freshBlockVar () in
         let xVal = freshVarHinted nameHint
         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 ->
-        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.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) ->
-        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) ->
-        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 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 =
     (** Entry point. Transforms a [Lambda] term into a [Tail] term, applying a

src/tests/if_fib.exp

@@ -0,0 +1 @@
+../tests_shared/if_fib.exp

src/tests/if_fib.lambda

@@ -0,0 +1 @@
+../tests_shared/if_fib.lambda

src/tests/if_nested.exp

@@ -0,0 +1 @@
+../tests_shared/if_nested.exp

src/tests/if_nested.lambda

@@ -0,0 +1 @@
+../tests_shared/if_nested.lambda

src/tests/multi_args.lambda

@@ -1,2 +1,2 @@
 let sum = fun x -> fun y -> x + y in
-print(40 + 2)
+print(sum 40 2)

src/tests/ren.exp

@@ -0,0 +1 @@
+../tests_shared/ren.exp

src/tests/ren.lambda

@@ -0,0 +1 @@
+../tests_shared/ren.lambda

src/tests_shared

@@ -0,0 +1 @@
+Subproject commit ab7549347e5b6b51183c5704048c6768aab23d86