dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cleanup pt. inf+

Browse Source
This commit is contained in:
Dane Johnson
2026-06-02 19:43:44 -05:00
parent 51e34c9750
commit 7a7b98310b
8 changed files with 1 additions and 363 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
example/asm/fib.scm
View File

@@ -1,34 +0,0 @@
(variable result 0)
(ref result)
(push fib)
(call)
(push cleanup)
(jmp)
fib
(dup)
(push 0)
(=)
(over)
(push 1)
(=)
(or)
(push recur)
(branch)
(return)
recur
(dup)
(push 1)
(-)
(push fib)
(call)
(over)
(push 2)
(-)
(push fib)
(call)
(+)
(nip)
(return)
cleanup
(set! result)
(bye)

153
example/asm/runtime.scm
View File

@@ -1,153 +0,0 @@
(push main)
(jmp)
;; Note that this is scheme syntax wrapping asm for a stack machine
(variable eol 0)
(variable scan 0)
(variable free 0)
;; These need to be initialized with the runtime
(variable eom 0)
(variable old 0)
(variable new 0)
(variable root 0)
alloc ;; ( -- p)
;; Test if free will go beyond eom
(ref free)
(dup) ; ( -- free free)
(push 8)
(+)
(dup) ; ( -- free free+8 free+8)
(ref eom)
(<) ; ( -- free free+8 (free+8 < eom))
(push alloc-do-gc)
(if)
;; write free+8 to free
(set! free)
;; return the old free, it is memory the program can use
(return)
alloc-do-gc
;; Empty the stack
(drop)
(drop)
;; Run garbage collection
(push gc-run)
(call)
;; Tail-call allocation
(push alloc)
(jmp)
gc-run ;; ( -- )
; Move scan & free to start of new memory
(ref new)
(dup)
(set! free)
(set! scan)
(ref root)
(push relocate-cons)
(call)
(push gc-loop)
(call)
; Flip old and new
(ref old)
(dup)
(ref new)
(set! old)
(set! new)
(push 512)
(+)
(set! eom)
(return)
relocate-cons ;; (o -- )
(dup)
(@)
(push relocate-reg)
(call)
(push 4)
(+)
(@)
(push relocate-reg)
relocate-reg ;; (r -- )
(dup)
(push #x80000000) ;; Is this a cons?
(and)
(push reg-relocated)
(if)
(dup)
(ref eol)
(=) ;; Is this eol?
(not)
(push reg-relocated)
(if)
(dup)
(push #x40000000) ;; Is it a broken heart?
(and)
(push copy-and-construct)
(if)
(dup) ;; Broken heart, copy updated address from cdr
(push 4)
(+)
(@) ;; Retrieve new address
(dup)
(!) ;; Write it here
(push reg-relocated)
(jmp)
copy-and-construct
(dup) ;; Wasn't a broken heart, move car to new memory
(@)
(push free)
(!)
(dup) ;; Push cdr to new memory
(push 4)
(+)
(@)
(push free)
(push 4)
(+)
(!)
(push #x40000000)
(over)
(!)
(ref free)
(over)
(push 4)
(+)
(!)
(ref free) ;; Move free pointer
(push 8)
(+)
(set! free)
reg-relocated
(drop)
(return)
gc-loop
(ref free)
(ref scan)
(<)
(branch gc-loop-done)
(ref scan)
(push relocate-reg)
(push gc-loop)
(jmp)
gc-loop-done
(return)
main
;; These need to be initialized with the runtime
(push memory)
(dup)
(set! new)
(push 512)
(+)
(dup)
(set! eom)
(set! old)
;; TODO set up root
;; <<USER PROGRAM HERE >>
(bye)
memory

3
example/c/.gitignore vendored
View File

@@ -1,3 +0,0 @@
*.o
scheme
scheme.exe

5
example/c/Makefile
View File

@@ -1,5 +0,0 @@
CFLAGS=-g
all: scheme
scheme: gc.o runtime.o

27
example/c/common.h
View File

@@ -1,27 +0,0 @@
#ifndef _COMMON_H_
#define _COMMON_H_
#define SIZE 1024
#define BROKEN_HEART 1
#define CONS 2
#define INTEGER 3
#define SYMBOL 4
#define BYE 5
typedef struct box_t {
char type;
union {
int integer;
char* symbol;
struct cons_t* cons;
};
} box_t;
typedef struct cons_t {
box_t car;
box_t cdr;
} cons_t;
extern cons_t *the_empty_list;
#endif // _COMMON_H_

64
example/c/gc.c
View File

@@ -1,64 +0,0 @@
// Cheney style stop and copy garbage collector
#include "gc.h"
cons_t *the_empty_list = NULL;
static cons_t *old, *new, *scanptr, *freeptr, *eom, *root;
size_t tos;
void gc_init() {
old = calloc(sizeof(cons_t), SIZE);
freeptr = old;
eom = old + (SIZE / 2);
new = eom + 1;
root = alloc();
}
cons_t *alloc() {
if (freeptr < eom) {
cons_t *retval = freeptr;
freeptr++;
return retval;
} else {
gc_run();
return alloc();
}
}
void gc_run() {
freeptr = new;
scanptr = new;
// Relocate root
relocate(root);
// Enter the main GC loop
gc_loop();
// Flip old and new;
cons_t *temp = old;
old = new;
new = temp;
}
void gc_loop() {
while (scanptr < freeptr) {
relocate(scanptr);
scanptr++;
}
}
void move(box_t box) {
if (box.type == CONS && box.cons != the_empty_list) {
if (box.cons->car.type == BROKEN_HEART) {
box.cons = box.cons->cdr.cons;
} else {
memcpy(freeptr, box.cons, sizeof(cons_t));
box.cons->car.type = BROKEN_HEART;
box.cons->cdr.cons = freeptr;
freeptr++;
}
}
}
void relocate(cons_t* cons) {
move(cons->car);
move(cons->cdr);
}

16
example/c/gc.h
View File

@@ -1,16 +0,0 @@
#ifndef _GC_H_
#define _GC_H_
#include <stdint.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include "common.h"
void gc_init();
cons_t *alloc();
void gc_run();
void gc_loop();
void relocate(cons_t*);
#endif // _GC_H_

62
scmvm/language/scheme.scm
View File

@@ -4,11 +4,8 @@
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((rnrs base) #:use-module (d- oop)
#:version (6)
#:select (assert))
#:export (desugar-prgm #:export (desugar-prgm
cps-convert-prgm cps-convert-prgm
ir-convert)) ir-convert))
@@ -300,63 +297,6 @@
(newline)) (newline))
(ir-interpreter)) (ir-interpreter))
;; Optimization
(define-syntax-rule (define-cps-type name field ...)
(begin
(define-cps-record-type name field ...)
(set-record-type-printer! name cps-printer)))
(define-syntax define-cps-record-type
(lambda (ctx)
(define (syntax-append id . syns)
(datum->syntax id (apply symbol-append (map syntax->datum syns))))
(syntax-case ctx ()
[(_ name field ...)
(with-syntax ([ctor (syntax-append #'name #'make- #'name)]
[pred (syntax-append #'name #'name #'?)]
[(getter ...) (map (lambda (f) (syntax-append f #'name #'- f))
#'(field ...))])
#'(define-record-type name
(ctor field ...)
pred
(field getter) ...))])))
(define (cps-printer cps port)
(format port "<cps ~s>" (unparse-cps cps)))
(define-cps-type $constant val)
(define-cps-type $primitive name)
(define-cps-type $var name)
(define-cps-type $abstraction vars body ktail)
(define-cps-type $alternative pred kt kf)
(define-cps-type $fix vars exps body)
(define-cps-type $assignment var exp cont)
(define-cps-type $application f args ktail)
(define (parse-cps exp)
(match exp
[(? constant?) (make-$constant exp)]
[('cps-prim name) (make-$primitive name)]
[(? symbol?) (make-$var exp)]
[('lambda (vars ... ktail) body) (make-$abstraction (map parse-cps vars) (parse-cps body) ktail)]
[('if pred k1 k2) (make-$alternative (parse-cps pred) k1 k2)]
[('letrec ([vars exps] ...) body) (make-$fix (map parse-cps vars) (map parse-cps exps) (parse-cps body))]
[('set!-then var exp cont) (make-$assignment var (parse-cps exp) (parse-cps cont))]
[(f args ... ktail) (make-$application (parse-cps f) (map parse-cps args) ktail)]
[_ (error "unexpected cps while parsing" exp)]))
(define (unparse-cps exp)
(match exp
[($ $constant val) val]
[($ $primitive name) `(cps-prim ,name)]
[($ $var name) name]
[($ $abstraction vars body ktail) `(lambda (,@(map unparse-cps vars) ,ktail) ,(unparse-cps body))]
[($ $alternative pred kt kf) `(if ,(unparse-cps pred) ,kt ,kf)]
[($ $fix vars exps body) `(letrec ,(zip (map unparse-cps vars) (map unparse-cps exps)) ,(unparse-cps body))]
[($ $assignment var expr cont) `(set!-then ,(unparse-cps var) ,(unparse-cps expr) ,(unparse-cps cont))]
[($ $application fun args ktail) `(,(unparse-cps fun) ,@(map unparse-cps args) ,ktail)]
[_ (error "Unexpected cps while unparsing" exp)]))
;; Compilation ;; Compilation
(define (meaning e r) (define (meaning e r)