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

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

collects/compiler/decompile.rkt

@@ -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)))))]

collects/compiler/demodularizer/alpha.rkt

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

collects/compiler/demodularizer/batch.rkt

@@ -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"

collects/compiler/demodularizer/gc-toplevels.rkt

@@ -1,5 +1,10 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(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)
-             [(define-values (new-tls1 new-stxs1)
+             (for/fold ([new-tls tls]
-                (for/fold ([new-tls tls]
+                        [new-stxs stxs])
-                           [new-stxs stxs])
+                       ([tl (in-list n-tls)])
-                  ([tl (in-list n-tls)])
+               (visit-tl tl new-tls new-stxs)))
-                  (visit-tl tl new-tls new-stxs)))
+           (define new-stxs2
-              (define new-stxs2
+             (for/fold ([new-stxs new-stxs1])
-                (for/fold ([new-stxs new-stxs1])
+                       ([stx (in-list n-stxs)])
-                  ([stx (in-list n-stxs)])
+               (define this-stx (visit-stx stx))
-                  (define this-stx (visit-stx stx))
+               (if this-stx
-                  (if this-stx
+                   (list* this-stx new-stxs)
-                      (list* this-stx new-stxs)
+                   new-stxs)))
-                      new-stxs)))]          
+           (values (list* n new-tls1)
-             (values (list* n new-tls1)
+                   new-stxs2)])))
-                     new-stxs2))])))
   (define stx-visited? (make-hasheq))
   (define (visit-stx n)
     (if (hash-has-key? stx-visited? n)

collects/compiler/demodularizer/merge.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(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 which-lift (- n mod-lift-start))
-                               (define lift-tl (+ top-lift-start lift-offset which-lift))]
+                       (define lift-tl (+ top-lift-start lift-offset which-lift))
-                         (when (lift-tl . >= . max-toplevel)
+                       (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))
+                                name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
-                         lift-tl)]
+                       lift-tl]
                       [else
                        (list-ref toplevel-remap n)]))
                   (lambda (n)

collects/compiler/demodularizer/module.rkt

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

collects/compiler/demodularizer/mpi.rkt

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

collects/compiler/demodularizer/nodep.rkt

@@ -1,5 +1,9 @@
-#lang racket
+#lang racket/base
-(require compiler/zo-parse
+
+(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")))
 

collects/compiler/demodularizer/replace-modidx.rkt

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

collects/compiler/demodularizer/update-toplevels.rkt

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

collects/compiler/demodularizer/util.rkt

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

collects/compiler/zo-marshal.rkt

@@ -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))

collects/compiler/zo-parse.rkt

@@ -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]))))]

collects/compiler/zo-structs.rkt

@@ -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)

collects/tests/racket/embed-me21.rkt

@@ -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)])

collects/tests/racket/embed.rktl

@@ -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")