qq

.gitea/workflows/build.yaml

@@ -0,0 +1,13 @@
+name: build
+on: [push]
+
+jobs:
+  build:
+    runs-on: nixos
+    steps:
+      - name: Check out repository code
+        uses: actions/checkout@v4
+      - name: build gyehoek
+        run: nix build -L .#gyehoek
+      - name: test gyehoek
+        run: nix flake check -L

.gitignore

@@ -7,4 +7,5 @@ dist-newstyle
 .ghc.environment.*
 *.tix
 .direnv
-result
+result
+play/

app/Gyehoek/ANF/Syntax.hs

@@ -1,531 +0,0 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
-{- HLINT ignore "Avoid lambda using `infix`" -}
-module Gyehoek.ANF.Syntax
-  ( Exp(..)
-  , toANF
-  , lower
-  , wrapFunction
-  , lowerProgram
-  )
-  where
-
-import Data.Text (Text)
-import Effectful
-import Gyehoek.QBE qualified as QBE
-import Data.List (List)
-import Data.Text.IO qualified as TIO
-import Control.Lens
-import Data.Generics.Labels
-import Data.Vector.Strict (Vector)
-import Data.Function (fix)
-import Effectful.Writer.Static.Local
-import Gyehoek.Scheme.Syntax qualified as Lam
-import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..))
-import Gyehoek.GenSym
-import Control.Monad.Cont
-import Data.Foldable
-import Data.List.NonEmpty (NonEmpty((:|)))
-import Data.List.NonEmpty qualified as NE
-import Gyehoek.QBE (FuncDef(FuncDef))
-import Data.Foldable1
-import qualified Data.Text as T
-import Data.String (fromString)
-import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode, traversed)
-import Language.SexpGrammar.Generic
-import GHC.Generics (Generic)
-import Gyehoek.Sexp
-import Control.Category
-import Prelude hiding ((.), id)
-import Data.InvertibleGrammar.Base qualified as IG
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import qualified Gyehoek.Sexp
-import Control.Lens.Unsound
-import qualified Data.Bits
-import qualified GHC.IO.Encoding as T
-import qualified Data.Text.Encoding as T
-
-
-data Val
-  = ValLit Lit
-  | ValVar Name
-  deriving (Show, Generic)
-
-data Exp
-  = ExpLetApply Name Val (List Val) Exp
-  | ExpLetPrim Name (Prim Val) Exp
-  | ExpBegin (List Exp)
-  | ExpVal Val
-  deriving (Show, Generic)
-
-
-
-expandBindings
-  -- | Match constructor. (an affine fold would be preferable to a
-  --   prism here)
-  :: Prism' e (lhs, rhs, e)
-  -> e
-  -> (List (lhs, rhs), e)
-expandBindings p = go [] where
-  go acc e =
-    case e ^? p of
-      Just (l,r,e') -> go ((l,r):acc) e'
-      Nothing -> (acc, e)
-
-collapseBindings
-  :: Foldable f => AReview e (lhs, rhs, e) -> f (lhs, rhs)
-  -> e -> e
-collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
-
--- | Technically unlawful.
-bindingTelescope
-  :: Prism' e (lhs, rhs, e)
-  -> Iso' e (List (lhs, rhs), e)
-bindingTelescope p = iso
-  (expandBindings p)
-  (uncurry $ collapseBindings p)
-
-foldLet
-  :: Prism' Exp (lhs, rhs, Exp)
-  -> Grammar
-       Position
-       (Exp :- NonEmpty (lhs, rhs) :- t)
-       (Exp :- rhs :- lhs :- t)
-foldLet p =
-  IG.Iso
-    (\(e :- ((l1,r1):|bs) :- t) ->
-       collapseBindings p bs e :- r1 :- l1 :- t)
-    (\(e :- r :- l :- t) ->
-       let (bs,e') = expandBindings p e
-       in e' :- ((l,r) :| bs) :- t)
-
-instance SexpIso Val where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. symbol)
-    $ End
-
-nonEmptyIso :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
-nonEmptyIso = iso (\(x:|xs) -> (x,xs)) (uncurry (:|))
-
--- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
--- nonEmptyGrammar = IG.Iso
---   (\((x:|xs) :- t) -> xs :- x :- t)
---   (\(xs :- x :- t) -> (x:|xs) :- t)
-
-instance SexpIso Exp where
-  sexpIso = match
-    $ With (. letapp)
-    $ With (. letprim)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. sexpIso)
-    $ End
-    where
-      letprim
-        :: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
-      letprim =
-        Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
-        >>> foldLet #ExpLetPrim
-      letapp :: Grammar
-        Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
-      letapp =
-        Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
-         >>> foldLet (#ExpLetApply
-                      . iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
-                            (\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
-         >>> onTail nonEmptyGrammar
-
-
-
--- 뻘짓이어라
-telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
-telescope = runCont . traverse cont
-
-toANF'
-  :: forall es. GenSym :> es
-  => Lam.Exp
-  -> (Val -> Eff es Exp)
-  -> Eff es Exp
-
-toANF' (Lam.ExpLit v) k = k . ValLit $ v
-
-toANF' (Lam.ExpPrim p) k =
-  telescope (toANF' <$> p) \p' -> do
-    r <- gensym
-    ExpLetPrim r p' <$> k (ValVar r)
-
-toANF' (Lam.ExpApply f xs) k =
-  telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
-    r <- gensym
-    ExpLetApply r f' xs' <$> k (ValVar r)
-
-toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
-  where
-    anf x = toANF' x (pure . ExpVal)
-
-toANF' (Lam.ExpLet xs e) k = _
-
-toANF' e k = _
-
-toANF e = toANF' e (pure . ExpVal)
-
-
-
-expr =
-  Lam.ExpPrim
-    (PrimAdd
-     (Lam.ExpPrim
-      (PrimMul
-       (Lam.ExpLit (LitInt 2))
-       (Lam.ExpLit (LitInt 3))))
-    (Lam.ExpLit (LitInt 4)))
-
-expr2 =
-  Lam.ExpBegin
-    [ Lam.ExpPrim
-      (PrimWrite
-       (Lam.ExpPrim
-         (PrimCons
-          (Lam.ExpLit (LitInt 2))
-          (Lam.ExpLit (LitInt 3)))))
-    , Lam.ExpPrim
-      (PrimWrite
-       (Lam.ExpPrim
-        (PrimMul
-         (Lam.ExpLit (LitInt 5))
-         (Lam.ExpLit (LitInt 4)))))
-    ]
-
-
-
-instance Semigroup QBE.Program where
-  QBE.Program ts ds fs <> QBE.Program ts' ds' fs' =
-    QBE.Program (ts <> ts') (ds <> ds') (fs <> fs')
-
-instance Monoid QBE.Program where
-  mempty :: QBE.Program
-  mempty = QBE.Program mempty mempty mempty
-
-funcdef
-  :: QBE.Ident QBE.Global
-  -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
-funcdef name ps =
-  QBE.FuncDef
-  mempty
-  (Just (QBE.AbiBaseTy QBE.Long))
-  name Nothing ps QBE.NoVariadic
-
-prims :: QBE.Program
-prims = QBE.Program primtys mempty primfns where
-  primtys =
-    [ QBE.TypeDef "scm" Nothing
-      [ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
-    ]
-  primfns = [ -- write
-            -- , mkArith "plus" QBE.Add
-            -- , mkArith "star" QBE.Mul
-            -- , mkArith "_" QBE.Sub
-            -- , mkArith "slash" (QBE.Div QBE.Signed)
-            ]
-  mkArith name bop =
-    funcdef name
-    [ QBE.Param (QBE.AbiBaseTy QBE.Long) "x"
-    , QBE.Param (QBE.AbiBaseTy QBE.Long) "y"
-    ]
-    [ QBE.Block "start" []
-      [ QBE.BinaryOp ("r" QBE.:= QBE.Long) bop
-        (QBE.ValTemporary "x") (QBE.ValTemporary "y")
-      ]
-      (QBE.Ret (Just (QBE.ValTemporary "r")))
-    ]
-
-data BlockBuilder
-  = Emit (Vector QBE.Inst) !BlockBuilder
-  | Exit QBE.Jump
-  deriving (Show)
-
-instance Semigroup BlockBuilder where
-  Emit a as <> bs = Emit a (as <> bs)
-  Exit _ <> bs = bs
-
-instance Each BlockBuilder BlockBuilder QBE.Inst QBE.Inst where
-  each k (Emit is bb) = Emit <$> traverse k is <*> each k bb
-  each k (Exit j) = pure (Exit j)
-
-evalBlockBuilder :: BlockBuilder -> (Vector QBE.Inst, QBE.Jump)
-evalBlockBuilder (Emit is bb) = evalBlockBuilder bb & _1 <>:~ is
-evalBlockBuilder (Exit j)     = ([],j)
-
-buildBlock :: QBE.Ident QBE.Label -> BlockBuilder -> QBE.Block
-buildBlock n bb = QBE.Block n [] (is ^.. each) j
-  where (is,j) = evalBlockBuilder bb
-
-lowerName :: Name -> QBE.Ident t
-lowerName = fromString . T.unpack
-
-lowerInt' = QBE.ValConst . QBE.CInt . fromIntegral
-
-lowerInt = QBE.ValConst . QBE.CInt
-  . (Data.Bits..|. 2)
-  . (Data.Bits..<<. 2)
-  . fromIntegral
-
-lowerVal
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
-
--- lowerVal (ValLit (LitQuote (SexpSymbol s))) k = _aaa
-
-lowerVal (ValLit (LitString s)) k = do
-  rawString <- gensym
-  r <- gensym
-  let bs = T.encodeUtf8 s
-      len = lengthOf each bs
-  tell . pure $
-    QBE.DataDef [] rawString Nothing
-      [QBE.FieldExtTy QBE.Byte [QBE.String bs]]
-  Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
-  where
-    alloc r rs len =
-      [ QBE.Call
-        (Just (r, QBE.AbiBaseTy QBE.Long))
-        (QBE.ValGlobal "scm_from_utf8_string")
-        Nothing
-        [ QBE.Arg (QBE.AbiBaseTy QBE.Long) (QBE.ValGlobal rs)
-        -- N.b. The C function declares this argument as size_t, which
-        -- /is/ long on my system.
-        , QBE.Arg (QBE.AbiBaseTy QBE.Long) (lowerInt' len)
-        ]
-        []
-      ]
-
-lowerVal (ValLit _) k = error "todo"
-lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
-
-binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
-binaryPrim = prism' up down where
-  up (bop,a,b) = case bop of
-    QBE.Add -> _
-    QBE.Mul -> _
-    _ -> _
-  down = \case
-    PrimAdd a b -> Just (QBE.Add,a,b)
-    PrimMul a b -> Just (QBE.Mul,a,b)
-    _ -> Nothing
-
-lowerArithmetic :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
-lowerArithmetic r p = QBE.BinaryOp r bop x y
-  where
-    (bop,x,y) = case p of
-      PrimAdd a b -> (QBE.Add,a,b)
-      PrimMul a b -> (QBE.Mul,a,b)
-      _ -> _
-
-sizeofScm :: Integral a => a
-sizeofScm = 8
-
-lowerCons
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Name -> QBE.Val -> QBE.Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerCons r car cdr e k = do
-  r1 <- gensym
-  Emit (alloc <> initialise r1) <$> lower' e k
-  where
-    alloc = [ QBE.Call
-              (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-              (QBE.ValGlobal "GC_malloc")
-              Nothing
-              [ QBE.Arg
-                (QBE.AbiBaseTy QBE.Long)
-                (QBE.ValConst (QBE.CInt (sizeofScm * 2))) ]
-              []
-            ]
-    initialise r1 =
-      [ QBE.BinaryOp (r1 QBE.:= QBE.Long) QBE.Add
-        (QBE.ValTemporary (lowerName r)) (QBE.ValConst (QBE.CInt 8))
-      , QBE.Store (QBE.BaseTy QBE.Long) car (QBE.ValTemporary (lowerName r))
-      , QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
-      ]
-
-smallIntHelper'
-  :: GenSym :> es
-  => QBE.Ident 'QBE.Temporary
-  -> QBE.BinaryOp
-  -> QBE.Val -> QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-smallIntHelper' r bop v1 v2 k = do
-  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
-         bop v1 v2 ]
-    <$> k (QBE.ValTemporary r)
-
-smallIntHelper
-  :: GenSym :> es
-  => QBE.BinaryOp
-  -> QBE.Val -> QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-smallIntHelper bop a b k = do
-  r <- gensym
-  smallIntHelper' r bop a b k
-
-makeSmallInt'
-  :: forall es. (GenSym :> es)
-  => QBE.Ident 'QBE.Temporary
-  -> QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-makeSmallInt' r n k =
-  smallIntHelper QBE.Shl n (lowerInt' 2) \n' ->
-    smallIntHelper' r QBE.Add n' (lowerInt' 2) k
-
-makeSmallInt
-  :: forall es. (GenSym :> es)
-  => QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-makeSmallInt n k = do
-  r <- gensym
-  makeSmallInt' r n k
-
-getSmallInt
-  :: forall es. (GenSym :> es)
-  => QBE.Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
-
-lowerWrite 
-  :: forall es. (GenSym :> es)
-  => Name -> QBE.Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerWrite r x e k =
-  Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-         (QBE.ValGlobal "scm_write") Nothing
-         [QBE.Arg (QBE.AbiBaseTy QBE.Long) x]
-         []
-       ]
-    <$> k (QBE.ValTemporary (lowerName r))
-
-smallIntMask :: Integer
-smallIntMask = 2 ^ (sizeofScm * 8) - 2
-
-lowerCar
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Name -> QBE.Val -> _
-  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
-lowerCar r x e k = do
-  Emit [ QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long x
-       ]
-    <$> lower' e k
-
-lowerCdr
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Name -> QBE.Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
-lowerCdr r x e k = do
-  x1 <- gensym
-  Emit [ QBE.BinaryOp (x1 QBE.:= QBE.Long)
-         QBE.Add x (lowerInt' sizeofScm)
-       , QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long
-         (QBE.ValTemporary x1)
-       ]
-    <$> lower' e k
-
-lowerPrim 
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Name -> Prim Val -> Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-lowerPrim r p e k =
-  telescope (lowerVal <$> p) \case
-    (preview binaryPrim -> Just (bop,a,b)) ->
-      getSmallInt a \a' ->
-        getSmallInt b \b' ->
-          smallIntHelper bop a' b' \c ->
-            makeSmallInt' (lowerName r) c \_ ->
-              lower' e k
-    PrimCons x y -> lowerCons r x y e k
-    PrimCar x -> lowerCar r x e k
-    PrimCdr x -> lowerCdr r x e k
-    PrimWrite x -> lowerWrite r x e k
-
-lower'
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lower' (ExpVal v) k = lowerVal v k
-
-lower' (ExpLetPrim r p e) k = lowerPrim r p e k
-
-lower' (ExpLetApply r f xs e) k =
-  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
-    Emit [ QBE.Call
-            (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-            f'
-            Nothing
-            (QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
-            []
-          ]
-      <$> lower' e k
-
-lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
-  where low e = lower' @es e (pure . Exit . QBE.Ret . Just)
-
-lower' _ k = _
-
-lower
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => QBE.Ident QBE.Label
-  -> Exp
-  -> Eff es QBE.Block
-lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
-
-lowerProgram 
-  :: (GenSym :> es, Traversable t)
-  => t Exp -> Eff es QBE.Program
-lowerProgram anfs =
-  case toList anfs of
-    -- hack for dev convenience: if there's only one expression, let
-    -- it be the entry point.
-    [e] -> do
-      (b,dataDefs) <- runWriter . lower "start" $ e
-      let f = wrapFunction @NonEmpty "main" [b]
-      pure $ QBE.Program [] (dataDefs ^.. each) [f]
-    _ -> do
-      let low e = do
-            bl <- gensym' "b"
-            fl <- gensym' "f"
-            b <- lower bl e
-            pure $ wrapFunction @NonEmpty fl [b]
-      (fs,dataDefs) <- runWriter $ traverse low anfs
-      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
-
-wrapFunction
-  :: Foldable1 t
-  => QBE.Ident 'QBE.Global -> t QBE.Block -> QBE.FuncDef
-wrapFunction l bs =
-  QBE.FuncDef [QBE.Export]
-    (Just (QBE.AbiBaseTy QBE.Word))
-    l Nothing [] QBE.NoVariadic (toNonEmpty bs)
-
-wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
-wrapProgram bs = prims <> QBE.Program [] [] [main] where
-  main = QBE.FuncDef [QBE.Export]
-    (Just (QBE.AbiBaseTy QBE.Word))
-    "main" Nothing [] QBE.NoVariadic (toNonEmpty bs)

app/Gyehoek/QBE.hs

@@ -1,61 +0,0 @@
-{-# LANGUAGE RequiredTypeArguments #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-module Gyehoek.QBE
-  ( module QBE
-  , render
-  , fn
-  , writeTo
-  )
-  where
-
-import Gyehoek.QBE.Parse
-import Language.QBE as QBE
-import Data.String (IsString(fromString))
-import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
-import Data.Text (Text)
-import Data.Data
-import Prettyprinter.Render.Text (renderStrict)
-import Text.Megaparsec
-import Text.Megaparsec.Char
-import Language.Haskell.TH qualified as TH
-import Language.Haskell.TH.Quote
-import Data.Kind (Type)
-import qualified Data.Text.IO as TIO
-
-
-writeTo :: FilePath -> Text -> IO ()
-writeTo = TIO.writeFile
-
-render :: Pretty a => a -> Text
-render = renderStrict . layoutPretty defaultLayoutOptions . pretty
-
-
-
-parseQuoteExp
-  :: (TH.Quote m, MonadFail m, Data a) => P a -> String -> m TH.Exp
-parseQuoteExp p s =
-  case parse (space *> p <* space <* eof) "qq" (fromString s) of
-    Left es -> fail . foldMap f . bundleErrors $ es
-      where f e = parseErrorPretty e ++ "\n\n"
-    Right x -> dataToExpQ (\_ -> Nothing) x
-
--- quoteExp :: TH.Quote m => forall (t :: Type) -> (Parser t) => String -> m TH.Exp
--- quoteExp t s = case parse (parser @t) "qq" (fromString s) of
---   Left es -> _
---   Right x -> dataToExpQ (\_ -> Nothing) x
-
-makeQQ :: forall (t :: Type) -> Parser t => QuasiQuoter
-makeQQ t = QuasiQuoter
-  { quoteExp = parseQuoteExp (parser @t)
-  , quotePat = _
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
-fn :: QuasiQuoter
-fn = makeQQ (type FuncDef)

app/Gyehoek/QBE/Parse.hs

@@ -1,194 +0,0 @@
-{-# LANGUAGE RequiredTypeArguments #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.QBE.Parse where
-
-import Language.QBE as QBE
-import Effectful.State.Dynamic
-import Effectful.Dispatch.Dynamic
-import Effectful
-import Numeric.Natural
-import Data.String (IsString(fromString))
-import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
-import Data.Text (Text)
-import Data.Data
-import Prettyprinter.Render.Text (renderStrict)
-import Text.Megaparsec
-import Text.Megaparsec.Char
-import Text.Megaparsec.Char.Lexer qualified as L
-import Data.Void (Void)
-import Data.Char (isAlpha, isAlphaNum)
-import Control.Lens.Wrapped
-import Data.Functor.Contravariant (Predicate(Predicate))
-import qualified Data.Text as T
-import Data.Functor
-import Data.List (List)
-import Data.Foldable (fold)
-import Data.Maybe (isJust, fromMaybe)
-import Control.Monad.Fix (MonadFix(mfix))
-import Data.List.NonEmpty (fromList)
-import Language.Haskell.TH qualified as TH
-import Language.Haskell.TH.Quote
-import Data.Proxy
-import Data.Kind (Type)
-
-
-type P = Parsec Void Text
-
-sc :: P ()
-sc = L.space hspace1 (L.skipLineComment "#") empty
-
-lexeme :: P a -> P a
-lexeme = L.lexeme sc
-
-symbol :: Text -> P Text
-symbol = L.symbol sc
-
-infixr 8 .:
-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-(.:) f g x y = f (g x y)
-
-rawIdent :: P QBE.RawIdent
-rawIdent = (fromString .: (:) <$> lead <*> trail) <?> "ident"
-  where
-    lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_')
-    trail = fmap T.unpack . takeWhileP Nothing $ \x ->
-      isAlphaNum x || (x=='.') || (x=='_')
-
-class ParseIdent (s :: Sigil) where
-  ident :: P (QBE.Ident s)
-
-rawIdentWithSigil :: Char -> P (Ident t)
-rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent)
-
-instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':'
-instance ParseIdent Global      where ident = rawIdentWithSigil '$'
-instance ParseIdent Temporary   where ident = rawIdentWithSigil '%'
-instance ParseIdent QBE.Label   where ident = rawIdentWithSigil '@'
-
-const :: P QBE.Const
-const = cint <|> csingle <|> cdouble <|> cglobal <?> "const"
-  where
-    cint = CInt <$> lexeme (L.signed empty L.decimal) <?> "integer"
-    csingle = empty <?> "single-precision float"
-    cdouble = empty <?> "double-precision float"
-    cglobal = CGlobal <$> ident <?> "global symbol"
-
-val :: P QBE.Val
-val = vconst <|> vtemp <?> "val"
-  where
-    vconst = ValConst <$> Gyehoek.QBE.Parse.const
-    vtemp = ValTemporary <$> ident <?> "temporary symbol"
-
-assignment :: P QBE.Assignment
-assignment =
-  Assignment <$> ident <*> (char '=' *> basety)
-
-basety :: P QBE.BaseTy
-basety = lexeme $ char 'w' $> Word
-              <|> char 'l' $> Long
-              <|> char 's' $> Single
-              <|> char 'd' $> Double
-
-abity :: P AbiTy
-abity = AbiBaseTy <$> basety
-    <|> AbiAggregateTy <$> ident
-
-binaryOp :: P QBE.BinaryOp
-binaryOp = lexeme $ "add" $> Add
-                <|> "sub" $> Sub
-                <|> "mul" $> Mul
-                <|> "div" $> Div Signed
-
-comma :: P a -> P a
-comma p = symbol "," *> p
-
-inst :: P QBE.Inst
-inst = try binaryOpInst <|> negInst <?> "inst"
-  where
-    binaryOpInst =
-      BinaryOp
-        <$> assignment
-        <*> binaryOp
-        <*> val <*> comma val
-    negInst = Neg <$> assignment <*> (symbol "neg" *> val)
-
-jump :: P QBE.Jump
-jump = jmp <|> jnz <|> ret <|> hlt <?> "jump"
-  where
-    jmp = symbol "jmp" *> (Jmp <$> ident)
-    jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident)
-    ret = symbol "ret" *> (Ret <$> optional val)
-    hlt = empty
-
-nl :: P ()
-nl = void (some (newline *> sc)) <?> "newline"
-
-phi :: P QBE.Phi
-phi = empty
-
-block :: P QBE.Block
-block = Block
-  <$> (ident <* nl)
-  <*> sepBy phi nl
-  <*> sepBy inst nl
-  <*> jump
-
-sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a)
-sepByTry p sep = do
-  x <- p
-  xs <- many (try $ sep *> p)
-  pure (x:xs)
-
-paramList :: P (Maybe (Ident Temporary), List Param, Variadic)
-paramList = label "parameter list" $ between (symbol "(") (symbol ")") do
-  e <- optional env
-  ps <- optional . try $ do
-    commaIf (isJust e)
-    sepByTry reg (symbol ",")
-  v <- optional do
-    commaIf (isJust e || isJust ps)
-    variadic
-  pure (e, fromMaybe [] ps, fromMaybe NoVariadic v)
-  where
-    commaIf True = void $ symbol ","
-    commaIf False = pure ()
-    env = symbol "env" *> ident @Temporary <?> "environment parameter"
-    reg = Param <$> abity <*> ident <?> "regular parameter"
-    variadic = symbol "..." $> Variadic <?> "variadic parameter"
-
-funcdef :: P QBE.FuncDef
-funcdef = do
-  linkages <- many linkage
-  symbol "function"
-  returnTy <- optional abity
-  name <- ident @Global
-  (env,params,variadic) <- paramList
-  code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $
-    sepEndBy1 block nl
-  pure $ FuncDef linkages returnTy name env params variadic code
-
-linkage :: P Linkage
-linkage = symbol "export" $> Export
-
--- stripped :: P a -> P a
--- stripped p = optional nl *>
-
-
-
-class Data a => Parser a where
-  parser :: P a
-
-instance Parser FuncDef where parser = funcdef
-
-class ParseSeparator a where
-  parseSeparator :: Proxy a -> P ()
-
-instance (Parser a, ParseSeparator a) => Parser (List a) where
-  parser = sepBy parser (parseSeparator @a Proxy)
-
-instance ParseSeparator FuncDef where parseSeparator _ = nl
-instance ParseSeparator Block where parseSeparator _ = nl

app/Gyehoek/Scheme/Syntax.hs

@@ -1,142 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Scheme.Syntax
-  ( Name
-  , Prim(..)
-  , Lit(..)
-  , Define(..)
-  , Exp(..)
-  , Sexp(..)
-  )
-  where
-
-import Data.Text (Text)
-import Data.List (List)
-import Language.SexpGrammar
-  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
-import Language.SexpGrammar qualified as Sexp
-import Language.SexpGrammar.Generic
-import GHC.Generics
-import Prelude hiding ((.), id)
-import Control.Category
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import Gyehoek.Sexp qualified
-import Control.Lens (Each)
-
-
-type Name = Text
-
-data Prim e
-  = PrimAdd e e
-  | PrimSub e e
-  | PrimMul e e
-  | PrimDiv e e
-  | PrimCons e e
-  | PrimCar e
-  | PrimCdr e
-  | PrimImmediateP e
-  | PrimConsP e
-  | PrimIntegerP e
-  | PrimWrite e
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-
-instance Each (Prim e) (Prim e') e e'
-
-data Lit
-  = LitInt Int
-  | LitNil
-  | LitBool Bool
-  | LitString Text
-  | LitQuote Sexp
-  deriving (Show, Generic)
-
-data Define
-  = DefineConstant Name Exp
-  | DefineProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic)
-
-data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpPrim (Prim Exp)
-  | ExpBegin (List Exp)
-  | ExpDefine Define
-  | ExpIf Exp Exp Exp
-  | ExpLit Lit
-  | ExpLambda (List Name) Exp
-  | ExpVar Name
-  | ExpApply Exp (List Exp)
-  deriving (Show, Generic)
-
-data Sexp
-  = SexpCons Sexp Sexp
-  | SexpSymbol Text
-  | SexpLit Lit
-  deriving (Show, Generic)
-
-
-
-instance SexpIso a => SexpIso (Prim a) where
-  sexpIso = match
-    $ With (. binop "+")
-    $ With (. binop "-")
-    $ With (. binop "*")
-    $ With (. binop "/")
-    $ With (. binop "cons")
-    $ With (. unop "car")
-    $ With (. unop "cdr")
-    $ With (. unop "immediate?")
-    $ With (. unop "cons?")
-    $ With (. unop "integer?")
-    $ With (. unop "write")
-    $ End
-    where
-      primname = ("prim:" <>)
-      unop s = list $ el (sym (primname s)) >>> el sexpIso
-      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
-
-instance SexpIso Lit where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. sym "nil")
-    $ With (. sexpIso)
-    $ With (. sexpIso)
-    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
-    $ End
-
-instance SexpIso Sexp where
-  sexpIso = match
-    $ With (\cons -> cons . Gyehoek.Sexp.todo)
-    $ With (\s -> s . symbol)
-    $ With (\lit -> lit . sexpIso)
-    $ End
-
-instance SexpIso Define where
-  sexpIso = match
-    $ With (. defconst)
-    $ With (. defun)
-    $ End
-    where
-      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
-      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el symbol >>> rest symbol
-  
-instance SexpIso Exp where
-  sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
-    $ With (. sexpIso)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. sexpIso)
-    $ With (. if_)
-    $ With (. sexpIso)
-    $ With (. lam)
-    $ With (. symbol)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
-    $ End
-    where
-      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
-      lam = list
-        ( el (sym "lambda")
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )

app/Gyehoek/Sexp.hs

@@ -1,111 +0,0 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLabels #-}
-module Gyehoek.Sexp
-  ( let_
-  , sexp
-  , nonempty
-  , nonEmptyGrammar
-  , encode
-  , decode
-  , parseSexps
-  , prefixSugar
-  , todo
-  )
-where
-
-import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
-import Language.SexpGrammar qualified as Sexp
-import Language.Sexp qualified as S
-import Language.SexpGrammar.Generic
-import Data.InvertibleGrammar.Base qualified as IGB
-import Data.InvertibleGrammar qualified as IG
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import Data.List (List)
-import Data.Text.Encoding
-import Data.Either (either)
-import GHC.Generics (Generic)
-import Control.Lens
-import Data.Generics.Labels
-import System.Process
-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)
-
-
-sexp :: SexpIso a => Iso' a Text
-sexp = iso
-  (either error id . encode)
-  (either error id . decode)
-
-encode :: SexpIso a => a -> Either String Text
-encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
-
-decode :: SexpIso a => Text -> Either String a
-decode = Sexp.decode . view lazy . encodeUtf8
-
-parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
-parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
-
-nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-nonEmptyGrammar = IGB.Iso
-  (\((x:|xs) :- t) -> reverse xs :- x :- t)
-  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
-
-nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
-nonempty a =
-  list (el a >>> rest a) >>>
-    IG.flipped nonEmptyGrammar
-
-let_
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
-  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
-  -> Grammar Position (Sexp :- t1) t2
-let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
-  where
-    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = nonempty binding
-    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
-    binding = list (el name >>> el rhs) >>> pair
-
-data DotList a = MkDotList (NonEmpty a) a
-  deriving (Show, Generic)
-
-dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
-dotlist x = list $ rest $ coproduct
-  [ x >>> _
-  ]
-
--- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
-prefixSugar
-  :: Text -> Prefix
-  -> Grammar Position (Sexp :- t') a
-  -> Grammar Position (Sexp :- t') a
-prefixSugar name prefix e = coproduct
-  -- 'something
-  [ Sexp.prefixed prefix e
-  -- (quote something)
-  , list $ el (sym name) >>> el e
-  ]
-
-todo :: Grammar p (Sexp :- t) t'
-todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
-  where
-    f _ = Left $ unexpected "todo"
-    g _ = Left $ unexpected "todo"
-
-lambda
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> Grammar Position (Sexp :- List a :- t1) t2
-  -> Grammar Position (Sexp :- t1) t2
-lambda name e = list $
-  el (sym "lambda")
-  >>> el (list $ rest name)
-  >>> el e

app/Main.hs

@@ -1,124 +1,6 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ViewPatterns #-}
-module Main
-  (main)
-  where
+module Main (main) where
 
-import qualified Gyehoek.ANF.Syntax as ANF
-import Gyehoek.QBE (render)
-import Gyehoek.Options
-import qualified Data.Text.IO as TIO
-import Data.Text (Text)
-import Prelude hiding (readFile, (.),id)
-import Control.Category
-import Options.Applicative
-import Control.Lens
-import Data.Generics.Labels
-import System.OsPath (OsPath)
-import System.FilePath ((-<.>), dropExtension)
-import Effectful.FileSystem
-import Effectful
-import Effectful.FileSystem.IO qualified as FS
-import Effectful.FileSystem.IO.ByteString qualified as FB
-import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
-import qualified Gyehoek.Sexp as Sexp
-import Data.Text.Lens
-import Data.List (List)
-import qualified Gyehoek.Scheme.Syntax as Scm
-import Effectful.Exception
-import qualified Gyehoek.QBE as QBE
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import System.IO (Handle)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Cradle as C
+import Gyehoek.Driver qualified
 
 
-main :: IO ()
-main = do
-  opts <- execParser $ info (helper <*> parser) fullDesc
-  runEff . runFileSystem . runGenSym . driver $ opts
-
-
-
-hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
-hPutStr h = FB.hPutStr h . T.encodeUtf8
-
-hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
-hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
-
-hGetContents :: FileSystem :> es => Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readFile :: FileSystem :> es => FilePath -> Eff es Text
-readFile f = FS.withFile f FS.ReadMode hGetContents
-
-readScm :: FileSystem :> es => FilePath -> Eff es (List Scm.Exp)
-readScm f = (Sexp.parseSexps f <$> readFile f) >>= either error pure
-
-toANF
-  :: (GenSym :> es, FileSystem :> es)
-  => FilePath -> List Scm.Exp -> Eff es (List ANF.Exp)
-toANF f exps = do
-  anfs <- traverse ANF.toANF exps
-  case traverse Sexp.encode anfs of
-    Left e -> hPutStr FS.stderr (view packed e)
-    Right ss -> do
-      let anf_file = f -<.> "anf"
-      FS.withFile anf_file FS.WriteMode \h_anf -> do
-        hPutStr h_anf ";;; -*- mode:scheme -*-\n\n"
-        hPutStr h_anf $ foldr (\x y -> x <> "\n\n" <> y) "" ss
-      hPutStrLn FS.stderr $ "wrote " <> T.pack anf_file
-  pure anfs
-
-toQBE
-  :: (GenSym :> es, FileSystem :> es, Traversable t)
-  => FilePath -> t ANF.Exp -> Eff es QBE.Program
-toQBE f anfs = do
-  p <- ANF.lowerProgram anfs
-  let qbe_file = f -<.> "ssa"
-  FS.withFile qbe_file FS.WriteMode \h -> do
-    hPutStr h . render $ p
-  hPutStrLn FS.stderr $ "wrote " <> T.pack qbe_file
-  pure p
-
-callQBE
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
-  => FilePath -> Eff es FilePath
-callQBE f = do
-  let asm_file = f -<.> "s"
-      qbe_file = f -<.> "ssa"
-  C.StdoutUntrimmed stdout <-
-    C.run $ C.cmd "qbe" & C.addArgs [qbe_file]
-  FS.withFile asm_file FS.WriteMode \h -> do
-    hPutStr h stdout
-  hPutStrLn FS.stderr $ "wrote " <> T.pack asm_file
-  pure asm_file
-
-callGCC
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
-  => FilePath -> List String -> Eff es FilePath
-callGCC f args = do
-  let asm_file = f -<.> "s"
-      exe = dropExtension f
-  C.StdoutTrimmed (T.words -> flags) <-
-    C.run $ C.cmd "pkg-config"
-          & C.addArgs @String ["--cflags", "--libs", "bdw-gc"]
-  C.run_ $ C.cmd "cc"
-         & C.addArgs flags
-         & C.addArgs ["-o", exe, asm_file]
-         & C.addArgs args
-  hPutStrLn FS.stderr $ "wrote " <> T.pack exe
-  pure exe
-
-driver
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
-  => Options -> Eff es ()
-driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
-  exps <- readScm f
-  anfs <- toANF f exps
-  qbe <- toQBE f anfs
-  callQBE f
-  callGCC f ["../runtime/target/debug/libgyehoek.a"]
-  pure ()
+main = Gyehoek.Driver.main

cabal.project

@@ -1,4 +1,5 @@
 packages: *.cabal
+tests: True
 
 source-repository-package
     type: git

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

example/ascii-string-literal.anf

@@ -1,4 +0,0 @@
-;;; -*- mode:scheme -*-
-
-(let ((x0 (prim:write "wawa"))) x0)
-

example/ascii-string-literal.s

@@ -1,23 +0,0 @@
-.data
-.balign 8
-.1:
-	.ascii "wawa"
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $4, %esi
-	leaq .1(%rip), %rdi
-	callq scm_from_utf8_string
-	movq %rax, %rdi
-	callq scm_write
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

example/ascii-string-literal.scm

@@ -1 +0,0 @@
-(prim:write "wawa")

example/ascii-string-literal.ssa

@@ -1,10 +0,0 @@
-
-data $.1 =
-{b "wawa"}
-export
-function w $main () {
-@start
-    %.2 =l call $scm_from_utf8_string (l $.1, l 4)
-    %x0 =l call $scm_write (l %.2)
-    ret %x0
-}

example/cons.anf

@@ -1,4 +0,0 @@
-;;; -*- mode:scheme -*-
-
-(let ((x0 (prim:cons 4 5)) (x1 (prim:write x0))) x1)
-

example/cons.s

@@ -1,18 +0,0 @@
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $16, %edi
-	callq GC_malloc
-	movq %rax, %rdi
-	movq $18, (%rdi)
-	movq $22, 8(%rdi)
-	callq scm_write
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

example/cons.scm

@@ -1 +0,0 @@
-(prim:write (prim:cons 4 5))

example/cons.ssa

@@ -1,10 +0,0 @@
-export
-function w $main () {
-@start
-    %x0 =l call $GC_malloc (l 16)
-    %.2 =l add %x0, 8
-    storel 18, %x0
-    storel 22, %.2
-    %x1 =l call $scm_write (l %x0)
-    ret %x1
-}

example/pseudo/closure.scm

@@ -1,15 +0,0 @@
-(define (adder x)
-  (lambda (y)
-    (+ x y)))
-
-((adder 3) 4)
-
-
-
-(define (adder x)
-  (list (lambda (self y)
-          (+ (nth self 1) y))
-        x))
-
-(let ((closure (adder 3)))
-  ((nth closure 0) closure 4))

example/pseudo/t.s

@@ -1,70 +0,0 @@
-.text
-zerop:
-	pushq %rbp
-	movq %rsp, %rbp
-	cmpl $0, %edi
-	jnz .Lbb2
-	movl $1, %eax
-	jmp .Lbb3
-.Lbb2:
-	movl $0, %eax
-.Lbb3:
-	leave
-	ret
-.type zerop, @function
-.size zerop, .-zerop
-/* end function zerop */
-
-.text
-factorial:
-	pushq %rbp
-	movq %rsp, %rbp
-	subq $8, %rsp
-	pushq %rbx
-	movq %rdi, %rbx
-	callq zerop
-	movq %rbx, %rdi
-	cmpl $0, %eax
-	jnz .Lbb6
-	movq %rdi, %rbx
-	subq $1, %rdi
-	callq factorial
-	movq %rbx, %rdi
-	imulq %rdi, %rax
-	jmp .Lbb7
-.Lbb6:
-	movl $1, %eax
-.Lbb7:
-	popq %rbx
-	leave
-	ret
-.type factorial, @function
-.size factorial, .-factorial
-/* end function factorial */
-
-.data
-.balign 8
-fstr:
-	.ascii "fac 3 = %d\n"
-	.byte 0
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $3, %edi
-	callq factorial
-	movq %rax, %rsi
-	leaq fstr(%rip), %rdi
-	movl $0, %eax
-	callq printf
-	movl $0, %eax
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

example/pseudo/t.scm

@@ -1,16 +0,0 @@
-(define (factorial n)
-  (if (zero? n)
-      1
-      (* n (factorial (- n 1)))))
-
-
-;;; ANF
-
-(define (factorial n)
-  (let ((r₁ (zero? n)))
-    (if r₁
-        1
-        (let ((r₂ (- n 1))
-              (r₃ (factorial r₂))
-              (r₄ (* n r₃)))
-          r₄))))

example/pseudo/t.ssa

@@ -1,30 +0,0 @@
-function l $zerop (l %n) {
-@start
-	jnz %n, @b1, @b2
-@b1
-	ret 0
-@b2
-	ret 1
-}
-
-function l $factorial (l %n) {
-@start
-	%r1 =l call $zerop (l %n)
-	jnz %r1, @b1, @b2
-@b1
-	ret 1
-@b2
-	%r2 =l sub %n, 1
-	%r3 =l call $factorial (l %r2)
-	%r4 =l mul %n, %r3
-	ret %r4
-}
-
-data $fstr = { b "fac 3 = %d\n", b 0 }
-
-export function w $main () {
-@start
-	%r =l call $factorial (l 3)
-	call $printf (l $fstr, ..., l %r)
-	ret 0
-}

example/string-literal.anf

@@ -1,4 +0,0 @@
-;;; -*- mode:scheme -*-
-
-(let ((x0 (prim:write "안녕하세요"))) x0)
-

example/string-literal.s

@@ -1,23 +0,0 @@
-.data
-.balign 8
-.1:
-	.ascii "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $15, %esi
-	leaq .1(%rip), %rdi
-	callq scm_from_utf8_string
-	movq %rax, %rdi
-	callq scm_write
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

example/string-literal.scm

@@ -1 +0,0 @@
-(prim:write "안녕하세요")

example/string-literal.ssa

@@ -1,10 +0,0 @@
-
-data $.1 =
-{b "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"}
-export
-function w $main () {
-@start
-    %.2 =l call $scm_from_utf8_string (l $.1, l 15)
-    %x0 =l call $scm_write (l %.2)
-    ret %x0
-}

flake.nix

@@ -16,35 +16,46 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
+
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
-            bdwgc;
+          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.gyehoek-wasmtime-wrapper
+                    pkgs.git
+                  ];
+                in ''
+                  # Wasmtime requires a cache in $HOME. This is less
+                  # painful than reconfiguring the cache location.
+                  export HOME=$(mktemp -d)
+                  export PATH=${lib.makeBinPath bin}:$PATH
+                '';
+            })];
             shell = {
               withHoogle = true;
-              inputsFrom = [
-                self.packages.${final.stdenv.hostPlatform.system}.runtime
-              ];
+              inputsFrom = [];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
               };
               buildInputs = with final; [
-                gcc
-                qbe
                 haskellPackages.cabal-fmt
-                bdwgc
-                pkg-config
-                guile
-                clang-tools # clangd
-                gdb
-                gdbgui
+                self.packages.${final.stdenv.hostPlatform.system}.shake
+                final.wabt
+                final.nodejs
+                final.wasm-tools
+                final.wac-cli
+                final.guile
+                final.gyehoek-wasmtime-wrapper
               ];
             };
           };
@@ -72,15 +83,18 @@
       _pkgs = each-system ({ pkgs, ... }: pkgs);
       _hf = hf;
 
-      packages = each-system ({ pkgs, system, ... }:
-        hf.packages.${system} // {
-          default = hf.packages.${system}."gyehoek:exe:gyehoek";
-          runtime = pkgs.callPackage ./runtime {};
-          inherit (pkgs) bdwgc;
-        });
+      packages = each-system ({ pkgs, lib, system, ... }:
+        hf.packages.${system} // lib.fix (packages: {
+          gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
+          default = packages.gyehoek;
+          shake = pkgs.callPackage ./shake-wrapper.nix {};
+        }));
 
       devShells = each-system
         ({ pkgs, system, ... }: hf.devShells.${system});
+
+      checks = each-system
+        ({ pkgs, system, ... }: hf.checks.${system});
     };
 
   nixConfig = {

golden/arith/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 22
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/arith/out.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)))

