From 26dcffa12e0bd0985cb31b8049cf9538f4f66b22 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 20 Jul 2026 02:56:42 -0600 Subject: [PATCH] appy --- .dir-locals.el | 4 +- src/Gyehoek/CPS/Convert.hs | 5 +-- src/Gyehoek/CPS/Lower.hs | 40 +++++++++++++++-- t.wat | 90 ++++++++++++++++++++++++++++---------- 4 files changed, 110 insertions(+), 29 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 545feef..c5558e4 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -2,4 +2,6 @@ . ((eval . (progn (defun apply-cabal-fmt-h () (haskell-mode-buffer-apply-command "cabal-fmt")) - (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))) + (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t) + (add-to-list 'haskell-font-lock-quasi-quote-modes + '("cps" . scheme-mode))))))) diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 1427ac3..368bd9c 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -54,11 +54,10 @@ convert (Scm.ExpLambda xs e) k = do convert (Scm.ExpApply f xs) k = telescope (convert @es) (f:|xs) \(f':|xs') -> do - -- r <- gensym' "r" + r <- gensym' "r" x <- gensym' "x" m <- k (ValVar x) - -- pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r]) - _ + pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r convert (Scm.ExpBegin xs) k = _ diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 0b6d2e4..18f14e3 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -25,6 +25,7 @@ import Language.Sexp.Located qualified as SL import Control.Monad.Fix import qualified Gyehoek.Sexp import Data.Text qualified as T +import Data.Foldable (fold) data Env = MkEnv @@ -41,6 +42,9 @@ instance Ixed Env where +tonat :: Integral a => a -> Natural +tonat = fromIntegral + -- | @makeSmallFixnum@ emits an expression injecting the i32 on top -- of the stack into the SCM unitype. makeSmallFixnum :: Wasm.Expr @@ -124,6 +128,11 @@ lower' g (ExpIf c t f) = do (else ##{f'})) |] +lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do + idx <- lowerKappa g kap + let g' = g & #kvars <>~ [r] + lower' g' e + lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do idx <- lowerLambda g lam let g' = g & #vars <>~ [r] @@ -137,10 +146,19 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do ##{e'} |] -lower' g (ExpContinue k [x]) = do - arg <- pushArg 0 <$> lowerVal g x +lower' g (ExpApply f xs ktail) = do + let nargs = length xs + f' <- lowerVal g f + args <- fold <$> + itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs + error "todo fml" + +lower' g (ExpContinue k xs) = do + -- let nargs = length xs + args <- fold <$> + itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs pure [expr| - ##{arg} + ##{args} (i32.const 1) (global.get $cont-stack) (global.get $cont-stack-top) @@ -159,6 +177,22 @@ lower' g e = error $ case Gyehoek.Sexp.encode e of Left _ -> show e Right x -> T.unpack x +lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx +lowerKappa g (MkKappa xs m) = do + let g' = g & #vars .~ V.fromList xs + m' <- lower' g' m + let body = mconcat + [ xs & ifoldMap \n _ -> + let n' = succ n + in popArg n <> [expr|(local.set #{n'})|] + , m' + ] + Wasm.defineFunction [wat| + (func (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + ##{body}) + |] + lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx lowerLambda g (MkLambda xs ktail m) = do let g' = g & #vars .~ V.fromList xs diff --git a/t.wat b/t.wat index 13092cc..aed853a 100644 --- a/t.wat +++ b/t.wat @@ -37,33 +37,79 @@ ref.as_non_null (global.set $result)) (func - $scm-entry (param i32) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 123) + (global.get $arg-array) + (i32.const 0) + (array.get $arg-array-type) + ref.as_non_null + (local.set 1) + (local.get 1) + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u + (local.get 1) + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u + i32.mul (i32.const 1) i32.shl ref.i31 - (call $gh-truthy?) - (if - (then - (global.get $arg-array) - (global.get 0) - (i32.const 777) - (i32.const 1) - i32.shl - ref.i31 - (array.set $arg-array-type) - (return_call $halt (i32.const 1))) - (else - (global.get $arg-array) - (global.get 0) - (i32.const 555) - (i32.const 1) - i32.shl - ref.i31 - (array.set $arg-array-type) - (return_call $halt (i32.const 1))))) + (local.set 2) + (global.get $arg-array) + (global.get 0) + (local.get 2) + (array.set $arg-array-type) + (i32.const 1) + (global.get $cont-stack) + (global.get $cont-stack-top) + (array.get $cont-stack-type) + ref.as_non_null + (global.get $cont-stack-top) + (i32.const 1) + i32.sub + (global.set $cont-stack-top) + (return_call_ref $cont-type)) + (elem declare funcref (ref.func 3)) + (func + (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (global.get $arg-array) + (i32.const 0) + (array.get $arg-array-type) + ref.as_non_null + (local.set 1) + (global.get $arg-array) + (global.get 0) + (local.get 1) + (array.set $arg-array-type) + (return_call $halt (i32.const 1))) + (func + $scm-entry + (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (i32.const 0) + (ref.func 3) + (struct.new $closure) + (local.set 1) + (global.get $arg-array) + (global.get 0) + (i32.const 5) + (i32.const 1) + i32.shl + ref.i31 + (array.set $arg-array-type) + (i32.const 1) + (local.get 1) + ref.func + (global.get $cont-stack) + (global.get $cont-stack-top) + (array.set $cont-stack-type) + (global.set + $cont-stack-top + (i32.add (i32.const 1) (global.get $cont-stack-top))) + (return_call_ref $cont-type)) (func (export "main") (call $scm-entry (i32.const 0))