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)
(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-"

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

@ -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)

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
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)))]))

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?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result))]
[num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref))]
[param-types (listof (or/c 'val 'ref 'flonum))]
[rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum))]
[max-let-depth exact-nonnegative-integer?]
[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
@scheme[param-types] list contains @scheme[num-params] symbols
indicating the type of each argumet, either @scheme['val] for a normal
argument or @scheme['ref] for a boxed argument (representing a mutable
local variable). The @scheme[closure-map] field is a vector of stack
positions that are captured when evaluating the @scheme[lambda] form
to create a closure.
argument, @scheme['ref] for a boxed argument (representing a mutable
local variable), or @scheme['flonum] for a flonum argument. The
@scheme[closure-map] field is a vector of stack positions that are
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
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)]
[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]
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
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?]
[pos exact-nonnegative-integer?]
[clear? boolean?]
[other-clears? boolean?])]{
[other-clears? boolean?]
[flonum? boolean?])]{
Represents a local-variable reference; it accesses the value in the
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
that can prevent reclamation of the value as garbage). If
@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?]

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;
else if (vld == VALID_BOX_NOCLEAR)
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;
}

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;
expanded_already = 1;
}
boxmap_set(closure_map, data->num_params + offset,
(flags & SCHEME_INFO_BOXED) ? 1 : 2, data->closure_size);
boxmap_set(closure_map, data->num_params + offset, 2, data->closure_size);
}
}
offset++;