appy

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,8 @@ 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)
+import Gyehoek.Sexp (encodeOrShow, toSexp)
 
 
 data Env = MkEnv
@@ -41,6 +43,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
@@ -56,7 +61,7 @@ makeSmallFixnum = [expr|
 pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
 pushArg n e = [expr|
     (global.get $arg-array)
-    (global.get #{n})
+    (i32.const #{n})
     ##{e}
     (array.set $arg-array-type)
   |]
@@ -124,6 +129,22 @@ 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]
+  e' <- lower' g' e
+  pure [expr|
+    (@gyehoek "push cont" :idx #{idx})
+    (array.set $cont-stack-type
+               (global.get $cont-stack)
+               (global.get $cont-stack-top)
+               (ref.func 4))
+    (global.set $cont-stack-top
+                (i32.add (global.get $cont-stack-top)
+                         (i32.const 1)))
+    ##{e'}
+  |]
+
 lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
   idx <- lowerLambda g lam
   let g' = g & #vars <>~ [r]
@@ -137,19 +158,45 @@ 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
+  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
+  args <- fold <$>
+    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
   pure [expr|
-    ##{arg}
+    (@gyehoek "load args")
+    ##{args}
     (i32.const 1)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
+    ##{f'}
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type)
+    ;; (@gyehoek todo
+    ;;  (f' ##{f'})
+    ;;  (ktail #{l}))
+     |]
+
+lower' g e@(ExpContinue k xs) = do
+  let nargs = length xs
+  args <- fold <$>
+    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
+  let origin = encodeOrShow @_ @Text e
+  pure [expr|
+    (@gyehoek :origin #{origin})
+    (@gyehoek "push args")
+    ##{args}
+    (@gyehoek "nargs")
+    (i32.const #{nargs})
+    (@gyehoek "pop cont stack")
     (global.get $cont-stack-top)
     (i32.const #{l})
     i32.sub
     (global.set $cont-stack-top)
+    (global.get $cont-stack)
+    (global.get $cont-stack-top)
+    (array.get $cont-stack-type)
+    ref.as_non_null
     (return_call_ref $cont-type)
   |]
   where
@@ -159,8 +206,28 @@ 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 e@(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'
+        ]
+  let origin = encodeOrShow @_ @Text e
+  idx <- Wasm.defineFunction [wat|
+    (func (param i32)
+      (@gyehoek :origin #{origin})
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{body})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
+
 lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-lowerLambda g (MkLambda xs ktail m) = do
+lowerLambda g e@(MkLambda xs ktail m) = do
   let g' = g & #vars .~ V.fromList xs
              & #kvars <>~ [ktail]
   m' <- lower' g' m
@@ -170,8 +237,10 @@ lowerLambda g (MkLambda xs ktail m) = do
             in popArg n <> [expr|(local.set #{n'})|]
         , m'
         ]
+  let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
+      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{body})
   |]
@@ -253,8 +322,10 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
   let g = MkEnv mempty mempty
   e' <- lower' g e
+  let origin = encodeOrShow @_ @Text e
   Wasm.defineFunction [wat|
     (func $scm-entry (param i32)
+      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{e'})
   |]