idk

src/Gyehoek/CPS/Lower.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultilineStrings #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
@@ -33,17 +32,17 @@ 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
-import Control.Monad.Fix
 
 
 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
 
@@ -57,8 +56,6 @@ data Runtime = MkRuntime
   , contStackType :: Idx
   , contStackTop :: Idx
   , contStack :: Idx
-  , result :: Idx
-  , halt :: Idx
   }
   deriving (Show, Generic)
 
@@ -107,16 +104,13 @@ lowerVal g (ValLit l) =
       <> ins "ref.i31" []
     _ -> _
 
-lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
+lowerVal g (ValVar x) = ins "local.get" [sxp l]
   where
     l = V.elemIndex x g.vars ^?! _Just
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
-lower' g (Halt [v]) = pure . mconcat $
-  [ pushArg g.runtime 0 (lowerVal g v)
-  , ins "return_call" [sxp @Int 1]
-  ]
+lower' g (Halt [e]) = pure $ lowerVal g e
 
 lower' g (ExpPrim p rs e) =
   case p of
@@ -141,32 +135,21 @@ lower' g (ExpContinue k [x]) = pure . mconcat $
   , 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.const" [sxp @Int 1]
   , 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
+  where rt = g.runtime
 
 lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
-  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
-    let g' = g & #vars <>~ V.fromList xs
-               & #kvars <>~ [ktail]
-    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]
+  idx <- defun [i32] [] (replicate 5 scm) \_ -> lower' g m
+  let g' = g & #vars <>~ []
   let n = length g.vars
   e' <- lower' g' e
   pure . mconcat $
     [ ins "ref.func" [sxp idx]
-    , ins "local.set" [sxp (n+1)]
+    , ins "local.set" [sxp n]
     , e'
     ]
 
@@ -186,7 +169,7 @@ lowerBinOp op g x y r e = do
     , ins "i31.get_s" []
     , ins op []
     , ins "ref.i31" []
-    , ins "local.set" [sxp (1+n)]
+    , ins "local.set" [sxp n]
     , e'
     ]
   where
@@ -200,50 +183,31 @@ scm = ref eq
 
 
 emitRuntime :: GenMod :> es => Eff es Runtime
-emitRuntime = mfix \runtime -> do
+emitRuntime = 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 $ mut $ refnull (fromIdx contType)
-  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
+  contStackType <- Wasm.deftype $ array (refnull (fromIdx contType))
+  contStackTop <- Wasm.defglobal 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 $ mut $ refnull eq
-  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
-    ins "i32.const" [sxp @Int 32]
-    <> ins "array.new_default" [sxp argArrayType]
+  argArrayType <- Wasm.deftype $ Wasm.array scm
+  argArray <- Wasm.defglobal (ref (Wasm.fromIdx 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
-    ,result,halt}
+    {argArray
+    ,contStack,contStackTop,contStackType,contType}
   -- pure $ error "todo"
 
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
-  let g = MkEnv runtime mempty mempty
-  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
-    lower' g e
+  let env = MkEnv runtime mempty
   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    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" []
-      ]
+    lower' env e
   Wasm.export "main" "func" main
 
 lowerProgram :: Program -> Eff es Text

src/Gyehoek/Wasm.hs

@@ -207,17 +207,17 @@ runGenMod =
       where e = MkExport $ ParenList
               [ "export", sxp name, ParenList [ "func", sxp idx ] ]
     env (Defun params result locals code) ->
-      localSeqUnlift env \unlift -> do
-        m <- get
-        -- the least unused function index, computed as the number
-        -- of currently allocated functions.
-        let idx = IdxNumeric . fromIntegral . length $ m.functions
-        -- the body is computed with access to the newly allocated
-        -- index `idx` for the sake of recursive occurences.
-        body <- unlift $ code idx
-        let func = MkFunction {params,result,locals,body}
-        #functions <>= V.singleton func
-        pure idx
+      localSeqUnlift env \unlift ->
+        stateM \m -> do
+          -- the least unused function index, computed as the number
+          -- of currently allocated functions.
+          let idx = IdxNumeric . fromIntegral . length $ m.functions
+          -- the body is computed with access to the newly allocated
+          -- index `idx` for the sake of recursive occurences.
+          body <- unlift $ code idx
+          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)
@@ -358,7 +358,6 @@ 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,62 +1,14 @@
 (module
   (type $heap-object (sub (struct (field (mut i32)))))
   (type (func (param i32) (result)))
-  (type (array (mut (ref null 1))))
-  (type (array (mut (ref null eq))))
-  (global (mut i32) (i32.const 0))
-  (global (ref 2) (i32.const 128) (array.new_default 2))
-  (global (ref 3) (i32.const 32) (array.new_default 3))
-  (global (mut (ref null eq)) (ref.null eq))
-  (elem declare funcref (ref.func 1))
-  (func
-    (param i32)
-    (result)
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (global.get 2)
-    (i32.const 0)
-    (array.get 3)
-    ref.as_non_null
-    (global.set 3))
-  (func
-    (param i32)
-    (result)
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (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))
+  (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 0)
-    (call 1)
-    (global.get 3)
-    ref.as_non_null)
-  (export "main" (func 3)))
+    (i32.const 1)
+    (i32.const 2)
+    i32.shl
+    ref.i31)
+  (export "main" (func 0)))