fuuuuck!

README.md

@@ -1,3 +1,3 @@
 # gyehoek-hs (계획)
 
-a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/) (an LLVM-like intermediate representation). uses ANF and some other GHC-esque compilation techniques.
+a (wip) toy compiler for a Scheme-like language. currently targetting [QBE](https://c9x.me/compile/). nabbing from GHC and GNU Guile.

app/Gyehoek/ANF.hs

@@ -1,290 +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
-  (toANF, lower)
-  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.Syntax qualified as Lam
-import Gyehoek.Syntax (Name, Prim(..), Lit(..))
-import Gyehoek.GenSym
-import Control.Monad.Cont
-import Data.Foldable
-import Data.List.NonEmpty (NonEmpty((:|)), toList)
-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)
-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
-
-
-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' 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)))
-
-
-
-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 Nothing name Nothing ps QBE.NoVariadic
-
-prims :: QBE.Program
-prims = QBE.Program mempty mempty primfns where
-  primfns = [ 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 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
-
-lowerVal
-  :: forall es. (GenSym :> es)
-  => Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lowerVal (ValLit (LitInt n)) k =
-  k . QBE.ValConst . QBE.CInt . fromIntegral $ n
-lowerVal (ValLit _) k = error "todo"
-lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
-
-lowerBinaryOp :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
-lowerBinaryOp 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)
-      _ -> _
-
--- lowerPrim 
---   :: forall es. (GenSym :> es)
---   => Prim Val
---   -> (QBE.Val -> Eff es BlockBuilder)
---   -> Eff es BlockBuilder
--- lowerPrim p k = telescope (lowerVal <$> p) \p' -> do
---   Emit [ lowerBinaryOp (r QBE.:= QBE.Long) p' ]
---     <$> k (QBE.ValTemporary r)
-
-lower'
-  :: forall es. (GenSym :> es)
-  => Exp
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lower' (ExpVal v) k = lowerVal v k
-
-lower' (ExpLetPrim r p e) k =
-  telescope (lowerVal <$> p) \p' -> do
-    Emit [ lowerBinaryOp (lowerName r QBE.:= QBE.Long) p' ]
-      <$> lower' e k
-
-lower' (ExpLetApply r f xs e) k =
-  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') -> do
-    Emit [ QBE.Call
-            (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
-            f'
-            Nothing
-            (QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
-            []
-          ]
-      <$> lower' e k
-
-lower' _ k = _
-
-lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
-lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
-
-wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
-wrapProgram bs = QBE.Program [] [] [main] where
-  main = QBE.FuncDef [QBE.Export]
-    (Just (QBE.AbiBaseTy QBE.Word))
-    "main" Nothing [] QBE.NoVariadic (toNonEmpty bs)

app/Gyehoek/ANF/Syntax.hs

@@ -0,0 +1,574 @@
+{-# 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
+import Data.HashMap.Strict (HashMap)
+import Effectful.State.Static.Local
+import qualified Data.HashMap.Strict as HM
+
+
+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
+
+lowerString
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
+  => Text -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
+lowerString s k = do
+  let len = lengthOf each $ T.encodeUtf8 s
+  rawString <- getRawString
+  r <- gensym
+  Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
+  where
+    -- getRawString
+    --   :: forall es. (GenSym :> es, State StringLiterals :> es)
+    --   => Eff es _
+    getRawString = do
+      x <- get
+      case x ^. at s of
+        Just s' -> pure s'
+        Nothing -> do r <- gensym
+                      state \lits -> (r, HM.insert s r lits)
+    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)
+        ]
+        []
+      ]
+
+type StringLiterals = HashMap Text (QBE.Ident QBE.Global)
+
+lowerVal
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
+  => Val
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+
+lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
+
+lowerVal (ValLit (LitQuote (Lam.SexpSymbol s))) k =
+  lowerString s \s' -> do
+    r <- gensym
+    Emit (intern r s') <$> k (QBE.ValTemporary r)
+  where
+    intern r s' =
+      [ QBE.Call
+        (Just (r, QBE.AbiBaseTy QBE.Long))
+        (QBE.ValGlobal "scm_string_to_symbol")
+        Nothing
+        [ QBE.Arg (QBE.AbiBaseTy QBE.Long) s'
+        ]
+        []
+      ]
+
+lowerVal (ValLit (LitString s)) k = lowerString s k
+
+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, State StringLiterals :> 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, State StringLiterals :> 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, State StringLiterals :> 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
+
+lowerNewline r k =
+  Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
+         (QBE.ValGlobal "scm_newline") Nothing
+         []
+         []
+       ]
+    <$> k (QBE.ValTemporary (lowerName r))
+
+lowerPrim 
+  :: forall es. (GenSym :> es, State StringLiterals :> 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
+    PrimNewline -> lowerNewline r k
+
+lower'
+  :: forall es. (GenSym :> es, State StringLiterals :> 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, State StringLiterals :> es)
+  => QBE.Ident QBE.Label
+  -> Exp
+  -> Eff es QBE.Block
+lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
+
+lowerStringLiterals =
+  ifoldMapOf itraversed \s v ->
+    [ QBE.DataDef [] v Nothing
+      [QBE.FieldExtTy QBE.Byte [QBE.String (T.encodeUtf8 s)]]]
+
+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,stringLits) <- runState mempty . lower "start" $ e
+      let f = wrapFunction @NonEmpty "main" [b]
+          dataDefs = lowerStringLiterals stringLits
+      pure $ QBE.Program [] dataDefs [f]
+    _ -> do
+      let low e = do
+            bl <- gensym' "b"
+            fl <- gensym' "f"
+            b <- lower bl e
+            pure $ wrapFunction @NonEmpty fl [b]
+      (fs,stringLits) <- runState mempty $ traverse low anfs
+      pure $ QBE.Program [] (lowerStringLiterals stringLits) (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/GenSym.hs

@@ -9,26 +9,34 @@ import Effectful
 import Language.QBE as QBE
 import Data.String (IsString(fromString))
 import Data.Text (Text)
+import qualified Data.Text.Short as ST
 
 
 class Gen a where
   gen :: Natural -> a
+  gen' :: Text -> Natural -> a
 
 data GenSym :: Effect where
   GenSym :: Gen a => GenSym m a
+  GenSym' :: Gen a => Text -> GenSym m a
 
 type instance DispatchOf GenSym = Dynamic
 
 gensym :: forall a es. (Gen a, GenSym :> es) => Eff es a
 gensym = send GenSym
 
+gensym' :: forall a es. (Gen a, GenSym :> es) => Text -> Eff es a
+gensym' = send . GenSym'
+
 runGenSym :: Eff (GenSym : es) a -> Eff es a
-runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \_ GenSym ->
-  state \n -> (gen n, succ n)
-  -- state \n -> (Ident . fromString $ '.' : show n, succ n)
+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

@@ -0,0 +1,51 @@
+{-# 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

@@ -9,6 +9,7 @@ module Gyehoek.QBE
   ( module QBE
   , render
   , fn
+  , writeTo
   )
   where
 
@@ -24,8 +25,12 @@ 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
 

app/Gyehoek/Scheme/Syntax.hs

@@ -0,0 +1,145 @@
+{-# 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
+  | PrimNewline
+  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")
+    $ With (. nullop "newline")
+    $ End
+    where
+      primname = ("prim:" <>)
+      nullop s = list $ el (sym (primname s))
+      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/Scratch.hs

@@ -1 +0,0 @@
-module Gyehoek.Scratch where

app/Gyehoek/Sexp.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -8,12 +9,16 @@ module Gyehoek.Sexp
   , 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
@@ -24,6 +29,13 @@ 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
@@ -37,10 +49,14 @@ 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) -> xs :- x :- t)
-  (\(xs :- x :- t) -> (x:|xs) :- t)
+  (\((x:|xs) :- t) -> reverse xs :- x :- t)
+  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
 
 nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
 nonempty a =
@@ -67,6 +83,24 @@ 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

app/Gyehoek/Syntax.hs

@@ -1,79 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Syntax where
-
-import Data.Text (Text)
-import Data.List (List)
-import Language.SexpGrammar as Sexp hiding (List)
-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
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-
-instance Each (Prim e) (Prim e') e e'
-
-data Lit
-  = LitInt Int
-  | LitNil
-  | LitBool Bool
-  deriving (Show, Generic)
-
-data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpApply Exp (List Exp)
-  | ExpBegin (List Exp)
-  | ExpLit Lit
-  | ExpPrim (Prim Exp)
-  | ExpLambda (List Name) Exp
-  | ExpVar Name
-  deriving (Show, Generic)
-
-
-
-instance SexpIso a => SexpIso (Prim a) where
-  sexpIso = match
-    $ With (. binop "prim-+")
-    $ With (. binop "prim--")
-    $ With (. binop "prim-*")
-    $ With (. binop "prim-/")
-    $ End
-    where
-      binop s = list $ el (sym s) >>> el sexpIso >>> el sexpIso
-
-instance SexpIso Lit where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. sym "nil")
-    $ With (. sexpIso)
-    $ End
-
-instance SexpIso Exp where
-  sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. sexpIso)
-    $ With (. sexpIso)
-    $ With (. lam)
-    $ With (. symbol)
-    $ End
-    where
-      lam = list
-        ( el (sym "lambda")
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )

app/Main.hs

@@ -1,17 +1,124 @@
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ViewPatterns #-}
 module Main
   (main)
   where
 
-import qualified Gyehoek.ANF as ANF
+import qualified Gyehoek.ANF.Syntax as ANF
 import Gyehoek.QBE (render)
+import Gyehoek.Options
 import qualified Data.Text.IO as TIO
-import Prelude hiding ((.),id)
+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
 
 
 main :: IO ()
-main = TIO.putStrLn . render $ ANF.expr
+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 = f -<.> "out"
+  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 ()

cabal.project

@@ -3,5 +3,5 @@ packages: *.cabal
 source-repository-package
     type: git
     location: https://git.deertopia.net/msyds/qbe-hs.git
-    tag: ab7cc053a4d58fde841e910f251b8e48b54466ad
-    --sha256: 0n2jqr6vymlyr0gwzbv3cljhqxnzcq1pzf7m92b16jalkymbcwgy
+    tag: 64be0096355a8fd23cc1a4910ed5c8e6075aeca9
+    --sha256: 0x507fmpyzyvg3f27wss94d7fkrbv6r05jknlphgyi53pscazr9r

example/ascii-string-literal.anf

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

example/ascii-string-literal.s

@@ -0,0 +1,23 @@
+.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

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

example/ascii-string-literal.ssa

@@ -0,0 +1,10 @@
+
+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

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

example/cons.s

@@ -0,0 +1,18 @@
+.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

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

example/cons.ssa

@@ -0,0 +1,10 @@
+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/string-literal.anf

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

example/string-literal.s

@@ -0,0 +1,23 @@
+.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

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

example/string-literal.ssa

@@ -0,0 +1,10 @@
+
+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

@@ -591,7 +591,8 @@
         "nixpkgs": [
           "haskellNix",
           "nixpkgs-unstable"
-        ]
+        ],
+        "sydpkgs": "sydpkgs"
       }
     },
     "stackage": {
@@ -609,6 +610,26 @@
         "repo": "stackage.nix",
         "type": "github"
       }
