suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix up validator, decompiler, and zo-marshaler for flonum-argument annotations

Browse Source 
svn: r17341
This commit is contained in:
Matthew Flatt 2009-12-17 20:17:48 +00:00
parent 5af212e825
commit cab948d61f
6 changed files with 91 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/decompile.ss
View File

@ -151,7 +151,7 @@
(define (extract-id expr) (define (extract-id expr)
(match 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)] (extract-name name)]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
(extract-name name)] (extract-name name)]
@ -288,7 +288,7 @@
(match expr (match expr
[(struct indirect (val)) (decompile-lam val globs stack closed)] [(struct indirect (val)) (decompile-lam val globs stack closed)]
[(struct closure (lam gen-id)) (decompile-lam lam 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)] (let ([vars (for/list ([i (in-range num-params)]
[type (in-list arg-types)]) [type (in-list arg-types)])
(gensym (format "~a~a-" (gensym (format "~a~a-"

50
collects/compiler/zo-marshal.ss
View File

@ -21,6 +21,8 @@
#f) #f)
(begin (begin
(hash-set! encountered v #t) (hash-set! encountered v #t)
(when (closure? v)
(hash-set! shared v (add1 (hash-count shared))))
#t))))]) #t))))])
(traverse-prefix prefix visit) (traverse-prefix prefix visit)
(traverse-form form visit)) (traverse-form form visit))
@ -197,11 +199,11 @@
(define (traverse-lam expr visit) (define (traverse-lam expr visit)
(match expr (match expr
[(struct indirect (val)) (traverse-lam expr visit)] [(struct indirect (val)) (traverse-lam val visit)]
[(struct closure (lam gen-id)) [(struct closure (lam gen-id))
(when (visit expr) (when (visit expr)
(traverse-lam expr visit))] (traverse-lam lam visit))]
[(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))
(traverse-data name visit) (traverse-data name visit)
(traverse-expr body visit)])) (traverse-expr body visit)]))
@ -221,7 +223,7 @@
(define case-lambda-sequence-type-num 96) (define case-lambda-sequence-type-num 96)
(define begin0-sequence-type-num 97) (define begin0-sequence-type-num 97)
(define module-type-num 100) (define module-type-num 100)
(define prefix-type-num 103) (define prefix-type-num 102)
(define-syntax define-enum (define-syntax define-enum
(syntax-rules () (syntax-rules ()
@ -532,7 +534,7 @@
(cons undef-ok? (cons id rhs)) (cons undef-ok? (cons id rhs))
out)] out)]
[(struct localref (unbox? offset clear? other-clears? flonum?)) [(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))) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START)))
(out-byte (+ (if unbox? (out-byte (+ (if unbox?
CPT_SMALL_LOCAL_UNBOX_START CPT_SMALL_LOCAL_UNBOX_START
@ -541,7 +543,7 @@
out) out)
(begin (begin
(out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) (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) (out-number offset out)
(begin (begin
(out-number (- (add1 offset)) out) (out-number (- (add1 offset)) out)
@ -648,7 +650,7 @@
(define (out-lam expr out) (define (out-lam expr out)
(match expr (match expr
[(struct indirect (val)) (out-lam expr out)] [(struct indirect (val)) (out-lam val out)]
[(struct closure (lam gen-id)) [(struct closure (lam gen-id))
(out-shared (out-shared
expr expr
@ -657,21 +659,32 @@
(out-byte CPT_CLOSURE out) (out-byte CPT_CLOSURE out)
(out-number ((out-shared-index out) expr) out) (out-number ((out-shared-index out) expr) out)
(out-lam lam 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)] (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? [l (cons (make-svector (if any-refs?
(list->vector (list->vector
(append (append
(vector->list closure-map) (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)] (for ([t (in-list param-types)]
[i (in-naturals)]) [i (in-naturals)])
(when (eq? t 'ref) (when (eq? t 'ref) (set-bit! i 1))
(let ([pos (quotient (* 2 i) BITS_PER_MZSHORT)]) (when (eq? t 'flonum) (set-bit! i 2)))
(vector-set! v pos (for ([t (in-list closure-types)]
(bitwise-ior (vector-ref v pos) [i (in-naturals num-all-params)])
(arithmetic-shift 1 (modulo (* 2 i) BITS_PER_MZSHORT))))))) (when (eq? t 'flonum) (set-bit! i 2)))
(vector->list v)))) (vector->list v))))
closure-map)) closure-map))
l)] l)]
@ -685,7 +698,7 @@
(if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0) (if (memq 'preserves-marks flags) CLOS_PRESERVES_MARKS 0)
(if (memq 'is-method flags) CLOS_IS_METHOD 0) (if (memq 'is-method flags) CLOS_IS_METHOD 0)
(if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0))
((if rest? add1 values) num-params) num-all-params
max-let-depth max-let-depth
name name
l) l)
@ -796,7 +809,10 @@
(out-byte CPT_QUOTE out) (out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])
(write (if (quoted? expr) (quoted-v expr) expr) s) (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-struct quoted (v))
(define (protect-quote v) (define (protect-quote v)

34
collects/compiler/zo-parse.ss
View File

@ -37,7 +37,7 @@
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported (define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context)) 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 (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 (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)) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
(values (vector-length v) v rest) (values (vector-length v) v rest)
(values v (car rest) (cdr 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)) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
(for/list ([i (in-range num-params)]) 'val) 0
(for/list ([i (in-range num-params)]) (let ([byte (vector-ref closed-over
(let ([byte (vector-ref closed-over (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))])
(+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT))
(if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) 1
'ref 0)
(if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT)))
'flonum 2
'val))))))]) 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 (make-lam name
(append (append
(if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks))
@ -158,6 +169,7 @@
(let ([v2 (make-vector closure-size)]) (let ([v2 (make-vector closure-size)])
(vector-copy! v2 0 closed-over 0 closure-size) (vector-copy! v2 0 closed-over 0 closure-size)
v2)) v2))
closure-types
max-let-depth max-let-depth
body)))])) body)))]))

29
collects/scribblings/mzc/zo-parse.scrbl
View File

@ -287,9 +287,10 @@ only other things that can be expressions).}
@defstruct+[(lam expr) ([name (or/c symbol? vector?)] @defstruct+[(lam expr) ([name (or/c symbol? vector?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result))] [flags (listof (or/c 'preserves-marks 'is-method 'single-result))]
[num-params exact-nonnegative-integer?] [num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref))] [param-types (listof (or/c 'val 'ref 'flonum))]
[rest? boolean?] [rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)] [closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? indirect? any/c)])]{ [body (or/c expr? seq? indirect? any/c)])]{
@ -300,10 +301,14 @@ argument; the @scheme[rest?] field indicates whether extra arguments
are accepted and collected into a ``rest'' variable. The are accepted and collected into a ``rest'' variable. The
@scheme[param-types] list contains @scheme[num-params] symbols @scheme[param-types] list contains @scheme[num-params] symbols
indicating the type of each argumet, either @scheme['val] for a normal indicating the type of each argumet, either @scheme['val] for a normal
argument or @scheme['ref] for a boxed argument (representing a mutable argument, @scheme['ref] for a boxed argument (representing a mutable
local variable). The @scheme[closure-map] field is a vector of stack local variable), or @scheme['flonum] for a flonum argument. The
positions that are captured when evaluating the @scheme[lambda] form @scheme[closure-map] field is a vector of stack positions that are
to create a closure. captured when evaluating the @scheme[lambda] form to create a closure.
The @scheme[closure-types] field provides a corresponding list of
types, but no distinction is made between normal values and boxed
values; also, this information is redundant, since it can be inferred by
the bindings referenced though @scheme[closure-map].
When the function is called, the rest-argument list (if any) is pushed When the function is called, the rest-argument list (if any) is pushed
onto the stack, then the normal arguments in reverse order, then the onto the stack, then the normal arguments in reverse order, then the
@ -341,10 +346,14 @@ arguments given.}
@defstruct+[(let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] @defstruct+[(let-one expr) ([rhs (or/c expr? seq? indirect? any/c)]
[body (or/c expr? seq? indirect? any/c)])]{ [body (or/c expr? seq? indirect? any/c)]
[flonum? boolean?])]{
Pushes an uninitialized slot onto the stack, evaluates @scheme[rhs] Pushes an uninitialized slot onto the stack, evaluates @scheme[rhs]
and puts its value into the slot, and then runs @scheme[body]. and puts its value into the slot, and then runs @scheme[body]. If
@scheme[flonum?] is @scheme[#t], then @scheme[rhs] must produce a
flonum, and the slot must be accessed by @scheme[localref]s that
expect a flonum.
After @scheme[rhs] is evaluated, the stack is restored to its depth After @scheme[rhs] is evaluated, the stack is restored to its depth
from before evaluating @scheme[rhs]. Note that the new slot is created from before evaluating @scheme[rhs]. Note that the new slot is created
@ -403,7 +412,8 @@ the value so that it can be mutated later.}
@defstruct+[(localref expr) ([unbox? boolean?] @defstruct+[(localref expr) ([unbox? boolean?]
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
[clear? boolean?] [clear? boolean?]
[other-clears? boolean?])]{ [other-clears? boolean?]
[flonum? boolean?])]{
Represents a local-variable reference; it accesses the value in the Represents a local-variable reference; it accesses the value in the
stack slot after the first @scheme[pos] slots. If @scheme[unbox?] is stack slot after the first @scheme[pos] slots. If @scheme[unbox?] is
@ -412,7 +422,8 @@ from the box. If @scheme[clear?] is @scheme[#t], then after the value
is obtained, the stack slot is cleared (to avoid retaining a reference is obtained, the stack slot is cleared (to avoid retaining a reference
that can prevent reclamation of the value as garbage). If that can prevent reclamation of the value as garbage). If
@scheme[other-clears?] is @scheme[#t], then some later reference to @scheme[other-clears?] is @scheme[#t], then some later reference to
the same stack slot may clear after reading.} the same stack slot may clear after reading. If @scheme[flonum?] is
@scheme[#t], the slot holds to a flonum value.}
@defstruct+[(toplevel expr) ([depth exact-nonnegative-integer?] @defstruct+[(toplevel expr) ([depth exact-nonnegative-integer?]

12
src/mzscheme/src/eval.c
View File

@ -11155,6 +11155,18 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
vld = VALID_VAL; vld = VALID_VAL;
else if (vld == VALID_BOX_NOCLEAR) else if (vld == VALID_BOX_NOCLEAR)
vld = VALID_BOX; vld = VALID_BOX;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
int pos = data->num_params + i;
int bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1)));
if (map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) {
if (vld != VALID_FLONUM)
vld = VALID_NOT;
} else if (vld == VALID_FLONUM)
vld = VALID_NOT;
} else if (vld == VALID_FLONUM)
vld = VALID_NOT;
closure_stack[i + base] = vld; closure_stack[i + base] = vld;
} }

3
src/mzscheme/src/fun.c
View File

@ -1392,8 +1392,7 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
closure_map = new_closure_map; closure_map = new_closure_map;
expanded_already = 1; expanded_already = 1;
} }
boxmap_set(closure_map, data->num_params + offset, boxmap_set(closure_map, data->num_params + offset, 2, data->closure_size);
(flags & SCHEME_INFO_BOXED) ? 1 : 2, data->closure_size);
} }
} }
offset++; offset++;