1;;; interpret.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;;; TODO 17;;; - recognize direct close calls in ip2 to avoid creation of closure 18;;; (but not closure pointer) and overhead of call 19;;; - handle let & letrec better 20;;; - use arg regs when available 21;;; - wire up letrec closures, then treat like let (good luck) 22;;; - optimize direct calls when no free vars 23;;; - since closure is just code in this case, can wire it in directly 24 25(let () 26(import (nanopass)) 27(include "base-lang.ss") 28(include "expand-lang.ss") 29 30(define-record-type c-var 31 (fields (immutable id) (immutable parent) (mutable index) (mutable loc)) 32 (nongenerative) 33 (sealed #t) 34 (protocol 35 (lambda (new) 36 (lambda (id parent) 37 (new id parent #f #f))))) 38 39(define list-of-c-var? 40 (lambda (x) 41 (and (list? x) (andmap c-var? x)))) 42 43(define-language Linterp 44 (extends Lsrc) 45 (terminals 46 (- ($prelex (x))) 47 (+ (c-var (x)) 48 (list-of-c-var (free)))) 49 (Expr (e body rtd-expr) 50 (- (case-lambda preinfo cl ...) 51 (call preinfo e0 e1 ...) 52 (moi) 53 (pariah) 54 (ref maybe-src x) 55 (set! maybe-src x e) 56 (profile src)) 57 (+ x 58 (close free cl ...) 59 (call e e* ...) 60 (set! x e)))) 61 62(define ip1 63(let () 64(define-record-type c-env 65 (fields (immutable prev) (mutable vars)) 66 (nongenerative) 67 (sealed #t) 68 (protocol 69 (lambda (new) 70 (lambda (prev) 71 (new prev '()))))) 72 73(define-pass ip1 : Lsrc (ir) -> Linterp () 74 (definitions 75 (define ip1-lambda 76 (lambda (clauses env) 77 (let ([env (make-c-env env)]) 78 (let ([bodies 79 (map (lambda (clause) 80 (nanopass-case (Lsrc CaseLambdaClause) clause 81 [(clause (,x* ...) ,interface ,body) 82 (with-vars (vars x* env) 83 (with-output-language (Linterp CaseLambdaClause) 84 (let ([body (Expr body env)]) 85 `(clause (,vars ...) ,interface ,body))))] 86 [else (errorf 'ip1-lambda "found something unexpected ~s\n" clause)])) 87 clauses)]) 88 (with-output-language (Linterp Expr) 89 `(close ,(ip1-free env) ,bodies ...)))))) 90 (define ip1-letrec 91 (lambda (ids vals body env) 92 (with-output-language (Lsrc Expr) 93 (define build-let 94 (lambda (ids vals body) 95 (if (null? ids) 96 body 97 `(call ,(make-preinfo-call) 98 (case-lambda ,(make-preinfo-lambda) 99 (clause (,ids ...) ,(length ids) ,body)) 100 ,vals ...)))) 101 (Expr (if (null? ids) 102 body 103 (build-let ids (map (lambda (x) `(quote ,(void))) ids) 104 (fold-left (lambda (body id val) 105 (set-prelex-assigned! id #t) 106 `(seq (set! #f ,id ,val) ,body)) 107 body ids vals))) 108 env))))) 109 (Expr : Expr (ir [env #f]) -> Expr () 110 [(ref ,maybe-src ,x) (ip1-lookup-lexical x env)] 111 [(case-lambda ,preinfo ,cl* ...) (ip1-lambda cl* env)] 112 [(call ,preinfo ,[e] ,[e*] ...) `(call ,e ,e* ...)] 113 [(set! ,maybe-src ,x ,[e]) `(set! ,(ip1-lookup-lexical x env) ,e)] 114 [(letrec ([,x* ,e*] ...) ,body) (ip1-letrec x* e* body env)] 115 [(seq ,[e1] ,[e2]) 116 (nanopass-case (Linterp Expr) e1 117 [(quote ,d) e2] 118 [else `(seq ,e1 ,e2)])] 119 [(moi) `(quote #f)] 120 [(pariah) `(quote ,(void))] 121 [(profile ,src) `(quote ,(void))])) 122 123;;; When we create a lex from a prelex, we replace the name field of 124;;; the prelex id with an initial mapping from environment to the lex 125;;; var corresponding to the prelex in the environment. This mapping is 126;;; augmented by lookup-lexical (for references through rebind-free 127;;; environments) and trimmed by maybe-free. 128 129(define-syntax with-var 130 (syntax-rules () 131 ((_ (var idexp env) e1 e2 ...) 132 (let ((id idexp)) 133 (let ((name (prelex-name id))) 134 (let ((var (make-c-var id #f))) 135 (prelex-name-set! id (list (cons env var))) 136 (let ((tmp (begin e1 e2 ...))) 137 ; restore name to leave prelex undamaged; this is necessary at 138 ; present because syntax objects may contain the same prelexes 139 ; that arrive here as bound variables 140 (prelex-name-set! id name) 141 tmp))))))) 142 143(define-syntax with-vars 144 (syntax-rules () 145 ((_ (vars idsexp env) e1 e2 ...) 146 (let f ((ids (reverse idsexp)) (vars '())) 147 (if (null? ids) 148 (begin e1 e2 ...) 149 (with-var (var (car ids) env) 150 (f (cdr ids) (cons var vars)))))))) 151 152(define ip1-free 153 (lambda (e) 154 (map (lambda (id) 155 (let ((ls (prelex-name id))) 156 (prelex-name-set! id (cdr ls)) 157 (cdar ls))) 158 (c-env-vars e)))) 159 160(define ip1-lookup-lexical 161 (lambda (id e) 162 (let ((ls (prelex-name id))) 163 (if (eq? (caar ls) e) 164 (cdar ls) 165 (let ((y (ip1-lookup-lexical id (c-env-prev e)))) 166 (let ([z (make-c-var id y)]) 167 (c-env-vars-set! e (cons id (c-env-vars e))) 168 (prelex-name-set! id (cons (cons e z) (prelex-name id))) 169 z)))))) 170 171(lambda (x) (ip1 x)))) 172 173(define-syntactic-monad $rt a0 a1 fp cp) 174 175(module (ip2) 176(define unexpected-loc 177 (lambda (loc) 178 ($oops 'interpret-internal "unexpected loc ~s" loc))) 179 180(define ip2 181 (lambda (x) 182 (define unexpected-record 183 (lambda (x) 184 ($oops 'interpret-internal "unexpected record ~s" x))) 185 (define non-procedure 186 (lambda (x) 187 ($oops #f "attempt to apply non-procedure ~s" x))) 188 (define unbound-or-non-procedure 189 (lambda (sym x) 190 (if ($unbound-object? x) 191 ($oops #f "variable ~:s is not bound" sym) 192 (non-procedure x)))) 193 (define-syntax docall-sym 194 (lambda (x) 195 (syntax-case x () 196 [(_ sym e1 ...) 197 (with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))]) 198 #'($rt lambda () 199 (let ([t0 (#3%$top-level-value sym)] [t1 ($rt e1)] ...) 200 (unless (procedure? t0) (unbound-or-non-procedure sym t0)) 201 (t0 t1 ...))))]))) 202 (define-syntax docall 203 (lambda (x) 204 (syntax-case x () 205 [(_ e0 e1 ...) 206 (with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))]) 207 #'($rt lambda () 208 (let ([t0 e0] [t1 ($rt e1)] ...) 209 (unless (procedure? t0) (non-procedure t0)) 210 (t0 t1 ...))))]))) 211 (define-syntax docallx 212 (lambda (x) 213 (syntax-case x () 214 [(_ e0 e1 ...) 215 (with-syntax ([(t0 t1 ...) (generate-temporaries #'(e0 e1 ...))]) 216 #'($rt lambda () 217 (let ([t0 ($rt e0)] [t1 ($rt e1)] ...) 218 (unless (procedure? t0) (non-procedure t0)) 219 (t0 t1 ...))))]))) 220 (define ip2-fat-call 221 (lambda (fun args) 222 (let ((args (reverse args))) 223 ($rt lambda () 224 (let ((fun ($rt fun))) 225 (let loop ([args args] [vals '()]) 226 (if (null? args) 227 (begin 228 (unless (procedure? fun) (non-procedure fun)) 229 (apply fun vals)) 230 (loop (cdr args) (cons ($rt (car args)) vals))))))))) 231 (nanopass-case (Linterp Expr) x 232 [,x 233 (let ((loc (c-var-loc x)) (i (c-var-index x))) 234 (if (prelex-assigned (c-var-id x)) 235 (case loc 236 [(a0) ($rt lambda () (car a0))] 237 [(a1) ($rt lambda () (car a1))] 238 [(fp) ($rt lambda () (car fp))] 239 [(cp) ($rt lambda () (car cp))] 240 [(frame) ($rt lambda () (car (list-ref fp i)))] 241 [(frame-rest) ($rt lambda () (car (list-tail fp i)))] 242 [(closure) ($rt lambda () (car (vector-ref cp i)))] 243 [else (unexpected-loc loc)]) 244 (case loc 245 [(a0) ($rt lambda () a0)] 246 [(a1) ($rt lambda () a1)] 247 [(fp) ($rt lambda () fp)] 248 [(cp) ($rt lambda () cp)] 249 [(frame) ($rt lambda () (list-ref fp i))] 250 [(frame-rest) ($rt lambda () (list-tail fp i))] 251 [(closure) ($rt lambda () (vector-ref cp i))] 252 [else (unexpected-loc loc)])))] 253 [,pr (let ((fun ($top-level-value (primref-name pr)))) 254 ($rt lambda () fun))] 255 [(quote ,d) ($rt lambda () d)] 256 [(close ,free ,cl* ...) 257 (unless (null? free) 258 (if (null? (cdr free)) 259 (c-var-loc-set! (car free) 'cp) 260 (let loop ((free free) (i 0)) 261 (unless (null? free) 262 (c-var-loc-set! (car free) 'closure) 263 (c-var-index-set! (car free) i) 264 (loop (cdr free) (fx+ i 1)))))) 265 (or (and (not (null? cl*)) 266 (null? (cdr cl*)) 267 (nanopass-case (Linterp CaseLambdaClause) (car cl*) 268 [(clause (,x* ...) ,interface ,body) 269 (if (null? free) 270 (case interface 271 [(0) 272 (let ((body (ip2-body body x* '(a0 a1 fp cp) #f))) 273 ($rt lambda () 274 (lambda () 275 ($rt body ([a0 0] [a1 0] [fp 0] [cp 0])))))] 276 [(1) 277 (let ((body (ip2-body body x* '(a0 a1 fp cp) #f))) 278 ($rt lambda () 279 (lambda (a0) 280 ($rt body ([a1 0] [fp 0] [cp 0])))))] 281 [(2) 282 (let ((body (ip2-body body x* '(a0 a1 fp cp) #f))) 283 ($rt lambda () 284 (lambda (a0 a1) 285 ($rt body ([fp 0] [cp 0])))))] 286 [(3) 287 (let ((body (ip2-body body x* '(a0 a1 fp cp) #f))) 288 ($rt lambda () 289 (lambda (a0 a1 fp) 290 ($rt body ([cp 0])))))] 291 [(4) 292 (let ((body (ip2-body body x* '(a0 a1 fp cp) #f))) 293 ($rt lambda () 294 (lambda (a0 a1 fp cp) 295 ($rt body))))] 296 [else #f]) 297 (case interface 298 [(0) 299 (ip2-closure free 300 (let ((body (ip2-body body x* '(a0 a1 fp) #f))) 301 ($rt lambda () 302 (lambda () 303 ($rt body ([a0 0] [a1 0] [fp 0]))))))] 304 [(1) 305 (ip2-closure free 306 (let ((body (ip2-body body x* '(a0 a1 fp) #f))) 307 ($rt lambda () 308 (lambda (a0) 309 ($rt body ([a1 0] [fp 0]))))))] 310 [(2) 311 (ip2-closure free 312 (let ((body (ip2-body body x* '(a0 a1 fp) #f))) 313 ($rt lambda () 314 (lambda (a0 a1) 315 ($rt body ([fp 0]))))))] 316 [(3) 317 (ip2-closure free 318 (let ((body (ip2-body body x* '(a0 a1 fp) #f))) 319 ($rt lambda () 320 (lambda (a0 a1 fp) 321 ($rt body)))))] 322 [else #f]))])) 323 ; we could use cp if no closure; we could use fp if max interface 324 ; is small enough. we don't bother with either presently. 325 (let ((m (let min? ((cl* cl*) (m (length '(a0 a1)))) 326 (if (null? cl*) 327 m 328 (nanopass-case (Linterp CaseLambdaClause) (car cl*) 329 [(clause (,x* ...) ,interface ,body) 330 (min? (cdr cl*) 331 (min (if (fx< interface 0) 332 (fx- -1 interface) 333 interface) 334 m))])))) 335 (arity-mask (let mask ((cl* cl*) (arity-mask 0)) 336 (if (null? cl*) 337 arity-mask 338 (nanopass-case (Linterp CaseLambdaClause) (car cl*) 339 [(clause (,x* ...) ,interface ,body) 340 (mask (cdr cl*) 341 (logor arity-mask 342 (if (< interface 0) 343 (- (ash 1 (- -1 interface))) 344 (ash 1 interface))))]))))) 345 (define adjust-interface 346 (lambda (x) 347 (if (fx< x 0) 348 (fx+ x m) 349 (fx- x m)))) 350 (let ((body (let f ((cl* cl*)) 351 (if (null? cl*) 352 ($rt lambda (args nargs) 353 ($oops #f "incorrect number of arguments to #<procedure>")) 354 (nanopass-case (Linterp CaseLambdaClause) (car cl*) 355 [(clause (,x* ...) ,interface ,body) 356 (ip2-prelude 357 (ip2-body body x* '(a0 a1) 358 (fx< interface 0)) 359 (list-tail x* m) 360 (list-tail '(a0 a1) m) 361 (adjust-interface interface) 362 (f (cdr cl*)))]))))) 363 (case m 364 [(0) 365 (ip2-closure free 366 ($rt lambda () 367 ($make-wrapper-procedure 368 (lambda args 369 ($rt body ([a0 0] [a1 0] [fp 0]) args (length args))) 370 arity-mask)))] 371 [(1) 372 (ip2-closure free 373 ($rt lambda () 374 ($make-wrapper-procedure 375 (lambda (a0 . args) 376 ($rt body ([a1 0] [fp 0]) args (length args))) 377 arity-mask)))] 378 [(2) 379 (ip2-closure free 380 ($rt lambda () 381 ($make-wrapper-procedure 382 (lambda (a0 a1 . args) 383 ($rt body ([fp 0]) args (length args))) 384 arity-mask)))]))))] 385 [(set! ,x ,e) 386 (let ((e (ip2 e))) 387 (let ((loc (c-var-loc x)) (i (c-var-index x))) 388 (case loc 389 [(a0) ($rt lambda () (set-car! a0 ($rt e)))] 390 [(a1) ($rt lambda () (set-car! a1 ($rt e)))] 391 [(fp) ($rt lambda () (set-car! fp ($rt e)))] 392 [(cp) ($rt lambda () (set-car! cp ($rt e)))] 393 [(frame) ($rt lambda () (set-car! (list-ref fp i) ($rt e)))] 394 [(frame-rest) 395 ($rt lambda () (set-car! (list-tail fp i) ($rt e)))] 396 [(closure) ($rt lambda () (set-car! (vector-ref cp i) ($rt e)))] 397 [else (unexpected-loc loc)])))] 398 [(if ,e0 ,e1 ,e2) 399 (let ((e0 (ip2 e0)) (e1 (ip2 e1)) (e2 (ip2 e2))) 400 ($rt lambda () 401 ($rt (if ($rt e0) e1 e2))))] 402 [(call ,e ,e* ...) 403 (let ((e* (map (lambda (x) (ip2 x)) e*))) 404 (or (nanopass-case (Linterp Expr) e 405 [,pr 406 (case (length e*) 407 [(0) 408 (let ((e ($top-level-value (primref-name pr)))) 409 ($rt lambda () (e)))] 410 [(1) 411 (apply 412 (lambda (x1) 413 (let ((e ($top-level-value (primref-name pr)))) 414 ($rt lambda () (e ($rt x1))))) 415 e*)] 416 [(2) 417 (apply 418 (lambda (x1 x2) 419 (let ((e ($top-level-value (primref-name pr)))) 420 ($rt lambda () (e ($rt x1) ($rt x2))))) 421 e*)] 422 [(3) 423 (apply 424 (lambda (x1 x2 x3) 425 (let ((e ($top-level-value (primref-name pr)))) 426 ($rt lambda () 427 (e ($rt x1) ($rt x2) ($rt x3))))) 428 e*)] 429 [else #f])] 430 [(call ,e1 ,e1* ...) 431 (nanopass-case (Linterp Expr) e1 432 [,pr (and (eq? (primref-name pr) '$top-level-value) 433 (fx= (length e*) 1) 434 (nanopass-case (Linterp Expr) (car e1*) 435 [(quote ,d) 436 (and (symbol? d) 437 (case (length e*) 438 [(0) (docall-sym d)] 439 [(1) 440 (apply 441 (lambda (x1) 442 (docall-sym d x1)) 443 e*)] 444 [(2) 445 (apply 446 (lambda (x1 x2) 447 (docall-sym d x1 x2)) 448 e*)] 449 [(3) 450 (apply 451 (lambda (x1 x2 x3) 452 (docall-sym d x1 x2 x3)) 453 e*)] 454 [else #f]))] 455 [else #f]))] 456 [else #f])] 457 [else #f]) 458 (let ((e (ip2 e))) 459 (case (length e*) 460 [(0) (docallx e)] 461 [(1) 462 (apply 463 (lambda (x1) (docallx e x1)) 464 e*)] 465 [(2) 466 (apply 467 (lambda (x1 x2) (docallx e x1 x2)) 468 e*)] 469 [(3) 470 (apply 471 (lambda (x1 x2 x3) (docallx e x1 x2 x3)) 472 e*)] 473 [else (ip2-fat-call e e*)]))))] 474 [(seq ,e1 ,e2) 475 (let ((e1 (ip2 e1)) (e2 (ip2 e2))) 476 ($rt lambda () ($rt e1) ($rt e2)))] 477 [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) 478 (unless $compiler-is-loaded? 479 ($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded")) 480 (let ([p ($compile-backend 481 (let ((t (make-prelex* 'tmp))) 482 (set-prelex-referenced! t #t) 483 (with-output-language (Lsrc Expr) 484 `(case-lambda ,(make-preinfo-lambda) 485 (clause (,t) 1 486 (foreign (,conv* ...) ,name (ref #f ,t) 487 (,arg-type* ...) ,result-type))))))]) 488 (let ([e (ip2 e)]) 489 ($rt lambda () ((p) ($rt e)))))] 490 [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) 491 (unless $compiler-is-loaded? 492 ($oops 'interpret "cannot compile foreign-callable: compiler is not loaded")) 493 (let ([p ($compile-backend 494 (let ((t (make-prelex* 'tmp))) 495 (set-prelex-referenced! t #t) 496 (with-output-language (Lsrc Expr) 497 `(case-lambda ,(make-preinfo-lambda) 498 (clause (,t) 1 499 (fcallable (,conv* ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))]) 500 (let ([e (ip2 e)]) 501 ($rt lambda () ((p) ($rt e)))))] 502 [else (unexpected-record x)]))) 503 504(define ip2-prelude 505 (lambda (body vars regs i next) 506 (define set-args 507 (lambda (vars regs body rest?) 508 (if (null? regs) 509 ($rt lambda (args) ($rt body ([fp args]))) 510 (let ((reg (car regs))) 511 (if (null? (cdr vars)) 512 (if rest? 513 (case reg 514 [(a0) ($rt lambda (args) ($rt body ([a0 args])))] 515 [(a1) ($rt lambda (args) ($rt body ([a1 args])))] 516 [(fp) ($rt lambda (args) ($rt body ([fp args])))] 517 [(cp) ($rt lambda (args) ($rt body ([cp args])))] 518 [else (unexpected-loc reg)]) 519 (case reg 520 [(a0) ($rt lambda (args) ($rt body ([a0 (car args)])))] 521 [(a1) ($rt lambda (args) ($rt body ([a1 (car args)])))] 522 [(fp) ($rt lambda (args) ($rt body ([fp (car args)])))] 523 [(cp) ($rt lambda (args) ($rt body ([cp (car args)])))] 524 [else (unexpected-loc reg)])) 525 (let ((body (set-args (cdr vars) (cdr regs) body rest?))) 526 (case reg 527 [(a0) ($rt lambda (args) 528 ($rt body ([a0 (car args)]) (cdr args)))] 529 [(a1) ($rt lambda (args) 530 ($rt body ([a1 (car args)]) (cdr args)))] 531 [(fp) ($rt lambda (args) 532 ($rt body ([fp (car args)]) (cdr args)))] 533 [(cp) ($rt lambda (args) 534 ($rt body ([cp (car args)]) (cdr args)))] 535 [else (unexpected-loc reg)]))))))) 536 (if (fx>= i 0) 537 (if (fx= i 0) 538 ($rt lambda (args nargs) 539 (if (fx= nargs 0) 540 ($rt body) 541 ($rt next () args nargs))) 542 (let ((body (set-args vars regs body #f))) 543 ($rt lambda (args nargs) 544 (if (fx= nargs i) 545 ($rt body () args) 546 ($rt next () args nargs))))) 547 (let ((body (set-args vars regs body #t))) 548 (if (fx= i -1) 549 ($rt lambda (args nargs) ($rt body () args)) 550 (let ((i (fx- -1 i))) 551 ($rt lambda (args nargs) 552 (if (fx>= nargs i) 553 ($rt body () args) 554 ($rt next () args nargs))))))))) 555 556(define ip2-closure 557 (lambda (free code) 558 (let ([free (map (lambda (var) 559 (let* ((var (c-var-parent var)) 560 (loc (c-var-loc var)) 561 (i (c-var-index var))) 562 (case loc 563 [(a0) ($rt lambda () a0)] 564 [(a1) ($rt lambda () a1)] 565 [(fp) ($rt lambda () fp)] 566 [(cp) ($rt lambda () cp)] 567 [(frame) ($rt lambda () (list-ref fp i))] 568 [(frame-rest) ($rt lambda () (list-tail fp i))] 569 [(closure) ($rt lambda () (vector-ref cp i))] 570 [else (unexpected-loc loc)]))) 571 free)]) 572 (let ((nfree (length free))) 573 (case nfree 574 [(0) ($rt lambda () ($rt code ([cp 0])))] 575 [(1) 576 (apply 577 (lambda (x1) 578 ($rt lambda () ($rt code ([cp ($rt x1)])))) 579 free)] 580 [(2) 581 (apply 582 (lambda (x1 x2) 583 ($rt lambda () 584 ($rt code ([cp (vector ($rt x1) ($rt x2))])))) 585 free)] 586 [(3) 587 (apply 588 (lambda (x1 x2 x3) 589 ($rt lambda () 590 ($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3))])))) 591 free)] 592 [(4) 593 (apply 594 (lambda (x1 x2 x3 x4) 595 ($rt lambda () 596 ($rt code ([cp (vector ($rt x1) ($rt x2) ($rt x3) ($rt x4))])))) 597 free)] 598 [else 599 ($rt lambda () 600 (let ((v (make-vector nfree ($rt (car free))))) 601 (do ((i 1 (fx+ i 1)) (free (cdr free) (cdr free))) 602 ((null? free)) 603 (vector-set! v i ($rt (car free)))) 604 ($rt code ([cp v]))))]))))) 605 606(define ip2-body 607 (lambda (body invars regs rest?) 608 ; set locations 609 (let loop ((vars invars) (regs regs) (i 0)) 610 (cond 611 [(null? vars) 612 ; process the body and wrap in consers for assigned variables 613 (do ((vars invars (cdr vars)) 614 (body (ip2 body) 615 (let ((var (car vars))) 616 (if (prelex-assigned (c-var-id var)) 617 (case (c-var-loc var) 618 [(a0) 619 ($rt lambda () 620 ($rt body ([a0 (cons a0 (void))])))] 621 [(a1) 622 ($rt lambda () 623 ($rt body ([a1 (cons a1 (void))])))] 624 [(fp) 625 ($rt lambda () 626 ($rt body ([fp (cons fp (void))])))] 627 [(cp) 628 ($rt lambda () 629 ($rt body ([cp (cons cp (void))])))] 630 [(frame) 631 (let ((i (c-var-index var))) 632 ($rt lambda () 633 (let ((ls (list-tail fp i))) 634 (set-car! ls (cons (car ls) (void)))) 635 ($rt body)))] 636 [(frame-rest) 637 (let ((i (fx- (c-var-index var) 1))) 638 ($rt lambda () 639 (let ((ls (list-tail fp i))) 640 (set-cdr! ls (cons (cdr ls) (void)))) 641 ($rt body)))]) 642 body)))) 643 ((null? vars) body))] 644 [(not (null? regs)) 645 (c-var-loc-set! (car vars) (car regs)) 646 (loop (cdr vars) (cdr regs) i)] 647 [(and rest? (null? (cdr vars))) 648 (cond 649 [(fx= i 0) 650 ; using fp here instead of the equivalent frame-rest[0] 651 ; eliminates need for special-casing frame-rest[0] elsewhere. 652 (c-var-loc-set! (car vars) 'fp) 653 (loop (cdr vars) regs i)] 654 [else 655 (c-var-loc-set! (car vars) 'frame-rest) 656 (c-var-index-set! (car vars) i) 657 (loop (cdr vars) regs (fx+ i 1))])] 658 [else 659 (c-var-loc-set! (car vars) 'frame) 660 (c-var-index-set! (car vars) i) 661 (loop (cdr vars) regs (fx+ i 1))]))))) 662 663(define (cptypes x) 664 (if (enable-type-recovery) 665 ($cptypes x)) 666 x) 667 668(define-pass interpret-Lexpand : Lexpand (ir situation for-import? importer ofn eoo) -> * (val) 669 (definitions 670 (define (ibeval x1) 671 ($rt (parameterize ([$target-machine (machine-type)] [$sfd #f]) 672 (let* ([x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))] 673 [x2a (let ([cpletrec-ran? #f]) 674 (let ([x ((run-cp0) 675 (lambda (x) 676 (set! cpletrec-ran? #t) 677 (let ([x ($pass-time 'cp0 (lambda () ($cp0 x #f)))]) 678 ($pass-time 'cpletrec 679 (lambda () ($cpletrec x))))) 680 x2)]) 681 (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] 682 [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))] 683 [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))]) 684 (when eoo (pretty-print ($uncprep x2b) eoo)) 685 (let ([x ($pass-time 'ip1 (lambda () (ip1 x2b)))]) 686 ($pass-time 'ip2 (lambda () (ip2 x)))))) 687 ([a0 0] [a1 0] [fp 0] [cp 0])))) 688 (Inner : Inner (ir) -> * (val) 689 [,lsrc (ibeval lsrc)] 690 [(program ,uid ,body) 691 (ibeval ($build-invoke-program uid body))] 692 [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) 693 (ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))] 694 [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) 695 (ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))] 696 [(library/rt-info ,linfo/rt) ($install-library/rt-desc linfo/rt for-import? importer ofn)] 697 [(library/ct-info ,linfo/ct) ($install-library/ct-desc linfo/ct for-import? importer ofn)] 698 [(program-info ,pinfo) ($install-program-desc pinfo)] 699 [else (sorry! who "unexpected language form ~s" ir)]) 700 (Outer : Outer (ir) -> * (val) 701 ; can't use cata since (Outer outer1) might return 0 or more than one value 702 [(group ,outer1 ,outer2) (Outer outer1) (Outer outer2)] 703 [(visit-only ,inner) (unless (eq? situation 'revisit) (Inner inner))] 704 [(revisit-only ,inner) (unless (eq? situation 'visit) (Inner inner))] 705 [(recompile-info ,rcinfo) (void)] 706 [,inner (Inner inner)] 707 [else (sorry! who "unexpected language form ~s" ir)]) 708 (Outer ir)) 709 710(set! interpret 711 (rec interpret 712 (case-lambda 713 [(x) 714 (interpret x 715 (if (eq? (subset-mode) 'system) 716 ($system-environment) 717 (interaction-environment)))] 718 [(x0 env-spec) 719 (unless (environment? env-spec) ($oops 'interpret "~s is not an environment" env-spec)) 720 (let ([x1 ($pass-time 'expand 721 (lambda () 722 (parameterize ([$target-machine (machine-type)] [$sfd #f]) 723 (expand x0 env-spec #t))))]) 724 ($uncprep x1 #t) ; populate preinfo sexpr fields 725 (when (and (expand-output) (not ($noexpand? x0))) 726 (pretty-print ($uncprep x1) (expand-output))) 727 (interpret-Lexpand x1 'load #f #f #f (and (not ($noexpand? x0)) (expand/optimize-output))))]))) 728 729(set! $interpret-backend 730 (lambda (x situation for-import? importer ofn) 731 (interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output)))) 732(current-eval interpret) 733) 734 735