lam

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

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
               ];
             };
           };

golden/arith/out.wat

@@ -1,19 +1,47 @@
 (module
+  (type $heap-object (sub (struct (field (mut i32)))))
   (func
     (param)
-    (result i32)
+    (result (ref eq))
-    (local i32 i32 i32 i32 i32)
+    (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)))

golden/if-false/out.wat

@@ -1,11 +1,13 @@
 (module
+  (type (sub (struct (field (mut i32)))))
   (func
     (param)
-    (result i32)
+    (result (ref eq))
-    (local i32 i32 i32 i32 i32)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
     (i32.const 0)
+    ref.i31
     (if
       (result i32)
-      (then (i32.const 777))
+      (then (i32.const 777) ref.i31)
-      (else (i32.const 555))))
+      (else (i32.const 555) ref.i31)))
   (export "main" (func 0)))

golden/if-true/out.wat

@@ -1,11 +1,13 @@
 (module
+  (type (sub (struct (field (mut i32)))))
   (func
     (param)
-    (result i32)
+    (result (ref eq))
-    (local i32 i32 i32 i32 i32)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
     (i32.const 1)
+    ref.i31
     (if
       (result i32)
-      (then (i32.const 777))
+      (then (i32.const 777) ref.i31)
-      (else (i32.const 555))))
+      (else (i32.const 555) ref.i31)))
   (export "main" (func 0)))

golden/lambda/source.scm

@@ -0,0 +1 @@
+(λ (x) x)

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,14 +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)
+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
@@ -46,10 +49,22 @@ type instance IxValue Env = Name
 instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
+data Runtime = MkRuntime
+  { argArrayIdx :: Idx
+  , contStackIdx :: Idx
+  }
+  deriving (Show, Generic)
+
 
 
-tshow :: Show a => a -> Text
+-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
-tshow = T.pack . show
+-- of the stack into the SCM unitype.
+makeSmallFixnum :: Wasm.Expr
+makeSmallFixnum = mconcat
+  [ ins "i32.const" [sxp @Int 2]
+  , ins "i32.shl" []
+  , ins "ref.i31" []
+  ]
 
 
 
@@ -57,17 +72,21 @@ lowerVal :: Env -> Val -> Wasm.Expr
 
 lowerVal g (ValLit l) =
   case l of
-    LitInt n -> ins "i32.const" [sxp n]
+    LitInt n -> 
-    LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
+      ins "i32.const" [sxp n]
+      <> makeSmallFixnum
+    LitBool b ->
+      ins "i32.const" [sxp @Int $ if b then 1 else 0]
+      <> ins "ref.i31" []
     _ -> _
 
 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,31 +95,59 @@ lower' g (ExpPrim p rs e) =
   where
     r = head rs
 
-lower' g (ExpIf c t f) =
+lower' g (ExpIf c t f) = do
-  lowerVal g c
+  t' <- lower' g t
-  <> Wasm.if' (Wasm.result [i32])
+  f' <- lower' g f
-    (lower' g t)
+  pure $ lowerVal g c
-    (lower' g f)
+    <> Wasm.if' (Wasm.result [i32]) t' f'
+
+lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = _
 
 lowerBinOp
-  :: _
+  :: (GenMod :> es)
-  -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
+  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
-lowerBinOp op g x y r e =
+lowerBinOp op g x y r e = do
-  lowerVal g x
+  e' <- lower' g' e
-  <> lowerVal g y
+  pure . mconcat $
-  <> ins op []
+    [ lowerVal g x
-  <> ins "local.set" [sxp n]
+    , ins "ref.cast" [sxp $ ref i31]
-  <> lower' g' e
+    , 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)
 
 
 
+scm = ref eq
+
+
+
+emitRuntime :: GenMod :> es => Eff es Runtime
+emitRuntime = do
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+    [ Wasm.mut i32 ]
+  scmUnclosedIdx <- Wasm.deftype $ Wasm.func [i32] []
+  argArrayType <- Wasm.deftype $ Wasm.array scm
+  argArrayIdx <- Wasm.defglobal $ ref (Wasm.fromIdx argArrayType)
+  contStackIdx <- Wasm.defglobal $ ref (Wasm.fromIdx argArrayType)
+  -- consIdx <- Wasm.defun _ _ _ _
+  pure $ MkRuntime {argArrayIdx,contStackIdx}
+  -- pure $ error "todo"
+
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
+  runtime <- emitRuntime
-    lower' emptyEnv e
+  let env = MkEnv runtime mempty
+  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+    lower' env e
   Wasm.export "main" "func" main
 
 lowerProgram :: Program -> Eff es Text

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
 

src/Gyehoek/Wasm.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeepSubsumption #-}
 {-# LANGUAGE NoFieldSelectors #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -11,16 +12,18 @@
 {-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
   ( defun
-  , deftype
+  , rec'
   , start
   , runGenMod
   , execGenMod
   , renderModule
   , Module
   , Function
+  , Type(..)
   , Expr
   , Instr
   , GenMod
+  , Idx
   , i32
   , export
   , ins
@@ -28,11 +31,26 @@ module Gyehoek.Wasm
   , result
   , param
   , if'
+  , ref
+  , eq
+  , i31ref
+  , i31
+  , struct
+  , mut
+  , sub
+  , deftype
+  , namedType
+  , type'
+  , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
   )
   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)
@@ -59,13 +77,16 @@ import Language.Sexp.Located
 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
+  , globals :: Vector Type
   }
   deriving (Show, Generic)
 
@@ -78,7 +99,10 @@ instance Semigroup Module where
     }
 
 instance Monoid Module where
-  mempty = MkModule mempty mempty Nothing mempty
+  mempty = MkModule mempty mempty Nothing mempty mempty
+
+newtype RecType = MkRecType { inner :: Vector Type }
+  deriving (Show, Generic)
 
 data Function = MkFunction
   { params :: List Type
@@ -101,14 +125,18 @@ newtype Instr = MkInstr { inner :: Sexp }
 newtype Type = MkType { inner :: Sexp }
   deriving (Show, Generic)
 
-newtype Idx = MkIdx { getIdx :: Natural }
+data Idx
-  deriving newtype (Show)
+  = 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
+  Defun :: List Type -> List Type -> List Type
+        -> (Idx -> m Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> GenMod m Idx
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -118,15 +146,26 @@ 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])
+
+defglobal :: (GenMod :> es) => Type -> Eff es Idx
+defglobal = send . DefGlobal
 
 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)
