1#lang racket/base 2(require "../common/set.rkt" 3 "../common/performance.rkt" 4 "../syntax/syntax.rkt" 5 "../syntax/to-list.rkt" 6 "../common/phase.rkt" 7 "../syntax/scope.rkt" 8 "../syntax/taint.rkt" 9 "../syntax/property.rkt" 10 "../namespace/namespace.rkt" 11 "../namespace/module.rkt" 12 "../syntax/binding.rkt" 13 "../syntax/match.rkt" 14 "../common/module-path.rkt" 15 "../expand/parsed.rkt" 16 "built-in-symbol.rkt" 17 "context.rkt" 18 "header.rkt" 19 "reserved-symbol.rkt" 20 "self-quoting.rkt" 21 "../host/correlate.rkt" 22 "correlate.rkt") 23 24(provide compile 25 compile-quote-syntax) 26 27;; Convert an expanded syntax object to an expression that is 28;; represented by a plain S-expression plus source location info (so, 29;; still represented as a syntax object). The expression is compiled 30;; for a particular phase, but if the expression is in a module, its 31;; phase can be shifted at run time by the amount bound to 32;; `phase-shift-id`. Module bindings are accessed through a namespace 33;; that is bound to `ns-id` at run time. 34;; The `result-used?` hint lets us drop `quote-syntax` forms that will 35;; not be used in the result, so we can avoid serializing them; a value 36;; of `#f` for `result-used?` means that the expression can be replaced 37;; by a boolean-equivalent value if it has no side effect. 38(define (compile p cctx [name #f] [result-used? #t]) 39 (let ([compile (lambda (p name result-used?) (compile p cctx name result-used?))]) 40 (define s (parsed-s p)) 41 (cond 42 [(parsed-id? p) 43 (compile-identifier p cctx)] 44 [(parsed-lambda? p) 45 (cond 46 [result-used? 47 (add-lambda-properties 48 (correlate* s `(lambda ,@(compile-lambda (parsed-lambda-keys p) (parsed-lambda-body p) cctx))) 49 name 50 s)] 51 [else (correlate~ s `(quote unused-lambda))])] 52 [(parsed-case-lambda? p) 53 (cond 54 [result-used? 55 (add-lambda-properties 56 (correlate* s `(case-lambda ,@(for/list ([clause (in-list (parsed-case-lambda-clauses p))]) 57 (compile-lambda (car clause) (cadr clause) cctx)))) 58 name 59 s)] 60 [else (correlate~ s `(quote unused-case-lambda))])] 61 [(parsed-app? p) 62 (define rands (parsed-app-rands p)) 63 (correlate/app s (cons 64 (compile (parsed-app-rator p) #f #t) 65 (for/list ([r (in-list rands)]) 66 (compile r #f #t))))] 67 [(parsed-if? p) 68 (define tst-e (compile (parsed-if-tst p) #f #f)) 69 ;; Ad hoc optimization of `(if #t ... ...)` or `(if #f ... ...)` 70 ;; happens to help avoid syntax literals in pattern matching. 71 (cond 72 [(eq? (correlated-e tst-e) #t) (compile (parsed-if-thn p) name result-used?)] 73 [(eq? (correlated-e tst-e) #f) (compile (parsed-if-els p) name result-used?)] 74 [else 75 (correlate~ s `(if 76 ,tst-e 77 ,(compile (parsed-if-thn p) name result-used?) 78 ,(compile (parsed-if-els p) name result-used?)))])] 79 [(parsed-with-continuation-mark? p) 80 (correlate~ s `(with-continuation-mark 81 ,(compile (parsed-with-continuation-mark-key p) #f #t) 82 ,(compile (parsed-with-continuation-mark-val p) #f #t) 83 ,(compile (parsed-with-continuation-mark-body p) name result-used?)))] 84 [(parsed-begin0? p) 85 (correlate~ s `(begin0 86 ,(compile (car (parsed-begin0-body p)) name result-used?) 87 ,@(for/list ([e (in-list (cdr (parsed-begin0-body p)))]) 88 (compile e #f #f))))] 89 [(parsed-begin? p) 90 (correlate~ s (compile-begin (parsed-begin-body p) cctx name result-used?))] 91 [(parsed-set!? p) 92 (correlate~ s `(,@(compile-identifier (parsed-set!-id p) cctx 93 #:set-to? #t 94 #:set-to (compile (parsed-set!-rhs p) (parsed-s (parsed-set!-id p)) #t))))] 95 [(parsed-let-values? p) 96 (compile-let p cctx name #:rec? #f result-used?)] 97 [(parsed-letrec-values? p) 98 (compile-let p cctx name #:rec? #t result-used?)] 99 [(parsed-quote? p) 100 (define datum (parsed-quote-datum p)) 101 (cond 102 [(self-quoting-in-linklet? datum) 103 (correlate~ s datum)] 104 [else 105 (correlate~ s `(quote ,datum))])] 106 [(parsed-quote-syntax? p) 107 (if result-used? 108 (compile-quote-syntax (parsed-quote-syntax-datum p) cctx) 109 ;; Note: the datum form of `s` has probably been pruned away, 110 ;; so don't try to use it here: 111 (correlate~ s `(quote syntax)))] 112 [(parsed-#%variable-reference? p) 113 (define id (parsed-#%variable-reference-id p)) 114 (correlate~ s 115 (if id 116 `(#%variable-reference ,(compile-identifier id cctx)) 117 `(#%variable-reference)))] 118 [else 119 (error "unrecognized parsed form:" p)]))) 120 121(define (compile-lambda formals bodys cctx) 122 `(,formals ,(compile-sequence bodys cctx #f #t))) 123 124(define (compile-sequence bodys cctx name result-used?) 125 (if (null? (cdr bodys)) 126 (compile (car bodys) cctx name result-used?) 127 (compile-begin bodys cctx name result-used?))) 128 129(define (compile-begin es cctx name result-used?) 130 (define used-pos (sub1 (length es))) 131 `(begin ,@(for/list ([e (in-list es)] 132 [i (in-naturals)]) 133 (define used? (= i used-pos)) 134 (compile e cctx (and used? name) (and used? result-used?))))) 135 136(define (add-lambda-properties s inferred-name orig-s) 137 ;; Allow pairs formed by origin tracking to provide the 138 ;; same name multiple times: 139 (define (simplify-name v) 140 (cond 141 [(pair? v) 142 (define n1 (simplify-name (car v))) 143 (define n2 (simplify-name (cdr v))) 144 (if (eq? n1 n2) n1 v)] 145 [else v])) 146 ;; Get either a declared 'inferred-name or one accumulated by the compiler 147 (define name (or (let ([v (simplify-name (syntax-property orig-s 'inferred-name))]) 148 (and (or (symbol? v) (and (syntax? v) (symbol? (syntax-e v))) (void? v)) 149 v)) 150 inferred-name)) 151 (define named-s (if name 152 (correlated-property (->correlated s) 153 'inferred-name 154 (if (syntax? name) (syntax-e name) name)) 155 s)) 156 (define as-method (syntax-property orig-s 'method-arity-error)) 157 (if as-method 158 (correlated-property (->correlated named-s) 'method-arity-error as-method) 159 named-s)) 160 161(define (compile-let p cctx name #:rec? rec? result-used?) 162 (define body (parsed-let_-values-body p)) 163 (correlate~ (parsed-s p) 164 `(,(if rec? 'letrec-values 'let-values) 165 ,(for/list ([clause (in-list (parsed-let_-values-clauses p))] 166 [ids (in-list (parsed-let_-values-idss p))]) 167 `[,(if rec? 168 (for/list ([sym (in-list (car clause))] 169 [id (in-list ids)]) 170 (add-undefined-error-name-property sym id)) 171 (car clause)) 172 ,(compile (cadr clause) 173 cctx 174 (and (= 1 (length ids)) (car ids)))]) 175 ,(compile-sequence body cctx name result-used?)))) 176 177(define (add-undefined-error-name-property sym orig-id) 178 (define id (correlate~ orig-id sym)) 179 (correlated-property (->correlated id) 'undefined-error-name 180 (or (syntax-property orig-id 'undefined-error-name) 181 (syntax-e orig-id)))) 182 183(define (compile-identifier p cctx #:set-to? [set-to? #f] #:set-to [rhs #f]) 184 (define normal-b (parsed-id-binding p)) 185 ;; If `normal-b`, then `(parsed-s p)` might be #f 186 (define b 187 (or normal-b 188 ;; Assume a variable reference 189 (make-module-binding (compile-context-self cctx) 190 (compile-context-phase cctx) 191 (syntax-e (parsed-s p))))) 192 (define sym 193 (cond 194 [(local-binding? b) 195 (local-binding-key b)] 196 [(module-binding? b) 197 (define mpi (if (parsed-top-id? p) 198 (compile-context-self cctx) 199 (module-binding-module b))) 200 (cond 201 [(parsed-primitive-id? p) 202 ;; Direct reference to a runtime primitive: 203 (unless (zero? (module-binding-phase b)) 204 (error "internal error: non-zero phase for a primitive")) 205 (when set-to? 206 (error "internal error: cannot assign to a primitive:" (module-binding-sym b))) 207 ;; Expect each primitive to be bound: 208 (module-binding-sym b)] 209 [(and (eq? mpi (compile-context-module-self cctx)) 210 ;; Direct reference to a variable defined in the same module: 211 (hash-ref (header-binding-sym-to-define-sym (compile-context-header cctx)) 212 (module-binding-sym b) 213 ;; If this `#f` is used as the result, then the identifier must be a 214 ;; reference to a binding that was introduced through `local-expand`, 215 ;; but didn't survive to a definition in the full expansion; treat it 216 ;; as an undefined export. 217 #f)) 218 => (lambda (sym) sym)] 219 [else 220 ;; Reference to a variable defined in another module or in an 221 ;; environment (such as the top level) other than a module 222 ;; context; register as a linklet import or export 223 (register-required-variable-use! (compile-context-header cctx) 224 (if (inside-module-context? mpi (compile-context-self cctx)) 225 (compile-context-self cctx) 226 mpi) 227 (module-binding-phase b) 228 (module-binding-sym b) 229 (or (module-binding-extra-inspector b) 230 (parsed-id-inspector p) 231 (and (parsed-s p) 232 (syntax-inspector (parsed-s p)))))])] 233 [else 234 (error "not a reference to a module or local binding:" b (parsed-s p))])) 235 (correlate~ (parsed-s p) (if set-to? 236 `(set! ,sym ,rhs) 237 sym))) 238 239(define (compile-quote-syntax q cctx) 240 (define pos (add-syntax-literal! (compile-context-header cctx) q)) 241 (cond 242 [(compile-context-lazy-syntax-literals? cctx) 243 (generate-lazy-syntax-literal-lookup pos)] 244 [else 245 (generate-eager-syntax-literal-lookup pos)])) 246