stupid

.dir-locals.el

@@ -1,5 +1,16 @@
-((haskell-cabal-mode
+((haskell-mode
+  . ((eval
+      . (progn (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . scheme-mode))
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("scm" . scheme-mode))))))
+ (haskell-cabal-mode
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+ (nil
+  . ((eval
+      . (progn (defun display-ansi ()
+                 (interactive)
+                 (ansi-color-apply-on-region (point-min) (point-max))))))))

.envrc

@@ -1 +1,3 @@
 use flake
+watch_file gyehoek.cabal cabal.project
+PATH_add $(dirname $(cabal list-bin gyehoek))

.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,6 @@ dist-newstyle
 .ghc.environment.*
 *.tix
 .direnv
-result
+result
+play/
+trace.html

README.md

@@ -1,3 +1,3 @@
-# gyehoek-hs (계획)
+# 계획
 
-a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/). nabbing from GHC and GNU Guile.
+a WIP compiler for R⁷RS Scheme targeting WebAssembly.

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/Options.hs

@@ -1,51 +0,0 @@
-{-# LANGUAGE NoFieldSelectors #-}
-module Gyehoek.Options
-  ( Options(..)
-  , parser
-  )
-  where
-
-import System.IO (Handle)
-import Data.HashSet (HashSet)
-import Options.Applicative
-import System.FilePath
-import qualified Data.HashSet as HS
-import Control.Lens hiding (argument)
-import GHC.Generics (Generic)
-
-
-data Options = MkOptions
-  { -- dumpANF :: Maybe FilePath
-  -- , dumpQBE :: Maybe FilePath
-  output :: Maybe FilePath
-  , sourceFiles :: HashSet FilePath
-  }
-  deriving (Show, Generic)
-
--- osPath :: ReadM _
--- osPath = eitherReader $
---   (_Left %~ show) . encodeUtf @(Either _)
-
--- parseDumpQBE =
---   optional $ strOption
---     ( long "dump-qbe"
---     <> metavar "FILE"
---     )
-
--- parseDumpANF =
---   optional $ strOption
---     ( long "dump-anf"
---     <> metavar "FILE"
---     )
-
-parseOutput =
-  optional $ strOption
-    ( long "output"
-    <> short 'o'
-    <> metavar "FILE"
-    )
-
-parser :: Parser Options
-parser = MkOptions
-  <$> parseOutput
-  <*> (HS.fromList <$> some (argument str (metavar "FILES")))

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,10 @@
 packages: *.cabal
+tests: True
+-- required for doctest-parallel
+write-ghc-environment-files: always
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+allow-older: Cabal:process 
 
 source-repository-package
     type: git

doc/abi.org

@@ -0,0 +1,218 @@
+#+title: ABI
+
+largely based on the Guile Hoot's [[https://codeberg.org/spritely/hoot/src/branch/main/design/ABI.md][ABI]].
+
+* calling convention
+
+** non-tail calls
+
+- set the global variable ~$current-closure~ to the callee's closure.
+- load arguments into globals ~$arg0~, ~$arg1~, ~$arg2~, …
+- push return continuation onto ~$cont-stack~
+
+* scratchpad
+
+#+begin_src scheme
+  ;; Scheme source
+  (define (silly f g h x)
+    (f (h x) (g x)))
+
+
+  ;; continuation-passing style
+  (define (silly f g h x ktail)
+    (h x (κ (x0)
+            (g x (κ (x1)
+                    (f x0 x1 ktail))))))
+
+  ;; with explicit stacks
+  (define (silly)
+    (define f (pop!))
+    (define g (pop!))
+    (define h (pop!))
+    (define x (pop!))
+    (define ktail (pop-cont!))
+    (push-cont! (κ (x0)
+                   (define x* (pop!))
+                   (define g* (pop!))
+                   (push-cont! (κ (x1)
+                                  (define f* (pop!))
+                                  (define x0* (pop!))
+                                  (push-cont! ktail)
+                                  (push! x0*)
+                                  (push! x1)
+                                  (call! f)))
+                   (push! x*)
+                   (call! g)))
+    (push! x)
+    (call! h))
+#+end_src
+
+** fac
+
+*** Scheme source
+
+#+begin_src scheme
+(define fac
+  (λ (n)
+    (if (zero? n)
+        1
+        (* n (fac (- n 1))))))
+
+(fac 3)
+#+end_src
+
+*** CPS
+
+#+begin_src scheme
+  (define fac
+  (λ (n ktail)
+    (zero? n (κ (x0)
+                (if x0
+                    1
+                    (- n 1
+                       (κ (x1)
+                          (fac x1
+                               (κ (x2)
+                                  (* n x2 ktail))))))))))
+
+(fac 3 halt)
+
+#+end_src
+
+*** tailified
+
+#+begin_src scheme
+(define (fac-k1)
+  (define n (pop!))
+  (define x2 (pop!))
+  (define x3 (* n x2))
+  (define ktail (pop-cont!))
+  (push! x3)
+  (call! ktail))
+
+(define (fac-k0)
+  (define x0 (pop!))
+  (define n (pop!))
+  (if x0
+      (begin (define ktail (pop-cont!))
+             (push! 1)
+             (call! ktail))
+      (begin (define x1 (- n 1))
+             (push! x1)
+             (push-cont! fac-k1)
+             (call! fac))))
+
+(define (fac)
+  (define n (pop!))
+  (push! n)
+  (push-cont! fac-k0)
+  (push! n)
+  (call! zero?))
+
+(push! 3)
+(push-cont! halt)
+(call! fac)
+#+end_src
+
+evaluation of ~(fac 0)~:
+
+#+begin_src scheme
+(push! 0)                  ; [] []
+(push-cont! halt)          ; [0] []
+(call! fac)                ; [0] [halt]
+(define n (pop!))          ; [0] [halt]
+(push! n)                  ; [] [halt]
+(push-cont! fac-k0)        ; [0] [halt]
+(push! n)                  ; [0] [halt fac-k0]
+(call! zero?)              ; [0 0] [halt fac-k0]
+#<internals of zero?>      ; [0 0] [halt fac-k0]
+(define x0 (pop!))         ; [0 #t] [halt]
+(define n (pop!))          ; [0] [halt]
+(define ktail (pop-cont!)) ; [] [halt]
+(push! 1)                  ; [] []
+(call! ktail)              ; [1] []
+#+end_src
+
+evaluation of ~(fac 3)~
+
+#+begin_src scheme
+(push! 3)                  ; [] []
+(push-cont! halt)          ; [3] []
+(call! fac)                ; [3] [halt]
+
+(define n (pop!))          ; [3] [halt]
+(push! n)                  ; [] [halt]
+(push-cont! fac-k0)        ; [3] [halt]
+(push! n)                  ; [3] [halt fac-k0]
+(call! zero?)              ; [3 3] [halt fac-k0]
+#<internals of zero?>      ; [3 3] [halt fac-k0]
+(define x0 (pop!))         ; [3 #f] [halt]
+(define n (pop!))          ; [3] [halt]
+(define x1 (- n 1))        ; [] [halt]
+(push! n)                  ; [] [halt]
+(push! x1)                 ; [3] [halt]
+(push-cont! fac-k1)        ; [3 2] [halt]
+(call! fac)                ; [3 2] [halt fac-k1]
+
+(define n (pop!))          ; [3 2] [halt fac-k1]
+(push! n)                  ; [3 ] [halt fac-k1]
+(push-cont! fac-k0)        ; [3 2] [halt fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1 fac-k0]
+(call! zero?)              ; [3 2 2] [halt fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 2] [halt fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 #f] [halt fac-k1]
+(define n (pop!))          ; [3 2] [halt fac-k1]
+(define x1 (- n 1))        ; [3] [halt fac-k1]
+(push! n)                  ; [3] [halt fac-k1]
+(push! x1)                 ; [3 2] [halt fac-k1]
+(push-cont! fac-k1)        ; [3 2 1] [halt fac-k1]
+(call! fac)                ; [3 2 1] [halt fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1 fac-k1]
+(push-cont! fac-k0)        ; [3 2 1] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2 1] [halt fac-k1 fac-k1 fac-k0]
+(call! zero?)              ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 1 1] [halt fac-k1 fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 1 #f] [halt fac-k1 fac-k1]
+(define n (pop!))          ; [3 2 1] [halt fac-k1 fac-k1]
+(define x1 (- n 1))        ; [3 2] [halt fac-k1 fac-k1]
+(push! n)                  ; [3 2] [halt fac-k1]
+(push! x1)                 ; [3 2 1] [halt fac-k1 fac-k1]
+(push-cont! fac-k1)        ; [3 2 1 0] [halt fac-k1 fac-k1]
+(call! fac)                ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(push! n)                  ; [3 2 1] [halt fac-k1 fac-k1 fac-k1]
+(push-cont! fac-k0)        ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(push! n)                  ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+(call! zero?)              ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+#<internals of zero?>      ; [3 2 1 0 0] [halt fac-k1 fac-k1 fac-k1 fac-k0]
+(define x0 (pop!))         ; [3 2 1 0 #t] [halt fac-k1 fac-k1 fac-k1]
+(define n (pop!))          ; [3 2 1 0] [halt fac-k1 fac-k1 fac-k1]
+(define ktail (pop-cont!)) ; [3 2 1] [halt fac-k1 fac-k1 fac-k1]
+(push! 1)                  ; [3 2 1 1] [halt fac-k1 fac-k1]
+(call! ktail)              ; [3 2 1 1] [halt fac-k1 fac-k1]
+
+(define n (pop!))          ; [3 2 1 1] [halt fac-k1 fac-k1]
+(define x2 (pop!))         ; [3 2 1] [halt fac-k1 fac-k1]
+(define x3 (* n x2))       ; [3 2] [halt fac-k1 fac-k1]
+(define ktail (pop-cont!)) ; [3 2] [halt fac-k1 fac-k1]
+(push! x3)                 ; [3 2] [halt fac-k1]
+(call! ktail)              ; [3 2 1] [halt fac-k1]
+
+(define n (pop!))          ; [3 2 1] [halt fac-k1]
+(define x2 (pop!))         ; [3 2] [halt fac-k1]
+(define x3 (* n x2))       ; [3] [halt fac-k1]
+(define ktail (pop-cont!)) ; [3] [halt fac-k1]
+(push! x3)                 ; [3] [halt]
+(call! ktail)              ; [3 2] [halt]
+
+(define n (pop!))          ; [3 2] [halt]
+(define x2 (pop!))         ; [3] [halt]
+(define x3 (* n x2))       ; [] [halt]
+(define ktail (pop-cont!)) ; [] [halt]
+(push! x3)                 ; [] []
+(call! ktail)              ; [6] []
+;; => (halt 6)
+#+end_src

doc/closure-conversion.org

@@ -0,0 +1,134 @@
+#+title: closure-conversion
+
+the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment.
+
+nice testable properties of closure-converted code:
+- code pointers only appear in function position
+- no function has free variables
+
+multiple ~env-ref~ calls could probably be replaced with a primitive that loads the entire environment at once, returning multiple variables.
+
+* scratchpad
+
+** example
+
+#+caption: scheme source
+#+begin_src scheme
+  (letrec ((curried-add (λ (n)
+                          (λ (m)
+                            (+ n m)))))
+    ((curried-add 3) 4))
+#+end_src
+
+#+caption: cps
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in
+                        (λ (m ktail1)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail1 x0))))))
+                (continue ktail0 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 3 k0)))
+#+end_src
+
+#+caption: closure-converted
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in-code
+                        (λ (env m ktail1)
+                          (prim (env-ref 0 env)
+                                (κ (n)
+                                   (prim (+ n m)
+                                         (κ (x0) (continue ktail1 x0))))))))
+                (prim (make-closure curried-add-in-code n)
+                      (κ (curried-add-in)
+                         (continue ktail0 curried-add-in)))))))
+    (letrec ((k0 (κ (adder-closure)
+                    (prim (closure-code adder-closure)
+                          (κ (adder)
+                             (adder adder-closure 4 halt))))))
+      (curried-add 3 k0)))
+#+end_src
+
+** wasm
+
+#+begin_src scheme
+(letrec ((make-adder
+        (lambda (n)
+          (lambda (x)
+            (+ n x)))))
+((make-adder 3) 2))
+#+end_src
+
+#+begin_src scheme
+(define add-code
+  (lambda (n env)
+    (+ n (env-ref env 'x))))
+
+(define make-adder-code
+  (lambda (n)
+    (make-closure add-code ('x n))))
+
+(define make-adder (make-closure make-adder-code))
+
+(apply-closure (apply-closure make-addder 3) 2)
+#+end_src
+
+#+begin_src wat
+(module
+ (type $heap-object (sub (struct (field $hash (mut i32)))))
+ (type $closure (sub $heap-object
+                     (struct (field $hash (mut i32))
+                             (field $code (ref $cont-type)))))
+ (type $closure1 (sub $closure
+                      (struct (field $hash (mut i32))
+                              (field $code (ref $cont-type))
+                              (field $env0 (ref eq)))))
+ (global $arg0 (mut (ref null eq)) (ref.null eq))
+ (global $arg1 (mut (ref null eq)) (ref.null eq))
+ (global $arg2 (mut (ref null eq)) (ref.null eq))
+ (global $arg3 (mut (ref null eq)) (ref.null eq))
+ (global $arg4 (mut (ref null eq)) (ref.null eq))
+ (global $arg5 (mut (ref null eq)) (ref.null eq))
+ ;; ⋮
+ ;; (global $argn (mut (ref null eq)) (ref.null eq))
+
+ (global $current-closure (mut (ref null $closure)) (ref.null $closure))
+
+ (func $add-code (param $nargs i32)
+       (local $n (ref eq))
+       (local $x (ref eq))
+       (local.set $n (global.get $arg0))
+       (local.set $x (struct.get $closure1
+                                 (global.get $current-closure)
+                                 $env0))
+       (return (i32.add $n $x)))
+
+ (func $make-adder-code (param $nargs i32)
+       (local $n (ref eq))
+       (local.set $n (global.get $arg0))
+       (return (struct.new $closure1
+                           0
+                           $add-code)))
+
+ (func $main
+       (local.set $make-adder
+                  (struct.new $closure
+                              0
+                              $make-adder-code))
+       (global.set $current-closure $make-adder)
+       (global.set $arg0 (i32.const 3))
+       (local.set $f (call (struct.get $closure
+                                       $make-adder
+                                       $code)
+                           1))
+       (global.set $current-closure $f)
+       (global.set $arg0 (i32.const 2))
+       (return (call (struct.get $closure
+                                 $f
+                                 $code)
+                     1))))
+#+end_src

doc/data-model.org

@@ -0,0 +1,23 @@
+#+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
+
+| type/value | low bits |
+|------------+----------|
+| small int  |        0 |
+| ~false~      |       01 |
+| ~true~       |       11 |

doc/index.org

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

doc/make-vm-stackier.org

@@ -0,0 +1,100 @@
+* rationale?
+
+previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
+
+this worked quite well until it became time to implement ~call/cc~.
+
+we are considering making the following alterations to the VM:
+- explicitly segment the stack into frames.
+- passing procedures and return addresses on the stack.
+- new instructions:
+  + ~(tail-call /n/)~
+  + ~(call /n/)~
+  + ~(load /r/ /n/)~
+  + ~(return /n/)~
+
+* scratchpad
+
+#+begin_src scheme
+  (letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 3))
+#+end_src
+
+#+begin_src scheme
+  (λ (ktail0)
+  (letrec ((fac
+            (λ (n ktail1)
+              (zero?
+               n
+               (κ (x0)
+                  (if x0
+                      (continue ktail1 1)
+                      (- n 1
+                         (κ (x1)
+                            (fac x1
+                                 (κ (x2)
+                                    (* n x2 ktail1)))))))))))
+    (fac 3)))
+#+end_src
+
+#+begin_example
+n ktail1
+| |
+| | x0
+| | |
+| | ^
+| |
+| | x1
+| | |
+| | ^
+| | 
+| | x2
+| | |
+^ ^ ^
+#+end_example
+
+#+begin_src scheme
+  (define $fac-c0
+    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
+    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
+        ;; every variable but `ktail1' is dead so we pop them all.
+        ;; this probably means that `if' should take two continuations
+        ;; rather than two blocks.
+        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
+              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
+        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
+              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              )))
+
+  (define $fac-c1
+    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
+    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (prim %x3 (* %n %x2))
+    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $fac
+    (load %ktail1 2) ; [ n $fac ktail1 ]
+    (load %n 0) ; [ n $fac ktail1 ]
+    (push! $fac-c0) ; [ n $fac ktail1 ]
+    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
+    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
+    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $start
+    (push! $fac) ; [ $start ktail0 ]
+    (push! 3) ; [ $fac $start ktail0 ]
+    (tail-call 1) ; [ 3 $fac $start ktail0 ]
+    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
+    )
+#+end_src
+

doc/notes.org

@@ -0,0 +1,53 @@
+#+title: assorted notes on compilation
+
+* letrec
+
+consider:
+
+#+begin_src scheme
+  (letrec ((even? (lambda (n)
+                    (if (zero? n)
+                        #t
+                        (odd? (- n 1)))))
+           (odd? (lambda (n)
+                   (if (zero? n)
+                       #f
+                       (even? (- n 1))))))
+    (even? 12))
+#+end_src
+
+#+RESULTS:
+: #t
+
+since ~letrec~ is a primitive construct in the CPS language, the translation of mutually recursive functions is straightforward:
+
+#+begin_src scheme
+  (define (-& x y k) (k (- x y)))
+  (define (zero?& x k) (k (zero? x)))
+  (define (halt x) x)
+
+  (letrec ((even? (lambda (n ktail)
+                    (zero?& n
+                            (lambda (x1)
+                              (if x1
+                                  #t
+                                  (-& n 1
+                                      (lambda (x2)
+                                        (odd? x2 ktail))))))))
+           (odd? (lambda (n ktail)
+                   (zero?& n
+                           (lambda (x1)
+                             (if x1
+                                 #f
+                                 (-& n 1
+                                     (lambda (x2)
+                                       (even? x2 ktail)))))))))
+    (even? 12 halt))
+#+end_src
+
+#+RESULTS:
+: #t
+
+however, Scheme permits ~letrec~-expressions with non-lambda right-hand sides, while the CPS language permits only kappa and lambda forms. thus, the handling of these forms is less trivial.
+
+for now we'll just reject any ~letrec~ forms with non-lambda right-hand sides, lol. they aren't very important.

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.lock

@@ -66,6 +66,21 @@
         "type": "github"
       }
     },
+    "crane": {
+      "locked": {
+        "lastModified": 1784248371,
+        "narHash": "sha256-0l0Y4D4wbZhp1Oi6h8OpbLtIm/4FN88oCf54MK2ZgiM=",
+        "owner": "ipetkov",
+        "repo": "crane",
+        "rev": "f7d151ec0bf52cf9662e2f59d7bea28588c2f070",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ipetkov",
+        "repo": "crane",
+        "type": "github"
+      }
+    },
     "flake-compat": {
       "flake": false,
       "locked": {
@@ -587,6 +602,7 @@
     },
     "root": {
       "inputs": {
+        "crane": "crane",
         "haskellNix": "haskellNix",
         "nixpkgs": [
           "haskellNix",

flake.nix

@@ -7,6 +7,7 @@
       url = "git+https://git.deertopia.net/msyds/sydpkgs";
       inputs.nixpkgs.follows = "nixpkgs";
     };
+    crane.url = "github:ipetkov/crane";
   };
 
   outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
@@ -19,32 +20,49 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
-            bdwgc;
-        })
-        (final: prev: {
+          gyehoek-wasm-runtime = final.callPackage ./wasm-runtime {
+            crane-lib = inputs.crane.mkLib final;
+          };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            configureArgs = "-f-doctest";
+            modules = [({ pkgs, lib, ...}: {
+              packages.gyehoek.components.tests.test.preCheck =
+                let
+                  bin = [
+                    pkgs.git # tasty uses git diff
+                  ];
+                in ''
+                  export GYEHOEK_WASM_RUNTIME=${
+                    lib.getExe final.gyehoek-wasm-runtime
+                  }
+                  export PATH=${lib.makeBinPath bin}:$PATH
+                '';
+            })];
             shell = {
               withHoogle = true;
               inputsFrom = [
-                self.packages.${final.stdenv.hostPlatform.system}.runtime
+                final.gyehoek-wasm-runtime
               ];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
               };
               buildInputs = with final; [
-                gcc
-                qbe
                 haskellPackages.cabal-fmt
-                bdwgc
-                pkg-config
+                wabt
+                nodejs
+                wasm-tools
+                wac-cli
                 guile
-                clang-tools # clangd
-                gdb
-                gdbgui
+                rust-analyzer
+                wasmtime
+                # bashInteractive is necessary to work around an
+                # optparse-applicative issue
+                #
+                # https://github.com/pcapriotti/optparse-applicative/pull/408
+                bashInteractive
               ];
             };
           };
@@ -72,15 +90,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;
+          inherit (pkgs) gyehoek-wasm-runtime;
+        }));
 
       devShells = each-system
         ({ pkgs, system, ... }: hf.devShells.${system});
