idk

src/Gyehoek/CPS/Lower.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
@@ -33,6 +34,7 @@ import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
 import Language.Sexp.Located (pattern ParenList)
 import Debug.Pretty.Simple
+import Control.Monad.Fix
 
 
 data Env = MkEnv
@@ -55,6 +57,8 @@ data Runtime = MkRuntime
   , contStackType :: Idx
   , contStackTop :: Idx
   , contStack :: Idx
+  , result :: Idx
+  , halt :: Idx
   }
   deriving (Show, Generic)
 
@@ -103,13 +107,16 @@ lowerVal g (ValLit l) =
       <> ins "ref.i31" []
     _ -> _
 
-lowerVal g (ValVar x) = ins "local.get" [sxp l]
+lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
   where
     l = V.elemIndex x g.vars ^?! _Just
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
-lower' g (Halt [e]) = pure $ lowerVal g e
+lower' g (Halt [v]) = pure . mconcat $
+  [ pushArg g.runtime 0 (lowerVal g v)
+  , ins "return_call" [sxp @Int 1]
+  ]
 
 lower' g (ExpPrim p rs e) =
   case p of
@@ -144,16 +151,22 @@ lower' g (ExpContinue k [x]) = pure . mconcat $
     l = V.elemIndex k g.kvars ^?! _Just
 
 lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
-  idx <- defun [i32] [] (replicate 5 scm) \_ ->
+  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
     let g' = g & #vars <>~ V.fromList xs
                & #kvars <>~ [ktail]
-    in lower' g' m
+    m' <- lower' g' m
+    pure . mconcat $
+      [ xs & ifoldMap \n _ ->
+          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
+      , m'
+      ]
+  declareFuncref idx
   let g' = g & #vars <>~ [r]
   let n = length g.vars
   e' <- lower' g' e
   pure . mconcat $
     [ ins "ref.func" [sxp idx]
-    , ins "local.set" [sxp n]
+    , ins "local.set" [sxp (n+1)]
     , e'
     ]
 
@@ -173,7 +186,7 @@ lowerBinOp op g x y r e = do
     , ins "i31.get_s" []
     , ins op []
     , ins "ref.i31" []
-    , ins "local.set" [sxp n]
+    , ins "local.set" [sxp (1+n)]
     , e'
     ]
   where
@@ -187,31 +200,50 @@ scm = ref eq
 
 
 emitRuntime :: GenMod :> es => Eff es Runtime
-emitRuntime = do
+emitRuntime = mfix \runtime -> do
   heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
     [ Wasm.mut i32 ]
   -- cont stack
   contType <- Wasm.deftype $ Wasm.func [i32] []
-  contStackType <- Wasm.deftype $ array (refnull (fromIdx contType))
+  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
-  contStackTop <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0]
+  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
   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
+  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
-  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _
+  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
+    ins "i32.const" [sxp @Int 32]
+    <> ins "array.new_default" [sxp argArrayType]
   -- consIdx <- Wasm.defun _ _ _ _
+  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
+  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    pure . mconcat $
+      [ popArg runtime 0
+      , ins "global.set" [sxp result]
+      ]
   pure $ MkRuntime
     {argArray,argArrayType
-    ,contStack,contStackTop,contStackType,contType}
+    ,contStack,contStackTop,contStackType,contType
+    ,result,halt}
   -- pure $ error "todo"
 
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
-  let env = MkEnv runtime mempty mempty
+  let g = MkEnv runtime mempty mempty
+  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    lower' g e
   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    lower' env e
+    pure . mconcat $
+      -- push return cont
+      [--  ins "ref.func" [sxp halt]
+      -- make call
+      ins "i32.const" [sxp @Int 0]
+      , ins "call" [sxp scm_entry]
+      , ins "global.get" [sxp runtime.result]
+      , ins "ref.as_non_null" []
+      ]
   Wasm.export "main" "func" main
 
 lowerProgram :: Program -> Eff es Text

src/Gyehoek/Wasm.hs