+    },
+    "sydpkgs": {
+      "inputs": {
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1778962331,
+        "narHash": "sha256-qMokSV7hsWYiDCkkBGyG0aD4Ds3JLzJzJ0Cp9f/spJU=",
+        "ref": "refs/heads/main",
+        "rev": "59d3a471cd960f9d1f6c645a4fe578a670848e9d",
+        "revCount": 41,
+        "type": "git",
+        "url": "https://git.deertopia.net/msyds/sydpkgs"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://git.deertopia.net/msyds/sydpkgs"
+      }
     }
   },
   "root": "root",

flake.nix

@@ -3,9 +3,13 @@
     haskellNix.url = "github:input-output-hk/haskell.nix";
     # nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
     nixpkgs.follows = "haskellNix/nixpkgs-unstable";
+    sydpkgs = {
+      url = "git+https://git.deertopia.net/msyds/sydpkgs";
+      inputs.nixpkgs.follows = "nixpkgs";
+    };
   };
 
-  outputs = { self, nixpkgs, haskellNix, ... }@inputs:
+  outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
     let
       supportedSystems = [
         "aarch64-darwin" "aarch64-linux"
@@ -15,23 +19,18 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          # haskellPackages = prev.haskellPackages.override {
-          #   qbe = final.haskell-nix.project' {
-          #     src = final.fetchFromGitea {
-          #       domain = "git.deertopia.net";
-          #       owner = "msyds";
-          #       repo = "qbe-hs";
-          #       rev = "master";
-          #       hash = "sha256-3Ni2xFOvw7Qjzq7BIXfnSQQ3U99OaEH0j6SdILMYizs=";
-          #     };
-          #     compiler-nix-name = "ghc912";
-          #   };
-          # };
+          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
+            bdwgc;
+        })
+        (final: prev: {
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
             shell = {
               withHoogle = true;
+              inputsFrom = [
+                self.packages.${final.stdenv.hostPlatform.system}.runtime
+              ];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
@@ -40,7 +39,13 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
-                schemat
+                bdwgc
+                pkg-config
+                guile
+                clang-tools # clangd
+                gdb
+                gdbgui
+                rust-analyzer
               ];
             };
           };
