msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SCM sum type

Browse Source
This commit is contained in:
Madeleine Sydney Slaga
2026-05-22 14:18:48 -06:00
parent 4b2c026d75
commit b1a210ef12
22 changed files with 135 additions and 314 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
app/Main.hs
View File

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

4
play/.gitignore vendored Normal file
View File

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

21
play/a.c
View File

@@ -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);
}

BIN
play/a.out
View File

Binary file not shown.

BIN
play/hash
View File

Binary file not shown.

48
play/hash.c
View File

@@ -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)));
}

BIN
play/string
View File

Binary file not shown.

4
play/string.anf
View File

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

23
play/string.s
View File

@@ -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

10
play/string.ssa
View File

@@ -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
}

BIN
play/t
View File

Binary file not shown.

4
play/t.anf
View File

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

18
play/t.s
View File

@@ -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

10
play/t.ssa
View File

@@ -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
}

0
play/t.scm → play/write-cons.scm
View File

31
play/wtf.s
View File

@@ -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

8
play/wtf.ssa
View File

@@ -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
}

16
runtime/Cargo.lock generated
View File

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

1
runtime/Cargo.toml
View File

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

34
runtime/src/gc.rs
View File

@@ -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_alloc_lock ();
fn GC_alloc_unlock ();
fn GC_free (ptr: *mut c_void);
// 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_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;
// 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 }
}

132
runtime/src/lib.rs
View File

@@ -3,128 +3,24 @@
use std::{io::{stdout, Write}};
mod gc;
// use crate::gc;
// use bdwgc_alloc:Allocator;
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)
}
mod scm;
use scm::{scm_bits, SCM};
#[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) {
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 (scm_car (x));
scm_write (car);
print! (" . ");
scm_write (scm_cdr (x));
scm_write (cdr);
print! (")");
} else {
let ty = if is_immediate (x) { "immediate" } else { "heap object" };
print! ("#<{ty} {:#016x}>", scm_unpack (x));
}
},
SCM::Nil => print! ("()"),
SCM::False => print! ("#f"),
SCM::True => print! ("#t"),
};
let _ = stdout ().flush ();
return scm_pack (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);
}
return 0;
}

77
runtime/src/scm.rs Normal file
View File

@@ -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) }
}