Cleanup pt. inf+
This commit is contained in:
@@ -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)
|
||||
@@ -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
3
example/c/.gitignore
vendored
@@ -1,3 +0,0 @@
|
||||
*.o
|
||||
scheme
|
||||
scheme.exe
|
||||
@@ -1,5 +0,0 @@
|
||||
CFLAGS=-g
|
||||
|
||||
all: scheme
|
||||
|
||||
scheme: gc.o runtime.o
|
||||
@@ -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_
|
||||
@@ -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);
|
||||
}
|
||||
@@ -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_
|
||||
@@ -4,11 +4,8 @@
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module ((rnrs base)
|
||||
#:version (6)
|
||||
#:select (assert))
|
||||
#:use-module (d- oop)
|
||||
#:export (desugar-prgm
|
||||
cps-convert-prgm
|
||||
ir-convert))
|
||||
@@ -300,63 +297,6 @@
|
||||
(newline))
|
||||
(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
|
||||
|
||||
(define (meaning e r)
|
||||
|
||||
Reference in New Issue
Block a user