From 2d1e7602c17f5b71f9a376463b48d3b742c49ce8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 17 Dec 2009 20:17:48 +0000 Subject: [PATCH] fix up validator, decompiler, and zo-marshaler for flonum-argument annotations svn: r17341 original commit: cab948d61f713399f5167875e9191ca754af4a0a --- collects/compiler/decompile.ss | 4 +-- collects/compiler/zo-marshal.ss | 50 ++++++++++++++++++++++----------- collects/compiler/zo-parse.ss | 34 ++++++++++++++-------- 3 files changed, 58 insertions(+), 30 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 250fc75867..5059b8dfa5 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -151,7 +151,7 @@ (define (extract-id expr) (match expr - [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) (extract-name name)] [(struct case-lam (name lams)) (extract-name name)] @@ -288,7 +288,7 @@ (match expr [(struct indirect (val)) (decompile-lam val globs stack closed)] [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] - [(struct lam (name flags num-params arg-types rest? closure-map max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index dce8346914..1d68f5f44c 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -21,6 +21,8 @@ #f) (begin (hash-set! encountered v #t) + (when (closure? v) + (hash-set! shared v (add1 (hash-count shared)))) #t))))]) (traverse-prefix prefix visit) (traverse-form form visit)) @@ -197,11 +199,11 @@ (define (traverse-lam expr visit) (match expr - [(struct indirect (val)) (traverse-lam expr visit)] + [(struct indirect (val)) (traverse-lam val visit)] [(struct closure (lam gen-id)) (when (visit expr) - (traverse-lam expr visit))] - [(struct lam (name flags num-params param-types rest? closure-map max-let-depth body)) + (traverse-lam lam visit))] + [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (traverse-data name visit) (traverse-expr body visit)])) @@ -221,7 +223,7 @@ (define case-lambda-sequence-type-num 96) (define begin0-sequence-type-num 97) (define module-type-num 100) -(define prefix-type-num 103) +(define prefix-type-num 102) (define-syntax define-enum (syntax-rules () @@ -532,7 +534,7 @@ (cons undef-ok? (cons id rhs)) out)] [(struct localref (unbox? offset clear? other-clears? flonum?)) - (if (and (not clear?) (not other-clears?) + (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 @@ -541,7 +543,7 @@ out) (begin (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears?)) + (if (not (or clear? other-clears? flonum?)) (out-number offset out) (begin (out-number (- (add1 offset)) out) @@ -648,7 +650,7 @@ (define (out-lam expr out) (match expr - [(struct indirect (val)) (out-lam expr out)] + [(struct indirect (val)) (out-lam val out)] [(struct closure (lam gen-id)) (out-shared expr @@ -657,21 +659,32 @@ (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 max-let-depth body)) + [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) (let* ([l (protect-quote body)] - [any-refs? (ormap (lambda (t) (eq? t 'ref)) param-types)] + [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) + (ormap (lambda (t) (memq t '(flonum))) closure-types))] + [num-all-params ((if rest? add1 values) num-params)] [l (cons (make-svector (if any-refs? (list->vector (append (vector->list closure-map) - (let ([v (make-vector (ceiling (/ (* 2 num-params) BITS_PER_MZSHORT)))]) + (let* ([v (make-vector (ceiling + (/ (* 2 (+ num-params (vector-length closure-map))) + BITS_PER_MZSHORT)))] + [set-bit! (lambda (i bit) + (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) + (vector-set! v pos + (bitwise-ior (vector-ref v pos) + (arithmetic-shift + bit + (modulo (* 2 i) BITS_PER_MZSHORT))))))]) (for ([t (in-list param-types)] [i (in-naturals)]) - (when (eq? t 'ref) - (let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) - (vector-set! v pos - (bitwise-ior (vector-ref v pos) - (arithmetic-shift 1 (modulo (* 2 i) BITS_PER_MZSHORT))))))) + (when (eq? t 'ref) (set-bit! i 1)) + (when (eq? t 'flonum) (set-bit! i 2))) + (for ([t (in-list closure-types)] + [i (in-naturals num-all-params)]) + (when (eq? t 'flonum) (set-bit! i 2))) (vector->list v)))) closure-map)) l)] @@ -685,7 +698,7 @@ (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) - ((if rest? add1 values) num-params) + num-all-params max-let-depth name l) @@ -796,7 +809,10 @@ (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) (write (if (quoted? expr) (quoted-v expr) expr) s) - (out-bytes (get-output-bytes s) out))])) + (out-byte CPT_ESCAPE out) + (let ([bstr (get-output-bytes s)]) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)))])) (define-struct quoted (v)) (define (protect-quote v) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index c995346f7b..6633050b26 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -37,7 +37,7 @@ (define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) -(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda' +(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) ; `lambda' (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) (define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam @@ -134,17 +134,28 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + [(check-bit) (lambda (i) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) - (for/list ([i (in-range num-params)]) 'val) - (for/list ([i (in-range num-params)]) - (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) - (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) - 'ref - (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) - 'flonum - 'val))))))]) + 0 + (let ([byte (vector-ref closed-over + (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) + (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) + 1 + 0) + (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) + 2 + 0)))))] + [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) + (for/list ([i (in-range num-params)]) + (case (check-bit i) + [(0) 'val] + [(1) 'ref] + [(2) 'flonum])))] + [(closure-types) (for/list ([i (in-range closure-size)] + [j (in-naturals num-params)]) + (case (check-bit j) + [(0) 'val/ref] + [(2) 'flonum]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) @@ -158,6 +169,7 @@ (let ([v2 (make-vector closure-size)]) (vector-copy! v2 0 closed-over 0 closure-size) v2)) + closure-types max-let-depth body)))]))