golden/arith/source.scm

@@ -0,0 +1 @@
+(+ (* 3 4) (* 2 5))

golden/if-false/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 555
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/if-false/out.wat

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

golden/if-false/source.scm

@@ -0,0 +1 @@
+(if #false 777 555)

golden/if-true/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 777
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/if-true/out.wat

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

golden/if-true/source.scm

@@ -0,0 +1 @@
+(if #true 777 555)

golden/lambda/source.scm

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

golden/square/source.scm

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

gyehoek.cabal

@@ -20,38 +20,55 @@ common ghcstuffs-dev
 common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
-    -threaded
+    -fdefer-out-of-scope-variables -threaded
 
   default-extensions:
     BlockArguments
     DeriveGeneric
+    OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms
+    QuasiQuotes
 
 executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
 
-  -- cabal-fmt: expand app -Main
-  other-modules:
-    Gyehoek.ANF.Syntax
+  build-depends:
+    , base                  ^>=4.21.2.0
+    , gyehoek
+
+  hs-source-dirs:   app
+  default-language: GHC2024
+
+library
+  import:           ghcstuffs, ghcstuffs-dev
+  ghc-options: -fplugin=Effectful.Plugin
+
+  -- cabal-fmt: expand src
+  exposed-modules:
+    Gyehoek.CPS.Convert
+    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Syntax
     Gyehoek.GenSym
     Gyehoek.Options
-    Gyehoek.QBE
-    Gyehoek.QBE.Parse
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Wasm
+    Gyehoek.Driver
 
   build-depends:
     , base                  ^>=4.21.2.0
+    , binary
     , containers
+    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
     , filepath
     , generic-lens
+    , hashable
     , invertible-grammar
     , lens
     , megaparsec
@@ -59,15 +76,28 @@ executable gyehoek
     , optparse-applicative
     , prettyprinter
     , process
-    , qbe
     , recursion-schemes
     , sexp-grammar
     , template-haskell
     , text
+    , text-short
     , unordered-containers
     , vector
-    , text-short
-    , cradle
+    , string-interpolate
+    , pretty-simple
 
-  hs-source-dirs:   app
+  hs-source-dirs:   src
   default-language: GHC2024
+
+test-suite test
+    import:           ghcstuffs, ghcstuffs-dev
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:    base
+                    , gyehoek
+                    , filepath
+                    , tasty
+                    , tasty-silver
+                    , directory
+    default-language: GHC2024

index.html

@@ -0,0 +1,20 @@
+<html>
+  <head>
+    <script>
+      const imports = {
+          guppy: {
+              print: (arg) => console.log (arg)
+          }
+      }
+
+      fetch("u.wasm")
+    .then((response) => response.arrayBuffer())
+    .then((bytes) => WebAssembly.instantiate(bytes, imports))
+    .then((results) => {
+        results.instance.exports.main ();
+    });
+    </script>
+  </head>
+  <body>
+  </body>
+</html>

play/a.c

@@ -1,21 +0,0 @@
-#include <stdio.h>
-#include <libguile/scm.h>
-
-#if (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2)
-# define SCM_SRS(x, y)  ((x) >> (y))
-#else
-# define SCM_SRS(x, y)                                   \
-  ((x) < 0                                               \
-   ? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y))  \
-   : ((x) >> (y)))
-#endif
-
-int main () {
-  unsigned long mask = 0xfffffffffffffffe;
-  unsigned long x = (4 << 2) + 2;
-  unsigned long y = (2 << 2) + 2;
-  unsigned long z = ((x + y) >> 2) + 2;
-  printf ("BLAH: %d\n", BLAH);
-  printf ("%ld\n", sizeof(long));
-  printf ("%lx\n", (long) z >> 2);
-}

