From 269d9565664b2b269a7bd6aeb716146436d3b9cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 12 Jul 2026 13:12:40 -0600 Subject: [PATCH] higher-order defun --- doc/data-model.org | 17 ++++++++ flake.nix | 12 +++++- golden/arith/out.wat | 10 ++++- src/Gyehoek/CPS/Lower.hs | 86 ++++++++++++++++++++++++++-------------- src/Gyehoek/Sexp.hs | 2 +- src/Gyehoek/Wasm.hs | 40 +++++++++++++------ t.wat | 47 ++++++++++++++++++++++ wasmtime.nix | 26 ++++++++++++ 8 files changed, 194 insertions(+), 46 deletions(-) create mode 100644 doc/data-model.org create mode 100644 t.wat create mode 100644 wasmtime.nix diff --git a/doc/data-model.org b/doc/data-model.org new file mode 100644 index 0000000..25884e9 --- /dev/null +++ b/doc/data-model.org @@ -0,0 +1,17 @@ +#+title: representation of Scheme types + +the Scheme unitype is encoded as ~(ref eq)~ with immediates in ~(ref i31)~ and heap objects in ~$heap-object~: +#+begin_src wat + (type $heap-object (sub (struct (field $hash (mut i32))))) +#+end_src + +* immediates + +all immediates are stored in ~(ref i31)~ and thus must fit in 31 bits. the most important immediate, the integer, is indicated by a null low bit. +#+begin_example +XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00 + || + |\ used by wasm's i31 rep + zero indicates a 30-bit fixnum / + in the upper bits +#+end_example diff --git a/flake.nix b/flake.nix index 008439e..32bcb31 100644 --- a/flake.nix +++ b/flake.nix @@ -16,15 +16,23 @@ "x86_64-darwin" "x86_64-linux" ]; + overlays = [ haskellNix.overlay + (final: prev: { + gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {}; + }) (final: prev: { gyehoek = final.haskell-nix.project' { src = ./.; compiler-nix-name = "ghc912"; modules = [({ pkgs, lib, ...}: { packages.gyehoek.components.tests.test.preCheck = - let bin = [pkgs.wasmtime pkgs.git]; + let + bin = [ + pkgs.gyehoek-wasmtime-wrapper + pkgs.git + ]; in '' # Wasmtime requires a cache in $HOME. This is less # painful than reconfiguring the cache location. @@ -44,10 +52,10 @@ self.packages.${final.stdenv.hostPlatform.system}.shake final.wabt final.nodejs - final.wasmtime final.wasm-tools final.wac-cli final.guile + final.gyehoek-wasmtime-wrapper ]; }; }; diff --git a/golden/arith/out.wat b/golden/arith/out.wat index 6931bec..1a9f4c6 100644 --- a/golden/arith/out.wat +++ b/golden/arith/out.wat @@ -1,14 +1,18 @@ (module - (type (sub (struct (field (mut i32))))) + (type $heap-object (sub (struct (field (mut i32))))) (func (param) (result (ref eq)) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) (i32.const 3) + (i32.const 2) + i32.shl ref.i31 (ref.cast (ref i31)) i31.get_s (i32.const 4) + (i32.const 2) + i32.shl ref.i31 (ref.cast (ref i31)) i31.get_s @@ -16,10 +20,14 @@ ref.i31 (local.set 0) (i32.const 2) + (i32.const 2) + i32.shl ref.i31 (ref.cast (ref i31)) i31.get_s (i32.const 5) + (i32.const 2) + i32.shl ref.i31 (ref.cast (ref i31)) i31.get_s diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 136d6d9..188b092 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -6,8 +6,7 @@ {-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Gyehoek.CPS.Lower - ( - lower, lowerProgram) where + (lower, lowerProgram) where import Gyehoek.CPS.Syntax import Data.Generics.Labels @@ -31,15 +30,18 @@ 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, Type (..)) +import Gyehoek.Wasm (i32, ins, sxp, eq, ref, i31, Type (..), Idx, GenMod) import Language.Sexp.Located (pattern ParenList) -data Env = MkEnv { vars :: Vector Name } +data Env = MkEnv + { runtime :: Runtime + , vars :: Vector Name + } deriving (Show, Generic) emptyEnv :: Env -emptyEnv = MkEnv mempty +emptyEnv = MkEnv (error "fuck") mempty type instance Index Env = Natural type instance IxValue Env = Name @@ -47,15 +49,31 @@ type instance IxValue Env = Name instance Ixed Env where ix i = #vars . ix (fromIntegral i) +data Runtime = MkRuntime + { consIdx :: Idx + } + deriving (Show, Generic) + + + +-- | @makeSmallFixnum@ emits an expression injecting the i32 on top +-- of the stack into the SCM unitype. +makeSmallFixnum :: Wasm.Expr +makeSmallFixnum = mconcat + [ ins "i32.const" [sxp @Int 2] + , ins "i32.shl" [] + , ins "ref.i31" [] + ] + lowerVal :: Env -> Val -> Wasm.Expr lowerVal g (ValLit l) = case l of - LitInt n -> + LitInt n -> ins "i32.const" [sxp n] - <> ins "ref.i31" [] + <> makeSmallFixnum LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0] <> ins "ref.i31" [] @@ -65,9 +83,9 @@ lowerVal g (ValVar x) = ins "local.get" [sxp l] where l = V.elemIndex x g.vars ^?! _Just -lower' :: Env -> Exp -> Wasm.Expr +lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr -lower' g (Halt [e]) = lowerVal g e +lower' g (Halt [e]) = pure $ lowerVal g e lower' g (ExpPrim p rs e) = case p of @@ -76,26 +94,29 @@ lower' g (ExpPrim p rs e) = where r = head rs -lower' g (ExpIf c t f) = - lowerVal g c - <> Wasm.if' (Wasm.result [i32]) - (lower' g t) - (lower' g f) +lower' g (ExpIf c t f) = do + t' <- lower' g t + f' <- lower' g f + pure $ lowerVal g c + <> Wasm.if' (Wasm.result [i32]) t' f' lowerBinOp - :: _ - -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr -lowerBinOp op g x y r e = - lowerVal g x - <> ins "ref.cast" [sxp $ ref i31] - <> ins "i31.get_s" [] - <> lowerVal g y - <> ins "ref.cast" [sxp $ ref i31] - <> ins "i31.get_s" [] - <> ins op [] - <> ins "ref.i31" [] - <> ins "local.set" [sxp n] - <> lower' g' e + :: (GenMod :> es) + => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr +lowerBinOp op g x y r e = do + e' <- lower' g' e + pure . mconcat $ + [ lowerVal g x + , ins "ref.cast" [sxp $ ref i31] + , ins "i31.get_s" [] + , lowerVal g y + , ins "ref.cast" [sxp $ ref i31] + , ins "i31.get_s" [] + , ins op [] + , ins "ref.i31" [] + , ins "local.set" [sxp n] + , e' + ] where g' = g & #vars <>~ [r] n = length (g ^. #vars) @@ -106,10 +127,17 @@ scm = ref eq -lower :: Exp -> Eff es Text -lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do +emitRuntime :: GenMod :> es => Eff es Runtime +emitRuntime = do Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct [ Wasm.mut i32 ] + consIdx <- Wasm.defun _ _ _ _ + pure $ MkRuntime {consIdx} + +lower :: Exp -> Eff es Text +lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do + -- runtime <- emitRuntime + let env = MkEnv _runtime mempty main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> lower' emptyEnv e Wasm.export "main" "func" main diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 796d3f0..b9f736e 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -48,7 +48,7 @@ import GHC.IO.Unsafe (unsafePerformIO) import qualified Data.Text.IO as TIO import Control.Monad (join) import qualified Language.Sexp.Located as SexpLoc -import Data.Void (absurd) +import Data.Void (absurd, Void) import Data.Coerce (coerce) import qualified Data.Map diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index c8e6eb4..e524d12 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeepSubsumption #-} {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordPuns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedLabels #-} @@ -22,6 +23,7 @@ module Gyehoek.Wasm , Expr , Instr , GenMod + , Idx , i32 , export , ins @@ -125,7 +127,8 @@ data Idx data GenMod :: Effect where DefRecType :: List Type -> GenMod m (List Idx) - Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx + Defun :: List Type -> List Type -> List Type + -> (Idx -> m Expr) -> GenMod m Idx Start :: Idx -> GenMod m () Export :: Text -> Text -> Idx -> GenMod m () @@ -151,9 +154,9 @@ deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t]) defun :: (GenMod :> es) => List Type -> List Type -> List Type - -> (Idx -> Expr) + -> (Idx -> Eff es Expr) -> Eff es Idx -defun params result locals code = send $ Defun params result locals code +defun params res locals code = send $ Defun params res locals code -- defun -- :: (GenMod :> es) @@ -163,7 +166,7 @@ defun params result locals code = send $ Defun params result locals code -- defun params result locals code = -- send $ Defun params result locals (runPureEff . execWriterLocal . code) -runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module) +runGenMod :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module) runGenMod = reinterpret (runStateLocal (mempty :: Module)) \cases _ (DefRecType ts) -> state \m -> @@ -176,12 +179,18 @@ runGenMod = #exports <>= V.singleton e where e = MkExport $ ParenList [ "export", sxp name, ParenList [ "func", sxp idx ] ] - _ (Defun params res locals code) -> state \m -> - let idx = IdxNumeric . fromIntegral . length $ m.functions - in ( idx - , m & #functions <>~ V.singleton - (MkFunction params res locals (code idx)) - ) + env (Defun params result locals code) -> + 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') execGenMod = fmap snd . runGenMod @@ -214,7 +223,7 @@ i31 = MkType $ Symbol "i31" instance SexpIso Idx where sexpIso = match $ With (\numeric -> num >>> numeric) - $ With (\named -> symbol >>> named) + $ With (\named -> name >>> named) $ End where num = Sexp.integer >>> Sexp.partialOsi f g @@ -223,6 +232,11 @@ instance SexpIso Idx where <> Sexp.expected "natural" | otherwise = Right $ fromIntegral n g n = fromIntegral n + l :: Prism' Text Text + l = prefixed "$" + name = Sexp.symbol >>> Sexp.partialOsi + (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l) + (review l) instance SexpIso RecType where sexpIso = with \rectype -> @@ -287,8 +301,8 @@ instance SexpIso Sexp where instance Each Expr Expr Instr Instr where each = #MkExpr . each -sxp :: SexpIso a => a -> Sexp -sxp e = Sexp.toSexp sexpIso e ^?! _Right +sxp :: HasCallStack => SexpIso a => a -> Sexp +sxp e = either error id . Sexp.toSexp sexpIso $ e ins :: Text -> List Sexp -> Expr ins op [] = [ MkInstr $ Symbol op ] diff --git a/t.wat b/t.wat new file mode 100644 index 0000000..3968ec8 --- /dev/null +++ b/t.wat @@ -0,0 +1,47 @@ +(module + (type $heap-object (sub (struct (field (mut i32))))) + (func + (param) + (result (ref eq)) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (i32.const 3) + (i32.const 2) + i32.shl + ref.i31 + (ref.cast (ref i31)) + i31.get_s + (i32.const 4) + (i32.const 2) + i32.shl + ref.i31 + (ref.cast (ref i31)) + i31.get_s + i32.mul + ref.i31 + (local.set 0) + (i32.const 2) + (i32.const 2) + i32.shl + ref.i31 + (ref.cast (ref i31)) + i31.get_s + (i32.const 5) + (i32.const 2) + i32.shl + 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))) diff --git a/wasmtime.nix b/wasmtime.nix new file mode 100644 index 0000000..84393cb --- /dev/null +++ b/wasmtime.nix @@ -0,0 +1,26 @@ +# A Wasmtime wrapper that provides our desired configuration. +{ wasmtime +, makeWrapper +, symlinkJoin +, formats +, extraSettings ? {} +}: + +let + config = { + wasm.gc = true; + }; + config-file = + (formats.toml {}).generate + "gyehoek-wasmtime.toml" + (config // extraSettings); +in symlinkJoin { + name = "gyehoek-wasmtime"; + inherit (wasmtime) version; + paths = [ wasmtime ]; + nativeBuildInputs = [ makeWrapper ]; + postBuild = '' + wrapProgram $out/bin/wasmtime \ + --add-flags "--config ${config-file}" + ''; +}