From 37f07cb68b504ed1e80853c899ef710cbf60188d Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 19 Aug 2010 12:33:31 -0600 Subject: [PATCH] zo-marshal single out-anything function and zo-parse debugging --- collects/compiler/zo-marshal.rkt | 1117 ++++++++++++++---------------- collects/compiler/zo-parse.rkt | 397 ++++++----- 2 files changed, 738 insertions(+), 776 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index da13079be1..fa3be595e9 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,9 +8,7 @@ racket/local racket/list racket/dict - racket/function - racket/pretty - racket/path) + racket/function) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,8 +22,8 @@ (define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) - (define shared (make-hasheq)) - (define wrapped (make-hasheq)) + (define shared (make-hash)) + (define wrapped (make-hash)) (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) @@ -34,13 +32,15 @@ (list* max-let-depth prefix (protect-quote form))) ; Compute what objects are in ct multiple times (by equal?) - (local [(define encountered (make-hasheq)) + (local [(define encountered (make-hash)) (define (encountered? v) (hash-ref encountered v #f)) (define (encounter! v) (hash-set! encountered v #t)) (define (visit! v) (cond + [(not (shareable? v)) + #t] [(shared-obj-pos v) #f] [(encountered? v) @@ -86,8 +86,8 @@ ; Compute where we ended (define post-shared (file-position outp)) ; Write the entire ctop - (out-data ct - (make-out outp shared-obj-pos wrapped)) + (out-anything ct + (make-out outp shared-obj-pos wrapped)) (values offsets post-shared (file-position outp))) ; Compute where the symbol table ends @@ -277,18 +277,146 @@ (define-struct case-seq (name lams)) (define-struct (seq0 seq) ()) + +(define (encode-module-bindings module-bindings) + (define encode-nominal-path + (match-lambda + [(struct simple-nominal-path (value)) + value] + [(struct imported-nominal-path (value import-phase)) + (cons value import-phase)] + [(struct phased-nominal-path (value import-phase phase)) + (cons value (cons import-phase phase))])) + (define encoded-bindings (make-vector (* (length module-bindings) 2))) + (for ([i (in-naturals)] + [(k v) (in-dict module-bindings)]) + (vector-set! encoded-bindings (* i 2) k) + (vector-set! encoded-bindings (add1 (* i 2)) + (match v + [(struct simple-module-binding (path)) + path] + [(struct exported-module-binding (path export-name)) + (cons path export-name)] + [(struct nominal-module-binding (path nominal-path)) + (cons path (encode-nominal-path nominal-path))] + [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) + (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] + [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) + (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) + encoded-bindings) + +(define encode-all-from-module + (match-lambda + [(struct all-from-module (path phase src-phase #f #f)) + (list* path phase src-phase)] + [(struct all-from-module (path phase src-phase exns #f)) + (list* path phase exns src-phase)] + [(struct all-from-module (path phase src-phase exns (vector prefix))) + (list* path phase src-phase exns prefix)])) + +(define (encode-wraps wraps) + (for/list ([wrap (in-list wraps)]) + (match wrap + [(struct phase-shift (amt src dest)) + (box (vector amt src dest #f))] + [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) + (define encoded-kind (eq? kind 'marked)) + (define encoded-unmarshals (map encode-all-from-module unmarshals)) + (define encoded-renames (encode-module-bindings renames)) + (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) + (values encoded-renames mark-renames) + (values encoded-unmarshals (cons encoded-renames mark-renames)))) + (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) + (if plus-kern? + (cons #t mod-rename) + mod-rename)] + [(struct lexical-rename (bool1 bool2 alist)) + (define len (length alist)) + (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning + (vector-set! vec 0 bool1) + (vector-set! vec 1 bool2) + (for ([(k v) (in-dict alist)] + [i (in-naturals)]) + (vector-set! vec (+ 2 i) k) + (vector-set! vec (+ 2 i len) v)) + vec] + [(struct top-level-rename (flag)) + flag] + [(struct mark-barrier (value)) + value] + [(struct prune (syms)) + (box syms)] + [(struct wrap-mark (val)) + (list val)]))) + +(define (encode-mark-map mm) + mm + #;(for/fold ([l empty]) + ([(k v) (in-hash ht)]) + (list* k v l))) + +(define-struct protected-symref (val)) + +(define encode-certs + (match-lambda + [(struct certificate:nest (m1 m2)) + (list* (encode-mark-map m1) (encode-mark-map m2))] + [(struct certificate:ref (val m)) + (list* #f (make-protected-symref val) (encode-mark-map m))])) + +(define (encode-wrapped w) + (match w + [(struct wrapped (datum wraps certs)) + (let* ([enc-datum + (match datum + [(cons a b) + (let ([p (cons (encode-wrapped a) + (let bloop ([b b]) + (match b + ['() null] + [(cons b1 b2) + (cons (encode-wrapped b1) + (bloop b2))] + [else + (encode-wrapped b)])))] + ; XXX Cylic list error possible + [len (let loop ([datum datum][len 0]) + (cond + [(null? datum) #f] + [(pair? datum) (loop (cdr datum) (add1 len))] + [else len]))]) + ;; for improper lists, we need to include the length so the + ;; parser knows where the end of the improper list is + (if len + (cons len p) + p))] + [(box x) + (box (encode-wrapped x))] + [(? vector? v) + (vector-map encode-wrapped v)] + [(? prefab-struct-key) + (define l (vector->list (struct->vector datum))) + (apply + make-prefab-struct + (car l) + (map encode-wrapped (cdr l)))] + [_ datum])] + [p (cons enc-datum + (encode-wraps wraps))]) + (if certs + (vector p (encode-certs certs)) + p))])) + (define-struct out (s shared-index encoded-wraps)) (define (out-shared v out k) - (let ([v ((out-shared-index out) v)]) - (if v - (begin - (out-byte CPT_SYMREF out) - (out-number v out)) - (k)))) -(define (display-byte b) - (if (b . <= . #xf) - (printf "0~x" b) - (printf "~x" b))) + (if (shareable? v) + (let ([v ((out-shared-index out) v)]) + (if v + (begin + (out-byte CPT_SYMREF out) + (out-number v out)) + (k))) + (k))) (define (out-byte v out) (write-byte v (out-s out))) @@ -322,34 +450,375 @@ (begin (out-byte CPT_MARSHALLED out) (out-number type-num out))) - (out-data val out)) + (out-anything val out)) + +(define (or-pred? v . ps) + (ormap (lambda (?) (? v)) ps)) + +(define (shareable? v) + (not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?))) + +(define (maybe-same-as-fixnum? v) + (and (exact-integer? v) + (and (v . >= . -1073741824) (v . <= . 1073741823)))) (define (out-anything v out) - (cond - [(module-variable? v) - (out-toplevel v out)] - [(closure? v) - (out-expr v out)] - [else - (out-data v out)])) - -(define (out-prefix a-prefix out) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) - (out-marshaled - prefix-type-num - (cons num-lifts - (cons (list->vector toplevels) - (list->vector stxs))) - out)])) - -(define (out-free-id-info a-free-id-info out) - (match a-free-id-info - [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) - (out-marshaled - free-id-info-type-num - (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) - out)])) + (out-shared + v out + (λ () + (match v + [(? char?) + (out-byte CPT_CHAR out) + (out-number (char->integer v) out)] + [(? maybe-same-as-fixnum?) ;XXX not sure if it's okay to use fixnum? instead of exact range check + (if (and (v . >= . 0) + (v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) + (out-byte (+ CPT_SMALL_NUMBER_START v) out) + (begin + (out-byte CPT_INT out) + (out-number v out)))] + [(list) + (out-byte CPT_NULL out)] + [#t + (out-byte CPT_TRUE out)] + [#f + (out-byte CPT_FALSE out)] + [(? void?) + (out-byte CPT_VOID out)] + [(struct module-variable (modidx sym pos phase)) + (out-byte CPT_MODULE_VAR out) + (out-anything modidx out) + (out-anything sym out) + (unless (zero? phase) + (out-number -2 out)) + (out-number pos out)] + [(struct indirect (val)) (out-anything val out)] + [(struct closure (lam gen-id)) + (out-byte CPT_CLOSURE out) + (out-number ((out-shared-index out) v) out) + (out-anything lam out)] + [(struct prefix (num-lifts toplevels stxs)) + (out-marshaled + prefix-type-num + (cons num-lifts + (cons (list->vector toplevels) + (list->vector stxs))) + out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) + (out-marshaled + free-id-info-type-num + (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) + out)] + [(? mod?) + (out-module v out)] + [(struct def-values (ids rhs)) + (out-syntax DEFINE_VALUES_EXPD + (list->vector (cons (protect-quote rhs) ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_FOR_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct seq0 (forms)) + (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + [(struct seq (forms)) + (out-marshaled sequence-type-num (map protect-quote forms) out)] + [(struct splice (forms)) + (out-syntax SPLICE_EXPD (make-seq forms) out)] + [(struct req (reqs dummy)) + (error "cannot handle top-level `require', yet") + (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (cons + depth + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos)) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (out-byte CPT_REFERENCE out) + (out-number id out)] + [(struct assign (id rhs undef-ok?)) + (out-syntax SET_EXPD + (cons undef-ok? (cons id rhs)) + out)] + [(struct localref (unbox? offset clear? other-clears? flonum?)) + (if (and (not clear?) (not other-clears?) (not flonum?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears? flonum?)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (if clear? + #x1 + (if other-clears? + #x2 + (if flonum? + #x3 + 0))) + out)))))] + [(? lam?) + (out-lam v out)] + [(struct case-lam (name lams)) + (let ([seq (make-case-seq name lams)]) + ;; XXX: This seems like an optimization, which should probably happen somewhere else + ;; If all closures are empty, generate a case sequence directly + (if (andmap (lambda (lam) + (or (closure? lam) + (and (lam? lam) + (equal? (lam-closure-map lam) #())))) + lams) + (out-anything seq out) + (out-syntax CASE_LAMBDA_EXPD + seq + out)))] + [(struct case-seq (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body flonum? unused?)) + (out-byte (cond + [flonum? CPT_LET_ONE_FLONUM] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) + out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out)] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-syntax BOXENV_EXPD + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-anything (protect-quote test) out) + (out-anything (protect-quote then) out) + (out-anything (protect-quote else) out)] + [(struct application (rator rands)) + (let ([len (length rands)]) + (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number len out))) + (for-each (lambda (e) (out-anything (protect-quote e) out)) + (cons rator rands)))] + [(struct apply-values (proc args-expr)) + (out-syntax APPVALS_EXPD + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] + [(struct beg0 (exprs)) + (out-syntax BEGIN0_EXPD + (make-seq0 exprs) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct varref (expr)) + (out-syntax REF_EXPD + expr + out)] + [(protected-symref v) + (out-anything ((out-shared-index out) v) out)] + [(and (? symbol?) (not (? symbol-interned?))) + (out-as-bytes v + #:before-length (if (symbol-unreadable? v) 0 1) + (compose string->bytes/utf-8 symbol->string) + CPT_WEIRD_SYMBOL + #f + out)] + [(? symbol?) + (define bs (string->bytes/utf-8 (symbol->string v))) + (define len (bytes-length bs)) + (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) + (out-byte (+ CPT_SMALL_SYMBOL_START len) out) + (begin (out-byte CPT_SYMBOL out) + (out-number len out))) + (out-bytes bs out)] + [(? keyword?) + (out-as-bytes v + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + #f + out)] + [(? string?) + (out-as-bytes v + string->bytes/utf-8 + CPT_CHAR_STRING + (string-length v) + out)] + [(? bytes?) + (out-as-bytes v + values + CPT_BYTE_STRING + #f + out)] + [(? box?) + (out-byte CPT_BOX out) + (out-anything (unbox v) out)] + [(? pair?) + (define (list-length-before-cycle/improper-end l) + (let loop ([len 1] [l (cdr l)]) + (cond + [((out-shared-index out) l) + (values len #f)] + [(null? l) + (values len #t)] + [(pair? l) + (loop (add1 len) (cdr l))] + [else + (values len #f)]))) + (define-values (len proper?) (list-length-before-cycle/improper-end v)) + (define (print-contents-as-proper) + (for ([e (in-list v)]) + (out-anything e out))) + (define (print-contents-as-improper) + (let loop ([l v] [i len]) + (cond + [(zero? i) + (out-anything l out)] + [else + (out-anything (car l) out) + (loop (cdr l) (sub1 i))]))) + (if proper? + (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) + (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) + (print-contents-as-proper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-proper) + (out-anything null out))) + (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR + (begin (out-byte (+ CPT_SMALL_LIST_START len) out) + (print-contents-as-improper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-improper))))] + [(? vector?) + (out-byte CPT_VECTOR out) + (out-number (vector-length v) out) + (for ([v (in-vector v)]) + (out-anything v out))] + [(? hash?) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? v) 2] + [(hash-eq? v) 0] + [else 1]) + out) + (out-number (hash-count v) out) + (for ([(k v) (in-hash v)]) + (out-anything k out) + (out-anything v out))] + [(svector vec) + (let* ([len (vector-length vec)]) + (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) + (out-byte (+ CPT_SMALL_SVECTOR_START len) out) + (begin (out-byte CPT_SVECTOR out) + (out-number len out))) + (for ([n (in-range (sub1 len) -1 -1)]) + (out-number (vector-ref vec n) out)))] + [(? module-path-index?) + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split v)]) + (out-anything name out) + (out-anything base out))] + [(module-decl content) + (out-marshaled module-type-num + content + out)] + [(stx encoded) + (out-byte CPT_STX out) + (out-anything encoded out)] + [(? wrapped?) + (out-anything (lookup-encoded-wrapped v out) out)] + [(? prefab-struct-key) + (define pre-v (struct->vector v)) + (vector-set! pre-v 0 (prefab-struct-key v)) + (out-byte CPT_PREFAB out) + (out-anything pre-v out)] + [else + (out-byte CPT_QUOTE out) + (if (quoted? v) + (out-anything (quoted-v v) out) + (let ([s (open-output-bytes)]) + (parameterize ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write expr s)) + (out-byte CPT_ESCAPE out) + (let ([bstr (get-output-bytes s)]) + (out-number (bytes-length bstr) out) + (out-bytes bstr out))))])))) (define-struct module-decl (content)) @@ -444,361 +913,15 @@ (make-module-decl l)) out)])) -(define (out-toplevel tl out) - (match tl - [#f (out-data tl out)] - [(? symbol?) (out-data tl out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(struct module-variable (modidx sym pos phase)) - (out-shared - tl - out - (lambda () - (out-byte CPT_MODULE_VAR out) - (out-data modidx out) - (out-data sym out) - (unless (zero? phase) - (out-number -2 out)) - (out-number pos out)))])) - -(define (encode-module-bindings module-bindings) - (define encode-nominal-path - (match-lambda - [(struct simple-nominal-path (value)) - value] - [(struct imported-nominal-path (value import-phase)) - (cons value import-phase)] - [(struct phased-nominal-path (value import-phase phase)) - (cons value (cons import-phase phase))])) - (define encoded-bindings (make-vector (* (length module-bindings) 2))) - (for ([i (in-naturals)] - [(k v) (in-dict module-bindings)]) - (vector-set! encoded-bindings (* i 2) k) - (vector-set! encoded-bindings (add1 (* i 2)) - (match v - [(struct simple-module-binding (path)) - path] - [(struct exported-module-binding (path export-name)) - (cons path export-name)] - [(struct nominal-module-binding (path nominal-path)) - (cons path (encode-nominal-path nominal-path))] - [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) - (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] - [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) - (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) - encoded-bindings) - -(define encode-all-from-module - (match-lambda - [(struct all-from-module (path phase src-phase #f #f)) - (list* path phase src-phase)] - [(struct all-from-module (path phase src-phase exns #f)) - (list* path phase exns src-phase)] - [(struct all-from-module (path phase src-phase exns (vector prefix))) - (list* path phase src-phase exns prefix)])) - -(define (encode-wraps wraps) - (for/list ([wrap (in-list wraps)]) - (match wrap - [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f))] - [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) - (define encoded-kind (eq? kind 'marked)) - (define encoded-unmarshals (map encode-all-from-module unmarshals)) - (define encoded-renames (encode-module-bindings renames)) - (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) - (values encoded-renames mark-renames) - (values encoded-unmarshals (cons encoded-renames mark-renames)))) - (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) - (if plus-kern? - (cons #t mod-rename) - mod-rename)] - [(struct lexical-rename (bool1 bool2 alist)) - (define len (length alist)) - (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning - (vector-set! vec 0 bool1) - (vector-set! vec 1 bool2) - (for ([(k v) (in-dict alist)] - [i (in-naturals)]) - (vector-set! vec (+ 2 i) k) - (vector-set! vec (+ 2 i len) v)) - vec] - [(struct top-level-rename (flag)) - flag] - [(struct mark-barrier (value)) - value] - [(struct prune (syms)) - (box syms)] - [(struct wrap-mark (val)) - (list val)]))) - -(define (encode-mark-map mm) - mm - #;(for/fold ([l empty]) - ([(k v) (in-hash ht)]) - (list* k v l))) - -(define-struct protected-symref (val)) - -(define encode-certs - (match-lambda - [(struct certificate:nest (m1 m2)) - (list* (encode-mark-map m1) (encode-mark-map m2))] - [(struct certificate:ref (val m)) - (list* #f (make-protected-symref val) (encode-mark-map m))])) - -(define (encode-wrapped w) - (match w - [(struct wrapped (datum wraps certs)) - (let* ([enc-datum - (match datum - [(cons a b) - (let ([p (cons (encode-wrapped a) - (let bloop ([b b]) - (match b - ['() null] - [(cons b1 b2) - (cons (encode-wrapped b1) - (bloop b2))] - [else - (encode-wrapped b)])))] - ; XXX Cylic list error possible - [len (let loop ([datum datum][len 0]) - (cond - [(null? datum) #f] - [(pair? datum) (loop (cdr datum) (add1 len))] - [else len]))]) - ;; for improper lists, we need to include the length so the - ;; parser knows where the end of the improper list is - (if len - (cons len p) - p))] - [(box x) - (box (encode-wrapped x))] - [(? vector? v) - (vector-map encode-wrapped v)] - [(? prefab-struct-key) - (define l (vector->list (struct->vector datum))) - (apply - make-prefab-struct - (car l) - (map encode-wrapped (cdr l)))] - [_ datum])] - [p (cons enc-datum - (encode-wraps wraps))]) - (if certs - (vector p (encode-certs certs)) - p))])) (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w (lambda () (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) -(define (out-wrapped w out) - (out-data (lookup-encoded-wrapped w out) out)) - -(define (out-stx s out) - (out-shared s out - (lambda () - (match s - [(struct stx (encoded)) - (out-byte CPT_STX out) - (out-wrapped encoded out)])))) - -(define (out-form form out) - (match form - [(? mod?) - (out-module form out)] - [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons (protect-quote rhs) ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq0 (forms)) - (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] - [(struct seq (forms)) - (out-marshaled sequence-type-num (map protect-quote forms) out)] - [(struct splice (forms)) - (out-syntax SPLICE_EXPD (make-seq forms) out)] - [(struct req (reqs dummy)) - (error "cannot handle top-level `require', yet") - (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] - [else - (out-expr form out)])) - -(define (out-expr expr out) - (match expr - [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (cons - depth - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) - pos)) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] - [(struct primval (id)) - (out-byte CPT_REFERENCE out) - (out-number id out)] - [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) - (if (and (not clear?) (not other-clears?) (not flonum?) - (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) - (out-byte (+ (if unbox? - CPT_SMALL_LOCAL_UNBOX_START - CPT_SMALL_LOCAL_START) - offset) - out) - (begin - (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears? flonum?)) - (out-number offset out) - (begin - (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) - out)))))] - [(? lam?) - (out-lam expr out)] - [(struct case-lam (name lams)) - (let ([seq (make-case-seq name lams)]) - ;; If all closures are empy, generate a case sequence directly - (if (andmap (lambda (lam) - (or (closure? lam) - (and (lam? lam) - (equal? (lam-closure-map lam) #())))) - lams) - (out-data seq out) - (out-syntax CASE_LAMBDA_EXPD - seq - out)))] - [(struct case-seq (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] - [(struct let-one (rhs body flonum? unused?)) - (out-byte (cond - [flonum? CPT_LET_ONE_FLONUM] - [unused? CPT_LET_ONE_UNUSED] - [else CPT_LET_ONE]) - out) - (out-expr (protect-quote rhs) out) - (out-expr (protect-quote body) out)] - [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] - [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] - [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] - [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] - [(struct branch (test then else)) - (out-byte CPT_BRANCH out) - (out-expr (protect-quote test) out) - (out-expr (protect-quote then) out) - (out-expr (protect-quote else) out)] - [(struct application (rator rands)) - (let ([len (length rands)]) - (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) - (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) - (begin - (out-byte CPT_APPLICATION out) - (out-number len out))) - (for-each (lambda (e) (out-expr (protect-quote e) out)) - (cons rator rands)))] - [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct seq (exprs)) - (out-form expr out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq0 exprs) - out)] - [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct closure (lam gen-id)) - (out-lam expr out)] - [(struct indirect (val)) - (out-expr val out)] - [(struct varref (expr)) - (out-syntax REF_EXPD - expr - out)] - [else (out-value expr out)])) (define (out-lam expr out) (match expr - [(struct indirect (val)) (out-lam val out)] - [(struct closure (lam gen-id)) - (out-shared - expr - out - (lambda () - (out-byte CPT_CLOSURE out) - (out-number ((out-shared-index out) expr) out) - (out-lam lam out)))] [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (let* ([l (protect-quote body)] [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) @@ -845,207 +968,13 @@ out))])) (define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) - (out-shared expr out (lambda () - (let ([s (->bytes expr)]) - (out-byte CPT out) - (when before-length - (out-number before-length out)) - (out-number (bytes-length s) out) - (when len2 (out-number len2 out)) - (out-bytes s out))))) - -(define (out-data expr out) - (cond - [(prefix? expr) (out-prefix expr out)] - [(global-bucket? expr) (out-toplevel expr out)] - [(module-variable? expr) (out-toplevel expr out)] - [(free-id-info? expr) (out-free-id-info expr out)] - [else (out-form expr out)])) - -(define (out-value expr out) - (cond - [(protected-symref? expr) - (let* ([val (protected-symref-val expr)] - [val-ref ((out-shared-index out) val)]) - (out-value val-ref out))] - [(and (symbol? expr) (not (symbol-interned? expr))) - (out-as-bytes expr - #:before-length (if (symbol-unreadable? expr) 0 1) - (compose string->bytes/utf-8 symbol->string) - CPT_WEIRD_SYMBOL - #f - out)] - [(symbol? expr) - (out-shared expr out - (lambda () - (define bs (string->bytes/utf-8 (symbol->string expr))) - (define len (bytes-length bs)) - (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) - (out-byte (+ CPT_SMALL_SYMBOL_START len) out) - (begin (out-byte CPT_SYMBOL out) - (out-number len out))) - (out-bytes bs out)))] - [(keyword? expr) - (out-as-bytes expr - (compose string->bytes/utf-8 keyword->string) - CPT_KEYWORD - #f - out)] - [(string? expr) - (out-as-bytes expr - string->bytes/utf-8 - CPT_CHAR_STRING - (string-length expr) - out)] - [(bytes? expr) - (out-as-bytes expr - values - CPT_BYTE_STRING - #f - out)] - #; - [(path? expr) - (out-as-bytes expr - path->bytes - CPT_PATH - #f - out)] - [(char? expr) - (out-byte CPT_CHAR out) - (out-number (char->integer expr) out)] - [(and (exact-integer? expr) - (and (expr . >= . -1073741824) (expr . <= . 1073741823))) - (if (and (expr . >= . 0) - (expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) - (out-byte (+ CPT_SMALL_NUMBER_START expr) out) - (begin - (out-byte CPT_INT out) - (out-number expr out)))] - [(null? expr) - (out-byte CPT_NULL out)] - [(eq? expr #t) - (out-byte CPT_TRUE out)] - [(eq? expr #f) - (out-byte CPT_FALSE out)] - [(void? expr) - (out-byte CPT_VOID out)] - [(box? expr) - (out-byte CPT_BOX out) - (out-data (unbox expr) out)] - [(pair? expr) - (local [(define seen? (make-hasheq)) ; XXX Maybe this should be global? - (define (list-length-before-cycle/improper-end l) - (if (hash-has-key? seen? l) - (begin (values 0 #f)) - (begin (hash-set! seen? l #t) - (cond - [(null? l) - (values 0 #t)] - [(pair? l) - (let-values ([(len proper?) - (list-length-before-cycle/improper-end (cdr l))]) - (values (add1 len) proper?))] - [else - (values 0 #f)])))) - (define-values (len proper?) (list-length-before-cycle/improper-end expr)) - (define (print-contents-as-proper) - (for ([e (in-list expr)]) - (out-data e out))) - (define (print-contents-as-improper) - (let loop ([l expr] [i len]) - (cond - [(zero? i) - (out-data l out)] - [else - (out-data (car l) out) - (loop (cdr l) (sub1 i))])))] - (if proper? - (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) - (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) - (print-contents-as-proper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-proper) - (out-data null out))) - (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) - ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR - (begin (out-byte (+ CPT_SMALL_LIST_START len) out) - (print-contents-as-improper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-improper)))))] - [(vector? expr) - (out-byte CPT_VECTOR out) - (out-number (vector-length expr) out) - (for ([v (in-vector expr)]) - (out-data v out))] - [(hash? expr) - (out-shared expr out - (lambda () - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))))] - [(svector? expr) - (let* ([vec (svector-vec expr)] - [len (vector-length vec)]) - (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) - (out-byte (+ CPT_SMALL_SVECTOR_START len) out) - (begin (out-byte CPT_SVECTOR out) - (out-number len out))) - (for ([n (in-range (sub1 len) -1 -1)]) - (out-number (vector-ref vec n) out)))] - [(module-path-index? expr) - (out-shared expr out - (lambda () - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split expr)]) - (out-data name out) - (out-data base out))))] - [(module-decl? expr) - (out-marshaled module-type-num - (module-decl-content expr) - out)] - [(stx? expr) - (out-stx expr out)] - [(wrapped? expr) - (out-wrapped expr out)] - [(prefab-struct-key expr) - => (lambda (key) - (define pre-v (struct->vector expr)) - (vector-set! pre-v 0 key) - (out-byte CPT_PREFAB out) - (out-data pre-v out))] - [else - (out-byte CPT_QUOTE out) - (if (quoted? expr) - (out-data (quoted-v expr) out) - (let ([s (open-output-bytes)]) - ;; print `expr' to a string, but print paths - ;; in a special way - (parameterize ([pretty-print-size-hook - (lambda (v mode port) - (and (path? v) - (let ([v (make-relative v)]) - (+ 2 (let ([p (open-output-bytes)]) - (write (path->bytes v) p) - (bytes-length (get-output-bytes p)))))))] - [pretty-print-print-hook - (lambda (v mode port) - (display "#^" port) - (write (path->bytes (make-relative v)) port))]) - (pretty-write expr s)) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr out))))])) - + (define s (->bytes expr)) + (out-byte CPT out) + (when before-length + (out-number before-length out)) + (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) + (out-bytes s out)) (define-struct quoted (v)) @@ -1057,11 +986,5 @@ (define-struct svector (vec)) -(define (make-relative v) - (let ([r (current-write-relative-directory)]) - (if r - (find-relative-path r v) - v))) - ;; ---------------------------------------- diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index b7889fe291..9d57363ec8 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1,9 +1,11 @@ #lang scheme/base -(require mzlib/etc +(require mzlib/etc + racket/function scheme/match scheme/list unstable/struct - compiler/zo-structs) + compiler/zo-structs + racket/dict) (provide zo-parse) (provide (all-from-out compiler/zo-structs)) @@ -30,6 +32,8 @@ ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms +(define debug-symrefs #f) + (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) (define SCHEME_TOPLEVEL_READY #x02) @@ -503,157 +507,172 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (make-memo) (make-weak-hash)) +(define (with-memo* mt arg thnk) + (hash-ref! mt arg thnk)) +(define-syntax-rule (with-memo mt arg body ...) + (with-memo* mt arg (λ () body ...))) + (define (decode-mark-map alist) - alist - #;(let loop ([alist alist] - [ht (make-immutable-hasheq empty)]) - (match alist - [(list) ht] - [(list* (? number? key) (? module-path-index? val) alist) - (loop alist (hash-set ht key val))]))) + alist) +(define marks-memo (make-memo)) (define (decode-marks cp ms) - (match ms - [#f #f] - [(list* #f (? number? symref) alist) - (make-certificate:ref - (vector-ref (cport-symtab cp) symref) - (decode-mark-map alist))] - [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (with-memo marks-memo ms + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (symtab-lookup cp symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]))) +(define stx-memo (make-memo)) +; XXX More memo use (define (decode-stx cp v) - (if (integer? v) - (unmarshal-stx-get/decode cp v decode-stx) - (let loop ([v v]) - (let-values ([(cert-marks v encoded-wraps) - (match v - [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] - [`(,datum . ,wraps) (values #f datum wraps)] - [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [marks (decode-marks cp cert-marks)] - [add-wrap (lambda (v) (make-wrapped v wraps marks))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let loop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) + (with-memo stx-memo v + (if (integer? v) + (unmarshal-stx-get/decode cp v decode-stx) + (let loop ([v v]) + (let-values ([(cert-marks v encoded-wraps) + (match v + [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] + [`(,datum . ,wraps) (values #f datum wraps)] + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) + (let* ([wraps (decode-wraps cp encoded-wraps)] + [marks (decode-marks cp cert-marks)] + [wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let loop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] + [else (loop v)]))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) (cond [(null? v) null] - [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] - [else (loop v)]))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) - (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])))))) + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)]))))))) +(define wrape-memo (make-memo)) +(define (decode-wrape cp a) + (define (aloop a) (decode-wrape cp a)) + (with-memo wrape-memo a + ; A wrap-elem is either + (cond + ; A reference + [(integer? a) + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] + ; A mark (not actually a number as the C says, but a (list ) + [(and (pair? a) (number? (car a))) + (make-wrap-mark (car a))] + + [(vector? a) + (make-lexical-rename (vector-ref a 0) (vector-ref a 1) + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] + [(pair? a) + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (curry decode-all-from-module cp) unmarshals) + (decode-renames renames) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] + [(boolean? a) + (make-top-level-rename a)] + [(symbol? a) + (make-mark-barrier a)] + [(box? a) + (match (unbox a) + [(list (? symbol?) ...) (make-prune (unbox a))] + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] + [else (error 'decode-wraps "bad wrap element: ~e" a)]))) + +(define all-from-module-memo (make-memo)) +(define (decode-all-from-module cp afm) + (define (phase? v) + (or (number? v) (not v))) + (with-memo all-from-module-memo afm + (match afm + [(list* path (? phase? phase) (? phase? src-phase) + (list exn ...) prefix) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn (vector prefix))] + [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn #f)] + [(list* path (? phase? phase) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase #f #f)]))) + +(define wraps-memo (make-memo)) (define (decode-wraps cp w) - ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) - (if (integer? w) - (unmarshal-stx-get/decode cp w decode-wraps) - (map (lambda (a) - (let aloop ([a a]) - ; A wrap-elem is either - (cond - ; A reference - [(integer? a) - (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] - ; A mark (not actually a number as the C says, but a (list ) - [(and (pair? a) (number? (car a))) - (make-wrap-mark (car a))] - - [(vector? a) - (make-lexical-rename (vector-ref a 0) (vector-ref a 1) - (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) - (let loop ([i 2]) - (if (= i top) - null - (cons (cons (vector-ref a i) - (vector-ref a (+ (- top 2) i))) - (loop (+ i 1)))))))] - [(pair? a) - (let-values ([(plus-kern? a) (if (eq? (car a) #t) - (values #t (cdr a)) - (values #f a))]) - (match a - [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) - (let-values ([(unmarshals renames mark-renames) - (if (vector? maybe-unmarshals) - (values null maybe-unmarshals renames) - (values maybe-unmarshals - (car renames) - (cdr renames)))]) - (make-module-rename phase - (if kind 'marked 'normal) - set-id - (map (local [(define (phase? v) - (or (number? v) (not v)))] - (match-lambda - [(list* path (? phase? phase) (? phase? src-phase) - (list exn ...) prefix) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase exn (vector prefix))] - [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase exn #f)] - [(list* path (? phase? phase) (? phase? src-phase)) - (make-all-from-module - (parse-module-path-index cp path) - phase src-phase #f #f)])) - unmarshals) - (decode-renames renames) - mark-renames - (and plus-kern? 'plus-kern)))] - [else (error "bad module rename: ~e" a)]))] - [(boolean? a) - (make-top-level-rename a)] - [(symbol? a) - (make-mark-barrier a)] - [(box? a) - (match (unbox a) - [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f) - (make-phase-shift amt - (parse-module-path-index cp src) - (parse-module-path-index cp dest))] - [else (error 'parse "bad phase shift: ~e" a)])] - [else (error 'decode-wraps "bad wrap element: ~e" a)]))) - w))) + (with-memo wraps-memo w + ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) + (if (integer? w) + (unmarshal-stx-get/decode cp w decode-wraps) + (map (curry decode-wrape cp) w)))) (define (in-vector* v n) (make-do-sequence @@ -665,40 +684,48 @@ (λ _ #t) (λ _ #t))))) -(define (decode-renames renames) - (define decode-nominal-path - (match-lambda +(define nominal-path-memo (make-memo)) +(define (decode-nominal-path np) + (with-memo nominal-path-memo np + (match np [(cons nominal-path (cons import-phase nominal-phase)) (make-phased-nominal-path nominal-path import-phase nominal-phase)] [(cons nominal-path import-phase) (make-imported-nominal-path nominal-path import-phase)] [nominal-path - (make-simple-nominal-path nominal-path)])) - - ; XXX Weird test copied from C code. Matthew? - (define (nom_mod_p p) - (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) - - (for/list ([(k v) (in-vector* renames 2)]) - (cons k - (match v - [(list-rest path phase export-name nominal-path nominal-export-name) - (make-phased-module-binding path - phase - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(list-rest path export-name nominal-path nominal-export-name) - (make-exported-nominal-module-binding path - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(cons module-path-index (? nom_mod_p nominal-path)) - (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] - [(cons module-path-index export-name) - (make-exported-module-binding module-path-index export-name)] - [module-path-index - (make-simple-module-binding module-path-index)])))) + (make-simple-nominal-path nominal-path)]))) + +; XXX Weird test copied from C code. Matthew? +(define (nom_mod_p p) + (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) + +(define rename-v-memo (make-memo)) +(define (decode-rename-v v) + (with-memo rename-v-memo v + (match v + [(list-rest path phase export-name nominal-path nominal-export-name) + (make-phased-module-binding path + phase + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(list-rest path export-name nominal-path nominal-export-name) + (make-exported-nominal-module-binding path + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(cons module-path-index (? nom_mod_p nominal-path)) + (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] + [(cons module-path-index export-name) + (make-exported-module-binding module-path-index export-name)] + [module-path-index + (make-simple-module-binding module-path-index)]))) + +(define renames-memo (make-memo)) +(define (decode-renames renames) + (with-memo renames-memo renames + (for/list ([(k v) (in-vector* renames 2)]) + (cons k (decode-rename-v v))))) (define (parse-module-path-index cp s) s) @@ -734,7 +761,6 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t] - ;; Use a readtable for special path support in escaped: [current-readtable (make-readtable #f @@ -910,10 +936,10 @@ (make-application (read-compact cp) (for/list ([i (in-range c)]) (read-compact cp))))] - [(closure) + [(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (placeholder-set! (vector-ref (cport-symtab cp) l) ind) + (symtab-write! cp l ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -941,15 +967,22 @@ (if decoded? v2 (let ([dv2 (decode-stx cp v2)]) - (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (symtab-write! cp pos dv2) (vector-set! (cport-decoded cp) pos #t) dv2))) +(define (symtab-write! cp i v) + (placeholder-set! (vector-ref (cport-symtab cp) i) v)) + +(define (symtab-lookup cp i) + (when (mark-parameter-first read-sym-mark) + (dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty)) + (vector-ref (cport-symtab cp) i)) + (require unstable/markparam) (define read-sym-mark (mark-parameter)) (define (read-sym cp i) - (define symtab (cport-symtab cp)) - (define ph (vector-ref symtab i)) + (define ph (symtab-lookup cp i)) ; We are reading this already, so return the placeholder (if (memq i (mark-parameter-all read-sym-mark)) ph @@ -1003,11 +1036,17 @@ (define symtab (build-vector symtabsize (λ (i) (make-placeholder nr)))) + (set! debug-symrefs (make-vector symtabsize empty)) + (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + (for ([i (in-naturals)] + [v (in-vector debug-symrefs)]) + (printf "~a: ~a~n" i v)) + #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v)))