SCM sum type

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

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/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/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/Cargo.lock

@@ -30,6 +30,15 @@ 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 = "find-msvc-tools"
 version = "0.1.9"
@@ -41,6 +50,7 @@ name = "gyehoek"
 version = "0.1.0"
 dependencies = [
  "bdwgc-alloc",
+ "const_panic",
  "libc",
 ]
 
@@ -55,3 +65,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,7 @@ crate-type = ["staticlib"]
 bdwgc-alloc = { version = "0.6.13"
               , default-features = false
               , features = ["cmake"] }
+const_panic = "0.2.15"
 libc = "0.2.186"
 
 [patch.crates-io]

runtime/src/gc.rs

@@ -1,30 +1,34 @@
-use libc::{c_int, c_void, size_t};
+use libc::{c_void, size_t};
 
 #[link(name = "gc", kind = "static")]
 unsafe extern "C" {
-    fn GC_allow_register_threads ();
+    // fn GC_allow_register_threads ();
-    fn GC_alloc_lock ();
+    // fn GC_alloc_lock ();
-    fn GC_alloc_unlock ();
+    // fn GC_alloc_unlock ();
-    fn GC_free (ptr: *mut c_void);
+    // fn GC_free (ptr: *mut c_void);
     // fn GC_get_stack_base (stack_base: *mut GcStackBase) -> c_int;
-    fn GC_init ();
+    // 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_unregister_my_thread ();
-    fn GC_gcollect ();
+    // fn GC_gcollect ();
-    fn GC_register_finalizer (
+    // fn GC_register_finalizer (
-        ptr: *const c_void,
+    //     ptr: *const c_void,
-        finalizer: extern "C" fn (*mut c_void, *mut c_void),
+    //     finalizer: extern "C" fn (*mut c_void, *mut c_void),
-        client_data: *const c_void,
+    //     client_data: *const c_void,
-        opt_old_finalizer: *const c_void,
+    //     opt_old_finalizer: *const c_void,
-        opt_old_client_data: *const c_void,
+    //     opt_old_client_data: *const c_void,
-    ) -> *mut 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

@@ -3,128 +3,24 @@
 
 use std::{io::{stdout, Write}};
 mod gc;
-// use crate::gc;
+mod scm;
-// use bdwgc_alloc:Allocator;
+use scm::{scm_bits, SCM};
-
-pub const scm_tc2_int      : u64 = 2;
-pub const scm_tc3_cons     : u64 = 0;
-pub const scm_tc7_weak_set : u64 = 0x55;
-pub const scm_tc7_symbol   : u64 = 0x05;
-pub const scm_tc7_string   : u64 = 0x15;
-
-pub const scm_false : SCM = scm_pack (0b00100);
-pub const scm_true  : SCM = scm_pack (0b01100);
-pub const scm_eol   : SCM = scm_pack (0b10100);
-
-
-pub type scm_bits = u64;
-
-#[repr(C)]
-#[derive(Clone, Copy)]
-pub struct SCM {
-    n : scm_bits
-}
-
-const 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_words (ty: scm_bits, n: usize) -> SCM {
-    unsafe {
-        let r = gc::malloc (n * size_of::<scm_bits> ()) as *mut scm_bits;
-        *r = ty;
-        return scm_pack_pointer (r);
-    }
-}
-
-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 {
+pub extern "C" fn scm_write (x: scm_bits) -> scm_bits {
-    if is_small_int (x) {
+    match scm::unpack (x) {
-        print! ("{:?}", get_small_int (x));
+        SCM::SmallInt (n) => print! ("{n}"),
-    } else if is_cons (x) {
+        SCM::Cons (car, cdr) => {
-        print! ("(");
+            print! ("(");
-        scm_write (scm_car (x));
+            scm_write (car);
-        print! (" . ");
+            print! (" . ");
-        scm_write (scm_cdr (x));
+            scm_write (cdr);
-        print! (")");
+            print! (")");
-    } else {
+        },
-        let ty = if is_immediate (x) { "immediate" } else { "heap object" };
+        SCM::Nil => print! ("()"),
-        print! ("#<{ty} {:#016x}>", scm_unpack (x));
+        SCM::False => print! ("#f"),
-    }
+        SCM::True => print! ("#t"),
+    };
     let _ = stdout ().flush ();
-    return scm_pack (0);
+    return 0;
-}
-
-#[unsafe(no_mangle)]
-pub extern "C" fn scm_from_utf8 (s: *const u8, len: usize) -> SCM {
-    let r = scm_words (scm_tc7_string, 3);
-    return scm_pack (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);
-    }
 }

runtime/src/scm.rs

@@ -0,0 +1,77 @@
+#![allow(non_upper_case_globals)]
+#![allow(non_camel_case_types)]
+
+pub type scm_bits = u64;
+
+pub const tc2_int      : u64 = 2;
+pub const tc3_cons     : u64 = 0;
+pub const tc7_weak_set : 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),
+    Nil,
+    False,
+    True,
+}
+
+// #[inline(always)]
+// pub fn pack (x : SCM) -> scm_bits {
+// }
+
+// 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 {
+        // 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_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
+    }
+}
+
+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) }
+}