; optimizer.lisp by Michael Thorpe 2017-05-29 (define byte-optimize-debug #f) ; Only useful within the optimize-assembly-peephole function (macro-define (#bytecode-matches o) (let ((ops (cdr o)) (conditionals `(and))) (ifelse (car ops) (set conditionals (cons `(eq? op1 ,(quote (car ops))) conditionals)) (set conditionals (cons `(not op1) conditionals))) (if (cadr ops) (set conditionals (cons `(<= ,(cadr ops) arg1) conditionals))) (if (caddr ops) (set conditionals (cons `(<= arg1 ,(caddr ops)) conditionals))) (set ops (cdddr ops)) (if ops (ifelse (car ops) (set conditionals (cons `(eq? op2 ,(quote (car ops))) conditionals)) (set conditionals (cons `(not op2) conditionals))) (if (cadr ops) (set conditionals (cons `(<= ,(cadr ops) arg2) conditionals))) (if (caddr ops) (set conditionals (cons `(<= arg2 ,(caddr ops)) conditionals))) (set ops (cdddr ops)) (if ops (ifelse (car ops) (set conditionals (cons `(eq? op3 ,(quote (car ops))) conditionals)) (set conditionals (cons `(not op3) conditionals))) (if (cadr ops) (set conditionals (cons `(<= ,(cadr ops) arg3) conditionals))) (if (caddr ops) (set conditionals (cons `(<= arg3 ,(caddr ops)) conditionals))) (set ops (cdddr ops)) (if ops (ifelse (car ops) (set conditionals (cons `(eq? op4 ,(quote (car ops))) conditionals)) (set conditionals (cons `(not op4) conditionals))) (if (cadr ops) (set conditionals (cons `(<= ,(cadr ops) arg4) conditionals))) (if (caddr ops) (set conditionals (cons `(<= arg4 ,(caddr ops)) conditionals))) (set ops (cdddr ops)) (if ops (throw macro-error o))))) (reverse conditionals))) (define (optimize-assembly-peephole instructions) (if instructions (let ((op1 (ifelse (pair? (car instructions)) (caar instructions) #f)) (arg1 (ifelse (pair? (car instructions)) (cdar instructions) #f)) (rest1 (cdr instructions)) (op2 (ifelse (and rest1 (pair? (car rest1))) (caar rest1) #f)) (arg2 (ifelse (and rest1 (pair? (car rest1))) (cdar rest1) #f)) (rest2 (ifelse rest1 (cdr rest1) #f)) (op3 (ifelse (and rest2 (pair? (car rest2))) (caar rest2) #f)) (arg3 (ifelse (and rest2 (pair? (car rest2))) (cdar rest2) #f)) (rest3 (ifelse rest2 (cdr rest2) #f)) (op4 (ifelse (and rest3 (pair? (car rest3))) (caar rest3) #f)) (arg4 (ifelse (and rest3 (pair? (car rest3))) (cdar rest3) #f)) (rest4 (ifelse rest3 (cdr rest3) #f)) (new #f)) (set new (or ; bf goto LABEL1 -> bt LABEL1 (and (#bytecode-matches bf #f #f goto #f #f #f #f #f) `((bt . ,arg2) ,(car rest2) . ,rest3)) ; bt goto LABEL1 -> bf LABEL1 (and (#bytecode-matches bt #f #f goto #f #f #f #f #f) `((bf . ,arg2) ,(car rest2) . ,rest3)) ; call ret<0> -> retcall (and (#bytecode-matches call #f #f ret #f 0) `((retcall . ,arg1) . ,rest2)) ; index<0> asr put<0> -> asr (and (#bytecode-matches index #f 0 asr #f #f put #f 0) (cons (car rest1) rest3)) ; index<0> car<0> put<0> -> cdr<0> (and (#bytecode-matches index #f 0 car #f 0 put #f 0) (cons (car rest1) rest3)) ; index<0> cdr<0> put<0> -> cdr<0> (and (#bytecode-matches index #f 0 cdr #f 0 put #f 0) (cons (car rest1) rest3)) ; index<0> nil<0> exch<0> put<1> -> nil<0> (and (#bytecode-matches index #f 0 nil #f 0 exch #f 0 put 1 1) `((nil . 0) . ,rest4)) ; index<0> not<0> put<0> -> cdr<0> (and (#bytecode-matches index #f 0 not #f 0 put #f 0) (cons (car rest1) rest3)) ; index pop<0> -> (nothing) (and (#bytecode-matches index #f #f pop #f 0) rest2) ; index pop -> pop (and (#bytecode-matches index #f #f pop 1 #f) `((pop . ,(- arg2 1)) . ,rest2)) ; index<0> pushi add<0> put<0> -> pushi add<0> (and (#bytecode-matches index #f 0 pushi #f #f add #f 0 put #f 0) `(,(car rest1) ,(car rest2) . ,rest4)) ; index<0> pushi sub<0> put<0> -> pushi sub<0> (and (#bytecode-matches index #f 0 pushi #f #f sub #f 0 put #f 0) `(,(car rest1) ,(car rest2) . ,rest4)) ; index<0> put pop<0> -> put (and (#bytecode-matches index #f 0 put 1 #f pop #f 0) `((put . ,(- arg2 1)) . ,rest3)) ; index put -> (nothing) (and (#bytecode-matches index #f #f put #f #f) (and (= arg1 arg2) rest2)) ; localobj lookup<0> call<0> ret -> pop localobj lookup<0> retcall<0> (and (#bytecode-matches localobj #f #f lookup #f 0 call #f 0 ret 1 #f) `((pop . ,(- arg4 1)) (localobj . ,arg1) (lookup . 0) (retcall . 0) . ,rest4)) ; localobj lookup<0> call<1> ret<1> -> put<0> localobj lookup<0> retcall<1> (and (#bytecode-matches localobj #f #f lookup #f 0 call 1 1 ret 1 1) `((put . 0) (localobj . ,arg1) (lookup . 0) (retcall . 1) . ,rest4)) ; localobj lookup<0> call<1> ret -> put pop localobj lookup<0> retcall<1> (and (#bytecode-matches localobj #f #f lookup #f 0 call 1 1 ret 2 #f) `((put . ,(- arg4 1)) (pop . ,(- arg4 2)) (localobj . ,arg1) (lookup . 0) (retcall . 1) . ,rest4)) ; localobj lookup<0> call<2> ret<1> -> exch<0> put<1> localobj lookup<0> retcall<2> (and (#bytecode-matches localobj #f #f lookup #f 0 call 2 2 ret 1 1) `((exch . 0) (put . 1) (localobj . ,arg1) (lookup . 0) (retcall . 2) . ,rest4)) ; localobj lookup<0> call<2> ret<2> -> put<1> put<1> localobj lookup<0> retcall<2> (and (#bytecode-matches localobj #f #f lookup #f 0 call 2 2 ret 2 2) `((put . 1) (put . 1) (localobj . ,arg1) (lookup . 0) (retcall . 2) . ,rest4)) ; localobj lookup<0> call<2> ret -> put put pop localobj lookup<0> retcall<2> (and (#bytecode-matches localobj #f #f lookup #f 0 call 2 2 ret 3 #f) `((put . ,(- arg4 1)) (put . ,(- arg4 1)) (pop . ,(- arg4 3)) (localobj . ,arg1) (lookup . 0) (retcall . 2) . ,rest4)) ; nil<0> pop<0> -> (nothing) (and (#bytecode-matches nil #f 0 pop #f 0) rest2) ; nil<0> pop -> pop (and (#bytecode-matches nil #f 0 pop 1 #f) `((pop . ,(- arg2 1)) . ,rest2)) ; nil<0> put<0> -> pop<0> nil<0> (and (#bytecode-matches nil #f 0 put #f 0) `((pop . 0) (nil . 0) . ,rest2)) ; pop pop -> pop (and (#bytecode-matches pop #f #f pop #f #f) `((pop . ,(+ arg1 arg2 1)) . ,rest2)) ; pushi add<0> pushi add<0> -> pushi add<0> (and (#bytecode-matches pushi #f #f add #f 0 pushi #f #f add #f 0) `((pushi . ,(+ arg1 arg3)) (add . 0) . ,rest4)) ; pushi add<0> pushi sub<0> -> pushi add<0> (and (#bytecode-matches pushi #f #f add #f 0 pushi #f #f sub #f 0) `((pushi . ,(- arg1 arg3)) (add . 0) . ,rest4)) ; pushi pop<0> -> (nothing) (and (#bytecode-matches pushi #f #f pop #f 0) rest2) ; pushi pop -> pop (and (#bytecode-matches pushi #f #f pop 1 #f) `((pop . ,(- arg2 1)) . ,rest2)) ; pushi pushi add<0> -> pushi (and (#bytecode-matches pushi #f #f pushi #f #f add #f 0) `((pushi . ,(+ arg1 arg2)) . ,rest3)) ; pushi pushi mul<0> -> pushi (and (#bytecode-matches pushi #f #f pushi #f #f mul #f 0) `((pushi . ,(* arg1 arg2)) . ,rest3)) ; pushi pushi put<0> -> pushi (and (#bytecode-matches pushi #f #f pushi #f #f put #f 0) `((pushi . ,arg2) . ,rest3)) ; pushi pushi sub<0> -> pushi (and (#bytecode-matches pushi #f #f pushi #f #f sub #f 0) `((pushi . ,(- arg1 arg2)) . ,rest3)) ; pushi put<0> -> pop<0> pushi (and (#bytecode-matches pushi #f #f put #f 0) `((pop . 0) (pushi . ,arg1) . ,rest2)) ; pushi sub<0> pushi add<0> -> pushi add<0> (and (#bytecode-matches pushi #f #f sub #f 0 pushi #f #f add #f 0) `((pushi . ,(- arg3 arg1)) (add . 0) . ,rest4)) ; pushi sub<0> pushi sub<0> -> pushi sub<0> (and (#bytecode-matches pushi #f #f sub #f 0 pushi #f #f sub #f 0) `((pushi . ,(+ arg1 arg3)) (sub . 0) . ,rest4)) ; LABEL1 nil<0> LABEL2 pop<0> -> nil<0> LABEL2 pop<0> LABEL1 (and (#bytecode-matches #f #f #f nil #f 0 #f #f #f pop #f 0) `((nil . 0) ,(car rest2) (pop . 0) ,(car instructions) . ,rest4)) instructions)) (if (neq? instructions new) (if byte-optimize-debug (dprint 'optimizing-from: instructions 'to: new)) (set instructions new))) (if (and (pair? instructions) (cdr instructions)) (let ((newtail (optimize-assembly-peephole (cdr instructions)))) (if (neq? (cdr instructions) newtail) (set instructions (cons (car instructions) newtail)))))) instructions) ; Turns a goto pointing to a ret/retcall/goto into a ret/retcall/goto (define (optimize-assembly-goto-ret instructions) (let ((insts instructions) (rets #f)) (while insts (if (and (word? (car insts)) (pair? (cdr insts)) (pair? (cadr insts)) (or (eq? (caadr insts) 'goto) (eq? (caadr insts) 'ret) (eq? (caadr insts) 'retcall))) (set rets (cons (cons (car insts) (cadr insts)) rets))) (set insts (cdr insts))) (set insts instructions) (while insts (if (and (pair? (car insts)) (eq? (caar insts) 'goto) (get rets (cdar insts))) (set instructions (let ((ret #f)) (map i (ifelse (and (pair? i) (eq? (car i) 'goto) (progn (set ret (get rets (cdr i))) ret)) (progn (if byte-optimize-debug (dprint 'optimizing-from: `(goto . ,(cdr i)) 'to: ret)) ret) i) instructions))) (exit-loop)) (set insts (cdr insts))) instructions)) ; An instruction after one that can't continue to it can be deleted (define (optimize-assembly-nonret-then-instruction instructions) (ifelse instructions (ifelse (and (pair? (car instructions)) (or (eq? 'goto (caar instructions)) (eq? 'ret (caar instructions)) (eq? 'retcall (caar instructions)) (eq? 'throw (caar instructions))) (pair? (cdr instructions)) (pair? (cadr instructions))) (progn (if byte-optimize-debug (dprint 'optimizing-from: (car instructions) (cadr instructions) 'to: (car instructions))) (optimize-assembly-nonret-then-instruction (cons (car instructions) (cddr instructions)))) (let ((new (optimize-assembly-nonret-then-instruction (cdr instructions)))) (ifelse (eq? new (cdr instructions)) instructions (cons (car instructions) new)))) instructions)) ; A goto that just proceeds on to the next instruction (label) can be removed (define (optimize-assembly-goto-next-instruction instructions) (ifelse instructions (ifelse (and (pair? (car instructions)) (eq? 'goto (caar instructions)) (pair? (cdr instructions)) (eq? (cadr instructions) (cdar instructions))) (progn (if byte-optimize-debug (dprint 'optimizing-from: (car instructions) (cadr instructions) 'to: (cadr instructions))) (optimize-assembly-goto-next-instruction (cdr instructions))) (let ((new (optimize-assembly-goto-next-instruction (cdr instructions)))) (ifelse (eq? new (cdr instructions)) instructions (cons (car instructions) new)))) instructions)) ; A conditional branch that just proceeds on to the next instruction (label) can be changed to a pop (define (optimize-assembly-branch-to-next-instruction instructions) (ifelse instructions (ifelse (and (pair? (car instructions)) (or (eq? 'bf (caar instructions)) (eq? 'bt (caar instructions))) (pair? (cdr instructions)) (eq? (cadr instructions) (cdar instructions))) (progn (if byte-optimize-debug (dprint 'optimizing-from: (car instructions) (cadr instructions) 'to: `(pop . 0) (cadr instructions))) (optimize-assembly-branch-to-next-instruction `((pop . 0) ,(cdr instructions)))) (let ((new (optimize-assembly-branch-to-next-instruction (cdr instructions)))) (ifelse (eq? new (cdr instructions)) instructions (cons (car instructions) new)))) instructions)) ; Expand ret into put/pop/ret<0> (define (optimize-assembly-expand-rets instructions) (if instructions (if (cdr instructions) (let ((newtail (optimize-assembly-expand-rets (cdr instructions)))) (if (neq? (cdr instructions) newtail) (set instructions (cons (car instructions) newtail))))) (if (and (pair? (car instructions)) (eq? 'ret (caar instructions))) (let ((new (car instructions))) (ifelse (< 1 (cdr new)) (set new `((put . ,(- (cdr new) 1)) (pop . ,(- (cdr new) 2)))) (if (= (cdr new) 1) (set new `((put . 0))))) (if (neq? new (car instructions)) (set new (append new `((ret . 0)))) (if byte-optimize-debug (dprint 'optimizing-from: (car instructions) 'to: new)) (set instructions (append new (cdr instructions))))))) instructions) ; Turns a goto pointing to a pop into a pop+goto pointing to the instruction after the original pop (define (optimize-assembly-goto-pop instructions) (let ((insts instructions) (rev #f) (pops #f)) (while insts (ifelse (and (word? (car insts)) (pair? (cdr insts)) (pair? (cadr insts)) (eq? (caadr insts) 'pop)) (let ((label (car insts)) (pop (cadr insts))) (set insts (cddr insts)) (set rev (cons pop (cons label rev))) (unless (word? (car insts)) (set insts (cons (unique-word) insts))) (set pops (cons (cons label (cons pop (car insts))) pops)) (set rev (cons (car insts) rev)) (set insts (cdr insts))) (progn (set rev (cons (car insts) rev)) (set insts (cdr insts))))) (let ((did-something #f) (pop #f)) (while rev (ifelse (and (pair? (car rev)) (eq? (caar rev) 'goto) (set pop (get pops (cdar rev))) pop) (progn (if byte-optimize-debug (dprint 'optimizing-from: (car rev) 'to: (car pop) (cons 'goto (cdr pop)))) (set insts (cons (cons 'goto (cdr pop)) insts)) (set insts (cons (car pop) insts)) (set did-something #t)) (set insts (cons (car rev) insts))) (set rev (cdr rev))) (ifelse did-something insts instructions)))) ; Run one pass of the optimizer (define (optimize-assembly-1pass instructions) (set instructions (optimize-assembly-goto-ret instructions)) (set instructions (optimize-assembly-goto-pop instructions)) (set instructions (trim-unused-labels instructions)) (set instructions (optimize-assembly-nonret-then-instruction instructions)) (set instructions (optimize-assembly-goto-next-instruction instructions)) (set instructions (optimize-assembly-branch-to-next-instruction instructions)) (set instructions (optimize-assembly-peephole instructions)) instructions) ; This and the other optimizers take a labelled instruction list as arguments (define (optimize-assembly instructions) (let ((prev #f)) (while (neq? instructions prev) (set prev instructions) (set instructions (optimize-assembly-1pass instructions))) (set instructions (optimize-assembly-expand-rets instructions)) (while (neq? instructions prev) (set prev instructions) (set instructions (optimize-assembly-1pass instructions))) instructions)) (define (bind-assembly-helper funcname numargs label instructions) (ifelse (and instructions (cdr instructions) (cddr instructions)) (ifelse (and (pair? (car instructions)) (eq? 'localobj (car (car instructions))) (eq? funcname (cdr (car instructions))) (pair? (cadr instructions)) (eq? 'lookup (car (cadr instructions))) (= 0 (cdr (cadr instructions))) (pair? (caddr instructions)) (eq? 'retcall (car (caddr instructions))) (= numargs (cdr (caddr instructions)))) (progn (if byte-optimize-debug (dprint 'optimizing-from: (car instructions) (cadr instructions) (caddr instructions) 'to: `(goto . ,label))) (bind-assembly-helper funcname numargs label `((goto . ,label) . ,(cdddr instructions)))) (let ((new (bind-assembly-helper funcname numargs label (cdr instructions)))) (ifelse (eq? new (cdr instructions)) instructions (cons (car instructions) new)))) instructions)) ; Turn retcalls to the function named funcname (presumably me) into gotos (define (bind-assembly funcname instructions) (unless (and (pair? instructions) (pair? (car instructions)) (eq? 'needargs (caar instructions))) (throw 'bind-assembly `(,funcname ,instructions))) (let ((numargs (cdar instructions)) (label (unique-word)) (new (bind-assembly-helper funcname numargs label (cdr instructions)))) (if (neq? new (cdr instructions)) (set instructions `(,(car instructions) ,label . ,new)))) instructions) (define (reassemble instructions) (let ((i 0) (revlist #f) (label-to-pos #f)) (while instructions (ifelse (pair? (car instructions)) (progn (set i (+ i 1)) (set revlist (cons (car instructions) revlist))) (set label-to-pos (cons (cons (car instructions) i) label-to-pos))) (set instructions (cdr instructions))) (while revlist (ifelse (flow-control-opcode? (caar revlist)) (let ((loc (get label-to-pos (cdar revlist)))) (ifelse loc (set instructions (cons (cons (caar revlist) (- loc i)) instructions)) (set instructions (cons (car revlist) instructions)))) (set instructions (cons (car revlist) instructions))) (set revlist (cdr revlist)) (set i (- i 1)))) (let ((code/objs (byte-compile-localobj-assign instructions))) (#lambda (byte-compile-flatten (car code/objs)) (cdr code/objs)))) (define (#optimize func) (reassemble (optimize-assembly (disassemble func)))) (macro-define (optimize o) (if (cddr o) (throw macro-error o)) `(set ,(cadr o) (#optimize ,(cadr o)))) (define (#bind name) (#set name (reassemble (bind-assembly name (disassemble (lookup name)))))) (macro-define (bind o) (if (cddr o) (throw macro-error o)) `(#bind ,(quote (cadr o))))