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

fix `lazy-require' in phase levels other than 0

Browse Source 
The `lazy-require' form expands to `define-runtime-module-path-index',
whch doesn't work right at phase levels other than 0. Work around the
problem by generating a submodule to hold the
`define-runtime-module-path-index' form.

This repair fixes `raco exe' on certain uses of `match', which in turn
uses `lazy-require' at compile time.

Also, use `register-external-module' to generate appropriate
dependencies on lazily loaded modules.

original commit: 6b16679b39
This commit is contained in:
Matthew Flatt 2012-11-11 07:22:51 -07:00
commit 03c5a46331
16 changed files with 181 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/compiler/decompile.rkt
View File

@ -78,7 +78,20 @@
(let-values ([(n b) (module-path-index-split modidx)])
(and (not n) (not b))))
(string->symbol (format "_~a" sym))
(string->symbol (format "_~s@~s~a" sym (mpi->string modidx)
(string->symbol (format "_~s~a@~s~a"
sym
(match constantness
['constant ":c"]
['fixed ":f"]
[(function-shape a pm?)
(if pm? ":P" ":p")]
[(struct-type-shape c) ":t"]
[(constructor-shape a) ":mk"]
[(predicate-shape) ":?"]
[(accessor-shape c) ":ref"]
[(mutator-shape c) ":set!"]
[else ""])
(mpi->string modidx)
(if (zero? phase)
""
(format "/~a" phase)))))]

5
collects/compiler/demodularizer/alpha.rkt
View File

@ -1,5 +1,6 @@
#lang racket
(require compiler/zo-parse)
#lang racket/base
(require racket/match racket/contract compiler/zo-parse)
(define (alpha-vary-ctop top)
(match top

4
collects/compiler/demodularizer/batch.rkt
View File

@ -1,4 +1,5 @@
#lang racket
#lang racket/base
#|
Here's the idea:
@ -40,6 +41,7 @@ Here's the idea:
(require racket/pretty
racket/system
racket/cmdline
"mpi.rkt"
"util.rkt"
"nodep.rkt"

38
collects/compiler/demodularizer/gc-toplevels.rkt
View File

@ -1,5 +1,10 @@
#lang racket
(require compiler/zo-parse
#lang racket/base
(require racket/match
racket/list
racket/dict
racket/contract
compiler/zo-parse
"util.rkt")
; XXX Use efficient set structure
@ -150,21 +155,20 @@
(match (dict-ref g n)
[(struct refs (n-tls n-stxs))
(hash-set! visited? n #t)
(local
[(define-values (new-tls1 new-stxs1)
(for/fold ([new-tls tls]
[new-stxs stxs])
([tl (in-list n-tls)])
(visit-tl tl new-tls new-stxs)))
(define new-stxs2
(for/fold ([new-stxs new-stxs1])
([stx (in-list n-stxs)])
(define this-stx (visit-stx stx))
(if this-stx
(list* this-stx new-stxs)
new-stxs)))]
(values (list* n new-tls1)
new-stxs2))])))
(define-values (new-tls1 new-stxs1)
(for/fold ([new-tls tls]
[new-stxs stxs])
([tl (in-list n-tls)])
(visit-tl tl new-tls new-stxs)))
(define new-stxs2
(for/fold ([new-stxs new-stxs1])
([stx (in-list n-stxs)])
(define this-stx (visit-stx stx))
(if this-stx
(list* this-stx new-stxs)
new-stxs)))
(values (list* n new-tls1)
new-stxs2)])))
(define stx-visited? (make-hasheq))
(define (visit-stx n)
(if (hash-has-key? stx-visited? n)

20
collects/compiler/demodularizer/merge.rkt
View File

@ -1,5 +1,9 @@
#lang racket
(require compiler/zo-parse
#lang racket/base
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt"
"mpi.rkt"
"nodep.rkt"
@ -156,12 +160,12 @@
(cond
[(mod-lift-start . <= . n)
; This is a lift
(local [(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)]
(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
(list-ref toplevel-remap n)]))
(lambda (n)

8
collects/compiler/demodularizer/module.rkt
View File

@ -1,5 +1,9 @@
#lang racket
(require compiler/zo-parse
#lang racket/base
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt")
(define (->module-path-index s)

6
collects/compiler/demodularizer/mpi.rkt
View File

@ -1,5 +1,7 @@
#lang racket
(require syntax/modresolve)
#lang racket/base
(require racket/contract
syntax/modresolve)
(define current-module-path (make-parameter #f))

11
collects/compiler/demodularizer/nodep.rkt
View File

@ -1,5 +1,9 @@
#lang racket
(require compiler/zo-parse
#lang racket/base
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt"
"mpi.rkt"
racket/set)
@ -92,7 +96,8 @@
(define (nodep-form form phase)
(if (mod? form)
(local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))]
(let-values ([(modvar-rewrite lang-info mods)
(nodep-module form phase)])
(values modvar-rewrite lang-info (make-splice mods)))
(error 'nodep-form "Doesn't support non mod forms")))

8
collects/compiler/demodularizer/replace-modidx.rkt
View File

@ -1,6 +1,10 @@
#lang racket
(require unstable/struct
#lang racket/base
(require racket/match
racket/vector
unstable/struct
"util.rkt")
(provide replace-modidx)
(define (replace-modidx expr self-modidx)

7
collects/compiler/demodularizer/update-toplevels.rkt
View File

@ -1,5 +1,8 @@
#lang racket
(require compiler/zo-structs
#lang racket/base
(require racket/match
racket/contract
compiler/zo-structs
"util.rkt")
(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)

6
collects/compiler/demodularizer/util.rkt
View File

@ -1,5 +1,7 @@
#lang racket
(require compiler/zo-parse)
#lang racket/base
(require racket/contract
compiler/zo-parse)
(define (prefix-syntax-start pre)
(length (prefix-toplevels pre)))

42
collects/compiler/zo-marshal.rkt
View File

@ -604,13 +604,51 @@
[(? void?)
(out-byte CPT_VOID out)]
[(struct module-variable (modidx sym pos phase constantness))
(define (to-sym n) (string->symbol (format "struct~a" n)))
(out-byte CPT_MODULE_VAR out)
(out-anything modidx out)
(out-anything sym out)
(out-anything (cond
[(function-shape? constantness)
(let ([a (function-shape-arity constantness)])
(cond
[(arity-at-least? a)
(bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1)
(if (function-shape-preserves-marks? constantness) 1 0))]
[(list? a)
(string->symbol (apply
string-append
(add-between
(for/list ([a (in-list a)])
(define n (if (arity-at-least? a)
(- (add1 (arity-at-least-value a)))
a))
(number->string n))
":")))]
[else
(bitwise-ior (arithmetic-shift a 1)
(if (function-shape-preserves-marks? constantness) 1 0))]))]
[(struct-type-shape? constantness)
(to-sym (arithmetic-shift (struct-type-shape-field-count constantness)
4))]
[(constructor-shape? constantness)
(to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness)
4)))]
[(predicate-shape? constantness) (to-sym 2)]
[(accessor-shape? constantness)
(to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness)
4)))]
[(mutator-shape? constantness)
(to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness)
4)))]
[(struct-other-shape? constantness)
(to-sym 5)]
[else #f])
out)
(case constantness
[(constant) (out-number -4 out)]
[(#f) (void)]
[(fixed) (out-number -5 out)]
[else (void)])
[else (out-number -4 out)])
(unless (zero? phase)
(out-number -2 out)
(out-number phase out))

28
collects/compiler/zo-parse.rkt
View File

@ -856,6 +856,7 @@
[(module-var)
(let ([mod (read-compact cp)]
[var (read-compact cp)]
[shape (read-compact cp)]
[pos (read-compact-number cp)])
(let-values ([(flags mod-phase pos)
(let loop ([pos pos])
@ -869,6 +870,33 @@
[else (values 0 0 pos)]))])
(make-module-variable mod var pos mod-phase
(cond
[shape
(cond
[(number? shape)
(define n (arithmetic-shift shape -1))
(make-function-shape (if (negative? n)
(make-arity-at-least (sub1 (- n)))
n)
(odd? shape))]
[(and (symbol? shape)
(regexp-match? #rx"^struct" (symbol->string shape)))
(define n (string->number (substring (symbol->string shape) 6)))
(case (bitwise-and n #x7)
[(0) (make-struct-type-shape (arithmetic-shift n -3))]
[(1) (make-constructor-shape (arithmetic-shift n -3))]
[(2) (make-predicate-shape)]
[(3) (make-accessor-shape (arithmetic-shift n -3))]
[(4) (make-mutator-shape (arithmetic-shift n -3))]
[else (make-struct-other-shape)])]
[else
;; parse symbol as ":"-separated sequence of arities
(make-function-shape
(for/list ([s (regexp-split #rx":" (symbol->string shape))])
(define i (string->number s))
(if (negative? i)
(make-arity-at-least (sub1 (- i)))
i))
#f)])]
[(not (zero? (bitwise-and #x1 flags))) 'constant]
[(not (zero? (bitwise-and #x2 flags))) 'fixed]
[else #f]))))]

15
collects/compiler/zo-structs.rkt
View File

@ -38,13 +38,26 @@
[(_ id . rest)
(define-form-struct* id (id zo) . rest)]))
(define-form-struct function-shape ([arity procedure-arity?]
[preserves-marks? boolean?]))
(define-form-struct struct-shape ())
(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ())
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-other-shape struct-shape) ())
;; In toplevels of resove prefix:
(define-form-struct global-bucket ([name symbol?])) ; top-level binding
(define-form-struct module-variable ([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed)]))
[constantness (or/c #f 'constant 'fixed
function-shape?
struct-shape?)]))
;; Syntax object
(define ((alist/c k? v?) l)

12
collects/tests/racket/embed-me21.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang racket/base
(require racket/match)
;; check using `racket/match', particularly with a pattern
;; that eneds run-time support that may go through a
;; compile-time `lazy-require':
(match "x"
[(pregexp "x")
(with-output-to-file "stdout"
(lambda () (printf "This is 21.\n"))
#:exists 'append)])

1
collects/tests/racket/embed.rktl
View File

@ -227,6 +227,7 @@
(one-mz-test "embed-me17.rkt" "This is 17.\n" #f)
(one-mz-test "embed-me18.rkt" "This is 18.\n" #f)
(one-mz-test "embed-me19.rkt" "This is 19.\n" #f)
(one-mz-test "embed-me21.rkt" "This is 21.\n" #f)
;; Try unicode expr and cmdline:
(prepare dest "unicode")