@@ -358,6 +358,7 @@ instance SexpIso Module where
     ParenList $
       [ Symbol "module" ]
       <> (m ^.. #types . each . to sxp)
+      <> (m ^.. #globals . each . to sxp)
       <> (m ^.. #funcrefs . each . to sxp)
       <> (m ^.. #functions . each . to sxp)
       <> (m ^.. #exports . each . to sxp)

t.wat

@@ -1,31 +1,69 @@
 (module
-  (type $heap-object (sub (struct (field (mut i32)))))
+ (type $heap-object (sub (struct (field (mut i32)))))
-  (type (func (param i32) (result)))
+ (type $open-procedure (func (param i32)))
-  (type (array (ref null 1)))
+ (type $closure (sub $heap-object
-  (type (array (ref eq)))
+                     (struct (field (mut i32))
-  (func
+                             (field (ref $open-procedure)))))
-    (param i32)
+ (type $cont-stack-type (array (mut (ref null $open-procedure))))
-    (result)
+ (type $arg-array-type (array (mut (ref null eq))))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+ (global $cont-stack-top (mut i32) (i32.const 0))
-    (global.get 2)
+ (global $cont-stack (ref $cont-stack-type)
-    (i32.const 0)
+         (i32.const 128)
-    (local.get 0)
+         (array.new_default $cont-stack-type))
-    (array.set 3)
+ (global $arg-array (ref $arg-array-type)
-    (i32.const 1)
+         (i32.const 32)
-    (global.get 1)
+         (array.new_default $arg-array-type))
-    (global.get 0)
+ (global (mut (ref null eq)) (ref.null eq))
-    (array.get 2)
+ (elem declare funcref (ref.func 1))
-    ref.as_non_null
+ (func
-    (global.get 0)
+  (param i32)
-    (i32.const 1)
+  (result)
-    i32.sub
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (global.set 0)
+  (global.get 2)
-    (return_call_ref 1))
+  (i32.const 0)
-  (func
+  (array.get 3)
-    (param)
+  ref.as_non_null
-    (result (ref eq))
+  (global.set 3))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+ (func
-    (ref.func 0)
+  (param i32)
-    (local.set 0)
+  (result)
-    (local.get 0))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-  (export "main" (func 0)))
+  (global.get 2)
+  (i32.const 0)
+  (array.get 3)
+  ref.as_non_null
+  (local.set 1)
+  (global.get 2)
+  (i32.const 0)
+  (local.get 1)
+  (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 i32)
+  (result)
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (ref.func 1)
+  (local.set 1)
+  (global.get 2)
+  (i32.const 0)
+  (local.get 1)
+  (array.set 3)
+  (return_call 1))
+ (func
+  (param)
+  (result (ref eq))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (i32.const 0)
+  (call 1)
+  (global.get 3)
+  ref.as_non_null)
+ (export "main" (func 3)))

t2.wat

@@ -0,0 +1,65 @@
+(module
+ (type $heap-object (sub (struct (field (mut i32)))))
+ (type $open-procedure (func (param i32)))
+ (type $closure (sub $heap-object
+                     (struct (field (mut i32))
+                             (field (ref $open-procedure)))))
+ (type $cont-stack-type (array (mut (ref null $open-procedure))))
+ (type $arg-array-type (array (mut eqref)))
+ (type (func (result (ref eq))))
+ (global $cont-stack-top (mut i32) (i32.const 0))
+ (global $cont-stack (ref $cont-stack-type)
+         (array.new_default $cont-stack-type (i32.const 128)))
+ (global $arg-array (ref $arg-array-type)
+         (array.new_default $arg-array-type (i32.const 32)))
+ (global (mut eqref) (ref.null eq))
+ (elem declare funcref (ref.func 1))
+ (func $halt (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (global.set 3
+                   (ref.as_non_null
+                    (array.get $arg-array-type
+                               (global.get $arg-array)
+                               (i32.const 0)))))
+ (func $f1 (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       ;; pop arg 0
+       (local.set
+        1
+        (ref.as_non_null
+         (array.get $arg-array-type
+                    (global.get $arg-array)
+                    (i32.const 0))))
+       ;; push arg 0
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       ;; pop continuation
+       (return_call_ref
+        $open-procedure
+        (i32.const 1)
+        (ref.as_non_null (array.get $cont-stack-type
+                                    (global.get $cont-stack)
+                                    (global.get $cont-stack-top)))
+        (global.set $cont-stack-top
+                    (i32.sub
+                     (global.get $cont-stack-top)
+                     (i32.const 1)))))
+ (func $f2 (type $open-procedure) (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (local.set 1
+                  (struct.new $closure
+                              (i32.const 0)
+                              (ref.func $f1)))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       (i32.const 1)
+       (return_call $f1))
+ (func $main (export "main") (result (ref eq))
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (call $f2 (i32.const 0))
+       (ref.as_non_null
+        (global.get 3))))