08a40b5998
The demodularizer used to include multiple dummy toplevels from every module that needed one, which didn't work with the unresolver. That change makes it so all references to dummy toplevels point to the same one.
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 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 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?)])
|