play/hash.c

@@ -1,48 +0,0 @@
-#include <stdio.h>
-#include <string.h>
-#include "../runtime/gyehoek.h"
-#include "../runtime/weak-set.h"
-
-static int
-symbol_lookup_predicate_fn (SCM sym1, void *closure) {
-  const SCM sym2 = *((SCM*)closure);
-  const int symp1 = SCM_SYMBOLP (sym1);
-  const int symp2 = SCM_SYMBOLP (sym2);
-  // both symbols?
-  if (SCM_SYMBOLP (sym1) && SCM_SYMBOLP (sym2)) {
-    const SCM str1 = SCM_CELL_OBJECT (sym1, 2);
-    const SCM str2 = SCM_CELL_OBJECT (sym2, 2);
-    const size_t len1 = scm_c_string_length (str1);
-    const size_t len2 = scm_c_string_length (str2);
-    // same length?
-    if (len1 == len2) {
-      // same name?
-      const char * const s1 = scm_c_string_chars (str1);
-      const char * const s2 = scm_c_string_chars (str2);
-      return strncmp (s1, s2, len1);
-    }
-  }
-  return 0;
-}
-
-SCM test (SCM set, const char *sym_name, SCM value) {
-  SCM str = scm_from_cstring (sym_name);
-  SCM sym = scm_make_symbol (str, scm_c_hash (str));
-  SCM r = scm_c_weak_set_insert (set, scm_c_hash (str), value,
-                                 symbol_lookup_predicate_fn,
-                                 &sym);
-  printf ("%ld\n", weak_set_count (set));
-  return r;
-}
-
-int main () {
-  /* const char s[] = "wormy"; */
-  /* const SCM str = scm_from_utf8_string (s, sizeof(s)); */
-  /* const unsigned long hash = scm_c_hash (str); */
-  /* printf ("%ld\n", hash); */
-
-  SCM set = scm_c_make_weak_set (31);
-  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
-  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
-  test (set, "my-symbol2", SCM_PACK (SCM_MAKE_SMALL_INT (456)));
-}

