fix up validator, decompiler, and zo-marshaler for flonum-argument annotations
svn: r17341
original commit: cab948d61f
This commit is contained in:
Matthew Flatt
parent
ab1cebd148
commit
2d1e7602c1
|
|
@ -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-"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user