ref: a4f25a806f45195df93398688e7e2683c2b73890
parent: 56cdb52a8ea9113e9a1d8d02656438e9d6ca950b
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Dec 1 08:29:43 EST 2024
compiler: emit: less aref calls
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -21,59 +21,58 @@
(aset! b 2 (+ nconst 1)))))))
(define (emit e inst . args)
- (if (null? args)
- (if (and (eq? inst 'car) (pair? (aref e 0))
- (eq? (car (aref e 0)) 'cdr))
- (set-car! (aref e 0) 'cadr)
- (aset! e 0 (cons inst (aref e 0))))
- (begin
- (if (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)))))
- (if (and longform
- (> (car args) 255))
- (set! inst (cadr longform))))
- (let ((longform
- (assq inst '((loadc loadc.l)))))
- (if (and longform (> (car args) 255))
- (set! inst (cadr longform))))
- (if (eq? inst 'loada)
- (cond ((equal? args '(0))
- (set! inst 'loada0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loada1)
- (set! args ()))))
- (if (eq? inst 'loadc)
- (cond ((equal? args '(0))
- (set! inst 'loadc0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loadc1)
- (set! args ()))))
+ (let ((bc (aref e 0)))
+ (if (null? args)
+ (if (and (eq? inst 'car) (pair? bc)
+ (eq? (car bc) 'cdr))
+ (set-car! bc 'cadr)
+ (aset! e 0 (cons inst bc)))
+ (begin
+ (if (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)))))
+ (if (and longform
+ (> (car args) 255))
+ (set! inst (cadr longform))))
+ (let ((longform
+ (assq inst '((loadc loadc.l)))))
+ (if (and longform (> (car args) 255))
+ (set! inst (cadr longform))))
+ (if (eq? inst 'loada)
+ (cond ((equal? args '(0))
+ (set! inst 'loada0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loada1)
+ (set! args ()))))
+ (if (eq? inst 'loadc)
+ (cond ((equal? args '(0))
+ (set! inst 'loadc0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loadc1)
+ (set! args ()))))
- (let ((lasti (if (pair? (aref e 0))
- (car (aref e 0)) ()))
- (bc (aref e 0)))
- (cond ((and
- (eq? inst 'brf)
- (cond ((and (eq? lasti 'not)
- (eq? (cadr bc) 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
- ((eq? lasti 'not)
- (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
- ((eq? lasti 'eq?)
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- ((eq? lasti 'null?)
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
- (else #f))))
- ((and (eq? inst 'brt) (eq? lasti 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
- (else
- (aset! e 0 (nreconc (cons inst args) bc)))))))
- e)
+ (let ((lasti (if (pair? bc)
+ (car bc) ())))
+ (cond ((and (eq? inst 'brf)
+ (cond ((and (eq? lasti 'not)
+ (eq? (cadr bc) 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
+ ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
+ ((eq? lasti 'null?)
+ (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ (else #f))))
+ ((and (eq? inst 'brt) (eq? lasti 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
+ (else
+ (aset! e 0 (nreconc (cons inst args) bc)))))))
+ e))
(define (make-label e) (gensym))
(define (mark-label e l) (emit e 'label l))