fuckeverythingggg

.gitignore

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

app/Gyehoek/ANF/Syntax.hs

@@ -1,529 +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 (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/CPS/Convert.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Convert
+  ( convert
+  ) 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
+
+
+-- 뻘짓이어라
+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' "f"
+  ktail <- gensym' "ktail"
+  m <- convert e $ \e' ->
+    pure $ ExpApply (ValVar ktail) [e']
+  ExpFix [(f, MkKappa (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 _ k = _

app/Gyehoek/CPS/Lower.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+module Gyehoek.CPS.Lower
+  (
+  lower) 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(LitInt))
+import Text.Printf
+import qualified Data.Text as T
+import qualified Data.Vector.Strict as V
+import Data.IntMap.Strict (IntMap)
+
+
+data Env = MkEnv { vars :: Vector Name }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty
+
+type instance Index Env = Natural
+type instance IxValue Env = Name
+
+instance Ixed Env where
+  ix i = #vars . ix (fromIntegral i)
+
+
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show
+
+
+
+lowerVal :: Env -> Val -> Vector Text
+
+lowerVal g (ValLit l) =
+  case l of
+    LitInt n -> [ "i32.const " <> tshow n ]
+    _ -> _
+
+lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
+  where
+    i = V.elemIndex x g.vars ^?! _Just
+
+lower' :: Env -> Exp -> Vector Text
+
+lower' g (Halt [e]) = lowerVal g e
+
+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
+
+lowerBinOp op g x y r e =
+  lowerVal g x
+  <> lowerVal g y
+  <> [ op, "local.set " <> tshow n ]
+  <> lower' g' e
+  where
+    g' = g & #vars <>~ [r]
+    n = length (g ^. #vars)
+
+
+
+makeFunc :: Vector Text -> Text
+makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
+  where
+    indent = ("    "<>)
+    preamble  = "(module\n\
+                \  (func (export \"main\") (result i32)\n\
+                \    (local i32 i32 i32 i32 i32 i32)\n"
+    postamble = "  ))"
+
+lower :: Exp -> Eff es Text
+lower = pure . makeFunc . lower' emptyEnv

app/Gyehoek/CPS/Syntax.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.CPS.Syntax
+  ( Val(..)
+  , Kappa(..)
+  , Exp(..)
+  , Name(..)
+  , Prim(..)
+  , 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)
+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)
+
+-- Data types
+
+data Val
+  = ValLabel Name
+  | ValVar Name
+  | ValLit Lit
+  deriving (Show, Generic)
+
+data Kappa = MkKappa (List Name) Exp
+  deriving (Show, Generic)
+
+data Exp
+  = ExpPrim (Prim Val) (List Name) Exp
+  | ExpFix (NonEmpty (Name, Kappa)) Exp
+  | ExpApply Val (List Val)
+  | ExpIf Val Exp Exp
+  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]
+
+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 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 (. let_)
+    $ With (. app)
+    $ With (. if_)
+    $ End
+    where
+      let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
+      if_ = S.list $ 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

app/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,6 @@ 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

app/Gyehoek/Options.hs

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

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

@@ -2,21 +2,40 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Scheme.Syntax where
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Gyehoek.Scheme.Syntax
+  ( Name(..)
+  , Prim(..)
+  , Lit(..)
+  , Define(..)
+  , Exp(..)
+  , Sexp(..)
+  , primSexpIso
+  )
+  where
 
 import Data.Text (Text)
 import Data.List (List)
-import Language.SexpGrammar as Sexp hiding (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 Gyehoek.GenSym (Gen)
 import Control.Lens (Each)
+import Data.String (IsString)
+import Data.Hashable (Hashable)
 
 
-type Name = Text
+newtype Name = MkName { getName :: Text }
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving stock (Generic)
 
 data Prim e
   = PrimAdd e e
@@ -30,6 +49,8 @@ data Prim e
   | PrimConsP e
   | PrimIntegerP e
   | PrimWrite e
+  | PrimZeroP e
+  | PrimNewline
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
 instance Each (Prim e) (Prim e') e e'
@@ -39,6 +60,7 @@ data Lit
   | LitNil
   | LitBool Bool
   | LitString Text
+  | LitQuote Sexp
   deriving (Show, Generic)
 
 data Define
@@ -53,15 +75,27 @@ data Exp
   | ExpDefine Define
   | ExpIf Exp Exp Exp
   | ExpLit Lit
-  | ExpApply Exp (List Exp)
   | 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
+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 "*")
@@ -73,11 +107,18 @@ instance SexpIso a => SexpIso (Prim a) where
     $ With (. unop "cons?")
     $ With (. unop "integer?")
     $ With (. unop "write")
+    $ With (. unop "zero?")
+    $ With (. nullop "newline")
     $ End
     where
-      primname = ("prim:" <>)
-      unop s = list $ el (sym (primname s)) >>> el sexpIso
-      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
+      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
@@ -85,6 +126,14 @@ instance SexpIso Lit where
     $ 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
@@ -93,25 +142,25 @@ instance SexpIso Define where
     $ With (. defun)
     $ End
     where
-      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
+      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
       defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el symbol >>> rest symbol
+      args = list $ el sexpIso >>> rest sexpIso
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. sexpIso)
     $ With (. if_)
     $ With (. sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ With (. lam)
-    $ With (. symbol)
+    $ 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 (sym "lambda")
+        ( el Gyehoek.Sexp.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )

app/Gyehoek/Sexp.hs

@@ -10,11 +10,20 @@ module Gyehoek.Sexp
   , encode
   , decode
   , parseSexps
+  , prefixSugar
+  , todo
+  , isoIso
+  , encodeWith
+  , decodeWith
+  , kappa
+  , lambda
+  , kappaKeyword
+  , lambdaKeyword
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
+import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
@@ -33,6 +42,7 @@ 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
@@ -41,10 +51,16 @@ sexp = iso
   (either error id . decode)
 
 encode :: SexpIso a => a -> Either String Text
-encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
+encode = encodeWith sexpIso
 
 decode :: SexpIso a => Text -> Either String a
-decode = Sexp.decode . view lazy . encodeUtf8
+decode = decodeWith sexpIso
+
+encodeWith :: SexpGrammar a -> a -> Either String Text
+encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
+
+decodeWith :: SexpGrammar a -> Text -> Either String a
+decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
@@ -61,11 +77,12 @@ nonempty a =
     IG.flipped nonEmptyGrammar
 
 let_
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  :: 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_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
+let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
   where
     -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
     bindings = nonempty binding
@@ -80,11 +97,47 @@ 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 (sym "lambda")
+  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" ]

app/Gyehoek/Wasm.hs

@@ -0,0 +1,28 @@
+{- HLINT ignore "Use newtype instead of data" -}
+module Gyehoek.Wasm
+  ()
+  where
+
+import Data.List (List)
+import GHC.Generics (Generic)
+
+
+data Module = MkModule
+  { typeSection :: List Type
+  }
+  deriving (Show, Generic)
+
+data Type
+  deriving (Show, Generic)
+
+data Function = MkFunction
+  { params :: List Type
+  , result :: List Type
+  , locals :: List Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+type Expr = List Instr
+
+type Instr = ByteString

app/Main.hs

@@ -1,17 +1,15 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OrPatterns #-}
 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 Prelude hiding (readFile)
 import Options.Applicative
 import Control.Lens
 import Data.Generics.Labels
@@ -27,12 +25,17 @@ 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.CPS.Convert
+import Gyehoek.CPS.Lower
+import Data.Foldable
+import qualified Gyehoek.Scheme.Syntax
+import Gyehoek.CPS.Syntax
+import Data.Maybe (fromMaybe)
 
 
 main :: IO ()
@@ -54,71 +57,28 @@ 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
+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
 
-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
+readScm :: FileSystem :> es => FilePath -> Eff es Scm.Exp
+readScm f =
+  withFile f FS.ReadMode $ \h ->
+    Sexp.parseSexps f <$> hGetContents h
+     >>= either error wrap
+  where
+    wrap [x] = pure x
+    wrap xs = pure . Gyehoek.Scheme.Syntax.ExpBegin $ xs
 
 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/gyehoek.c"]
-  pure ()
+driver opts = do
+  scm <- readScm opts.sourceFile
+  cps <- convert scm (pure . Halt1)
+  wat <- lower cps
+  withFile opts.output FS.WriteMode \h ->
+    hPutStr h wat

example/arith.scm

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

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

@@ -18,16 +18,13 @@
 
       overlays = [
         haskellNix.overlay
-        (final: prev: {
-          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
-            bdwgc;
-        })
         (final: prev: {
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
             shell = {
               withHoogle = true;
+              inputsFrom = [];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
@@ -36,10 +33,13 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
-                bdwgc
-                pkg-config
-                guile
-                clang-tools # clangd
+                self.packages.${final.stdenv.hostPlatform.system}.shake
+                final.wabt
+                final.nodejs
+                final.wasmtime
+                final.wasm-tools
+                final.wac-cli
+                final.guile
               ];
             };
           };
@@ -70,8 +70,7 @@
       packages = each-system ({ pkgs, system, ... }:
         hf.packages.${system} // {
           default = hf.packages.${system}."gyehoek:exe:gyehoek";
-          runtime = pkgs.callPackage ./runtime {};
-          inherit (pkgs) bdwgc;
+          shake = pkgs.callPackage ./shake-wrapper.nix {};
         });
 
       devShells = each-system

gyehoek.cabal

@@ -20,12 +20,12 @@ 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 -fplugin=Effectful.Plugin -threaded
 
   default-extensions:
     BlockArguments
     DeriveGeneric
+    OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms
@@ -36,22 +36,26 @@ executable gyehoek
 
   -- cabal-fmt: expand app -Main
   other-modules:
-    Gyehoek.ANF.Syntax
+    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
 
   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 +63,13 @@ executable gyehoek
     , optparse-applicative
     , prettyprinter
     , process
-    , qbe
     , recursion-schemes
     , sexp-grammar
     , template-haskell
     , text
+    , text-short
     , unordered-containers
     , vector
-    , text-short
-    , cradle
 
   hs-source-dirs:   app
   default-language: GHC2024

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/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/Makefile

@@ -1,8 +0,0 @@
-all: gyehoek.o
-
-gyehoek.o: gyehoek.c
-	$(CC) $(CFLAGS) -c gyehoek.c -o gyehoek.o
-
-.PHONY: install
-install:
-	install -Dm644 -t $(out)/lib gyehoek.o

runtime/default.nix

@@ -1,10 +0,0 @@
-{ stdenv
-, callPackage
-, bdwgc ? callPackage ../bdwgc.nix {}
-}:
-
-stdenv.mkDerivation {
-  pname = "gyehoek";
-  version = "1.0.0";
-  src = ./.;
-}

runtime/gyehoek.c

@@ -1,75 +0,0 @@
-#include <stdio.h>
-#include <gc.h>
-#include "gyehoek.h"
-
-
-
-const long scm_tc3_cons = 0;
-
-const long scm_tc7_obarray = 0x55;
-const long scm_tc7_symbol = 0x05;
-const long scm_tc7_string = 0x15;
-
-
-
-SCM scm_newline () {
-  putc ('\n', stdout);
-  return SCM_PACK(NULL);
-}
-
-static void scm_write_string (SCM x) {
-  const size_t len = SCM_CELL_WORD (x, 1);
-  const char *s = (const char *) SCM_UNPACK_POINTER (SCM_CELL_OBJECT (x, 2));
-  /* FIXME: this is a very naïve implementation with no escaping. */
-  printf ("some unrelated unicode lol: %s\n", "왜 하냐??");
-  printf ("\"%.*s\"", (int) len, s);
-}
-
-SCM scm_write (SCM x) {
-  if (SCM_IMP (x)) {
-    printf ("%ld", SCM_UNPACK (x) >> 2);
-  } else if (SCM_CONSP (x)) {
-    printf ("(");
-    scm_write (scm_car (x));
-    printf (" . ");
-    scm_write (scm_cdr (x));
-    printf (")");
-  } else if (SCM_STRINGP (x)) {
-    scm_write_string (x);
-  } else {
-    printf ("#<heap object 0x%016lx>", SCM_UNPACK (x));
-  }
-  return SCM_PACK(NULL);
-}
-
-SCM scm_car (SCM x) {
-  return SCM_CELL_OBJECT (x, 0);
-}
-
-SCM scm_cdr (SCM x) {
-  return SCM_CELL_OBJECT (x, 1);
-}
-
-SCM scm_words (scm_t_bits word_0, uint32_t n_words) {
-  scm_t_bits *r = GC_malloc (n_words * sizeof (scm_t_bits));
-  r[0] = word_0;
-  return SCM_PACK (r);
-}
-
-SCM scm_from_utf8_string (const char *str, size_t len) {
-  SCM r = scm_words (scm_tc7_string, 3);
-  SCM_SET_CELL_WORD (r, 1, len);
-  SCM_SET_CELL_WORD (r, 2, str);
-  printf ("str: %p\n", str);
-  return r;
-}
-
-SCM scm_from_utf8_symbol (const char *s, size_t len) {
-}
-
-SCM scm_cons (SCM car, SCM cdr) {
-  scm_t_bits *r = GC_malloc (2 * sizeof (scm_t_bits));
-  r[0] = SCM_UNPACK (car);
-  r[1] = SCM_UNPACK (cdr);
-  return SCM_PACK (r);
-}

runtime/gyehoek.h

@@ -1,102 +0,0 @@
-#ifndef GYEHOEK_H
-#define GYEHOEK_H
-
-#include <stddef.h>
-#include <stdint.h>
-
-
-
-typedef uintptr_t scm_t_bits;
-
-typedef union SCM { struct { scm_t_bits n; } n; } SCM;
-
-#define SCM_UNPACK(x) ((x).n.n)
-#define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } })
-#define SCM_IMP(x) 		(6 & SCM_UNPACK (x))
-#define SCM_NIMP(x) 		(!SCM_IMP (x))
-#define SCM_HEAP_OBJECT_P(x)    (SCM_NIMP (x))
-
-#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
-#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
-
-#define SCM_FALSE 0b00100
-#define SCM_TRUE  0b01100
-#define SCM_EOL   0b10100
-
-#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
-
-#define SCM_MAKE_SMALL_INT(x) (SCM_SRS ((SCM_PACK (x)), 2) + 2)
-#define SCM_GET_SMALL_INT(x) (SCM_UNPACK (x) >> 2)
-
-/* Checking if a SCM variable holds a pair (for historical reasons, in
-   Guile also known as a cons-cell): This is done by first checking that
-   the SCM variable holds a heap object, and second, by checking that
-   tc1==0 holds for the SCM_CELL_TYPE of the SCM variable.  */
-#define SCM_CONSP(x)  (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
-
-
-
-#define scm_tc2_int 2
-
-
-
-#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
-#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
-
-/* #define scm_tc3_cons 0 */
-extern const long scm_tc3_cons;
-
-SCM scm_cons (SCM car, SCM cdr);
-SCM scm_car (SCM x);
-SCM scm_cdr (SCM x);
-
-
-
-#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
-#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
-
-#define SCM_CELL_OBJECT(x, n) (((SCM *)SCM_UNPACK_POINTER (x)) [n])
-#define SCM_CELL_WORD(x, n)   (SCM_UNPACK (SCM_CELL_OBJECT ((x), (n))))
-
-#define SCM_SET_CELL_OBJECT(x, n, v) \
-  ((((SCM *)SCM_UNPACK_POINTER (x)) [n]) = (v))
-#define SCM_SET_CELL_WORD(x, n, v)  \
-  (SCM_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))
-
-#define SCM_CELL_TYPE(x) SCM_CELL_WORD (x, 0)
-#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
-#define SCM_HAS_HEAP_TYPE(x, type, tag)         \
-  (SCM_NIMP (x) && type (x) == (tag))
-#define SCM_HAS_TYP7(x, tag)    (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
-
-extern const long scm_tc7_obarray;
-extern const long scm_tc7_symbol;
-extern const long scm_tc7_string;
-
-
-
-#define SCM_STRINGP(x) (SCM_TYP7 (x) == scm_tc7_string)
-
-
-
-SCM scm_words (scm_t_bits word_0, uint32_t n_words);
-
-/* Construct a Scheme string. */
-SCM scm_from_utf8_string (const char *str, size_t len);
-
-/* Intern a symbol with a UTF-8 string name. */
-SCM scm_from_utf8_symbol (const char *s, size_t len);
-
-
-
-SCM scm_write (SCM);
-
-
-#endif /* GYEHOEK_H */

runtime/obarray.c

@@ -1,24 +0,0 @@
-#include "gyehoek.h"
-#include "obarray.h"
-
-typedef struct {
-  unsigned long hash;
-  scm_t_bits key;
-} scm_t_weak_entry;
-
-struct weak_entry_data {
-  scm_t_weak_entry *in;
-  scm_t_weak_entry *out;
-};
-
-typedef struct {
-  scm_t_weak_entry *entries;    /* the data */
-  scm_i_pthread_mutex_t lock;   /* the lock */
-  unsigned long size;    	/* total number of slots. */
-  unsigned long n_items;	/* number of items in set */
-  unsigned long lower;		/* when to shrink */
-  unsigned long upper;		/* when to grow */
-  int size_index;		/* index into hashset_size */
-  int min_size_index;		/* minimum size_index */
-} scm_t_weak_set;
-

runtime/obarray.h

@@ -1,8 +0,0 @@
-#ifndef OBARRAY_H
-#define OBARRAY_H
-
-#define SCM_OBARRAY_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
-
-SCM scm_obarray_insert ()
-
-#endif /* OBARRAY_H */

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]}
+  ''