230 lines
10 KiB
Racket
230 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/list
|
|
racket/match
|
|
racket/contract
|
|
compiler/zo-parse
|
|
"util.rkt"
|
|
"mpi.rkt"
|
|
"nodep.rkt"
|
|
"update-toplevels.rkt")
|
|
|
|
(define MODULE-TOPLEVEL-OFFSETS (make-hasheq))
|
|
|
|
(define current-get-modvar-rewrite (make-parameter #f))
|
|
(define (merge-compilation-top get-modvar-rewrite top)
|
|
(parameterize ([current-get-modvar-rewrite get-modvar-rewrite])
|
|
(match top
|
|
[(struct compilation-top (max-let-depth binding-namess prefix form))
|
|
(define-values (new-max-let-depth new-prefix gen-new-forms)
|
|
(merge-form max-let-depth prefix form))
|
|
(define total-tls (length (prefix-toplevels new-prefix)))
|
|
(define total-stxs (length (prefix-stxs new-prefix)))
|
|
(define total-lifts (prefix-num-lifts new-prefix))
|
|
(log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth))
|
|
(log-debug (format "total toplevels ~S" total-tls))
|
|
(log-debug (format "total stxs ~S" total-stxs))
|
|
(log-debug (format "num-lifts ~S" total-lifts))
|
|
(for ([i (in-naturals)]
|
|
[p (in-list (prefix-toplevels new-prefix))])
|
|
(log-debug (format "new-prefix tls\t~v ~v" i p)))
|
|
(make-compilation-top
|
|
new-max-let-depth #hash() new-prefix
|
|
(make-splice (gen-new-forms new-prefix)))]
|
|
[else (error 'merge "unrecognized: ~e" top)])))
|
|
|
|
(define (merge-forms max-let-depth prefix forms)
|
|
(if (empty? forms)
|
|
(values max-let-depth prefix (lambda _ empty))
|
|
(let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))]
|
|
[(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))])
|
|
(values rmax-let-depth
|
|
rprefix
|
|
(lambda args
|
|
(append (apply gen-fform args)
|
|
(apply gen-rforms args)))))))
|
|
|
|
(define (merge-form max-let-depth prefix form)
|
|
(match form
|
|
[(? mod?)
|
|
(merge-module max-let-depth prefix form)]
|
|
[(struct seq (forms))
|
|
(merge-forms max-let-depth prefix forms)]
|
|
[(struct splice (forms))
|
|
(merge-forms max-let-depth prefix forms)]
|
|
[else
|
|
(values max-let-depth prefix (lambda _ (list form)))]))
|
|
|
|
(define (index-of v l)
|
|
(for/or ([e (in-list l)]
|
|
[i (in-naturals)]
|
|
#:when (eq? e v))
|
|
i))
|
|
|
|
(define (merge-prefix root-prefix mod-prefix)
|
|
(match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix)
|
|
(match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix)
|
|
(make-prefix (+ root-num-lifts mod-num-lifts)
|
|
(append root-toplevels mod-toplevels)
|
|
(append root-stxs mod-stxs)
|
|
root-src-insp-desc))
|
|
|
|
(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent)
|
|
|
|
(define (compute-new-modvar mv rw)
|
|
(match mv
|
|
[(struct module-variable (modidx sym pos phase constantness))
|
|
(match rw
|
|
[(struct modvar-rewrite (self-modidx provide->toplevel))
|
|
(log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx)))
|
|
(define tl (provide->toplevel sym pos))
|
|
(log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl))
|
|
(match-define (toplevel-offset-rewriter rewrite-fun meta)
|
|
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx
|
|
(lambda ()
|
|
(error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))))
|
|
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta))
|
|
(define res (rewrite-fun tl))
|
|
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S"
|
|
sym pos (mpi->path* modidx) tl meta res))
|
|
res])]))
|
|
|
|
(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels)
|
|
(define-values
|
|
(i new-toplevels remap)
|
|
(for/fold ([i 0]
|
|
[new-toplevels empty]
|
|
[remap empty])
|
|
([tl (in-list mod-toplevels)]
|
|
[idx (in-naturals)])
|
|
(log-debug (format "[~S] mod-prefix tls\t~v ~v"
|
|
name idx tl))
|
|
(match tl
|
|
[(and mv (struct module-variable (modidx sym pos phase constantness)))
|
|
(define rw ((current-get-modvar-rewrite) modidx))
|
|
;; XXX We probably don't need to deal with #f phase
|
|
(unless (or (not phase) (zero? phase))
|
|
(error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv))
|
|
(cond
|
|
; Primitive module like #%paramz
|
|
[(symbol? rw)
|
|
(log-debug (format "~S from ~S" sym rw))
|
|
(values (add1 i)
|
|
(list* tl new-toplevels)
|
|
(list* (+ i toplevel-offset) remap))]
|
|
[(module-path-index? rw)
|
|
(values (add1 i)
|
|
(list* tl new-toplevels)
|
|
(list* (+ i toplevel-offset) remap))]
|
|
[(modvar-rewrite? rw)
|
|
(values i
|
|
new-toplevels
|
|
(list* (compute-new-modvar mv rw) remap))]
|
|
[else
|
|
(error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])]
|
|
[tl
|
|
(cond
|
|
[(and new-#f-idx (not tl))
|
|
(log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v"
|
|
name idx (+ i toplevel-offset) new-#f-idx))
|
|
(values i
|
|
new-toplevels
|
|
(list* new-#f-idx remap))]
|
|
[else
|
|
(values (add1 i)
|
|
(list* tl new-toplevels)
|
|
(list* (+ i toplevel-offset) remap))])])))
|
|
; XXX This would be more efficient as a vector
|
|
(values (reverse new-toplevels)
|
|
(reverse remap)))
|
|
|
|
(define (merge-module max-let-depth top-prefix mod-form)
|
|
(match mod-form
|
|
[(struct mod (name srcname self-modidx
|
|
mod-prefix provides requires body syntax-bodies
|
|
unexported mod-max-let-depth dummy lang-info
|
|
internal-context binding-names
|
|
flags pre-submodules post-submodules))
|
|
(define top-toplevels (prefix-toplevels top-prefix))
|
|
(define toplevel-offset (length top-toplevels))
|
|
(define topsyntax-offset (length (prefix-stxs top-prefix)))
|
|
(define lift-offset (prefix-num-lifts top-prefix))
|
|
(define mod-toplevels (prefix-toplevels mod-prefix))
|
|
(define new-#f-idx
|
|
(index-of #f top-toplevels))
|
|
(when new-#f-idx
|
|
(log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing"
|
|
name new-#f-idx)))
|
|
(define-values (new-mod-toplevels toplevel-remap)
|
|
(filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels))
|
|
(define num-mod-toplevels
|
|
(length toplevel-remap))
|
|
(define mod-stxs
|
|
(length (prefix-stxs mod-prefix)))
|
|
(define mod-num-lifts
|
|
(prefix-num-lifts mod-prefix))
|
|
(define new-mod-prefix
|
|
(struct-copy prefix mod-prefix
|
|
[toplevels new-mod-toplevels]))
|
|
(define offset-meta (vector name srcname self-modidx))
|
|
(log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S"
|
|
offset-meta
|
|
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f))
|
|
(hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx
|
|
(toplevel-offset-rewriter
|
|
(lambda (n)
|
|
(log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta)
|
|
(list-ref toplevel-remap n))
|
|
offset-meta))
|
|
(unless (= (length toplevel-remap)
|
|
(length mod-toplevels))
|
|
(error 'merge-module "Not remapping everything: ~S ~S"
|
|
mod-toplevels toplevel-remap))
|
|
(log-debug (format "[~S] Incrementing toplevels by ~a"
|
|
name
|
|
toplevel-offset))
|
|
(log-debug (format "[~S] Incrementing lifts by ~a"
|
|
name
|
|
lift-offset))
|
|
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
|
|
name
|
|
(length mod-toplevels)
|
|
(length new-mod-toplevels)))
|
|
(values (max max-let-depth mod-max-let-depth)
|
|
(merge-prefix top-prefix new-mod-prefix)
|
|
(lambda (top-prefix)
|
|
(log-debug (format "[~S] Updating top-levels" name))
|
|
(define top-lift-start (prefix-lift-start top-prefix))
|
|
(define mod-lift-start (prefix-lift-start mod-prefix))
|
|
(define total-lifts (prefix-num-lifts top-prefix))
|
|
(define max-toplevel (+ top-lift-start total-lifts))
|
|
(define update
|
|
(update-toplevels
|
|
(lambda (n)
|
|
(define new-idx
|
|
(cond
|
|
[(mod-lift-start . <= . n)
|
|
(log-debug (format "[~S] ~v is a lift"
|
|
name n))
|
|
(define which-lift (- n mod-lift-start))
|
|
(define lift-tl (+ top-lift-start lift-offset which-lift))
|
|
(when (lift-tl . >= . max-toplevel)
|
|
(error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)"
|
|
name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
|
|
lift-tl]
|
|
[else
|
|
;; xxx maybe change this to a vector after it is made to make this efficient
|
|
(list-ref toplevel-remap n)]))
|
|
(log-debug (format "[~S] ~v is remapped to ~v"
|
|
name n new-idx))
|
|
new-idx)
|
|
(lambda (n)
|
|
(+ n topsyntax-offset))
|
|
(prefix-syntax-start top-prefix)))
|
|
(map update body)))]))
|
|
|
|
(provide/contract
|
|
[merge-compilation-top (-> get-modvar-rewrite/c
|
|
compilation-top?
|
|
compilation-top?)])
|