idk

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,9 +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
@@ -58,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")
-    (global.get $arg-array)
-    (i32.const #{n})
+    (@gyehoek begin pushArg)
     ##{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")
-  (global.get $arg-array)
-  (i32.const #{n})
-  (array.get $arg-array-type)
+  (@gyehoek begin popArg)
+  (global.get #{reg})
   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
@@ -97,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
-
--- lowerVal g (ValLambda lam) = do
---   idx <- lowerLambda g lam
---   pure [expr|
---     (i32.const 0)
---     (ref.func #{idx})
---     (struct.new $closure)
---   |]
+    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
@@ -159,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'}
   |]
 
@@ -219,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
@@ -242,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
@@ -265,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
@@ -279,7 +268,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do
     i32.shr_u
     #{op'}
     ##{makeSmallFixnum}
-    (local.set #{n})
+    (global.set #{reg})
     ##{e'}
   |]
 
@@ -306,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
-  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)))
+  -- 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|

src/Gyehoek/CPS/Syntax.hs

@@ -9,6 +9,7 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
@@ -20,6 +21,7 @@ module Gyehoek.CPS.Syntax
   , _ExpPrim
   , _ExpLetRec
   , _ExpApply
+  , _AbsLambda'
   , binders
   , body
   , op
@@ -29,8 +31,9 @@ module Gyehoek.CPS.Syntax
   , pattern AbsLambda'
   , pattern AbsKappa'
   , Abs(..)
-  , free
-  , free'
+  , Free(..)
+  , Vars(..)
+  , Subst(..)
   )
   where
 
@@ -55,6 +58,8 @@ 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
 
@@ -114,6 +119,7 @@ makePrisms ''Exp
 makeFieldsId ''Exp
 makeFieldsId ''Kappa
 makeFieldsId ''Lambda
+makeBaseFunctor ''Exp
 
 instance HasBinders Abs (List Name) where
   binders k (AbsKappa kap) = AbsKappa <$> binders k kap
@@ -123,6 +129,12 @@ 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
 
@@ -234,49 +246,95 @@ insertFrom = flip $ foldr HS.insert
 toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
 toHashSetOf l = foldrOf l HS.insert mempty
 
-free :: Exp -> HashSet Name
-free = go where
-  gokap (MkKappa xs m) = go m & deleteFrom xs
-  golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
-  goabs = \case
-    AbsKappa kap -> gokap kap
-    AbsLambda lam -> golam lam
-  go = \case
+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 & toHashSetOf (folded . #ValVar)
-        & HS.union (gokap k)
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
-      foldMapOf (each . _2) goabs bs <> go m
-      & deleteFrom (bs ^.. each . _1)
-    ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
-    ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
-    ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
+      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))
 
--- | Free variables given in the order of their appearance.
-free' :: Exp -> List Name
-free' = nubOrd . goFree HS.empty where
+instance Free Kappa where
+  freeWithBound' bound (MkKappa xs m) =
+    freeWithBound' (bound & insertFrom xs) m
 
-goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
-goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
-goFreeAbs bound = \case
-  AbsKappa kap -> goFreeKap bound kap
-  AbsLambda lam -> goFreeLam bound lam
+instance Free Lambda where
+  freeWithBound' bound (MkLambda xs k m) =
+    freeWithBound' (bound & insertFrom (k:xs)) m
 
-goFree :: HashSet Name -> Exp -> List Name
-goFree bound = \case
-  ExpPrim p k ->
-    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      & (<> goFreeKap bound k)
-  ExpLetRec bs m ->
-    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree 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))
-    <> goFree bound t <> goFree bound f
-  ExpApply f xs k ->
-    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-    <> (k ^.. filtered (`notElem` bound))
+
 
-freeLambda :: Lambda -> List Name
-freeLambda (MkLambda {binders,ktail,body}) = _
+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
@@ -102,10 +102,9 @@ driver opts = do
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   wat <- lowerProgram cps
-  if not opts.inspectWasm then
-    withFile opts.output FS.WriteMode \h ->
-      hPutStrLn h wat
-  else
+  withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
+  when opts.inspectWasm do
     inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program

src/Gyehoek/Scheme/Syntax.hs

@@ -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_)