play/string.anf

@@ -1,4 +0,0 @@
-;;; -*- mode:scheme -*-
-
-(let ((x0 (prim:write "abc"))) x0)
-

play/string.s

@@ -1,23 +0,0 @@
-.data
-.balign 8
-.1:
-	.ascii "abc"
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $3, %esi
-	leaq .1(%rip), %rdi
-	callq scm_from_utf8_string
-	movq %rax, %rdi
-	callq scm_write
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

play/string.scm

@@ -1 +0,0 @@
-(prim:write "abc")

play/string.ssa

@@ -1,10 +0,0 @@
-
-data $.1 =
-{b "abc"}
-export
-function w $main () {
-@start
-    %.2 =l call $scm_from_utf8_string (l $.1, l 3)
-    %x0 =l call $scm_write (l %.2)
-    ret %x0
-}

play/t.anf

@@ -1,4 +0,0 @@
-;;; -*- mode:scheme -*-
-
-(let ((x0 (prim:cons 4 2)) (x1 (prim:write x0))) x1)
-

play/t.s

@@ -1,18 +0,0 @@
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	movl $16, %edi
-	callq GC_malloc
-	movq %rax, %rdi
-	movq $18, (%rdi)
-	movq $10, 8(%rdi)
-	callq scm_write
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

play/t.scm