@@ -136,41 +175,123 @@ 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
-    _ (DefType t) -> state \m ->
+    _ (DefRecType ts) -> state \m ->
-     ( MkIdx . fromIntegral . length $ m.types
+     ( let prev_n = sumOf (#types . each . #inner . to V.length) m
-     , m & #types <>~ V.singleton t
+       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 ->
+    env (Defun params result locals code) ->
-      let idx = MkIdx . fromIntegral . length $ m.functions
+      localSeqUnlift env \unlift ->
-      in ( idx
+        stateM \m -> do
-         , m & #functions <>~ V.singleton
+          -- the least unused function index, computed as the number
-             (MkFunction params result locals (code idx))
+          -- 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) -> state \m ->
+      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
+          m' = m & #globals <>~ V.singleton t
+      in (prev_n, m')
 
 execGenMod = fmap snd . runGenMod
 
 renderModule :: Module -> Text
 renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
 
-i32 :: Type
+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]
+
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", 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]
+
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
+i32, i31ref, eq, i31 :: Type
 i32 = MkType $ Symbol "i32"
+i31ref = MkType $ Symbol "i31ref"
+eq = MkType $ Symbol "eq"
+i31 = MkType $ Symbol "i31"
+
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
 
 
 
 instance SexpIso Idx where
-  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
+  sexpIso = match
+    $ With (\numeric -> num >>> numeric)
+    $ With (\named -> name >>> named)
+    $ End
     where
-      f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
+      num = Sexp.integer >>> Sexp.partialOsi f g
-          | otherwise = Right . MkIdx $ fromIntegral n
+        where
-      g (MkIdx n) = fromIntegral n
+          f n | n < 0 = Left $ Sexp.unexpected "negative"
+                            <> 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 ->
+    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
@@ -202,15 +323,18 @@ 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)
 
+instance SexpIso Sexp where
+  sexpIso = Control.Category.id
+
 instance Each Expr Expr Instr Instr where
   each = #MkExpr . each
 
-sxp :: SexpIso a => a -> Sexp
+sxp :: HasCallStack => SexpIso a => a -> Sexp
-sxp e = Sexp.toSexp sexpIso e ^?! _Right
+sxp e = either error id . Sexp.toSexp sexpIso $ e
 
 ins :: Text -> List Sexp -> Expr
 ins op [] = [ MkInstr $ Symbol op ]

t.wat

@@ -0,0 +1,16 @@
+(module
+ (type $heap-object (sub (struct (field (mut i32)))))
+ (type $unclosure
+       (func (param i32)
+             (result (ref eq))))
+ (type $closure
+       (sub $heap-object
+            (struct (field (mut i32))
+                    (field (ref $unclosure))
+                    (field $arg1 (ref eq)))))
+ (func $make-adder-inner (param $self (ref $closure)) (result (ref eq))
+       )
+ (func $make-adder (param (ref eq)) (result $closure)
+       )
+ (func (export "main") (result (ref eq))
+       (ref.i31 (i32.const 123))))

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}"
+  '';
+}

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