1;;; cpcommonize.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(begin 17(define-who commonization-level 18 ($make-thread-parameter 19 0 20 (lambda (x) 21 (unless (and (fixnum? x) (<= 0 x 9)) 22 ($oops who "invalid level ~s" x)) 23 x))) 24 25(define $cpcommonize 26 (let () 27 (import (nanopass)) 28 (include "base-lang.ss") 29 30 (define-record-type binding 31 (nongenerative) 32 (sealed #t) 33 (fields x (mutable e) size helper-box (mutable helper-b) (mutable helper-arg*)) 34 (protocol 35 (lambda (new) 36 (lambda (x e size helper-box) 37 (new x e size helper-box #f #f))))) 38 39 (define-language Lcommonize1 (extends Lsrc) 40 (terminals 41 (+ (fixnum (size)))) 42 (Expr (e body rtd-expr) 43 (- (letrec ([x* e*] ...) body)) 44 (+ (letrec ([x* e* size] ...) body)))) 45 46 (define-language Lcommonize2 (extends Lcommonize1) 47 (terminals 48 (- (fixnum (size))) 49 (+ (binding (b helper-b)))) 50 (Expr (e body rtd-expr) 51 (- (letrec ([x* e* size] ...) body)) 52 (+ (letrec (helper-b* ...) (b* ...) body)))) 53 54 (define-syntax iffalse 55 (syntax-rules () 56 [(_ e1 e2) e1 #;(or e1 (begin e2 #f))])) 57 58 (define-syntax iftrue 59 (syntax-rules () 60 [(_ e1 e2) e1 #;(let ([t e1]) (and t (begin e2 t)))])) 61 62 (define Lcommonize1-lambda? 63 (lambda (e) 64 (nanopass-case (Lcommonize1 Expr) e 65 [(case-lambda ,preinfo ,cl* ...) #t] 66 [else #f]))) 67 68 (define-pass cpcommonize0 : Lsrc (ir) -> Lcommonize1 () 69 (Expr : Expr (ir) -> Expr (1) 70 [(set! ,maybe-src ,x ,[e size]) 71 (values `(set! ,maybe-src ,x ,e) (fx+ 1 size))] 72 [(seq ,[e1 size1] ,[e2 size2]) 73 (values `(seq ,e1 ,e2) (fx+ size1 size2))] 74 [(if ,[e1 size1] ,[e2 size2] ,[e3 size3]) 75 (values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))] 76 [(foreign (,conv* ...) ,name ,[e size] (,arg-type* ...) ,result-type) 77 (values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] 78 [(fcallable (,conv* ...) ,[e size] (,arg-type* ...) ,result-type) 79 (values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] 80 ; ($top-level-value 'x) adds just 1 to the size 81 [(call ,preinfo ,pr (quote ,d)) 82 (guard (eq? (primref-name pr) '$top-level-value)) 83 (values `(call ,preinfo ,pr (quote ,d)) 1)] 84 ; (let ([x* e*] ...) body) splits into letrec binding unassigned variables to lambdas plus a let for the remaining bindings 85 [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,[body size])) ,[e* -> e* size*] ...) 86 (guard (fx= (length e*) interface)) 87 (define-record-type fudge (nongenerative) (sealed #t) (fields x e size)) 88 (let-values ([(lb* ob*) (partition 89 (lambda (b) 90 (and (not (prelex-assigned (fudge-x b))) 91 (Lcommonize1-lambda? (fudge-e b)))) 92 (map make-fudge x* e* size*))]) 93 (values 94 (let ([body (if (null? ob*) 95 body 96 `(call ,preinfo1 97 (case-lambda ,preinfo2 98 (clause (,(map fudge-x ob*) ...) ,(length ob*) ,body)) 99 ,(map fudge-e ob*) ...))]) 100 (if (null? lb*) 101 body 102 `(letrec ([,(map fudge-x lb*) ,(map fudge-e lb*) ,(map fudge-size lb*)] ...) ,body))) 103 (apply fx+ size size*)))] 104 [(call ,preinfo ,[e size] ,[e* size*] ...) 105 (values `(call ,preinfo ,e ,e* ...) (apply fx+ size size*))] 106 [(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* size*]) ...) 107 (values `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...) (apply fx+ 1 size*))] 108 [(letrec ([,x* ,[e* size*]] ...) ,[body size]) 109 (values `(letrec ([,x* ,e* ,size*] ...) ,body) (apply fx+ size size*))] 110 [(record-ref ,rtd ,type ,index ,[e size]) 111 (values `(record-ref ,rtd ,type ,index ,e) (fx+ size 1))] 112 [(record-set! ,rtd ,type ,index ,[e1 size1] ,[e2 size2]) 113 (values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))] 114 [(record ,rtd ,[rtd-expr size] ,[e* size*] ...) 115 (values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))] 116 [(cte-optimization-loc ,box ,[e size] ,exts) 117 (values `(cte-optimization-loc ,box ,e ,exts) size)] 118 [(immutable-list (,[e* size*] ...) ,[e size]) 119 (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))] 120 [(quote ,d) (values `(quote ,d) 1)] 121 [(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)] 122 [,pr (values pr 1)] 123 [(moi) (values `(moi) 1)] 124 [(pariah) (values `(pariah) 0)] 125 [(profile ,src) (values `(profile ,src) 0)] 126 [else (sorry! who "unhandled record ~s" ir)]) 127 (let-values ([(e size) (Expr ir)]) e)) 128 129 (define-pass cpcommonize1 : Lcommonize1 (ir worthwhile-size) -> Lcommonize2 () 130 (definitions 131 (define worthwhile-size? 132 (lambda (expr-size) 133 (fx>= expr-size worthwhile-size))) 134 (define worthwhile-ratio? 135 (lambda (expr-size subst-count) 136 (or (fx= subst-count 0) 137 (fx>= (div expr-size subst-count) 4)))) 138 (define-record-type subst 139 (nongenerative) 140 (sealed #t) 141 (fields t e1 e2)) 142 (define-record-type frob 143 (nongenerative) 144 (sealed #t) 145 (fields subst* e b)) 146 (define ht (make-hashtable values fx=)) 147 (define make-sym 148 (lambda x* 149 (string->symbol (apply string-append (map (lambda (x) (if (prelex? x) (symbol->string (prelex-name x)) x)) x*))))) 150 (define same-preinfo? 151 (lambda (p1 p2) 152 ; ignore differences in src and sexpr 153 #t)) 154 (define same-preinfo-lambda? 155 (lambda (p1 p2) 156 ; ignore differences src, sexpr, and name 157 (eq? (preinfo-lambda-libspec p1) (preinfo-lambda-libspec p2)))) 158 (define-who same-type? 159 (lambda (ty1 ty2) 160 (nanopass-case (Ltype Type) ty1 161 [(fp-integer ,bits1) 162 (nanopass-case (Ltype Type) ty2 163 [(fp-integer ,bits2) (= bits1 bits2)] 164 [else #f])] 165 [(fp-unsigned ,bits1) 166 (nanopass-case (Ltype Type) ty2 167 [(fp-unsigned ,bits2) (= bits1 bits2)] 168 [else #f])] 169 [(fp-void) 170 (nanopass-case (Ltype Type) ty2 171 [(fp-void) #t] 172 [else #f])] 173 [(fp-scheme-object) 174 (nanopass-case (Ltype Type) ty2 175 [(fp-scheme-object) #t] 176 [else #f])] 177 [(fp-u8*) 178 (nanopass-case (Ltype Type) ty2 179 [(fp-u8*) #t] 180 [else #f])] 181 [(fp-u16*) 182 (nanopass-case (Ltype Type) ty2 183 [(fp-u16*) #t] 184 [else #f])] 185 [(fp-u32*) 186 (nanopass-case (Ltype Type) ty2 187 [(fp-u32*) #t] 188 [else #f])] 189 [(fp-fixnum) 190 (nanopass-case (Ltype Type) ty2 191 [(fp-fixnum) #t] 192 [else #f])] 193 [(fp-double-float) 194 (nanopass-case (Ltype Type) ty2 195 [(fp-double-float) #t] 196 [else #f])] 197 [(fp-single-float) 198 (nanopass-case (Ltype Type) ty2 199 [(fp-single-float) #t] 200 [else #f])] 201 [(fp-ftd ,ftd1) 202 (nanopass-case (Ltype Type) ty2 203 [(fp-ftd ,ftd2) (eq? ftd1 ftd2)] 204 [else #f])] 205 [else (sorry! who "unhandled foreign type ~s" ty1)]))) 206 (define okay-to-subst? 207 (lambda (e) 208 (define free? 209 (lambda (x) 210 (and (not (prelex-operand x)) #t))) 211 (nanopass-case (Lcommonize1 Expr) e 212 [(ref ,maybe-src1 ,x1) (and (not (prelex-assigned x1)) (free? x1))] 213 [(quote ,d) #t] 214 [,pr (all-set? (prim-mask proc) (primref-flags pr))] 215 [else #f]))) 216 (define constant-equal? 217 (lambda (x y) 218 (define record-equal? 219 (lambda (x y e?) 220 (let ([rtd ($record-type-descriptor x)]) 221 (and (eq? ($record-type-descriptor y) rtd) 222 (let f ([field-name* (csv7:record-type-field-names rtd)] [i 0]) 223 (or (null? field-name*) 224 (and (let ([accessor (csv7:record-field-accessor rtd i)]) 225 (e? (accessor x) (accessor y))) 226 (f (cdr field-name*) (fx+ i 1))))))))) 227 (parameterize ([default-record-equal-procedure record-equal?]) 228 ; equal? should be okay since even mutable constants aren't supposed to be mutated 229 (equal? x y)))) 230 (define same? 231 (lambda (e1 e2) 232 (nanopass-case (Lcommonize1 Expr) e1 233 [(ref ,maybe-src1 ,x1) 234 (nanopass-case (Lcommonize1 Expr) e2 235 [(ref ,maybe-src2 ,x2) 236 (or (eq? x1 x2) 237 (eq? (prelex-operand x1) x2))] 238 [else #f])] 239 [(quote ,d1) 240 (nanopass-case (Lcommonize1 Expr) e2 241 [(quote ,d2) (constant-equal? d1 d2)] 242 [else #f])] 243 [,pr1 244 (nanopass-case (Lcommonize1 Expr) e2 245 [,pr2 (eq? pr1 pr2)] 246 [else #f])] 247 [(moi) 248 (nanopass-case (Lcommonize1 Expr) e2 249 [(moi) #t] 250 [else #f])] 251 [(pariah) 252 (nanopass-case (Lcommonize1 Expr) e2 253 [(pariah) #t] 254 [else #f])] 255 [(profile ,src1) 256 (nanopass-case (Lcommonize1 Expr) e2 257 [(profile ,src2) (eq? src1 src2)] 258 [else #f])] 259 [(call ,preinfo1 ,pr1 (quote ,d1)) 260 (guard (eq? (primref-name pr1) '$top-level-value)) 261 (nanopass-case (Lcommonize1 Expr) e2 262 [(call ,preinfo2 ,pr2 (quote ,d2)) 263 (guard (eq? (primref-name pr2) '$top-level-value)) 264 (and (same-preinfo? preinfo1 preinfo2) (eq? d1 d2))] 265 [else #f])] 266 [else #f]))) 267 (define-who unify 268 (lambda (e1 e2) 269 (module (with-env) 270 (define $with-env 271 (lambda (x1* x2* th) 272 (dynamic-wind 273 (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 x2) (prelex-operand-set! x2 #t)) x1* x2*)) 274 th 275 (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 #f) (prelex-operand-set! x2 #f)) x1* x2*))))) 276 (define-syntax with-env 277 (syntax-rules () 278 [(_ x1* x2* e) ($with-env x1* x2* (lambda () e))]))) 279 (call/cc 280 (lambda (return) 281 (let ([subst* '()]) 282 (define lookup-subst 283 (lambda (e1 e2) 284 (define same-subst? 285 (lambda (x) 286 (and (same? (subst-e1 x) e1) (same? (subst-e2 x) e2)))) 287 (cond 288 [(find same-subst? subst*) => 289 (lambda (subst) 290 (let ([t (subst-t subst)]) 291 (set-prelex-multiply-referenced! t #t) 292 t))] 293 [else #f]))) 294 (let ([e (with-output-language (Lcommonize1 Expr) 295 (let () 296 (define fclause 297 (lambda (cl1 cl2) 298 (nanopass-case (Lcommonize1 CaseLambdaClause) cl1 299 [(clause (,x1* ...) ,interface1 ,body1) 300 (nanopass-case (Lcommonize1 CaseLambdaClause) cl2 301 [(clause (,x2* ...) ,interface2 ,body2) 302 (if (fx= interface1 interface2) 303 (with-env x1* x2* 304 (with-output-language (Lcommonize1 CaseLambdaClause) 305 `(clause (,x1* ...) ,interface1 ,(f body1 body2)))) 306 (return (iffalse #f (printf "lambda interfaces don't match\n")) '()))])]))) 307 (define f 308 (case-lambda 309 [(e1 e2) (f e1 e2 #f)] 310 [(e1 e2 call-position?) 311 (or (cond 312 [(same? e1 e2) e1] 313 [(and (not call-position?) (okay-to-subst? e1) (okay-to-subst? e2)) 314 `(ref #f ,(or (lookup-subst e1 e2) 315 (let ([t (make-prelex*)]) 316 (set-prelex-referenced! t #t) 317 (set! subst* (cons (make-subst t e1 e2) subst*)) 318 t)))] 319 [else 320 (nanopass-case (Lcommonize1 Expr) e1 321 [(ref ,maybe-src1 ,x1) #f] 322 [(quote ,d) #f] 323 [,pr #f] 324 [(moi) #f] 325 [(profile ,src1) #f] 326 ; reject non-same top-level-value calls with constant symbol so they 327 ; don't end up being abstracted over the symbol in the residual code 328 [(call ,preinfo ,pr (quote ,d)) 329 (guard (eq? (primref-name pr) '$top-level-value)) 330 #f] 331 ; don't allow abstraction of first (type) argument to $object-ref, foreign-ref, etc., 332 ; since they can't be inlined without a constant type. 333 ; ditto for $tc-field's first (field) argument. 334 ; there are many other primitives we don't catch here for which the compiler generates 335 ; more efficient code when certain arguments are constant. 336 [(call ,preinfo1 ,pr1 (quote ,d1) ,e1* ...) 337 (guard (memq (primref-name pr1) '($object-ref $swap-object-ref $object-set foreign-ref foreign-set! $tc-field))) 338 (nanopass-case (Lcommonize1 Expr) e2 339 [(call ,preinfo2 ,pr2 (quote ,d2) ,e2* ...) 340 (guard (eq? pr2 pr1) (eq? d1 d2)) 341 (and (same-preinfo? preinfo1 preinfo2) 342 (fx= (length e1*) (length e2*)) 343 `(call ,preinfo1 ,pr1 (quote ,d1) ,(map f e1* e2*) ...))] 344 [else #f])] 345 [(call ,preinfo1 ,e1 ,e1* ...) 346 (nanopass-case (Lcommonize1 Expr) e2 347 [(call ,preinfo2 ,e2 ,e2* ...) 348 (and (fx= (length e1*) (length e2*)) 349 (same-preinfo? preinfo1 preinfo2) 350 `(call ,preinfo1 ,(f e1 e2 #t) ,(map f e1* e2*) ...))] 351 [else #f])] 352 [(if ,e10 ,e11 ,e12) 353 (nanopass-case (Lcommonize1 Expr) e2 354 [(if ,e20 ,e21 ,e22) 355 `(if ,(f e10 e20) ,(f e11 e21) ,(f e12 e22))] 356 [else #f])] 357 [(case-lambda ,preinfo1 ,cl1* ...) 358 (nanopass-case (Lcommonize1 Expr) e2 359 [(case-lambda ,preinfo2 ,cl2* ...) 360 (and (fx= (length cl1*) (length cl2*)) 361 (same-preinfo-lambda? preinfo1 preinfo2) 362 `(case-lambda ,preinfo1 ,(map fclause cl1* cl2*) ...))] 363 [else #f])] 364 [(seq ,e11 ,e12) 365 (nanopass-case (Lcommonize1 Expr) e2 366 [(seq ,e21 ,e22) `(seq ,(f e11 e21) ,(f e12 e22))] 367 [else #f])] 368 [(set! ,maybe-src1 ,x1 ,e1) 369 (nanopass-case (Lcommonize1 Expr) e2 370 [(set! ,maybe-src2 ,x2 ,e2) 371 (and (eq? x1 x2) 372 `(set! ,maybe-src1 ,x1 ,(f e1 e2)))] 373 [else #f])] 374 [(letrec ([,x1* ,e1* ,size1*] ...) ,body1) 375 (nanopass-case (Lcommonize1 Expr) e2 376 [(letrec ([,x2* ,e2* ,size2*] ...) ,body2) 377 (and (fx= (length x2*) (length x1*)) 378 (andmap fx= size1* size2*) 379 (with-env x1* x2* 380 `(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))] 381 [else #f])] 382 [(foreign (,conv1* ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1) 383 (nanopass-case (Lcommonize1 Expr) e2 384 [(foreign (,conv2* ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2) 385 (and (equal? conv1* conv2*) 386 (equal? name1 name2) 387 (fx= (length arg-type1*) (length arg-type2*)) 388 (andmap same-type? arg-type1* arg-type2*) 389 (same-type? result-type1 result-type2) 390 `(foreign (,conv1* ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] 391 [else #f])] 392 [(fcallable (,conv1* ...) ,e1 (,arg-type1* ...) ,result-type1) 393 (nanopass-case (Lcommonize1 Expr) e2 394 [(fcallable (,conv2* ...) ,e2 (,arg-type2* ...) ,result-type2) 395 (and (equal? conv1* conv2*) 396 (fx= (length arg-type1*) (length arg-type2*)) 397 (andmap same-type? arg-type1* arg-type2*) 398 (same-type? result-type1 result-type2) 399 `(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))] 400 [else #f])] 401 [(cte-optimization-loc ,box1 ,e1 ,exts1) 402 (nanopass-case (Lcommonize1 Expr) e2 403 [(cte-optimization-loc ,box2 ,e2 ,exts2) 404 (and (eq? box1 box2) 405 `(cte-optimization-loc ,box1 ,(f e1 e2) ,exts1))] 406 [else #f])] 407 [else (sorry! who "unhandled record ~s" e1)])]) 408 (return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))])) 409 (f e1 e2)))]) 410 (values e subst*))))))) 411 (define sort-substs 412 ; reestablish original argument order for substituted variables where possible 413 ; so the arguments to an abstracted procedure aren't shuffled around in the 414 ; call to the generated helper. 415 (lambda (subst0* x1* x2*) 416 (define (this? x x*) (and (not (null? x*)) (eq? x (car x*)))) 417 (define (next x*) (if (null? x*) x* (cdr x*))) 418 (let-values ([(new-subst* subst*) (let f ([x1* x1*] [x2* x2*] [subst* subst0*] [n (length subst0*)]) 419 (cond 420 [(fx= n 0) (values '() subst*)] 421 [(find (lambda (subst) 422 (define (is-this-arg? e x*) 423 (nanopass-case (Lcommonize1 Expr) e 424 [(ref ,maybe-src ,x) (this? x x*)] 425 [else #f])) 426 (or (is-this-arg? (subst-e1 subst) x1*) 427 (is-this-arg? (subst-e2 subst) x2*))) 428 subst*) => 429 (lambda (subst) 430 (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) (remq subst subst*) (fx- n 1))]) 431 (values (cons subst new-subst*) subst*)))] 432 [else 433 (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) subst* (fx- n 1))]) 434 (values (cons (car subst*) new-subst*) (cdr subst*)))]))]) 435 (safe-assert (null? subst*)) 436 (safe-assert (fx= (length new-subst*) (length subst0*))) 437 new-subst*))) 438 (define find-match 439 (lambda (b1 ht) 440 (and (iffalse (worthwhile-size? (binding-size b1)) (printf "skipping b1: under worthwhile size ~s ~s\n" (binding-size b1) worthwhile-size)) 441 (ormap (lambda (b2) 442 (iffalse #f (printf "checking ~s & ~s:" (prelex-name (binding-x b1)) (prelex-name (binding-x b2)))) 443 (nanopass-case (Lcommonize1 Expr) (binding-e b1) 444 ; NB: restricting to one clause for now...handling multiple 445 ; NB: clauses should be straightforward with a helper per 446 ; NB: common clause. 447 [(case-lambda ,preinfo1 (clause (,x1* ...) ,interface1 ,body1)) 448 ; NB: no rest interface for now. should be straightforward 449 (guard (fxnonnegative? interface1)) 450 (and 451 (nanopass-case (Lcommonize1 Expr) (binding-e b2) 452 [(case-lambda ,preinfo2 (clause (,x2* ...) ,interface2 ,body2)) 453 (guard (fxnonnegative? interface2)) 454 (let-values ([(e subst*) (unify body1 body2)]) 455 (and e 456 (iffalse (worthwhile-ratio? (binding-size b1) (length subst*)) (printf " no, not worthwhile ratio ~s ~s\n" (binding-size b1) (length subst*))) 457 (let ([subst* (sort-substs subst* x1* x2*)]) 458 (iffalse #f (printf " yes\n")) 459 (make-frob subst* e b2))))] 460 [else (iffalse #f (printf " no, b2 does not meet lambda restrictions\n"))]))] 461 [else (iffalse #f (printf " no, b1 does not meet lambda restrictions\n"))])) 462 (hashtable-ref ht (binding-size b1) '()))))) 463 (define record-helper! 464 (lambda (b next e*) 465 (binding-helper-b-set! b next) 466 (binding-helper-arg*-set! b e*))) 467 (define build-helper 468 (lambda (t t* body size helper-box) 469 (make-binding t 470 (with-output-language (Lcommonize1 Expr) 471 `(case-lambda ,(make-preinfo-lambda) (clause (,t* ...) ,(length t*) ,body))) 472 size 473 helper-box))) 474 (define commonize-letrec 475 (lambda (x* e* size* body) ; e* and body have not been processed 476 (define (prune-and-process! b) 477 (let ([b* (remq b (hashtable-ref ht (binding-size b) '()))]) 478 (if (null? b*) 479 (hashtable-delete! ht (binding-size b)) 480 (hashtable-set! ht (binding-size b) b*))) 481 (unless (binding-helper-b b) (binding-e-set! b (Expr (binding-e b))))) 482 (if (null? x*) 483 body 484 (let ([helper-box (box '())]) 485 (let ([b* (map (lambda (x e size) (make-binding x e size helper-box)) x* e* size*)]) 486 (let ([body (let f ([b* b*]) 487 (if (null? b*) 488 (Expr body) 489 (let ([b (car b*)]) 490 (let ([frob (find-match b ht)]) 491 (if frob 492 (let* ([outer-b (frob-b frob)] 493 [helper-box (binding-helper-box outer-b)] 494 [helper-b (let ([t (make-prelex* (make-sym (binding-x b) "&" (binding-x outer-b)))]) 495 (build-helper t (map subst-t (frob-subst* frob)) (frob-e frob) (binding-size outer-b) helper-box))]) 496 (set-box! helper-box (cons helper-b (unbox helper-box))) 497 (record-helper! b helper-b (map subst-e1 (frob-subst* frob))) 498 (record-helper! outer-b helper-b (map subst-e2 (frob-subst* frob))) 499 (hashtable-update! ht (binding-size outer-b) (lambda (b*) (cons helper-b (remq outer-b b*))) '()) 500 (f (cdr b*))) 501 (begin 502 (hashtable-update! ht (binding-size b) (lambda (b*) (cons b b*)) '()) 503 (let ([body (f (cdr b*))]) 504 (prune-and-process! b) 505 body)))))))]) 506 (let ([helper-b* (unbox helper-box)]) 507 (for-each prune-and-process! helper-b*) 508 (with-output-language (Lcommonize2 Expr) 509 `(letrec (,helper-b* ...) (,b* ...) ,body)))))))))) 510 (Expr : Expr (ir) -> Expr () 511 [(letrec ([,x* ,e* ,size*] ...) ,body) 512 ; only unassigned lambda bindings post-cpletrec 513 (safe-assert (andmap (lambda (x) (not (prelex-assigned x))) x*)) 514 (safe-assert (andmap (lambda (e) (Lcommonize1-lambda? e)) e*)) 515 (commonize-letrec x* e* size* body)] 516 [(letrec* ([,x* ,e*] ...) ,body) 517 ; no letrec* run post-cpletrec 518 (assert #f)])) 519 520 (define-pass cpcommonize2 : Lcommonize2 (ir) -> Lsrc () 521 (definitions 522 (define build-caller 523 (lambda (e helper-b helper-arg*) 524 (define-who Arg 525 (lambda (e) 526 (with-output-language (Lsrc Expr) 527 (nanopass-case (Lcommonize1 Expr) e 528 [(ref ,maybe-src ,x) `(ref ,maybe-src ,x)] 529 [(quote ,d) `(quote ,d)] 530 [else (sorry! who "unexpected helper arg ~s" e)])))) 531 (define propagate 532 (lambda (alist) 533 (lambda (e) 534 (nanopass-case (Lsrc Expr) e 535 [(ref ,maybe-src ,x) 536 (cond 537 [(assq x alist) => cdr] 538 [else e])] 539 [else e])))) 540 (nanopass-case (Lcommonize1 Expr) e 541 [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body)) 542 (with-output-language (Lsrc Expr) 543 `(case-lambda ,preinfo 544 (clause (,x* ...) ,interface 545 ,(let loop ([helper-b helper-b] [e* (map Arg helper-arg*)]) 546 (if (binding-helper-b helper-b) 547 (nanopass-case (Lcommonize1 Expr) (binding-e helper-b) 548 [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body)) 549 (loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))]) 550 `(call ,(make-preinfo-call) 551 ,(let ([t (binding-x helper-b)]) 552 (if (prelex-referenced t) 553 (set-prelex-multiply-referenced! t #t) 554 (set-prelex-referenced! t #t)) 555 `(ref #f ,t)) 556 ,e* ...))))))]))) 557 (define maybe-build-caller 558 (lambda (b) 559 (let ([helper-b (binding-helper-b b)] [e (binding-e b)]) 560 (if helper-b 561 (build-caller e helper-b (binding-helper-arg* b)) 562 (Expr e)))))) 563 (Expr : Expr (ir) -> Expr () 564 [(letrec (,helper-b* ...) (,b* ...) ,[body]) 565 (let loop ([rb* (reverse helper-b*)] [x* (map binding-x b*)] [e* (map maybe-build-caller b*)]) 566 (if (null? rb*) 567 `(letrec ([,x* ,e*] ...) ,body) 568 (let ([b (car rb*)] [rb* (cdr rb*)]) 569 (if (prelex-referenced (binding-x b)) 570 (loop rb* (cons (binding-x b) x*) (cons (maybe-build-caller b) e*)) 571 (loop rb* x* e*)))))])) 572 573 (lambda (x) 574 (let ([level (commonization-level)]) 575 (if (fx= level 0) 576 x 577 (let ([worthwhile-size (expt 2 (fx- 10 level))]) 578 (cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size)))))))) 579) 580