opt.scm (8007B)
1 ;;;; opt.scm - optimizer 2 3 4 (define (optimize form state) 5 (let-syntax ((result 6 (syntax-rules () 7 ((_ (a b c) x body ...) 8 (match-let ((#(a b c) x)) body ...))))) 9 (let ((debug (test-option 'debug state)) 10 (block (test-option 'block state)) 11 (local-env #f)) 12 ;; (walk FORM ENV DEST LOC) -> #(FORM' VALUE SIDEEFFECT?) 13 ;; 14 ;; ENV = ((<variable1> <value1> <used?>) ...) 15 ;; VALUE = '<const> | <variable> | #f | (%void) 16 (define (walk form e dest loc) 17 (define (return form val se?) 18 ;;(pp `(RETURN: ,form ,val ,se?)) 19 (vector form val se?)) 20 ;;(pp `(WALK: ,form)) 21 (match form 22 ;; * propagate variable value, if known 23 ((? symbol?) 24 (let ((px (propagate form form #f))) 25 (cond ((and (symbol? px) (assq px e)) => 26 (lambda (a) (set-car! (cddr a) #t)))) ; mark as used 27 (return 28 (if (eq? px form) 29 form 30 (note 31 loc state 32 px 33 (string-append 34 "replaced reference to `" (symbol->string form) "' with: ") 35 px)) 36 form #f))) 37 ;; * "straighten" `let' forms 38 ;; 39 ;;XXX disabled, because it results in too deeply nested 40 ;; functions (r4rstest.scm), even for v8 41 ;; (('let ((v1 ('let ((v2 x)) z))) y) 42 ;; (walk `(let ((,v2 ,x)) ; alpha-conversion should make this safe 43 ;; (let ((,v1 ,z)) ,y)) 44 ;; e dest loc)) 45 ;; * remove side-effect free unused bindings 46 (('let (('%unused x)) y) 47 (result 48 (x2 vx se) (walk x e #f loc) 49 (if se 50 (result 51 (y2 yv yse) (walk y e dest loc) 52 (return 53 `(let ((%unused ,x2)) 54 ,y2) 55 yv #t)) 56 (note 57 loc state 58 (walk y e dest loc) 59 "removed side-effect free expression: " x2)))) 60 ;; * remove unused bindings 61 (('let ((v x)) y) 62 (result 63 (x2 xv xse) (walk x e v loc) 64 (let ((b (list v xv #f))) 65 (fluid-let ((local-env (cons b local-env))) 66 (result 67 (y2 yv yse) (walk y (cons b e) dest loc) 68 (return 69 (cond ((caddr b) ; variable used? 70 `(let ((,v ,x2)) 71 ,y2)) 72 (xse ; unused, but bound value has side-effect? 73 `(let ((%unused ,x2)) 74 ,y2)) 75 (else 76 (note loc state y2 "removed unused binding: " v))) 77 yv 78 (or xse yse))))))) 79 (('quote c) (return form form #f)) 80 ;; * remove self-assignment 81 (('set! v x) 82 (result 83 (x2 xv _) (walk x e v loc) 84 (cond ((eq? v x2) 85 (note 86 loc state 87 (return '(%void) '(%void) #f) 88 "removing self-assignment: " v)) 89 (else 90 (cond ((and xv (assq v local-env)) => 91 (lambda (a) ; assign new value, if local 92 (set-car! (cddr a) #t) ; mark as used 93 (set-car! (cdr a) xv))) 94 ((assq v e) => ; otherwise invalidate 95 (lambda (a) 96 (set-car! (cddr a) #t) 97 (set-car! (cdr a) #f)))) 98 (return `(set! ,v ,x2) '(%void) #t))))) 99 ;; 100 (('lambda llist body) 101 (match-let (((vars _) (parse-llist llist))) 102 (fluid-let ((local-env (map (cut list <> #f #f) vars))) 103 (result 104 (body2 _ _) 105 (walk body (append local-env e) #f dest) 106 (let ((form2 `(lambda ,llist ,body2))) 107 (return form2 #f #f)))))) 108 ;; 109 (('%void) (return form form #f)) 110 ;; * replace with constant, if argument known to be void or non-void 111 (('%void? x) 112 (result 113 (x2 xv se?) (walk x e #f loc) 114 (match xv 115 ('(%void) 116 (note 117 loc state 118 (return 119 (if se? 120 `(let ((%unused ,x2)) ''#t) 121 ''#t) 122 ''#t 123 se?) 124 "removed voidness-test (true)")) 125 (('quote _) 126 (note 127 loc state 128 (return 129 (if se? 130 `(let ((%unused ,x2)) ''#f) 131 ''#f) 132 ''#f 133 se?) 134 "removed voidness-test (false)")) 135 (_ (return `(%void? ,x2) #f se?))))) 136 ;; * "straighten" binding inside condition 137 (('if ('let binding x) . more) 138 (let ((t (temp))) 139 (walk 140 `(let ,binding 141 (let ((,t ,x)) 142 (if ,t ,@more))) 143 e dest loc))) 144 ;; * replace side-effect free known condition and/or side-effect free branches 145 (('if x y z) 146 (result 147 (x2 xv xse) (walk x e #f loc) 148 (cond ((and (pair? xv) (eq? 'quote (car xv))) ; constant condition? 149 (let ((b (if (cadr xv) y z))) 150 (note 151 loc state 152 (if xse 153 (result ; execute condition, but ignore result 154 (b2 bv bse) (walk b e dest loc) 155 (return 156 `(let ((%unused ,x2)) ,b2) 157 b2 #t)) 158 (note 159 loc state 160 (walk b e dest loc) ; drop alternative branch 161 "removed side-effect free conditional branch for: " x2)) 162 "constant condition in conditional: " x2))) 163 (else 164 (result 165 (y2 yv yse) (walk y e dest loc) 166 (result 167 (z2 zv zse) (walk z e dest loc) 168 (return 169 `(if ,x2 ,y2 ,z2) 170 #f 171 (or xse yse zse)))))))) 172 ;; 173 (('%host-ref _) 174 (return form #f debug)) 175 ;; 176 (('%host-set! p x) 177 (result 178 (x2 xv xse) (walk x e p loc) 179 (return `(%host-set! ,p ,x2) #f #t))) 180 ;; 181 (('%property-ref _) 182 (return form #f debug)) 183 ;; 184 (('%check type x) 185 ;;XXX remove unneeded `%check's (constant known value) 186 (result 187 (x2 xv xse) (walk x e dest loc) 188 (return `(%check ,type ,x2) #f (or xse debug)))) 189 ;; ((%property-ref PARTS) X) ~> (%property-ref PARTS X) 190 ((('%property-ref parts) x) 191 (walk `(%property-ref ,parts ,x) e dest loc)) 192 ;; 193 (('%property-ref parts x) 194 (result 195 (x2 xv xse) (walk x e dest loc) 196 (return `(%property-ref ,parts ,x2) #f (or xse debug)))) 197 ;; 198 (('%property-set! p x y) 199 (result 200 (x2 _ xse) (walk x e #f loc) 201 (result 202 (y2 _ yse) (walk y e p loc) 203 (return `(%property-set! ,p ,x2 ,y2) #f #t)))) 204 ;; 205 (('%code . code) 206 (return form #f #t)) 207 ;; 208 (('%native-lambda . code) 209 (return form #f #f)) 210 ;; 211 (('%inline name args ...) 212 (result 213 (xs _ _) (walk-many args e loc) 214 (return `(%inline ,name ,@xs) #f #t))) 215 ;; 216 (('%new args ...) 217 (result 218 (xs _ _) (walk-many args e loc) 219 (return `(%new ,@xs) #f #t))) 220 ;; 221 (('%global-ref _) 222 (return form #f debug)) 223 ;; * remove global, if unused, if in block-mode and value has no side-effects 224 ;; * remove self-assignment 225 (('%global-set! v x) 226 (result 227 (x2 _ se) (walk x e v loc) 228 (cond ((eq? v x2) 229 (note 230 loc state 231 (return '(%void) '(%void) #f) 232 "removing global self-assignment: " v)) 233 ((and block (not se) 234 (not (memq v referenced))) 235 (set! dropped (cons v dropped)) 236 (note 237 loc state 238 (return '(%void) '(%void) #f) 239 "dropped unused global variable assignment: " 240 v)) 241 (else 242 (return `(%global-set! ,v ,x2) '(%void) #t))))) 243 ;; 244 (('%loop llist body) 245 (result 246 (x2 xv xse) (walk body e dest loc) 247 (return `(%loop ,llist ,x2) xv xse))) 248 ;; 249 (('%continue . xs) 250 (result 251 (xs2 _ se) (walk-many xs e loc) 252 (return `(%continue ,@xs2) #f se))) ;XXX se? 253 ;; 254 ((op args ...) 255 (for-each (lambda (a) (set-car! (cdr a) #f)) e) ; invalidate all variables in env 256 (result 257 (xs2 _ se) (walk-many form e loc) ;XXX should we re-walk if op changed? 258 (return xs2 #f #t))) 259 (_ (error "opt: invalid form" form)))) 260 (define (walk-many forms e loc) 261 (let loop ((forms forms) (xs '()) (vs '()) (se #f)) 262 (if (null? forms) 263 (vector (reverse xs) (reverse vs) se) 264 (result 265 (x2 xv xse) (walk (car forms) e #f loc) 266 (loop (cdr forms) 267 (cons x2 xs) 268 (cons xv vs) 269 (or se xse)))))) 270 ;; replace expression with known value, if possible and no side effects are caused 271 (define (propagate exp val se) 272 (if se 273 exp 274 (let loop ((val val)) 275 (cond ((and (pair? val) 276 (or (and (eq? 'quote (car val)) 277 ;; do not propagate complex constants 278 (not (pair? (cadr val))) 279 (not (vector? (cadr val)))) 280 (eq? '%void (car val)))) 281 val) 282 ((and (symbol? val) (assq val local-env)) => 283 (lambda (a) 284 (if (cadr a) 285 (loop (cadr a)) 286 val))) 287 (else exp))))) 288 (result 289 (form2 _ _) (walk form '() #f #f) 290 form2))))