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