convert (limited) letrec
build / build (push) Successful in 20s

This commit is contained in:
2026-08-18 20:38:17 -06:00
parent a73b3ed89b
commit 6949ff7fdf
4 changed files with 32 additions and 4 deletions
+2
View File
@@ -0,0 +1,2 @@
ret > ExitSuccess
out > 720
+5
View File
@@ -0,0 +1,5 @@
(letrec ((fac (λ (n)
(if (zero? n)
1
(* n (fac (- n 1)))))))
(fac 6))
+24 -4
View File
@@ -14,6 +14,10 @@ import Control.Monad.Cont qualified as Cont
import Control.Lens import Control.Lens
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Gyehoek.Sexp import qualified Gyehoek.Sexp
import Data.String.Interpolate (i)
import Data.Functor (unzip)
import Data.List (List)
import Prelude hiding (unzip)
-- 뻘짓이어라 -- 뻘짓이어라
@@ -45,11 +49,10 @@ convert (Scm.ExpPrim p) k =
convert (Scm.ExpLambda xs e) k = do convert (Scm.ExpLambda xs e) k = do
f <- gensym' "λ-body" f <- gensym' "λ-body"
ktail <- gensym' "λ-tail" lam <- convertLambda xs e
m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
ke <- k $ ValVar f ke <- k $ ValVar f
pure [cps| pure [cps|
(letrec ((#{f} (λ (##{xs} #{ktail}) #{m}))) (letrec ((#{f} #{lam}))
#{ke}) #{ke})
|] |]
@@ -80,7 +83,24 @@ convert (Scm.ExpLet bs e) k =
(continue #{kbody} ##{rhss'})) (continue #{kbody} ##{rhss'}))
|] |]
convert _ k = _ convert (Scm.ExpLetRec bs m) k = do
let bs' = bs & each . _2 %~ (^?! #ExpLambda)
let conv = traverseOf _2 (uncurry $ convertLambda @es)
bs'' <- traverse conv bs'
m' <- convert m k
pure [cps|
(letrec #{bs''} #{m'})
|]
-- convert e k = error [i|unimplemented expr: #{e}|]
convertLambda
:: GenSym :> es
=> List Name -> Scm.Exp -> Eff es Lambda
convertLambda bs m = do
ktail <- gensym' "lambda-tail"
m' <- convert m $ pure . ExpContinue ktail . (:[])
pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
convertProgram p = convertProgram p =
+1
View File
@@ -25,6 +25,7 @@ brokenWasmTests =
, "fn-of-fn" , "fn-of-fn"
, "let-fn" , "let-fn"
, "apply2" , "apply2"
, "factorial"
] ]
brokenStackifyTests :: List String brokenStackifyTests :: List String