;;;; 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))) ; 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)))) (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) (prog1 (io->str bcode) (io-close 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? 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 (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)) (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 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 'loade8 #.(logior 1 (ash 1 3))) ; NIL (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)) (n (compile-arglist g env args))) (let ((newvars (vars-to-env vars (complex-bindings (caddr lam) vars) sp))) (box-vars g newvars) (let ((newenv (cons (nconc newvars (car env)) (cdr env)))) (compile-in g newenv tail? (caddr lam)) (bcode:stack g (- n)) (when (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 (begin (let {[nargs (compile-arglist g env (cdr x))]} (bcode:stack g (- nargs)) (compile-builtin-call g env tail? x head b nargs))) (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)) ((not x) (emit g 'loade8 #.(logior 1 (ash 1 3)))) ; NIL ((eq? x T) (emit g 'loade8 #.(logior 1 (ash 2 3)))) ; T ((void? x) (emit g 'loade8 #.(logior 1 (ash 3 3)))) ; #<void> ((fits-i8 x) (emit g 'loadi8 x)) (else (emit g 'loadv x)))) ((eq? (car x) 'aset!) (compile-aset! g env (cdr x))) ((or (not (sym? (car x))) (bound? (car x)) (in-env? (car x) env)) (compile-app g env tail? x)) ((or (eq? (car x) '$set!) (eq? (car x) '$set!-)) (let {[name (cadr x)] [value (caddr x)] [nargs (length (cdr x))]} (unless (= nargs 2) (compile-error "set!: arity error: expected 2, got " nargs)) (unless (sym? name) (type-error 'sym name "set!" "name")) (when (eq? name value) (compile-error "set!: useless assignment to itself")) (compile-set! g env name value (eq? (car x) '$set!)))) (else (case (car x) ($quote (if (self-evaluating? (cadr x)) (compile-in g env tail? (cadr x)) (emit g 'loadv (cadr x)))) ($if (compile-if g env tail? x)) ($begin (compile-begin g env tail? (cdr x))) ($prog1 (compile-prog1 g env x)) (λ (receive (the-f cenv) (compile-f- env x) (begin (emit g 'loadv the-f) (when cenv (for-each (λ (var) (compile-sym g env var NIL))Lines 1–500 of 871. 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))) ; 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)))) (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) (prog1 (io->str bcode) (io-close 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? 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 (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)) (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 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 'loade8 #.(logior 1 (ash 1 3))) ; NIL (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)) (n (compile-arglist g env args))) (let ((newvars (vars-to-env vars (complex-bindings (caddr lam) vars) sp))) (box-vars g newvars) (let ((newenv (cons (nconc newvars (car env)) (cdr env)))) (compile-in g newenv tail? (caddr lam)) (bcode:stack g (- n)) (when (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 (begin (let {[nargs (compile-arglist g env (cdr x))]} (bcode:stack g (- nargs)) (compile-builtin-call g env tail? x head b nargs))) (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)) ((not x) (emit g 'loade8 #.(logior 1 (ash 1 3)))) ; NIL ((eq? x T) (emit g 'loade8 #.(logior 1 (ash 2 3)))) ; T ((void? x) (emit g 'loade8 #.(logior 1 (ash 3 3)))) ; #<void> ((fits-i8 x) (emit g 'loadi8 x)) (else (emit g 'loadv x)))) ((eq? (car x) 'aset!) (compile-aset! g env (cdr x))) ((or (not (sym? (car x))) (bound? (car x)) (in-env? (car x) env)) (compile-app g env tail? x)) ((or (eq? (car x) '$set!) (eq? (car x) '$set!-)) (let {[name (cadr x)] [value (caddr x)] [nargs (length (cdr x))]} (unless (= nargs 2) (compile-error "set!: arity error: expected 2, got " nargs)) (unless (sym? name) (type-error 'sym name "set!" "name")) (when (eq? name value) (compile-error "set!: useless assignment to itself")) (compile-set! g env name value (eq? (car x) '$set!)))) (else (case (car x) ($quote (if (self-evaluating? (cadr x)) (compile-in g env tail? (cadr x)) (emit g 'loadv (cadr x)))) ($if (compile-if g env tail? x)) ($begin (compile-begin g env tail? (cdr x))) ($prog1 (compile-prog1 g env x)) (λ (receive (the-f cenv) (compile-f- env x) (begin (emit g 'loadv the-f) (when cenv (for-each (λ (var) (compile-sym g env var NIL))