src/schemify/jitify.rkt

2 (require "match.rkt"
37 (define lifts-id (string->uninterned-symbol "_jits"))
48   (define (make-jit-on-call free-vars argss v name env convert-mode body-lifts lifts)
98             (no-lifts? body-lifts))
100        (define-values (get-e new-lifts)
102            [(convert-mode-need-lift? convert-mode) (add-lift e lifts)]
103            [else (values `',e lifts)]))
105                    `(jitified-extract-closed ,get-e)
106                    get-e)
107                new-lifts)]
111                                           `(lambda ,(if (no-lifts? body-lifts)
113                                                         (cons lifts-id captures))
117        (define-values (all-captures new-lifts)
119            [(no-lifts? body-lifts)
120             (values captures lifts)]
122             (values (cons `',(lifts->datum body-lifts) captures) lifts)]
124             (define-values (get-sub-lift new-lifts) (add-lift (lifts->datum body-lifts) lifts))
125             (values (cons get-sub-lift captures) new-lifts)]))
126        (define-values (get-e newer-lifts)
128            [(convert-mode-need-lift? convert-mode) (add-lift e new-lifts)]
129            [else (values `',e new-lifts)]))
131                    `((jitified-extract ,get-e) . ,all-captures)
132                    `(,get-e . ,all-captures))
133                newer-lifts)]))
193 …(define-values (new-v free lifts) (jitify-expr v env mutables #hasheq() no-lifts convert-mode name…
194     (if (no-lifts? lifts)
196         `(let ([,lifts-id ',(lifts->datum lifts)])
206   (define (jitify-expr v env mutables free lifts convert-mode name in-name)
216        (define body-lifts (if convert? no-lifts lifts))
217        (define-values (new-body lam-body-free new-body-lifts)
218 …       (jitify-body body body-env mutables #hasheq() body-lifts body-convert-mode #f body-in-name))
222        (define-values (converted-v new-lifts)
224              (values new-v new-body-lifts)
225 …    (make-jit-on-call lam-free (list args) new-v name self-env convert-mode new-body-lifts lifts)))
228                new-lifts)]
236        (define body-lifts (if convert? no-lifts lifts))
237        (define-values (rev-new-bodys lam-free new-body-lifts)
238 …(for/fold ([rev-new-bodys '()] [lam-free #hasheq()] [body-lifts body-lifts]) ([args (in-list argss…
241            (define-values (new-body lam-body-free new-body-lifts)
242 …       (jitify-body body body-env mutables #hasheq() body-lifts body-convert-mode #f body-in-name))
246                    new-body-lifts)))
253        (define-values (converted-v new-lifts)
255              (values new-v new-body-lifts)
256 …          (make-jit-on-call lam-free argss new-v name self-env convert-mode new-body-lifts lifts)))
259                new-lifts)]
260       [`(let . ,_) (jitify-let v env mutables free lifts convert-mode name in-name)]
261       [`(letrec . ,_) (jitify-let v env mutables free lifts convert-mode name in-name)]
262       [`(letrec* . ,_) (jitify-let v env mutables free lifts convert-mode name in-name)]
264        (define-values (new-body new-free new-lifts)
265          (jitify-body vs env mutables free lifts convert-mode name in-name))
268                new-lifts)]
270        (jitify-expr `(begin . ,vs) env mutables free lifts convert-mode name in-name)]
272        (define-values (new-v0 v0-free v0-lifts)
273          (jitify-expr v0 env mutables free lifts (convert-mode-non-tail convert-mode) name in-name))
274        (define-values (new-body new-free new-lifts)
275 …    (jitify-body vs env mutables v0-free v0-lifts (convert-mode-non-tail convert-mode) #f in-name))
278                new-lifts)]
280        (define-values (new-e new-free new-lifts)
281          (jitify-expr e env mutables free lifts convert-mode name in-name))
284                new-lifts)]
287        (define-values (new-tst new-free/tst new-lifts/tst)
288          (jitify-expr tst env mutables free lifts sub-convert-mode #f in-name))
289        (define-values (new-thn new-free/thn new-lifts/thn)
290          (jitify-expr thn env mutables new-free/tst new-lifts/tst convert-mode name in-name))
291        (define-values (new-els new-free/els new-lifts/els)
292          (jitify-expr els env mutables new-free/thn new-lifts/thn convert-mode name in-name))
295                new-lifts/els)]
298        (define-values (new-key new-free/key new-lifts/key)
299          (jitify-expr key env mutables free lifts sub-convert-mode #f in-name))
300        (define-values (new-val new-free/val new-lifts/val)
301          (jitify-expr val env mutables new-free/key new-lifts/key sub-convert-mode #f in-name))
302        (define-values (new-body new-free/body new-lifts/body)
303          (jitify-expr body env mutables new-free/val new-lifts/val convert-mode name in-name))
306                new-lifts/body)]
307       [`(quote ,_) (values v free lifts)]
309        (define-values (new-rhs new-free new-lifts)
310          (jitify-expr rhs env mutables free lifts (convert-mode-non-tail convert-mode) var in-name))
321                   new-lifts)]
332           (values new-v newer-free new-lifts)])]
336          (jitify-expr proc1 env mutables free lifts proc-convert-mode #f in-name))
347        (define-values (new-proc new-free new-lifts)
348          (jitify-expr proc env mutables free lifts proc-convert-mode #f in-name))
351                new-lifts)]
353        (define-values (new-vs new-free new-lifts)
354 …(jitify-body (wrap-cdr v) env mutables free lifts (convert-mode-non-tail convert-mode) #f in-name))
357                new-lifts)]
363           (define-values (new-vs new-free new-lifts)
364 …(jitify-body (wrap-cdr v) env mutables free lifts (convert-mode-non-tail convert-mode) #f in-name))
367                   new-lifts)]
369           (define-values (new-vs new-free new-lifts)
370             (jitify-body v env mutables free lifts (convert-mode-non-tail convert-mode) #f in-name))
373                   new-lifts)])]
385              (values var free lifts)]
399                      lifts)])]
402                        lifts)])]))
410   (define (jitify-body vs env mutables free lifts convert-mode name in-name)
411     (let loop ([vs vs] [free free] [lifts lifts])
413         [(wrap-null? vs) (values null free lifts)]
415          (define-values (new-v new-free new-lifts)
416            (jitify-expr (wrap-car vs) env mutables free lifts convert-mode name in-name))
417          (values (list new-v) new-free new-lifts)]
419          (define-values (new-v new-free new-lifts)
420 …(jitify-expr (wrap-car vs) env mutables free lifts (convert-mode-non-tail convert-mode) #f in-name…
421          (define-values (new-rest newer-free newer-lifts)
422            (loop (wrap-cdr vs) new-free new-lifts))
425                  newer-lifts)])))
427   (define (jitify-let v env mutables free lifts convert-mode name in-name)
442        (define-values (rev-new-rhss rhs-free rhs-lifts)
443          (for/fold ([rev-new-rhss '()] [free #hasheq()] [lifts lifts]) ([id (in-list ids)]
449            (define-values (new-rhs rhs-free rhs-lifts)
450              (jitify-expr rhs self-env mutables free lifts rhs-convert-mode id in-name))
451            (values (cons new-rhs rev-new-rhss) rhs-free rhs-lifts)))
456        (define-values (new-body new-free new-lifts)
457 …(jitify-body body local-env mutables (union-free free rhs-free) rhs-lifts convert-mode name in-nam…
491                new-lifts)]))
765   ;; Keep lifts in a list, in reverse order of eventual
768   (define no-lifts '(0))
770   (define (no-lifts? v)
773   (define (lifts->datum v)
776   (define (add-lift e lifts)
777     (values `(unsafe-vector-ref ,lifts-id ,(car lifts))
778             (cons (add1 (car lifts))
779                   (cons e (cdr lifts)))))
843   (require racket/pretty)