├── .gitignore ├── compile.sh ├── symtab.h ├── boot.c ├── types.h ├── LICENSE ├── symtab.c ├── po.scm └── bytecode.scm /.gitignore: -------------------------------------------------------------------------------- 1 | po 2 | *.o 3 | *.out 4 | *.swp 5 | print-atom-gdb.py 6 | *.s 7 | *_test 8 | core* 9 | -------------------------------------------------------------------------------- /compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cc -c -g -m32 boot.c symtab.c && 4 | csi -s bytecode.scm > t.s && nasm -felf32 t.s && 5 | cc -m32 -o po boot.o symtab.o t.o 6 | -------------------------------------------------------------------------------- /symtab.h: -------------------------------------------------------------------------------- 1 | #ifndef SYMTAB_H 2 | #define SYMTAB_H 3 | 4 | #include "types.h" 5 | 6 | sym_table st_create(unsigned short size); 7 | void* st_get_or_set(lstr *k); 8 | 9 | #endif // SYMTAB 10 | -------------------------------------------------------------------------------- /boot.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "symtab.h" 3 | #include "types.h" 4 | 5 | sym_table *symtab; 6 | 7 | extern void po_entry(); 8 | 9 | int main() { 10 | sym_table t = st_create(256); 11 | symtab = &t; 12 | po_entry(); 13 | } 14 | -------------------------------------------------------------------------------- /types.h: -------------------------------------------------------------------------------- 1 | #ifndef TYPES_H 2 | #define TYPES_H 3 | 4 | #define NIL (void *) 0x1 5 | 6 | typedef struct { 7 | void *car; 8 | void *cdr; 9 | } __attribute__((packed)) cons; 10 | 11 | typedef struct lstr { 12 | unsigned short n; 13 | char str[]; 14 | } __attribute__((packed)) lstr; 15 | 16 | // sym table 17 | 18 | typedef struct { 19 | char *key; 20 | cons *vals; 21 | } bucket; 22 | 23 | typedef struct { 24 | short size; 25 | bucket *table; 26 | } sym_table; 27 | 28 | #endif // TYPES_H 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Charles L 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /symtab.c: -------------------------------------------------------------------------------- 1 | // TODO: generalize this code a bit so it can be used for more than 2 | // just the sym table (i.e. allow full hash tables in the lang itself) 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include "symtab.h" 9 | #define MIN(X, Y) (((X) < (Y)) ? (X) : (Y)) 10 | 11 | extern sym_table *symtab; 12 | 13 | // TODO: test that this works 14 | char *lstr_to_cstr(lstr *l) { 15 | char *c = malloc(l->n + 1); 16 | memcpy(c, l + offsetof(lstr, str), l->n); 17 | c[l->n] = 0; 18 | return c; 19 | } 20 | 21 | // TODO: test that this works 22 | lstr *cstr_to_lstr(char *c) { 23 | size_t s = strlen(c); 24 | lstr *l = malloc(sizeof(short) + sizeof(char) * s); 25 | return l; 26 | } 27 | 28 | sym_table st_create(unsigned short size) { 29 | sym_table t; 30 | t.size = size; 31 | t.table = calloc(size, sizeof(bucket)); 32 | return t; 33 | } 34 | 35 | unsigned int st_hash(lstr *k) { 36 | // djb2 37 | unsigned long hash = 5381; 38 | for(int i = 0; i < k->n; i++) 39 | hash = ((hash << 5) + hash) + k->str[i]; 40 | return hash % symtab->size; 41 | } 42 | 43 | void* st_get_or_set(lstr *k) { 44 | int bin = st_hash(k); 45 | bucket *b = &(symtab->table[bin]); 46 | 47 | if(b->vals == NULL) { 48 | b->vals = NIL; 49 | } 50 | 51 | for(cons *c = b->vals; c != NIL; c = c->cdr) { 52 | lstr *l = ((lstr *) c->car); 53 | if(strncmp(l->str, k->str, MIN(l->n, k->n)) == 0) 54 | return (void *) c->car; 55 | } 56 | 57 | cons *n = malloc(sizeof(cons)); 58 | n->car = k; 59 | n->cdr = b->vals; 60 | b->vals = n; 61 | return n->car; 62 | } 63 | -------------------------------------------------------------------------------- /po.scm: -------------------------------------------------------------------------------- 1 | (use srfi-1) 2 | 3 | (define env.init '()) 4 | (define env.global env.init) 5 | 6 | (define-syntax definitial 7 | (syntax-rules () 8 | ((definitial name) 9 | (begin (set! env.global (cons (cons 'name 'void) env.global)) 10 | 'name)) 11 | ((definitial name value) 12 | (begin (set! env.global (cons (cons 'name value) env.global)) 13 | 'name)))) 14 | 15 | (define-syntax defprimitive 16 | (syntax-rules () 17 | ((defprimitive name value arity) 18 | (definitial name 19 | (lambda (vals env) 20 | (if (= arity (length vals)) 21 | (apply value vals) 22 | (error "incorrect arity" (list 'name vals)))))))) 23 | 24 | (define (evlis exps env) 25 | (cond 26 | ((null? exps) '()) 27 | (else (cons (c:eval (car exps) env) 28 | (evlis (cdr exps) env))))) 29 | 30 | (define (eprogn exps env) 31 | (cond ((null? exps) '()) 32 | ((pair? (cdr exps)) 33 | (begin (c:eval (car exps) env) 34 | (eprogn (cdr exps) env))) 35 | (else 36 | (c:eval (car exps) env)))) 37 | 38 | (define (c:apply fn args env) 39 | (if (procedure? fn) 40 | (fn args env) 41 | (error "not a function" fn))) 42 | 43 | (define (make-lambda vars body env) 44 | (lambda (vals current.env) 45 | (eprogn body (extend env vars vals)))) 46 | 47 | (define (make-closure fun env) 48 | (lambda (vals current.env) 49 | (fun vals env))) 50 | 51 | (define (lookup id env) 52 | (cond 53 | ((assoc id env) => cdr) 54 | (else (error "no such binding" id)))) 55 | 56 | (define (extend env vars vals) 57 | (append 58 | (map (lambda (v d) 59 | (cons v d)) 60 | vars vals) 61 | env)) 62 | 63 | (define (update! id env val) 64 | (cond 65 | ((assoc id env) => (lambda (v) 66 | (set-cdr! v val))) 67 | (else 68 | (error "no such binding" id)))) 69 | 70 | (define (c:eval e env) 71 | (if (atom? e) 72 | (cond 73 | ((symbol? e) (lookup e env)) 74 | ((or (number? e) (string? e) (char? e) (boolean? e) (vector? e)) 75 | e) 76 | (else (error "cannot eval" e))) 77 | (case (car e) 78 | ((quote) (cadr e)) 79 | ((if) (if (c:eval (cadr e) env) 80 | (c:eval (caddr e) env) 81 | (c:eval (cadddr e) env))) 82 | ((begin) (eprogn (cdr e) env)) 83 | ((set!) (update! (cadr e) env (c:eval (caddr e) env))) 84 | ((closure) 85 | (let* ((f (cadr e)) 86 | (fun (make-lambda (cadr f) (cddr f) env))) 87 | (make-closure fun env))) 88 | ((lambda) (make-lambda (cadr e) (cddr e) env)) 89 | ((letrec) 90 | (let ((new-env (extend env 91 | (map car (cadr e)) 92 | (map (lambda (binding) 'void) 93 | (cadr e))))) 94 | (map (lambda (binding) 95 | (update! (car binding) 96 | new-env 97 | (c:eval (cadr binding) new-env))) 98 | (cadr e)) 99 | (eprogn (cddr e) new-env))) 100 | (else (c:apply (c:eval (car e) env) 101 | (evlis (cdr e) env) 102 | env))))) 103 | 104 | (define (test e expr) 105 | (let ((t (c:eval expr env.global))) 106 | (if (eq? e t) 107 | (display ".") 108 | (begin (newline) 109 | (print "failed on (eq? " e " " t ")"))))) 110 | 111 | 112 | (definitial foo) 113 | (definitial bar) 114 | (definitial a) 115 | 116 | (defprimitive cons cons 2) 117 | (defprimitive car car 1) 118 | (defprimitive set-cdr! set-cdr! 2) 119 | (defprimitive + + 2) 120 | (defprimitive eq? eq? 2) 121 | (defprimitive < < 2) 122 | 123 | (newline) 124 | (test 1 1) 125 | (test #\a #\a) 126 | (test 'a ''a) 127 | (test #t #t) 128 | (test 'b '(if #f 'a 'b)) 129 | (test 'a '(if #t 'a 'b)) 130 | (test 3 '(begin (set! a 3) a)) 131 | (test 'a '((lambda (a) a) 'a)) 132 | (test 1 '((closure (lambda (a) a) x y z) 1)) 133 | (test 9 '(letrec ((x 9) (y 2) (z x)) 134 | x)) 135 | (test 8 '(letrec ((x 8) (y 2) (z x)) 136 | x y z)) 137 | (test 2 '(letrec ((x (lambda (y) 138 | (+ y 1)))) 139 | (x 1))) 140 | (test 9 '((letrec ((x 9)) 141 | (closure (lambda () x) x)))) 142 | (newline) 143 | -------------------------------------------------------------------------------- /bytecode.scm: -------------------------------------------------------------------------------- 1 | (use srfi-1 srfi-13 srfi-69) 2 | (define *val* 'eax) 3 | (define *env* 'ebx) 4 | (define *fun* 'ecx) 5 | (define *t1* 'edx) 6 | (define *t2* 'edi) 7 | (define *sp* 'esp) 8 | (define word-size 4) 9 | (define short-size 2) 10 | 11 | (define num-tag #b000) 12 | (define nil-tag #b001) 13 | (define cons-tag #b010) 14 | (define str-tag #b011) 15 | (define sym-tag #b100) 16 | (define vec-tag #b101) 17 | (define fun-tag #b110) 18 | 19 | (define (with-index f) 20 | (let ((i 0)) 21 | (lambda (e) 22 | (let ((r (f e i))) 23 | (set! i (add1 i)) 24 | r)))) 25 | 26 | (define (logn x n) 27 | (inexact->exact (/ (log x) (log n)))) 28 | 29 | (define (tag v tag) 30 | (bitwise-ior (arithmetic-shift v 3) tag)) 31 | 32 | (define (tsize t e) 33 | (symbol-append t e)) 34 | 35 | (define (deref . e) 36 | (symbol-append '\[ (string->symbol (string-join (map ->string e))) '\])) 37 | 38 | (define (untag v) 39 | (arithmetic-shift v -3)) 40 | 41 | (define (register? r) 42 | (any (cut eq? r <>) (list *val* *env* *fun* *t1* *sp*))) 43 | 44 | (define (reg-or-val v) 45 | (if (register? v) 46 | v 47 | (tagged-val v))) 48 | 49 | (define (tagged-val v) 50 | (cond 51 | ((number? v) (tag v num-tag)) 52 | ((null? v) (tag 0 nil-tag)) 53 | ;((eq? #t v) (tag v true-tag)) 54 | )) 55 | 56 | ;;; 57 | 58 | (define env.init '(())) 59 | 60 | (define (env-push env k) 61 | (cons (cons k (car env)) (cdr env))) 62 | 63 | (define (env-new-frame env) 64 | (cons '() env)) 65 | 66 | (define (env-pop-frame env) 67 | (cdr env)) 68 | 69 | (define (env-lookup env k) 70 | (list-index (cut eq? <> k) (car env))) 71 | 72 | (define global-vars (make-hash-table)) 73 | (define (global-ref i) 74 | (if (hash-table-exists? global-vars i) 75 | (hash-table-ref global-vars i) 76 | (let ((s (gensym i))) 77 | (hash-table-set! global-vars i s) 78 | s))) 79 | 80 | (define (_CONST v) 81 | `((mov ,*val* ,v))) 82 | 83 | (define (CONST v) 84 | (_CONST (reg-or-val v))) 85 | 86 | (define (SYMBOL s) 87 | `(,@(STRING (symbol->string s)) 88 | (sub ,*val* 3) ; untag *val* so C has a real pointer 89 | ,@(CCALL 'st_get_or_set *val*))) 90 | 91 | (define (GLOBAL-SET! i m) 92 | (let ((sym (global-ref i))) 93 | `(,m 94 | (mov ,(deref sym) ,*val*)))) 95 | 96 | (define (GLOBAL-REF i) 97 | `((mov ,*val* ,(deref i)))) 98 | 99 | (define (PUSH v) 100 | (_PUSH (reg-or-val v))) 101 | 102 | (define (_PUSH v) 103 | `((push ,v))) 104 | 105 | (define (POP v) 106 | `((pop ,v))) 107 | 108 | (define (STORE-ARGUMENT m m* rank) 109 | (append (m) 110 | `(PUSH ,*val*) 111 | (m*) 112 | `(POP ,*val*))) 113 | 114 | (define (FIX-CLOSURE m+) 115 | (append (m+) 116 | ; TODO: make closure and move it to *val* 117 | )) 118 | 119 | (define (REGULAR-CALL m m*) 120 | `(,m 121 | (push ,*val*) 122 | ,m* 123 | (pop ,*fun*) 124 | (push ,*env*) 125 | (call ,*fun*) 126 | (pop ,*env*))) 127 | 128 | (define (JMP l) 129 | `(jmp ,l)) 130 | 131 | (define (MALLOC n) 132 | (CCALL 'malloc n)) 133 | 134 | (define (CONS) ; cons top two stack values 135 | `(,@(MALLOC (* 2 word-size)) 136 | ,@(POP *t1*) ; car 137 | ,@(POP *t2*) ; cdr 138 | (mov ,(deref *val*) ,*t1*) 139 | (mov ,(deref *val* '+ word-size) ,*t2*) 140 | (or ,*val* ,cons-tag))) 141 | 142 | (define (CMP-NIL r) 143 | ; TODO: cmp nil tag against reg r 144 | '()) 145 | 146 | (define (JMP-FALSE l) 147 | `(,@(CMP-NIL *val*) 148 | (je ,l))) 149 | 150 | (define (CAR) 151 | ; TODO: assert type 152 | `((mov ,*val* ,(deref *val* '- cons-tag)))) 153 | 154 | (define (CDR) 155 | ; TODO: assert type 156 | `((mov ,*val* ,(deref *val* '+ (- word-size cons-tag))))) 157 | 158 | (define (CCALL f . args) 159 | `(,@(append-map (lambda (i) 160 | (cond 161 | ((list? i) 162 | (append i (_PUSH *val*))) 163 | (else (_PUSH i)))) 164 | (reverse args)) 165 | (extern ,f) 166 | (call ,f) 167 | ,@(concatenate (make-list (length args) (POP *t1*))) 168 | )) 169 | 170 | (define (ALTERNATIVE con t e) 171 | (let ((le (gensym 'else)) (ld (gensym 'd))) 172 | (append 173 | con 174 | (JMP-FALSE le) 175 | t (JMP ld) 176 | le e 177 | ld))) 178 | 179 | (define (STRING s) 180 | `(,@(MALLOC (+ short-size (string-length s))) 181 | (mov ,(tsize 'word (deref *val*)) ,(string-length s)) 182 | ,@(map (with-index 183 | (lambda (e i) 184 | `(mov ,(tsize 'byte (deref *val* '+ (+ short-size i))) 185 | ,(char->integer e)))) 186 | (string->list s)) 187 | (or ,*val* ,str-tag))) 188 | 189 | (define (VEC n) 190 | ; [n (h) | v1 (w) | v2 (w) ...] 191 | `(,@(MALLOC (+ short-size (* word-size n))) 192 | (mov ,(tsize 'word (deref *val*)) ,n) 193 | (or ,*val* ,vec-tag))) 194 | 195 | (define (VEC-REF) ; *val* = *STACK[*val*] 196 | ; TODO: assert that vec ref is within arr bounds 197 | `((shl ,*val* ,(logn word-size 2)) ; (* *val* word-size) using bitshifts :D 198 | (mov ,*val* ,(deref *sp* '+ short-size '+ *val*)))) 199 | 200 | (define (VEC-SET!) ; *STACK[POP(STACK)] = *val* 201 | ; TODO: assert vec ref is within arr bounds 202 | `("vset" 203 | ,@(POP *t1*) 204 | (shl ,*t1* ,(logn word-size 2)) 205 | (mov ,*t2* ,(deref *sp*)) 206 | (mov ,(deref *t2* '- 5 '+ *t1*) ,*val*))) 207 | 208 | (define (FUN-PROLOGUE) 209 | `((push ebp) 210 | (mov ebp esp))) 211 | 212 | (define (FUN-EPILOGUE) 213 | `((pop ebp) 214 | (ret))) 215 | 216 | (define (print-instr i) 217 | (cond 218 | ((string? i) (print i ":")) 219 | ((display "\t") 220 | (display (car i)) 221 | (display " ") 222 | (print (string-join (map ->string (cdr i)) ","))))) 223 | 224 | (print "section .text") 225 | (print "global po_entry") 226 | (print "extern malloc") 227 | (print "extern symtab") 228 | (print-instr "po_entry") 229 | (map print-instr 230 | (append 231 | (FUN-PROLOGUE) 232 | 233 | ; DIS IS ALL BORKED 234 | (VEC 3) 235 | (PUSH *val*) 236 | (_PUSH 2) 237 | (_CONST 2) 238 | (VEC-SET!) 239 | 240 | 241 | (_CONST 2) 242 | (VEC-REF) 243 | 244 | (POP *t1*) 245 | 246 | ;`((mov ,*t1* ,*val*)) 247 | (CCALL 'printf (STRING " hi 0x%x\n") *val*) 248 | 249 | ;(SYMBOL 'blah) 250 | ;`((mov ,*t1* ,*val*)) 251 | ;(CCALL 'printf (STRING " %x\n") *t1*) 252 | 253 | (FUN-EPILOGUE) 254 | )) 255 | 256 | (map print-instr (CCALL 'exit 0)) 257 | 258 | (print "section .data") 259 | (for-each (lambda (l) 260 | (print (conc (hash-table-ref global-vars l) " " 'dw " " 0))) 261 | (hash-table-keys global-vars)) 262 | --------------------------------------------------------------------------------