@@ -1 +0,0 @@
-(prim:write (prim:cons 4 2))

play/t.ssa

@@ -1,10 +0,0 @@
-export
-function w $main () {
-@start
-    %x0 =l call $GC_malloc (l 16)
-    %.2 =l add %x0, 8
-    storel 18, %x0
-    storel 10, %.2
-    %x1 =l call $scm_write (l %x0)
-    ret %x1
-}

play/wtf.s

@@ -1,31 +0,0 @@
-.data
-.balign 8
-fstr:
-	.ascii "%s"
-	.byte 0
-/* end data */
-
-.data
-.balign 8
-str:
-	.ascii "안녕하세요"
-	.byte 0
-/* end data */
-
-.text
-.globl main
-main:
-	pushq %rbp
-	movq %rsp, %rbp
-	leaq str(%rip), %rsi
-	leaq fstr(%rip), %rdi
-	movl $0, %eax
-	callq printf
-	movl $0, %eax
-	leave
-	ret
-.type main, @function
-.size main, .-main
-/* end function main */
-
-.section .note.GNU-stack,"",@progbits

play/wtf.ssa

@@ -1,8 +0,0 @@
-data $fstr = { b "%s", b 0 }
-data $str = { b "안녕하세요", b 0 }
-
-export function w $main () {
-@start
-	call $printf (l $fstr, ..., l $str)
-	ret 0
-}

repl

@@ -0,0 +1,2 @@
+#!/usr/bin/env sh
+cabal repl --repl-options "-interactive-print=Text.Pretty.Simple.pPrint" --build-depends pretty-simple

runtime/.envrc

@@ -1 +0,0 @@
-use flake

runtime/.gitignore

@@ -1 +0,0 @@
-target

runtime/Cargo.lock

@@ -1,56 +0,0 @@
-# This file is automatically @generated by Cargo.
-# It is not intended for manual editing.
-version = 4
-
-[[package]]
-name = "bdwgc-alloc"
-version = "0.6.13"
-source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
-dependencies = [
- "cmake",
- "libc",
-]
-
-[[package]]
-name = "cc"
-version = "1.2.62"
-source = "registry+https://github.com/rust-lang/crates.io-index"
-checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
-dependencies = [
- "find-msvc-tools",
- "shlex",
-]
-
-[[package]]
-name = "cmake"
-version = "0.1.58"
-source = "registry+https://github.com/rust-lang/crates.io-index"
-checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
-dependencies = [
- "cc",
-]
-
-[[package]]
-name = "find-msvc-tools"
-version = "0.1.9"
-source = "registry+https://github.com/rust-lang/crates.io-index"
-checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
-
-[[package]]
-name = "gyehoek"
-version = "0.1.0"
-dependencies = [
- "bdwgc-alloc",
-]
-
-[[package]]
-name = "libc"
-version = "0.2.186"
-source = "registry+https://github.com/rust-lang/crates.io-index"
-checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
-
-[[package]]
-name = "shlex"
-version = "1.3.0"
-source = "registry+https://github.com/rust-lang/crates.io-index"
-checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"

runtime/Cargo.toml

@@ -1,17 +0,0 @@
-[package]
-name = "gyehoek"
-version = "0.1.0"
-edition = "2024"
-
-[lib]
-name = "gyehoek"
-# crate-type = ["cdylib"]
-crate-type = ["staticlib"]
-
-[dependencies]
-bdwgc-alloc = { version = "0.6.13"
-              , default-features = false
-              , features = ["cmake"] }
-
-[patch.crates-io]
-bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }

runtime/default.nix

@@ -1,24 +0,0 @@
-{ lib
-, rustPlatform
-, bdwgc
-, cmake
-, pkg-config
-}:
-
-rustPlatform.buildRustPackage (finalAttrs: {
-  pname = "gyehoek-runtime";
-  version = "0.0.1";
-  src = ./.;
-  cargoLock = {
-    lockFile = ./Cargo.lock;
-    outputHashes."bdwgc-alloc-0.6.13" =
-      "sha256-8/EZ9FThVVsdkwB+OIlNHQJxIr6DPf701Mlfq5U1j4E=";
-  };
-  nativeBuildInputs = [
-    pkg-config
-    cmake
-  ];
-  buildInputs = [
-    bdwgc
-  ];
-})

runtime/src/lib.rs

@@ -1,109 +0,0 @@
-use std::{io::{stdout, Write}};
-
-const scm_tc3_cons: u64 = 0;
-const scm_tc2_int: u64 = 2;
-
-
-type scm_bits = u64;
-
-#[repr(C)]
-#[derive(Clone, Copy)]
-struct SCM {
-    n : scm_bits
-}
-
-fn scm_pack (bits : scm_bits) -> SCM {
-    SCM {n: bits}
-}
-
-fn scm_unpack (x : SCM) -> scm_bits {
-    x.n
-}
-
-fn scm_unpack_pointer (x : SCM) -> *mut scm_bits {
-    x.n as *mut scm_bits
-}
-
-fn scm_pack_pointer (x : *const scm_bits) -> SCM {
-    SCM {n: x as scm_bits}
-}
-
-
-
-fn scm_cell_object (x: SCM, n: usize) -> SCM {
-    let p = scm_unpack_pointer (x) as *mut SCM;
-    unsafe {
-        *(p.wrapping_add (n))
-    }
-}
-
-fn scm_cell_word (x: SCM, n: usize) -> scm_bits {
-    scm_unpack (scm_cell_object (x, n))
-}
-
-fn is_immediate (x: SCM) -> bool {
-    6 & scm_unpack (x) != 0
-}
-
-fn scm_cell_type (x: SCM) -> scm_bits {
-    scm_cell_word (x, 0)
-}
-
-fn is_cons (x: SCM) -> bool {
-    ! is_immediate (x) && (1 & scm_cell_type (x)) == 0
-}
-
-fn is_small_int (x: SCM) -> bool {
-    3 & scm_unpack (x) == scm_tc2_int
-}
-
-fn get_small_int (x: SCM) -> scm_bits {
-    scm_unpack (x) >> 2
-}
-
-fn scm_car (x: SCM) -> SCM {
-    scm_cell_object (x, 0)
-}
-
-fn scm_cdr (x: SCM) -> SCM {
-    scm_cell_object (x, 1)
-}
-
-#[unsafe(no_mangle)]
-pub extern "C" fn scm_write (x: SCM) -> SCM {
-    if is_small_int (x) {
-        print! ("{:?}", get_small_int (x));
-    } else if is_cons (x) {
-        print! ("(");
-        scm_write (scm_car (x));
-        print! (" . ");
-        scm_write (scm_cdr (x));
-        print! (")");
-    } else {
-        let ty = if is_immediate (x) { "immediate" } else { "heap object" };
-        print! ("#<{ty} {:#016x}>", scm_unpack (x));
-    }
-    stdout ().flush ();
-    return scm_pack (0);
-}
-
-#[unsafe(no_mangle)]
-pub extern "C" fn scm_from_utf8_string (s: scm_bits, len: scm_bits) -> scm_bits {
-    println! ("scm_from_utf8_string");
-    return 0;
-}
-
-pub fn add (left: u64, right: u64) -> u64 {
-    left + right
-}
-
-#[cfg(test)]
-mod tests {
-    use super::*;
-
-    #[test]
-    fn it_works () {
-        let result = add (2, 2);
-        assert_eq! (result, 4);
-    }
-}

shake-wrapper.nix

@@ -0,0 +1,14 @@
+{ runCommandLocal, makeWrapper, lib, haskellPackages }:
+
+let
+  our-ghc = haskellPackages.ghc.withPackages (ps: [
+    ps.shake
+  ]);
+in runCommandLocal
+  "shake-wrapper"
+  { nativeBuildInputs = [ makeWrapper ]; }
+  ''
+    mkdir -p $out/bin
+    makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
+      --prefix PATH : ${lib.makeBinPath [our-ghc]}
+  ''

src/Gyehoek/CPS/Convert.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Convert
+  ( convert
+  , convertProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Scheme.Syntax qualified as Scm
+import Gyehoek.GenSym
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Effectful
+import Control.Monad.Cont qualified as Cont
+import Control.Lens
+import qualified Data.List.NonEmpty as NE
+
+
+-- 뻘짓이어라
+telescope
+  :: Traversable t
+  => (a -> (b -> r) -> r)
+  -> t a -> (t b -> r) -> r
+telescope f = Cont.runCont . traverse (Cont.cont . f)
+
+convert
+  :: forall es. (GenSym :> es)
+  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+
+convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpLit l) k = k $ ValLit l
+
+convert (Scm.ExpPrim p) k =
+  telescope (convert @es) p \p' -> do
+    r <- gensym' "r"
+    ExpPrim p' [r] <$> k (ValVar r)
+
+convert (Scm.ExpLambda xs e) k = do
+  f <- gensym' "λ-body"
+  ktail <- gensym' "λ-tail"
+  m <- convert e $ \e' ->
+    pure $ ExpContinue ktail [e']
+  ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f)
+
+convert (Scm.ExpApply f xs) k =
+  telescope (convert @es) (f:|xs) \(f':|xs') -> do
+    r <- gensym' "r"
+    x <- gensym' "x"
+    m <- k (ValVar x)
+    pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
+
+convert (Scm.ExpBegin xs) k = _
+
+convert (Scm.ExpIf c t f) k =
+  convert c \c' ->
+    ExpIf c' <$> convert t k <*> convert f k
+
+convert _ k = _
+
+convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
+convertProgram p =
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
+    pure . Halt1 $ case NE.nonEmpty exps of
+      Nothing -> ValLit Void
+      Just es -> NE.last es

