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,26 +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 (LitQuote (SexpSymbol s))) k = _aaa
-
-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))
@@ -309,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
 
@@ -335,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
@@ -424,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
@@ -433,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
@@ -445,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
@@ -462,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
@@ -490,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
@@ -504,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

@@ -40,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'
@@ -90,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
 

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"]

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 = {};
@@ -42,6 +45,7 @@
                 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/hash.c

@@ -1,48 +0,0 @@
-#include <stdio.h>
-#include <string.h>
-#include "../runtime/gyehoek.h"
-#include "../runtime/weak-set.h"
-
-static int
-symbol_lookup_predicate_fn (SCM sym1, void *closure) {
-  const SCM sym2 = *((SCM*)closure);
-  const int symp1 = SCM_SYMBOLP (sym1);
-  const int symp2 = SCM_SYMBOLP (sym2);
-  // both symbols?
-  if (SCM_SYMBOLP (sym1) && SCM_SYMBOLP (sym2)) {
-    const SCM str1 = SCM_CELL_OBJECT (sym1, 2);
-    const SCM str2 = SCM_CELL_OBJECT (sym2, 2);
-    const size_t len1 = scm_c_string_length (str1);
-    const size_t len2 = scm_c_string_length (str2);
-    // same length?
-    if (len1 == len2) {
-      // same name?
-      const char * const s1 = scm_c_string_chars (str1);
-      const char * const s2 = scm_c_string_chars (str2);
-      return strncmp (s1, s2, len1);
-    }
-  }
-  return 0;
-}
-
-SCM test (SCM set, const char *sym_name, SCM value) {
-  SCM str = scm_from_cstring (sym_name);
-  SCM sym = scm_make_symbol (str, scm_c_hash (str));
-  SCM r = scm_c_weak_set_insert (set, scm_c_hash (str), value,
-                                 symbol_lookup_predicate_fn,
-                                 &sym);
-  printf ("%ld\n", weak_set_count (set));
-  return r;
-}
-
-int main () {
-  /* const char s[] = "wormy"; */
-  /* const SCM str = scm_from_utf8_string (s, sizeof(s)); */
-  /* const unsigned long hash = scm_c_hash (str); */
-  /* printf ("%ld\n", hash); */
-
-  SCM set = scm_c_make_weak_set (31);
-  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
-  test (set, "my-symbol", SCM_PACK (SCM_MAKE_SMALL_INT (123)));
-  test (set, "my-symbol2", SCM_PACK (SCM_MAKE_SMALL_INT (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/.envrc

@@ -1 +0,0 @@
-use flake

runtime/Cargo.lock

@@ -2,6 +2,12 @@
 # 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"
@@ -30,17 +36,61 @@ 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]]
@@ -54,3 +104,9 @@ 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

@@ -12,6 +12,9 @@ crate-type = ["staticlib"]
 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' }
+bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }

runtime/default.nix

@@ -0,0 +1,24 @@
+{ lib
+, rustPlatform
+, bdwgc
+, cmake
+, pkg-config
+}:
+
+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/flake.lock

@@ -1,87 +0,0 @@
-{
-  "nodes": {
-    "fenix": {
-      "inputs": {
-        "nixpkgs": [
-          "nixpkgs"
-        ],
-        "rust-analyzer-src": "rust-analyzer-src"
-      },
-      "locked": {
-        "lastModified": 1779185128,
-        "narHash": "sha256-Kl2bkmwZJD3n2KWDxuIlturZ7emqRK+anpD1LmDwpmY=",
-        "owner": "nix-community",
-        "repo": "fenix",
-        "rev": "b7bd9323fe26a3b4f4bddbb2c2a1dacabced2f88",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nix-community",
-        "repo": "fenix",
-        "type": "github"
-      }
-    },
-    "nixpkgs": {
-      "locked": {
-        "lastModified": 1778869304,
-        "narHash": "sha256-30sZNZoA1cqF5JNO9fVX+wgiQYjB7HJqqJ4ztCDeBZE=",
-        "owner": "NixOS",
-        "repo": "nixpkgs",
-        "rev": "d233902339c02a9c334e7e593de68855ad26c4cb",
-        "type": "github"
-      },
-      "original": {
-        "owner": "NixOS",
-        "ref": "nixos-unstable",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "root": {
-      "inputs": {
-        "fenix": "fenix",
-        "nixpkgs": "nixpkgs",
-        "sydpkgs": "sydpkgs"
-      }
-    },
-    "rust-analyzer-src": {
-      "flake": false,
-      "locked": {
-        "lastModified": 1779074864,
-        "narHash": "sha256-0M3WqsWmtXmv9Ev/vnFfCHosWvISDwiuuhQ104UO3CI=",
-        "owner": "rust-lang",
-        "repo": "rust-analyzer",
-        "rev": "cdfe408d4b436e806ff525cb3e67588a6a009ed1",
-        "type": "github"
-      },
-      "original": {
-        "owner": "rust-lang",
-        "ref": "nightly",
-        "repo": "rust-analyzer",
-        "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",
-  "version": 7
-}

runtime/flake.nix

@@ -1,70 +0,0 @@
-{
-  inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
-    fenix = {
-      url = "github:nix-community/fenix";
-      inputs.nixpkgs.follows = "nixpkgs";
-    };
-    sydpkgs = {
-      url = "git+https://git.deertopia.net/msyds/sydpkgs";
-      inputs.nixpkgs.follows = "nixpkgs";
-    };
-  };
-
-  outputs = { self, nixpkgs, fenix, sydpkgs, ... }:
-  let
-    supportedSystems = [
-      "aarch64-darwin" "aarch64-linux"
-      "x86_64-darwin" "x86_64-linux"
-    ];
-
-    each-system = f: nixpkgs.lib.genAttrs supportedSystems (system: f rec {
-      pkgs = import nixpkgs {
-        inherit system overlays;
-      };
-      inherit (pkgs) lib;
-      inherit system;
-    });
-
-    overlays = [
-      (final: prev: {
-        inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
-          bdwgc;
-      })
-      fenix.overlays.default
-    ];
-
-  in {
-    _pkgs = each-system ({ pkgs, ... }: pkgs);
-
-    packages = each-system ({ pkgs, ... }: {
-      default = pkgs.callPackage ./. {};
-    });
-
-    devShells = each-system ({ pkgs, lib, ... }: {
-      default = pkgs.mkShell {
-        RUSTFLAGS = "-L " + lib.makeLibraryPath [
-          pkgs.bdwgc
-        ];
-        packages = [
-          pkgs.pkg-config
-          pkgs.bdwgc
-          (pkgs.fenix.complete.withComponents [
-            "cargo" "clippy" "rust-src" "rustc" "rustfmt"
-          ])
-          pkgs.rust-analyzer-nightly
-          pkgs.cmake
-        ];
-      };
-    });
-  };
-
-  nixConfig = {
-    extra-substituters = [
-      "https://fenix.cachix.org"
-    ];
-    extra-trusted-public-keys = [
-      "fenix.cachix.org-1:ecJhr+RdYEdcVgUkjruiYhjbBloIEGov7bos90cZi0Q="
-    ];
-  };
-}

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

@@ -1,109 +1,9 @@
-use std::{io::{stdout, Write}};
+#![allow(non_upper_case_globals)]
+#![allow(non_camel_case_types)]
 
-const scm_tc3_cons: u64 = 0;
-const scm_tc2_int: u64 = 2;
-
-
-type scm_bits = u64;
-
-#[repr(C)]
-#[derive(Clone, Copy)]
-struct SCM {
-    n : scm_bits
-}
-
-fn scm_pack (bits : scm_bits) -> SCM {
-    SCM {n: bits}
-}
-
-fn scm_unpack (x : SCM) -> scm_bits {
-    x.n
-}
-
-fn scm_unpack_pointer (x : SCM) -> *mut scm_bits {
-    x.n as *mut scm_bits
-}
-
-fn scm_pack_pointer (x : *const scm_bits) -> SCM {
-    SCM {n: x as scm_bits}
-}
-
-
-
-fn scm_cell_object (x: SCM, n: usize) -> SCM {
-    let p = scm_unpack_pointer (x) as *mut SCM;
-    unsafe {
-        *(p.wrapping_add (n))
-    }
-}
-
-fn scm_cell_word (x: SCM, n: usize) -> scm_bits {
-    scm_unpack (scm_cell_object (x, n))
-}
-
-fn is_immediate (x: SCM) -> bool {
-    6 & scm_unpack (x) != 0
-}
-
-fn scm_cell_type (x: SCM) -> scm_bits {
-    scm_cell_word (x, 0)
-}
-
-fn is_cons (x: SCM) -> bool {
-    ! is_immediate (x) && (1 & scm_cell_type (x)) == 0
-}
-
-fn is_small_int (x: SCM) -> bool {
-    3 & scm_unpack (x) == scm_tc2_int
-}
-
-fn get_small_int (x: SCM) -> scm_bits {
-    scm_unpack (x) >> 2
-}
-
-fn scm_car (x: SCM) -> SCM {
-    scm_cell_object (x, 0)
-}
-
-fn scm_cdr (x: SCM) -> SCM {
-    scm_cell_object (x, 1)
-}
-
-#[unsafe(no_mangle)]
-pub extern "C" fn scm_write (x: SCM) -> SCM {
-    if is_small_int (x) {
-        print! ("{:?}", get_small_int (x));
-    } else if is_cons (x) {
-        print! ("(");
-        scm_write (scm_car (x));
-        print! (" . ");
-        scm_write (scm_cdr (x));
-        print! (")");
-    } else {
-        let ty = if is_immediate (x) { "immediate" } else { "heap object" };
-        print! ("#<{ty} {:#016x}>", scm_unpack (x));
-    }
-    stdout ().flush ();
-    return scm_pack (0);
-}
-
-#[unsafe(no_mangle)]
-pub extern "C" fn scm_from_utf8_string (s: scm_bits, len: scm_bits) -> scm_bits {
-    println! ("scm_from_utf8_string");
-    return 0;
-}
-
-pub fn add (left: u64, right: u64) -> u64 {
-    left + right
-}
-
-#[cfg(test)]
-mod tests {
-    use super::*;
-
-    #[test]
-    fn it_works () {
-        let result = add (2, 2);
-        assert_eq! (result, 4);
-    }
-}
+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 ();