suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Base now works, but was broken before

Browse Source
This commit is contained in:
Jay McCarthy 2013-10-15 07:51:14 -06:00
parent a460ab960c
commit e6e95f1029
4 changed files with 52 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
pkgs/compiler-lib/compiler/demodularizer/merge.rkt
View File

@ -9,7 +9,7 @@
"nodep.rkt"
"update-toplevels.rkt")
(define MODULE-TOPLEVEL-OFFSETS (make-hash))
(define MODULE-TOPLEVEL-OFFSETS (make-hasheq))
(define current-get-modvar-rewrite (make-parameter #f))
(define (merge-compilation-top get-modvar-rewrite top)
@ -25,21 +25,21 @@
(log-debug (format "total toplevels ~S" total-tls))
(log-debug (format "total stxs ~S" total-stxs))
(log-debug (format "num-lifts ~S" total-lifts))
(make-compilation-top
new-max-let-depth new-prefix
(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)))))))
(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
@ -61,16 +61,20 @@
(append root-toplevels mod-toplevels)
(append root-stxs mod-stxs))])]))
(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 of ~S" pos (mpi->path* modidx)))
((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx
(lambda ()
(error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))
(provide->toplevel sym pos))])]))
(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 of ~S from ~S" pos (mpi->path* modidx) meta))
(rewrite-fun (provide->toplevel sym pos))])]))
(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels)
(define-values
@ -78,15 +82,15 @@
(for/fold ([i 0]
[new-toplevels empty]
[remap empty])
([tl (in-list mod-toplevels)])
([tl (in-list mod-toplevels)])
(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
; 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
; Primitive module like #%paramz
[(symbol? rw)
(log-debug (format "~S from ~S" sym rw))
(values (add1 i)
@ -106,7 +110,7 @@
(values (add1 i)
(list* tl new-toplevels)
(list* (+ i toplevel-offset) remap))])))
; XXX This would be more efficient as a vector
; XXX This would be more efficient as a vector
(values (reverse new-toplevels)
(reverse remap)))
@ -118,8 +122,9 @@
(define toplevel-offset (length (prefix-toplevels top-prefix)))
(define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix))
(define mod-toplevels (prefix-toplevels mod-prefix))
(define-values (new-mod-toplevels toplevel-remap) (filter-rewritable-module-variable? toplevel-offset mod-toplevels))
(define mod-toplevels (prefix-toplevels mod-prefix))
(define-values (new-mod-toplevels toplevel-remap)
(filter-rewritable-module-variable? toplevel-offset mod-toplevels))
(define num-mod-toplevels
(length toplevel-remap))
(define mod-stxs
@ -129,9 +134,16 @@
(define new-mod-prefix
(struct-copy prefix mod-prefix
[toplevels new-mod-toplevels]))
(hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx
(lambda (n)
(list-ref toplevel-remap n)))
(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"
@ -142,7 +154,7 @@
(log-debug (format "[~S] Incrementing lifts by ~a"
name
lift-offset))
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
name
(length mod-toplevels)
(length new-mod-toplevels)))
@ -155,15 +167,15 @@
(define total-lifts (prefix-num-lifts top-prefix))
(define max-toplevel (+ top-lift-start total-lifts))
(define update
(update-toplevels
(update-toplevels
(lambda (n)
(cond
[(mod-lift-start . <= . n)
; This is a lift
; This is a lift
(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)"
(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

9
pkgs/compiler-lib/compiler/demodularizer/nodep.rkt
View File

@ -128,10 +128,13 @@
(when (symbol? tl)
(hash-set! provide-ht (intern tl) i)))
(lambda (sym pos)
(log-debug (format "Looking up ~S@~a" sym pos))
(hash-ref provide-ht (intern sym)
(log-debug (format "Looking up ~S@~a in ~S" sym pos prefix))
(define res
(hash-ref provide-ht (intern sym)
(lambda ()
(error 'provide->toplevel "Cannot find ~S in ~S" sym prefix)))))
(error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))
(log-debug (format "Looked up ~S@~a and got ~v" sym pos res))
res))
(define (nodep-module mod-form phase)
(match mod-form

8
pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/demod-test.rkt
View File

@ -13,7 +13,7 @@
(values (get-output-string o) (get-output-string e)))
(define (test-on-program filename)
; run modular program, capture output
;; run modular program, capture output
(define-values (modular-output modular-error)
(capture-output (find-exe) filename))
@ -24,15 +24,15 @@
(find-system-path 'temp-dir)
(path-add-suffix filename #"_merged.zo")))))
; demodularize
;; demodularize
(parameterize ([current-input-port (open-input-string "")])
(system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename))
; run whole program
;; run whole program
(define-values (whole-output whole-error)
(capture-output (find-exe) demod-filename))
; compare output
;; compare output
(test
#:failure-prefix (format "~a stdout" filename)
whole-output => modular-output

2
pkgs/racket-pkgs/racket-test/tests/compiler/demodularizer/tests/base-5.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang racket/base
5