src/Gyehoek/CPS/Lower.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+module Gyehoek.CPS.Lower
+  (lower, lowerProgram) where
+
+import Gyehoek.CPS.Syntax
+import Data.Generics.Labels
+import Gyehoek.Scheme.Syntax qualified as Scm
+import Gyehoek.GenSym
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Effectful
+import Control.Monad.Cont qualified as Cont
+import Effectful.Writer.Static.Local
+import Data.Text (Text)
+import Data.Vector.Strict (Vector)
+import Control.Lens
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Numeric.Natural
+import GHC.Generics (Generic)
+import Gyehoek.Scheme.Syntax (Lit(..))
+import Text.Printf
+import qualified Data.Text as T
+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 hiding (Expr)
+import Language.Sexp.Located (pattern ParenList)
+import Debug.Pretty.Simple
+import Control.Monad.Fix
+
+
+data Env = MkEnv
+  { runtime :: Runtime
+  , vars :: Vector Name
+  , kvars :: Vector Name
+  }
+  deriving (Show, Generic)
+
+type instance Index Env = Natural
+type instance IxValue Env = Name
+
+instance Ixed Env where
+  ix i = #vars . ix (fromIntegral i)
+
+data Runtime = MkRuntime
+  { argArrayType :: Idx
+  , argArray :: Idx
+  , contType :: Idx
+  , contStackType :: Idx
+  , contStackTop :: Idx
+  , contStack :: Idx
+  , result :: Idx
+  , halt :: 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 1]
+  , ins "i32.shl" []
+  , ins "ref.i31" []
+  ]
+
+-- | 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 -> Int -> Wasm.Expr -> Wasm.Expr
+pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+  [ 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 (MkRuntime {argArrayType,argArray}) n = mconcat
+  [ ins "global.get" [sxp argArray]
+  , ins "i32.const" [sxp n]
+  , ins "array.get" [sxp argArrayType]
+  , ins "ref.as_non_null" []
+  ]
+
+
+
+lowerVal :: Env -> Val -> Wasm.Expr
+
+lowerVal g (ValLit l) =
+  case l of
+    LitInt n -> 
+      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 (1+l)]
+  where
+    l = V.elemIndex x g.vars ^?! _Just
+
+lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+
+lower' g (Halt [v]) = pure . mconcat $
+  [ pushArg g.runtime 0 (lowerVal g v)
+  , ins "return_call" [sxp @Int 1]
+  ]
+
+lower' g (ExpPrim p rs e) =
+  case p of
+    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+  where
+    r = head rs
+
+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'
+
+lower' g (ExpContinue k [x]) = pure . mconcat $
+  [ pushArg rt 0 (lowerVal g x)
+  , ins "i32.const" [sxp @Int 1] -- nargs
+  -- get the return continuation.
+  , ins "global.get" [sxp rt.contStack]
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "array.get" [sxp rt.contStackType]
+  , ins "ref.as_non_null" []
+  -- decrement contStackTop, completing the "pop."
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "i32.const" [sxp @Int (1 + l)]
+  , ins "i32.sub" []
+  , ins "global.set" [sxp rt.contStackTop]
+  , ins "return_call_ref" [sxp rt.contType]
+  ]
+  where
+    rt = g.runtime
+    l = V.elemIndex k g.kvars ^?! _Just
+
+lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
+  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
+    let g' = g & #vars <>~ V.fromList xs
+               & #kvars <>~ [ktail]
+    m' <- lower' g' m
+    pure . mconcat $
+      [ xs & ifoldMap \n _ ->
+          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
+      , m'
+      ]
+  declareFuncref idx
+  let g' = g & #vars <>~ [r]
+  let n = length g.vars
+  e' <- lower' g' e
+  pure . mconcat $
+    [ ins "ref.func" [sxp idx]
+    , ins "local.set" [sxp (n+1)]
+    , e'
+    ]
+
+lower' g e = error . show $ e
+
+lowerBinOp
+  :: (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 (1+n)]
+    , e'
+    ]
+  where
+    g' = g & #vars <>~ [r]
+    n = length (g ^. #vars)
+
+
+
+scm = ref eq
+
+
+
+emitRuntime :: GenMod :> es => Eff es Runtime
+emitRuntime = mfix \runtime -> do
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+    [ Wasm.mut i32 ]
+  -- cont stack
+  contType <- Wasm.deftype $ Wasm.func [i32] []
+  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
+  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
+  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
+    ins "i32.const" [sxp @Int 128]
+    <> ins "array.new_default" [sxp contStackType]
+  -- arg array
+  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
+  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
+    ins "i32.const" [sxp @Int 32]
+    <> ins "array.new_default" [sxp argArrayType]
+  -- consIdx <- Wasm.defun _ _ _ _
+  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
+  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    pure . mconcat $
+      [ popArg runtime 0
+      , ins "global.set" [sxp result]
+      ]
+  pure $ MkRuntime
+    {argArray,argArrayType
+    ,contStack,contStackTop,contStackType,contType
+    ,result,halt}
+  -- pure $ error "todo"
+
+lower :: Exp -> Eff es Text
+lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+  runtime <- emitRuntime
+  let g = MkEnv runtime mempty mempty
+  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    lower' g e
+  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+    pure . mconcat $
+      -- push return cont
+      [--  ins "ref.func" [sxp halt]
+      -- make call
+      ins "i32.const" [sxp @Int 0]
+      , ins "call" [sxp scm_entry]
+      , ins "global.get" [sxp runtime.result]
+      , ins "ref.as_non_null" []
+      ]
+  Wasm.export "main" "func" main
+
+lowerProgram :: Program -> Eff es Text
+lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Syntax.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.CPS.Syntax
+  ( Val(..)
+  , Kappa(..)
+  , Lambda(..)
+  , Exp(..)
+  , Name(..)
+  , Prim(..)
+  , Program(..)
+  , Lit(..)
+  , pattern Void
+  , pattern Halt
+  , pattern Halt1
+  , _MkKappa
+  , _ExpPrim
+  , _ExpFix
+  , _ExpApply
+  )
+  where
+
+import Language.SexpGrammar qualified as S
+import Gyehoek.Sexp qualified
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
+import Data.Text (Text)
+import Data.List (List)
+import GHC.Generics (Generic)
+import Language.SexpGrammar.Generic
+import Control.Category
+import Control.Lens
+import Data.Text qualified as T
+import Data.Generics.Labels
+import Prelude hiding ((.), id)
+import Data.List.NonEmpty (NonEmpty)
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import qualified Data.InvertibleGrammar as IG
+
+-- Data types
+
+data Val
+  = ValLabel Name
+  | ValVar Name
+  | ValLit Lit
+  deriving (Show, Generic)
+
+data Kappa = MkKappa (List Name) Exp
+  deriving (Show, Generic)
+
+data Lambda = MkLambda (List Name) Name Exp
+  deriving (Show, Generic)
+
+data Exp
+  = ExpPrim (Prim Val) (List Name) Exp
+  | ExpFix (NonEmpty (Name, Kappa)) Exp
+  | ExpLet (NonEmpty (Name, Lambda)) Exp
+  | ExpContinue Name (List Val)
+  | ExpIf Val Exp Exp
+  | ExpApply Val (List Val)
+  deriving (Show, Generic)
+
+pattern Halt :: List Val -> Exp
+pattern Halt xs = ExpApply (ValVar "halt") xs
+
+pattern Halt1 :: Val -> Exp
+pattern Halt1 x = ExpApply (ValVar "halt") [x]
+
+data Def = DefConstant Name Exp
+  deriving (Show, Generic)
+
+data Program = MkProgram
+  { body :: Exp
+  }
+  deriving (Show, Generic)
+
+makePrisms ''Kappa
+makePrisms ''Exp
+
+
+-- SexpIso instances
+
+instance S.SexpIso Val where
+  sexpIso = match
+    $ With (. label)
+    $ With (. var)
+    $ With (. S.sexpIso)
+    $ End
+    where
+      label = S.keyword >>> S.iso MkName getName
+      var = S.sexpIso
+
+instance S.SexpIso Lambda where
+  sexpIso = match
+    $ With (. lambda)
+    $ End
+    where
+      lambda = S.list $
+        S.el Gyehoek.Sexp.lambdaKeyword
+        >>> S.el (S.list (S.rest S.sexpIso))
+        >>> S.el S.sexpIso
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Kappa where
+  sexpIso = match
+    $ With (. kappa)
+    $ End
+    where
+      kappa = S.list $
+        S.el Gyehoek.Sexp.kappaKeyword
+        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Exp where
+  sexpIso = match
+    $ With (. prim)
+    $ With (. fix)
+    $ With (. let_)
+    $ With (. continue)
+    $ With (. if_)
+    $ With (. app)
+    $ End
+    where
+      continue = S.list $
+        S.el (S.sym "continue")
+        >>> S.el S.sexpIso
+        >>> S.rest S.sexpIso
+      fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
+      let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso S.sexpIso
+      if_ = S.list $ S.el (S.sym "if")
+        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+      app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
+      prim = S.list $
+        S.el (S.sym "prim")
+        >>> S.el (primSexpIso id (S.sexpIso @Val))
+        >>> S.el S.sexpIso
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Program where
+  sexpIso = with \prog -> S.sexpIso @Exp >>> prog

src/Gyehoek/Driver.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OrPatterns #-}
+module Gyehoek.Driver
+  (main, lower_e2e, convert_e2e, parse_e2e)
+  where
+
+import Gyehoek.Options
+import qualified Data.Text.IO as TIO
+import Data.Text (Text)
+import Prelude hiding (readFile)
+import Options.Applicative
+import Control.Lens
+import Data.Generics.Labels
+import System.OsPath (OsPath)
+import System.FilePath ((-<.>), dropExtension)
+import Effectful.FileSystem
+import Effectful
+import Effectful.FileSystem.IO qualified as FS
+import Effectful.FileSystem.IO.ByteString qualified as FB
+import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
+import qualified Gyehoek.Sexp as Sexp
+import Data.Text.Lens
+import Data.List (List)
+import qualified Gyehoek.Scheme.Syntax as Scm
+import Effectful.Exception
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import System.IO (Handle)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Cradle as C
+import Gyehoek.CPS.Convert
+import Gyehoek.CPS.Lower
+import Data.Foldable
+import qualified Gyehoek.Scheme.Syntax
+import Gyehoek.CPS.Syntax qualified as Cps
+import Data.Maybe (fromMaybe)
+import Control.Monad
+import Text.Pretty.Simple (pShow, pShowNoColor)
+
+
+main :: IO ()
+main = do
+  opts <- execParser $ info (helper <*> parser) fullDesc
+  runEff . runFileSystem . runGenSym . driver $ opts
+
+
+
+hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
+hPutStr h = FB.hPutStr h . T.encodeUtf8
+
+hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
+hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
+
+hGetContents :: FileSystem :> es => Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readFile :: FileSystem :> es => FilePath -> Eff es Text
+readFile f = FS.withFile f FS.ReadMode hGetContents
+
+withFile
+  :: (FileSystem :> es)
+  => FilePath -> FS.IOMode -> (Handle -> Eff es a) -> Eff es a
+withFile "-" FS.ReadMode k = k FS.stdin
+withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
+withFile f m k = FS.withFile f m k
+
+readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
+readScm f =
+  withFile f FS.ReadMode $ \h ->
+    Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h
+     >>= either error (pure . Scm.MkProgram)
+
+driver
+  :: (GenSym :> es, FileSystem :> es, IOE :> es)
+  => Options -> Eff es ()
+driver opts = do
+  scm <- readScm opts.sourceFile
+  when opts.dumpParsed do
+    hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
+  cps <- convertProgram scm
+  when opts.dumpCPS do
+    hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
+  wat <- lowerProgram cps
+  withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
+
+parse_e2e :: FilePath -> IO Scm.Program
+parse_e2e = runEff . runFileSystem . readScm
+
+convert_e2e :: FilePath -> IO Cps.Program
+convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm)
+
+lower_e2e :: FilePath -> IO Text
+lower_e2e =
+  runEff . runFileSystem . runGenSym
+  . (lowerProgram <=< convertProgram <=< readScm)

src/Gyehoek/GenSym.hs

@@ -6,7 +6,6 @@ import Numeric.Natural
 import Effectful.State.Dynamic
 import Effectful.Dispatch.Dynamic
 import Effectful
-import Language.QBE as QBE
 import Data.String (IsString(fromString))
 import Data.Text (Text)
 import qualified Data.Text.Short as ST
@@ -33,10 +32,14 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
   _ GenSym -> state \n -> (gen n, succ n)
   _ (GenSym' s) -> state \n -> (gen' s n, succ n)
 
-instance Gen (QBE.Ident s) where
-  gen = Ident . fromString . ('.':) . show
-  gen' s = Ident . (ST.fromText s <>) . fromString . show
-
 instance Gen Text where
   gen = fromString . ('x':) . show
   gen' s = (s <>) . fromString . show
+
+instance Gen Natural where
+  gen = id
+  gen' = const id
+
+instance Gen Int where
+  gen = fromIntegral
+  gen' _ = fromIntegral

src/Gyehoek/Options.hs

@@ -17,8 +17,10 @@ import GHC.Generics (Generic)
 data Options = MkOptions
   { -- dumpANF :: Maybe FilePath
   -- , dumpQBE :: Maybe FilePath
-  output :: Maybe FilePath
-  , sourceFiles :: HashSet FilePath
+  dumpCPS :: Bool
+  , dumpParsed :: Bool
+  , output :: FilePath
+  , sourceFile :: FilePath
   }
   deriving (Show, Generic)
 
@@ -38,14 +40,19 @@ data Options = MkOptions
 --     <> metavar "FILE"
 --     )
 
-parseOutput =
-  optional $ strOption
+parseOutput = strOption
     ( long "output"
     <> short 'o'
     <> metavar "FILE"
+    <> value "-"
     )
 
+parseDumpCPS = switch (long "dump-cps")
+parseDumpParsed = switch (long "dump-parsed")
+
 parser :: Parser Options
 parser = MkOptions
