msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

idk

Browse Source
This commit is contained in:
Madeleine Sydney Slaga
2026-07-15 02:12:15 -06:00
parent f593227a70
commit 08b8bc50d6
4 changed files with 180 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Gyehoek/CPS/Lower.hs
+46 -14
View File
@@ -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))
contStackTop <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0]
contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
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
argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _
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]
-- 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
+1
View File
@@ -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
+68 -30
View File
@@ -1,31 +1,69 @@
(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 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))
(ref.func 0)
(local.set 0)
(local.get 0))
(export "main" (func 0)))
(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 (ref null eq))))
(global $cont-stack-top (mut i32) (i32.const 0))
(global $cont-stack (ref $cont-stack-type)
(i32.const 128)
(array.new_default $cont-stack-type))
(global $arg-array (ref $arg-array-type)
(i32.const 32)
(array.new_default $arg-array-type))
(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))
(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
+65
View File
@@ -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))))