diff --git a/compiler-lib/compiler/decompile.rkt b/compiler-lib/compiler/decompile.rkt index 3c80c7a2f0..3d25c16e2b 100644 --- a/compiler-lib/compiler/decompile.rkt +++ b/compiler-lib/compiler/decompile.rkt @@ -184,8 +184,9 @@ (length toplevels) (length stxs) num-lifts) - (cons + (list* `(quote inspector ,src-insp-desc) + ;; `(quote tls ,toplevels) (map (lambda (stx id) `(define ,id ,(if stx `(#%decode-syntax @@ -487,6 +488,12 @@ [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] + [(struct with-immed-mark (key-expr val-expr body-expr)) + (let ([id (gensym 'cmval)]) + `(#%call-with-immediate-continuation-mark + ,(decompile-expr key-expr globs stack closed) + (lambda (,id) ,(decompile-expr body-expr globs (cons id stack) closed)) + ,(decompile-expr val-expr globs stack closed)))] [(struct seq (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) (decompile-expr expr globs stack closed)))] @@ -540,7 +547,7 @@ ,@(if (not tl-map) '() (list - (for/list ([pos (in-set tl-map)]) + (for/list ([pos (in-list (sort (set->list tl-map) <))]) (define tl-pos (cond [(or (pos . < . (glob-desc-num-tls globs)) diff --git a/zo-lib/compiler/zo-marshal.rkt b/zo-lib/compiler/zo-marshal.rkt index 59db7ca70a..2a90ca01fd 100644 --- a/zo-lib/compiler/zo-marshal.rkt +++ b/zo-lib/compiler/zo-marshal.rkt @@ -20,7 +20,7 @@ (struct not-ready ()) -(struct encoded-scope ([content #:mutable]) #:prefab) +(struct encoded-scope (relative-id [content #:mutable]) #:prefab) (define (zo-marshal top) (define bs (open-output-bytes)) @@ -291,11 +291,12 @@ (define require-form-type-num 22) (define varref-form-type-num 23) (define apply-values-type-num 24) -(define case-lambda-sequence-type-num 25) -(define module-type-num 26) -(define inline-variants-type-num 27) -(define variable-type-num 35) -(define prefix-type-num 120) +(define with-immed-mark-type-num 25) +(define case-lambda-sequence-type-num 26) +(define module-type-num 27) +(define inline-variants-type-num 28) +(define variable-type-num 36) +(define prefix-type-num 121) (define-syntax define-enum (syntax-rules () @@ -753,6 +754,13 @@ (cons (protect-quote proc) (protect-quote args-expr)) out)] + [(struct with-immed-mark (key val body)) + (out-marshaled with-immed-mark-type-num + (vector + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] [(struct with-cont-mark (key val body)) (out-marshaled wcm-type-num (list* @@ -881,12 +889,13 @@ [(stx content) (out-byte CPT_STX out) (out-anything content out)] - [(encoded-scope content) + [(encoded-scope relative-id content) (out-byte CPT_SCOPE out) ;; The `out-shared` wrapper already called `((out-shared-index out) v)` ;; once, so `pos` will defintely be a number: (let ([pos ((out-shared-index out) v)]) (out-number pos out)) + (out-number relative-id out) (out-anything (share-everywhere content out) out)] [(? stx-obj?) (out-anything (share-everywhere (lookup-encoded-stx-obj v out) out) out)] @@ -1229,7 +1238,7 @@ s (hash-ref ht s (lambda () - (define es (encoded-scope #f)) + (define es (encoded-scope (scope-name s) #f)) (hash-set! ht s es) (define kind (case (scope-kind s) diff --git a/zo-lib/compiler/zo-parse.rkt b/zo-lib/compiler/zo-parse.rkt index 9c411c323f..0d7b9ac55b 100644 --- a/zo-lib/compiler/zo-parse.rkt +++ b/zo-lib/compiler/zo-parse.rkt @@ -192,6 +192,8 @@ (make-varref (car v) (cdr v))) (define (read-apply-values v) (make-apply-values (car v) (cdr v))) +(define (read-with-immed-mark v) + (make-with-immed-mark (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) (define (read-splice v) (make-splice v)) @@ -372,12 +374,13 @@ [(22) 'require-form-type] [(23) 'varref-form-type] [(24) 'apply-values-type] - [(25) 'case-lambda-sequence-type] - [(26) 'module-type] - [(27) 'inline-variant-type] - [(35) 'variable-type] - [(36) 'module-variable-type] - [(120) 'resolve-prefix-type] + [(25) 'with-immed-mark-type] + [(26) 'case-lambda-sequence-type] + [(27) 'module-type] + [(28) 'inline-variant-type] + [(36) 'variable-type] + [(37) 'module-variable-type] + [(121) 'resolve-prefix-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -407,6 +410,7 @@ (cons 'require-form-type read-require) (cons 'varref-form-type read-#%variable-ref) (cons 'apply-values-type read-apply-values) + (cons 'with-immed-mark-type read-with-immed-mark) (cons 'splice-sequence-type read-splice)))) (define (get-reader type) @@ -592,7 +596,7 @@ (with-memo* mt arg (λ () body ...))) ;; placeholder for a `scope` decoded in a second pass: -(struct encoded-scope (content) #:prefab) +(struct encoded-scope (relative-id content) #:prefab) (define (decode-wrapped cp v) (let loop ([v v]) @@ -942,10 +946,13 @@ [(small-svector) (read-compact-svector cp (- ch cpt-start))] [(scope) - (let ([pos (read-compact-number cp)]) + (let ([pos (read-compact-number cp)] + [relative-id (read-compact-number cp)]) (if (zero? pos) - (encoded-scope (read-compact cp)) - (read-cyclic cp pos 'scope encoded-scope)))] + (encoded-scope relative-id (read-compact cp)) + (read-cyclic cp pos 'scope (lambda (v) + (encoded-scope relative-id + v)))))] [(root-scope) root-scope] [(shared) @@ -1254,7 +1261,7 @@ [(cons (? number?) _) (car v)] [else (error 'decode-wrap "bad scope")])) - (define sc (scope (hash-count ht) + (define sc (scope (encoded-scope-relative-id s) (case kind [(0 1) 'module] [(2) 'macro] diff --git a/zo-lib/compiler/zo-structs.rkt b/zo-lib/compiler/zo-structs.rkt index 68af6f58e4..5b83c6047a 100644 --- a/zo-lib/compiler/zo-structs.rkt +++ b/zo-lib/compiler/zo-structs.rkt @@ -170,6 +170,9 @@ (define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] + [def-val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' @@ -186,7 +189,7 @@ (define-form-struct wrap ([shifts (listof module-shift?)] [simple-scopes (listof scope?)] - [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])) + [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) (define-form-struct module-shift ([from (or/c #f module-path-index?)] [to (or/c #f module-path-index?)]