beautiful

src/Gyehoek/CPS/Lower.hs

@@ -42,8 +42,7 @@ import Data.Functor.Foldable (cata)
 
 
 data Env = MkEnv
-  { runtime :: Runtime
+  { vars :: Vector Name
-  , vars :: Vector Name
   , kvars :: Vector Name
   }
   deriving (Show, Generic)
@@ -54,17 +53,17 @@ type instance IxValue Env = Name
 instance Ixed Env where
   ix i = #vars . ix (fromIntegral i)
 
-data Runtime = MkRuntime
+-- data Runtime = MkRuntime
-  { argArrayType :: Idx
+--   { argArrayType :: Idx
-  , argArray :: Idx
+--   , argArray :: Idx
-  , contType :: Idx
+--   , contType :: Idx
-  , contStackType :: Idx
+--   , contStackType :: Idx
-  , contStackTop :: Idx
+--   , contStackTop :: Idx
-  , contStack :: Idx
+--   , contStack :: Idx
-  , result :: Idx
+--   , result :: Idx
-  , halt :: Idx
+--   , halt :: Idx
-  }
+--   }
-  deriving (Show, Generic)
+--   deriving (Show, Generic)
 
 
 
@@ -80,59 +79,58 @@ makeSmallFixnum = [expr|
 -- | 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 :: Runtime -> Natural -> Wasm.Expr -> Wasm.Expr
+pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
-pushArg (MkRuntime {argArrayType,argArray}) n e = [expr|
+pushArg n e = [expr|
-    (global.get #{argArray})
+    (global.get $arg-array)
     (global.get #{n})
     ##{e}
-    (array.set #{argArrayType})
+    (array.set $arg-array-type)
   |]
-  -- [ ins "global.get" [sxp argArray]
-  -- , ins "i32.const" [sxp n]
-  -- , e
-  -- , ins "array.set" [sxp argArrayType]
-  -- ]
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
--- popArg :: Runtime -> Int -> Wasm.Expr
+popArg :: Int -> Wasm.Expr
--- popArg (MkRuntime {argArrayType,argArray}) n = mconcat
+popArg n = [expr|
---   [ ins "global.get" [sxp argArray]
+  (global.get $arg-array)
---   , ins "i32.const" [sxp n]
+  (i32.const #{n})
---   , ins "array.get" [sxp argArrayType]
+  (array.get $arg-array-type)
---   , ins "ref.as_non_null" []
+  ref.as_non_null
---   ]
+|]
 
 
 
--- lowerVal :: Env -> Val -> Wasm.Expr
+lowerVal :: Env -> Val -> Wasm.Expr
 
--- lowerVal g (ValLit l) =
+lowerVal g (ValLit l) =
---   case l of
+  case l of
---     LitInt n -> 
+    LitInt n -> [expr|
---       ins "i32.const" [sxp n]
+      (i32.const #{n})
---       <> makeSmallFixnum
+      ##{makeSmallFixnum}
---     LitBool b ->
+    |]
---       ins "i32.const" [sxp @Int $ if b then 1 else 0]
+    LitBool b -> [expr|
---       <> ins "ref.i31" []
+      (i32.const #{b'})
---     _ -> _
+      ref.i31
+    |]
+      where b' :: Int = if b then 1 else 0
+    _ -> _
 
--- lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
+lowerVal g (ValVar x) = [expr|(local.get #{l})|]
---   where
+  where
---     l = V.elemIndex x g.vars ^?! _Just
+    l = succ $ V.elemIndex x g.vars ^?! _Just
 
--- lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
--- lower' g (Halt [v]) = pure . mconcat $
+lower' g (Halt [v]) = pure [expr|
---   [ pushArg g.runtime 0 (lowerVal g v)
+  ##{arg}
---   , ins "return_call" [sxp @Int 1]
+  (return_call $halt)
---   ]
+|]
+  where arg = pushArg 0 (lowerVal g v)
 
--- lower' g (ExpPrim p rs e) =
+lower' g (ExpPrim p rs e) =
---   case p of
+  case p of
---     PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
---     PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
---   where
+  where
---     r = head rs
+    r = head rs
 
 -- lower' g (ExpIf c t f) = do
 --   t' <- lower' g t
@@ -181,26 +179,23 @@ pushArg (MkRuntime {argArrayType,argArray}) n e = [expr|
 
 -- lower' g e = error . show $ e
 
--- lowerBinOp
+lowerBinOp
---   :: (GenMod :> es)
+  :: (GenMod :> es)
---   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
+  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
--- lowerBinOp op g x y r e = do
+lowerBinOp op g x y r e = do
---   e' <- lower' g' e
+  let g' = g & #vars <>~ [r]
---   pure . mconcat $
+  let n = succ $ length (g ^. #vars)
---     [ lowerVal g x
+  let x' = lowerVal g x
---     , ins "ref.cast" [sxp $ ref i31]
+  let y' = lowerVal g y
---     , ins "i31.get_s" []
+  e' <- lower' g' e
---     , lowerVal g y
+  pure [expr|
---     , ins "ref.cast" [sxp $ ref i31]
+    ##{x'}
---     , ins "i31.get_s" []
+    (i31.get_s (ref.cast (ref i31)))
---     , ins op []
+    ##{y'}
---     , ins "ref.i31" []
+    (i31.get_s (ref.cast (ref i31)))
---     , ins "local.set" [sxp (1+n)]
+    (local.set #{n} (ref.i31 #{op}))
---     , e'
+    ##{e'}
---     ]
+  |]
---   where
---     g' = g & #vars <>~ [r]
---     n = length (g ^. #vars)
 
 
 
@@ -237,29 +232,65 @@ pushArg (MkRuntime {argArrayType,argArray}) n e = [expr|
 --     ,result,halt}
 --   -- pure $ error "todo"
 
--- lower :: Exp -> Eff es Text
+emitRuntime :: GenMod :> es => Eff es ()
--- lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+emitRuntime = mfix \runtime -> do
---   runtime <- emitRuntime
+  -- cont stack
---   let g = MkEnv runtime mempty mempty
+  Wasm.defineType [wat|
---   scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    (type $heap-object (sub (struct (field $hash (mut i32)))))
---     lower' g e
+  |]
---   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+  Wasm.defineType [wat|
---     pure . mconcat $
+    (type $cont-type (func (param i32)))
---       -- push return cont
+  |]
---       [--  ins "ref.func" [sxp halt]
+  Wasm.defineType [wat|
---       -- make call
+    (type $cont-stack-type (array (mut (ref null $cont-type))))
---       ins "i32.const" [sxp @Int 0]
+  |]
---       , ins "call" [sxp scm_entry]
+  Wasm.defineGlobal [wat|
---       , ins "global.get" [sxp runtime.result]
+    (global $cont-stack-top (mut i32) (i32.const 0))
---       , ins "ref.as_non_null" []
+  |]
---       ]
+  Wasm.defineGlobal [wat|
---   Wasm.export "main" "func" main
+    (global $cont-stack (ref $cont-stack-type)
+            (array.new_default $cont-stack-type (i32.const 128)))
+  |]
+  -- arg array
+  Wasm.defineType [wat|
+    (type $arg-array-type (array (mut (ref null eq))))
+  |]
+  Wasm.defineGlobal [wat|
+    (global $arg-array (ref $arg-array-type)
+            (array.new_default $arg-array-type) (i32.const 32))
+  |]
+  -- 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 ()
 
--- lowerProgram :: Program -> Eff es Text
+lower :: Exp -> Eff es Text
--- lowerProgram (MkProgram e) = lower e
+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") (result (ref eq))
+      (call $scm-entry (i32.const 0))
+      (ref.as_non_null (global.get $result)))
+  |]
   
-lower = _
+lowerProgram :: Program -> Eff es Text
-lowerProgram = _
+lowerProgram (MkProgram e) = lower e
 
 antiquote_example =
   let

src/Gyehoek/Sexp.hs

@@ -38,6 +38,7 @@ module Gyehoek.Sexp
   , toSexp
   , fromSexp
   , stripLocation
+  , format
   )
   where
 
@@ -87,6 +88,9 @@ sexp = iso
   (either error id . encode)
   (either error id . decode)
 
+format :: Sexp -> Text
+format = decodeUtf8 . view strict . SL.format
+
 encode :: SexpIso a => a -> Either String Text
 encode = encodeWith sexpIso
 

src/Gyehoek/Wasm.hs

@@ -29,6 +29,8 @@ module Gyehoek.Wasm
   , defineType
   , defineGlobal
   , declare
+  , renderModule
+  , wat
   )
   where
 
@@ -65,6 +67,8 @@ import Data.Functor (void)
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Data.Data (Data)
 import Data.Functor.Foldable (cata)
+import Gyehoek.Sexp (sx)
+import qualified Language.Sexp as SL
 
 
 newtype Module = MkModule { inner :: Vector Sexp }
@@ -159,6 +163,11 @@ runGenMod =
 execGenMod :: Eff (GenMod : es) a -> Eff es Module
 execGenMod = fmap snd . runGenMod
 
+renderModule :: Module -> Text
+renderModule (MkModule ss) = Gyehoek.Sexp.format [sx|
+  (module ##{ss})
+|]
+
 
 -- SexpIso instances
 
@@ -185,3 +194,6 @@ expr :: QuasiQuoter
 expr = Gyehoek.Sexp.makeSxs
   [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
    . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
+
+wat :: QuasiQuoter
+wat = Gyehoek.Sexp.makeSx [|| id ||]