diff --git a/src/CPS.ml b/src/CPS.ml index 68f1cc9..77eaca0 100644 --- a/src/CPS.ml +++ b/src/CPS.ml @@ -29,9 +29,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 _ -> true (* TODO *) - (* A lambda itself may contain calls, but this call is not evaluated at - * declaration time *) +| S.Lam _ -> false + (* 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 @@ -60,12 +60,10 @@ 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 (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.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 xVal = freshVarHinted nameHint and fVal = freshVar () in @@ -108,7 +106,14 @@ and light_term varName valExpr valHint next = subLetVar, cps_value subLetVal, light_term varName subLetNext valHint next) - | S.Lam _ | S.App _ | S.Print _ | S.IfZero _ -> assert false + | 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 _ -> assert false )