idk

doc/index.org

@@ -0,0 +1,53 @@
+#+title: Gyehoek Scheme
+
+#+begin_center
+(this document is written in present tense as if the project is complete, but Gyehoek is a work-in-progress.)
+#+end_center
+
+Gyehoek is an R⁷RS-compliant Scheme compiler targeting WebAssembly 3.0, relying principally on the recently standardised garbage collector and tail call proposals. the Gyehoek compiler is implemented in Haskell, and the Gyehoek runtime is a Rust program providing primitive routines and WebAssembly execution via the Wasmtime library.
+
+primitives are implemented as native Rust functions made available to the guest by Wasmtime. in the future, it would be ideal to provide the primitives as a WASI interface to help decouple ourselves from a specific Wasm runtime, but it is not a priority.
+
+Gyehoek allows separate compilation, ~eval~, first-class continuations, and so on.
+
+* pipeline
+
+a Scheme program's journey through Gyehoek is as follows:
+1. read (source code → Scheme data)
+2. parse (Scheme data → AST)
+3. expand(?) (AST → AST)
+4. contify (AST → CPS)
+5. close (CPS → CPS)
+6. lower (CPS → Wasm)
+
+** read
+
+in the read phase, Gyehoek's reader serialises textual source code into a sequence of tokens, which are then parsed into S-expressions. this phase is completely agnostic towards any interpretation of the data — it's just data, not code (yet). this distinction between reading and parsing is made so that the reader can easily be shared amongst many parsers, allowing convenient definition of human-readable representations for all sorts of compiler internals. Gyehoek's intermediate languages and WebAssembly text format are of particular interest.
+
+the reader may be configured to extend R⁷RS's syntax with a special "antiquotation" notation, used internally in the compiler to elegantly interpolate and splice S-expression literals via Haskell's quasiquotation.
+#+begin_src haskell
+  let meta = 123 :: Int
+  in [sx|(a b c #{meta} d)|] -- ⇒ (a b c 123 d)
+
+  let metas = ["c","d"] :: List Text
+  in [sx|(a b ##{metas} e f)|] -- ⇒ (a b "c" "d" e f)
+#+end_src
+
+Gyehoek's lexer and parser are generated by Alex and Happy, respectively.
+
+unless otherwise noted, the term "parse" will be used in reference to the phase taking S-expressions to ASTs, while "read" refers to the combined Alex/Happy process. if the tokenisation process (Alex) must be distinguished from the "parse" process (Happy), the former is called "lexical analysis" and the latter "syntactic analysis."
+
+** parse
+
+- use invertible-grammar library
+
+** expand
+
+** contify
+
+- procedures are distinguished from continuations, and procedure applications are distinguished from continuation jumps.
+- all continuations and lambda will be named i think. the exception is continuations for primitive calls.
+
+** close
+
+** lower

golden/adder/source.scm

@@ -0,0 +1,4 @@
+(let ((make-adder (lambda (x)
+                    (lambda (y)
+                      (+ x y)))))
+  ((make-adder 4) 5))

gyehoek.cabal

@@ -52,6 +52,7 @@ library
 
   -- cabal-fmt: expand src
   exposed-modules:
+    Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Lower
     Gyehoek.CPS.Syntax
@@ -65,8 +66,8 @@ library
   build-depends:
     , base                  ^>=4.21.2.0
     , binary
+    , bytestring
     , containers
-    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
@@ -87,6 +88,7 @@ library
     , template-haskell
     , text
     , text-short
+    , typed-process
     , unordered-containers
     , vector
 

src/Gyehoek/CPS/Close.hs

@@ -0,0 +1,29 @@
+module Gyehoek.CPS.Close
+  ( closeProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Effectful
+import Data.Functor.Foldable
+import Control.Monad ((>=>))
+import Control.Lens
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.HashSet as HS
+
+
+cataM
+  :: (Monad m, Traversable (Base t), Recursive t)
+  => (Base t a -> m a) -> t -> m a
+cataM f = cata (sequenceA >=> f)
+
+close :: Exp -> Exp
+close = cata \case
+  ExpLetRecF {bindersF,bodyF} -> ExpLetRec binders bodyF
+    where
+      binders = bindersF & (each . _2 . _AbsLambda' . _3) %~ \e -> _
+  e -> embed e
+
+        -- let frees = freeWithBound' (HS.fromList $ ktail : bs) e'
+
+closeProgram :: Program -> Eff es Program
+closeProgram (MkProgram e) = pure . MkProgram . close $ e

src/Gyehoek/CPS/Convert.hs

@@ -65,6 +65,21 @@ convert (Scm.ExpIf c t f) k =
   convert c \c' ->
     ExpIf c' <$> convert t k <*> convert f k
 
+-- let-bindings are desugared into continuation calls whose parameters
+-- are the left-hand sides and whose arguments are the right-hand
+-- sides.
+convert (Scm.ExpLet bs e) k =
+  let rhss = bs ^.. each . _2
+  in telescope (convert @es) rhss \rhss' -> do
+    e' <- convert e k
+    kbody <- gensym' @Name "letrec-body"
+    let bs' = bs ^.. each . _1
+    pure [cps|
+      (letrec ((#{kbody} (κ #{bs'} #{e'})))
+        (continue #{kbody} ##{rhss'}))
+    |]
+
+
 convert _ k = _
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program

src/Gyehoek/CPS/Lower.hs

@@ -26,8 +26,12 @@ import Language.Sexp.Located qualified as SL
 import Control.Monad.Fix
 import qualified Gyehoek.Sexp
 import Data.Text qualified as T
+import Data.List qualified
 import Data.Foldable (fold)
 import Gyehoek.Sexp (encodeOrShow, toSexp)
+import Debug.Pretty.Simple
+import GHC.Stack (HasCallStack)
+import Data.String.Interpolate
 
 
 data Env = MkEnv
@@ -57,31 +61,34 @@ makeSmallFixnum = [expr|
     ref.i31
   |]
 
+getArgRegister :: Natural -> SL.Sexp
+getArgRegister n = SL.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 "push argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
-    (i32.const #{n})
     ##{e}
-    (array.set $arg-array-type)
+    (global.set #{reg})
+    (@gyehoek end pushArg)
   |]
+  where reg = getArgRegister n
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Int -> Wasm.Expr
+popArg :: Natural -> Wasm.Expr
 popArg n = [expr|
-  (@gyehoek "pop argument")
+  (@gyehoek begin popArg)
-  (global.get $arg-array)
+  (global.get #{reg})
-  (i32.const #{n})
-  (array.get $arg-array-type)
   ref.as_non_null
+  (@gyehoek end popArg)
 |]
+  where reg = getArgRegister n
 
 
 
-lowerVal :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr
+lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
 
 lowerVal g (ValLit l) =
   pure $ case l of
@@ -96,17 +103,10 @@ lowerVal g (ValLit l) =
       where b' :: Int = if b then 0b11 else 0b01
     _ -> _
 
-lowerVal g (ValVar x) = pure $ [expr|(local.get #{l})|]
+lowerVal g (ValVar x) = do
+  pure [expr|(global.get #{l})|]
   where
-    l = succ $ V.elemIndex x g.vars ^?! _Just
+    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
-
--- lowerVal g (ValLambda lam) = do
---   idx <- lowerLambda g lam
---   pure [expr|
---     (i32.const 0)
---     (ref.func #{idx})
---     (struct.new $closure)
---   |]
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
@@ -158,11 +158,12 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
   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)
-    (local.set #{n})
+    (global.set #{reg})
     ##{e'}
   |]
 
@@ -182,10 +183,10 @@ lower' g e@(ExpApply f xs ktail) = do
     (ref.cast (ref $closure))
     (struct.get $closure $code)
     (return_call_ref $cont-type)
-    ;; (@gyehoek todo
+    (@gyehoek todo
-    ;;  (f' ##{f'})
+     (f' ##{f'})
-    ;;  (ktail #{l}))
+     (ktail #{l}))
-     |]
+  |]
 
 lower' g e@(ExpContinue k xs) = do
   let nargs = length xs
@@ -218,20 +219,14 @@ lower' g e = error $ case Gyehoek.Sexp.encode e of
 
 lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
 lowerKappa g e@(MkKappa xs m) = do
-  let g' = g & #vars .~ V.fromList xs
+  let g' = g & #vars <>~ V.fromList xs
   m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
   let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
       (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
+      ##{m'})
   |]
   Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
   pure idx
@@ -241,18 +236,12 @@ lowerLambda g e@(MkLambda xs ktail m) = do
   let g' = g & #vars .~ V.fromList xs
              & #kvars <>~ [ktail]
   m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
   let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
       (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
+      ##{m'})
   |]
   Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
   pure idx
@@ -264,6 +253,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do
   let op' = SL.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
@@ -278,7 +268,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do
     i32.shr_u
     #{op'}
     ##{makeSmallFixnum}
-    (local.set #{n})
+    (global.set #{reg})
     ##{e'}
   |]
 
@@ -305,13 +295,24 @@ emitRuntime = mfix \runtime -> do
     (global $cont-stack (ref $cont-stack-type)
             (array.new_default $cont-stack-type (i32.const 128)))
   |]
-  -- arg array
+  -- arg registers
-  Wasm.defineType [wat|
+  Wasm.defineGlobals [wats|
-    (type $arg-array-type (array (mut (ref null eq))))
+    (global $arg0 (mut (ref null eq)) (ref.null eq))
-  |]
+    (global $arg1 (mut (ref null eq)) (ref.null eq))
-  Wasm.defineGlobal [wat|
+    (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (global $arg-array (ref $arg-array-type)
+    (global $arg3 (mut (ref null eq)) (ref.null eq))
-            (array.new_default $arg-array-type (i32.const 32)))
+    (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|

src/Gyehoek/CPS/Syntax.hs

@@ -2,11 +2,14 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
@@ -18,10 +21,19 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
+  , binders
+  , body
+  , op
+  , args
+  , cont
   , cps
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
+  , Free(..)
+  , Vars(..)
+  , Subst(..)
   )
   where
 
@@ -41,6 +53,13 @@ import Language.Sexp.Located (Sexp)
 import qualified Data.InvertibleGrammar.Base as IG
 import qualified Gyehoek.Scheme.Syntax as Gyehoek
 import Data.InvertibleGrammar.Base (type (:-)((:-)))
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.Hashable (Hashable)
+import Data.Monoid (Endo)
+import Data.Containers.ListUtils (nubOrd)
+import Data.Functor.Foldable.TH
+import Data.Functor.Foldable (Recursive(..), Corecursive (..))
 
 -- Data types
 
@@ -49,10 +68,10 @@ data Val
   | ValLit Lit
   deriving (Show, Generic, Data, Eq)
 
-data Kappa = MkKappa (List Name) Exp
+data Kappa = MkKappa { binders :: List Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
-data Lambda = MkLambda (List Name) Name Exp
+data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
 data Abs
@@ -65,7 +84,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec (NonEmpty (Name, Abs)) Exp
+  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -90,14 +109,37 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
+-- makeLenses ''Kappa
 makePrisms ''Exp
+-- makeLenses ''Exp
+-- makeFieldsNoPrefix ''Exp
+-- makeFieldsNoPrefix ''Kappa
+-- makeLensesWith abbreviatedFields ''Exp
+-- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
+makeFieldsId ''Exp
+makeFieldsId ''Kappa
+makeFieldsId ''Lambda
+makeBaseFunctor ''Exp
+
+instance HasBinders Abs (List Name) where
+  binders k (AbsKappa kap) = AbsKappa <$> binders k kap
+  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
+
+instance HasBody Abs Exp where
+  body k (AbsKappa kap) = AbsKappa <$> body k kap
+  body k (AbsLambda lam) = AbsLambda <$> body k lam
+
+_AbsLambda' :: Prism' Abs (List Name, Name, Exp)
+_AbsLambda' = prism'
+  (\(bs,ktail,e) -> AbsLambda' bs ktail e)
+  (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
+         _ -> Nothing)
 
 
 -- SexpIso instances
 
 instance S.SexpIso Val where
   sexpIso = match
-    --  $ With (. label)
     $ With (\var -> var . S.sexpIso)
     $ With (\lit -> lit . S.sexpIso)
     $ End
@@ -192,3 +234,107 @@ instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
 
 cps :: QuasiQuoter
 cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+
+
+
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
+insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+insertFrom = flip $ foldr HS.insert
+
+toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
+toHashSetOf l = foldrOf l HS.insert mempty
+
+class Free a where
+  free :: a -> HashSet Name
+  free = freeWithBound mempty
+
+  freeWithBound :: HashSet Name -> a -> HashSet Name
+  freeWithBound bound = HS.fromList . freeWithBound' bound
+
+  -- | Free variables given in the order of their appearance.
+  free' :: a -> List Name
+  free' = freeWithBound' mempty
+
+  freeWithBound' :: HashSet Name -> a -> List Name
+
+instance Free Abs where
+  freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
+  freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
+
+instance Free Exp where
+  freeWithBound' bound = \case
+    ExpPrim p k ->
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> freeWithBound' bound k)
+    ExpLetRec bs m ->
+      foldMapOf (each . _2) (freeWithBound' bound') bs
+      <> freeWithBound' bound' m
+      where bound' = bound & insertFrom (bs ^.. each . _1)
+    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+    ExpIf c t f ->
+      (c ^.. #ValVar . filtered (`notElem` bound))
+      <> freeWithBound' bound t <> freeWithBound' bound f
+    ExpApply f xs k ->
+      (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+      <> (k ^.. filtered (`notElem` bound))
+
+instance Free Kappa where
+  freeWithBound' bound (MkKappa xs m) =
+    freeWithBound' (bound & insertFrom xs) m
+
+instance Free Lambda where
+  freeWithBound' bound (MkLambda xs k m) =
+    freeWithBound' (bound & insertFrom (k:xs)) m
+
+
+
+class Vars a where
+  -- | Traverse the immediate variables of an expression.
+  vars :: Traversal' a Name
+
+instance Vars Val where
+  vars k (ValVar x) = ValVar <$> k x
+  vars _ x = pure x
+
+instance Vars a => Vars (Prim a) where
+  vars k p = traverseOf (each . vars) k p
+
+instance Vars Exp where
+  vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
+  vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
+  vars _ e = pure e
+
+
+
+data Scope
+  = Bind (List Name) Scope
+  | Use (List Name) Scope
+  | Leaf
+  deriving (Show, Eq)
+
+makeBaseFunctor ''Scope
+
+class Subst a where
+  substWith :: (Name -> Val) -> a -> a
+
+instance Subst Exp where
+  substWith sub = cata \e ->
+    _
+
+class Scoped a where
+  scope :: a -> Scope
+
+instance Scoped Kappa where
+  scope (MkKappa bs e) =
+    Bind bs (scope e)
+
+instance Scoped Val where
+  scope = \case
+    ValVar x -> Use [x] Leaf
+    _ -> Leaf
+
+instance Scoped Exp where
+  scope = \case
+    ExpApply f xs k = _

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm)
   where
 
 import Gyehoek.Options
@@ -16,11 +16,18 @@ import qualified Gyehoek.Sexp as Sexp
 import qualified Gyehoek.Scheme.Syntax as Scm
 import qualified Data.Text.Encoding as T
 import System.IO (Handle)
+import System.IO qualified as IO
 import Gyehoek.CPS.Convert
 import Gyehoek.CPS.Lower
 import Gyehoek.CPS.Syntax qualified as Cps
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
+import System.Process.Typed
+import Data.Text.Encoding (encodeUtf8)
+import System.Environment.Blank (getEnvDefault)
+import GHC.Conc (atomically)
+import qualified Data.Text.IO as TIO
+import qualified Data.ByteString.Lazy as BS
 
 
 main :: IO ()
@@ -59,6 +66,31 @@ readScm f =
     Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
      >>= either error (pure . Scm.MkProgram)
 
+inspectWasm :: IOE :> es => Text -> Eff es ()
+inspectWasm wat = do
+  pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
+  let wasmtools_cfg
+        = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
+                            ,"--color", "always", "-"]
+          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
+          -- & setStdout byteStringOutput
+          & setStdin createPipe
+          & setStdout createPipe
+          & setStderr inherit
+  let pager_cfg = proc pager_cmd []
+                & setStdin createPipe
+                & setStdout inherit
+                & setStderr inherit
+  liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
+    TIO.hPutStrLn (getStdin wasmtools) wat
+    IO.hFlush (getStdin wasmtools)
+    IO.hClose (getStdin wasmtools)
+    withProcessWait_ pager_cfg \pager -> do
+      t <- BS.hGetContents (getStdout wasmtools)
+      BS.hPut (getStdin pager) t
+      IO.hFlush (getStdin pager)
+      IO.hClose (getStdin pager)
+
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -72,6 +104,8 @@ driver opts = do
   wat <- lowerProgram cps
   withFile opts.output FS.WriteMode \h ->
     hPutStrLn h wat
+  when opts.inspectWasm do
+    inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm

src/Gyehoek/Options.hs

@@ -19,6 +19,7 @@ data Options = MkOptions
   -- , dumpQBE :: Maybe FilePath
   dumpCPS :: Bool
   , dumpParsed :: Bool
+  , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   }
@@ -49,10 +50,12 @@ parseOutput = strOption
 
 parseDumpCPS = switch (long "dump-cps")
 parseDumpParsed = switch (long "dump-parsed")
+parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseDumpCPS
   <*> parseDumpParsed
+  <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -52,7 +52,7 @@ import Language.Haskell.TH.Quote (QuasiQuoter)
 
 
 newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
   deriving stock (Generic, Data)
 
 getName :: Name -> Text
@@ -72,6 +72,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
+  | PrimMakeClosure { code :: e, upvals :: List e }
   deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
@@ -94,6 +95,7 @@ data Def
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
+  | ExpLetRec (NonEmpty (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -154,12 +156,14 @@ primSexpIso namefn a = match
     $ With (. unop "write")
     $ With (. unop "zero?")
     $ With (. nullop "newline")
+    $ With (. mkclosure)
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
       unop s = list $ idn s >>> el a
       binop s = list $ idn s >>> el a >>> el a
+      mkclosure = list $ idn "make-closure" >>> el a >>> rest a
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -203,6 +207,7 @@ instance SexpIso Def where
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)

t.scm

@@ -0,0 +1,3 @@
+(letrec ((x 3)
+         (y 4))
+  (values x y))

t.wat

@@ -0,0 +1,142 @@
+(module
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "truthy?"
+    (func $gh-truthy? (param (ref eq)) (result i32)))
+  (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)))))
+  (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)))
+  (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))
+  (global $result (mut (ref null eq)) (ref.null eq))
+  (func
+    $halt
+    (param i32)
+    (@gyehoek begin popArg)
+    (global.get $arg0)
+    ref.as_non_null
+    (@gyehoek end popArg)
+    (global.set $result))
+  (func
+    (param i32)
+    (@gyehoek
+      :origin
+      "(λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2))))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek
+      :origin
+      "(prim (* x x) (κ (r2) (continue λ-tail1 r2)))")
+    (global.get $arg1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    (global.get $arg1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    i32.mul
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (global.set $arg2)
+    (@gyehoek :origin "(continue λ-tail1 r2)")
+    (@gyehoek "push args")
+    (@gyehoek begin pushArg)
+    (global.get $arg2)
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (@gyehoek "nargs")
+    (i32.const 1)
+    (@gyehoek "pop cont stack")
+    (global.get $cont-stack-top)
+    (i32.const 1)
+    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))
+  (elem declare funcref (ref.func 3))
+  (func
+    (param i32)
+    (@gyehoek :origin "(κ (x4) (continue halt x4))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek begin pushArg)
+    (global.get $arg2)
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (return_call $halt (i32.const 1)))
+  (elem declare funcref (ref.func 4))
+  (func
+    $scm-entry
+    (param i32)
+    (@gyehoek
+      :origin
+      "(letrec ((λ-body0 (λ (x λ-tail1) (prim (* x x) (κ (r2) (continue λ-tail1 r2)))))) (letrec ((r3 (κ (x4) (continue halt x4)))) (λ-body0 5 r3)))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    (ref.func 3)
+    (struct.new $closure)
+    (global.set $arg1)
+    (@gyehoek :origin "(λ-body0 5 r3)")
+    (@gyehoek "push cont" :idx 4)
+    (array.set
+      $cont-stack-type
+      (global.get $cont-stack)
+      (global.get $cont-stack-top)
+      (ref.func 4))
+    (global.set
+      $cont-stack-top
+      (i32.add (global.get $cont-stack-top) (i32.const 1)))
+    (@gyehoek :origin "(λ-body0 5 r3)")
+    (@gyehoek "load args")
+    (@gyehoek begin pushArg)
+    (i32.const 5)
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (global.set $arg0)
+    (@gyehoek end pushArg)
+    (i32.const 1)
+    (global.get $arg1)
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type)
+    (@gyehoek todo (f' (global.get $arg1)) (ktail 1)))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

test/Gyehoek/Test/CPS/Syntax.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.Test.CPS.Syntax (root) where
 
 import Test.Tasty (TestTree, testGroup)
@@ -13,6 +14,20 @@ import Gyehoek.Test.Sexp (equivto)
 root :: IO TestTree
 root = pure . testGroup "cps syntax" $
   [ qqTree
+  , freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testGroup "free"
+  [ testCase "lambda" do
+    Sut.free' @Sut.Lambda [cps|
+      (lambda (x y z k1) (continue k1 x a b c y))
+    |] @=? ["a","b","c"]
+  , testCase "exp" do
+    Sut.free' @Sut.Exp [cps|
+      (letrec ((x (lambda (r k1) (continue k1 y)))
+               (y (lambda (r k2) (continue k2 x))))
+        (continue x y k3))|] @=? ["k3"]
   ]
 
 qqTree :: TestTree