idk

src/Gyehoek/CPS/Lower.hs

@@ -32,17 +32,16 @@ import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
 import Language.Sexp.Located (pattern ParenList)
+import Debug.Pretty.Simple
 
 
 data Env = MkEnv
   { runtime :: Runtime
   , vars :: Vector Name
+  , kvars :: Vector Name
   }
   deriving (Show, Generic)
 
-emptyEnv :: Env
-emptyEnv = MkEnv (error "fuck") mempty
-
 type instance Index Env = Natural
 type instance IxValue Env = Name
 
@@ -50,11 +49,12 @@ instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
 data Runtime = MkRuntime
-  { argArrayIdx :: Idx
+  { argArrayType :: Idx
+  , argArray :: Idx
   , contType :: Idx
   , contStackType :: Idx
-  , contStackIndexIdx :: Idx
+  , contStackTop :: Idx
-  , contStackIdx :: Idx
+  , contStack :: Idx
   }
   deriving (Show, Generic)
 
@@ -64,11 +64,31 @@ data Runtime = MkRuntime
 -- of the stack into the SCM unitype.
 makeSmallFixnum :: Wasm.Expr
 makeSmallFixnum = mconcat
-  [ ins "i32.const" [sxp @Int 2]
+  [ ins "i32.const" [sxp @Int 1]
   , ins "i32.shl" []
   , ins "ref.i31" []
   ]
 
+-- | Given an expression @e@ leaving a @ref eq@ atop the stack,
+-- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
+-- result of @e@.
+pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
+pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+  [ ins "global.get" [sxp argArray]
+  , ins "i32.const" [sxp n]
+  , e
+  , ins "array.set" [sxp argArrayType]
+  ]
+
+-- | Pop the nth arg from the arg-passing array onto the stack.
+popArg :: Runtime -> Int -> Wasm.Expr
+popArg (MkRuntime {argArrayType,argArray}) n = mconcat
+  [ ins "global.get" [sxp argArray]
+  , ins "i32.const" [sxp n]
+  , ins "array.get" [sxp argArrayType]
+  , ins "ref.as_non_null" []
+  ]
+
 
 
 lowerVal :: Env -> Val -> Wasm.Expr
@@ -104,23 +124,38 @@ lower' g (ExpIf c t f) = do
   pure $ lowerVal g c
     <> Wasm.if' (Wasm.result [i32]) t' f'
 
+lower' g (ExpContinue k [x]) = pure . mconcat $
+  [ pushArg rt 0 (lowerVal g x)
+  , ins "i32.const" [sxp @Int 1] -- nargs
+  -- get the return continuation.
+  , ins "global.get" [sxp rt.contStack]
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "array.get" [sxp rt.contStackType]
+  , ins "ref.as_non_null" []
+  -- decrement contStackTop, completing the "pop."
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "i32.const" [sxp @Int (1 + l)]
+  , ins "i32.sub" []
+  , ins "global.set" [sxp rt.contStackTop]
+  , ins "return_call_ref" [sxp rt.contType]
+  ]
+  where
+    rt = g.runtime
+    l = V.elemIndex k g.kvars ^?! _Just
+
 lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
-  _ <- defun [i32] [] [] \_ -> do
+  idx <- defun [i32] [] (replicate 5 scm) \_ ->
-    let stack = g.runtime.contStackIdx
+    let g' = g & #vars <>~ V.fromList xs
-    let index = g.runtime.contStackIndexIdx
+               & #kvars <>~ [ktail]
-    m' <- lower' g m
+    in lower' g' m
-    pure . mconcat $
+  let g' = g & #vars <>~ [r]
-      [ m'
+  let n = length g.vars
-      , ins "global.get" [sxp index]
+  e' <- lower' g' e
-      , ins "i32.const" [sxp @Int 1]
+  pure . mconcat $
-      , ins "i32.sub" []
+    [ ins "ref.func" [sxp idx]
-      , ins "global.set" [sxp index]
+    , ins "local.set" [sxp n]
-      , ins "global.get" [sxp stack]
+    , e'
-      , ins "global.get" [sxp index]
+    ]
-      , ins "array.get" [sxp g.runtime.contStackType]
-      , ins "return_call_ref" [sxp g.runtime.contType]
-      ]
-  _
 
 lower' g e = error . show $ e
 
@@ -158,23 +193,23 @@ emitRuntime = do
   -- cont stack
   contType <- Wasm.deftype $ Wasm.func [i32] []
   contStackType <- Wasm.deftype $ array (refnull (fromIdx contType))
-  contStackIndexIdx <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0]
+  contStackTop <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0]
-  contStackIdx <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
+  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
     ins "i32.const" [sxp @Int 128]
     <> ins "array.new_default" [sxp contStackType]
   -- arg array
   argArrayType <- Wasm.deftype $ Wasm.array scm
-  argArrayIdx <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _
+  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _
   -- consIdx <- Wasm.defun _ _ _ _
   pure $ MkRuntime
