From 4522e455dd9c812b1d640a6523b1b0bf76d6853d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 11 Jul 2026 23:51:39 -0600 Subject: [PATCH] unitype --- golden/arith/out.wat | 24 +++++++++- golden/if-false/out.wat | 10 ++-- golden/if-true/out.wat | 10 ++-- src/Gyehoek/CPS/Lower.hs | 7 ++- src/Gyehoek/Wasm.hs | 100 ++++++++++++++++++++++++++++++++------- wasmtime.toml | 6 +++ 6 files changed, 128 insertions(+), 29 deletions(-) create mode 100644 wasmtime.toml diff --git a/golden/arith/out.wat b/golden/arith/out.wat index 3ec9052..6931bec 100644 --- a/golden/arith/out.wat +++ b/golden/arith/out.wat @@ -1,19 +1,39 @@ (module + (type (sub (struct (field (mut i32))))) (func (param) - (result i32) - (local i32 i32 i32 i32 i32) + (result (ref eq)) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) (i32.const 3) + ref.i31 + (ref.cast (ref i31)) + i31.get_s (i32.const 4) + ref.i31 + (ref.cast (ref i31)) + i31.get_s i32.mul + ref.i31 (local.set 0) (i32.const 2) + ref.i31 + (ref.cast (ref i31)) + i31.get_s (i32.const 5) + 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)) (export "main" (func 0))) \ No newline at end of file diff --git a/golden/if-false/out.wat b/golden/if-false/out.wat index 7dee941..88f2ff4 100644 --- a/golden/if-false/out.wat +++ b/golden/if-false/out.wat @@ -1,11 +1,13 @@ (module + (type (sub (struct (field (mut i32))))) (func (param) - (result i32) - (local i32 i32 i32 i32 i32) + (result (ref eq)) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) (i32.const 0) + ref.i31 (if (result i32) - (then (i32.const 777)) - (else (i32.const 555)))) + (then (i32.const 777) ref.i31) + (else (i32.const 555) ref.i31))) (export "main" (func 0))) \ No newline at end of file diff --git a/golden/if-true/out.wat b/golden/if-true/out.wat index 5fcebbe..8189412 100644 --- a/golden/if-true/out.wat +++ b/golden/if-true/out.wat @@ -1,11 +1,13 @@ (module + (type (sub (struct (field (mut i32))))) (func (param) - (result i32) - (local i32 i32 i32 i32 i32) + (result (ref eq)) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) (i32.const 1) + ref.i31 (if (result i32) - (then (i32.const 777)) - (else (i32.const 555)))) + (then (i32.const 777) ref.i31) + (else (i32.const 555) ref.i31))) (export "main" (func 0))) \ No newline at end of file diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 1ec0b0d..136d6d9 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -31,7 +31,8 @@ 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) +import Gyehoek.Wasm (i32, ins, sxp, eq, ref, i31, Type (..)) +import Language.Sexp.Located (pattern ParenList) data Env = MkEnv { vars :: Vector Name } @@ -103,8 +104,12 @@ lowerBinOp op g x y r e = scm = ref eq + + lower :: Exp -> Eff es Text lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do + Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct + [ Wasm.mut i32 ] main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> lower' emptyEnv e Wasm.export "main" "func" main diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index bb03773..c8e6eb4 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -11,13 +11,14 @@ {-# LANGUAGE DerivingVia #-} module Gyehoek.Wasm ( defun - , deftype + , rec' , start , runGenMod , execGenMod , renderModule , Module , Function + , Type(..) , Expr , Instr , GenMod @@ -32,11 +33,18 @@ module Gyehoek.Wasm , eq , i31ref , i31 + , struct + , mut + , sub + , deftype + , namedType + , type' + , deftypeNamed ) where import Language.SexpGrammar - ( SexpIso(..), list, el, (>>>), rest, sym, symbol ) + ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) ) import Language.SexpGrammar qualified as Sexp import Language.SexpGrammar.Generic import Data.List (List) @@ -64,10 +72,11 @@ import qualified Gyehoek.Sexp import GHC.IsList (IsList(..)) import Data.Coerce (coerce) import qualified Control.Category +import Data.Functor (void) data Module = MkModule - { types :: Vector Type + { types :: Vector RecType , functions :: Vector Function , start :: Maybe Idx , exports :: Vector Export @@ -85,6 +94,9 @@ instance Semigroup Module where instance Monoid Module where mempty = MkModule mempty mempty Nothing mempty +newtype RecType = MkRecType { inner :: Vector Type } + deriving (Show, Generic) + data Function = MkFunction { params :: List Type , result :: List Type @@ -106,11 +118,13 @@ newtype Instr = MkInstr { inner :: Sexp } newtype Type = MkType { inner :: Sexp } deriving (Show, Generic) -newtype Idx = MkIdx { getIdx :: Natural } - deriving newtype (Show) +data Idx + = IdxNumeric Natural + | IdxNamed Text + deriving (Show, Generic) data GenMod :: Effect where - DefType :: Type -> GenMod m Idx + DefRecType :: List Type -> GenMod m (List Idx) Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx Start :: Idx -> GenMod m () Export :: Text -> Text -> Idx -> GenMod m () @@ -123,8 +137,16 @@ export name ty idx = send $ Export name ty idx start :: (GenMod :> es) => Idx -> Eff es () start = send . Start +rec' :: (GenMod :> es) => List Type -> Eff es (List Idx) +rec' = send . DefRecType + deftype :: (GenMod :> es) => Type -> Eff es Idx -deftype = send . DefType +deftype (MkType t) = send (DefRecType [type' t]) <&> \case + [x] -> x + x -> error $ "unreachable " <> show x + +deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es () +deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t]) defun :: (GenMod :> es) @@ -144,20 +166,21 @@ defun params result locals code = send $ Defun params result locals code runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module) runGenMod = reinterpret (runStateLocal (mempty :: Module)) \cases - _ (DefType t) -> state \m -> - ( MkIdx . fromIntegral . length $ m.types - , m & #types <>~ V.singleton t + _ (DefRecType ts) -> state \m -> + ( let prev_n = sumOf (#types . each . #inner . to V.length) m + in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1] + , m & #types <>~ V.singleton (MkRecType (V.fromList ts)) ) _ (Start idx) -> assign #start (Just idx) _ (Export name ty idx) -> #exports <>= V.singleton e where e = MkExport $ ParenList [ "export", sxp name, ParenList [ "func", sxp idx ] ] - _ (Defun params result locals code) -> state \m -> - let idx = MkIdx . fromIntegral . length $ m.functions + _ (Defun params res locals code) -> state \m -> + let idx = IdxNumeric . fromIntegral . length $ m.functions in ( idx , m & #functions <>~ V.singleton - (MkFunction params result locals (code idx)) + (MkFunction params res locals (code idx)) ) execGenMod = fmap snd . runGenMod @@ -168,6 +191,18 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty ref :: Type -> Type ref (MkType x) = MkType . ParenList $ [Symbol "ref", x] +sub :: List Idx -> Type -> Type +sub supers (MkType x) = MkType . ParenList $ + Symbol "sub" : (sxp <$> supers) ++ [x] + +mut :: Type -> Type +mut (MkType x) = MkType . ParenList $ [Symbol "mut", x] + +struct :: List Type -> Type +struct xs = MkType . ParenList $ + Symbol "struct" : (xs ^.. each . #inner . to field) + where field x = ParenList [Symbol "field", x] + i32, i31ref, eq, i31 :: Type i32 = MkType $ Symbol "i32" i31ref = MkType $ Symbol "i31ref" @@ -177,11 +212,40 @@ i31 = MkType $ Symbol "i31" instance SexpIso Idx where - sexpIso = Sexp.integer >>> Sexp.partialOsi f g + sexpIso = match + $ With (\numeric -> num >>> numeric) + $ With (\named -> symbol >>> named) + $ End where - f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural" - | otherwise = Right . MkIdx $ fromIntegral n - g (MkIdx n) = fromIntegral n + num = Sexp.integer >>> Sexp.partialOsi f g + where + f n | n < 0 = Left $ Sexp.unexpected "negative" + <> Sexp.expected "natural" + | otherwise = Right $ fromIntegral n + g n = fromIntegral n + +instance SexpIso RecType where + sexpIso = with \rectype -> + Sexp.coproduct + [ sexpIso @Type >>> Sexp.partialIso + (\x -> [x]) + (\case [x] -> Right x + _ -> Left $ Sexp.expected "a single type") + , list (el (sym "rec") >>> rest sexpIso) + ] + >>> Sexp.iso V.fromList V.toList + >>> rectype + -- where + -- typedef + -- :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t) + -- -> Sexp.Grammar Position (Sexp :- t) (a :- t) + -- typedef x = list (el (sym "type") >>> el x) + +type' :: Sexp -> Type +type' e = MkType . ParenList $ [ "type", e ] + +namedType :: Text -> Sexp -> Type +namedType name e = MkType . ParenList $ [ "type", Symbol name, e ] instance SexpIso Instr where sexpIso = Sexp.iso coerce coerce @@ -213,7 +277,7 @@ instance SexpIso Module where sexpIso = Sexp.partialOsi (const $ Left mempty) \m -> ParenList $ [ Symbol "module" ] - <> (m ^.. #types . each . #inner) + <> (m ^.. #types . each . to sxp) <> (m ^.. #functions . each . to sxp) <> (m ^.. #exports . each . to sxp) diff --git a/wasmtime.toml b/wasmtime.toml new file mode 100644 index 0000000..174e8f9 --- /dev/null +++ b/wasmtime.toml @@ -0,0 +1,6 @@ +# Comment out certain settings to use default values. +# For more settings, please refer to the documentation: +# https://bytecodealliance.github.io/wasmtime/cli-cache.html + +[wasm] +gc=true \ No newline at end of file