repairs for change for machine-independent bytecode

Fix problems with moving some VM-specific handlign to schemify, and
fix some interning issues that the change exposed.

pkgs/compiler-lib/compiler/decompile.rkt

@@ -759,7 +759,7 @@
 (struct faslable-correlated-linklet (expr name)
   #:prefab)
 
-(struct faslable-correlated (e source position line column span name)
+(struct faslable-correlated (e source position line column span props)
   #:prefab)
 
 (define (strip-correlated v)

racket/collects/racket/private/c.rkt

@@ -0,0 +1,366 @@
+;;----------------------------------------------------------------------
+;; case: based on Clinger, "Rapid Case Dispatch in Scheme"
+;;       [http://scheme2006.cs.uchicago.edu/07-clinger.pdf]
+
+(module case '#%kernel
+  (#%require '#%paramz '#%unsafe "small-scheme.rkt" "define.rkt"
+             (for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt"
+                         "qqstx.rkt" "define.rkt" "sort.rkt"))
+  (#%provide case)
+  
+  
+  (define-syntax (case stx)
+    (syntax-case stx (else)
+      ;; Empty case
+      [(_ v)
+       (syntax-protect
+        (syntax/loc stx (#%expression (begin v (void)))))]
+      
+      ;; Else-only case
+      [(_ v [else e es ...])
+       (syntax-protect
+        (syntax/loc stx (#%expression (begin v (let-values () e es ...)))))]
+      
+      ;; If we have a syntactically correct form without an 'else' clause,
+      ;; add the default 'else' and try again.
+      [(self v [(k ...) e1 e2 ...] ...)
+       (syntax-protect
+        (syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))]
+      
+      ;; The general case
+      [(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...])
+       (syntax-protect
+        (if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*)
+            (syntax/loc stx (let ([tmp v])
+                              (case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))
+            (syntax/loc stx (let ([tmp v])
+                              (case/dispatch   tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))]
+      
+      ;; Error cases
+      [(_ v clause ...)
+       (let loop ([clauses (syntax->list #'(clause ...))])
+         (unless (null? clauses)
+           (let ([clause (car clauses)])
+             (syntax-case clause ()
+               [((_ ...) _ _ ...)
+                (loop (cdr clauses))]
+               [((_ ...) . _)
+                (syntax-case clause ()
+                  [(_)
+                   (raise-syntax-error
+                    #f
+                    "bad syntax (missing expression after datum sequence)"
+                    stx
+                    clause)]
+                  [(_ . _)
+                   (raise-syntax-error
+                    #f
+                    "bad syntax (illegal use of `.' in clause)"
+                    stx
+                    clause)]
+                  [_
+                   (raise-syntax-error 
+                    #f
+                    "bad syntax (ill-formed clause)"
+                    stx
+                    clause)])]
+               [(bad . _)
+                (raise-syntax-error 
+                 #f
+                 ;; If #'bad is an identifier, report its binding in the error message.
+                 ;; This helps resolving the syntax error when `else' is shadowed somewhere
+                 (if (not (symbol? (syntax-e (syntax bad))))
+                     "bad syntax (not a datum sequence)"
+                     (string-append
+                      "bad syntax (not a datum sequence)\n"
+                      "  expected: a datum sequence or the binding 'else' from racket/base\n"
+                      "  given: "
+                      (let ([binding (identifier-binding (syntax bad))])
+                        (cond
+                          [(not binding) "an unbound identifier"]
+                          [(eq? binding 'lexical) "a locally bound identifier"]
+                          [else
+                           (let*-values ([(src) (car binding)]
+                                         [(mpath base) (module-path-index-split src)])
+                             (cond
+                               [(not mpath)
+                                "an identifier bound by the current module"]
+                               [else
+                                (format "an identifier required from the module ~a"
+                                        (resolved-module-path-name
+                                         (module-path-index-resolve src)))]))]))))
+                 stx
+                 (syntax bad))]
+               [_
+                (raise-syntax-error 
+                 #f
+                 "bad syntax (ill-formed clause)"
+                 stx
+                 (syntax bad))]))))]
+      [(_ . v)
+       (not (null? (syntax-e (syntax v))))
+       (raise-syntax-error 
+        #f
+        "bad syntax (illegal use of `.')"
+        stx)]))
+  
+  ;; Sequential case: 
+  ;; Turn the expression into a sequence of if-then-else.
+  (define-syntax (case/sequential stx)
+    (syntax-case stx (else)
+      [(_ v [(k ...) es ...] arms ... [else xs ...])
+       (syntax-protect
+        #'(if (case/sequential-test v (k ...))
+              (let-values () es ...)
+              (case/sequential v arms ... [else xs ...])))]
+      [(_ v [(k ...) es ...] [else xs ...])
+       (syntax-protect
+        #'(if (case/sequential-test v (k ...))
+              (let-values () es ...)
+              (let-values () xs ...)))]
+      [(_ v [else xs ...])
+       (syntax-protect
+        #'(let-values () xs ...))]))
+  
+  (define-syntax (case/sequential-test stx)
+    (syntax-protect
+     (syntax-case stx ()
+       [(_ v ())         #'#f]
+       [(_ v (k))        #`(equal? v 'k)]
+       [(_ v (k ks ...)) #`(if (equal? v 'k)
+                               #t
+                               (case/sequential-test v (ks ...)))])))
+  
+  ;; Triple-dispatch case:
+  ;; (1) From the type of the value to a type-specific mechanism for
+  ;; (2) mapping the value to the index of the consequent we need. Then,
+  ;; (3) from the index, perform a binary search to find the consequent code.
+  ;; Note: the else clause is given index 0.
+  (define-syntax (case/dispatch stx)
+    (syntax-case stx (else)
+      [(_ v [(k ...) es ...] ... [else xs ...])
+       (syntax-protect
+        #`(let ([index
+                 #,(let* ([ks  (partition-constants #'((k ...) ...))]
+                          [exp #'0]
+                          [exp (if (null? (consts-other ks))
+                                   exp
+                                   (dispatch-other #'v (consts-other ks) exp))]
+                          [exp (if (null? (consts-char ks))
+                                   exp
+                                   #`(if (char? v)
+                                         #,(dispatch-char #'v (consts-char ks))
+                                         #,exp))]
+                          [exp (if (null? (consts-symbol ks))
+                                   exp
+                                   #`(if #,(test-for-symbol #'v (consts-symbol ks))
+                                         #,(dispatch-symbol #'v (consts-symbol ks) #'0)
+                                         #,exp))]
+                          [exp (if (null? (consts-fixnum ks))
+                                   exp
+                                   #`(if (fixnum? v)
+                                         #,(dispatch-fixnum #'v (consts-fixnum ks))
+                                         #,exp))])
+                     exp)])
+            #,(index-binary-search #'index #'([xs ...] [es ...] ...))))]))
+
+    
+  (begin-for-syntax
+    (define *sequential-threshold* 12)
+    (define *hash-threshold*       10)
+    
+    (define nothing (gensym))
+    
+    (define interval-lo    car)
+    (define interval-hi    cadr)
+    (define interval-index caddr)
+    
+    (define (partition-constants stx)
+      (define h (make-hash))
+      
+      (define (duplicate? x)
+        (not (eq? (hash-ref h x nothing) nothing)))
+      
+      (define (add xs x idx)
+        (hash-set! h x idx)
+        (cons (cons x idx) xs))
+      
+      (let loop ([f '()] [s '()] [c '()] [o '()] [idx 1] [xs (syntax->list stx)])
+        (cond [(null? xs)
+               (list (cons 'fixnum f)
+                     (cons 'symbol s)
+                     (cons 'char   c)
+                     (cons 'other  o))]
+              [else (let inner ([f f] [s s] [c c] [o o] [ys (syntax->list (car xs))])
+                      (cond [(null? ys) (loop f s c o (add1 idx) (cdr xs))]
+                            [else
+                             (let ([y (syntax->datum (car ys))])
+                               (cond [(duplicate? y) (inner f s c o (cdr ys))]
+                                     [(fixnum? y)    (inner (add f y idx) s c o (cdr ys))]
+                                     [(symbol? y)    (inner f (add s y idx) c o (cdr ys))]
+                                     [(keyword? y)   (inner f (add s y idx) c o (cdr ys))]
+                                     [(char? y)      (inner f s (add c y idx) o (cdr ys))]
+                                     [else           (inner f s c (add o y idx) (cdr ys))]))]))])))
+    
+    (define (consts-fixnum ks) (cdr (assq 'fixnum ks)))
+    (define (consts-symbol ks) (cdr (assq 'symbol ks)))
+    (define (consts-char   ks) (cdr (assq 'char   ks)))
+    (define (consts-other  ks) (cdr (assq 'other  ks)))
+    
+    ;; Character dispatch is fixnum dispatch.
+    (define (dispatch-char tmp-stx char-alist)
+      #`(let ([codepoint (char->integer #,tmp-stx)])
+          #,(dispatch-fixnum #'codepoint
+                             (map (λ (x)
+                                    (cons (char->integer (car x))
+                                          (cdr x)))
+                                  char-alist))))
+    
+    ;; Symbol and "other" dispatch is either sequential or
+    ;; hash-table-based, depending on how many constants we
+    ;; have. Assume that `alist' does not map anything to `#f'.
+    (define (dispatch-hashable tmp-stx alist make-hashX else-exp)
+      (if (< (length alist) *hash-threshold*)
+          #`(case/sequential #,tmp-stx 
+                             #,@(map (λ (x)
+                                       #`[(#,(car x)) #,(cdr x)])
+                                     alist)
+                             [else #,else-exp])
+          (let ([tbl (make-hashX alist)])
+            (if (literal-expression? else-exp)
+                #`(hash-ref #,tbl #,tmp-stx (lambda () #,else-exp))
+                #`(or (hash-ref #,tbl #,tmp-stx (lambda () #f))
+                      #,else-exp)))))
+
+    (define (dispatch-symbol tmp-stx symbol-alist else-exp)
+      (dispatch-hashable tmp-stx symbol-alist make-immutable-hasheq else-exp))
+
+    (define (dispatch-other tmp-stx other-alist else-exp)
+      (dispatch-hashable tmp-stx other-alist make-immutable-hash else-exp))
+
+    (define (test-for-symbol tmp-stx alist)
+      (define (contains? pred)
+        (ormap (lambda (p) (pred (car p))) alist))
+      (if (contains? symbol?)
+          (if (contains? keyword?)
+              #`(or (symbol? #,tmp-stx) (keyword? #,tmp-stx))
+              #`(symbol? #,tmp-stx))
+          #`(keyword? #,tmp-stx)))
+
+    (define (literal-expression? else-exp)
+      (define v (syntax-e else-exp))
+      (or (boolean? v) (number? v)))
+    
+    ;; Fixnum dispatch is either table lookup or binary search.
+    (define (dispatch-fixnum tmp-stx fixnum-alist)
+      (define (go intervals lo hi lo-bound hi-bound)
+        (define len (length intervals))
+        
+        (cond [(or (>= lo-bound hi)
+                   (<= hi-bound lo))
+               #'0]
+              [(and (> len 1)
+                    (< (- hi lo) (* len 5)))
+               (fixnum-table-lookup  intervals lo hi lo-bound hi-bound)]
+              [else
+               (fixnum-binary-search intervals lo hi lo-bound hi-bound)]))
+      
+      (define (fixnum-table-lookup intervals lo hi lo-bound hi-bound)
+        (define index-lists
+          (map (λ (int)
+                 (vector->list
+                  (make-vector (- (interval-hi int)
+                                  (interval-lo int))
+                               (interval-index int))))
+               intervals))
+        
+        #`(let ([tbl #,(list->vector (apply append index-lists))])
+            #,(bounded-expr tmp-stx lo hi lo-bound hi-bound
+                            #`(unsafe-vector*-ref tbl (unsafe-fx- #,tmp-stx #,lo)))))
+      
+      (define (fixnum-binary-search intervals lo hi lo-bound hi-bound)
+        (cond [(null? (cdr intervals))
+               #`#,(interval-index (car intervals))]
+              [else
+               (define-values (lo-ints hi-ints) (split-intervals intervals))
+               (define-values (lo-lo lo-hi) (lo+hi lo-ints))
+               (define-values (hi-lo hi-hi) (lo+hi hi-ints))
+
+               #`(if (unsafe-fx< #,tmp-stx #,hi-lo)
+                     #,(go lo-ints lo-lo lo-hi lo-bound hi-lo)
+                     #,(go hi-ints hi-lo hi-hi hi-lo hi-bound))]))
+
+      (define (split-intervals intervals)
+        (define n (quotient (length intervals) 2))
+        (let loop ([n n] [lo '()] [hi intervals])
+          (cond [(zero? n) (values (reverse lo) hi)]
+                [else (loop (sub1 n) (cons (car hi) lo) (cdr hi))])))
+      
+      (define (lo+hi intervals)
+        (values (interval-lo (car intervals))
+                (interval-hi (car (reverse intervals)))))
+      
+      (define intervals (alist->intervals fixnum-alist))
+      (define-values (lo hi) (lo+hi intervals))
+      
+      #`(if (and (unsafe-fx>= #,tmp-stx #,lo)
+                 (unsafe-fx<  #,tmp-stx #,hi))
+            #,(go intervals lo hi lo hi)
+            0))
+    
+    ;; Once we have the index of the consequent we want, perform
+    ;; a binary search to find it.
+    (define (index-binary-search index-stx leg-stx)
+      (define legs (list->vector (syntax->list leg-stx)))
+
+      (define (go min max)
+        (cond [(= min max)
+               #`(let-values () #,@(vector-ref legs min))]
+              [(= max (add1 min))
+               #`(if (unsafe-fx< #,index-stx #,max)
+                     (let-values () #,@(vector-ref legs min))
+                     (let-values () #,@(vector-ref legs max)))]
+              [else
+               (let ([mid (quotient (+ min max) 2)])
+                 #`(if (unsafe-fx< #,index-stx #,mid)
+                       #,(go min (sub1 mid))
+                       #,(go mid max)))]))
+      
+      (go 0 (sub1 (vector-length legs))))
+    
+    (define (bounded-expr tmp-stx lo hi lo-bound hi-bound exp-stx)
+      (cond [(and (<= hi-bound hi)
+                  (>= lo-bound lo))
+             exp-stx]
+            [(<= hi-bound hi)
+             #`(if (unsafe-fx>= #,tmp-stx #,lo) exp-stx 0)]
+            [(>= lo-bound lo)
+             #`(if (unsafe-fx<  #,tmp-stx #,hi) exp-stx 0)]
+            [else
+             #`(if (and (unsafe-fx>= #,tmp-stx #,lo)
+                        (unsafe-fx<  #,tmp-stx #,hi))
+                   exp-stx
+                   0)]))
+    
+    (define (alist->intervals alist)
+      (let loop ([xs (sort alist < car)] [start-idx #f] [end-idx #f] [cur-val #f] [res '()])
+        (cond [(null? xs)
+               (if start-idx
+                   (reverse (cons (list start-idx end-idx cur-val) res))
+                   '())]
+              [else
+               (let* ([x (car xs)]
+                      [k (car x)]
+                      [v (cdr x)])
+                 (cond [(not start-idx)
+                        (loop (cdr xs) k (add1 k) v res)]
+                       [(and (= end-idx k) (= cur-val v))
+                        (loop (cdr xs) start-idx (add1 end-idx) cur-val res)]
+                       [(= end-idx k)
+                        (let ([interval (list start-idx end-idx cur-val)])
+                          (loop (cdr xs) k (add1 k) v (cons interval res)))]
+                       [else
+                        ;; insert an interval in the gap for the default
+                        (let ([int1 (list start-idx end-idx cur-val)]
+                              [int2 (list end-idx k 0)])
+                          (loop (cdr xs) k (add1 k) v (cons int2 (cons int1 res))))]))])))))

racket/src/cs/expander.sls

@@ -28,7 +28,9 @@
           (thread)
           (regexp)
           (io)
-          (linklet))
+          (linklet)
+          (only (schemify)
+                force-unfasl))
 
   (include "place-register.ss")
   (define-place-register-define define expander-register-start expander-register-count)
@@ -38,9 +40,6 @@
   ;; the build incompatible with previously generated ".zo" files.
   (define compile-as-independent? #f)
 
-  (define (fasl->s-exp/intern s)
-    (1/fasl->s-exp/intern s))
-
   ;; The expander needs various tables to set up primitive modules, and
   ;; the `primitive-table` function is the bridge between worlds
 
@@ -113,7 +112,9 @@
                      (thread)
                      (io)
                      (regexp)
-                     (linklet)))
+                     (linklet)
+                     (only (schemify)
+                           force-unfasl)))
       ;; Ensure that the library is visited, especially for a wpo build:
       (eval 'variable-set!)))
 
@@ -181,9 +182,6 @@
                [(_ name val) #`(let ([name val]) name)])))
     (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error)))
 
-  ;; Special "primitive" for syntax-data deserialization:
-  (eval `(define fasl->s-exp/intern ',fasl->s-exp/intern))
-
   ;; For interpretation of the outer shell of a linklet:
   (install-linklet-primitive-tables! kernel-table
                                      unsafe-table

racket/src/cs/primitive/internal.ss

@@ -36,4 +36,4 @@
   [make-pthread-parameter (known-procedure 2)]
   [break-enabled-key (known-constant)]
 
-  [fasl->s-exp/intern (known-procedure 2)])
+  [force-unfasl (known-procedure 2)])

racket/src/cs/schemify.sls

@@ -9,6 +9,7 @@
           linklet-bigger-than?
           make-path->compiled-path
           compiled-path->path
+          force-unfasl
           prim-knowns
           known-procedure
           known-procedure/pure

racket/src/expander/compile/correlated-linklet.rkt

@@ -53,7 +53,7 @@
 
 (define correlated-linklet-vm-bytes #"linklet")
 
-(struct faslable-correlated (e source position line column span name)
+(struct faslable-correlated (e source position line column span props)
   #:prefab)
 
 (struct faslable-correlated-linklet (expr name)
@@ -81,7 +81,13 @@
       (correlated-line v)
       (correlated-column v)
       (correlated-span v)
-      (correlated-property v 'inferred-name))]
+      (for/fold ([ht #f]) ([k (in-list '(inferred-name
+                                         undefined-error-name
+                                         method-arity-error))])
+        (define p (correlated-property v k))
+        (if p
+            (hash-set (or ht '#hasheq()) k p)
+            ht)))]
     [(hash? v)
      (cond
        [(hash-eq? v)
@@ -101,7 +107,7 @@
 ;; ----------------------------------------
 
 (define (read-correlated-linklet-bundle-hash in)
-  (faslable-> (fasl->s-exp in)))
+  (faslable-> (fasl->s-exp in #:datum-intern? #t)))
 
 (define (faslable-> v)
   (cond
@@ -113,7 +119,7 @@
          v
          (cons a d))]
     [(faslable-correlated? v)
-     (define name (faslable-correlated-name v))
+     (define props (faslable-correlated-props v))
      (define c (datum->correlated (faslable-> (faslable-correlated-e v))
                                   (vector
                                    (faslable-correlated-source v)
@@ -121,8 +127,9 @@
                                    (faslable-correlated-column v)
                                    (faslable-correlated-position v)
                                    (faslable-correlated-span v))))
-     (if name
+     (if props
-         (correlated-property c 'inferred-name name)
+         (for/fold ([c c]) ([(k p) (in-hash props)])
+           (correlated-property c k p))
          c)]
     [(hash? v)
      (cond

racket/src/expander/compile/module.rkt

@@ -265,7 +265,7 @@
                            (make-correlated-linklet s 'syntax-literals-data)
                            (performance-region
                             ['compile 'module 'linklet]
-                            (compile-linklet s 'syntax-literals-data #f #f '(serializable uninterned-literal)))))
+                            (compile-linklet s 'syntax-literals-data #f #f '(serializable)))))
            `(linklet
              ;; imports
              (,deserialize-imports

racket/src/expander/main.rkt

@@ -1,6 +1,5 @@
 #lang racket/base
 (require "common/set.rkt"
-         "common/fasl.rkt"
          "common/module-path.rkt"
          "namespace/namespace.rkt"
          "eval/main.rkt"
@@ -119,8 +118,6 @@
 
          expander-place-init!
 
-         fasl->s-exp/intern  ; for Chez Scheme as "primitive" and in linklet layer
-
          ;; The remaining functions are provided for basic testing
          ;; (such as "demo.rkt")
 

racket/src/racket/src/startup.inc

@@ -28732,7 +28732,7 @@ static const char *startup_source =
 " faslable-correlated-line"
 " faslable-correlated-column"
 " faslable-correlated-span"
-" faslable-correlated-name)"
+" faslable-correlated-props)"
 "(let-values(((struct:_0 make-_0 ?_0 -ref_0 -set!_0)"
 "(let-values()"
 "(let-values()"
@@ -28758,7 +28758,7 @@ static const char *startup_source =
 "(make-struct-field-accessor -ref_0 3 'line)"
 "(make-struct-field-accessor -ref_0 4 'column)"
 "(make-struct-field-accessor -ref_0 5 'span)"
-"(make-struct-field-accessor -ref_0 6 'name))))"
+"(make-struct-field-accessor -ref_0 6 'props))))"
 "(define-values"
 "(struct:faslable-correlated-linklet"
 " faslable-correlated-linklet3.1"
@@ -28808,7 +28808,34 @@ static const char *startup_source =
 "(correlated-line v_0)"
 "(correlated-column v_0)"
 "(correlated-span v_0)"
-"(correlated-property v_0 'inferred-name)))"
+"(let-values(((lst_0) '(inferred-name undefined-error-name method-arity-error)))"
+"(begin"
+"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_0)))"
+"((letrec-values(((for-loop_0)"
+"(lambda(ht_0 lst_1)"
+"(begin"
+" 'for-loop"
+"(if(pair? lst_1)"
+"(let-values(((k_0)(unsafe-car lst_1))((rest_0)(unsafe-cdr lst_1)))"
+"(let-values(((ht_1)"
+"(let-values(((ht_1) ht_0))"
+"(let-values(((ht_2)"
+"(let-values()"
+"(let-values(((p_0)"
+"(correlated-property v_0 k_0)))"
+"(if p_0"
+"(hash-set"
+"(let-values(((or-part_0) ht_1))"
+"(if or-part_0 or-part_0 '#hasheq()))"
+" k_0"
+" p_0)"
+" ht_1)))))"
+"(values ht_2)))))"
+"(if(not #f)(for-loop_0 ht_1 rest_0) ht_1)))"
+" ht_0)))))"
+" for-loop_0)"
+" #f"
+" lst_0)))))"
 "(if(hash? v_0)"
 "(let-values()"
 "(if(hash-eq? v_0)"
@@ -28914,7 +28941,7 @@ static const char *startup_source =
 "(let-values() v_0))))))))"
 "(define-values"
 "(read-correlated-linklet-bundle-hash)"
-"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0))(fasl->s-exp17.1 #t in9_0))))))"
+"(lambda(in_0)(begin(faslable->(let-values(((in9_0) in_0)((temp10_0) #t))(fasl->s-exp17.1 temp10_0 in9_0))))))"
 "(define-values"
 "(faslable->)"
 "(lambda(v_0)"
@@ -28926,7 +28953,7 @@ static const char *startup_source =
 "(if(if(eq? a_0(car v_0))(eq? d_0(cdr v_0)) #f) v_0(cons a_0 d_0)))))"
 "(if(faslable-correlated? v_0)"
 "(let-values()"
-"(let-values(((name_0)(faslable-correlated-name v_0)))"
+"(let-values(((props_0)(faslable-correlated-props v_0)))"
 "(let-values(((c_0)"
 "(datum->correlated"
 "(faslable->(faslable-correlated-e v_0))"
@@ -28936,7 +28963,30 @@ static const char *startup_source =
 "(faslable-correlated-column v_0)"
 "(faslable-correlated-position v_0)"
 "(faslable-correlated-span v_0)))))"
-"(if name_0(correlated-property c_0 'inferred-name name_0) c_0))))"
+"(if props_0"
+"(let-values(((ht_0) props_0))"
+"(begin"
+"(if(variable-reference-from-unsafe?(#%variable-reference))"
+"(void)"
+"(let-values()(check-in-hash ht_0)))"
+"((letrec-values(((for-loop_0)"
+"(lambda(c_1 i_0)"
+"(begin"
+" 'for-loop"
+"(if i_0"
+"(let-values(((k_0 p_0)(hash-iterate-key+value ht_0 i_0)))"
+"(let-values(((c_2)"
+"(let-values(((c_2) c_1))"
+"(let-values(((c_3)"
+"(let-values()"
+"(correlated-property c_2 k_0 p_0))))"
+"(values c_3)))))"
+"(if(not #f)(for-loop_0 c_2(hash-iterate-next ht_0 i_0)) c_2)))"
+" c_1)))))"
+" for-loop_0)"
+" c_0"
+"(hash-iterate-first ht_0))))"
+" c_0))))"
 "(if(hash? v_0)"
 "(let-values()"
 "(if(hash-eq? v_0)"
@@ -39653,8 +39703,7 @@ static const char *startup_source =
 " 'syntax-literals-data"
 " #f"
 " #f"
-" '(serializable"
+" '(serializable)))"
-" uninterned-literal)))"
 "(if log-performance?"
 "(let-values()"
 "(end-performance-region))"

racket/src/schemify/interpret.rkt

@@ -4,6 +4,7 @@
          "match.rkt"
          "wrap.rkt"
          "path-for-srcloc.rkt"
+         "to-fasl.rkt"
          "interp-match.rkt"
          "interp-stack.rkt")
 
@@ -84,7 +85,8 @@
                     (let ([rhs (cadr binding)])
                       (cons (cond
                               [(or (path? rhs)
-                                   (path-for-srcloc? rhs))
+                                   (path-for-srcloc? rhs)
+                                   (to-fasl? rhs))
                                ;; The caller must extract all the paths from the bindings
                                ;; and pass them back in at interp time; assume '#%path is
                                ;; not a primitive

racket/src/schemify/path.rkt

@@ -1,12 +1,15 @@
 #lang racket/base
 (require racket/private/relative-path
          racket/private/truncate-path
+         racket/fasl
          "match.rkt"
-         "path-for-srcloc.rkt")
+         "path-for-srcloc.rkt"
+         "to-fasl.rkt")
 
 (provide extract-paths-from-schemified-linklet
          make-path->compiled-path
-         compiled-path->path)
+         compiled-path->path
+         force-unfasl)
 
 ;; Recognize lifted paths in a schemified linklet, and
 ;; return the list of path values. If `convert?`, then
@@ -20,7 +23,7 @@
     [`(let* ,bindings ,body)
      (define (path-binding? b)
        (define rhs (cadr b))
-       (or (path? rhs) (path-for-srcloc? rhs)))
+       (or (path? rhs) (path-for-srcloc? rhs) (to-fasl? rhs)))
      (define any-path?
        (for/or ([b (in-list bindings)])
          (path-binding? b)))
@@ -48,28 +51,49 @@
 (define (make-path->compiled-path who)
   (define path->relative-path-elements (make-path->relative-path-elements #:who who))
   (lambda (orig-p)
-    (define p (if (path-for-srcloc? orig-p)
-                  (path-for-srcloc-path orig-p)
-                  orig-p))
     (cond
-      [(path? p)
+      [(to-fasl? orig-p)
-       (or (path->relative-path-elements p)
+       (box (s-exp->fasl (force-unfasl orig-p)))]
-           (cond
-             [(path-for-srcloc? orig-p)
-              ;; Can't make relative, so create a string that keeps up
-              ;; to two path elements
-              (truncate-path p)]
-             [else (path->bytes p)]))]
-      [(or (string? p) (bytes? p) (symbol? p) (not p))
-       ;; Allowed in compiled form
-       p]
       [else
-       (error 'write
+       (define p (if (path-for-srcloc? orig-p)
-              "cannot marshal value that is embedded in compiled code: ~V"
+                     (path-for-srcloc-path orig-p)
-              p)])))
+                     orig-p))
+       (cond
+         [(path? p)
+          (or (path->relative-path-elements p)
+              (cond
+                [(path-for-srcloc? orig-p)
+                 ;; Can't make relative, so create a string that keeps up
+                 ;; to two path elements
+                 (truncate-path p)]
+                [else (path->bytes p)]))]
+         [(or (string? p) (bytes? p) (symbol? p) (not p))
+          ;; Allowed in compiled form
+          p]
+         [else
+          (error 'write
+                 "cannot marshal value that is embedded in compiled code: ~V"
+                 p)])])))
 
 (define (compiled-path->path e)
   (cond
+    [(box? e) (to-fasl (box (unbox e))
+                       (or (current-load-relative-directory)
+                           (current-directory)))]
     [(bytes? e) (bytes->path e)]
     [(string? e) e] ; was `path-for-srcloc` on write
     [else (relative-path-elements->path e)]))
+
+(define (force-unfasl tf)
+  (define vb (to-fasl-vb tf))
+  (define v (unbox vb))
+  (cond
+    [(bytes? v)
+     (define v2 (parameterize ([current-load-relative-directory (to-fasl-wrt tf)])
+                  (fasl->s-exp v #:datum-intern? #t)))
+     (box-cas! vb v v2)
+     (set-to-fasl-wrt! tf #f)
+     (unbox vb)]
+    [else
+     ;; already forced (or never fasled)
+     v]))

racket/src/schemify/serialize.rkt

@@ -1,10 +1,10 @@
 #lang racket/base
 (require racket/extflonum
          racket/prefab
-         racket/fasl
          "match.rkt"
          "wrap.rkt"
          "path-for-srcloc.rkt"
+         "to-fasl.rkt"
          "quoted.rkt")
 
 (provide convert-for-serialize)
@@ -78,8 +78,7 @@
                `(,(convert rator) ,@(convert-body exps))]
               [`,_
                (cond
-                 [(and for-cify?
+                 [(and (not (symbol? v))
-                       (not (symbol? v))
                        (lift-quoted? v for-cify? datum-intern?))
                   (convert `(quote ,v))]
                  [else v])])))
@@ -136,8 +135,7 @@
       [`(,exps ...)
        (for/or ([exp (in-list exps)])
          (convert-any? exp))]
-      [`,_ (and for-cify?
+      [`,_ (and (not (symbol? v))
-                (not (symbol? v))
                 (lift-quoted? v for-cify? datum-intern?))])))
 
 ;; Construct an expression to be lifted
@@ -155,8 +153,10 @@
   (cond
     [(and (not for-cify?)
           (large-quoted? q))
-     (add-lifted `(fasl->s-exp/intern
+     ;; a `to-fasl` struct is recognized like
-                   ',(s-exp->fasl q)))]
+     ;; paths and `path-for-srcloc`:
+     (define id (add-lifted (to-fasl (box q) #f)))
+     `(force-unfasl ,id)]
     [else    
      (let make-construct ([q q])
        (define lifted-constants (if (or (string? q) (bytes? q))

racket/src/schemify/to-fasl.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+
+(provide (struct-out to-fasl))
+
+(struct to-fasl (vb   ; box containing byte string as marhsaled or other as unmarshaled
+                 wrt) ; directory for unmarshaling
+  #:mutable)