+
+      checks = each-system
+        ({ pkgs, system, ... }: hf.checks.${system});
     };
 
   nixConfig = {

golden/exec/adder/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 9

golden/exec/adder/source.scm

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

golden/exec/apply-twice/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 17

golden/exec/apply-twice/source.scm

@@ -0,0 +1,5 @@
+;; apply `f' to `x' twice.
+((λ (f x)
+   (f (f x)))
+ (λ (x) (+ x 4))
+ 9)

golden/exec/apply2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 10

golden/exec/apply2/source.scm

@@ -0,0 +1,5 @@
+((λ (f g x)
+   (f (g x)))
+ (λ (x) (+ x 4))
+ (λ (x) (* x 2))
+ 3)

golden/exec/arith/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 22

golden/exec/arith/source.scm

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

golden/exec/begin-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/exec/begin-1/source.scm

@@ -0,0 +1 @@
+(begin 123 456) ; => 456

golden/exec/callcc-constant/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 123

golden/exec/callcc-constant/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (cc) (cc 123)))

golden/exec/callcc-discard/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 1234

golden/exec/callcc-discard/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (_) 1234))

golden/exec/callcc-early-exit-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit-1/source.scm

@@ -0,0 +1,12 @@
+(letrec ((iter (λ (n f)
+                 (if (zero? n)
+                     #f
+                     (begin (f n)
+                            (iter (- n 1) f))))))
+  (call/cc
+   (λ (k)
+     (iter 10 (λ (n)
+                ;; i don't feel like implementing (= n 5) right now lmfao
+                (if (zero? (- n 5))
+                    (k #t)
+                    #f))))))

golden/exec/callcc-early-exit-2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit-2/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin (k #t)
+          #f)))

golden/exec/callcc-early-exit-3/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit-3/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-4
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app k #t))))

golden/exec/callcc-early-exit-4/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit-4/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-3
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app (λ (x) (k x)) #t))))

golden/exec/callcc-early-exit-5/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit-5/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin ((λ () (k #t)))
+          #f)))

golden/exec/callcc-early-exit-6/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 12

golden/exec/callcc-early-exit-6/source.scm

@@ -0,0 +1,4 @@
+(* 2 (call/cc
+      (λ (k)
+        (begin (k 6)
+               3))))

golden/exec/callcc-nested-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/exec/callcc-nested-1/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k1 456)))))

golden/exec/callcc-nested-2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/exec/callcc-nested-2/source.scm

@@ -0,0 +1,5 @@
+(call/cc
+ (λ (k1)
+   (call/cc
+    (λ (k2)
+      (k2 456)))))

golden/exec/complicated-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 155

golden/exec/complicated-1/source.scm

@@ -0,0 +1,10 @@
+(letrec ((factorial (λ (n)
+                      (if (zero? n)
+                          1
+                          (* n (factorial (- n 1)))))))
+  (letrec ((sum-of-factorials
+            (λ (n)
+              (if (zero? n)
+                  0
+                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
+    (+ 2 (sum-of-factorials 5))))

golden/exec/cons-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (6 . 7)

golden/exec/cons-1/source.scm

@@ -0,0 +1 @@
+(cons 6 7)

golden/exec/factorial/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 2432902008176640000

golden/exec/factorial/source.scm

@@ -0,0 +1,5 @@
+(letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 20))

golden/exec/false/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #f

golden/exec/false/source.scm

@@ -0,0 +1 @@
+#f

golden/exec/fn-of-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 128

golden/exec/fn-of-fn/source.scm

@@ -0,0 +1,3 @@
+(((λ (f) f)
+  (λ (x) (* x 4)))
+ 32)

golden/exec/if-false/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 555

golden/exec/if-false/source.scm

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

golden/exec/if-number/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 777

golden/exec/if-number/source.scm

@@ -0,0 +1 @@
+(if 123 777 555)

golden/exec/if-true/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 777

golden/exec/if-true/source.scm

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

golden/exec/lambda/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #<procedure>

golden/exec/lambda/source.scm

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

golden/exec/let-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/exec/let-fn/source.scm

@@ -0,0 +1,2 @@
+(let ((square (λ (x) (* x x))))
+  (square 4))

golden/exec/letrec-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/exec/letrec-fn/source.scm

@@ -0,0 +1,2 @@
+(letrec ((square (λ (x) (* x x))))
+  (square 4))

golden/exec/square/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 25

golden/exec/square/source.scm

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

golden/exec/true/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/true/source.scm

@@ -0,0 +1 @@
+#t

golden/print/begin-nonempty-thin

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/begin-nonempty-wide

@@ -0,0 +1,4 @@
+(begin
+  책을
+  더
+  먹으세요~!)

golden/print/lambda-thin

@@ -0,0 +1,5 @@
+(lambda
+    (어간
+     어미)
+  (display
+   꾸깃))

golden/print/lambda-wide

@@ -0,0 +1,2 @@
+(lambda (어간 어미)
+  (display 꾸깃))