1#lang racket/base 2(require "wrap.rkt" 3 "match.rkt" 4 "known.rkt" 5 "import.rkt" 6 "export.rkt" 7 "struct-convert.rkt" 8 "simple.rkt" 9 "source-sym.rkt" 10 "find-definition.rkt" 11 "mutated.rkt" 12 "mutated-state.rkt" 13 "left-to-right.rkt" 14 "let.rkt" 15 "equal.rkt" 16 "optimize.rkt" 17 "find-known.rkt" 18 "infer-known.rkt" 19 "inline.rkt" 20 "letrec.rkt" 21 "unnest-let.rkt" 22 "infer-name.rkt" 23 "ptr-ref-set.rkt" 24 "literal.rkt" 25 "authentic.rkt" 26 "single-valued.rkt" 27 "id-to-var.rkt" 28 "gensym.rkt" 29 "aim.rkt") 30 31(provide schemify-linklet 32 schemify-body) 33 34;; Convert a linklet to a Scheme `lambda`, dealing with several 35;; issues: 36;; 37;; - imports and exports are represented by `variable` objects that 38;; are passed to the function; to avoid obscuring the program to 39;; the optimizer, though, refer to the definitions of exported 40;; variables instead of going through the `variable`, whenever 41;; possible, and accept values instead of `variable`s for constant 42;; imports; 43;; 44;; - wrap expressions in a sequence of definitions plus expressions 45;; so that the result body is a sequence of definitions followed 46;; by a single expression; 47;; 48;; - convert function calls and `let` forms to enforce left-to-right 49;; evaluation; 50;; 51;; - convert function calls to support applicable structs, using 52;; `#%app` whenever a call might go through something other than a 53;; plain function; 54;; 55;; - convert all `letrec` patterns that might involve `call/cc` to 56;; ensure that locations are allocated at the right time; 57;; 58;; - explicitly handle all potential too-early variable uses, so that 59;; the right name and enclosing module are reported; 60;; 61;; - convert `make-struct-type` bindings to a pattern that Chez can 62;; recognize; 63;; 64;; - optimize away `variable-reference-constant?` uses, which is 65;; important to make keyword-argument function calls work directly 66;; without keywords; 67;; 68;; - similarly optimize away `variable-reference-from-unsafe?`; 69;; 70;; - simplify `define-values` and `let-values` to `define` and 71;; `let`, when possible, and generally avoid `let-values`. 72 73;; The given linklet can have parts wrapped as annotations. When 74;; called from the Racket expander, those annotation will be 75;; "correlated" objects that just support source locations. 76 77;; Returns (values schemified-linklet import-abi export-info). 78;; An import ABI is a list of list of booleans, parallel to the 79;; linklet imports, where #t to means that a value is expected, and #f 80;; means that a variable (which boxes a value) is expected. 81;; If `serializable?-box` is not #f, it is filled with a 82;; hash table of objects that need to be handled by `racket/fasl`. 83(define (schemify-linklet lk serializable?-box datum-intern? target allow-set!-undefined? 84 unsafe-mode? enforce-constant? allow-inline? no-prompt? 85 prim-knowns primitives get-import-knowns import-keys) 86 (with-deterministic-gensym 87 (define (im-int-id id) (unwrap (if (pair? id) (cadr id) id))) 88 (define (im-ext-id id) (unwrap (if (pair? id) (car id) id))) 89 (define (ex-int-id id) (unwrap (if (pair? id) (car id) id))) 90 (define (ex-ext-id id) (unwrap (if (pair? id) (cadr id) id))) 91 ;; Assume no wraps unless the level of an id or expression 92 (match lk 93 [`(linklet ,im-idss ,ex-ids . ,bodys) 94 ;; For imports, map symbols to gensymed `variable` argument names, 95 ;; keeping `import` records in groups: 96 (define grps 97 (for/list ([im-ids (in-list im-idss)] 98 [index (in-naturals)]) 99 ;; An import key from `import-keys` lets us get cross-module 100 ;; information on demand 101 (import-group index (and import-keys (vector-ref import-keys index)) 102 get-import-knowns #f #f 103 '()))) 104 ;; Record import information in both the `imports` table and within 105 ;; the import-group record 106 (define imports 107 (let ([imports (make-hasheq)]) 108 (for ([im-ids (in-list im-idss)] 109 [grp (in-list grps)]) 110 (set-import-group-imports! 111 grp 112 (for/list ([im-id (in-list im-ids)]) 113 (define id (im-int-id im-id)) 114 (define ext-id (im-ext-id im-id)) 115 (define int-id (deterministic-gensym id)) 116 (define im (import grp int-id id ext-id)) 117 (hash-set! imports id im) 118 (hash-set! imports int-id im) ; useful for optimizer to look up known info late 119 im))) 120 imports)) 121 ;; Inlining can add new import groups or add imports to an existing group 122 (define new-grps '()) 123 (define add-import! 124 (make-add-import! imports 125 grps 126 get-import-knowns 127 (lambda (new-grp) (set! new-grps (cons new-grp new-grps))))) 128 ;; For exports, too, map symbols to gensymed `variable` argument names 129 (define exports 130 (for/fold ([exports (hasheq)]) ([ex-id (in-list ex-ids)]) 131 (define id (ex-int-id ex-id)) 132 (hash-set exports id (export (deterministic-gensym id) (ex-ext-id ex-id))))) 133 ;; Collect source names for defined identifiers, to the degree that the 134 ;; original source name differs from the current name 135 (define src-syms (get-definition-source-syms bodys)) 136 ;; Schemify the body, collecting information about defined names: 137 (define-values (new-body defn-info mutated) 138 (schemify-body* bodys prim-knowns primitives imports exports 139 serializable?-box datum-intern? allow-set!-undefined? add-import! target 140 unsafe-mode? enforce-constant? allow-inline? no-prompt? #t)) 141 (define all-grps (append grps (reverse new-grps))) 142 (values 143 ;; Build `lambda` with schemified body: 144 `(lambda (instance-variable-reference 145 ,@(for*/list ([grp (in-list all-grps)] 146 [im (in-list (import-group-imports grp))]) 147 (import-id im)) 148 ,@(for/list ([ex-id (in-list ex-ids)]) 149 (export-id (hash-ref exports (ex-int-id ex-id))))) 150 ,@new-body) 151 ;; Imports (external names), possibly extended via inlining: 152 (for/list ([grp (in-list all-grps)]) 153 (for/list ([im (in-list (import-group-imports grp))]) 154 (import-ext-id im))) 155 ;; Exports (external names, but paired with source name if it's different): 156 (for/list ([ex-id (in-list ex-ids)]) 157 (define sym (ex-ext-id ex-id)) 158 (define int-sym (ex-int-id ex-id)) 159 (define src-sym (hash-ref src-syms int-sym sym)) ; external name unless 'source-name 160 (if (eq? sym src-sym) sym (cons sym src-sym))) 161 ;; Import keys --- revised if we added any import groups 162 (if (null? new-grps) 163 import-keys 164 (for/vector #:length (length all-grps) ([grp (in-list all-grps)]) 165 (import-group-key grp))) 166 ;; Import ABI: request values for constants, `variable`s otherwise 167 (for/list ([grp (in-list all-grps)]) 168 (define im-ready? (import-group-lookup-ready? grp)) 169 (for/list ([im (in-list (import-group-imports grp))]) 170 (and im-ready? 171 (let ([k (import-group-lookup grp (import-ext-id im))]) 172 (and (known-constant? k) 173 (if (known-procedure? k) 174 ;; A call to the procedure is probably in unsafe form: 175 'proc 176 ;; Otherwise, accept any value: 177 #t)))))) 178 ;; Convert internal to external identifiers for known-value info 179 (for/fold ([knowns (hasheq)]) ([ex-id (in-list ex-ids)]) 180 (define id (ex-int-id ex-id)) 181 (define v (known-inline->export-known (hash-ref defn-info id #f) 182 prim-knowns imports exports 183 serializable?-box)) 184 (cond 185 [(not (set!ed-mutated-state? (hash-ref mutated id #f))) 186 (define ext-id (ex-ext-id ex-id)) 187 (hash-set knowns ext-id (or v a-known-constant))] 188 [else knowns])))]))) 189 190;; ---------------------------------------- 191 192(define (schemify-body l prim-knowns primitives imports exports 193 target unsafe-mode? no-prompt? explicit-unnamed?) 194 (with-deterministic-gensym 195 (define-values (new-body defn-info mutated) 196 (schemify-body* l prim-knowns primitives imports exports 197 #f #f #f (lambda (im ext-id index) #f) 198 target unsafe-mode? #t #t no-prompt? explicit-unnamed?)) 199 new-body)) 200 201(define (schemify-body* l prim-knowns primitives imports exports 202 serializable?-box datum-intern? allow-set!-undefined? add-import! 203 target unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?) 204 ;; For non-exported definitions, we may need to create some variables 205 ;; to guard against multiple returns or early references 206 (define extra-variables (make-hasheq)) 207 (define (add-extra-variables l) 208 (append (for/list ([(int-id ex) (in-hash extra-variables)]) 209 `(define ,(export-id ex) (make-internal-variable ',int-id))) 210 l)) 211 ;; Keep simple checking efficient by caching results 212 (define simples (make-hasheq)) 213 ;; Various conversion steps need information about mutated variables, 214 ;; where "mutated" here includes visible implicit mutation, such as 215 ;; a variable that might be used before it is defined: 216 (define mutated (mutated-in-body l exports extra-variables prim-knowns (hasheq) imports simples 217 unsafe-mode? target enforce-constant?)) 218 ;; Make another pass to gather known-binding information: 219 (define knowns 220 (for/fold ([knowns (hasheq)]) ([form (in-list l)]) 221 (define-values (new-knowns info) 222 (find-definitions form prim-knowns knowns imports mutated simples unsafe-mode? target 223 #:primitives primitives 224 #:optimize? #t)) 225 new-knowns)) 226 ;; Mutated to communicate the final `knowns` 227 (define final-knowns knowns) 228 ;; While schemifying, add calls to install exported values in to the 229 ;; corresponding exported `variable` records, but delay those 230 ;; installs to the end, if possible 231 (define schemified 232 (let loop ([l l] [in-mut-l l] [accum-exprs null] [accum-ids null] [knowns knowns]) 233 (define mut-l (update-mutated-state! l in-mut-l mutated)) 234 (define (make-set-variables) 235 ;; Resulting list of assinments will be reversed 236 (cond 237 [(or (aim? target 'cify) (aim? target 'interp)) 238 (for/list ([id (in-list accum-ids)] 239 #:when (or (hash-ref exports (unwrap id) #f) 240 (hash-ref extra-variables (unwrap id) #f))) 241 (make-set-variable id exports knowns mutated extra-variables))] 242 [else 243 ;; Group 'consistent variables in one `set-consistent-variables!/define` call 244 (let loop ([accum-ids accum-ids] [consistent-ids null]) 245 (cond 246 [(null? accum-ids) 247 (make-set-consistent-variables consistent-ids exports knowns mutated extra-variables)] 248 [else 249 (define id (car accum-ids)) 250 (define u-id (unwrap id)) 251 (cond 252 [(or (hash-ref exports u-id #f) 253 (hash-ref extra-variables u-id #f)) 254 (cond 255 [(eq? 'consistent (variable-constance u-id knowns mutated)) 256 (loop (cdr accum-ids) (cons id consistent-ids))] 257 [else 258 (append (make-set-consistent-variables consistent-ids exports knowns mutated extra-variables) 259 (cons (make-set-variable id exports knowns mutated extra-variables) 260 (loop (cdr accum-ids) '())))])] 261 [else 262 (loop (cdr accum-ids) consistent-ids)])]))])) 263 (define (make-expr-defns es) 264 (if (or (aim? target 'cify) (aim? target 'interp)) 265 (reverse es) 266 (for/list ([e (in-list (reverse es))]) 267 (make-expr-defn e)))) 268 (cond 269 [(null? l) 270 (set! final-knowns knowns) 271 ;; Finish by making sure that all pending variables in `accum-ids` are 272 ;; moved into their `variable` records: 273 (define set-vars (make-set-variables)) 274 (cond 275 [(null? set-vars) 276 (cond 277 [(null? accum-exprs) '((void))] 278 [else (reverse accum-exprs)])] 279 [else (reverse (append set-vars accum-exprs))])] 280 [else 281 (define form (car l)) 282 (define schemified (schemify form 283 prim-knowns primitives knowns mutated imports exports extra-variables simples 284 allow-set!-undefined? 285 add-import! 286 serializable?-box datum-intern? target 287 unsafe-mode? allow-inline? no-prompt? explicit-unnamed? 288 (if (and no-prompt? (null? (cdr l))) 289 'tail 290 'fresh))) 291 ;; For the case that the right-hand side won't capture a 292 ;; continuation or return multiple times, we can generate a 293 ;; simple definition: 294 (define (finish-definition ids [accum-exprs accum-exprs] [accum-ids accum-ids] 295 #:knowns [knowns knowns] 296 #:schemified [schemified schemified] 297 #:next-k [next-k #f]) 298 ;; Maybe schemify made a known shape apparent: 299 (define next-knowns 300 (cond 301 [(and (pair? ids) 302 (null? (cdr ids)) 303 (can-improve-infer-known? (hash-ref knowns (unwrap (car ids)) #f))) 304 (define id (car ids)) 305 (define k (match schemified 306 [`(define ,id ,rhs) 307 (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target 308 #:post-schemify? #t)])) 309 (if k 310 (hash-set knowns (unwrap id) k) 311 knowns)] 312 [else knowns])) 313 (append 314 (make-expr-defns accum-exprs) 315 (cons 316 schemified 317 (let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids]) 318 (cond 319 [(null? ids) (if next-k 320 (next-k accum-exprs accum-ids next-knowns) 321 (loop (cdr l) mut-l accum-exprs accum-ids next-knowns))] 322 [(or (or (aim? target 'interp) (aim? target 'cify)) 323 (via-variable-mutated-state? (hash-ref mutated (unwrap (car ids)) #f))) 324 (define id (unwrap (car ids))) 325 (cond 326 [(or (hash-ref exports id #f) 327 (hash-ref extra-variables id #f)) 328 (id-loop (cdr ids) 329 (cons (make-set-variable id exports knowns mutated extra-variables) 330 accum-exprs) 331 accum-ids)] 332 [else 333 (id-loop (cdr ids) accum-exprs accum-ids)])] 334 [else 335 (id-loop (cdr ids) accum-exprs (cons (car ids) accum-ids))]))))) 336 ;; For the case when the right-hand side might capture a 337 ;; continuation or return multiple times, so we need a prompt. 338 ;; The `variable` records are set within the prompt, while 339 ;; definitions appear outside the prompt to just transfer the 340 ;; value into a `variable` record (if it's not one that is 341 ;; mutable, and therefore always access via the `variable` 342 ;; record): 343 (define (finish-wrapped-definition ids rhs) 344 (append 345 (make-expr-defns accum-exprs) 346 (make-expr-defns (make-set-variables)) 347 (cond 348 [no-prompt? 349 (cons 350 (cond 351 [(or unsafe-mode? 352 (aim? target 'system) 353 (and (pair? ids) (null? (cdr ids)))) 354 schemified] 355 [else 356 `(define-values ,ids 357 (call-with-values 358 (lambda () ,rhs) 359 (case-lambda 360 [,ids (values . ,ids)] 361 [vals (raise-definition-result-arity-error ',ids vals)])))]) 362 (loop (cdr l) mut-l null (reverse ids) knowns))] 363 [else 364 (define expr 365 `(call-with-module-prompt 366 (lambda () ,rhs) 367 ',ids 368 ',(for/list ([id (in-list ids)]) 369 (variable-constance (unwrap id) knowns mutated)) 370 ,@(for/list ([id (in-list ids)]) 371 (id-to-variable (unwrap id) exports extra-variables)))) 372 (define defns 373 (for/list ([id (in-list ids)]) 374 (make-define-variable id exports knowns mutated extra-variables))) 375 (cons 376 (if (aim? target 'interp) 377 expr 378 (make-expr-defn expr)) 379 (append defns (loop (cdr l) mut-l null null knowns)))]))) 380 ;; Dispatch on the schemified form, distinguishing definitions 381 ;; from expressions: 382 (match schemified 383 [`(define ,id ,rhs) 384 (cond 385 [(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples unsafe-mode?) 386 (finish-definition (list id))] 387 [else 388 (finish-wrapped-definition (list id) rhs)])] 389 [`(define-values ,ids ,rhs) 390 (cond 391 [(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples unsafe-mode? 392 #:result-arity (length ids)) 393 (match rhs 394 [`(values ,rhss ...) 395 ;; Flatten `(define-values (id ...) (values rhs ...))` to 396 ;; a sequence `(define id rhs) ...` 397 (if (and (= (length rhss) (length ids)) 398 ;; Must be simple enough, otherwise a variable might be referenced 399 ;; too early: 400 (for/and ([rhs (in-list rhss)]) 401 (simple? rhs prim-knowns knowns imports mutated simples unsafe-mode?))) 402 (let values-loop ([ids ids] [rhss rhss] [accum-exprs accum-exprs] [accum-ids accum-ids] [knowns knowns]) 403 (cond 404 [(null? ids) (loop (cdr l) mut-l accum-exprs accum-ids knowns)] 405 [else 406 (define id (car ids)) 407 (define rhs (car rhss)) 408 (finish-definition (list id) accum-exprs accum-ids 409 #:knowns knowns 410 #:schemified `(define ,id ,rhs) 411 #:next-k (lambda (accum-exprs accum-ids knowns) 412 (values-loop (cdr ids) (cdr rhss) accum-exprs accum-ids knowns)))])) 413 (finish-definition ids))] 414 [`,_ (finish-definition ids)])] 415 [else 416 (finish-wrapped-definition ids rhs)])] 417 [`(quote ,_) ; useful to drop #<void>s for the interpreter 418 #:guard (or (pair? (cdr l)) (pair? accum-ids)) 419 (loop (cdr l) mut-l accum-exprs accum-ids knowns)] 420 [`,_ 421 (match form 422 [`(define-values ,ids ,_) 423 ;; This is a rearranged `struct` form where any necessary 424 ;; prompt is in place already. There may be arbitrary expressions 425 ;; for properties, though, so sync exported variables 426 (define set-vars (make-set-variables)) 427 (finish-definition ids (append set-vars accum-exprs) null)] 428 [`,_ 429 (cond 430 [(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples unsafe-mode? 431 #:result-arity #f) 432 (loop (cdr l) mut-l (cons schemified accum-exprs) accum-ids knowns)] 433 [else 434 ;; In case `schemified` triggers an error, sync exported variables 435 (define set-vars (make-set-variables)) 436 (define expr (if no-prompt? 437 schemified 438 `(call-with-module-prompt (lambda () ,schemified)))) 439 (loop (cdr l) mut-l (cons expr (append set-vars accum-exprs)) null knowns)])])])]))) 440 ;; Return both schemified and known-binding information, where 441 ;; the later is used for cross-linklet optimization 442 (values (add-extra-variables schemified) final-knowns mutated)) 443 444(define (make-set-variable id exports knowns mutated [extra-variables #f]) 445 (define int-id (unwrap id)) 446 (define ex-id (id-to-variable int-id exports extra-variables)) 447 `(variable-set!/define ,ex-id ,id ',(variable-constance int-id knowns mutated))) 448 449;; returns a list equilanet to a sequence of `variable-set!/define` forms 450(define (make-set-consistent-variables ids exports knowns mutated extra-variables) 451 (cond 452 [(null? ids) null] 453 [(null? (cdr ids)) (list (make-set-variable (car ids) exports knowns mutated extra-variables))] 454 [else 455 (define ex-ids (for/list ([id (in-list ids)]) 456 (id-to-variable (unwrap id) exports extra-variables))) 457 `((set-consistent-variables!/define (vector ,@ex-ids) (vector ,@ids)))])) 458 459(define (make-define-variable id exports knowns mutated extra-variables) 460 (define int-id (unwrap id)) 461 (define ex (or (hash-ref exports int-id #f) 462 (hash-ref extra-variables int-id))) 463 `(define ,id (variable-ref/no-check ,(export-id ex)))) 464 465(define (make-expr-defn expr) 466 `(define ,(deterministic-gensym "effect") (begin ,expr (void)))) 467 468(define (variable-constance id knowns mutated) 469 (cond 470 [(set!ed-mutated-state? (hash-ref mutated id #f)) 471 #f] 472 [(known-consistent? (hash-ref knowns id #f)) 473 'consistent] 474 [else 475 'constant])) 476 477;; ---------------------------------------- 478 479;; Schemify `let-values` to `let`, etc., and reorganize struct bindings. 480;; 481;; Non-simple `mutated` state overrides bindings in `knowns`; a 482;; a 'too-early state in `mutated` for a `letrec`-bound variable can be 483;; effectively canceled with a mapping in `knowns`. 484(define (schemify v prim-knowns primitives knowns mutated imports exports extra-variables simples allow-set!-undefined? add-import! 485 serializable?-box datum-intern? target unsafe-mode? allow-inline? no-prompt? explicit-unnamed? 486 wcm-state) 487 ;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks) 488 (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v]) 489 (define (schemify v wcm-state) 490 (define s-v 491 (reannotate 492 v 493 (match v 494 [`(lambda ,formals ,body ...) 495 (infer-procedure-name 496 v 497 `(lambda ,formals ,@(schemify-body body 'tail)) 498 explicit-unnamed?)] 499 [`(case-lambda [,formalss ,bodys ...] ...) 500 (infer-procedure-name 501 v 502 `(case-lambda ,@(for/list ([formals (in-list formalss)] 503 [body (in-list bodys)]) 504 `[,formals ,@(schemify-body body 'tail)])) 505 explicit-unnamed?)] 506 [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) 507 (let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk)) 508 (values ,struct:2 509 ,make2 510 ,?2 511 ,make-acc/muts ...))) 512 #:guard (not (or (aim? target 'interp) (aim? target 'cify))) 513 (define new-seq 514 (struct-convert v prim-knowns knowns imports exports mutated 515 (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) 516 target no-prompt? #t)) 517 (or new-seq 518 (match v 519 [`(,_ ,ids ,rhs) 520 `(define-values ,ids ,(schemify rhs 'fresh))]))] 521 [`(define-values (,id) ,rhs) 522 `(define ,id ,(schemify rhs 'fresh))] 523 [`(define-values ,ids ,rhs) 524 `(define-values ,ids ,(schemify rhs 'fresh))] 525 [`(quote ,q) 526 (when serializable?-box 527 (register-literal-serialization q serializable?-box datum-intern?)) 528 v] 529 [`(let-values () ,body) 530 (schemify body wcm-state)] 531 [`(let-values () ,bodys ...) 532 (schemify `(begin . ,bodys) wcm-state)] 533 [`(let-values ([(,ids) ,rhss] ...) ,bodys ...) 534 (cond 535 [(and (pair? ids) (null? (cdr ids)) 536 (pair? bodys) (null? (cdr bodys)) 537 (eq? (unwrap (car ids)) (unwrap (car bodys))) 538 (lambda? (car rhss))) 539 ;; Simplify by discarding the binding; assume that any 540 ;; needed naming is already reflected in properties 541 (schemify (car rhss) wcm-state)] 542 [else 543 (define new-knowns 544 (for/fold ([knowns knowns]) ([id (in-list ids)] 545 [rhs (in-list rhss)]) 546 (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target)) 547 (if k 548 (hash-set knowns (unwrap id) k) 549 knowns))) 550 (define (merely-a-copy? id) 551 (define u-id (unwrap id)) 552 (define k (hash-ref new-knowns u-id #f)) 553 (and (or (known-copy? k) 554 (known-literal? k)) 555 (simple-mutated-state? (hash-ref mutated u-id #f)))) 556 (unnest-let 557 (left-to-right/let (for/list ([id (in-list ids)] 558 #:unless (merely-a-copy? id)) 559 id) 560 (for/list ([id (in-list ids)] 561 [rhs (in-list rhss)] 562 #:unless (merely-a-copy? id)) 563 (schemify rhs 'fresh)) 564 (for/list ([body (in-list bodys)]) 565 (schemify/knowns new-knowns inline-fuel wcm-state body)) 566 prim-knowns knowns imports mutated simples unsafe-mode?) 567 prim-knowns knowns imports mutated simples unsafe-mode?)])] 568 [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...) 569 `(begin ,@(schemify-body rhss 'fresh) ,@(schemify-body bodys wcm-state))] 570 [`(let-values ([,idss ,rhss] ...) ,bodys ...) 571 (or (and (not (or (aim? target 'interp) (aim? target 'cify))) 572 (struct-convert-local v prim-knowns knowns imports mutated simples 573 (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) 574 #:unsafe-mode? unsafe-mode? 575 #:target target)) 576 (unnest-let 577 (left-to-right/let-values idss 578 (for/list ([rhs (in-list rhss)]) 579 (schemify rhs 'fresh)) 580 (schemify-body bodys wcm-state) 581 mutated 582 target) 583 prim-knowns knowns imports mutated simples unsafe-mode?))] 584 [`(letrec-values () ,bodys ...) 585 (schemify `(begin . ,bodys) wcm-state)] 586 [`(letrec-values ([() (values)]) ,bodys ...) 587 (schemify `(begin . ,bodys) wcm-state)] 588 [`(letrec-values ([(,id) (values ,rhs)]) ,bodys ...) 589 ;; special case of splitable values: 590 (schemify `(letrec-values ([(,id) ,rhs]) . ,bodys) wcm-state)] 591 [`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...) 592 (define-values (rhs-knowns body-knowns) 593 (for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)] 594 [rhs (in-list rhss)]) 595 (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target)) 596 (define u-id (unwrap id)) 597 (cond 598 [(too-early-mutated-state? (hash-ref mutated u-id #f)) 599 (values rhs-knowns (hash-set knowns u-id (or k a-known-constant)))] 600 [k (values (hash-set rhs-knowns u-id k) (hash-set body-knowns u-id k))] 601 [else (values rhs-knowns body-knowns)]))) 602 (unnest-let 603 (letrec-conversion 604 ids mutated target 605 `(letrec* ,(for/list ([id (in-list ids)] 606 [rhs (in-list rhss)]) 607 `[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)]) 608 ,@(for/list ([body (in-list bodys)]) 609 (schemify/knowns body-knowns inline-fuel wcm-state body)))) 610 prim-knowns knowns imports mutated simples unsafe-mode?)] 611 [`(letrec-values ([,idss ,rhss] ...) ,bodys ...) 612 (cond 613 [(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples 614 (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) 615 #:unsafe-mode? unsafe-mode? 616 #:target target) 617 => (lambda (form) form)] 618 [(letrec-splitable-values-binding? idss rhss) 619 (schemify 620 (letrec-split-values-binding idss rhss bodys) 621 wcm-state)] 622 [else 623 ;; Convert 624 ;; (letrec*-values ([(id ...) rhs] ...) ....) 625 ;; to 626 ;; (letrec* ([vec (call-with-values rhs vector)] 627 ;; [id (vector-ref vec 0)] 628 ;; ... ...) 629 ;; ....) 630 (letrec-conversion 631 idss mutated target 632 `(letrec* ,(apply 633 append 634 (for/list ([ids (in-list idss)] 635 [rhs (in-list rhss)]) 636 (let ([rhs (schemify rhs 'fresh)]) 637 (cond 638 [(null? ids) 639 `([,(deterministic-gensym "lr") 640 ,(make-let-values null rhs '(void) target)])] 641 [(and (pair? ids) (null? (cdr ids))) 642 `([,(car ids) ,rhs])] 643 [else 644 (define lr (deterministic-gensym "lr")) 645 `([,lr ,(make-let-values ids rhs `(vector . ,ids) target)] 646 ,@(for/list ([id (in-list ids)] 647 [pos (in-naturals)]) 648 `[,id (unsafe-vector*-ref ,lr ,pos)]))])))) 649 ,@(schemify-body bodys wcm-state)))])] 650 [`(if ,tst ,thn ,els) 651 `(if ,(schemify tst 'fresh) ,(schemify thn wcm-state) ,(schemify els wcm-state))] 652 [`(with-continuation-mark ,key ,val ,body) 653 (define s-key (schemify key 'fresh)) 654 (define s-val (schemify val 'fresh)) 655 (define s-body (schemify body 'marked)) 656 (define authentic-key? 657 (authentic-valued? key knowns prim-knowns imports mutated)) 658 (define (build-wcm s-key s-val s-body) 659 (cond 660 [(aim? target 'cify) 661 `(with-continuation-mark ,s-key ,s-val ,s-body)] 662 [else 663 (define mode 664 (case wcm-state 665 [(fresh) (if authentic-key? 'push-authentic 'push)] 666 [else (if authentic-key? 'authentic 'general)])) 667 `(with-continuation-mark* ,mode ,s-key ,s-val ,s-body)])) 668 (define (build-begin s-key s-val s-body) 669 (cond 670 [(and (simple? s-key prim-knowns knowns imports mutated simples unsafe-mode?) 671 (simple? s-val prim-knowns knowns imports mutated simples unsafe-mode?)) 672 ;; Avoid `begin` wrapper to help further `with-continuation-mark` optimizations 673 s-body] 674 [else 675 `(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated) 676 ,(ensure-single-valued s-val knowns prim-knowns imports mutated) 677 ,s-body)])) 678 (cond 679 [authentic-key? 680 (cond 681 [(simple? s-body prim-knowns knowns imports mutated simples unsafe-mode? #:result-arity #f) 682 (build-begin s-key s-val s-body)] 683 [else 684 ;; Simplify (with-continuation-mark <same-key> <val1> 685 ;; (with-continuation-mark <same-key> <val2> 686 ;; <body>) 687 ;; to (begin <same-key> <val1> 688 ;; (with-continuation-mark <same-key> <val2> 689 ;; <body>)) 690 ;; as long as <same-key> and <val2> don't use marks 691 (match s-body 692 [`(with-continuation-mark* ,mode2 ,s-key2 ,s-val2 ,s-body2) 693 (cond 694 [(and (always-eq/no-marks? s-key s-key2 mutated) 695 (simple? s-val2 prim-knowns knowns imports mutated simples unsafe-mode?)) 696 (build-begin s-key s-val 697 ;; rebuild to use current `wcm-state`: 698 (build-wcm s-key2 s-val2 s-body2))] 699 [else (build-wcm s-key s-val s-body)])] 700 [`,_ (build-wcm s-key s-val s-body)])])] 701 [else 702 (build-wcm s-key s-val s-body)])] 703 [`(begin ,exp) 704 (schemify exp wcm-state)] 705 [`(begin ,exps ...) 706 `(begin . ,(schemify-body exps wcm-state))] 707 [`(begin-unsafe ,exps ...) 708 `(begin-unsafe . ,(schemify-body exps wcm-state))] 709 [`(begin0 ,exp) 710 (schemify exp wcm-state)] 711 [`(begin0 ,exp ,exps ...) 712 `(begin0 ,(schemify exp 'fresh) . ,(schemify-body exps 'fresh))] 713 [`(set! ,id ,rhs) 714 (define int-id (unwrap id)) 715 (define ex (or (hash-ref exports int-id #f) 716 (hash-ref extra-variables int-id #f))) 717 (define new-rhs (schemify rhs 'fresh)) 718 (define state (hash-ref mutated int-id #f)) 719 (cond 720 [ex 721 (define set-id 722 (if (or allow-set!-undefined? 723 (not (too-early-mutated-state? state))) 724 'variable-set! 725 'variable-set!/check-undefined)) 726 `(,set-id ,(export-id ex) ,new-rhs)] 727 [else 728 (cond 729 [(and (too-early-mutated-state? state) 730 (not (aim? target 'cify))) 731 (define tmp (deterministic-gensym "set")) 732 `(let ([,tmp ,new-rhs]) 733 (check-not-unsafe-undefined/assign ,id ',(too-early-mutated-state-name state int-id)) 734 (set! ,id ,tmp))] 735 [(not state) 736 ;; It's worrying that `id` is not marked as mutable, but this is 737 ;; possible when mutability inference determines that the `set!` is 738 ;; dead code. Since the variable is not mutated, it might even be 739 ;; optimized away by schemify; so, just in case, discard the `set!`. 740 `(void ,new-rhs)] 741 [else 742 `(set! ,id ,new-rhs)])])] 743 [`(variable-reference-constant? (#%variable-reference ,id)) 744 (define u-id (unwrap id)) 745 (cond 746 [(hash-ref mutated u-id #f) #f] 747 [else 748 (define im (hash-ref imports u-id #f)) 749 (cond 750 [(not im) 751 ;; Not imported and not mutable => a constant or local defined 752 ;; in this linklet or a direct primitive reference 753 #t] 754 [(known-constant? (import-lookup im)) #t] 755 [else 756 ;; Not statically known 757 `(variable-reference-constant? ,(schemify `(#%variable-reference ,id) 'fresh))])])] 758 [`(variable-reference-from-unsafe? (#%variable-reference)) 759 unsafe-mode?] 760 [`(#%variable-reference) 761 'instance-variable-reference] 762 [`(#%variable-reference ,id) 763 (define u (unwrap id)) 764 (define v (or (let ([ex (or (hash-ref exports u #f) 765 (hash-ref extra-variables u #f))]) 766 (and ex (export-id ex))) 767 (let ([im (hash-ref imports u #f)]) 768 (and im (import-id im))))) 769 (if v 770 `(make-instance-variable-reference 771 instance-variable-reference 772 ,v) 773 `(make-instance-variable-reference 774 instance-variable-reference 775 ',(cond 776 [(hash-ref mutated u #f) 'mutable] 777 [(hash-ref prim-knowns u #f) u] ; assuming that `mutable` and `constant` are not primitives 778 [else 'constant])))] 779 [`(equal? ,exp1 ,exp2) 780 (let ([exp1 (schemify exp1 'fresh)] 781 [exp2 (schemify exp2 'fresh)]) 782 (cond 783 [(eq? exp1 exp2) 784 #t] 785 [(or (equal-implies-eq? exp1) (equal-implies-eq? exp2)) 786 `(eq? ,exp1 ,exp2)] 787 [(or (equal-implies-eqv? exp1) (equal-implies-eqv? exp2)) 788 `(eqv? ,exp1 ,exp2)] 789 [else 790 (left-to-right/app 'equal? 791 (list exp1 exp2) 792 #f target 793 prim-knowns knowns imports mutated simples unsafe-mode?)]))] 794 [`(call-with-values ,generator ,receiver) 795 (cond 796 [(and (lambda? generator) 797 (or (lambda? receiver) 798 (eq? (unwrap receiver) 'list))) 799 `(call-with-values ,(schemify generator 'fresh) ,(schemify receiver 'fresh))] 800 [else 801 (left-to-right/app (if (aim? target 'cify) 'call-with-values '#%call-with-values) 802 (list (schemify generator 'fresh) (schemify receiver 'fresh)) 803 #f target 804 prim-knowns knowns imports mutated simples unsafe-mode?)])] 805 [`(single-flonum-available?) 806 ;; Fold to a boolean to allow earlier simplification 807 (aim? target 'cify)] 808 [`((letrec-values ,binds ,rator) ,rands ...) 809 (schemify `(letrec-values ,binds (,rator . ,rands)) wcm-state)] 810 [`(,rator ,exps ...) 811 (define (left-left-lambda-convert rator inline-fuel) 812 (match rator 813 [`(lambda ,formal-args ,bodys ...) 814 ;; Try to line up `formal-args` with `exps` 815 (let loop ([formal-args formal-args] [args exps] [binds '()]) 816 (cond 817 [(null? formal-args) 818 (and (null? args) 819 (let ([r (schemify/knowns knowns 820 inline-fuel 821 wcm-state 822 `(let-values ,(reverse binds) . ,bodys))]) 823 ;; make suure constant-fold to #f counts as success: 824 (or r `(quote #f))))] 825 [(null? args) #f] 826 [(not (pair? formal-args)) 827 (loop '() '() (cons (list (list formal-args) 828 (if (null? args) 829 ''() 830 (cons 'list args))) 831 binds))] 832 [else 833 (loop (cdr formal-args) 834 (cdr args) 835 (cons (list (list (car formal-args)) 836 (car args)) 837 binds))]))] 838 [`(case-lambda [,formal-args ,bodys ...] . ,rest) 839 (or (left-left-lambda-convert `(lambda ,formal-args . ,bodys) inline-fuel) 840 (left-left-lambda-convert `(case-lambda . ,rest) inline-fuel))] 841 [`,_ #f])) 842 (define (inline-rator) 843 (define u-rator (unwrap rator)) 844 (and allow-inline? 845 (symbol? u-rator) 846 (let-values ([(k im) (find-known+import u-rator prim-knowns knowns imports mutated)]) 847 (and (known-procedure/can-inline? k) 848 (left-left-lambda-convert 849 (inline-clone k im add-import! mutated imports) 850 (sub1 inline-fuel)))))) 851 (define (maybe-tmp e name) 852 ;; use `e` directly if it's ok to duplicate 853 (if (simple/can-copy? e prim-knowns knowns imports mutated) 854 e 855 (deterministic-gensym name))) 856 (define (wrap-tmp tmp e body) 857 (if (eq? tmp e) 858 body 859 `(let ([,tmp ,e]) 860 ,body))) 861 (define (inline-struct-constructor k s-rator im args) 862 (define type-id (and (bitwise-bit-set? (known-procedure-arity-mask k) (length args)) 863 (inline-type-id k im add-import! mutated imports))) 864 (cond 865 [type-id 866 (left-to-right/app 'unsafe-struct 867 (cons (schemify type-id 'fresh) args) 868 #f target 869 prim-knowns knowns imports mutated simples unsafe-mode?)] 870 [else #f])) 871 (define (inline-struct-predicate k s-rator im args) 872 (define type-id (and (pair? args) 873 (null? (cdr args)) 874 (inline-type-id k im add-import! mutated imports))) 875 (define unsafe-struct? (if (known-struct-predicate-sealed? k) 876 'unsafe-sealed-struct? 877 'unsafe-struct?)) 878 (cond 879 [(not type-id) #f] 880 [(known-struct-predicate-authentic? k) 881 (define tmp (maybe-tmp (car args) 'v)) 882 (define ques `(,unsafe-struct? ,tmp ,(schemify type-id 'fresh))) 883 (wrap-tmp tmp (car args) 884 ques)] 885 [else 886 (define tmp (maybe-tmp (car args) 'v)) 887 (define schemified-type-id (schemify type-id 'fresh)) 888 (define tmp-type-id (maybe-tmp schemified-type-id 'v)) 889 (define ques `(if (,unsafe-struct? ,tmp ,tmp-type-id) 890 #t 891 (if (impersonator? ,tmp) 892 (,unsafe-struct? (impersonator-val ,tmp) ,tmp-type-id) 893 #f))) 894 (wrap-tmp tmp (car args) 895 (wrap-tmp tmp-type-id schemified-type-id 896 ques))])) 897 (define (inline-field-access k s-rator im args) 898 ;; Inline the selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`. 899 (define type-id (and (pair? args) 900 (null? (cdr args)) 901 (inline-type-id k im add-import! mutated imports))) 902 (cond 903 [type-id 904 (define tmp (maybe-tmp (car args) 'v)) 905 (define sel (if (and unsafe-mode? 906 (known-field-accessor-authentic? k)) 907 `(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k)) 908 `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh)) 909 (unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k)) 910 ,(let ([a `(,s-rator ,tmp)]) 911 (if (known-field-accessor-authentic? k) 912 (cons '#%app/no-return a) 913 a))))) 914 (wrap-tmp tmp (car args) 915 sel)] 916 [else #f])) 917 (define (inline-field-mutate k s-rator im args) 918 (define type-id (and (pair? args) 919 (pair? (cdr args)) 920 (null? (cddr args)) 921 (inline-type-id k im add-import! mutated imports))) 922 (cond 923 [type-id 924 (define tmp (maybe-tmp (car args) 'v)) 925 (define tmp-rhs (maybe-tmp (cadr args) 'rhs)) 926 (define mut (if (and unsafe-mode? 927 (known-field-mutator-authentic? k)) 928 `(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs) 929 `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh)) 930 (unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs) 931 ,(let ([a `(,s-rator ,tmp ,tmp-rhs)]) 932 (if (known-field-mutator-authentic? k) 933 (cons '#%app/no-return a) 934 a))))) 935 (wrap-tmp tmp (car args) 936 (wrap-tmp tmp-rhs (cadr args) 937 mut))] 938 [else #f])) 939 (or (left-left-lambda-convert rator inline-fuel) 940 (and (positive? inline-fuel) 941 (inline-rator)) 942 (let ([s-rator (schemify rator 'fresh)] 943 [args (schemify-body exps 'fresh)] 944 [u-rator (unwrap rator)]) 945 (define-values (k im) (find-known+import u-rator prim-knowns knowns imports mutated)) 946 (cond 947 [(or (and (eq? rator 'ptr-ref) (inline-ptr-ref args)) 948 (and (eq? rator 'ptr-set!) (inline-ptr-set args))) 949 => (lambda (e) 950 (left-to-right/app (car e) 951 (cdr e) 952 #f target 953 prim-knowns knowns imports mutated simples unsafe-mode?))] 954 [(and (not (or 955 ;; Don't inline in cify mode, because cify takes care of it 956 (aim? target 'cify) 957 ;; Don't inline in 'system mode, because there will 958 ;; be no `|#%struct-constructor| in the way, and 959 ;; it's more readable to use the normal constructor name 960 (aim? target 'system))) 961 (known-struct-constructor? k) 962 (inline-struct-constructor k s-rator im args)) 963 => (lambda (e) e)] 964 [(and (not (or 965 (aim? target 'cify) 966 (aim? target 'system))) 967 (known-struct-predicate? k) 968 (inline-struct-predicate k s-rator im args)) 969 => (lambda (e) e)] 970 [(and (not (or 971 (aim? target 'cify) 972 (aim? target 'system))) 973 (known-field-accessor? k) 974 (inline-field-access k s-rator im args)) 975 => (lambda (e) e)] 976 [(and (not (or 977 (aim? target 'cify) 978 (aim? target 'system))) 979 (known-field-mutator? k) 980 (inline-field-mutate k s-rator im args)) 981 => (lambda (e) e)] 982 [(and unsafe-mode? 983 (known-procedure/has-unsafe? k)) 984 (left-to-right/app (known-procedure/has-unsafe-alternate k) 985 args 986 #f target 987 prim-knowns knowns imports mutated simples unsafe-mode?)] 988 [else 989 (left-to-right/app s-rator 990 args 991 (cond 992 [(and (not (aim? target 'system)) 993 (known-procedure/no-return? k)) 994 '#%app/no-return] 995 [(and im 996 (known-procedure/single-valued? k)) 997 '#%app/value] 998 [(or (known-procedure? k) 999 (lambda? rator)) 1000 #f] 1001 [else '|#%app|]) 1002 target 1003 prim-knowns knowns imports mutated simples unsafe-mode?)])))] 1004 [`,_ 1005 (let ([u-v (unwrap v)]) 1006 (cond 1007 [(not (symbol? u-v)) v] 1008 [(eq? u-v 'call-with-values) 1009 '#%call-with-values] 1010 [else 1011 (define state (hash-ref mutated u-v #f)) 1012 (cond 1013 [(and (via-variable-mutated-state? state) 1014 (or (hash-ref exports u-v #f) 1015 (hash-ref extra-variables u-v #f))) 1016 => (lambda (ex) 1017 (if (too-early-mutated-state? state) 1018 `(variable-ref ,(export-id ex)) 1019 `(variable-ref/no-check ,(export-id ex))))] 1020 [(hash-ref imports u-v #f) 1021 => (lambda (im) 1022 (define k (import-lookup im)) 1023 (if (known-constant? k) 1024 ;; Not boxed: 1025 (cond 1026 [(known-literal? k) 1027 ;; We'd normally leave this to `optimize`, but 1028 ;; need to handle it here before generating a 1029 ;; reference to the renamed identifier 1030 (wrap-literal (known-literal-value k))] 1031 [(and (known-copy? k) 1032 (hash-ref prim-knowns (known-copy-id k) #f)) 1033 ;; Directly reference primitive 1034 (known-copy-id k)] 1035 [else 1036 (import-id im)]) 1037 ;; Will be boxed, but won't be undefined (because the 1038 ;; module system won't link to an instance whose 1039 ;; definitions didn't complete): 1040 `(variable-ref/no-check ,(import-id im))))] 1041 [(hash-ref knowns u-v #f) 1042 => (lambda (k) 1043 (cond 1044 [(and (known-copy? k) 1045 (simple-mutated-state? (hash-ref mutated u-v #f))) 1046 (schemify (known-copy-id k) wcm-state)] 1047 [else v]))] 1048 [(and (too-early-mutated-state? state) 1049 (not (aim? target 'cify))) 1050 ;; Note: we don't get to this case if `knowns` has 1051 ;; a mapping that says the variable is ready by now 1052 `(check-not-unsafe-undefined ,v ',(too-early-mutated-state-name state u-v))] 1053 [else v])]))]))) 1054 (optimize s-v prim-knowns primitives knowns imports mutated)) 1055 1056 (define (schemify-body l wcm-state) 1057 (cond 1058 [(null? l) null] 1059 [(null? (cdr l)) 1060 (list (schemify (car l) wcm-state))] 1061 [else 1062 (cons (schemify (car l) 'fresh) 1063 (schemify-body (cdr l) wcm-state))])) 1064 1065 (schemify v wcm-state))) 1066