Remove wrong TODOs

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

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "src/tests"]
+	path = src/tests
+	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,71 @@ 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 = 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.BinOp (t1, op, t2) ->
+        (try cps_value_as_term t cont
+        with NotValue _ -> (
+            let t1Var = freshVar ()
+            and t2Var = freshVar () in
+            light_term t1Var t1 None @@
+                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 (
-            letCont fCont fVal
-                (T.TailCall(T.vvar fVal, T.vvars [xVal; cont])) @@
-            (cps_term_inner f fCont None)) @@
-            cps_term_inner x xCont None
-
+        light_term xVal x None @@
+            light_term fVal f None @@
+                T.TailCall (T.vvar fVal, T.vvars [xVal; cont])
 | 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 None)
+        let termVal = freshVar () in
+        light_term termVal term None @@
+            T.Print (T.vvar termVal,
+            T.TailCall(T.vvar cont, T.vvars [termVal]))
 | S.Let (var, value, next) ->
-        let curCont = freshBlockVar () in
-        letCont curCont var (cps_term_inner next cont None) @@
-        cps_term_inner value curCont (Some (Atom.hint var))
+        light_term var value (Some (Atom.hint var)) @@
+            cps_term_inner next cont None
 | S.IfZero (expr, tIf, tElse) ->
-        let curCont = freshBlockVar ()
-        and exprVal = freshVar () in
-        letCont curCont exprVal (T.IfZero(T.vvar exprVal,
+        let exprVal = freshVar () in
+        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 expr curCont None
+                cps_term_inner tElse cont 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

@@ -0,0 +1 @@
+Subproject commit 3eb98d93627b34552d937f904ee4d808d2adbecc

src/tests/.gitignore

@@ -1,4 +0,0 @@
-*.err
-*.out
-*.exe
-*.c

src/tests/bool.exp

@@ -1,20 +0,0 @@
-1
-0
-1
-0
-0
-24
-120
-8
-13
-5
-0
-1
-7
-1
-1
-2
-6
-24
-120
-42

src/tests/bool.lambda

@@ -1,88 +0,0 @@
-(* Thunks. *)
-let force = fun x -> x 0 in
-(* Church Booleans. *)
-let false = fun x -> fun y -> y in
-let true = fun x -> fun y -> x in
-let k = true in
-let cond = fun p -> fun x -> fun y -> p x y in
-let forcecond = fun p -> fun x -> fun y -> force (p x y) in
-let bool2int = fun b -> cond b 1 0 in
-let _ = print (bool2int true) in
-let _ = print (bool2int false) in
-(* Church pairs. *)
-let pair = fun x -> fun y -> fun p -> cond p x y in
-let fst = fun p -> p true in
-let snd = fun p -> p false in
-(* Church naturals. *)
-let zero = fun f -> fun x -> x in
-let one = fun f -> fun x -> f x in
-let plus = fun m -> fun n -> fun f -> fun x -> m f (n f x) in
-let two = plus one one in
-let three = plus one two in
-let four = plus two two in
-let five = plus four one in
-let six = plus four two in
-let succ = plus one in
-let mult = fun m -> fun n -> fun f -> m (n f) in
-let exp = fun m -> fun n -> n m in
-let is_zero = fun n -> n (k false) true in
-let convert = fun n -> n (fun x -> x + 1) 0 in
-let _ = print (bool2int (is_zero zero)) in
-let _ = print (bool2int (is_zero one)) in
-let _ = print (bool2int (is_zero two)) in
-(* Factorial, based on Church naturals. *)
-let loop = fun p ->
-  let n = succ (fst p) in
-  pair n (mult n (snd p))
-in
-let fact = fun n ->
-  snd (n loop (pair zero one))
-in
-let _ = print (convert (fact four)) in
-let _ = print (convert (fact five)) in
-(* Fibonacci, based on Church naturals. *)
-let loop = fun p ->
-  let fib1 = fst p in
-  pair (plus fib1 (snd p)) fib1
-in
-let fib = fun n ->
-  snd (n loop (pair one one))
-in
-let _ = print (convert (fib five)) in
-let _ = print (convert (fib six)) in
-(* Predecessor. *)
-let loop = fun p ->
-  let pred = fst p in
-  pair (succ pred) pred
-in
-let pred = fun n ->
-  snd (n loop (pair zero zero))
-in
-let _ = print (convert (pred six)) in
-(* Comparison, yielding a Church Boolean. *)
-let geq = fun m -> fun n ->
-  m pred n (k false) true
-in
-let _ = print (bool2int (geq four six)) in
-let _ = print (bool2int (geq six one)) in
-(* Iteration. *)
-let iter = fun f -> fun n ->
-  n f (f one)
-in
-(* Ackermann's function. *)
-let ack = fun n -> n iter succ n in
-let _ = print (convert (ack two)) in
-(* A fixpoint. *)
-let fix = fun f -> (fun y -> f (fun z -> y y z)) (fun y -> f (fun z -> y y z)) in
-(* Another version of fact. *)
-let fact = fun n ->
-  fix (fun fact -> fun n -> forcecond (is_zero n) (fun _ -> one) (fun _ -> mult n (fact (pred n)))) n
-in
-let _ = print (convert (fact zero)) in
-let _ = print (convert (fact one)) in
-let _ = print (convert (fact two)) in
-let _ = print (convert (fact three)) in
-let _ = print (convert (fact four)) in
-let _ = print (convert (fact five)) in
-
-print 42

src/tests/church.exp

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

src/tests/church.lambda

@@ -1,16 +0,0 @@
-let i = fun x -> x in
-let k = fun x -> fun y -> x in
-let zero = fun f -> i in
-let one = fun f -> fun x -> f x in
-let plus = fun m -> fun n -> fun f -> fun x -> m f (n f x) in
-let succ = plus one in
-let mult = fun m -> fun n -> fun f -> m (n f) in
-let exp = fun m -> fun n -> n m in
-let two = succ one in
-let three = succ two in
-let six = mult two three in
-let seven = succ six in
-let twenty_one = mult three seven in
-let forty_two = mult two twenty_one in
-let convert = fun n -> n (fun x -> x + 1) 0 in
-print (convert forty_two)

src/tests/hello.exp

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

src/tests/hello.lambda

@@ -1 +0,0 @@
-print (21 + 21)

src/tests/if_func.exp

@@ -1,2 +0,0 @@
-1
-1

src/tests/if_func.lambda

@@ -1,26 +0,0 @@
-let i = fun x -> x in
-let k = fun x -> fun y -> x in
-let zero = fun f -> i in
-let one = fun f -> fun x -> f x in
-let plus = fun m -> fun n -> fun f -> fun x -> m f (n f x) in
-let succ = plus one in
-let mult = fun m -> fun n -> fun f -> m (n f) in
-let exp = fun m -> fun n -> n m in
-let two = succ one in
-let three = succ two in
-let six = mult two three in
-let seven = succ six in
-let twenty_one = mult three seven in
-let forty_two = mult two twenty_one in
-let convert = fun n -> n (fun x -> x + 1) 0 in
-
-let nothing =
-    ifzero convert forty_two then
-        print 0
-    else
-        print 1
-    in
-ifzero convert zero then
-    print 1
-else
-    print 0

src/tests/if_func_branch.exp

@@ -1,2 +0,0 @@
-1
-1

src/tests/if_func_branch.lambda

@@ -1,8 +0,0 @@
-let succeed = fun x -> print 1 in
-let fail = fun x -> print 0 in
-
-let true = fun x -> 0 in
-let false = fun x -> 1 in
-
-let nothing = ifzero true 0 then succeed 0 else fail 0 in
-ifzero false 0 then fail 0 else succeed 0

src/tests/loop/loop.lambda

@@ -1,10 +0,0 @@
-(* This program is supposed to never terminate.
-   This can actually work if the C compiler is
-   smart enough to recognize and optimize tail
-   calls. It works for me with clang but not with
-   gcc, for some reason. *)
-let rec loop = fun x ->
-  let _ = print x in
-  loop (x + 1)
-in
-loop 0

src/tests/multi_args.exp

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

src/tests/multi_args.lambda

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

src/tests/multi_args_rec.exp

@@ -1,10 +0,0 @@
-0
-0
-0
-0
-0
-0
-0
-0
-0
-0

src/tests/multi_args_rec.lambda

@@ -1,8 +0,0 @@
-let rec print_n = fun cur -> fun n ->
-    ifzero n - cur then
-        0
-    else
-        let x = print 0 in
-        print_n (cur + 1) n
-    in
-print_n 0 10

src/tests/partial_eval.exp

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

src/tests/partial_eval.lambda

@@ -1,5 +0,0 @@
-let sum = fun x -> fun y -> fun z -> x + y + z in
-let plus2 = sum 1 1 in
-
-let _ = print (sum 30 10 2) in
-print (plus2 40)

src/tests/printprint.exp

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

src/tests/printprint.lambda

@@ -1,2 +0,0 @@
-(* Because [print] returns its argument, this program should print 42 twice. *)
-print (print 42)

src/tests/rec_factorial.exp

@@ -1 +0,0 @@
-5040

src/tests/rec_factorial.lambda

@@ -1,9 +0,0 @@
-let rec fact = fun n ->
-    ifzero n then
-        1
-    else
-        let sub_val = fact (n - 1) in
-        n * sub_val
-    in
-
-print (fact 7)

src/tests/rec_fibo.exp

@@ -1,9 +0,0 @@
-1
-1
-2
-3
-5
-8
-13
-21
-34

src/tests/rec_fibo.lambda

@@ -1,25 +0,0 @@
-let fibo = fun n ->
-    let rec fibo_inner = fun i -> fun last -> fun last_last ->
-        ifzero (n - i) then
-            last + last_last
-        else
-            fibo_inner (i+1) (last + last_last) last
-    in
-
-    ifzero n then
-        1
-    else ifzero (n - 1) then
-        1
-    else
-        fibo_inner 2 1 1
-    in
-
-let x = print (fibo 0) in
-let x = print (fibo 1) in
-let x = print (fibo 2) in
-let x = print (fibo 3) in
-let x = print (fibo 4) in
-let x = print (fibo 5) in
-let x = print (fibo 6) in
-let x = print (fibo 7) in
-print (fibo 8)

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)

src/tests/simple_call.exp

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

src/tests/simple_call.lambda

@@ -1,2 +0,0 @@
-let id = fun x -> x in
-print (id 42)

src/tests/simple_if.exp

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

src/tests/simple_if.lambda

@@ -1 +0,0 @@
-ifzero 42 then print 0 else print 1