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

@@ -7,8 +7,13 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
 {- HLINT ignore "Avoid lambda using `infix`" -}
-module Gyehoek.ANF
-  (toANF, lower)
+module Gyehoek.ANF.Syntax
+  ( Exp(..)
+  , toANF
+  , lower
+  , wrapFunction
+  , lowerProgram
+  )
   where
 
 import Data.Text (Text)
@@ -21,18 +26,18 @@ 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.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((:|)), toList)
+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)
+import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode, traversed)
 import Language.SexpGrammar.Generic
 import GHC.Generics (Generic)
 import Gyehoek.Sexp
@@ -43,6 +48,11 @@ 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
@@ -162,6 +172,8 @@ 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)
@@ -185,7 +197,12 @@ expr2 =
          (PrimCons
           (Lam.ExpLit (LitInt 2))
           (Lam.ExpLit (LitInt 3)))))
-    , Lam.ExpPrim (PrimWrite (Lam.ExpLit (LitInt 4)))
+    , Lam.ExpPrim
+      (PrimWrite
+       (Lam.ExpPrim
+        (PrimMul
+         (Lam.ExpLit (LitInt 5))
+         (Lam.ExpLit (LitInt 4)))))
     ]
 
 
@@ -255,17 +272,71 @@ buildBlock n bb = QBE.Block n [] (is ^.. each) j
 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
+  . (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)
+  :: 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
 
@@ -288,10 +359,11 @@ lowerArithmetic r p = QBE.BinaryOp r bop x y
       PrimMul a b -> (QBE.Mul,a,b)
       _ -> _
 
-sizeofScm = 16
+sizeofScm :: Integral a => a
+sizeofScm = 8
 
 lowerCons
-  :: (GenSym :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> QBE.Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -305,7 +377,7 @@ lowerCons r car cdr e k = do
               Nothing
               [ QBE.Arg
                 (QBE.AbiBaseTy QBE.Long)
-                (QBE.ValConst (QBE.CInt sizeofScm)) ]
+                (QBE.ValConst (QBE.CInt (sizeofScm * 2))) ]
               []
             ]
     initialise r1 =
@@ -315,32 +387,53 @@ lowerCons r car cdr e k = do
       , 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.Val -> (QBE.Val -> Eff es BlockBuilder)
+  => QBE.BinaryOp
+  -> QBE.Val -> QBE.Val
+  -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
-smallIntHelper bop v k = do
+smallIntHelper bop a b k = do
   r <- gensym
-  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
-         bop v (QBE.ValConst (QBE.CInt 2)) ]
-    <$> k (QBE.ValTemporary r)
+  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 =
-  smallIntHelper QBE.Shl n \n' ->
-    smallIntHelper QBE.And n' k
+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 = smallIntHelper QBE.Shr
+getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
 
 lowerWrite 
   :: forall es. (GenSym :> es)
@@ -355,25 +448,60 @@ lowerWrite r x e k =
        ]
     <$> 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)
+  :: 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)) -> do
-      r1 <- gensym
-      Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
-           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.And
-             (QBE.ValTemporary r1) (QBE.ValConst (QBE.CInt 0b10))
-           ]
-        <$> lower' e k
+    (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)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -398,9 +526,47 @@ lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
 
 lower' _ k = _
 
-lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
+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]

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/Scheme/Syntax.hs

@@ -2,11 +2,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Syntax where
+module Gyehoek.Scheme.Syntax
+  ( Name
+  , Prim(..)
+  , Lit(..)
+  , Define(..)
+  , Exp(..)
+  , Sexp(..)
+  )
+  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)
@@ -30,6 +40,7 @@ data Prim e
   | PrimConsP e
   | PrimIntegerP e
   | PrimWrite e
+  | PrimNewline
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
 instance Each (Prim e) (Prim e') e e'
@@ -38,16 +49,31 @@ 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
-  | 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)
 
 
@@ -65,9 +91,11 @@ instance SexpIso a => SexpIso (Prim a) where
     $ 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
 
@@ -76,19 +104,41 @@ instance SexpIso Lit where
     $ 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 (\app -> app . list (el sexpIso >>> rest 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))

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/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 ()

bdwgc.nix

@@ -1,18 +0,0 @@
-{ cmake
-, stdenv
-, fetchFromGitHub
-}:
-
-stdenv.mkDerivation (finalAttrs: {
-  pname = "bdwgc";
-  version = "8.2.12";
-  src = fetchFromGitHub {
-    owner = "bdwgc";
-    repo = "bdwgc";
-    tag = "v${finalAttrs.version}";
-    hash = "sha256-5yeAB5Y92YjOutwRXBJkMxoOLkmzmqIJs4PirKX89fE=";
-  };
-  nativeBuildInputs = [
-    cmake
-  ];
-})

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,26 +19,18 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          bdwgc = final.callPackage ./bdwgc.nix {};
+          inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
+            bdwgc;
         })
         (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";
-          #   };
-          # };
           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 = {};
@@ -43,9 +39,13 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
-                schemat
                 bdwgc
                 pkg-config
+                guile
+                clang-tools # clangd
+                gdb
+                gdbgui
+                rust-analyzer
               ];
             };
           };

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/t.ssa

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

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,11 +0,0 @@
-#include <stdio.h>
-#include "gyehoek.h"
-
-SCM scm_write (SCM x) {
-  if (SCM_IMP (x)) {
-    printf ("#<immediate %ld>\n", SCM_UNPACK (x));
-  } else {
-    printf ("#<heap object %ld>\n", SCM_UNPACK(x));
-  }
-  return SCM_PACK(NULL);
-}

runtime/gyehoek.h

@@ -1,23 +0,0 @@
-#ifndef GYEHOEK_H
-#define GYEHOEK_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))
-
-
-
-SCM scm_write (SCM);
-
-
-#endif /* GYEHOEK_H */

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 ();