appy

.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)))))))

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 = _
 

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
+lower' g (ExpApply f xs ktail) = do
-  arg <- pushArg 0 <$> lowerVal g x
+  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

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?)
+    (local.set 2)
-    (if
+    (global.get $arg-array)
-      (then
+    (global.get 0)
-        (global.get $arg-array)
+    (local.get 2)
-        (global.get 0)
+    (array.set $arg-array-type)
-        (i32.const 777)
+    (i32.const 1)
-        (i32.const 1)
+    (global.get $cont-stack)
-        i32.shl
+    (global.get $cont-stack-top)
-        ref.i31
+    (array.get $cont-stack-type)
-        (array.set $arg-array-type)
+    ref.as_non_null
-        (return_call $halt (i32.const 1)))
+    (global.get $cont-stack-top)
-      (else
+    (i32.const 1)
-        (global.get $arg-array)
+    i32.sub
-        (global.get 0)
+    (global.set $cont-stack-top)
-        (i32.const 555)
+    (return_call_ref $cont-type))
-        (i32.const 1)
+  (elem declare funcref (ref.func 3))
-        i32.shl
+  (func
-        ref.i31
+    (param i32)
-        (array.set $arg-array-type)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-        (return_call $halt (i32.const 1)))))
+    (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))