lam

golden/lambda/source.scm

@@ -0,0 +1 @@
+(λ (x) x)

src/Gyehoek/CPS/Lower.hs

@@ -30,7 +30,7 @@ import qualified Data.Vector.Strict as V
 import Data.IntMap.Strict (IntMap)
 import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Wasm (i32, ins, sxp, eq, ref, i31, Type (..), Idx, GenMod)
+import Gyehoek.Wasm hiding (Expr)
 import Language.Sexp.Located (pattern ParenList)
 
 
@@ -50,7 +50,11 @@ instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
 data Runtime = MkRuntime
-  { consIdx :: Idx
+  { argArrayIdx :: Idx
+  , contType :: Idx
+  , contStackType :: Idx
+  , contStackIndexIdx :: Idx
+  , contStackIdx :: Idx
   }
   deriving (Show, Generic)
 
@@ -100,6 +104,26 @@ lower' g (ExpIf c t f) = do
   pure $ lowerVal g c
     <> Wasm.if' (Wasm.result [i32]) t' f'
 
+lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
+  _ <- defun [i32] [] [] \_ -> do
+    let stack = g.runtime.contStackIdx
+    let index = g.runtime.contStackIndexIdx
+    m' <- lower' g m
+    pure . mconcat $
+      [ m'
+      , ins "global.get" [sxp index]
+      , ins "i32.const" [sxp @Int 1]
+      , ins "i32.sub" []
+      , ins "global.set" [sxp index]
+      , ins "global.get" [sxp stack]
+      , 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
+
 lowerBinOp
   :: (GenMod :> es)
   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
@@ -129,17 +153,30 @@ scm = ref eq
 
 emitRuntime :: GenMod :> es => Eff es Runtime
 emitRuntime = do
-  Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
     [ Wasm.mut i32 ]
-  consIdx <- Wasm.defun _ _ _ _
-  pure $ MkRuntime {consIdx}
+  -- 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]
+  contStackIdx <- 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)) _
+  -- consIdx <- Wasm.defun _ _ _ _
+  pure $ MkRuntime
+    {argArrayIdx
+    ,contStackIdx,contStackIndexIdx,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
+  runtime <- emitRuntime
+  let env = MkEnv runtime mempty
   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    lower' emptyEnv e
+    lower' env e
   Wasm.export "main" "func" main
 
 lowerProgram :: Program -> Eff es Text

src/Gyehoek/Wasm.hs

@@ -42,6 +42,11 @@ module Gyehoek.Wasm
   , namedType
   , type'
   , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
+  , refnull
   )
   where
 
@@ -82,6 +87,7 @@ data Module = MkModule
   , functions :: Vector Function
   , start :: Maybe Idx
   , exports :: Vector Export
+  , globals :: Vector Global
   }
   deriving (Show, Generic)
 
@@ -94,7 +100,13 @@ instance Semigroup Module where
     }
 
 instance Monoid Module where
-  mempty = MkModule mempty mempty Nothing mempty
+  mempty = MkModule mempty mempty Nothing mempty mempty
+
+data Global = MkGlobal
+  { ty :: Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
 
 newtype RecType = MkRecType { inner :: Vector Type }
   deriving (Show, Generic)
@@ -131,6 +143,7 @@ data GenMod :: Effect where
         -> (Idx -> m Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> Expr -> GenMod m Idx
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -151,6 +164,9 @@ deftype (MkType t) = send (DefRecType [type' t]) <&> \case
 deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
 deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
 
+defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
+defglobal t e = send $ DefGlobal t e
+
 defun
   :: (GenMod :> es)
   => List Type -> List Type -> List Type
@@ -191,6 +207,10 @@ runGenMod =
           let func = MkFunction {params,result,locals,body}
           let m' = m & #functions <>~ V.singleton func
           pure (idx, m')
+    _ (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')
 
 execGenMod = fmap snd . runGenMod
 
@@ -200,10 +220,16 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
 ref :: Type -> Type
 ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
 
+refnull :: Type -> Type
+refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
+
 sub :: List Idx -> Type -> Type
 sub supers (MkType x) = MkType . ParenList $
   Symbol "sub" : (sxp <$> supers) ++ [x]
 
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", x]
+
 mut :: Type -> Type
 mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
 
@@ -212,12 +238,28 @@ struct xs = MkType . ParenList $
   Symbol "struct" : (xs ^.. each . #inner . to field)
   where field x = ParenList [Symbol "field", x]
 
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
 i32, i31ref, eq, i31 :: Type
 i32 = MkType $ Symbol "i32"
 i31ref = MkType $ Symbol "i31ref"
 eq = MkType $ Symbol "eq"
 i31 = MkType $ Symbol "i31"
 
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
+
 
 
 instance SexpIso Idx where
@@ -261,6 +303,14 @@ type' e = MkType . ParenList $ [ "type", e ]
 namedType :: Text -> Sexp -> Type
 namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
 
+instance SexpIso Global where
+  sexpIso = with \glob ->
+    list ( el (sym "global")
+         >>> el (sexpIso @Type)
+         >>> restCode
+         )
+    >>> glob
+
 instance SexpIso Instr where
   sexpIso = Sexp.iso coerce coerce
 
@@ -270,22 +320,26 @@ instance SexpIso Type where
 instance SexpIso Export where
   sexpIso = Sexp.iso coerce coerce
 
+restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
+restCode =
+  rest (sexpIso @Instr)
+  >>> Sexp.onTail
+           (Sexp.iso
+            (view instrsExpr)
+            (review instrsExpr))
+    where
+      instrsExpr :: Iso' (List Instr) Expr
+      instrsExpr = vector . coerced
+
 instance SexpIso Function where
   sexpIso = with \func ->
     list ( el (sym "func")
        >>> el (list $ el (sym "param") >>> rest (sexpIso @Type))
        >>> el (list $ el (sym "result") >>> rest (sexpIso @Type))
        >>> el (list $ el (sym "local") >>> rest (sexpIso @Type))
-       >>> rest (sexpIso @Instr)
-       >>> Sexp.onTail
-           (Sexp.iso
-            (view instrsExpr)
-            (review instrsExpr))
+       >>> restCode
          )
      >>> func
-    where
-      instrsExpr :: Iso' (List Instr) Expr
-      instrsExpr = vector . coerced
 
 instance SexpIso Module where
   sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->

t.wat

@@ -1,47 +1,14 @@
 (module
   (type $heap-object (sub (struct (field (mut i32)))))
+  (type (func (param i32) (result)))
+  (type (array (ref null 1)))
+  (type (array (ref eq)))
   (func
     (param)
     (result (ref eq))
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 3)
+    (i32.const 1)
     (i32.const 2)
     i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 4)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 0)
-    (i32.const 2)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    (i32.const 5)
-    (i32.const 2)
-    i32.shl
-    ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.mul
-    ref.i31
-    (local.set 1)
-    (local.get 0)
-    (ref.cast (ref i31))
-    i31.get_s
-    (local.get 1)
-    (ref.cast (ref i31))
-    i31.get_s
-    i32.add
-    ref.i31
-    (local.set 2)
-    (local.get 2))
+    ref.i31)
   (export "main" (func 0)))

u.wat

@@ -0,0 +1,7 @@
+(module
+ (type $cont (func (param i32)))
+ (type $cont-stack-type (array (ref null $cont)))
+ (global $cont-stack (ref $cont-stack-type)
+         (array.new_default $cont-stack-type (i32.const 128)))
+ (func (export "main") (result (ref eq))
+       (ref.i31 (i32.const 123))))