;;;; built-in compiler ;; code generation state, constant tables, bytecode encoding(def (make-code-emitter) (vec NIL (table) 0 NIL 0 0))(defmacro (bcode:code b) `(aref ,b 0))(defmacro (bcode:ctable b) `(aref ,b 1))(defmacro (bcode:nconst b) `(aref ,b 2))(defmacro (bcode:cenv b) `(aref ,b 3))(defmacro (bcode:sp b) `(aref ,b 4))(defmacro (bcode:spmax b) `(aref ,b 5))(def (bcode:stack b n) (let ((sp (+ (bcode:sp b) n))) (when (> sp (bcode:spmax b)) (aset! b 5 sp)) (aset! b 4 sp))) (def (compile-error . rest) (apply error (cons "compile: " rest))) ;; get an index for a referenced value in a bytecode object(def (bcode:indexfor b v) (let ((const-to-idx (bcode:ctable b)) (nconst (bcode:nconst b))) (if (has? const-to-idx v) (get const-to-idx v) (put! const-to-idx v nconst) (prog1 nconst (aset! b 2 (+ nconst 1)))))) (def (emit e inst . args) (def (load? i) (memq i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet (let ((bc (aref e 0))) (if (not args) (if (and (eq? inst 'car) (eq? (car bc) 'cdr)) (set-car! bc 'cadr) (cond ((and (eq? inst 'pop) (load? (car bc))) (aset! e 0 (cdr bc))) (else (aset! e 0 (cons inst bc))))) (when (memq inst '(loadv loadg setg)) (set! args (list (bcode:indexfor e (car args))))) (let ((longform (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta seta.l) (box box.l))))) (when (and longform (> (car args) 255)) (set! inst (cadr longform)))) (let ((longform (assq inst '((loadc loadc.l))))) (when (and longform (> (car args) 255)) (set! inst (cadr longform)))) (if (eq? inst 'loada) (cond ((equal? args '(0)) (set! inst 'loada0 args NIL)) ((equal? args '(1)) (set! inst 'loada1 args NIL))) (when (eq? inst 'loadc) (cond ((equal? args '(0)) (set! inst 'loadc0 args NIL)) ((equal? args '(1)) (set! inst 'loadc1 args NIL))))) (let ((lasti (car bc))) (cond ((and (eq? inst 'brn) (cond ((eq? lasti 'not) (aset! e 0 (cons (car args) (cons 'brnn (cdr bc))))) ((eq? lasti 'eq?) (aset! e 0 (cons (car args) (cons 'brne (cdr bc))))) (else NIL)))) (else (aset! e 0 (nreconc (cons inst args) bc)))))) e)) (defmacro (make-label e) `(gensym))(defmacro (mark-label e l) `(emit ,e 'label ,l)) ;; convert symbolic bytecode representation to a byte array.;; labels are fixed-up.(def (encode-byte-code e) (let* {[cl (reverse! e)] [v (list->vec cl)] [n (length v)] [long? (>= (+ n ;; 1 byte for each entry, plus... ;; at most half the entries in this vector can be ;; instructions accepting 32-bit arguments (* 3 (div0 n 2))) 65536)] [label-to-loc (table)] [fixup-to-label (table)] [bcode (buffer)] [vi NIL] [nxt NIL] [i 0]} (while (< i n) (set! vi (aref v i)) (if (eq? vi 'label) (begin (put! label-to-loc (aref v (+ i 1)) (size-of bcode)) (set! i (+ i 2))) (io-write bcode (get Instructions (if long? (case vi (jmp 'jmp.l) (brne 'brne.l) (brnn 'brnn.l) (brn 'brn.l) (else vi)) vi))) (set! i (+ i 1) nxt (and (< i n) (aref v i))) (cond ((memq vi '(jmp brne brnn brn)) (put! fixup-to-label (size-of bcode) nxt) (io-write bcode ((if long? s32 s16) 0)) (set! i (+ i 1))) ((eq? vi 'bounda) (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1))) ((num? nxt) (case vi ((loadv.l loadg.l setg.l loada.l seta.l argc.l vargc.l call.l tcall.l loadc.l box.l) (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1))) ((optargs keyargs) ; 2 s32 args (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1)) (io-write bcode (s32 (aref v i)) :little-endian) (set! i (+ i 1)) (when (eq? vi 'keyargs) (io-write bcode (s32 (aref v i)) :little-endian) (set! i (+ i 1)))) (else ; other number arguments are always u8 (io-write bcode (u8 nxt)) (set! i (+ i 1))))) (else NIL)))) (for-each (λ (addr labl) (io-pos! bcode addr) (io-write bcode ((if long? s32 s16) (- (get label-to-loc labl) addr)) :little-endian)) fixup-to-label) (io->str bcode))) (def (const-to-idx-vec e) (let ((cvec (vec-alloc (bcode:nconst e)))) (for-each (λ (val idx) (aset! cvec idx val)) (bcode:ctable e)) cvec)) ;; variables (def (vinfo symbol heap? index) (list symbol heap? index))(def vinfo:sym car)(def vinfo:heap? cadr)(def vinfo:index caddr) (def (quoted? e) (eq? (car e) '$quote)) (def (capture-var! g s) (def (index-of item lst start) (cond ((not lst) NIL) ((eq? item (car lst)) start) (else (index-of item (cdr lst) (+ start 1))))) (let* {[ce (bcode:cenv g)] [n (index-of s ce 0)]} (or n (prog1 (length ce) (aset! g 3 (nconc ce (list s))))))) (def (in-env? s env) (and (cons? env) (or (assq s (car env)) (in-env? s (cdr env))))) (def (lookup-sym s env lev) (if (not env) 'global (let* ((curr (car env)) (vi (assq s curr))) (if vi (cons lev vi) (lookup-sym s (cdr env) (+ lev 1)))))) (def (compile-sym g env s deref) (def (printable? x) (not (or (io? x) (void? x) (eof-object? x)))) (let ((loc (lookup-sym s env 0))) (cond ((eq? loc 'global) (if (and (const? s) (printable? (top-level-value s)) (not (or (<= '*a s '*z) (<= '+a s '+z)))) (emit g 'loadv (top-level-value s)) (emit g 'loadg s))) ((= (car loc) 0) (emit g 'loada (vinfo:index (cdr loc))) (when (and deref (vinfo:heap? (cdr loc))) (emit g 'car))) (else (emit g 'loadc (capture-var! g s)) (when (and deref (vinfo:heap? (cdr loc))) (emit g 'car)))))) (def (compile-aset! g env args) (let ((nref (- (length args) 2))) (cond ((= nref 1) (compile-app g env NIL (cons 'aset! args))) ((> nref 1) (compile-app g env NIL (cons 'aref (subseq args 0 nref))) (let ((nargs (compile-arglist g env (subseq args nref)))) (bcode:stack g (- nargs)) (emit g 'aset!))) (else (argc-error 'aset! 3))))) (def (compile-set! g env s rhs (err-no-def NIL)) (let ((loc (lookup-sym s env 0))) (if (eq? loc 'global) (begin (when (and err-no-def (not (bound? s))) (compile-error "undefined variable: " s)) (compile-in g env NIL rhs) (emit g 'setg s)) (let* {[h? (vinfo:heap? (cdr loc))] [arg? (= (car loc) 0)] [idx (if arg? (vinfo:index (cdr loc)) (capture-var! g s))]} (if h? (begin (emit g (if arg? 'loada 'loadc) idx) (bcode:stack g 1) (compile-in g env NIL rhs) (bcode:stack g -1) (emit g 'set-car!)) (compile-in g env NIL rhs) (unless arg? (error (str "internal error: misallocated var " s))) (emit g 'seta idx)))))) (def (box-vars g env) (let loop ((e env)) (when (cons? e) (when (cadr (car e)) (emit g 'box (caddr (car e)))) (loop (cdr e))))) ;; control flow (def (compile-if g env tail? x) (let ((thenl (make-label g)) (elsel (make-label g)) (endl (make-label g)) (test (cadr x)) (then (caddr x)) (else (if (cons? (cdddr x)) (cadddr x) NIL))) (cond ((eq? test T) (compile-in g env tail? then)) ((not test) (compile-in g env tail? else)) (else (compile-in g env NIL test elsel) (emit g 'brn elsel) (mark-label g thenl) (compile-in g env tail? then) (if tail? (emit g 'ret) (emit g 'jmp endl)) (mark-label g elsel) (compile-in g env tail? else) (mark-label g endl))))) (def (compile-begin g env tail? forms) (cond ((atom? forms) (compile-in g env tail? (void))) ((atom? (cdr forms)) (compile-in g env tail? (car forms))) (else (compile-in g env NIL (car forms)) (emit g 'pop) (compile-begin g env tail? (cdr forms))))) (def (compile-prog1 g env x) (compile-in g env NIL (cadr x)) (when (cons? (cddr x)) (bcode:stack g 1) (compile-begin g env NIL (cddr x)) (emit g 'pop) (bcode:stack g -1))) (def (compile-while g env cond body) (let ((top (make-label g)) (end (make-label g))) (compile-in g env NIL (void)) (bcode:stack g 1) (mark-label g top) (compile-in g env NIL cond) (emit g 'brn end) (emit g 'pop) (bcode:stack g -1) (compile-in g env NIL body) (emit g 'jmp top) (mark-label g end))) (def (1arg-lambda? func) (and (cons? func) (eq? (car func) 'λ) (cons? (cadr func)) (length= (cadr func) 1))) (def (compile-short-circuit g env tail? forms default branch outl) (cond ((atom? forms) (compile-in g env tail? default outl)) ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl)) (else (let ((end (or outl (make-label g)))) (compile-in g env NIL (car forms) outl) (bcode:stack g 1) (unless outl (emit g 'dup)) (emit g branch end) (bcode:stack g -1) (unless outl (emit g 'pop)) (compile-short-circuit g env tail? (cdr forms) default branch outl) (unless outl (mark-label g end)))))) (def (compile-and g env tail? forms outl) (compile-short-circuit g env tail? forms T 'brn outl))(def (compile-or g env tail? forms) (compile-short-circuit g env tail? forms NIL 'brnn NIL)) ;; calls (def (compile-arglist g env lst) (for-each (λ (a) (compile-in g env NIL a) (bcode:stack g 1)) lst) (length lst)) ; do a map here. return it with the offsets of each one.; compile-in needs to return extra stack offset.(def (compile-arglist-let g env lst) (map (λ (a) (let* {[c (compile-in g env NIL a)] [shift (if (num? c) c 0)]} (bcode:stack g (1+ shift)) shift)) lst)) (def (argc-error head count) (compile-error head " expects " count (if (= count 1) " argument." " arguments."))) (def builtin->instruction (let ((b2i (table num? 'num? cons 'cons stkcons 'stkcons fixnum? 'fixnum? equal? 'equal? eq? 'eq? sym? 'sym? div0 'div0 builtin? 'builtin? aset! 'aset! - '- not 'not apply 'apply atom? 'atom? nan? 'nan? set-cdr! 'set-cdr! / '/ fn? 'fn? vec 'vec list 'list bound? 'bound? < '< * '* cdr 'cdr cadr 'cadr + '+ eqv? 'eqv? compare 'compare aref 'aref set-car! 'set-car! car 'car cons? 'cons? = '= vec? 'vec?))) (λ (b) (get b2i b NIL)))) (def (compile-builtin-call g env tail? x head b nargs) (def (num-compare) (if (= nargs 0) (argc-error b 1) (emit g b nargs))) (let ((count (get arg-counts b NIL))) (when (and count (not (length= (cdr x) count))) (argc-error b count)) (case b ; handle special cases of vararg builtins (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs))) (< (num-compare)) (= (num-compare)) (+ (cond ((= nargs 0) (emit g 'load0)) ((= nargs 2) (emit g 'add2)) (else (emit g b nargs)))) (- (cond ((= nargs 0) (argc-error b 1)) ((= nargs 1) (emit g 'neg)) ((= nargs 2) (emit g 'sub2)) (else (emit g b nargs)))) (* (if (= nargs 0) (emit g 'load1) (emit g b nargs))) (/ (if (= nargs 0) (argc-error b 1) (emit g b nargs))) (vec (if (= nargs 0) (emit g 'loadv #()) (emit g b nargs))) (apply (if (< nargs 2) (argc-error b 2) (emit g (if tail? 'tapply 'apply) nargs))) (aref (cond ((= nargs 2) (emit g 'aref2)) ((> nargs 2) (emit g b (- nargs 3))) (else (argc-error b 2)))) (else (emit g b))))) (def (inlineable? form) (let ((lam (car form))) (and (cons? lam) (eq? (car lam) 'λ) (proper-list? (cadr lam)) (every sym? (cadr lam)) (not (length> (cadr lam) 255)) (length= (cadr lam) (length (cdr form)))))) ;; compile call to lambda in head position, inlined(def (compile-let g env tail? form) (let ((lam (car form)) (args (cdr form)) (sp (bcode:sp g))) (let ((vars (cadr lam)) (shifts (compile-arglist-let g env args))) (let {[newvars (vars-to-env-let vars shifts (complex-bindings (caddr lam) vars) sp)] [n (+ (length shifts) (apply + shifts))]} (box-vars g newvars) (let ((newenv (cons (nconc newvars (car env)) (cdr env)))) (prog1 (compile-in g newenv tail? (caddr lam)) (bcode:stack g (- n)) (and (> n 0) (not tail?)) (emit g 'shift n))))))) (def (compile-app g env tail? x) (let* {[head (car x)] [head (if (and (sym? head) (not (in-env? head env)) (bound? head) (builtin? (top-level-value head))) (top-level-value head) head)] [b (and (builtin? head) (builtin->instruction head))]} (if (length> (cdr x) 255) ;; more than 255 arguments, need long versions of instructions (begin (compile-in g env NIL head) (bcode:stack g 1) (let ((nargs (compile-arglist g env (cdr x)))) (bcode:stack g (- nargs)) (emit g (if tail? 'tcall.l 'call.l) nargs))) (if (and (cons? head) (eq? (car head) 'λ) (inlineable? x)) (compile-let g env tail? x) (if b (let {[nargs (compile-arglist g env (cdr x))]} (bcode:stack g (- nargs)) (compile-builtin-call g env tail? x head b nargs) (and (eq? b 'stkcons) 2)) (prog1 (compile-in g env NIL head) (bcode:stack g 1) (let* {[nargs (compile-arglist g env (cdr x))] [loc (and (sym? head) (lookup-sym head env 0))] [fn (and (eq? loc 'global) (bound? head) (top-level-value head))] [code (and (closure? fn) (fn-code fn))] [argc? (and code (= (aref code 0) (get Instructions 'argc)))] [argc (and argc? (aref code 1))]} (unless (or (not argc) (= argc nargs)) (compile-error "arity error: expected " argc ", got " nargs)) (bcode:stack g (- nargs)) (bcode:stack g -1) (emit g (if tail? 'tcall 'call) nargs)))))))) ;; lambda, main compilation loop (def (compile-in g env tail? x (outl NIL)) (def (fits-i8 x) (and (fixnum? x) (>= 127 x -128))) (cond ((sym? x) (compile-sym g env x T)) ((atom? x) (cond ((eq? x 0) (emit g 'load0)) ((eq? x 1) (emit g 'load1)) ((eq? x T) (emit g 'loadt)) ((not x) (emit g 'loadnil)) ((void? x) (emit g 'loadvoid)) ((fits-i8 x) (emit g 'loadi8 x)) (else (emit g 'loadv x)))) ((eq? (car x) 'aset!) (compile-aset! g env (cdr x)))Lines 1–500 of 898. Load more
;;;; built-in compiler ;; code generation state, constant tables, bytecode encoding (def (make-code-emitter) (vec NIL (table) 0 NIL 0 0)) (defmacro (bcode:code b) `(aref ,b 0)) (defmacro (bcode:ctable b) `(aref ,b 1)) (defmacro (bcode:nconst b) `(aref ,b 2)) (defmacro (bcode:cenv b) `(aref ,b 3)) (defmacro (bcode:sp b) `(aref ,b 4)) (defmacro (bcode:spmax b) `(aref ,b 5)) (def (bcode:stack b n) (let ((sp (+ (bcode:sp b) n))) (when (> sp (bcode:spmax b)) (aset! b 5 sp)) (aset! b 4 sp))) (def (compile-error . rest) (apply error (cons "compile: " rest))) ;; get an index for a referenced value in a bytecode object (def (bcode:indexfor b v) (let ((const-to-idx (bcode:ctable b)) (nconst (bcode:nconst b))) (if (has? const-to-idx v) (get const-to-idx v) (put! const-to-idx v nconst) (prog1 nconst (aset! b 2 (+ nconst 1)))))) (def (emit e inst . args) (def (load? i) (memq i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet (let ((bc (aref e 0))) (if (not args) (if (and (eq? inst 'car) (eq? (car bc) 'cdr)) (set-car! bc 'cadr) (cond ((and (eq? inst 'pop) (load? (car bc))) (aset! e 0 (cdr bc))) (else (aset! e 0 (cons inst bc))))) (when (memq inst '(loadv loadg setg)) (set! args (list (bcode:indexfor e (car args))))) (let ((longform (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta seta.l) (box box.l))))) (when (and longform (> (car args) 255)) (set! inst (cadr longform)))) (let ((longform (assq inst '((loadc loadc.l))))) (when (and longform (> (car args) 255)) (set! inst (cadr longform)))) (if (eq? inst 'loada) (cond ((equal? args '(0)) (set! inst 'loada0 args NIL)) ((equal? args '(1)) (set! inst 'loada1 args NIL))) (when (eq? inst 'loadc) (cond ((equal? args '(0)) (set! inst 'loadc0 args NIL)) ((equal? args '(1)) (set! inst 'loadc1 args NIL))))) (let ((lasti (car bc))) (cond ((and (eq? inst 'brn) (cond ((eq? lasti 'not) (aset! e 0 (cons (car args) (cons 'brnn (cdr bc))))) ((eq? lasti 'eq?) (aset! e 0 (cons (car args) (cons 'brne (cdr bc))))) (else NIL)))) (else (aset! e 0 (nreconc (cons inst args) bc)))))) e)) (defmacro (make-label e) `(gensym)) (defmacro (mark-label e l) `(emit ,e 'label ,l)) ;; convert symbolic bytecode representation to a byte array. ;; labels are fixed-up. (def (encode-byte-code e) (let* {[cl (reverse! e)] [v (list->vec cl)] [n (length v)] [long? (>= (+ n ;; 1 byte for each entry, plus... ;; at most half the entries in this vector can be ;; instructions accepting 32-bit arguments (* 3 (div0 n 2))) 65536)] [label-to-loc (table)] [fixup-to-label (table)] [bcode (buffer)] [vi NIL] [nxt NIL] [i 0]} (while (< i n) (set! vi (aref v i)) (if (eq? vi 'label) (begin (put! label-to-loc (aref v (+ i 1)) (size-of bcode)) (set! i (+ i 2))) (io-write bcode (get Instructions (if long? (case vi (jmp 'jmp.l) (brne 'brne.l) (brnn 'brnn.l) (brn 'brn.l) (else vi)) vi))) (set! i (+ i 1) nxt (and (< i n) (aref v i))) (cond ((memq vi '(jmp brne brnn brn)) (put! fixup-to-label (size-of bcode) nxt) (io-write bcode ((if long? s32 s16) 0)) (set! i (+ i 1))) ((eq? vi 'bounda) (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1))) ((num? nxt) (case vi ((loadv.l loadg.l setg.l loada.l seta.l argc.l vargc.l call.l tcall.l loadc.l box.l) (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1))) ((optargs keyargs) ; 2 s32 args (io-write bcode (s32 nxt) :little-endian) (set! i (+ i 1)) (io-write bcode (s32 (aref v i)) :little-endian) (set! i (+ i 1)) (when (eq? vi 'keyargs) (io-write bcode (s32 (aref v i)) :little-endian) (set! i (+ i 1)))) (else ; other number arguments are always u8 (io-write bcode (u8 nxt)) (set! i (+ i 1))))) (else NIL)))) (for-each (λ (addr labl) (io-pos! bcode addr) (io-write bcode ((if long? s32 s16) (- (get label-to-loc labl) addr)) :little-endian)) fixup-to-label) (io->str bcode))) (def (const-to-idx-vec e) (let ((cvec (vec-alloc (bcode:nconst e)))) (for-each (λ (val idx) (aset! cvec idx val)) (bcode:ctable e)) cvec)) ;; variables (def (vinfo symbol heap? index) (list symbol heap? index)) (def vinfo:sym car) (def vinfo:heap? cadr) (def vinfo:index caddr) (def (quoted? e) (eq? (car e) '$quote)) (def (capture-var! g s) (def (index-of item lst start) (cond ((not lst) NIL) ((eq? item (car lst)) start) (else (index-of item (cdr lst) (+ start 1))))) (let* {[ce (bcode:cenv g)] [n (index-of s ce 0)]} (or n (prog1 (length ce) (aset! g 3 (nconc ce (list s))))))) (def (in-env? s env) (and (cons? env) (or (assq s (car env)) (in-env? s (cdr env))))) (def (lookup-sym s env lev) (if (not env) 'global (let* ((curr (car env)) (vi (assq s curr))) (if vi (cons lev vi) (lookup-sym s (cdr env) (+ lev 1)))))) (def (compile-sym g env s deref) (def (printable? x) (not (or (io? x) (void? x) (eof-object? x)))) (let ((loc (lookup-sym s env 0))) (cond ((eq? loc 'global) (if (and (const? s) (printable? (top-level-value s)) (not (or (<= '*a s '*z) (<= '+a s '+z)))) (emit g 'loadv (top-level-value s)) (emit g 'loadg s))) ((= (car loc) 0) (emit g 'loada (vinfo:index (cdr loc))) (when (and deref (vinfo:heap? (cdr loc))) (emit g 'car))) (else (emit g 'loadc (capture-var! g s)) (when (and deref (vinfo:heap? (cdr loc))) (emit g 'car)))))) (def (compile-aset! g env args) (let ((nref (- (length args) 2))) (cond ((= nref 1) (compile-app g env NIL (cons 'aset! args))) ((> nref 1) (compile-app g env NIL (cons 'aref (subseq args 0 nref))) (let ((nargs (compile-arglist g env (subseq args nref)))) (bcode:stack g (- nargs)) (emit g 'aset!))) (else (argc-error 'aset! 3))))) (def (compile-set! g env s rhs (err-no-def NIL)) (let ((loc (lookup-sym s env 0))) (if (eq? loc 'global) (begin (when (and err-no-def (not (bound? s))) (compile-error "undefined variable: " s)) (compile-in g env NIL rhs) (emit g 'setg s)) (let* {[h? (vinfo:heap? (cdr loc))] [arg? (= (car loc) 0)] [idx (if arg? (vinfo:index (cdr loc)) (capture-var! g s))]} (if h? (begin (emit g (if arg? 'loada 'loadc) idx) (bcode:stack g 1) (compile-in g env NIL rhs) (bcode:stack g -1) (emit g 'set-car!)) (compile-in g env NIL rhs) (unless arg? (error (str "internal error: misallocated var " s))) (emit g 'seta idx)))))) (def (box-vars g env) (let loop ((e env)) (when (cons? e) (when (cadr (car e)) (emit g 'box (caddr (car e)))) (loop (cdr e))))) ;; control flow (def (compile-if g env tail? x) (let ((thenl (make-label g)) (elsel (make-label g)) (endl (make-label g)) (test (cadr x)) (then (caddr x)) (else (if (cons? (cdddr x)) (cadddr x) NIL))) (cond ((eq? test T) (compile-in g env tail? then)) ((not test) (compile-in g env tail? else)) (else (compile-in g env NIL test elsel) (emit g 'brn elsel) (mark-label g thenl) (compile-in g env tail? then) (if tail? (emit g 'ret) (emit g 'jmp endl)) (mark-label g elsel) (compile-in g env tail? else) (mark-label g endl))))) (def (compile-begin g env tail? forms) (cond ((atom? forms) (compile-in g env tail? (void))) ((atom? (cdr forms)) (compile-in g env tail? (car forms))) (else (compile-in g env NIL (car forms)) (emit g 'pop) (compile-begin g env tail? (cdr forms))))) (def (compile-prog1 g env x) (compile-in g env NIL (cadr x)) (when (cons? (cddr x)) (bcode:stack g 1) (compile-begin g env NIL (cddr x)) (emit g 'pop) (bcode:stack g -1))) (def (compile-while g env cond body) (let ((top (make-label g)) (end (make-label g))) (compile-in g env NIL (void)) (bcode:stack g 1) (mark-label g top) (compile-in g env NIL cond) (emit g 'brn end) (emit g 'pop) (bcode:stack g -1) (compile-in g env NIL body) (emit g 'jmp top) (mark-label g end))) (def (1arg-lambda? func) (and (cons? func) (eq? (car func) 'λ) (cons? (cadr func)) (length= (cadr func) 1))) (def (compile-short-circuit g env tail? forms default branch outl) (cond ((atom? forms) (compile-in g env tail? default outl)) ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl)) (else (let ((end (or outl (make-label g)))) (compile-in g env NIL (car forms) outl) (bcode:stack g 1) (unless outl (emit g 'dup)) (emit g branch end) (bcode:stack g -1) (unless outl (emit g 'pop)) (compile-short-circuit g env tail? (cdr forms) default branch outl) (unless outl (mark-label g end)))))) (def (compile-and g env tail? forms outl) (compile-short-circuit g env tail? forms T 'brn outl)) (def (compile-or g env tail? forms) (compile-short-circuit g env tail? forms NIL 'brnn NIL)) ;; calls (def (compile-arglist g env lst) (for-each (λ (a) (compile-in g env NIL a) (bcode:stack g 1)) lst) (length lst)) ; do a map here. return it with the offsets of each one. ; compile-in needs to return extra stack offset. (def (compile-arglist-let g env lst) (map (λ (a) (let* {[c (compile-in g env NIL a)] [shift (if (num? c) c 0)]} (bcode:stack g (1+ shift)) shift)) lst)) (def (argc-error head count) (compile-error head " expects " count (if (= count 1) " argument." " arguments."))) (def builtin->instruction (let ((b2i (table num? 'num? cons 'cons stkcons 'stkcons fixnum? 'fixnum? equal? 'equal? eq? 'eq? sym? 'sym? div0 'div0 builtin? 'builtin? aset! 'aset! - '- not 'not apply 'apply atom? 'atom? nan? 'nan? set-cdr! 'set-cdr! / '/ fn? 'fn? vec 'vec list 'list bound? 'bound? < '< * '* cdr 'cdr cadr 'cadr + '+ eqv? 'eqv? compare 'compare aref 'aref set-car! 'set-car! car 'car cons? 'cons? = '= vec? 'vec?))) (λ (b) (get b2i b NIL)))) (def (compile-builtin-call g env tail? x head b nargs) (def (num-compare) (if (= nargs 0) (argc-error b 1) (emit g b nargs))) (let ((count (get arg-counts b NIL))) (when (and count (not (length= (cdr x) count))) (argc-error b count)) (case b ; handle special cases of vararg builtins (list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs))) (< (num-compare)) (= (num-compare)) (+ (cond ((= nargs 0) (emit g 'load0)) ((= nargs 2) (emit g 'add2)) (else (emit g b nargs)))) (- (cond ((= nargs 0) (argc-error b 1)) ((= nargs 1) (emit g 'neg)) ((= nargs 2) (emit g 'sub2)) (else (emit g b nargs)))) (* (if (= nargs 0) (emit g 'load1) (emit g b nargs))) (/ (if (= nargs 0) (argc-error b 1) (emit g b nargs))) (vec (if (= nargs 0) (emit g 'loadv #()) (emit g b nargs))) (apply (if (< nargs 2) (argc-error b 2) (emit g (if tail? 'tapply 'apply) nargs))) (aref (cond ((= nargs 2) (emit g 'aref2)) ((> nargs 2) (emit g b (- nargs 3))) (else (argc-error b 2)))) (else (emit g b))))) (def (inlineable? form) (let ((lam (car form))) (and (cons? lam) (eq? (car lam) 'λ) (proper-list? (cadr lam)) (every sym? (cadr lam)) (not (length> (cadr lam) 255)) (length= (cadr lam) (length (cdr form)))))) ;; compile call to lambda in head position, inlined (def (compile-let g env tail? form) (let ((lam (car form)) (args (cdr form)) (sp (bcode:sp g))) (let ((vars (cadr lam)) (shifts (compile-arglist-let g env args))) (let {[newvars (vars-to-env-let vars shifts (complex-bindings (caddr lam) vars) sp)] [n (+ (length shifts) (apply + shifts))]} (box-vars g newvars) (let ((newenv (cons (nconc newvars (car env)) (cdr env)))) (prog1 (compile-in g newenv tail? (caddr lam)) (bcode:stack g (- n)) (and (> n 0) (not tail?)) (emit g 'shift n))))))) (def (compile-app g env tail? x) (let* {[head (car x)] [head (if (and (sym? head) (not (in-env? head env)) (bound? head) (builtin? (top-level-value head))) (top-level-value head) head)] [b (and (builtin? head) (builtin->instruction head))]} (if (length> (cdr x) 255) ;; more than 255 arguments, need long versions of instructions (begin (compile-in g env NIL head) (bcode:stack g 1) (let ((nargs (compile-arglist g env (cdr x)))) (bcode:stack g (- nargs)) (emit g (if tail? 'tcall.l 'call.l) nargs))) (if (and (cons? head) (eq? (car head) 'λ) (inlineable? x)) (compile-let g env tail? x) (if b (let {[nargs (compile-arglist g env (cdr x))]} (bcode:stack g (- nargs)) (compile-builtin-call g env tail? x head b nargs) (and (eq? b 'stkcons) 2)) (prog1 (compile-in g env NIL head) (bcode:stack g 1) (let* {[nargs (compile-arglist g env (cdr x))] [loc (and (sym? head) (lookup-sym head env 0))] [fn (and (eq? loc 'global) (bound? head) (top-level-value head))] [code (and (closure? fn) (fn-code fn))] [argc? (and code (= (aref code 0) (get Instructions 'argc)))] [argc (and argc? (aref code 1))]} (unless (or (not argc) (= argc nargs)) (compile-error "arity error: expected " argc ", got " nargs)) (bcode:stack g (- nargs)) (bcode:stack g -1) (emit g (if tail? 'tcall 'call) nargs)))))))) ;; lambda, main compilation loop (def (compile-in g env tail? x (outl NIL)) (def (fits-i8 x) (and (fixnum? x) (>= 127 x -128))) (cond ((sym? x) (compile-sym g env x T)) ((atom? x) (cond ((eq? x 0) (emit g 'load0)) ((eq? x 1) (emit g 'load1)) ((eq? x T) (emit g 'loadt)) ((not x) (emit g 'loadnil)) ((void? x) (emit g 'loadvoid)) ((fits-i8 x) (emit g 'loadi8 x)) (else (emit g 'loadv x)))) ((eq? (car x) 'aset!) (compile-aset! g env (cdr x)))