-  <$> parseOutput
-  <*> (HS.fromList <$> some (argument str (metavar "FILES")))
+  <$> parseDumpCPS
+  <*> parseDumpParsed
+  <*> parseOutput
+  <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -0,0 +1,266 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Gyehoek.Scheme.Syntax
+  ( Name(..)
+  , Prim(..)
+  , Lit(..)
+  , Def(..)
+  , Exp(..)
+  , Sexp(..)
+  , Program(..)
+  , CommandOrDef(..)
+  , primSexpIso
+  , pattern Void
+  , free
+  , qexp
+  , qprog
+  , subst
+  , freeVariables
+  )
+  where
+
+import Data.Text (Text)
+import Data.List (List)
+import Language.SexpGrammar
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+import Language.SexpGrammar qualified as Sexp
+import Language.Sexp.Located qualified as S
+import Language.SexpGrammar.Generic
+import GHC.Generics
+import Prelude hiding ((.), id)
+import Control.Category
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Gyehoek.Sexp qualified
+import Gyehoek.GenSym (Gen)
+import Control.Lens
+import Data.String (IsString)
+import Data.Hashable (Hashable)
+import Control.Lens.Unsound (prismSum)
+import Data.Data (Data)
+import Data.Functor.Foldable.TH (makeBaseFunctor)
+import Data.Functor.Foldable hiding (fold)
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.Foldable (fold)
+
+
+newtype Name = MkName { getName :: Text }
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving stock (Generic, Data)
+
+data Prim e
+  = PrimAdd e e
+  | PrimSub e e
+  | PrimMul e e
+  | PrimDiv e e
+  | PrimCons e e
+  | PrimCar e
+  | PrimCdr e
+  | PrimImmediateP e
+  | PrimConsP e
+  | PrimIntegerP e
+  | PrimWrite e
+  | PrimZeroP e
+  | PrimNewline
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
+
+instance Each (Prim e) (Prim e') e e'
+
+data Lit
+  = LitInt Int
+  | LitNil
+  | LitBool Bool
+  | LitString Text
+  | LitQuote Sexp
+  deriving (Show, Generic, Data)
+
+pattern Void :: Lit
+pattern Void = LitNil
+
+data Def
+  = DefConstant Name Exp
+  | DefProcedure Name (List Name) (List Exp)
+  deriving (Show, Generic, Data)
+
+data Exp
+  = ExpLet (NonEmpty (Name, Exp)) Exp
+  | ExpPrim (Prim Exp)
+  | ExpBegin (List Exp)
+  | ExpIf Exp Exp Exp
+  | ExpLit Lit
+  | ExpLambda (List Name) Exp
+  | ExpVar Name
+  | ExpApply Exp (List Exp)
+  deriving (Show, Generic, Data)
+
+data Sexp
+  = SexpCons Sexp Sexp
+  | SexpSymbol Text
+  | SexpLit Lit
+  deriving (Show, Generic, Data)
+
+data CommandOrDef
+  = Command Exp
+  | Definition Def
+  | Begin (List CommandOrDef)
+  deriving (Show, Generic, Data)
+
+data Program = MkProgram
+  { commandsAndDefs :: List CommandOrDef
+  }
+  deriving (Show, Generic, Data)
+
+instance Each Program Program (Either Exp Def) (Either Exp Def) where
+  each = #commandsAndDefs . each . go
+    where
+      inj = either Command Definition
+      toeither (Command e) = Left e
+      toeither (Definition d) = Right d
+      go :: Traversal' CommandOrDef (Either Exp Def)
+      go k (Command e) = inj <$> k (Left e)
+      go k (Definition d) = inj <$> k (Right d)
+      go k (Begin xs) = Begin <$> traverse (go k) xs
+
+makeBaseFunctor ''Exp
+
+
+
+instance SexpIso Name where
+  sexpIso = symbol >>> Sexp.partialOsi f g
+    where
+      f = Right . MkName
+      g (MkName s) = s
+
+primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
+primSexpIso namefn a = match
+    $ With (. binop "+")
+    $ With (. binop "-")
+    $ With (. binop "*")
+    $ With (. binop "/")
+    $ With (. binop "cons")
+    $ With (. unop "car")
+    $ With (. unop "cdr")
+    $ With (. unop "immediate?")
+    $ With (. unop "cons?")
+    $ With (. unop "integer?")
+    $ With (. unop "write")
+    $ With (. unop "zero?")
+    $ With (. nullop "newline")
+    $ 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
+
+instance SexpIso a => SexpIso (Prim a) where
+  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
+  sexpIso = primSexpIso id sexpIso
+
+instance SexpIso Lit where
+  sexpIso = match
+    $ With (. sexpIso)
+    $ With (. sym "nil")
+    $ With (. bool)
+    $ With (. sexpIso)
+    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ End
+    where
+      bool :: Sexp.SexpGrammar Bool
+      bool = Sexp.hashed $ Sexp.partialOsi f g
+        where
+          f (S.Symbol ("t";"true")) = Right True
+          f (S.Symbol ("f";"false")) = Right False
+          f _ = Left $ Sexp.expected "bool"
+          g True = S.Symbol "true"
+          g False = S.Symbol "false"
+
+instance SexpIso Sexp where
+  sexpIso = match
+    $ With (\cons -> cons . Gyehoek.Sexp.todo)
+    $ With (\s -> s . symbol)
+    $ With (\lit -> lit . sexpIso)
+    $ End
+
+instance SexpIso Def where
+  sexpIso = match
+    $ With (. defconst)
+    $ With (. defun)
+    $ End
+    where
+      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
+      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
+      args = list $ el sexpIso >>> rest sexpIso
+  
+instance SexpIso Exp where
+  sexpIso = match
+    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. sexpIso)
+    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
+    $ With (. if_)
+    $ With (. sexpIso)
+    $ With (. lam)
+    $ With (. sexpIso)
+    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
+    $ End
+    where
+      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
+      lam = list
+        ( el Gyehoek.Sexp.lambdaKeyword
+          >>> el (sexpIso @(List Name))
+          >>> el sexpIso )
+
+instance SexpIso CommandOrDef where
+  sexpIso = match
+    $ With (\_Command -> _Command . sexpIso)
+    $ With (\_Definition -> _Definition . sexpIso)
+    $ With (\_Begin -> _Begin . bgn)
+    $ End
+    where
+      bgn = list $ el (sym "begin") >>> rest sexpIso
+
+
+-- utilities
+
+qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
+qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
+
+free :: Exp -> HashSet Name
+free = cata \case
+  ExpVarF x -> HS.singleton x
+  ExpLetF bs e -> error "todo lol"
+  ExpLambdaF binders vs -> deleteFrom binders vs
+  e -> fold e
+
+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
+
+subst :: (Name -> Maybe Exp) -> Exp -> Exp
+subst f = \e -> cata go e mempty where
+  go (ExpVarF x) bound
+    | not (x `HS.member` bound), Just e' <- f x = e'
+    | otherwise                         = ExpVar x
+  go (ExpLetF _ _) _ = error "todo lol"
+  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
+  go e bound = embed $ fmap ($ bound) e
+
+-- | Unlawful!
+freeVariables :: Traversal Exp Exp Name Exp
+freeVariables k = \e -> cataA go e mempty where
+  go (ExpVarF x) bound
+    | not (x `HS.member` bound) = k x
+    | otherwise                 = pure $ ExpVar x
+  go (ExpLetF _ _) _ = error "todo lol"
+  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
+  go e bound = embed <$> traverse ($ bound) e

src/Gyehoek/Sexp.hs

@@ -0,0 +1,330 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE OrPatterns #-}
+module Gyehoek.Sexp
+  ( let_
+  , sexp
+  , nonempty
+  , nonEmptyGrammar
+  , encode
+  , decode
+  , parseSexps
+  , prefixSugar
+  , todo
+  , isoIso
+  , encodeWith
+  , decodeWith
+  , kappa
+  , lambda
+  , kappaKeyword
+  , lambdaKeyword
+  , encodePrettyWith
+  , encodePretty
+  , UglySexpIso(..)
+  , AsSexpIso(..)
+  , parseSexpsWithPos
+  , parseSexpWithPos
+  , parseSexp
+  , sx
+  , sxs
+  , makeSx
+  , makeSxs
+  )
+where
+
+import Data.Text (Text)
+import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+import Language.SexpGrammar qualified as Sexp
+import Language.Sexp qualified as S
+import Language.SexpGrammar.Generic
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar qualified as IG
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List.NonEmpty qualified as NE
+import Data.List (List, groupBy)
+import Data.Text.Encoding
+import Data.Either (either)
+import GHC.Generics (Generic)
+import Control.Lens
+import Data.Generics.Labels
+import System.Process
+import GHC.IO.Unsafe (unsafePerformIO)
+import qualified Data.Text.IO as TIO
+import Control.Monad (join)
+import qualified Language.Sexp.Located as SL
+import Data.Void (absurd, Void)
+import Data.Coerce (coerce)
+import qualified Data.Map
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE)
+import qualified Data.Text as T
+import qualified Control.Category
+import Data.Data (Data, Typeable, cast)
+import Language.Haskell.TH.Syntax (lift, Lift)
+
+
+sexp :: SexpIso a => Iso' a Text
+sexp = iso
+  (either error id . encode)
+  (either error id . decode)
+
+encode :: SexpIso a => a -> Either String Text
+encode = encodeWith sexpIso
+
+decode :: SexpIso a => Text -> Either String a
+decode = decodeWith sexpIso
+
+encodeWith :: SexpGrammar a -> a -> Either String Text
+encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
+
+encodePretty :: SexpIso a => a -> Either String Text
+encodePretty = encodePrettyWith sexpIso
+
+decodeWith :: SexpGrammar a -> Text -> Either String a
+decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
+
+encodePrettyWith :: SexpGrammar a -> a -> Either String Text
+encodePrettyWith g =
+  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
+
+parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
+parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
+
+parseSexp :: SexpIso a => FilePath -> Text -> Either String a
+parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
+  where marshal = join . traverseOf _Right (fromSexp sexpIso)
+
+parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
+parseSexpsWithPos g pos =
+  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (fromSexp g)
+
+parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
+parseSexpWithPos g pos =
+  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
+  where marshal = join . traverseOf _Right (fromSexp g)
+
+nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
+nonEmptyGrammar = IGB.Iso
+  (\((x:|xs) :- t) -> reverse xs :- x :- t)
+  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
+
+nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
+nonempty a =
+  list (el a >>> rest a) >>>
+    IG.flipped nonEmptyGrammar
+
+let_
+  :: Text
+  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
+  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
+  -> Grammar Position (Sexp :- t1) t2
+let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
+  where
+    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
+    bindings = nonempty binding
+    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair
+
+data DotList a = MkDotList (NonEmpty a) a
+  deriving (Show, Generic)
+
+dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
+dotlist x = list $ rest $ coproduct
+  [ x >>> _
+  ]
+
+-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
+prefixSugar
+  :: Text -> Prefix
+  -> Grammar Position (Sexp :- t') a
+  -> Grammar Position (Sexp :- t') a
+prefixSugar name prefix e = coproduct
+  -- 'something
+  [ Sexp.prefixed prefix e
+  -- (quote something)
+  , list $ el (sym name) >>> el e
+  ]
+
+todo :: Grammar p (Sexp :- t) t'
+todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
+  where
+    f _ = Left $ unexpected "todo"
+    g _ = Left $ unexpected "todo"
+
+kappa
+  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> Grammar Position (Sexp :- List a :- t1) t2
+  -> Grammar Position (Sexp :- t1) t2
+kappa name e = list $
+  el kappaKeyword
+  >>> el (list $ rest name)
+  >>> el e
+
+lambda
+  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> Grammar Position (Sexp :- List a :- t1) t2
+  -> Grammar Position (Sexp :- t1) t2
+lambda name e = list $
+  el lambdaKeyword
+  >>> el (list $ rest name)
+  >>> el e
+
+isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
+isoIso l = Sexp.iso (view l) (review l)
+
+kappaKeyword :: Grammar Position (Sexp :- t) t
+kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
+
+lambdaKeyword :: Grammar Position (Sexp :- t) t
+lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
+
+
+
+class UglySexpIso a where
+  uglySexpIso :: SexpGrammar a
+
+newtype AsSexpIso a = AsSexpIso a
+newtype AsUglySexpIso a = AsUglySexpIso a
+
+asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
+asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)
+
+instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
+  sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce
+
+instance SexpIso a => UglySexpIso (AsSexpIso a) where
+  uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)
+
+-- why not work
+-- deriving via AsSexpIso Text instance UglySexpIso Text
+
+instance UglySexpIso Text where uglySexpIso = sexpIso
+instance UglySexpIso Integer where uglySexpIso = sexpIso
+instance UglySexpIso Int where uglySexpIso = sexpIso
+instance UglySexpIso Bool where uglySexpIso = sexpIso
+instance UglySexpIso Double where uglySexpIso = sexpIso
+instance UglySexpIso () where uglySexpIso = sexpIso
+
+instance SexpIso Sexp where
+  sexpIso = Control.Category.id
+
+-- evil ass orphan instances
+deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
+deriving instance Data SL.Atom
+deriving instance Data SL.Prefix
+deriving instance Data SL.Position
+deriving instance (Data e) => Data (SL.SexpF e)
+
+
+-- Quasiquoter
+
+getPos = do
+  Loc {loc_filename,loc_start} <- location
+  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
+
+makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
+makeSxs g f = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpsWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right xs -> dataToExpQ (const Nothing) (f xs)
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+toSexp :: SexpIso a => a -> Sexp
+toSexp = either error id . Sexp.toSexp sexpIso
+
+pattern Unquote x =
+  SL.Modified Hash (SL.BraceList [SL.Symbol x])
+pattern UnquoteSplicing x =
+  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
+
+_UnquoteSplicing :: Prism' Sexp.Sexp Text
+_UnquoteSplicing = prism'
+  UnquoteSplicing
+  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
+
+instance Each Sexp Sexp Sexp Sexp where
+  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
+  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
+  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
+  each _ e@(SL.Atom _; SL.Modified _ _) = pure e
+
+metaSexp :: Sexp.Sexp -> Maybe ExpQ
+metaSexp (Unquote x) =
+  Just [| toSexp $(varE (mkName (T.unpack x))) |]
+metaSexp (SL.ParenList xs)
+  | (_:_) <- xs ^.. each . _UnquoteSplicing
+  = Just [| SL.ParenList (mconcat $(listE spans)) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (UnquoteSplicing _) _ -> False
+          _ (UnquoteSplicing _) -> False
+          _ _                   -> True
+      & fmap \case
+        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
+        x -> lift x
+metaSexp _ = Nothing
+
+-- 뻘짓뻘짓뻘짓뻘짓뻘짓
+class Lift1 f where
+  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
+
+lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
+lift1 = liftLift lift
+
+instance Lift1 f => Lift (SL.Fix f) where
+  lift (SL.Fix inner) = appE [|Fix|] (lift1 inner)
+
+instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
+  liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|]
+
+instance Lift a => Lift1 (SL.LocatedBy a) where
+  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
+
+instance Lift1 List where
+  liftLift l xs = listE $ l <$> xs
+
+instance Lift1 SL.SexpF where
+  liftLift l = \case
+    SL.AtomF a -> [|SL.AtomF $(lift a)|]
+    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
+    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
+    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
+    SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|]
+
+-- deriving instance Lift a => Lift (SL.SexpF a)
+deriving instance Lift SL.Atom
+deriving instance Lift SL.Position
+deriving instance Lift SL.Prefix
+
+extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
+extQ f g a = maybe (f a) g (cast a)
+
+makeSx :: Data a => SexpGrammar a -> QuasiQuoter
+makeSx g = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+sxs = makeSxs (sexpIso @Sexp) id
+sx = makeSx (sexpIso @Sexp)