@@ -72,6 +77,7 @@
         hf.packages.${system} // {
           default = hf.packages.${system}."gyehoek:exe:gyehoek";
           runtime = pkgs.callPackage ./runtime {};
+          inherit (pkgs) bdwgc;
         });
 
       devShells = each-system

gyehoek.cabal

@@ -13,48 +13,61 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+common ghcstuffs-dev
+  ghc-options:
+    -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
+
 common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -Wno-typed-holes
-    -fplugin=Effectful.Plugin
+    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
+    -threaded
 
-  other-extensions:
+  default-extensions:
     BlockArguments
+    DeriveGeneric
+    OverloadedStrings
     PartialTypeSignatures
+    PatternSynonyms
 
 executable gyehoek
-  import:           ghcstuffs
+  import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
 
   -- cabal-fmt: expand app -Main
   other-modules:
-    Gyehoek.ANF
-    Gyehoek.Sexp
+    Gyehoek.ANF.Syntax
     Gyehoek.GenSym
+    Gyehoek.Options
     Gyehoek.QBE
     Gyehoek.QBE.Parse
-    Gyehoek.Scratch
-    Gyehoek.Syntax
+    Gyehoek.Scheme.Syntax
+    Gyehoek.Sexp
 
-  -- other-extensions:
   build-depends:
-    , base               ^>=4.21.2.0
+    , base                  ^>=4.21.2.0
+    , containers
     , effectful
     , effectful-core
     , effectful-plugin
+    , filepath
+    , generic-lens
+    , invertible-grammar
     , lens
     , megaparsec
     , mtl
+    , optparse-applicative
     , prettyprinter
+    , process
     , qbe
     , recursion-schemes
+    , sexp-grammar
     , template-haskell
     , text
+    , unordered-containers
     , vector
-    , generic-lens
-    , sexp-grammar
-    , invertible-grammar
+    , text-short
+    , cradle
 
   hs-source-dirs:   app
   default-language: GHC2024

play/.gitignore

@@ -0,0 +1,4 @@
+*.anf
+*.s
+*.ssa
+*.out

play/car.scm

@@ -0,0 +1 @@
+(prim:write (prim:car (prim:cons 123 456)))

play/cdr.scm

@@ -0,0 +1 @@
+(prim:write (prim:cdr (prim:cons 123 456)))

play/string.scm

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

play/symbol.scm

@@ -0,0 +1,3 @@
+(begin (prim:write 'abc)
+       (prim:newline)
+       (prim:write 'abc))

play/write-cons.scm

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

runtime/.gitignore

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

runtime/Cargo.lock

@@ -0,0 +1,112 @@
+# This file is automatically @generated by Cargo.
+# It is not intended for manual editing.
+version = 4
+
+[[package]]
+name = "allocator-api2"
+version = "0.2.21"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923"
+
+[[package]]
+name = "bdwgc-alloc"
+version = "0.6.13"
+source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
+dependencies = [
+ "cmake",
+ "libc",
+]
+
+[[package]]
+name = "cc"
+version = "1.2.62"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
+dependencies = [
+ "find-msvc-tools",
+ "shlex",
+]
+
+[[package]]
+name = "cmake"
+version = "0.1.58"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
+dependencies = [
+ "cc",
+]
+
+[[package]]
+name = "const_panic"
+version = "0.2.15"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "e262cdaac42494e3ae34c43969f9cdeb7da178bdb4b66fa6a1ea2edb4c8ae652"
+dependencies = [
+ "typewit",
+]
+
+[[package]]
+name = "equivalent"
+version = "1.0.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f"
+
+[[package]]
+name = "find-msvc-tools"
+version = "0.1.9"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
+
+[[package]]
+name = "foldhash"
+version = "0.1.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "d9c4f5dac5e15c24eb999c26181a6ca40b39fe946cbe4c263c7209467bc83af2"
+
+[[package]]
+name = "gyehoek"
+version = "0.1.0"
+dependencies = [
+ "bdwgc-alloc",
+ "const_panic",
+ "internment",
+ "libc",
+]
+
+[[package]]
+name = "hashbrown"
+version = "0.15.5"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "9229cfe53dfd69f0609a49f65461bd93001ea1ef889cd5529dd176593f5338a1"
+dependencies = [
+ "allocator-api2",
+ "equivalent",
+ "foldhash",
+]
+
+[[package]]
+name = "internment"
+version = "0.8.6"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "636d4b0f6a39fd684effe2a73f5310df16a3fa7954c26d36833e98f44d1977a2"
+dependencies = [
+ "hashbrown",
+]
+
+[[package]]
+name = "libc"
+version = "0.2.186"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
+
+[[package]]
+name = "shlex"
+version = "1.3.0"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"
+
+[[package]]
+name = "typewit"
+version = "1.15.2"
+source = "registry+https://github.com/rust-lang/crates.io-index"
+checksum = "214ca0b2191785cbc06209b9ca1861e048e39b5ba33574b3cedd58363d5bb5f6"

runtime/Cargo.toml

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

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 +1,24 @@
-{ stdenv
-, callPackage
-, bdwgc ? callPackage ./bdwgc.nix {}
+{ lib
+, rustPlatform
+, bdwgc
+, cmake
+, pkg-config
 }:
 
-stdenv.mkDerivation {
-  pname = "gyehoek";
-  version = "1.0.0";
+rustPlatform.buildRustPackage (finalAttrs: {
+  pname = "gyehoek-runtime";
+  version = "0.0.1";
   src = ./.;
-}
+  cargoLock = {
+    lockFile = ./Cargo.lock;
+    outputHashes."bdwgc-alloc-0.6.13" =
+      "sha256-8/EZ9FThVVsdkwB+OIlNHQJxIr6DPf701Mlfq5U1j4E=";
+  };
+  nativeBuildInputs = [
+    pkg-config
+    cmake
+  ];
+  buildInputs = [
+    bdwgc
+  ];
+})

runtime/gyehoek.c

@@ -1,5 +0,0 @@
-#include <stdio.h>
-
-int blah () {
-  puts ("aaa");
-}

runtime/src/capi.rs

@@ -0,0 +1,24 @@
+use std::slice;
+
+use crate::scm::scm_bits;
+use crate::scm;
+
+#[unsafe(no_mangle)]
+pub extern "C" fn scm_from_utf8_string (
+    ptr : *const u8,
+    len : usize
+) -> scm_bits {
+    let bytes = unsafe { slice::from_raw_parts (ptr, len) };
+    scm::make_string (str::from_utf8 (bytes).unwrap ())
+}
+
+// #[unsafe(no_mangle)]
+// pub extern "C" fn scm_hash (ptr : *const u8, len : usize) -> u64 {
+//     let bytes = unsafe { slice::from_raw_parts (ptr, len) };
+//     crate::obarray::hash (str::from_utf8 (bytes).unwrap ())
+// }
+
+#[unsafe(no_mangle)]
+pub extern "C" fn scm_string_to_symbol (str : scm_bits) -> scm_bits {
+    crate::scm::string_to_symbol (str)
+}

runtime/src/gc.rs

@@ -0,0 +1,34 @@
+use libc::{c_void, size_t};
+
+#[link(name = "gc", kind = "static")]
+unsafe extern "C" {
+    // fn GC_allow_register_threads ();
+    // fn GC_alloc_lock ();
+    // fn GC_alloc_unlock ();
+    // fn GC_free (ptr: *mut c_void);
+    // fn GC_get_stack_base (stack_base: *mut GcStackBase) -> c_int;
+    // fn GC_init ();
+    fn GC_malloc (size: size_t) -> *mut c_void;
+    fn GC_realloc (ptr: *mut c_void, size: size_t) -> *mut c_void;
+    // fn GC_register_my_thread
+    //     (stack_base: *const GcStackBase) -> c_int;
+    // fn GC_set_stackbottom
+    //     (thread: *const c_void, stack_bottom: *const GcStackBase);
+    // fn GC_unregister_my_thread ();
+    // fn GC_gcollect ();
+    // fn GC_register_finalizer (
+    //     ptr: *const c_void,
+    //     finalizer: extern "C" fn (*mut c_void, *mut c_void),
+    //     client_data: *const c_void,
+    //     opt_old_finalizer: *const c_void,
+    //     opt_old_client_data: *const c_void,
+    // ) -> *mut c_void;
+}
+
+pub unsafe fn malloc<T> (size: usize) -> *mut T {
+    unsafe { GC_malloc (size) as *mut T }
+}
+
+pub unsafe fn realloc<T> (ptr: *mut T, size: usize) -> *mut T {
+    unsafe { GC_realloc (ptr as *mut c_void, size) as *mut T }
+}

runtime/src/lib.rs

@@ -0,0 +1,9 @@
+#![allow(non_upper_case_globals)]
+#![allow(non_camel_case_types)]
+
+mod gc;
+mod scm;
+mod primitives;
+// mod obarray;
+mod capi;
+mod var;

runtime/src/primitives.rs

@@ -0,0 +1,31 @@
+use crate::scm;
+use crate::scm::{scm_bits, SCM};
+use std::io::{stdout, Write};
+
+#[unsafe(no_mangle)]
+pub extern "C" fn scm_write (x: scm_bits) -> scm_bits {
+    match scm::unpack (x) {
+        SCM::SmallInt (n) => print! ("{n}"),
+        SCM::Cons (car, cdr) => {
+            print! ("(");
+            scm_write (car);
+            print! (" . ");
+            scm_write (cdr);
+            print! (")");
+        },
+        SCM::String (s) => print! ("\"{s}\""),
+        SCM::Nil => print! ("()"),
+        SCM::False => print! ("#f"),
+        SCM::True => print! ("#t"),
+        SCM::Symbol (_s) => print! ("{x:#016x}"),
+        // SCM::Symbol (s) => print! ("{s}"),
+    };
+    let _ = stdout ().flush ();
+    return 0;
+}
+
+#[unsafe(no_mangle)]
+pub extern "C" fn scm_newline () -> scm_bits {
+    print! ("\n");
+    0
+}

runtime/src/scm.rs

@@ -0,0 +1,203 @@
+#![allow(non_upper_case_globals)]
+#![allow(non_camel_case_types)]
+
+use std::slice;
+
+use internment::Intern;
+
+use crate::gc;
+
+pub type scm_bits = u64;
+
+pub const tc2_int      : u64 = 2;
+pub const tc3_cons     : u64 = 0;
+pub const tc7_obarray  : u64 = 0x55;
+pub const tc7_symbol   : u64 = 0x05;
+pub const tc7_string   : u64 = 0x15;
+
+// pub const scm_false : SCM = pack (0b00100);
+// pub const scm_true  : SCM = pack (0b01100);
+// pub const scm_eol   : SCM = pack (0b10100);
+
+pub enum SCM {
+    SmallInt (i64), 
+    Cons (scm_bits, scm_bits),
+    String (String),
+    Symbol (String),
+    Nil,
+    False,
+    True,
+}
+
+// #[inline(always)]
+// pub fn pack (x : SCM) -> scm_bits {
+// }
+
+#[inline(always)]
+pub fn unpack_string (x : scm_bits) -> String {
+    let len = unsafe { cell_word (x, 1) };
+    let str_beginning = (x as *const scm_bits).wrapping_add (2) as *const u8;
+    let slice = unsafe {
+        str::from_utf8 (
+            slice::from_raw_parts (
+                str_beginning,
+                len.try_into ().unwrap ()
+            )
+        ).unwrap ()
+    };
+    String::from (slice)
+}
+
+// super duper important for this to inline. we want to eliminate the
+// SCM type at runtime as much as possible. the hope is for inlining
+// to lead to a case-of-case–esque transformation.
+#[inline(always)]
+pub fn unpack (x : scm_bits) -> SCM {
+    if is_small_int (x) {
+        SCM::SmallInt ((x >> 2) as i64)
+    } else if is_cons (x) {
+        // `car` x and `cdr` x are safe iff `is_cons` x.
+        unsafe { SCM::Cons (car (x), cdr (x)) }
+    } else if is_string (x) {
+        SCM::String (unpack_string (x))
+    } else if is_symbol (x) {
+        let s = unpack_string (unsafe { cell_word (x, 1) });
+        SCM::Symbol (s)
+    } else {
+        // concat_panic! ("don't know how to unpack: ", x)
+        panic! ("don't know how to unpack {x:#016x}")
+    }
+}
+
+const fn is_small_int (x: scm_bits) -> bool {
+    3 & x == tc2_int
+}
+
+const fn is_immediate (x: scm_bits) -> bool {
+    6 & x != 0
+}
+
+fn is_string (x: scm_bits) -> bool {
+    has_tc7 (x, tc7_string)
+}
+
+fn is_cons (x: scm_bits) -> bool {
+    // safety of `cell_type` is mutually exclusive with
+    // `is_immediate`, so this is okay.
+    unsafe {
+        ! is_immediate (x) && (1 & cell_type (x)) == 0
+    }
+}
+
+fn is_symbol (x : scm_bits) -> bool {
+    has_tc7 (x, tc7_symbol)
+}
+
+fn has_tc7 (x: scm_bits, tc7: u64) -> bool {
+    unsafe {
+        ! is_immediate (x) && (0x7f & cell_type (x)) == tc7
+    }
+}
+
+unsafe fn cell_type (x: scm_bits) -> scm_bits {
+    unsafe { cell_word (x, 0) }
+}
+
+unsafe fn cell_word (x: scm_bits, n: usize) -> scm_bits {
+    let p = x as *mut scm_bits;
+    unsafe {
+        *(p.wrapping_add (n))
+    }
+}
+
+unsafe fn car (x: scm_bits) -> scm_bits {
+    unsafe { cell_word (x, 0) }
+}
+
+unsafe fn cdr (x: scm_bits) -> scm_bits {
+    unsafe { cell_word (x, 1) }
+}
+
+pub unsafe fn words (tag : scm_bits, n : usize) -> *mut scm_bits {
+    let r = unsafe { gc::malloc (n * size_of::<scm_bits> ()) };
+    unsafe { *r = tag };
+    return r
+}
+
+pub fn pack_ptr (obj : *const scm_bits) -> scm_bits {
+    obj as scm_bits
+}
+
+pub unsafe fn set_word (obj : *mut scm_bits, ix : usize, val : scm_bits) {
+    let x = obj.wrapping_add (ix);
+    unsafe { *x = val; }
+}
+
+
+
+pub fn make_string_from_raw_parts (
+    ptr : *const u8,
+    len : usize
+) -> scm_bits {
+    let bytes = unsafe { slice::from_raw_parts (ptr, len) };
+    make_string (str::from_utf8 (bytes).unwrap ())
+}
+
+pub fn make_string (s : &str) -> scm_bits {
+    let len = s.len ();
+    let size_of_tag_and_len = 2 * size_of::<scm_bits> ();
+    let size_of_contents = len;
+    let r = unsafe { gc::malloc (size_of_tag_and_len + size_of_contents) };
+    unsafe {
+        set_word (r, 0, tc7_string);
+        set_word (r, 1, len as u64);
+    }
+    let str_beginning = r.wrapping_add (2) as *mut u8;
+    for (i, b) in s.as_bytes ().iter ().enumerate () {
+        unsafe { *(str_beginning.wrapping_add (i)) = *b };
+    }
+    return pack_ptr (r)
+}
+
+
+
+// pub fn make_symbol (name : &str) -> scm_bits {
+//     let r = unsafe { words (tc7_symbol, 2) };
+//     let sym = obarray::symbols.intern (name).to_usize ();
+//     unsafe { set_word (r, 1, sym.try_into ().unwrap ()) };
+//     pack_ptr (r)
+// }
+
+struct Symbol ([scm_bits; 2]);
+
+impl PartialEq for Symbol {
+    fn eq (&self, other: &Self) -> bool {
+        if let (SCM::String (s1), SCM::String (s2))
+             = (unpack (self.0[1]), unpack (other.0[1])) {
+                 s1 == s2
+        } else {
+            panic! ("not a symbol")
+        }
+    }
+}
+
+impl Eq for Symbol {}
+
+impl std::hash::Hash for Symbol {
+    fn hash <H: std::hash::Hasher> (&self, state: &mut H) {
+        if let SCM::String (s) = unpack (self.0[1]) {
+            s.hash (state)
+        } else {
+            panic! ("not a symbol")
+        }
+    }
+}
+
+fn make_symbol_off_heap (name : scm_bits) -> Symbol {
+    Symbol ([ tc7_symbol, name ])
+}
+
+pub fn string_to_symbol (str : scm_bits) -> scm_bits {
+    let r = Intern::new (make_symbol_off_heap (str));
+    pack_ptr (r.0.as_ptr ())
+}

runtime/src/var.rs

@@ -0,0 +1,26 @@
+use std::{collections::HashMap, ops::DerefMut as _, sync::{LazyLock, RwLock}};
+use crate::scm::scm_bits;
+
+struct Vars (
+    LazyLock <RwLock <HashMap <String, scm_bits>>>
+);
+
+impl Vars {
+    pub const fn new () -> Vars {
+        Vars (LazyLock::new (|| RwLock::new (HashMap::new ())))
+    }
+
+    pub fn lookup (&self, name : String) -> Option <scm_bits> {
+        // let r = self.0.write ().unwrap ();
+        // (*r).get (&name).map (|x| *x)
+        todo! ()
+    }
+
+    pub fn define (&self, name : String, value : scm_bits) {
+        // let mut r = self.0.write ().unwrap ();
+        // r.deref_mut ().insert (name, value);
+        todo! ()
+    }
+}
+
+static vars : Vars = Vars::new ();