fuuuuck!

app/Gyehoek/ANF/Syntax.hs

@@ -50,6 +50,9 @@ 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
@@ -276,24 +279,24 @@ lowerInt = QBE.ValConst . QBE.CInt
   . (Data.Bits..<<. 2)
   . fromIntegral
 
-lowerVal
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
-  => Val
-  -> (QBE.Val -> Eff es BlockBuilder)
-  -> Eff es BlockBuilder
-
-lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
-
-lowerVal (ValLit (LitString s)) k = do
-  rawString <- gensym
+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
-  let bs = T.encodeUtf8 s
-      len = lengthOf each bs
-  tell . pure $
-    QBE.DataDef [] rawString Nothing
-      [QBE.FieldExtTy QBE.Byte [QBE.String bs]]
   Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
   where
+    -- 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))
@@ -307,6 +310,33 @@ lowerVal (ValLit (LitString s)) k = do
         []
       ]
 
+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
 
@@ -333,7 +363,7 @@ sizeofScm :: Integral a => a
 sizeofScm = 8
 
 lowerCons
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> QBE.Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -422,7 +452,7 @@ smallIntMask :: Integer
 smallIntMask = 2 ^ (sizeofScm * 8) - 2
 
 lowerCar
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> _
   -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCar r x e k = do
@@ -431,7 +461,7 @@ lowerCar r x e k = do
     <$> lower' e k
 
 lowerCdr
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCdr r x e k = do
@@ -443,8 +473,16 @@ lowerCdr r x e k = do
        ]
     <$> 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, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Name -> Prim Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -460,9 +498,10 @@ lowerPrim r p 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, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -488,12 +527,17 @@ lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
 lower' _ k = _
 
 lower
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (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
@@ -502,17 +546,18 @@ lowerProgram anfs =
     -- hack for dev convenience: if there's only one expression, let
     -- it be the entry point.
     [e] -> do
-      (b,dataDefs) <- runWriter . lower "start" $ e
+      (b,stringLits) <- runState mempty . lower "start" $ e
       let f = wrapFunction @NonEmpty "main" [b]
-      pure $ QBE.Program [] (dataDefs ^.. each) [f]
+          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,dataDefs) <- runWriter $ traverse low anfs
-      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
+      (fs,stringLits) <- runState mempty $ traverse low anfs
+      pure $ QBE.Program [] (lowerStringLiterals stringLits) (fs ^.. traversed)
 
 wrapFunction
   :: Foldable1 t

app/Gyehoek/Scheme/Syntax.hs

@@ -2,11 +2,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
-module Gyehoek.Scheme.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'
@@ -39,6 +50,7 @@ data Lit
   | LitNil
   | LitBool Bool
   | LitString Text
+  | LitQuote Sexp
   deriving (Show, Generic)
 
 data Define
@@ -53,9 +65,15 @@ data Exp
   | ExpDefine Define
   | ExpIf Exp Exp Exp
   | ExpLit Lit
-  | ExpApply Exp (List Exp)
   | ExpLambda (List Name) Exp
   | ExpVar Name
+  | ExpApply Exp (List Exp)
+  deriving (Show, Generic)
+
+data Sexp
+  = SexpCons Sexp Sexp
+  | SexpSymbol Text
+  | SexpLit Lit
   deriving (Show, Generic)
 
 
@@ -73,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
 
@@ -85,6 +105,14 @@ instance SexpIso Lit where
     $ With (. sym "nil")
     $ With (. sexpIso)
     $ With (. sexpIso)
+    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ End
+
+instance SexpIso Sexp where
+  sexpIso = match
+    $ With (\cons -> cons . Gyehoek.Sexp.todo)
+    $ With (\s -> s . symbol)
+    $ With (\lit -> lit . sexpIso)
     $ End
 
 instance SexpIso Define where
@@ -105,9 +133,9 @@ instance SexpIso Exp where
     $ With (. sexpIso)
     $ With (. if_)
     $ With (. sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest 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

app/Gyehoek/Sexp.hs

@@ -10,6 +10,8 @@ module Gyehoek.Sexp
   , encode
   , decode
   , parseSexps
+  , prefixSugar
+  , todo
   )
 where
 
@@ -33,6 +35,7 @@ import GHC.IO.Unsafe (unsafePerformIO)
 import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SexpLoc
+import Data.Void (absurd)
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -80,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

@@ -101,7 +101,7 @@ callGCC
   => FilePath -> List String -> Eff es FilePath
 callGCC f args = do
   let asm_file = f -<.> "s"
-      exe = dropExtension f
+      exe = f -<.> "out"
   C.StdoutTrimmed (T.words -> flags) <-
     C.run $ C.cmd "pkg-config"
           & C.addArgs @String ["--cflags", "--libs", "bdw-gc"]
@@ -120,5 +120,5 @@ driver = runGenSym . traverseOf_ (#sourceFiles . folded) \f -> do
   anfs <- toANF f exps
   qbe <- toQBE f anfs
   callQBE f
-  callGCC f ["../runtime/gyehoek.c"]
+  callGCC f ["../runtime/target/debug/libgyehoek.a"]
   pure ()

flake.nix

@@ -28,6 +28,9 @@
             compiler-nix-name = "ghc912";
             shell = {
               withHoogle = true;
+              inputsFrom = [
+                self.packages.${final.stdenv.hostPlatform.system}.runtime
+              ];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
@@ -40,6 +43,9 @@
                 pkg-config
                 guile
                 clang-tools # clangd
+                gdb
+                gdbgui
+                rust-analyzer
               ];
             };
           };

play/.gitignore

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

play/a.c

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

play/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.anf

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

play/string.s

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

play/string.ssa

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

play/symbol.scm

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

play/t.anf

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

play/t.s

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

play/t.ssa

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

play/wtf.s

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

play/wtf.ssa

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

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

runtime/gyehoek.h

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

runtime/obarray.c

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

runtime/obarray.h

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

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