-    {argArrayIdx
+    {argArray,argArrayType
-    ,contStackIdx,contStackIndexIdx,contStackType,contType}
+    ,contStack,contStackTop,contStackType,contType}
   -- pure $ error "todo"
 
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
-  let env = MkEnv runtime mempty
+  let env = MkEnv runtime mempty mempty
   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
     lower' env e
   Wasm.export "main" "func" main

src/Gyehoek/Wasm.hs

@@ -47,6 +47,7 @@ module Gyehoek.Wasm
   , FromIdx(..)
   , func
   , refnull
+  , declareFuncref
   )
   where
 
@@ -85,6 +86,7 @@ import Data.Functor (void)
 data Module = MkModule
   { types :: Vector RecType
   , functions :: Vector Function
+  , funcrefs :: Vector Funcref
   , start :: Maybe Idx
   , exports :: Vector Export
   , globals :: Vector Global
@@ -97,10 +99,15 @@ instance Semigroup Module where
     , functions = m1.functions <> m2.functions
     , start = m2.start <|> m1.start
     , exports = m1.exports <> m2.exports
+    , funcrefs = m1.funcrefs <> m2.funcrefs
+    , globals = m1.globals <> m2.globals
     }
 
 instance Monoid Module where
-  mempty = MkModule mempty mempty Nothing mempty mempty
+  mempty = MkModule mempty mempty mempty Nothing mempty mempty
+
+newtype Funcref = MkFuncref { inner :: Idx }
+  deriving (Show, Generic)
 
 data Global = MkGlobal
   { ty :: Type
@@ -144,6 +151,7 @@ data GenMod :: Effect where
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
   DefGlobal :: Type -> Expr -> GenMod m Idx
+  DeclareFuncref :: Idx -> GenMod m ()
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -174,6 +182,9 @@ defun
   -> Eff es Idx
 defun params res locals code = send $ Defun params res locals code
 
+declareFuncref :: GenMod :> es => Idx -> Eff es ()
+declareFuncref = send . DeclareFuncref
+
 -- defun
 --   :: (GenMod :> es)
 --   => List Type -> List Type -> List Type
@@ -196,21 +207,22 @@ runGenMod =
       where e = MkExport $ ParenList
               [ "export", sxp name, ParenList [ "func", sxp idx ] ]
     env (Defun params result locals code) ->
-      localSeqUnlift env \unlift ->
+      localSeqUnlift env \unlift -> do
-        stateM \m -> do
+        m <- get
-          -- the least unused function index, computed as the number
+        -- the least unused function index, computed as the number
-          -- of currently allocated functions.
+        -- of currently allocated functions.
-          let idx = IdxNumeric . fromIntegral . length $ m.functions
+        let idx = IdxNumeric . fromIntegral . length $ m.functions
-          -- the body is computed with access to the newly allocated
+        -- the body is computed with access to the newly allocated
-          -- index `idx` for the sake of recursive occurences.
+        -- index `idx` for the sake of recursive occurences.
-          body <- unlift $ code idx
+        body <- unlift $ code idx
-          let func = MkFunction {params,result,locals,body}
+        let func = MkFunction {params,result,locals,body}
-          let m' = m & #functions <>~ V.singleton func
+        #functions <>= V.singleton func
-          pure (idx, m')
+        pure idx
     _ (DefGlobal t e) -> state \m ->
       let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
           m' = m & #globals <>~ V.singleton (MkGlobal t e)
       in (prev_n, m')
+    _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx)
 
 execGenMod = fmap snd . runGenMod
 
@@ -346,9 +358,19 @@ instance SexpIso Module where
     ParenList $
       [ Symbol "module" ]
       <> (m ^.. #types . each . to sxp)
+      <> (m ^.. #funcrefs . each . to sxp)
       <> (m ^.. #functions . each . to sxp)
       <> (m ^.. #exports . each . to sxp)
 
+instance SexpIso Funcref where
+  sexpIso = with \funcref ->
+    list ( el (sym "elem")
+         >>> el (sym "declare")
+         >>> el (sym "funcref")
+         >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx))
+         )
+    >>> funcref
+
 instance SexpIso Sexp where
   sexpIso = Control.Category.id
 

t.wat

@@ -3,12 +3,29 @@
   (type (func (param i32) (result)))
   (type (array (ref null 1)))
   (type (array (ref eq)))
+  (func
+    (param i32)
+    (result)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (global.get 2)
+    (i32.const 0)
+    (local.get 0)
+    (array.set 3)
+    (i32.const 1)
+    (global.get 1)
+    (global.get 0)
+    (array.get 2)
+    ref.as_non_null
+    (global.get 0)
+    (i32.const 1)
+    i32.sub
+    (global.set 0)
+    (return_call_ref 1))
   (func
     (param)
     (result (ref eq))
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 1)
+    (ref.func 0)
-    (i32.const 2)
+    (local.set 0)
-    i32.shl
+    (local.get 0))
-    ref.i31)
   (export "main" (func 0)))