From 1b5c93b030a31c85357379e685f326fa59833235 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Mon, 24 Aug 2026 06:21:54 -0600 Subject: [PATCH] --- gyehoek.cabal | 24 +-- src/Gyehoek/CPS/Lower.hs | 325 ------------------------------------ src/Gyehoek/Sexp/Grammar.hs | 11 -- src/Gyehoek/Stack/Lower.hs | 29 ++++ src/Gyehoek/Wasm.hs | 177 ++------------------ wit-test/gyehoek.wit | 16 ++ wit-test/program.wat | 5 + wit-test/runtime.wat | 5 + 8 files changed, 86 insertions(+), 506 deletions(-) delete mode 100644 src/Gyehoek/CPS/Lower.hs create mode 100644 src/Gyehoek/Stack/Lower.hs create mode 100644 wit-test/gyehoek.wit create mode 100644 wit-test/program.wat create mode 100644 wit-test/runtime.wat diff --git a/gyehoek.cabal b/gyehoek.cabal index c247dcb..8baa6e1 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -14,9 +14,9 @@ build-type: Simple -- extra-source-files: flag doctest - description: enable the doctest suite - default: True - manual: True + description: enable the doctest suite + default: True + manual: True common ghcstuffs-dev ghc-options: @@ -60,7 +60,6 @@ library Gyehoek.CPS.Close Gyehoek.CPS.Convert Gyehoek.CPS.Eval - Gyehoek.CPS.Lower Gyehoek.CPS.Stackify Gyehoek.CPS.Syntax Gyehoek.Driver @@ -77,6 +76,7 @@ library Gyehoek.Sexp.QQ Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax + Gyehoek.Stack.Lower Gyehoek.Stack.Syntax Gyehoek.Stack.VM Gyehoek.Wasm @@ -162,13 +162,15 @@ test-suite test -- https://github.com/martijnbastiaan/doctest-parallel/pull/66 test-suite doctest - import: ghcstuffs, ghcstuffs-dev - type: exitcode-stdio-1.0 - hs-source-dirs: test - build-depends: base + import: ghcstuffs, ghcstuffs-dev + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base default-extensions: CPP - main-is: doctest.hs + main-is: doctest.hs + if flag(doctest) - build-depends: doctest-parallel >=0.1 + build-depends: doctest-parallel >=0.1 + else - cpp-options: "-DGYEHOEK_NO_DOCTEST" + cpp-options: -DGYEHOEK_NO_DOCTEST diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs deleted file mode 100644 index a9c7a91..0000000 --- a/src/Gyehoek/CPS/Lower.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultilineStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RecursiveDo #-} -{- HLINT ignore "Use camelCase" -} -module Gyehoek.CPS.Lower - (lower, lowerProgram) where - -import Gyehoek.CPS.Syntax -import Data.Vector.Strict (Vector) -import Control.Lens hiding (op) -import Numeric.Natural -import qualified Data.Vector.Strict as V -import Gyehoek.Wasm qualified as Wasm -import Gyehoek.Wasm hiding (Expr) -import Control.Monad.Fix -import Data.Text qualified as T -import Data.Foldable (fold) -import Gyehoek.Jalmot -import Gyehoek.Sexp qualified as S -import Gyehoek.Prelude - - -data Env = MkEnv - { vars :: Vector Name - , kvars :: Vector Name - } - deriving (Show, Generic) - -type instance Index Env = Natural -type instance IxValue Env = Name - -instance Ixed Env where - ix i = #vars . ix (fromIntegral i) - - - -tonat :: Integral a => a -> Natural -tonat = fromIntegral - --- | @makeSmallFixnum@ emits an expression injecting the i32 on top --- of the stack into the SCM unitype. -makeSmallFixnum :: Wasm.Expr -makeSmallFixnum = [expr| - (@gyehoek "construct small fixnum") - (i32.const 1) - i32.shl - ref.i31 - |] - -getArgRegister :: Natural -> S.Datum -getArgRegister n = S.Symbol [i|$arg#{n}|] - --- | Given an expression @e@ leaving a @ref eq@ atop the stack, --- @pushArg rt n e@ sets the nth slot of the arg-passing array to the --- result of @e@. -pushArg :: Natural -> Wasm.Expr -> Wasm.Expr -pushArg n e = [expr| - (@gyehoek begin pushArg) - ##{e} - (global.set #{reg}) - (@gyehoek end pushArg) - |] - where reg = getArgRegister n - --- | Pop the nth arg from the arg-passing array onto the stack. -popArg :: Natural -> Wasm.Expr -popArg n = [expr| - (@gyehoek begin popArg) - (global.get #{reg}) - ref.as_non_null - (@gyehoek end popArg) -|] - where reg = getArgRegister n - - - -lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr - -lowerVal g (ValImm imm) = - pure $ case imm of - ImmInt n -> [expr| - (i32.const #{n}) - ##{makeSmallFixnum} - |] - ImmBool b -> [expr| - (i32.const #{b'}) - ref.i31 - |] - where b' :: Int = if b then 0b11 else 0b01 - _ -> _ - -lowerVal g (ValVar x) = do - pure [expr|(global.get #{l})|] - where - l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just - -lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr - -lower' g (Halt [v]) = do - arg <- pushArg 0 <$> lowerVal g v - pure [expr| - ##{arg} - (return_call $halt (i32.const 1)) - |] - -lower' g e@(ExpPrim p k) = - case p of - PrimAdd x y -> lowerBinOp "i32.add" g x y k - PrimMul x y -> lowerBinOp "i32.mul" g x y k - -lower' g (ExpIf c t f) = do - c' <- lowerVal g c - t' <- lower' g t - f' <- lower' g f - pure [expr| - ##{c'} - (call $gh-truthy?) - (if (then ##{t'}) - (else ##{f'})) - |] - -lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do - idx <- lowerKappa g kap - let g' = g & #kvars <>~ [r] - e' <- lower' g' e - pure [expr| - (@gyehoek "push cont" :idx #{idx}) - (array.set $cont-stack-type - (global.get $cont-stack) - (global.get $cont-stack-top) - (ref.func #{idx})) - (global.set $cont-stack-top - (i32.add (global.get $cont-stack-top) - (i32.const 1))) - ##{e'} - |] - -lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do - idx <- lowerLambda g lam - let g' = g & #vars <>~ [r] - let n = succ $ length g.vars - e' <- lower' g' e - let reg = getArgRegister . fromIntegral $ n - pure [expr| - (i32.const 0) - (ref.func #{idx}) - (struct.new $closure) - (global.set #{reg}) - ##{e'} - |] - -lower' g e@(ExpApply f xs ktail) = do - let nargs = length xs - f' <- lowerVal g f - let l = succ $ V.elemIndex ktail g.kvars ^?! _Just - args <- fold <$> - itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - pure [expr| - (@gyehoek "load args") - ##{args} - (i32.const 1) - ##{f'} - (ref.cast (ref $closure)) - (struct.get $closure $code) - (return_call_ref $cont-type) - (@gyehoek todo - (f' ##{f'}) - (ktail #{l})) - |] - -lower' g e@(ExpContinue k xs) = do - let nargs = length xs - args <- fold <$> - itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs - pure [expr| - (@gyehoek "push args") - ##{args} - (@gyehoek "nargs") - (i32.const #{nargs}) - (@gyehoek "pop cont stack") - (global.get $cont-stack-top) - (i32.const #{l}) - i32.sub - (global.set $cont-stack-top) - (global.get $cont-stack) - (global.get $cont-stack-top) - (array.get $cont-stack-type) - ref.as_non_null - (return_call_ref $cont-type) - |] - where - l = succ $ V.elemIndex k g.kvars ^?! _Just - -lower' g e = error . S.encodeOrShow' S.datumIso $ e - -lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx -lowerKappa g e@(MkKappa xs m) = do - let g' = g & #vars <>~ V.fromList xs - m' <- lower' g' m - idx <- Wasm.defineFunction [wat| - (func (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{m'}) - |] - Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] - pure idx - -lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx -lowerLambda g e@(MkLambda xs ktail m) = do - let g' = g & #vars .~ V.fromList xs - & #kvars <>~ [ktail] - m' <- lower' g' m - idx <- Wasm.defineFunction [wat| - (func (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{m'}) - |] - Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] - pure idx - -lowerBinOp - :: (GenMod :> es) - => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr -lowerBinOp op g x y (MkKappa [r] e) = do - let op' = S.Symbol op - let g' = g & #vars <>~ [r] - let n = succ $ length (g ^. #vars) - let reg = getArgRegister . fromIntegral $ n - x' <- lowerVal g x - y' <- lowerVal g y - e' <- lower' g' e - pure [expr| - ##{x'} - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - ##{y'} - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - #{op'} - ##{makeSmallFixnum} - (global.set #{reg}) - ##{e'} - |] - - - -emitRuntime :: GenMod :> es => Eff es () -emitRuntime = mfix \runtime -> do - Wasm.defineFunctions [wats| - (import "gyehoek" "write" (func $gh-write (param (ref eq)))) - (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq)) - (result i32))) - |] - -- cont stack - Wasm.defineTypes [wats| - (type $heap-object (sub (struct (field $hash (mut i32))))) - (type $cont-type (func (param i32))) - (type $cont-stack-type (array (mut (ref null $cont-type)))) - (type $closure (sub $heap-object - (struct (field $hash (mut i32)) - (field $code (ref $cont-type))))) - |] - Wasm.defineGlobals [wats| - (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))) - |] - -- arg registers - Wasm.defineGlobals [wats| - (global $arg0 (mut (ref null eq)) (ref.null eq)) - (global $arg1 (mut (ref null eq)) (ref.null eq)) - (global $arg2 (mut (ref null eq)) (ref.null eq)) - (global $arg3 (mut (ref null eq)) (ref.null eq)) - (global $arg4 (mut (ref null eq)) (ref.null eq)) - (global $arg5 (mut (ref null eq)) (ref.null eq)) - (global $arg6 (mut (ref null eq)) (ref.null eq)) - (global $arg7 (mut (ref null eq)) (ref.null eq)) - (global $arg8 (mut (ref null eq)) (ref.null eq)) - (global $arg9 (mut (ref null eq)) (ref.null eq)) - (global $arg10 (mut (ref null eq)) (ref.null eq)) - (global $arg11 (mut (ref null eq)) (ref.null eq)) - (global $arg12 (mut (ref null eq)) (ref.null eq)) - (global $arg13 (mut (ref null eq)) (ref.null eq)) - (global $arg14 (mut (ref null eq)) (ref.null eq)) - (global $arg15 (mut (ref null eq)) (ref.null eq)) - |] - -- other things 😼 - Wasm.defineGlobal [wat| - (global $result (mut (ref null eq)) - (ref.null eq)) - |] - -- procedures - let arg = popArg 0 - Wasm.defineFunction [wat| - (func $halt (param i32) - ##{arg} - (global.set $result)) - |] - pure () - -lower :: Exp -> Eff es Text -lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do - runtime <- emitRuntime - let g = MkEnv mempty mempty - e' <- lower' g e - Wasm.defineFunction [wat| - (func $scm-entry (param i32) - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{e'}) - |] - Wasm.defineFunction [wat| - (func (export "main") - (call $scm-entry (i32.const 0)) - (call $gh-write (ref.as_non_null (global.get $result)))) - |] - -lowerProgram :: Program -> Eff es Text -lowerProgram (MkProgram e) = lower e diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 33ba9e1..063911f 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -150,14 +150,3 @@ instance DatumIso a => DataIso (V.Vector a) where instance (DatumIso a, DatumIso b) => DatumIso (a, b) where datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2 - -data Example = MkExample (List Int) Text - deriving (Generic, Show) - -instance DataIso Example where - dataIso = with \g -> - flipped snoced - >>> onHead (traversed $ sealed int) - >>> onTail (onHead $ sealed symbol) - >>> swap - >>> g diff --git a/src/Gyehoek/Stack/Lower.hs b/src/Gyehoek/Stack/Lower.hs new file mode 100644 index 0000000..75d7c30 --- /dev/null +++ b/src/Gyehoek/Stack/Lower.hs @@ -0,0 +1,29 @@ +module Gyehoek.Stack.Lower + ( lowerProgram + ) where + +import Gyehoek.Stack.Syntax +import Gyehoek.Wasm qualified as Wasm +import Gyehoek.Prelude +import Gyehoek.Wasm (wat, watM) + + +lowerRoutine :: Routine -> Wasm.Function +lowerRoutine rt = _ + +lowerBlock :: Block -> Wasm.Expr +lowerBlock = _ + +lowerInstr :: Instr -> Wasm.Expr +lowerInstr = \case + PopCont ktail -> [wat| + + |] + +lowerProgram :: Program -> Eff es Wasm.Module +lowerProgram p = pure [watM| + (module + ##{rs}) +|] + where + rs = p ^.. #routines . each . to lowerRoutine diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 2c65802..18592e2 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -6,182 +6,41 @@ module Gyehoek.Wasm ( -- * syntax Module - , Idx + , Program + , Function , Expr -- ** quasiquoters - , expr - , S.sx - , S.sxs - -- * GenMod effect - , GenMod - , runGenMod - , execGenMod - , defineFunction - , defineType - , defineGlobal - , emit - , renderModule + , watM , wat - , wats - , defineFunctions - , defineTypes - , defineGlobals ) where import Data.List (List) import GHC.Generics (Generic) -import Data.Text (Text) -import Effectful -import Numeric.Natural (Natural) -import Effectful.Dispatch.Dynamic -import Effectful.State.Dynamic -import Control.Lens -import Data.Vector.Strict (Vector) -import qualified Data.Vector.Strict as V -import GHC.IsList (IsList(..)) import Language.Haskell.TH.Quote (QuasiQuoter) -import Data.Data (Data) import Gyehoek.Sexp qualified as S -import Gyehoek.Sexp (Datum, sx, (>>>)) -import Data.Foldable (traverse_) -import Data.Coerce (coerce) +import Gyehoek.Sexp (Datum, (>>>)) +import Data.Data (Data) -newtype Module = MkModule { inner :: Vector Datum } - deriving (Show, Generic) +type Program = Module +type Function = Datum +type Expr = List Datum + +newtype Module = MkModule { inner :: List Datum } + deriving (Show, Generic, Data) deriving newtype (Semigroup, Monoid) -newtype Expr = MkExpr { inner :: Vector Instr } - deriving (Show, Generic, Data, Eq) - deriving newtype (Semigroup, Monoid) - -instance IsList Expr where - type Item Expr = Instr - fromList = MkExpr . V.fromList - toList = V.toList . view #inner - -newtype Instr = MkInstr { inner :: Datum } - deriving (Show, Generic, Data, Eq) - -newtype Idx = MkIdx { inner :: Natural } - deriving (Generic, Data) - deriving newtype (Show) - - --- GenMod - --- | 'GenModState' is a 'Module' paired with the numbers of functions, --- types, globals, etc. defined in the module. -data GenModState = MkGenModState - { mod :: Module - , funcs :: Natural - , types :: Natural - , globals :: Natural - } - deriving (Show, Generic) - -instance Semigroup GenModState where - m1 <> m2 = MkGenModState - { mod = m1.mod <> m2.mod - , funcs = m1.funcs + m2.funcs - , types = m1.types + m2.types - , globals = m1.globals + m2.globals - } - -instance Monoid GenModState where - mempty = MkGenModState - { mod = mempty - , funcs = 0 - , types = 0 - , globals = 0 - } - -data GenMod :: Effect where - DefineFunction :: Datum -> GenMod m Idx - DefineType :: Datum -> GenMod m Idx - DefineGlobal :: Datum -> GenMod m Idx - Emit :: Datum -> GenMod m () - -type instance DispatchOf GenMod = Dynamic - -defineFunction :: GenMod :> es => Datum -> Eff es Idx -defineFunction = send . DefineFunction - -defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx) -defineFunctions = traverse (send . DefineFunction) - -defineType :: GenMod :> es => Datum -> Eff es Idx -defineType = send . DefineType - -defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx) -defineTypes = traverse (send . DefineType) - -defineGlobal :: GenMod :> es => Datum -> Eff es Idx -defineGlobal = send . DefineGlobal - -defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx) -defineGlobals = traverse (send . DefineGlobal) - -emit :: GenMod :> es => List Datum -> Eff es () -emit = traverse_ (send . Emit) - -appendAndIncrement - :: State GenModState :> es - => LensLike' ((,) Natural) GenModState Natural - -> Datum - -> Eff es Idx -appendAndIncrement l s = - state \st -> st - & #mod . #inner <>~ V.singleton s - & l <<%~ succ - & _1 %~ MkIdx - -runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module) -runGenMod = - let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState) - in reinterpret run \cases - _ (DefineFunction s) -> appendAndIncrement #funcs s - _ (DefineType s) -> appendAndIncrement #types s - _ (DefineGlobal s) -> appendAndIncrement #globals s - _ (Emit s) -> #mod . #inner <>= V.singleton s - -execGenMod :: Eff (GenMod : es) a -> Eff es Module -execGenMod = fmap snd . runGenMod - -renderModule :: Module -> Text -renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx| - (module ##{ss}) -|] - - --- DatumIso instances - -instance S.DatumIso Idx where - datumIso = S.with \idx -> - S.integer >>> S.partialOsi f g - >>> idx - where - f n | n < 0 = Left $ S.unexpected "negative" - <> S.expected "natural" - | otherwise = Right $ fromIntegral n - g = fromIntegral - -instance S.DatumIso Instr where - datumIso = S.with S.id - -instance S.DataIso Expr where - dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce +instance S.DatumIso Module where + datumIso = S.with \g -> + S.list (S.el (S.sym "module") >>> S.rest S.datumIso) + >>> g -- quasiquoters -expr :: QuasiQuoter -expr = S.makeSxs - [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||] - wat :: QuasiQuoter -wat = S.makeSx [|| id ||] +wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||] -wats :: QuasiQuoter -wats = S.makeSxs [|| id ||] +watM :: QuasiQuoter +watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||] diff --git a/wit-test/gyehoek.wit b/wit-test/gyehoek.wit new file mode 100644 index 0000000..9b05bd1 --- /dev/null +++ b/wit-test/gyehoek.wit @@ -0,0 +1,16 @@ +package gyehoek:gyehoek@0.1.0; + +interface runtime { + resource scm { + make-small-int: static func(n: s32) -> scm; + } +} + +interface program { + run: func() -> s32; +} + +world gyehoek { + import runtime; + export program; +} \ No newline at end of file diff --git a/wit-test/program.wat b/wit-test/program.wat new file mode 100644 index 0000000..277f7e3 --- /dev/null +++ b/wit-test/program.wat @@ -0,0 +1,5 @@ +(module + (func $run (result i32) + (i32.const 123)) + (export "gyehoek:gyehoek/program@0.1.0#run" + (func $run))) diff --git a/wit-test/runtime.wat b/wit-test/runtime.wat new file mode 100644 index 0000000..0faf36f --- /dev/null +++ b/wit-test/runtime.wat @@ -0,0 +1,5 @@ +(module + (func $make-small-int (param $n i32) (result i32) + (i32.mul (local.get $n) (i32.const 2))) + (export "gyehoek:gyehoek/runtime@0.1.0[method]scm.make-small-int" + (func $make-small-int)))