src/Gyehoek/Wasm.hs

@@ -0,0 +1,76 @@
+{- HLINT ignore "Use newtype instead of data" -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE DerivingVia #-}
+module Gyehoek.Wasm
+  ( Module
+  )
+  where
+
+import Language.SexpGrammar
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
+import Language.SexpGrammar qualified as Sexp
+import Language.SexpGrammar.Generic
+import Data.List (List)
+import GHC.Generics (Generic, Generically(..))
+import Data.Text (Text)
+import Data.String (IsString (fromString))
+import Text.Printf
+import Effectful
+import Numeric.Natural (Natural)
+import Effectful.Dispatch.Dynamic
+import Effectful.State.Dynamic
+import Control.Lens
+import Data.Generics.Labels
+import Data.Vector (Vector)
+import Data.String.Interpolate
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import Effectful.Writer.Dynamic
+import Control.Applicative (Alternative((<|>)))
+import Control.Category qualified as Cat
+import Data.Vector.Lens
+import Data.Either (fromLeft, fromRight)
+import Language.Sexp.Located
+import qualified Gyehoek.Sexp
+import GHC.IsList (IsList(..))
+import Data.Coerce (coerce)
+import qualified Control.Category
+import Data.Functor (void)
+
+
+newtype Module = MkModule { inner :: Vector Sexp }
+  deriving (Show, Generic)
+  deriving newtype (Semigroup, Monoid)
+
+newtype Expr = MkExpr { inner :: Vector Sexp }
+  deriving (Show, Generic)
+  deriving newtype (Semigroup, Monoid)
+
+newtype Idx = MkIdx { inner :: Natural }
+  deriving (Generic)
+  deriving newtype (Show)
+
+
+-- GenMod
+
+-- | 'GenModState' is a 'Module' paired with the numbers of functions,
+-- types, globals, etc. defined in the module.
+data GenModState = MkGenModState
+  { mod :: Module
+  , funcs :: Natural
+  , types :: Natural
+  }
+  deriving (Show, Generic)
+
+data GenMod :: Effect where
+  DefineFunction :: Sexp -> GenMod m Idx
+  DefineType :: Sexp -> GenMod m Idx

t.js

@@ -0,0 +1,18 @@
+const imports = {
+    guppy: {
+        print: (arg) => console.log (arg)
+    }
+}
+
+// Assume add.wasm file exists that contains a single function adding 2 provided arguments
+const fs = require('node:fs');
+
+// Use the readFileSync function to read the contents of the "add.wasm" file
+const wasmBuffer = fs.readFileSync('u.wasm');
+
+// Use the WebAssembly.instantiate method to instantiate the WebAssembly module
+WebAssembly.instantiate(wasmBuffer, imports).then(wasmModule => {
+    // Exported function lives under instance.exports object
+    const { main } = wasmModule.instance.exports;
+    main ()
+});

t.wat

@@ -0,0 +1,69 @@
+(module
+ (type $heap-object (sub (struct (field (mut i32)))))
+ (type $open-procedure (func (param i32)))
+ (type $closure (sub $heap-object
+                     (struct (field (mut i32))
+                             (field (ref $open-procedure)))))
+ (type $cont-stack-type (array (mut (ref null $open-procedure))))
+ (type $arg-array-type (array (mut (ref null eq))))
+ (global $cont-stack-top (mut i32) (i32.const 0))
+ (global $cont-stack (ref $cont-stack-type)
+         (i32.const 128)
+         (array.new_default $cont-stack-type))
+ (global $arg-array (ref $arg-array-type)
+         (i32.const 32)
+         (array.new_default $arg-array-type))
+ (global (mut (ref null eq)) (ref.null eq))
+ (elem declare funcref (ref.func 1))
+ (func
+  (param i32)
+  (result)
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get 2)
+  (i32.const 0)
+  (array.get 3)
+  ref.as_non_null
+  (global.set 3))
+ (func
+  (param i32)
+  (result)
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get 2)
+  (i32.const 0)
+  (array.get 3)
+  ref.as_non_null
+  (local.set 1)
+  (global.get 2)
+  (i32.const 0)
+  (local.get 1)
+  (array.set 3)
+  (i32.const 1)
+  (global.get 1)
+  (global.get 0)
+  (array.get 2)
+  ref.as_non_null
+  (global.get 0)
+  (i32.const 1)
+  i32.sub
+  (global.set 0)
+  (return_call_ref 1))
+ (func
+  (param i32)
+  (result)
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (ref.func 1)
+  (local.set 1)
+  (global.get 2)
+  (i32.const 0)
+  (local.get 1)
+  (array.set 3)
+  (return_call 1))
+ (func
+  (param)
+  (result (ref eq))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (i32.const 0)
+  (call 1)
+  (global.get 3)
+  ref.as_non_null)
+ (export "main" (func 3)))

t2.wat

@@ -0,0 +1,65 @@
+(module
+ (type $heap-object (sub (struct (field (mut i32)))))
+ (type $open-procedure (func (param i32)))
+ (type $closure (sub $heap-object
+                     (struct (field (mut i32))
+                             (field (ref $open-procedure)))))
+ (type $cont-stack-type (array (mut (ref null $open-procedure))))
+ (type $arg-array-type (array (mut eqref)))
+ (type (func (result (ref eq))))
+ (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 $arg-array (ref $arg-array-type)
+         (array.new_default $arg-array-type (i32.const 32)))
+ (global (mut eqref) (ref.null eq))
+ (elem declare funcref (ref.func 1))
+ (func $halt (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (global.set 3
+                   (ref.as_non_null
+                    (array.get $arg-array-type
+                               (global.get $arg-array)
+                               (i32.const 0)))))
+ (func $f1 (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       ;; pop arg 0
+       (local.set
+        1
+        (ref.as_non_null
+         (array.get $arg-array-type
+                    (global.get $arg-array)
+                    (i32.const 0))))
+       ;; push arg 0
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       ;; pop continuation
+       (return_call_ref
+        $open-procedure
+        (i32.const 1)
+        (ref.as_non_null (array.get $cont-stack-type
+                                    (global.get $cont-stack)
+                                    (global.get $cont-stack-top)))
+        (global.set $cont-stack-top
+                    (i32.sub
+                     (global.get $cont-stack-top)
+                     (i32.const 1)))))
+ (func $f2 (type $open-procedure) (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (local.set 1
+                  (struct.new $closure
+                              (i32.const 0)
+                              (ref.func $f1)))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       (i32.const 1)
+       (return_call $f1))
+ (func $main (export "main") (result (ref eq))
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (call $f2 (i32.const 0))
+       (ref.as_non_null
+        (global.get 3))))

test/Main.hs

@@ -0,0 +1,57 @@
+module Main (main) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import Test.Tasty.Silver.Interactive (defaultMain)
+import Data.Traversable
+import Gyehoek.Driver qualified as Driver
+import System.FilePath
+import Data.List (List)
+import Data.Functor ((<&>))
+import System.Directory
+import Data.Function
+
+
+disabled :: List String
+disabled =
+  [ "square"
+  ]
+
+main :: IO ()
+main = defaultMain =<< goldenTests
+
+goldenTests :: IO TestTree
+goldenTests = do
+  all_cases <- listDirectory "golden"
+  let tests = all_cases
+            & filter (`notElem` disabled)
+            & fmap ("golden"</>)
+  pure $ testGroup "golden"
+    [ watTests tests
+    , executionTests tests
+    ]
+
+watTests :: List FilePath -> TestTree
+watTests files =
+  testGroup "wat" $ files <&> \test ->
+    let source = test </> "source.scm"
+        golden = test </> "out.wat"
+        testname = takeFileName test
+    in goldenVsAction
+      testname
+      golden
+      (Driver.lower_e2e source)
+      id
+
+executionTests :: List FilePath -> TestTree
+executionTests files =
+  testGroup "execution" $ files <&> \test ->
+    let wat = test </> "out.wat"
+        testname = takeFileName test
+        resultfile = test </> "exec"
+    in goldenVsProg
+       testname
+       resultfile
+       "wasmtime"
+       ["--invoke", "main", wat]
+       ""

u.wat

@@ -0,0 +1,78 @@
+(module
+ (func $print (import "guppy" "print") (param i32))
+ (table 2 funcref)
+ (elem (i32.const 0) $halt)
+
+ (type $cont (func (param i32)))
+ (type $cont-stack-type (array (mut (ref null $cont))))
+ (global $cont-stack (ref $cont-stack-type)
+         (array.new_default $cont-stack-type (i32.const 128)))
+ (global $cont-stack-top (mut i32) (i32.const 0))
+
+ (type $arg-array-type (array (mut (ref null eq))))
+ (global $arg-array (ref $arg-array-type)
+         (array.new_default $arg-array-type (i32.const 32)))
+
+ ;; (memory $memory i32 1)
+ ;; (global $arg-stack-base i32 (i32.const 0))
+ ;; (global $arg-stack-ptr i32 (global.get $arg-stack-base))
+ ;; (global $cont-stack-base i32 (i32.const 32))
+ ;; (global $cont-stack-ptr i32 (global.get $cont-stack-base))
+
+ (func $add (param $nargs i32)
+       (local $x (ref eq))
+       (local $y (ref eq))
+       (local $return (ref $cont))
+       (local.set $x (ref.as_non_null
+                      (array.get $arg-array-type
+                                 (global.get $arg-array)
+                                 (i32.const 0))))
+       (local.set $y (ref.as_non_null
+                      (array.get $arg-array-type
+                                 (global.get $arg-array)
+                                 (i32.const 1))))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (ref.i31
+                   (i32.add (i31.get_s (ref.cast (ref i31) (local.get $x)))
+                            (i31.get_s (ref.cast (ref i31) (local.get $y))))))
+       (return_call_ref
+        $cont
+        (i32.const 1)
+        (block (result (ref $cont))
+               (ref.as_non_null
+                (array.get $cont-stack-type
+                           (global.get $cont-stack)
+                           (global.get $cont-stack-top)))
+               (global.set $cont-stack-top
+                           (i32.sub (global.get $cont-stack-top)
+                                    (i32.const 1))))))
+ (func $halt (param $nargs i32)
+       (call $print
+             (i31.get_s
+              (ref.cast
+               (ref i31)
+               (ref.as_non_null
+                (array.get $arg-array-type
+                           (global.get $arg-array)
+                           (i32.const 0)))))))
+ (func (export "main")
+       ;; push args
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (ref.i31 (i32.const 4)))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 1)
+                  (ref.i31 (i32.const 5)))
+       ;; push return continuation
+       (array.set $cont-stack-type
+                  (global.get $cont-stack)
+                  (i32.const 0)
+                  (ref.func $halt))
+       ;; make call }:)
+       (return_call $add
+                    ;; inform $add how many arguments we called it with
+                    (i32.const 2))))

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