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

bytecode compiler: generalize local-type tracking for unboxing

Browse Source 
Track fixnum results in the same way as flonum results to enable
unboxing, if that turns out to be useful. The intent of the change,
though, is to support other types in the future, such as "extnums".

The output `raco decompile' no longer includes `#%in', `#%flonum',
etc., annotations, which are mostly obvious and difficult to
keep in sync with the implementation. A local-binding name now
reflects a known type, however.

The change includes a bug repair for he bytecode compiler that
is independent of the generalization (i.e., the new test case
triggered the old problem using flonums).
This commit is contained in:
Matthew Flatt 2012-11-14 10:03:07 -07:00
parent 447db085dc
commit bdf1c3e165
28 changed files with 584 additions and 490 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/compiler/decompile.rkt
View File

@ -330,16 +330,14 @@
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack closed) `(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack closed))] ,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear? other-clears? flonum?)) [(struct localref (unbox? offset clear? other-clears? type))
(let ([id (list-ref/protect stack offset 'localref)]) (let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox? (let ([e (if unbox?
`(#%unbox ,id) `(#%unbox ,id)
id)]) id)])
(if clear? (if clear?
`(#%sfs-clear ,e) `(#%sfs-clear ,e)
(if flonum? e)))]
`(#%from-flonum ,e)
e))))]
[(? lam?) [(? lam?)
`(lambda . ,(decompile-lam expr globs stack closed))] `(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams)) [(struct case-lam (name lams))
@ -347,13 +345,10 @@
,@(map (lambda (lam) ,@(map (lambda (lam)
(decompile-lam lam globs stack closed)) (decompile-lam lam globs stack closed))
lams))] lams))]
[(struct let-one (rhs body flonum? unused?)) [(struct let-one (rhs body type unused?))
(let ([id (or (extract-id rhs) (let ([id (or (extract-id rhs)
(gensym (if unused? 'unused 'local)))]) (gensym (or type (if unused? 'unused 'local))))])
`(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
(if flonum?
(list '#%as-flonum v)
v))])
,(decompile-expr body globs (cons id stack) closed)))] ,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body)) [(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)]) (let ([ids (make-vector count #f)])
@ -428,7 +423,10 @@
(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-"
(case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) (case type
[(ref) "argbox"]
[(val) "arg"]
[else (format "arg~a" type)])
i)))] i)))]
[rest-vars (if rest? (list (gensym 'rest)) null)] [rest-vars (if rest? (list (gensym 'rest)) null)]
[captures (map (lambda (v) [captures (map (lambda (v)
@ -444,8 +442,8 @@
,@(if (null? captures) ,@(if (null? captures)
null null
`('(captures: ,@(map (lambda (c t) `('(captures: ,@(map (lambda (c t)
(if (eq? t 'flonum) (if t
`(flonum ,c) `(,t ,c)
c)) c))
captures captures
closure-types) closure-types)
@ -465,70 +463,10 @@
closed)))])) closed)))]))
(define (annotate-inline a) (define (annotate-inline a)
(if (and (symbol? (car a)) a)
(case (length a)
[(2) (memq (car a) '(not null? pair? mpair? symbol?
syntax? char? boolean?
number? real? exact-integer?
fixnum? inexact-real?
procedure? vector? box? string? bytes? eof-object?
zero? negative? exact-nonnegative-integer?
exact-positive-integer?
car cdr caar cadr cdar cddr
mcar mcdr unbox vector-length syntax-e
add1 sub1 - abs bitwise-not
list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=?
+ - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons set-box!
list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!
list list* vector vector-immutable
+ - * / min max bitwise-and bitwise-ior bitwise-xor))]
[else (memq (car a) '(list list* vector vector-immutable
+ - * / min max bitwise-and bitwise-ior bitwise-xor))]))
(cons '#%in a)
a))
(define (annotate-unboxed args a) (define (annotate-unboxed args a)
(define (unboxable? e s) a)
(cond
[(localref? e) #t]
[(toplevel? e) #t]
[(eq? '#%flonum (car s)) #t]
[(not (expr? e)) #t]
[else #f]))
(if (and (symbol? (car a))
(case (length a)
[(2) (memq (car a) '(flabs flsqrt ->fl
unsafe-flabs
unsafe-flsqrt
unsafe-fx->fl
flsin flcos fltan
flasin flacos flatan
flexp fllog
flfloor flceiling flround fltruncate
flmin flmax
unsafe-flmin unsafe-flmax))]
[(3) (memq (car a) '(fl+ fl- fl* fl/
fl< fl> fl<= fl>= fl=
flvector-ref
unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/
unsafe-fl< unsafe-fl>
unsafe-fl=
unsafe-fl<= unsafe-fl>=
unsafe-flvector-ref
unsafe-f64vector-ref))]
[(4) (memq (car a) '(flvector-set!
unsafe-flvector-set!
unsafe-f64vector-set!))]
[else #f])
(andmap unboxable? args (cdr a)))
(cons '#%flonum a)
a))
;; ---------------------------------------- ;; ----------------------------------------

17
collects/compiler/zo-marshal.rkt
View File

@ -725,7 +725,7 @@
(out-marshaled set-bang-type-num (out-marshaled set-bang-type-num
(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? type))
(if (and (not clear?) (not other-clears?) (not flonum?) (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?
@ -735,17 +735,16 @@
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? flonum?)) (if (not (or clear? other-clears? type))
(out-number offset out) (out-number offset out)
(begin (begin
(out-number (- (add1 offset)) out) (out-number (- (add1 offset)) out)
(out-number (if clear? (out-number (cond
#x1 [clear? 1]
(if other-clears? [other-clears? 2]
#x2 [else (+ 2 (case type
(if flonum? [(flonum) 1]
#x3 [(fixnum) 2]))])
0)))
out)))))] out)))))]
[(? lam?) [(? lam?)
(out-lam v out)] (out-lam v out)]

55
collects/compiler/zo-parse.rkt
View File

@ -88,6 +88,7 @@
(define CLOS_IS_METHOD 16) (define CLOS_IS_METHOD 16)
(define CLOS_SINGLE_RESULT 32) (define CLOS_SINGLE_RESULT 32)
(define BITS_PER_MZSHORT 32) (define BITS_PER_MZSHORT 32)
(define BITS_PER_ARG 4)
(match v (match v
[`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest)
(let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
@ -95,31 +96,32 @@
(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)))]
[(check-bit) (lambda (i) [(get-flags) (lambda (i)
(if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
0 0
(let ([byte (vector-ref closed-over (let ([byte (vector-ref closed-over
(+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))])
(+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT)))
1 (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))]
0) [(num->type) (lambda (n)
(if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) (case n
2 [(2) 'flonum]
0)))))] [(3) 'fixnum]
[else (error "invaid type flag")]))]
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
(for/list ([i (in-range num-params)]) (for/list ([i (in-range num-params)])
(case (check-bit i) (define v (get-flags i))
(case v
[(0) 'val] [(0) 'val]
[(1) 'ref] [(1) 'ref]
[(2) 'flonum] [else (num->type v)])))]
[else (error "both 'ref and 'flonum argument?")])))]
[(closure-types) (for/list ([i (in-range closure-size)] [(closure-types) (for/list ([i (in-range closure-size)]
[j (in-naturals num-params)]) [j (in-naturals num-params)])
(case (check-bit j) (define v (get-flags j))
(case v
[(0) 'val/ref] [(0) 'val/ref]
[(1) (error "invalid 'ref closure variable")] [(1) (error "invalid 'ref closure variable")]
[(2) 'flonum] [else (num->type v)]))])
[else (error "both 'ref and 'flonum closure var?")]))])
(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))
@ -467,7 +469,7 @@
[16 vector] [16 vector]
[17 hash-table] [17 hash-table]
[18 stx] [18 stx]
[19 let-one-flonum] [19 let-one-typed]
[20 marshalled] [20 marshalled]
[21 quote] [21 quote]
[22 reference] [22 reference]
@ -550,14 +552,21 @@
[reader (get-reader type)]) [reader (get-reader type)])
(reader l))) (reader l)))
(define SCHEME_LOCAL_TYPE_FLONUM 1)
(define SCHEME_LOCAL_TYPE_FIXNUM 2)
(define (make-local unbox? pos flags) (define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ #x01) (define SCHEME_LOCAL_CLEAR_ON_READ 1)
(define SCHEME_LOCAL_OTHER_CLEARS #x02) (define SCHEME_LOCAL_OTHER_CLEARS 2)
(define SCHEME_LOCAL_FLONUM #x03) (define SCHEME_LOCAL_TYPE_OFFSET 2)
(make-localref unbox? pos (make-localref unbox? pos
(= flags SCHEME_LOCAL_CLEAR_ON_READ) (= flags SCHEME_LOCAL_CLEAR_ON_READ)
(= flags SCHEME_LOCAL_OTHER_CLEARS) (= flags SCHEME_LOCAL_OTHER_CLEARS)
(= flags SCHEME_LOCAL_FLONUM))) (let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)])
(cond
[(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum]
[(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum]
[else #f]))))
(define (a . << . b) (define (a . << . b)
(arithmetic-shift a b)) (arithmetic-shift a b))
@ -841,9 +850,13 @@
(if ppr null (read-compact cp))) (if ppr null (read-compact cp)))
(read-compact-list l ppr cp)) (read-compact-list l ppr cp))
(loop l ppr)))] (loop l ppr)))]
[(let-one let-one-flonum let-one-unused) [(let-one let-one-typed let-one-unused)
(make-let-one (read-compact cp) (read-compact cp) (make-let-one (read-compact cp) (read-compact cp)
(eq? cpt-tag 'let-one-flonum) (and (eq? cpt-tag 'let-one-typed)
(case (read-compact-number cp)
[(1) 'flonum]
[(2) 'fixnum]
[else #f]))
(eq? cpt-tag 'let-one-unused))] (eq? cpt-tag 'let-one-unused))]
[(branch) [(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))] (make-branch (read-compact cp) (read-compact cp) (read-compact cp))]

15
collects/compiler/zo-structs.rkt
View File

@ -146,17 +146,20 @@
[flags (listof (or/c 'preserves-marks 'is-method 'single-result [flags (listof (or/c 'preserves-marks 'is-method 'single-result
'only-rest-arg-not-used 'sfs-clear-rest-args))] 'only-rest-arg-not-used 'sfs-clear-rest-args))]
[num-params exact-nonnegative-integer?] [num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref 'flonum))] [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))]
[rest? boolean?] [rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)] [closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum))] [closure-types (listof (or/c 'val/ref 'flonum 'fixnum))]
[toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? any/c)])) ; `lambda' [body (or/c expr? seq? any/c)])) ; `lambda'
(define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over) (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) (define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))]))
(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack (define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] ; pushes one value onto stack
[body (or/c expr? seq? any/c)]
[type (or/c #f 'flonum 'fixnum)]
[unused? boolean?]))
(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots
(define-form-struct (install-value expr) ([count exact-nonnegative-integer?] (define-form-struct (install-value expr) ([count exact-nonnegative-integer?]
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
@ -166,7 +169,11 @@
(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots (define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element (define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element
(define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack (define-form-struct (localref expr) ([unbox? boolean?]
[pos exact-nonnegative-integer?]
[clear? boolean?]
[other-clears? boolean?]
[type (or/c #f 'flonum 'fixnum)])) ; access local via stack
(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack)

17
collects/scribblings/raco/decompile.scrbl
View File

@ -110,18 +110,11 @@ Many forms in the decompiled code, such as @racket[module],
@racketmodname[racket/flonum] and @racketmodname[racket/unsafe/ops] @racketmodname[racket/flonum] and @racketmodname[racket/unsafe/ops]
are always inlined, so @racketidfont{#%in} is not shown for them.} are always inlined, so @racketidfont{#%in} is not shown for them.}
@item{Some applications of flonum operations from @racketmodname[racket/flonum] @item{Function arguments and local bindings that are known to have a
and @racketmodname[racket/unsafe/ops] are annotated with particular type have names that embed the known type. For example, an
@racketidfont{#%flonum}, indicating a place where the JIT compiler argument might have a name that starts @racketidfont{argflonum} or a
might avoid allocation for intermediate flonum results. A single local binding might have a name that starts @racketidfont{flonum} to
@racketidfont{#%flonum} by itself is not useful, but a indicate a flonum value.}
@racketidfont{#%flonum} operation that consumes a
@racketidfont{#%flonum} or @racketidfont{#%from-flonum} argument
indicates a potential performance improvement. A
@racketidfont{#%from-flonum} wraps an identifier that is bound by
@racket[let] with a @racketidfont{#%as-flonum} around its value,
which indicates a local binding that can avoid boxing (when used as
an argument to an operation that can work with unboxed values).}
@item{A @racketidfont{#%decode-syntax} form corresponds to a syntax @item{A @racketidfont{#%decode-syntax} form corresponds to a syntax
object.} object.}

16
collects/scribblings/raco/zo-struct.scrbl
View File

@ -270,7 +270,7 @@ binding, constructor, etc.}
[flags (listof (or/c 'preserves-marks 'is-method 'single-result [flags (listof (or/c 'preserves-marks 'is-method 'single-result
'only-rest-arg-not-used 'sfs-clear-rest-args))] 'only-rest-arg-not-used 'sfs-clear-rest-args))]
[num-params exact-nonnegative-integer?] [num-params exact-nonnegative-integer?]
[param-types (listof (or/c 'val 'ref 'flonum))] [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))]
[rest? boolean?] [rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)] [closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum))] [closure-types (listof (or/c 'val/ref 'flonum))]
@ -339,13 +339,13 @@ binding, constructor, etc.}
@defstruct+[(let-one expr) @defstruct+[(let-one expr)
([rhs (or/c expr? seq? any/c)] ([rhs (or/c expr? seq? any/c)]
[body (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)]
[flonum? boolean?] [type (or/c #f 'flonum 'fixnum)]
[unused? boolean?])]{ [unused? boolean?])]{
Pushes an uninitialized slot onto the stack, evaluates @racket[rhs] Pushes an uninitialized slot onto the stack, evaluates @racket[rhs]
and puts its value into the slot, and then runs @racket[body]. If and puts its value into the slot, and then runs @racket[body]. If
@racket[flonum?] is @racket[#t], then @racket[rhs] must produce a @racket[type] is not @racket[#f], then @racket[rhs] must produce a
flonum, and the slot must be accessed by @racket[localref]s that value of the corresponding type, and the slot must be accessed by @racket[localref]s that
expect a flonum. If @racket[unused?] is @racket[#t], then the slot expect the type. If @racket[unused?] is @racket[#t], then the slot
must not be used, and the value of @racket[rhs] is not actually pushed must not be used, and the value of @racket[rhs] is not actually pushed
onto the stack (but @racket[rhs] is constrained to produce a single onto the stack (but @racket[rhs] is constrained to produce a single
value). value).
@ -402,7 +402,7 @@ binding, constructor, etc.}
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
[clear? boolean?] [clear? boolean?]
[other-clears? boolean?] [other-clears? boolean?]
[flonum? boolean?])]{ [type (or/c #f 'flonum 'fixnum)])]{
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 @racket[pos] slots. If @racket[unbox?] is stack slot after the first @racket[pos] slots. If @racket[unbox?] is
@racket[#t], the stack slot contains a box, and a value is extracted @racket[#t], the stack slot contains a box, and a value is extracted
@ -410,8 +410,8 @@ binding, constructor, etc.}
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
@racket[other-clears?] is @racket[#t], then some later reference to @racket[other-clears?] is @racket[#t], then some later reference to
the same stack slot may clear after reading. If @racket[flonum?] is the same stack slot may clear after reading. If @racket[type] is
@racket[#t], the slot holds to a flonum value.} not @racket[#f], the slot is known to hold a specific type of value.}
@defstruct+[(toplevel expr) @defstruct+[(toplevel expr)
([depth exact-nonnegative-integer?] ([depth exact-nonnegative-integer?]

20
collects/tests/racket/optimize.rktl
View File

@ -2551,6 +2551,26 @@
(newline))) (newline)))
list))) list)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure compiler isn't too agressive for the validator
;; in terms of typed arguments:
(let ([m '(module m racket/base
(require racket/flonum)
(define (f x)
(letrec ([z (if x (other 1) 'none)]
[collect (lambda (x)
(lambda (n)
(list '(1 2 3)
(fl+ n x))))]
[a (collect 0.0)]
[other 6])
(values a z))))])
(define o (open-output-bytes))
(write (compile m) o)
(parameterize ([read-accept-compiled #t])
;; too-aggressive compilation produces a validator failure here
(read (open-input-bytes (get-output-bytes o)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
Version 5.3.1.7
compiler/zo-structs: generalize flonum? field to type
field in localref, let-one, and fun
Version 5.3.1.6 Version 5.3.1.6
racket/unsafe/ops: added unsafe-cons-list racket/unsafe/ops: added unsafe-cons-list

10
src/racket/src/compenv.c
View File

@ -855,16 +855,8 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
k = type - scheme_local_type; k = type - scheme_local_type;
/* Helper for reading bytecode: make sure flags is a valid value */ /* Helper for reading bytecode: make sure flags is a valid value */
switch (flags) { if ((flags < 0) || (flags > (SCHEME_MAX_LOCAL_TYPE + SCHEME_LOCAL_TYPE_OFFSET)))
case 0:
case SCHEME_LOCAL_CLEAR_ON_READ:
case SCHEME_LOCAL_OTHER_CLEARS:
case SCHEME_LOCAL_FLONUM:
break;
default:
flags = SCHEME_LOCAL_OTHER_CLEARS; flags = SCHEME_LOCAL_OTHER_CLEARS;
break;
}
if (pos < MAX_CONST_LOCAL_POS) { if (pos < MAX_CONST_LOCAL_POS) {
return scheme_local[pos][k][flags]; return scheme_local[pos][k][flags];

10
src/racket/src/cstartup.inc
View File

@ -1,5 +1,5 @@
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0,
21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83, 21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83,
0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0,
@ -100,7 +100,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2048); EVAL_ONE_SIZED_STR((char *)expr, 2048);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0, 0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0,
26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203, 26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203,
0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1, 0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1,
@ -581,7 +581,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 10019); EVAL_ONE_SIZED_STR((char *)expr, 10019);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0, 0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0,
57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,190,0,197, 57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,190,0,197,
0,0,0,222,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99, 0,0,0,222,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,
@ -611,7 +611,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 548); EVAL_ONE_SIZED_STR((char *)expr, 548);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0, 0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0,
45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187,
0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1,
@ -1020,7 +1020,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 8518); EVAL_ONE_SIZED_STR((char *)expr, 8518);
} }
{ {
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0, SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,
29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0,
0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,

41
src/racket/src/jit.c
View File

@ -311,10 +311,10 @@ Scheme_Object *scheme_apply_lightweight_continuation_stack(Scheme_Current_LWC *l
#ifdef USE_FLONUM_UNBOXING #ifdef USE_FLONUM_UNBOXING
int scheme_jit_check_closure_flonum_bit(Scheme_Closure_Data *data, int pos, int delta) int scheme_jit_check_closure_flonum_bit(Scheme_Closure_Data *data, int pos, int delta)
{ {
int bit; int ct;
pos += delta; pos += delta;
bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); ct = scheme_boxmap_get(data->closure_map, pos, data->closure_size);
if (data->closure_map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) if (ct == (CLOS_TYPE_TYPE_OFFSET + SCHEME_LOCAL_TYPE_FLONUM))
return 1; return 1;
else else
return 0; return 0;
@ -443,7 +443,7 @@ static int no_sync_change(Scheme_Object *obj, int fuel)
return no_sync_change(branch->fbranch, fuel); return no_sync_change(branch->fbranch, fuel);
} }
case scheme_local_type: case scheme_local_type:
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) if (JIT_TYPE_NEEDS_BOXING(SCHEME_GET_LOCAL_TYPE(obj)))
return 0; return 0;
else else
return fuel - 1; return fuel - 1;
@ -716,7 +716,7 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth)
break; break;
case scheme_local_type: case scheme_local_type:
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) if (JIT_TYPE_NEEDS_BOXING(SCHEME_GET_LOCAL_TYPE(obj)))
return 0; return 0;
return 1; return 1;
break; break;
@ -765,18 +765,22 @@ static int is_a_procedure(Scheme_Object *v, mz_jit_state *jitter)
int scheme_ok_to_move_local(Scheme_Object *obj) int scheme_ok_to_move_local(Scheme_Object *obj)
{ {
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) {
&& !SCHEME_GET_LOCAL_FLAGS(obj)) { int flags = SCHEME_GET_LOCAL_FLAGS(obj);
if (!flags
|| ((flags > SCHEME_LOCAL_TYPE_OFFSET)
&& !JIT_TYPE_NEEDS_BOXING(flags - SCHEME_LOCAL_TYPE_OFFSET)))
return 1; return 1;
} else }
return 0; return 0;
} }
int scheme_ok_to_delay_local(Scheme_Object *obj) int scheme_ok_to_delay_local(Scheme_Object *obj)
{ {
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)
/* We can delay if the clears flag is set: */ /* We can delay if the clears flag is set and no type: */
&& (SCHEME_GET_LOCAL_FLAGS(obj) <= 1)) { && (SCHEME_GET_LOCAL_FLAGS(obj) <= SCHEME_LOCAL_CLEAR_ON_READ)) {
return 1; return 1;
} else } else
return 0; return 0;
@ -827,7 +831,7 @@ static int expression_avoids_clearing_local(Scheme_Object *wrt, int pos, int fue
return 1; return 1;
else if (SAME_TYPE(t, scheme_local_type)) else if (SAME_TYPE(t, scheme_local_type))
return ((SCHEME_LOCAL_POS(wrt) != pos) return ((SCHEME_LOCAL_POS(wrt) != pos)
|| !(SCHEME_GET_LOCAL_FLAGS(wrt) & SCHEME_LOCAL_CLEAR_ON_READ)); || !(SCHEME_GET_LOCAL_FLAGS(wrt) == SCHEME_LOCAL_CLEAR_ON_READ));
else if (SAME_TYPE(t, scheme_toplevel_type)) else if (SAME_TYPE(t, scheme_toplevel_type))
return 1; return 1;
else if (t == scheme_application2_type) { else if (t == scheme_application2_type) {
@ -858,9 +862,9 @@ int scheme_is_relatively_constant_and_avoids_r1_maybe_fp(Scheme_Object *obj, Sch
t = SCHEME_TYPE(obj); t = SCHEME_TYPE(obj);
if (SAME_TYPE(t, scheme_local_type)) { if (SAME_TYPE(t, scheme_local_type)) {
/* Must have clearing, other-clears, or flonum flag set, /* Must have clearing, other-clears, or type flag set,
otherwise is_constant_and_avoids_r1() would have returned 1. */ otherwise is_constant_and_avoids_r1() would have returned 1. */
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) if (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM)
return fp_ok; return fp_ok;
else if (expression_avoids_clearing_local(wrt, SCHEME_LOCAL_POS(obj), 3)) else if (expression_avoids_clearing_local(wrt, SCHEME_LOCAL_POS(obj), 3))
/* different local vars, sp order doesn't matter */ /* different local vars, sp order doesn't matter */
@ -884,9 +888,10 @@ int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder)
t = SCHEME_TYPE(obj); t = SCHEME_TYPE(obj);
if (SAME_TYPE(t, scheme_local_type)) { if (SAME_TYPE(t, scheme_local_type)) {
if (and_can_reorder && SCHEME_GET_LOCAL_FLAGS(obj)) int flags = SCHEME_GET_LOCAL_FLAGS(obj);
if (and_can_reorder && (flags && (flags <= SCHEME_LOCAL_OTHER_CLEARS)))
return 0; return 0;
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) if (JIT_TYPE_NEEDS_BOXING(flags - SCHEME_LOCAL_TYPE_OFFSET))
return 0; return 0;
return 1; return 1;
} else } else
@ -1929,11 +1934,11 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_local_type: case scheme_local_type:
{ {
/* Other parts of the JIT rely on this code modifying only the target register, /* Other parts of the JIT rely on this code modifying only the target register,
unless the flag is SCHEME_LOCAL_FLONUM */ unless the type is SCHEME_FLONUM_TYPE */
int pos, flonum; int pos, flonum;
START_JIT_DATA(); START_JIT_DATA();
#ifdef USE_FLONUM_UNBOXING #ifdef USE_FLONUM_UNBOXING
flonum = (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM); flonum = (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM);
#else #else
flonum = 0; flonum = 0;
#endif #endif
@ -2826,7 +2831,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
mz_runstack_skipped(jitter, 1); mz_runstack_skipped(jitter, 1);
#ifdef USE_FLONUM_UNBOXING #ifdef USE_FLONUM_UNBOXING
flonum = SCHEME_LET_EVAL_TYPE(lv) & LET_ONE_FLONUM; flonum = (SCHEME_LET_ONE_TYPE(lv) == SCHEME_LOCAL_TYPE_FLONUM);
#else #else
flonum = 0; flonum = 0;
#endif #endif

5
src/racket/src/jit.h
View File

@ -1087,6 +1087,11 @@ static void emit_indentation(mz_jit_state *jitter)
/**********************************************************************/ /**********************************************************************/
/* Does boxing a type require registers, possibly GC, etc.? */
#define JIT_TYPE_NEEDS_BOXING(t) ((t) == SCHEME_LOCAL_TYPE_FLONUM)
/**********************************************************************/
#ifdef MZ_USE_FUTURES #ifdef MZ_USE_FUTURES
# define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_prepare_direct_prim(n) mz_prepare(n)
# define mz_finishr_direct_prim(reg, proc, refr) (jit_pusharg_p(reg), (void)mz_finish_lwe(proc, refr)) # define mz_finishr_direct_prim(reg, proc, refr) (jit_pusharg_p(reg), (void)mz_finish_lwe(proc, refr))

13
src/racket/src/jitalloc.c
View File

@ -100,16 +100,21 @@ static intptr_t read_first_word(void *sp)
return foo; return foo;
} }
static intptr_t initial_tag_word(Scheme_Type tag, int immut) static intptr_t initial_tag_word(Scheme_Type tag, int flags)
{ {
GC_CAN_IGNORE Scheme_Small_Object sp; GC_CAN_IGNORE Scheme_Small_Object sp;
memset(&sp, 0, sizeof(Scheme_Small_Object)); memset(&sp, 0, sizeof(Scheme_Small_Object));
sp.iso.so.type = tag; sp.iso.so.type = tag;
if (immut) SCHEME_SET_IMMUTABLE(&sp); if (flags) {
if (tag == scheme_pair_type)
SCHEME_PAIR_FLAGS(&sp) |= flags;
else
SCHEME_SET_IMMUTABLE(&sp);
}
return read_first_word((void *)&sp); return read_first_word((void *)&sp);
} }
int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int immut, int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int flags,
int keep_r0_r1, int keep_fpr1, int inline_retry) int keep_r0_r1, int keep_fpr1, int inline_retry)
/* Puts allocated result at JIT_V1; first word is GC tag. /* Puts allocated result at JIT_V1; first word is GC tag.
Uses JIT_R2 as temporary. The allocated memory is "dirty" (i.e., not 0ed). Uses JIT_R2 as temporary. The allocated memory is "dirty" (i.e., not 0ed).
@ -163,7 +168,7 @@ int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int immut
jit_stir_l(JIT_V1, a_word); jit_stir_l(JIT_V1, a_word);
/* Scheme_Object header: */ /* Scheme_Object header: */
a_word = initial_tag_word(ty, immut); a_word = initial_tag_word(ty, flags);
jit_stixi_l(sizeof(intptr_t), JIT_V1, a_word); jit_stixi_l(sizeof(intptr_t), JIT_V1, a_word);
} else { } else {
/* an array of pointers */ /* an array of pointers */

4
src/racket/src/jitarith.c
View File

@ -124,7 +124,7 @@ static int is_unboxing_immediate(Scheme_Object *obj, int unsafely)
t = SCHEME_TYPE(obj); t = SCHEME_TYPE(obj);
switch (t) { switch (t) {
case scheme_local_type: case scheme_local_type:
if (SCHEME_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) if (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM)
return 1; return 1;
return unsafely; return unsafely;
case scheme_toplevel_type: case scheme_toplevel_type:
@ -1086,7 +1086,7 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
simple_rand = (scheme_ok_to_move_local(rand) simple_rand = (scheme_ok_to_move_local(rand)
|| SCHEME_INTP(rand)); || SCHEME_INTP(rand));
simple_rand2 = (SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type) simple_rand2 = (SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type)
&& (SCHEME_GET_LOCAL_FLAGS(rand2) != SCHEME_LOCAL_FLONUM)); && (SCHEME_GET_LOCAL_TYPE(rand2) != SCHEME_LOCAL_TYPE_FLONUM));
if (simple_rand && simple_rand2) { if (simple_rand && simple_rand2) {
if (mz_CURRENT_REG_STATUS_VALID() if (mz_CURRENT_REG_STATUS_VALID()
&& (jitter->r0_status >= 0) && (jitter->r0_status >= 0)

8
src/racket/src/jitcall.c
View File

@ -1178,13 +1178,13 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
? alt_rands[i+1+args_already_in_place] ? alt_rands[i+1+args_already_in_place]
: app->args[i+1+args_already_in_place]); : app->args[i+1+args_already_in_place]);
if (!SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type) if (!SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)
|| (SCHEME_GET_LOCAL_FLAGS(rand) == SCHEME_LOCAL_FLONUM)) { || (SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FLONUM)) {
int aoffset = JIT_FRAME_FLONUM_OFFSET - (arg_tmp_offset * sizeof(double)); int aoffset = JIT_FRAME_FLONUM_OFFSET - (arg_tmp_offset * sizeof(double));
GC_CAN_IGNORE jit_insn *iref; GC_CAN_IGNORE jit_insn *iref;
if (i != num_rands - 1) if (i != num_rands - 1)
mz_pushr_p(JIT_R0); mz_pushr_p(JIT_R0);
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) { if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
/* assert: SCHEME_GET_LOCAL_FLAGS(rand) == SCHEME_LOCAL_FLONUM */ /* assert: SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FLONUM */
/* have to check for an existing box */ /* have to check for an existing box */
if (i != num_rands - 1) if (i != num_rands - 1)
mz_rs_ldxi(JIT_R0, i+1); mz_rs_ldxi(JIT_R0, i+1);
@ -1450,7 +1450,7 @@ static jit_direct_arg *check_special_direct_args(Scheme_App_Rec *app, Scheme_Obj
? alt_rands[i+1+args_already_in_place] ? alt_rands[i+1+args_already_in_place]
: app->args[i+1+args_already_in_place]); : app->args[i+1+args_already_in_place]);
if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type) if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)
&& !SCHEME_GET_LOCAL_FLAGS(v)) { && !SCHEME_GET_LOCAL_TYPE(v)) {
pos = SCHEME_LOCAL_POS(v); pos = SCHEME_LOCAL_POS(v);
for (j = 0; j < n; j++) { for (j = 0; j < n; j++) {
if (reg_to_pos[j] == pos) if (reg_to_pos[j] == pos)
@ -1859,7 +1859,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
: app->args[1+args_already_in_place]); : app->args[1+args_already_in_place]);
t = SCHEME_TYPE(arg); t = SCHEME_TYPE(arg);
if ((num_rands == 1) && ((SAME_TYPE(scheme_local_type, t) if ((num_rands == 1) && ((SAME_TYPE(scheme_local_type, t)
&& ((SCHEME_GET_LOCAL_FLAGS(arg) != SCHEME_LOCAL_FLONUM))) && ((SCHEME_GET_LOCAL_TYPE(arg) != SCHEME_LOCAL_TYPE_FLONUM)))
|| (t >= _scheme_values_types_))) { || (t >= _scheme_values_types_))) {
/* App of something complex to a local variable. We /* App of something complex to a local variable. We
can move the proc directly to V1. */ can move the proc directly to V1. */

8
src/racket/src/marshal.c
View File

@ -708,14 +708,12 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
svec_size = data->closure_size; svec_size = data->closure_size;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT; svec_size += ((CLOS_TYPE_BITS_PER_ARG * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT;
{ {
int k, mv; int k, mv;
for (k = data->num_params + data->closure_size; --k; ) { for (k = data->num_params + data->closure_size; --k; ) {
mv = ((data->closure_map[data->closure_size + ((2 * k) / BITS_PER_MZSHORT)] mv = scheme_boxmap_get(data->closure_map, k, data->closure_size);
>> ((2 * k) % BITS_PER_MZSHORT)) if (mv > (CLOS_TYPE_TYPE_OFFSET + SCHEME_MAX_LOCAL_TYPE))
& 0x3);
if (mv == 0x3)
scheme_signal_error("internal error: inconsistent closure/argument type"); scheme_signal_error("internal error: inconsistent closure/argument type");
} }
} }

4
src/racket/src/mzmark_fun.inc
View File

@ -10,7 +10,7 @@ static int mark_closure_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->local_flags, gc); gcMARK2(i->local_flags, gc);
gcMARK2(i->base_closure_map, gc); gcMARK2(i->base_closure_map, gc);
gcMARK2(i->flonum_map, gc); gcMARK2(i->local_type_map, gc);
return return
gcBYTES_TO_WORDS(sizeof(Closure_Info)); gcBYTES_TO_WORDS(sizeof(Closure_Info));
@ -21,7 +21,7 @@ static int mark_closure_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->local_flags, gc); gcFIXUP2(i->local_flags, gc);
gcFIXUP2(i->base_closure_map, gc); gcFIXUP2(i->base_closure_map, gc);
gcFIXUP2(i->flonum_map, gc); gcFIXUP2(i->local_type_map, gc);
return return
gcBYTES_TO_WORDS(sizeof(Closure_Info)); gcBYTES_TO_WORDS(sizeof(Closure_Info));

2
src/racket/src/mzmark_optimize.inc
View File

@ -19,6 +19,7 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->transitive_use_len, gc); gcMARK2(i->transitive_use_len, gc);
gcMARK2(i->context, gc); gcMARK2(i->context, gc);
gcMARK2(i->logger, gc); gcMARK2(i->logger, gc);
gcMARK2(i->types, gc);
return return
gcBYTES_TO_WORDS(sizeof(Optimize_Info)); gcBYTES_TO_WORDS(sizeof(Optimize_Info));
@ -38,6 +39,7 @@ static int mark_optimize_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->transitive_use_len, gc); gcFIXUP2(i->transitive_use_len, gc);
gcFIXUP2(i->context, gc); gcFIXUP2(i->context, gc);
gcFIXUP2(i->logger, gc); gcFIXUP2(i->logger, gc);
gcFIXUP2(i->types, gc);
return return
gcBYTES_TO_WORDS(sizeof(Optimize_Info)); gcBYTES_TO_WORDS(sizeof(Optimize_Info));

2
src/racket/src/mzmarksrc.c
View File

@ -1383,7 +1383,7 @@ mark_closure_info {
gcMARK2(i->local_flags, gc); gcMARK2(i->local_flags, gc);
gcMARK2(i->base_closure_map, gc); gcMARK2(i->base_closure_map, gc);
gcMARK2(i->flonum_map, gc); gcMARK2(i->local_type_map, gc);
size: size:
gcBYTES_TO_WORDS(sizeof(Closure_Info)); gcBYTES_TO_WORDS(sizeof(Closure_Info));

317
src/racket/src/optimize.c
View File

@ -77,14 +77,20 @@ struct Optimize_Info
Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */ Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */
}; };
static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); #define OPT_IS_MUTATED 0x1
static void set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); #define OPT_LOCAL_TYPE_ARG_SHIFT 2
static void merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); #define OPT_LOCAL_TYPE_VAL_SHIFT (OPT_LOCAL_TYPE_ARG_SHIFT + SCHEME_MAX_LOCAL_TYPE_BITS)
static char *get_closure_local_type_map(Scheme_Closure_Data *data, int arg_n, int *ok);
static void set_closure_local_type_map(Scheme_Closure_Data *data, char *local_type_map);
static void merge_closure_local_type_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2);
static int closure_body_size(Scheme_Closure_Data *data, int check_assign, static int closure_body_size(Scheme_Closure_Data *data, int check_assign,
Optimize_Info *info, int *is_leaf); Optimize_Info *info, int *is_leaf);
static int closure_has_top_level(Scheme_Closure_Data *data); static int closure_has_top_level(Scheme_Closure_Data *data);
static int closure_argument_flags(Scheme_Closure_Data *data, int i); static int closure_argument_flags(Scheme_Closure_Data *data, int i);
static int wants_local_type_arguments(Scheme_Object *rator, int argpos);
static int optimize_info_is_ready(Optimize_Info *info, int pos); static int optimize_info_is_ready(Optimize_Info *info, int pos);
static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use);
@ -96,13 +102,13 @@ static Scheme_Object *optimize_get_predicate(int pos, Optimize_Info *info);
static void add_type(Optimize_Info *info, int pos, Scheme_Object *pred); static void add_type(Optimize_Info *info, int pos, Scheme_Object *pred);
static void optimize_mutated(Optimize_Info *info, int pos); static void optimize_mutated(Optimize_Info *info, int pos);
static void optimize_produces_flonum(Optimize_Info *info, int pos); static void optimize_produces_local_type(Optimize_Info *info, int pos, int ct);
static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use); static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use);
static int optimize_is_used(Optimize_Info *info, int pos); static int optimize_is_used(Optimize_Info *info, int pos);
static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos); static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos);
static int optimize_is_mutated(Optimize_Info *info, int pos); static int optimize_is_mutated(Optimize_Info *info, int pos);
static int optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth); static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth);
static int optimize_is_flonum_valued(Optimize_Info *info, int pos); static int optimize_is_local_type_valued(Optimize_Info *info, int pos);
static int env_uses_toplevel(Optimize_Info *frame); static int env_uses_toplevel(Optimize_Info *frame);
static void env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); static void env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map);
@ -978,7 +984,7 @@ static int movable_expression(Scheme_Object *expr, Optimize_Info *info, int delt
return 1; return 1;
else if (!optimize_is_mutated(info, pos + delta)) { else if (!optimize_is_mutated(info, pos + delta)) {
if (check_space) { if (check_space) {
if (optimize_is_flonum_valued(info, pos + delta)) if (optimize_is_local_type_valued(info, pos + delta))
return 1; return 1;
/* the value of the identifier might be something that would /* the value of the identifier might be something that would
retain significant memory, so we can't delay evaluation */ retain significant memory, so we can't delay evaluation */
@ -1616,20 +1622,22 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
return NULL; return NULL;
} }
static int is_flonum_expression(Scheme_Object *expr, Optimize_Info *info) static int is_local_type_expression(Scheme_Object *expr, Optimize_Info *info)
{ {
if (scheme_expr_produces_flonum(expr)) int ty;
return 1;
ty = scheme_expr_produces_local_type(expr);
if (ty) return ty;
if (SAME_TYPE(SCHEME_TYPE(expr), scheme_local_type)) { if (SAME_TYPE(SCHEME_TYPE(expr), scheme_local_type)) {
if (optimize_is_flonum_valued(info, SCHEME_LOCAL_POS(expr))) ty = optimize_is_local_type_valued(info, SCHEME_LOCAL_POS(expr));
return 1; if (ty) return ty;
} }
return 0; return 0;
} }
static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, static void register_local_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
Optimize_Info *info) Optimize_Info *info)
{ {
Scheme_Object *rator, *rand, *le; Scheme_Object *rator, *rand, *le;
@ -1656,11 +1664,11 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec
char *map; char *map;
int ok; int ok;
map = get_closure_flonum_map(data, n, &ok); map = get_closure_local_type_map(data, n, &ok);
if (ok) { if (ok) {
for (i = 0; i < n; i++) { for (i = 0; i < n; i++) {
int is_flonum; int ct;
if (app) if (app)
rand = app->args[i+1]; rand = app->args[i+1];
@ -1673,19 +1681,19 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec
rand = app3->rand2; rand = app3->rand2;
} }
is_flonum = is_flonum_expression(rand, info); ct = is_local_type_expression(rand, info);
if (is_flonum) { if (ct) {
if (!map) { if (!map) {
map = MALLOC_N_ATOMIC(char, n); map = MALLOC_N_ATOMIC(char, n);
memset(map, 1, n); memset(map, ct, n);
memset(map, 0, i); memset(map, 0, i);
} }
} }
if (map && !is_flonum) if (map)
map[i] = 0; map[i] = ct;
} }
set_closure_flonum_map(data, map); set_closure_local_type_map(data, map);
} }
} }
} }
@ -1866,8 +1874,9 @@ static int is_nonmutating_primitive(Scheme_Object *rator, int n)
#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) #define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm))
int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos) static int wants_local_type_arguments(Scheme_Object *rator, int argpos)
{ {
/* See ALWAYS_PREFER_UNBOX_TYPE() for why we don't return SCHEME_LOCAL_TYPE_FIXNUM */
if (SCHEME_PRIMP(rator)) { if (SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) { if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) {
if (IS_NAMED_PRIM(rator, "unsafe-flabs") if (IS_NAMED_PRIM(rator, "unsafe-flabs")
@ -1884,7 +1893,7 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos)
|| IS_NAMED_PRIM(rator, "unsafe-flmin") || IS_NAMED_PRIM(rator, "unsafe-flmin")
|| IS_NAMED_PRIM(rator, "unsafe-flmax") || IS_NAMED_PRIM(rator, "unsafe-flmax")
|| IS_NAMED_PRIM(rator, "unsafe-fl->fx")) || IS_NAMED_PRIM(rator, "unsafe-fl->fx"))
return 1; return SCHEME_LOCAL_TYPE_FLONUM;
} else if (SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { } else if (SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) {
if (IS_NAMED_PRIM(rator, "flabs") if (IS_NAMED_PRIM(rator, "flabs")
|| IS_NAMED_PRIM(rator, "flsqrt") || IS_NAMED_PRIM(rator, "flsqrt")
@ -1911,20 +1920,18 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos)
|| IS_NAMED_PRIM(rator, "fl>") || IS_NAMED_PRIM(rator, "fl>")
|| IS_NAMED_PRIM(rator, "flmin") || IS_NAMED_PRIM(rator, "flmin")
|| IS_NAMED_PRIM(rator, "flmax")) || IS_NAMED_PRIM(rator, "flmax"))
return 1; return SCHEME_LOCAL_TYPE_FLONUM;
if ((argpos == 2) if ((argpos == 2)
&& IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) && (IS_NAMED_PRIM(rator, "unsafe-flvector-set!")
return 1; || IS_NAMED_PRIM(rator, "flvector-set!")))
if ((argpos == 2) return SCHEME_LOCAL_TYPE_FLONUM;
&& IS_NAMED_PRIM(rator, "flvector-set!"))
return 1;
} }
} }
return 0; return 0;
} }
static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc) static int produces_local_type(Scheme_Object *rator, int argc)
{ {
if (SCHEME_PRIMP(rator)) { if (SCHEME_PRIMP(rator)) {
if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) { if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) {
@ -1940,12 +1947,40 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc)
|| IS_NAMED_PRIM(rator, "unsafe-fl/") || IS_NAMED_PRIM(rator, "unsafe-fl/")
|| IS_NAMED_PRIM(rator, "unsafe-flmin") || IS_NAMED_PRIM(rator, "unsafe-flmin")
|| IS_NAMED_PRIM(rator, "unsafe-flmax")))) || IS_NAMED_PRIM(rator, "unsafe-flmax"))))
return 1; return SCHEME_LOCAL_TYPE_FLONUM;
if (((argc == 2) && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) if (((argc == 2) && IS_NAMED_PRIM(rator, "unsafe-flvector-ref"))
|| ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) { || ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl")))
if (non_fl_args) *non_fl_args = 1; return SCHEME_LOCAL_TYPE_FLONUM;
return 1; if (((argc == 1)
} && (IS_NAMED_PRIM(rator, "unsafe-fxabs")
|| IS_NAMED_PRIM(rator, "fxnot")
|| IS_NAMED_PRIM(rator, "unsafe-fl->fx")))
|| ((argc == 2)
&& (IS_NAMED_PRIM(rator, "unsafe-fx+")
|| IS_NAMED_PRIM(rator, "unsafe-fx-")
|| IS_NAMED_PRIM(rator, "unsafe-fx*")
|| IS_NAMED_PRIM(rator, "unsafe-fxquotient")
|| IS_NAMED_PRIM(rator, "unsafe-fxremainder")
|| IS_NAMED_PRIM(rator, "unsafe-fxmodulo")
|| IS_NAMED_PRIM(rator, "unsafe-fxmin")
|| IS_NAMED_PRIM(rator, "unsafe-fxmax")
|| IS_NAMED_PRIM(rator, "fxlshift")
|| IS_NAMED_PRIM(rator, "fxrshift")
|| IS_NAMED_PRIM(rator, "fxior")
|| IS_NAMED_PRIM(rator, "fxand")
|| IS_NAMED_PRIM(rator, "fxxor"))))
return SCHEME_LOCAL_TYPE_FIXNUM;
if (((argc == 2)
&& (IS_NAMED_PRIM(rator, "unsafe-fxvector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-bytes-ref")))
|| ((argc == 1)
&& (IS_NAMED_PRIM(rator, "unsafe-fl->fx")
|| IS_NAMED_PRIM(rator, "unsafe-vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-string-length")
|| IS_NAMED_PRIM(rator, "unsafe-bytes-length"))))
return SCHEME_LOCAL_TYPE_FIXNUM;
} else if ((argc == 1) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { } else if ((argc == 1) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) {
if (IS_NAMED_PRIM(rator, "flabs") if (IS_NAMED_PRIM(rator, "flabs")
|| IS_NAMED_PRIM(rator, "flsqrt") || IS_NAMED_PRIM(rator, "flsqrt")
@ -1962,12 +1997,19 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc)
|| IS_NAMED_PRIM(rator, "fllog") || IS_NAMED_PRIM(rator, "fllog")
|| IS_NAMED_PRIM(rator, "flexp") || IS_NAMED_PRIM(rator, "flexp")
|| IS_NAMED_PRIM(rator, "flimag-part") || IS_NAMED_PRIM(rator, "flimag-part")
|| IS_NAMED_PRIM(rator, "flreal-part")) || IS_NAMED_PRIM(rator, "flreal-part")
return 1; || IS_NAMED_PRIM(rator, "->fl")
if (IS_NAMED_PRIM(rator, "->fl")) { || IS_NAMED_PRIM(rator, "fx->fl"))
if (non_fl_args) *non_fl_args = 1; return SCHEME_LOCAL_TYPE_FLONUM;
return 1; if (IS_NAMED_PRIM(rator, "fxabs")
} || IS_NAMED_PRIM(rator, "fxnot")
|| IS_NAMED_PRIM(rator, "fl->fx")
|| IS_NAMED_PRIM(rator, "vector-length")
|| IS_NAMED_PRIM(rator, "fxvector-length")
|| IS_NAMED_PRIM(rator, "flvector-length")
|| IS_NAMED_PRIM(rator, "string-length")
|| IS_NAMED_PRIM(rator, "bytes-length"))
return SCHEME_LOCAL_TYPE_FIXNUM;
} else if ((argc ==2) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { } else if ((argc ==2) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) {
if (IS_NAMED_PRIM(rator, "flabs") if (IS_NAMED_PRIM(rator, "flabs")
|| IS_NAMED_PRIM(rator, "flsqrt") || IS_NAMED_PRIM(rator, "flsqrt")
@ -1977,38 +2019,52 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc)
|| IS_NAMED_PRIM(rator, "fl/") || IS_NAMED_PRIM(rator, "fl/")
|| IS_NAMED_PRIM(rator, "flmin") || IS_NAMED_PRIM(rator, "flmin")
|| IS_NAMED_PRIM(rator, "flmax") || IS_NAMED_PRIM(rator, "flmax")
|| IS_NAMED_PRIM(rator, "flexpt")) || IS_NAMED_PRIM(rator, "flexpt")
return 1; || IS_NAMED_PRIM(rator, "flvector-ref"))
if (IS_NAMED_PRIM(rator, "flvector-ref")) { return SCHEME_LOCAL_TYPE_FLONUM;
if (non_fl_args) *non_fl_args = 1; if (IS_NAMED_PRIM(rator, "fxabs")
return 1; || IS_NAMED_PRIM(rator, "fx+")
} || IS_NAMED_PRIM(rator, "fx-")
|| IS_NAMED_PRIM(rator, "fx*")
|| IS_NAMED_PRIM(rator, "fxquotient")
|| IS_NAMED_PRIM(rator, "fxremainder")
|| IS_NAMED_PRIM(rator, "fxmodulo")
|| IS_NAMED_PRIM(rator, "fxmin")
|| IS_NAMED_PRIM(rator, "fxmax")
|| IS_NAMED_PRIM(rator, "fxlshift")
|| IS_NAMED_PRIM(rator, "fxrshift")
|| IS_NAMED_PRIM(rator, "fxand")
|| IS_NAMED_PRIM(rator, "fxior")
|| IS_NAMED_PRIM(rator, "fxxor")
|| IS_NAMED_PRIM(rator, "fxvector-ref")
|| IS_NAMED_PRIM(rator, "bytes-ref"))
return SCHEME_LOCAL_TYPE_FIXNUM;
} }
} }
return 0; return 0;
} }
int scheme_expr_produces_flonum(Scheme_Object *expr) int scheme_expr_produces_local_type(Scheme_Object *expr)
{ {
while (1) { while (1) {
switch (SCHEME_TYPE(expr)) { switch (SCHEME_TYPE(expr)) {
case scheme_application_type: case scheme_application_type:
{ {
Scheme_App_Rec *app = (Scheme_App_Rec *)expr; Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
return produces_unboxed(app->args[0], NULL, app->num_args); return produces_local_type(app->args[0], app->num_args);
} }
break; break;
case scheme_application2_type: case scheme_application2_type:
{ {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator, NULL, 1); return produces_local_type(app->rator, 1);
} }
break; break;
case scheme_application3_type: case scheme_application3_type:
{ {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator, NULL, 2); return produces_local_type(app->rator, 2);
} }
break; break;
case scheme_compiled_let_void_type: case scheme_compiled_let_void_type:
@ -2024,7 +2080,9 @@ int scheme_expr_produces_flonum(Scheme_Object *expr)
break; break;
default: default:
if (SCHEME_FLOATP(expr)) if (SCHEME_FLOATP(expr))
return 1; return SCHEME_LOCAL_TYPE_FLONUM;
if (SCHEME_INTP(expr))
return SCHEME_LOCAL_TYPE_FIXNUM;
return 0; return 0;
} }
} }
@ -2142,8 +2200,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
} }
sub_context = 0; sub_context = 0;
if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1)) if (i > 0) {
sub_context = OPT_CONTEXT_FLONUM_ARG; int ty;
ty = wants_local_type_arguments(app->args[0], i - 1);
if (ty)
sub_context = (ty << OPT_CONTEXT_TYPE_SHIFT);
}
le = scheme_optimize_expr(app->args[i], info, sub_context); le = scheme_optimize_expr(app->args[i], info, sub_context);
app->args[i] = le; app->args[i] = le;
@ -2204,7 +2266,7 @@ static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_
if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc)) if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc))
return scheme_null; return scheme_null;
register_flonum_argument_types(app, NULL, NULL, info); register_local_argument_types(app, NULL, NULL, info);
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
@ -2281,7 +2343,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
{ {
Scheme_App2_Rec *app; Scheme_App2_Rec *app;
Scheme_Object *le; Scheme_Object *le;
int rator_flags = 0, sub_context = 0; int rator_flags = 0, sub_context = 0, ty;
app = (Scheme_App2_Rec *)o; app = (Scheme_App2_Rec *)o;
@ -2302,8 +2364,9 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
return le; return le;
} }
if (scheme_wants_flonum_arguments(app->rator, 0)) ty = wants_local_type_arguments(app->rator, 0);
sub_context |= OPT_CONTEXT_FLONUM_ARG; if (ty)
sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT);
le = scheme_optimize_expr(app->rand, info, sub_context); le = scheme_optimize_expr(app->rand, info, sub_context);
app->rand = le; app->rand = le;
@ -2463,7 +2526,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
} }
} }
register_flonum_argument_types(NULL, app, NULL, info); register_local_argument_types(NULL, app, NULL, info);
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
@ -2472,7 +2535,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
{ {
Scheme_App3_Rec *app; Scheme_App3_Rec *app;
Scheme_Object *le; Scheme_Object *le;
int rator_flags = 0, sub_context = 0; int rator_flags = 0, sub_context = 0, ty;
app = (Scheme_App3_Rec *)o; app = (Scheme_App3_Rec *)o;
@ -2499,18 +2562,20 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
/* 1st arg */ /* 1st arg */
if (scheme_wants_flonum_arguments(app->rator, 0)) ty = wants_local_type_arguments(app->rator, 0);
sub_context |= OPT_CONTEXT_FLONUM_ARG; if (ty)
sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT);
le = scheme_optimize_expr(app->rand1, info, sub_context); le = scheme_optimize_expr(app->rand1, info, sub_context);
app->rand1 = le; app->rand1 = le;
/* 2nd arg */ /* 2nd arg */
if (scheme_wants_flonum_arguments(app->rator, 1)) ty = wants_local_type_arguments(app->rator, 1);
sub_context |= OPT_CONTEXT_FLONUM_ARG; if (ty)
sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT);
else else
sub_context &= ~OPT_CONTEXT_FLONUM_ARG; sub_context &= ~OPT_CONTEXT_TYPE_MASK;
le = scheme_optimize_expr(app->rand2, info, sub_context); le = scheme_optimize_expr(app->rand2, info, sub_context);
app->rand2 = le; app->rand2 = le;
@ -2678,7 +2743,7 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
} }
} }
register_flonum_argument_types(NULL, NULL, app, info); register_local_argument_types(NULL, NULL, app, info);
return (Scheme_Object *)app; return (Scheme_Object *)app;
} }
@ -3784,7 +3849,7 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
static int set_one_code_flags(Scheme_Object *value, int flags, static int set_one_code_flags(Scheme_Object *value, int flags,
Scheme_Object *first, Scheme_Object *second, Scheme_Object *first, Scheme_Object *second,
int set_flags, int mask_flags, int just_tentative, int set_flags, int mask_flags, int just_tentative,
int merge_flonum) int merge_local_typed)
{ {
Scheme_Case_Lambda *cl, *cl2, *cl3; Scheme_Case_Lambda *cl, *cl2, *cl3;
Scheme_Closure_Data *data, *data2, *data3; Scheme_Closure_Data *data, *data2, *data3;
@ -3813,10 +3878,10 @@ static int set_one_code_flags(Scheme_Object *value, int flags,
data3 = (Scheme_Closure_Data *)second; data3 = (Scheme_Closure_Data *)second;
} }
if (merge_flonum) { if (merge_local_typed) {
merge_closure_flonum_map(data, data2); merge_closure_local_type_map(data, data2);
merge_closure_flonum_map(data, data3); merge_closure_local_type_map(data, data3);
merge_closure_flonum_map(data, data2); merge_closure_local_type_map(data, data2);
} }
if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
@ -3833,7 +3898,7 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *pre_body, Scheme_Compiled_Let_Value *pre_body,
Scheme_Object *clones, Scheme_Object *clones,
int set_flags, int mask_flags, int just_tentative, int set_flags, int mask_flags, int just_tentative,
int merge_flonum) int merge_local_typed)
{ {
Scheme_Compiled_Let_Value *clv; Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *first; Scheme_Object *value, *first;
@ -3854,7 +3919,7 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
flags = set_one_code_flags(value, flags, flags = set_one_code_flags(value, flags,
SCHEME_CAR(first), SCHEME_CDR(first), SCHEME_CAR(first), SCHEME_CDR(first),
set_flags, mask_flags, just_tentative, set_flags, mask_flags, just_tentative,
merge_flonum); merge_local_typed);
clones = SCHEME_CDR(clones); clones = SCHEME_CDR(clones);
} }
@ -4377,10 +4442,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
did_set_value = 1; did_set_value = 1;
checked_once = 1; checked_once = 1;
} else if (value && !is_rec) { } else if (value && !is_rec) {
int cnt; int cnt, ct;
if (scheme_expr_produces_flonum(value)) ct = scheme_expr_produces_local_type(value);
optimize_produces_flonum(body_info, pos); if (ct)
optimize_produces_local_type(body_info, pos, ct);
if (!indirect) { if (!indirect) {
checked_once = 1; checked_once = 1;
@ -4640,9 +4706,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
} else { } else {
for (j = pre_body->count; j--; ) { for (j = pre_body->count; j--; ) {
int ct;
pre_body->flags[j] |= SCHEME_WAS_USED; pre_body->flags[j] |= SCHEME_WAS_USED;
if (optimize_is_flonum_arg(body_info, pos+j, 0)) ct = optimize_is_local_type_arg(body_info, pos+j, 0);
pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT; if (ct)
pre_body->flags[j] |= (ct << SCHEME_WAS_TYPED_ARGUMENT_SHIFT);
if (first_once_used && (first_once_used->pos == (pos+j))) { if (first_once_used && (first_once_used->pos == (pos+j))) {
if (first_once_used->vclock < 0) { if (first_once_used->vclock < 0) {
@ -4779,8 +4848,10 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont
code = scheme_optimize_expr(data->code, info, 0); code = scheme_optimize_expr(data->code, info, 0);
for (i = 0; i < data->num_params; i++) { for (i = 0; i < data->num_params; i++) {
if (optimize_is_flonum_arg(info, i, 1)) int ct;
cl->local_flags[i] |= SCHEME_WAS_FLONUM_ARGUMENT; ct = optimize_is_local_type_arg(info, i, 1);
if (ct)
cl->local_flags[i] |= (ct << SCHEME_WAS_TYPED_ARGUMENT_SHIFT);
} }
while (first_once_used) { while (first_once_used) {
@ -4829,7 +4900,7 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont
return (Scheme_Object *)data; return (Scheme_Object *)data;
} }
static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok) static char *get_closure_local_type_map(Scheme_Closure_Data *data, int arg_n, int *ok)
{ {
Closure_Info *cl = (Closure_Info *)data->closure_map; Closure_Info *cl = (Closure_Info *)data->closure_map;
@ -4839,60 +4910,60 @@ static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *o
return NULL; return NULL;
} }
if (cl->has_flomap && !cl->flonum_map) { if (cl->has_tymap && !cl->local_type_map) {
*ok = 0; *ok = 0;
return NULL; return NULL;
} }
*ok = 1; *ok = 1;
return cl->flonum_map; return cl->local_type_map;
} }
static void set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map) static void set_closure_local_type_map(Scheme_Closure_Data *data, char *local_type_map)
{ {
Closure_Info *cl = (Closure_Info *)data->closure_map; Closure_Info *cl = (Closure_Info *)data->closure_map;
int i; int i;
if (!cl->flonum_map) { if (!cl->local_type_map) {
cl->has_flomap = 1; cl->has_tymap = 1;
cl->flonum_map = flonum_map; cl->local_type_map = local_type_map;
} }
if (flonum_map) { if (local_type_map) {
for (i = data->num_params; i--; ) { for (i = data->num_params; i--; ) {
if (flonum_map[i]) break; if (local_type_map[i]) break;
} }
if (i < 0) { if (i < 0) {
cl->flonum_map = NULL; cl->local_type_map = NULL;
} }
} }
} }
static void merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2) static void merge_closure_local_type_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2)
{ {
Closure_Info *cl1 = (Closure_Info *)data1->closure_map; Closure_Info *cl1 = (Closure_Info *)data1->closure_map;
Closure_Info *cl2 = (Closure_Info *)data2->closure_map; Closure_Info *cl2 = (Closure_Info *)data2->closure_map;
if (cl1->has_flomap) { if (cl1->has_tymap) {
if (!cl1->flonum_map || !cl2->has_flomap) { if (!cl1->local_type_map || !cl2->has_tymap) {
cl2->has_flomap = 1; cl2->has_tymap = 1;
cl2->flonum_map = cl1->flonum_map; cl2->local_type_map = cl1->local_type_map;
} else if (cl2->flonum_map) { } else if (cl2->local_type_map) {
int i; int i;
for (i = data1->num_params; i--; ) { for (i = data1->num_params; i--; ) {
if (cl1->flonum_map[i] != cl2->flonum_map[i]) { if (cl1->local_type_map[i] != cl2->local_type_map[i]) {
cl2->flonum_map = NULL; cl2->local_type_map = NULL;
cl1->flonum_map = NULL; cl1->local_type_map = NULL;
break; break;
} }
} }
} else { } else {
cl1->flonum_map = NULL; cl1->local_type_map = NULL;
} }
} else if (cl2->has_flomap) { } else if (cl2->has_tymap) {
cl1->has_flomap = 1; cl1->has_tymap = 1;
cl1->flonum_map = cl2->flonum_map; cl1->local_type_map = cl2->local_type_map;
} }
} }
@ -4902,7 +4973,7 @@ static Scheme_Object *clone_closure_compilation(int dup_ok, Scheme_Object *_data
Scheme_Object *body; Scheme_Object *body;
Closure_Info *cl; Closure_Info *cl;
int *flags, sz; int *flags, sz;
char *flonum_map; char *local_type_map;
data = (Scheme_Closure_Data *)_data; data = (Scheme_Closure_Data *)_data;
@ -4926,11 +4997,11 @@ static Scheme_Object *clone_closure_compilation(int dup_ok, Scheme_Object *_data
memcpy(flags, cl->local_flags, sz); memcpy(flags, cl->local_flags, sz);
cl->local_flags = flags; cl->local_flags = flags;
if (cl->flonum_map) { if (cl->local_type_map) {
sz = data2->num_params; sz = data2->num_params;
flonum_map = (char *)scheme_malloc_atomic(sz); local_type_map = (char *)scheme_malloc_atomic(sz);
memcpy(flonum_map, cl->flonum_map, sz); memcpy(local_type_map, cl->local_type_map, sz);
cl->flonum_map = flonum_map; cl->local_type_map = local_type_map;
} }
return (Scheme_Object *)data2; return (Scheme_Object *)data2;
@ -6517,13 +6588,13 @@ static void register_use(Optimize_Info *info, int pos, int flag)
static void optimize_mutated(Optimize_Info *info, int pos) static void optimize_mutated(Optimize_Info *info, int pos)
/* pos must be in immediate frame */ /* pos must be in immediate frame */
{ {
register_use(info, pos, 0x1); register_use(info, pos, OPT_IS_MUTATED);
} }
static void optimize_produces_flonum(Optimize_Info *info, int pos) static void optimize_produces_local_type(Optimize_Info *info, int pos, int ct)
/* pos must be in immediate frame */ /* pos must be in immediate frame */
{ {
register_use(info, pos, 0x4); register_use(info, pos, ct << OPT_LOCAL_TYPE_VAL_SHIFT);
} }
static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use) static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated, int disrupt_single_use)
@ -6541,7 +6612,7 @@ static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_
} }
if (unless_mutated) if (unless_mutated)
if (info->use && (info->use[pos] & 0x1)) if (info->use && (info->use[pos] & OPT_IS_MUTATED))
return NULL; return NULL;
if (disrupt_single_use) { if (disrupt_single_use) {
@ -6582,7 +6653,7 @@ static int optimize_is_used(Optimize_Info *info, int pos)
return 0; return 0;
} }
static int check_use(Optimize_Info *info, int pos, int flag) static int check_use(Optimize_Info *info, int pos, int mask, int shift)
/* pos is in new-frame counts */ /* pos is in new-frame counts */
{ {
while (info) { while (info) {
@ -6592,8 +6663,8 @@ static int check_use(Optimize_Info *info, int pos, int flag)
info = info->next; info = info->next;
} }
if (info->use && (info->use[pos] & flag)) if (info->use)
return 1; return (info->use[pos] >> shift) & mask;
return 0; return 0;
} }
@ -6601,19 +6672,19 @@ static int check_use(Optimize_Info *info, int pos, int flag)
static int optimize_is_mutated(Optimize_Info *info, int pos) static int optimize_is_mutated(Optimize_Info *info, int pos)
/* pos is in new-frame counts */ /* pos is in new-frame counts */
{ {
return check_use(info, pos, 0x1); return check_use(info, pos, OPT_IS_MUTATED, 0);
} }
static int optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth) static int optimize_is_local_type_arg(Optimize_Info *info, int pos, int depth)
/* pos is in new-frame counts */ /* pos is in new-frame counts */
{ {
return check_use(info, pos, 0x2); return check_use(info, pos, SCHEME_MAX_LOCAL_TYPE_MASK, OPT_LOCAL_TYPE_ARG_SHIFT);
} }
static int optimize_is_flonum_valued(Optimize_Info *info, int pos) static int optimize_is_local_type_valued(Optimize_Info *info, int pos)
/* pos is in new-frame counts */ /* pos is in new-frame counts */
{ {
return check_use(info, pos, 0x4); return check_use(info, pos, SCHEME_MAX_LOCAL_TYPE_MASK, OPT_LOCAL_TYPE_VAL_SHIFT);
} }
static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
@ -6661,11 +6732,11 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
info = info->next; info = info->next;
} }
if (context & OPT_CONTEXT_FLONUM_ARG) if (OPT_CONTEXT_TYPE(context))
register_use(info, pos, 0x2); register_use(info, pos, OPT_CONTEXT_TYPE(context) << OPT_LOCAL_TYPE_ARG_SHIFT);
if (is_mutated) if (is_mutated)
if (info->use && (info->use[pos] & 0x1)) if (info->use && (info->use[pos] & OPT_IS_MUTATED))
*is_mutated = 1; *is_mutated = 1;
if (just_test) return NULL; if (just_test) return NULL;

6
src/racket/src/print.c
View File

@ -3021,12 +3021,14 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED) if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED)
print_compact(pp, CPT_LET_ONE_UNUSED); print_compact(pp, CPT_LET_ONE_UNUSED);
else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) else if (SCHEME_LET_ONE_TYPE(lo))
print_compact(pp, CPT_LET_ONE_FLONUM); print_compact(pp, CPT_LET_ONE_TYPED);
else else
print_compact(pp, CPT_LET_ONE); print_compact(pp, CPT_LET_ONE);
print(scheme_protect_quote(lo->value), notdisplay, 1, NULL, mt, pp); print(scheme_protect_quote(lo->value), notdisplay, 1, NULL, mt, pp);
closed = print(scheme_protect_quote(lo->body), notdisplay, 1, NULL, mt, pp); closed = print(scheme_protect_quote(lo->body), notdisplay, 1, NULL, mt, pp);
if (SCHEME_LET_ONE_TYPE(lo))
print_compact_number(pp, SCHEME_LET_ONE_TYPE(lo));
} }
else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_branch_type)) else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_branch_type))
{ {

10
src/racket/src/read.c
View File

@ -4640,7 +4640,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
} }
break; break;
case CPT_LET_ONE: case CPT_LET_ONE:
case CPT_LET_ONE_FLONUM: case CPT_LET_ONE_TYPED:
case CPT_LET_ONE_UNUSED: case CPT_LET_ONE_UNUSED:
{ {
Scheme_Let_One *lo; Scheme_Let_One *lo;
@ -4654,9 +4654,11 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = read_compact(port, 1); v = read_compact(port, 1);
lo->body = v; lo->body = v;
et = scheme_get_eval_type(lo->value); et = scheme_get_eval_type(lo->value);
if (ch == CPT_LET_ONE_FLONUM) if (ch == CPT_LET_ONE_TYPED) {
et |= LET_ONE_FLONUM; int ty;
if (ch == CPT_LET_ONE_UNUSED) ty = read_compact_number(port);
et |= (ty << LET_ONE_TYPE_SHIFT);
} else if (ch == CPT_LET_ONE_UNUSED)
et |= LET_ONE_UNUSED; et |= LET_ONE_UNUSED;
SCHEME_LET_EVAL_TYPE(lo) = et; SCHEME_LET_EVAL_TYPE(lo) = et;

185
src/racket/src/resolve.c
View File

@ -957,7 +957,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL; Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL;
Scheme_Letrec *letrec; Scheme_Letrec *letrec;
mzshort *skips, skips_fast[NUM_SKIPS_FAST]; mzshort *skips, skips_fast[NUM_SKIPS_FAST];
char *flonums, flonums_fast[NUM_SKIPS_FAST]; char *local_types, local_types_fast[NUM_SKIPS_FAST];
Scheme_Object **lifted, *lifted_fast[NUM_SKIPS_FAST], *boxes; Scheme_Object **lifted, *lifted_fast[NUM_SKIPS_FAST], *boxes;
int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc; int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
int rec_proc_nonapply = 0; int rec_proc_nonapply = 0;
@ -1052,24 +1052,28 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (j <= NUM_SKIPS_FAST) { if (j <= NUM_SKIPS_FAST) {
skips = skips_fast; skips = skips_fast;
lifted = lifted_fast; lifted = lifted_fast;
flonums = flonums_fast; local_types = local_types_fast;
} else { } else {
skips = MALLOC_N_ATOMIC(mzshort, j); skips = MALLOC_N_ATOMIC(mzshort, j);
lifted = MALLOC_N(Scheme_Object*, j); lifted = MALLOC_N(Scheme_Object*, j);
flonums = MALLOC_N_ATOMIC(char, j); local_types = MALLOC_N_ATOMIC(char, j);
} }
clv = (Scheme_Compiled_Let_Value *)head->body; clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) {
int aty, pty;
if (!(clv->flags[0] & SCHEME_WAS_USED)) if (!(clv->flags[0] & SCHEME_WAS_USED))
skips[i] = 1; skips[i] = 1;
else else
skips[i] = 0; skips[i] = 0;
if ((clv->flags[0] & SCHEME_WAS_FLONUM_ARGUMENT)
&& scheme_expr_produces_flonum(clv->value)) aty = SCHEME_WAS_TYPED_ARGUMENT(clv->flags[0]);
flonums[i] = SCHEME_INFO_FLONUM_ARG; pty = scheme_expr_produces_local_type(clv->value);
if (pty && ((pty == aty) || ALWAYS_PREFER_UNBOX_TYPE(pty)))
local_types[i] = pty;
else else
flonums[i] = 0; local_types[i] = 0;
lifted[i] = NULL; lifted[i] = NULL;
} }
@ -1099,9 +1103,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
for (j = i, k = 0; j >= 0; j--) { for (j = i, k = 0; j >= 0; j--) {
n = (rev_bind_order ? (head->count - j - 1) : j); n = (rev_bind_order ? (head->count - j - 1) : j);
if (skips[j]) if (skips[j])
resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]); resolve_info_add_mapping(linfo, n, -1, local_types[j] << SCHEME_INFO_TYPED_VAL_SHIFT, lifted[j]);
else else
resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]); resolve_info_add_mapping(linfo, n, k++, local_types[j] << SCHEME_INFO_TYPED_VAL_SHIFT, lifted[j]);
} }
} }
lifts_frame_size = frame_size; lifts_frame_size = frame_size;
@ -1143,8 +1147,8 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
lo->value = le; lo->value = le;
et = scheme_get_eval_type(lo->value); et = scheme_get_eval_type(lo->value);
if (flonums[i]) if (local_types[i])
et |= LET_ONE_FLONUM; et |= (local_types[i] << LET_ONE_TYPE_SHIFT);
SCHEME_LET_EVAL_TYPE(lo) = et; SCHEME_LET_EVAL_TYPE(lo) = et;
if (last) if (last)
@ -1170,9 +1174,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
n = (rev_bind_order ? (head->count - i - 1) : i); n = (rev_bind_order ? (head->count - i - 1) : i);
if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n"); if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n");
if (skips[i]) if (skips[i])
resolve_info_add_mapping(linfo, n, -1, flonums[i], lifted[i]); resolve_info_add_mapping(linfo, n, -1, local_types[i] << SCHEME_INFO_TYPED_VAL_SHIFT, lifted[i]);
else else
resolve_info_add_mapping(linfo, n, k++, flonums[i], lifted[i]); resolve_info_add_mapping(linfo, n, k++, local_types[i] << SCHEME_INFO_TYPED_VAL_SHIFT, lifted[i]);
} }
body = scheme_resolve_expr(body, linfo); body = scheme_resolve_expr(body, linfo);
@ -1666,7 +1670,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
XFORM_NONGCING static int boxmap_size(int n) XFORM_NONGCING static int boxmap_size(int n)
{ {
return ((2 * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT; return ((CLOS_TYPE_BITS_PER_ARG * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT;
} }
static mzshort *allocate_boxmap(int n) static mzshort *allocate_boxmap(int n)
@ -1681,17 +1685,17 @@ static mzshort *allocate_boxmap(int n)
return boxmap; return boxmap;
} }
XFORM_NONGCING static void boxmap_set(mzshort *boxmap, int j, int bit, int delta) void scheme_boxmap_set(mzshort *boxmap, int j, int bit, int delta)
{ {
boxmap[delta + ((2 * j) / BITS_PER_MZSHORT)] |= ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1))); j *= CLOS_TYPE_BITS_PER_ARG;
boxmap[delta + (j / BITS_PER_MZSHORT)] |= ((mzshort)bit << (j & (BITS_PER_MZSHORT - 1)));
} }
XFORM_NONGCING static int boxmap_get(mzshort *boxmap, int j, int bit, int delta) int scheme_boxmap_get(mzshort *boxmap, int j, int delta)
{ {
if (boxmap[delta + ((2 * j) / BITS_PER_MZSHORT)] & ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1)))) j *= CLOS_TYPE_BITS_PER_ARG;
return 1; return (boxmap[delta + (j / BITS_PER_MZSHORT)] >> (j & (BITS_PER_MZSHORT - 1))
else & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1));
return 0;
} }
static int is_nonconstant_procedure(Scheme_Object *_data, Resolve_Info *info, int skip) static int is_nonconstant_procedure(Scheme_Object *_data, Resolve_Info *info, int skip)
@ -1764,24 +1768,24 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
closure. */ closure. */
closure_size = data->closure_size; closure_size = data->closure_size;
if (cl->flonum_map) { if (cl->local_type_map) {
int at_least_one = 0; int at_least_one = 0;
for (i = data->num_params; i--; ) { for (i = data->num_params; i--; ) {
if (cl->flonum_map[i]) { if (cl->local_type_map[i]) {
if (cl->local_flags[i] & SCHEME_WAS_FLONUM_ARGUMENT) if (SCHEME_WAS_TYPED_ARGUMENT(cl->local_flags[i]) == cl->local_type_map[i])
at_least_one = 1; at_least_one = 1;
else else
cl->flonum_map[i] = 0; cl->local_type_map[i] = 0;
} }
} }
if (at_least_one) { if (at_least_one) {
closure_size += boxmap_size(data->num_params + closure_size); closure_size += boxmap_size(data->num_params + closure_size);
expanded_already = 1; expanded_already = 1;
} else } else
cl->flonum_map = NULL; cl->local_type_map = NULL;
} }
closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size);
if (cl->flonum_map) if (cl->local_type_map)
memset(closure_map, 0, sizeof(mzshort) * closure_size); memset(closure_map, 0, sizeof(mzshort) * closure_size);
has_tl = cl->has_tl; has_tl = cl->has_tl;
@ -1809,17 +1813,21 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
} }
} else { } else {
closure_map[offset] = li; closure_map[offset] = li;
if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_FLONUM_ARG))) { if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_TYPED_VAL_MASK))) {
/* The only problem with a boxed/flonum variable is that /* The only problem with a boxed/local_type variable is that
it's more difficult to validate. We have to track it's more difficult to validate. We have to track
which arguments are boxes. And the resulting procedure which arguments are boxes. And the resulting procedure
must be used only in application positions. */ must be used only in application positions. */
if (!convert_boxes) if (!convert_boxes)
convert_boxes = allocate_boxmap(cl->base_closure_size); convert_boxes = allocate_boxmap(cl->base_closure_size);
boxmap_set(convert_boxes, offset, (flags & SCHEME_INFO_BOXED) ? 1 : 2, 0); scheme_boxmap_set(convert_boxes, offset,
((flags & SCHEME_INFO_BOXED)
? CLOS_TYPE_BOXED
: CLOS_TYPE_TYPE_OFFSET + (flags >> SCHEME_INFO_TYPED_VAL_SHIFT)),
0);
} else { } else {
/* Currently, we only need flonum information as a closure type */ /* Currently, we only need local_type information as a closure type */
if (flags & SCHEME_INFO_FLONUM_ARG) { if (flags & SCHEME_INFO_TYPED_VAL_MASK) {
if (!expanded_already) { if (!expanded_already) {
closure_size += boxmap_size(data->num_params + closure_size); closure_size += boxmap_size(data->num_params + closure_size);
new_closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); new_closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size);
@ -1828,7 +1836,9 @@ 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, 2, data->closure_size); scheme_boxmap_set(closure_map, data->num_params + offset,
CLOS_TYPE_TYPE_OFFSET + (flags >> SCHEME_INFO_TYPED_VAL_SHIFT),
data->closure_size);
} }
} }
offset++; offset++;
@ -1838,25 +1848,22 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
/* Add bindings introduced by closure conversion. The `captured' /* Add bindings introduced by closure conversion. The `captured'
table maps old positions to new positions. */ table maps old positions to new positions. */
while (lifteds) { while (lifteds) {
int j, cnt, boxed, flonumed; int j, cnt, local_typed;
Scheme_Object *vec, *loc; Scheme_Object *vec, *loc;
if (!captured) { if (!captured) {
captured = scheme_make_hash_table(SCHEME_hash_ptr); captured = scheme_make_hash_table(SCHEME_hash_ptr);
for (i = 0; i < offset; i++) { for (i = 0; i < offset; i++) {
int cp; int cp, v;
cp = i; cp = i;
if (convert_boxes) { if (convert_boxes) {
if (boxmap_get(convert_boxes, i, 1, 0)) v = scheme_boxmap_get(convert_boxes, i, 0);
cp = -((2 * cp) + 1);
else if (boxmap_get(convert_boxes, i, 2, 0))
cp = -((2 * cp) + 2);
} else if (expanded_already) { } else if (expanded_already) {
if (boxmap_get(closure_map, data->num_params + i, 1, data->closure_size)) v = scheme_boxmap_get(closure_map, data->num_params + i, data->closure_size);
cp = -((2 * cp) + 1); } else
else if (boxmap_get(closure_map, data->num_params + i, 2, data->closure_size)) v = 0;
cp = -((2 * cp) + 2); if (v)
} cp = -((cp << CLOS_TYPE_BITS_PER_ARG) + v);
scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp)); scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp));
} }
} }
@ -1869,25 +1876,20 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
loc = SCHEME_VEC_ELS(vec)[j+1]; loc = SCHEME_VEC_ELS(vec)[j+1];
if (SCHEME_BOXP(loc)) { if (SCHEME_BOXP(loc)) {
loc = SCHEME_BOX_VAL(loc); loc = SCHEME_BOX_VAL(loc);
boxed = 1; local_typed = CLOS_TYPE_BOXED;
flonumed = 0;
} else if (SCHEME_VECTORP(loc)) { } else if (SCHEME_VECTORP(loc)) {
local_typed = SCHEME_INT_VAL(SCHEME_VEC_ELS(loc)[1]);
loc = SCHEME_VEC_ELS(loc)[0]; loc = SCHEME_VEC_ELS(loc)[0];
boxed = 0;
flonumed = 1;
} else { } else {
boxed = 0; local_typed = 0;
flonumed = 0;
} }
i = SCHEME_LOCAL_POS(loc); i = SCHEME_LOCAL_POS(loc);
if (!scheme_hash_get(captured, scheme_make_integer(i))) { if (!scheme_hash_get(captured, scheme_make_integer(i))) {
/* Need to capture an extra binding: */ /* Need to capture an extra binding: */
int cp; int cp;
cp = captured->count; cp = captured->count;
if (boxed) if (local_typed)
cp = -((2 * cp) + 1); cp = -((cp << CLOS_TYPE_BITS_PER_ARG) + local_typed);
else if (flonumed)
cp = -((2 * cp) + 2);
scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp)); scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp));
} }
} }
@ -1900,7 +1902,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
is in captured, so just build it from scratch. */ is in captured, so just build it from scratch. */
int old_pos, j, new_size, need_flags; int old_pos, j, new_size, need_flags;
new_size = (captured->count + (has_tl ? 1 : 0)); new_size = (captured->count + (has_tl ? 1 : 0));
if (cl->flonum_map || expanded_already || convert_boxes) { if (cl->local_type_map || expanded_already || convert_boxes) {
need_flags = new_size; need_flags = new_size;
new_size += boxmap_size(data->num_params + new_size); new_size += boxmap_size(data->num_params + new_size);
} else } else
@ -1916,21 +1918,16 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
cp = SCHEME_INT_VAL(captured->vals[j]); cp = SCHEME_INT_VAL(captured->vals[j]);
old_pos = SCHEME_INT_VAL(captured->keys[j]); old_pos = SCHEME_INT_VAL(captured->keys[j]);
if (cp < 0) { if (cp < 0) {
/* Boxed or flonum */ /* Boxed or local_type */
int bit; int bit;
cp = -cp; cp = -cp;
if (cp & 0x1) { bit = cp & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1);
cp = (cp - 1) / 2; cp >>= CLOS_TYPE_BITS_PER_ARG;
bit = 1;
} else {
cp = (cp - 2) / 2;
bit = 2;
}
if (!convert_boxes) if (!convert_boxes)
convert_boxes = allocate_boxmap(offset); convert_boxes = allocate_boxmap(offset);
boxmap_set(convert_boxes, cp, bit, 0); scheme_boxmap_set(convert_boxes, cp, bit, 0);
if (need_flags) if (need_flags)
boxmap_set(closure_map, cp, bit, need_flags); scheme_boxmap_set(closure_map, cp, bit, need_flags);
} }
closure_map[cp] = old_pos; closure_map[cp] = old_pos;
} }
@ -1944,7 +1941,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
convert_map = closure_map; convert_map = closure_map;
convert_size = offset; convert_size = offset;
if (has_tl || convert_boxes || cl->flonum_map) { if (has_tl || convert_boxes || cl->local_type_map) {
int new_boxes_size; int new_boxes_size;
int sz; int sz;
new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0));
@ -2014,12 +2011,14 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
(((cl->local_flags[i] & SCHEME_WAS_SET_BANGED) (((cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
? SCHEME_INFO_BOXED ? SCHEME_INFO_BOXED
: 0) : 0)
| ((cl->flonum_map && cl->flonum_map[i]) | ((convert && (cl->local_type_map && cl->local_type_map[i]))
? SCHEME_INFO_FLONUM_ARG ? (cl->local_type_map[i] << SCHEME_INFO_TYPED_VAL_SHIFT)
: 0)), : 0)),
NULL); NULL);
if (cl->flonum_map && cl->flonum_map[i] && !just_compute_lift) if (convert && cl->local_type_map && cl->local_type_map[i] && !just_compute_lift)
boxmap_set(closure_map, i + convert_size, 2, closure_size); scheme_boxmap_set(closure_map, i + convert_size,
cl->local_type_map[i] + CLOS_TYPE_TYPE_OFFSET,
closure_size);
} }
if (expanded_already && !just_compute_lift) if (expanded_already && !just_compute_lift)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS;
@ -2063,36 +2062,37 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
--sz; --sz;
cmap = MALLOC_N_ATOMIC(mzshort, sz); cmap = MALLOC_N_ATOMIC(mzshort, sz);
for (j = 0; j < sz; j++) { for (j = 0; j < sz; j++) {
int is_boxed = 0, is_flonum = 0; int is_boxed = 0, is_local_type = 0;
loc = SCHEME_VEC_ELS(vec)[j+1]; loc = SCHEME_VEC_ELS(vec)[j+1];
if (SCHEME_BOXP(loc)) { if (SCHEME_BOXP(loc)) {
if (!boxmap) if (!boxmap)
boxmap = allocate_boxmap(sz); boxmap = allocate_boxmap(sz);
boxmap_set(boxmap, j, 1, 0); scheme_boxmap_set(boxmap, j, CLOS_TYPE_BOXED, 0);
loc = SCHEME_BOX_VAL(loc); loc = SCHEME_BOX_VAL(loc);
is_boxed = 1; is_boxed = 1;
} else if (SCHEME_VECTORP(loc)) { } else if (SCHEME_VECTORP(loc)) {
if (!boxmap) if (!boxmap)
boxmap = allocate_boxmap(sz); boxmap = allocate_boxmap(sz);
boxmap_set(boxmap, j, 2, 0); scheme_boxmap_set(boxmap, j, SCHEME_INT_VAL(SCHEME_VEC_ELS(loc)[1]), 0);
loc = SCHEME_VEC_ELS(loc)[0]; loc = SCHEME_VEC_ELS(loc)[0];
is_flonum = 1; is_local_type = 1;
} }
loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc))); loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc)));
cp = SCHEME_INT_VAL(loc); cp = SCHEME_INT_VAL(loc);
if (cp < 0) { if (cp < 0) {
int v;
cp = -cp; cp = -cp;
if (cp & 0x1) { v = cp & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1);
cp = (cp - 1) / 2; cp >>= CLOS_TYPE_BITS_PER_ARG;
if (v == CLOS_TYPE_BOXED) {
if (convert && !is_boxed) if (convert && !is_boxed)
scheme_signal_error("internal error: lift mismatch (boxed)"); scheme_signal_error("internal error: lift mismatch (boxed)");
} else { } else {
cp = (cp - 2) / 2; if (convert && !is_local_type)
if (convert && !is_flonum) scheme_signal_error("internal error: lift mismatch (local type) %d", v);
scheme_signal_error("internal error: lift mismatch (flonum)");
} }
} else { } else {
if (convert && (is_boxed || is_flonum)) if (convert && (is_boxed || is_local_type))
scheme_signal_error("internal error: lift mismatch"); scheme_signal_error("internal error: lift mismatch");
} }
cmap[j] = cp + (has_tl && convert ? 1 : 0); cmap[j] = cp + (has_tl && convert ? 1 : 0);
@ -2368,8 +2368,10 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
? scheme_local_unbox_type ? scheme_local_unbox_type
: scheme_local_type, : scheme_local_type,
pos, pos,
((flags & SCHEME_INFO_FLONUM_ARG) ((flags & SCHEME_INFO_TYPED_VAL_MASK)
? SCHEME_LOCAL_FLONUM ? (SCHEME_LOCAL_TYPE_OFFSET
+ ((flags & SCHEME_INFO_TYPED_VAL_MASK)
>> SCHEME_INFO_TYPED_VAL_SHIFT))
: 0)); : 0));
} }
} }
@ -2886,15 +2888,16 @@ static int do_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Schem
boxmap = (mzshort *)ca[3]; boxmap = (mzshort *)ca[3];
vec = scheme_make_vector(sz + 1, NULL); vec = scheme_make_vector(sz + 1, NULL);
for (i = 0; i < sz; i++) { for (i = 0; i < sz; i++) {
int boxed = 0, flonumed = 0, flags = 0; int boxed = 0, local_typed = 0, flags = 0;
if (boxmap) { if (boxmap) {
int byte = boxmap[(2 * i) / BITS_PER_MZSHORT]; int lt;
if (byte & ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) lt = scheme_boxmap_get(boxmap, i, 0);
if (lt == CLOS_TYPE_BOXED) {
boxed = 1; boxed = 1;
if (byte & ((mzshort)2 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) { } else if (lt) {
flonumed = 1; local_typed = lt;
flags = SCHEME_LOCAL_FLONUM; flags = ((lt - CLOS_TYPE_TYPE_OFFSET) + SCHEME_LOCAL_TYPE_OFFSET);
} }
} }
@ -2904,8 +2907,10 @@ static int do_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Schem
if (boxed) if (boxed)
loc = scheme_box(loc); loc = scheme_box(loc);
else if (flonumed) else if (local_typed) {
loc = scheme_make_vector(1, loc); loc = scheme_make_vector(2, loc);
SCHEME_VEC_ELS(loc)[1] = scheme_make_integer(local_typed);
}
SCHEME_VEC_ELS(vec)[i+1] = loc; SCHEME_VEC_ELS(vec)[i+1] = loc;
} }

2
src/racket/src/schcpt.h
View File

@ -19,7 +19,7 @@ enum {
CPT_VECTOR, CPT_VECTOR,
CPT_HASH_TABLE, CPT_HASH_TABLE,
CPT_STX, CPT_STX,
CPT_LET_ONE_FLONUM, CPT_LET_ONE_TYPED,
CPT_MARSHALLED, /* 20 */ CPT_MARSHALLED, /* 20 */
CPT_QUOTE, CPT_QUOTE,
CPT_REFERENCE, CPT_REFERENCE,

73
src/racket/src/schpriv.h
View File

@ -1270,8 +1270,21 @@ typedef struct {
Scheme_Object *body; Scheme_Object *body;
} Scheme_With_Continuation_Mark; } Scheme_With_Continuation_Mark;
/* Used with SCHEME_LOCAL_TYPE_MASK, LET_ONE_TYPE_MASK, etc.*/
#define SCHEME_LOCAL_TYPE_FLONUM 1
#define SCHEME_LOCAL_TYPE_FIXNUM 2
#define SCHEME_MAX_LOCAL_TYPE 2
#define SCHEME_MAX_LOCAL_TYPE_MASK 0x3
#define SCHEME_MAX_LOCAL_TYPE_BITS 2
/* Flonum unboxing is only useful if a value is going to flow to a
function that wants it, otherwise we'll have to box the flonum anyway.
Fixnum unboxing is always fine, since it's easy to box. */
#define ALWAYS_PREFER_UNBOX_TYPE(ty) ((ty) == SCHEME_LOCAL_TYPE_FIXNUM)
typedef struct Scheme_Local { typedef struct Scheme_Local {
Scheme_Inclhash_Object iso; /* keyex used for clear-on-read flag */ Scheme_Inclhash_Object iso; /* keyex used for flags and type info (and can't be hashed) */
mzshort position; mzshort position;
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
# ifdef MZSHORT_IS_SHORT # ifdef MZSHORT_IS_SHORT
@ -1284,12 +1297,12 @@ typedef struct Scheme_Local {
#define SCHEME_LOCAL_POS(obj) (((Scheme_Local *)(obj))->position) #define SCHEME_LOCAL_POS(obj) (((Scheme_Local *)(obj))->position)
#define SCHEME_LOCAL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Local *)(obj))->iso) #define SCHEME_LOCAL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Local *)(obj))->iso)
#define SCHEME_LOCAL_CLEAR_ON_READ 0x1 #define SCHEME_LOCAL_CLEAR_ON_READ 1
#define SCHEME_LOCAL_OTHER_CLEARS 0x2 #define SCHEME_LOCAL_OTHER_CLEARS 2
#define SCHEME_LOCAL_FLONUM 0x3 #define SCHEME_LOCAL_TYPE_OFFSET 2
#define SCHEME_LOCAL_FLAGS_MASK 0x3
#define SCHEME_GET_LOCAL_FLAGS(obj) (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_FLAGS_MASK) #define SCHEME_GET_LOCAL_FLAGS(obj) SCHEME_LOCAL_FLAGS(obj)
#define SCHEME_GET_LOCAL_TYPE(obj) ((SCHEME_LOCAL_FLAGS(obj) > 2) ? (SCHEME_LOCAL_FLAGS(obj) - 2) : 0)
typedef struct Scheme_Toplevel { typedef struct Scheme_Toplevel {
Scheme_Inclhash_Object iso; /* keyex used for flags (and can't be hashed) */ Scheme_Inclhash_Object iso; /* keyex used for flags (and can't be hashed) */
@ -1350,8 +1363,11 @@ typedef struct Scheme_Let_One {
} Scheme_Let_One; } Scheme_Let_One;
#define SCHEME_LET_EVAL_TYPE(lh) MZ_OPT_HASH_KEY(&lh->iso) #define SCHEME_LET_EVAL_TYPE(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define LET_ONE_FLONUM 0x8 #define LET_ONE_UNUSED 0x8
#define LET_ONE_UNUSED 0x10
#define LET_ONE_TYPE_SHIFT 4
#define LET_ONE_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << 4)
#define SCHEME_LET_ONE_TYPE(lo) (SCHEME_LET_EVAL_TYPE(lo) >> LET_ONE_TYPE_SHIFT)
typedef struct Scheme_Let_Void { typedef struct Scheme_Let_Void {
Scheme_Inclhash_Object iso; /* keyex used for autobox */ Scheme_Inclhash_Object iso; /* keyex used for autobox */
@ -2293,9 +2309,9 @@ typedef struct Scheme_Comp_Env
#define CLOS_IS_METHOD 16 #define CLOS_IS_METHOD 16
#define CLOS_SINGLE_RESULT 32 #define CLOS_SINGLE_RESULT 32
#define CLOS_RESULT_TENTATIVE 64 #define CLOS_RESULT_TENTATIVE 64
#define CLOS_SFS 128
#define CLOS_VALIDATED 128 #define CLOS_VALIDATED 128
/* BITS 8-15 used by write_compiled_closure() */ #define CLOS_SFS 256
/* BITS 8-15 (overlaps CLOS_SFS) used by write_compiled_closure() */
typedef struct Scheme_Compile_Expand_Info typedef struct Scheme_Compile_Expand_Info
{ {
@ -2338,8 +2354,8 @@ typedef struct {
int *local_flags; /* for arguments from compile pass, flonum info updated in optimize pass */ int *local_flags; /* for arguments from compile pass, flonum info updated in optimize pass */
mzshort base_closure_size; /* doesn't include top-level (if any) */ mzshort base_closure_size; /* doesn't include top-level (if any) */
mzshort *base_closure_map; mzshort *base_closure_map;
char *flonum_map; /* NULL when has_flomap set => no flonums */ char *local_type_map; /* NULL when has_tymap set => no local types */
char has_tl, has_flomap, has_nonleaf; char has_tl, has_tymap, has_nonleaf;
int body_size, body_psize; int body_size, body_psize;
} Closure_Info; } Closure_Info;
@ -2362,7 +2378,7 @@ typedef struct Scheme_Closure_Data
mzshort max_let_depth; mzshort max_let_depth;
mzshort closure_size; mzshort closure_size;
mzshort *closure_map; /* actually a Closure_Info* until resolved; if CLOS_HAS_TYPED_ARGS, mzshort *closure_map; /* actually a Closure_Info* until resolved; if CLOS_HAS_TYPED_ARGS,
followed by bit array with 2 bits per args then per closed-over */ followed by bit array with CLOS_TYPE_BITS_PER_ARG bits per args then per closed-over */
Scheme_Object *code; Scheme_Object *code;
Scheme_Object *name; /* name or (vector name src line col pos span generated?) */ Scheme_Object *name; /* name or (vector name src line col pos span generated?) */
void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */
@ -2377,6 +2393,13 @@ typedef struct Scheme_Closure_Data
#define SCHEME_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso) #define SCHEME_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso)
#define CLOS_TYPE_BITS_PER_ARG 4
#define CLOS_TYPE_BOXED 1
#define CLOS_TYPE_TYPE_OFFSET 1
XFORM_NONGCING void scheme_boxmap_set(mzshort *boxmap, int j, int bit, int delta);
XFORM_NONGCING int scheme_boxmap_get(mzshort *boxmap, int j, int delta);
int scheme_has_method_property(Scheme_Object *code); int scheme_has_method_property(Scheme_Object *code);
typedef struct { typedef struct {
@ -2491,8 +2514,7 @@ Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, i
#define MAX_CONST_LOCAL_POS 64 #define MAX_CONST_LOCAL_POS 64
#define MAX_CONST_LOCAL_TYPES 2 #define MAX_CONST_LOCAL_TYPES 2
#define MAX_CONST_LOCAL_FLAG_VAL 3 #define MAX_CONST_LOCAL_FLAG_VAL (2 + SCHEME_MAX_LOCAL_TYPE)
#define SCHEME_LOCAL_FLAGS_MASK 0x3
#define MAX_CONST_TOPLEVEL_DEPTH 16 #define MAX_CONST_TOPLEVEL_DEPTH 16
#define MAX_CONST_TOPLEVEL_POS 16 #define MAX_CONST_TOPLEVEL_POS 16
@ -2663,11 +2685,13 @@ Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context); Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context); Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context);
#define OPT_CONTEXT_FLONUM_ARG 0x1 #define OPT_CONTEXT_BOOLEAN 0x1
#define OPT_CONTEXT_BOOLEAN 0x2 #define OPT_CONTEXT_NO_SINGLE 0x2
#define OPT_CONTEXT_NO_SINGLE 0x4 #define OPT_CONTEXT_TYPE_SHIFT 3
#define OPT_CONTEXT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << OPT_CONTEXT_TYPE_SHIFT)
#define OPT_CONTEXT_TYPE(oc) ((oc & OPT_CONTEXT_TYPE_MASK) >> OPT_CONTEXT_TYPE_SHIFT)
#define scheme_optimize_result_context(c) (c & (~(OPT_CONTEXT_FLONUM_ARG | OPT_CONTEXT_NO_SINGLE))) #define scheme_optimize_result_context(c) (c & (~(OPT_CONTEXT_TYPE_MASK | OPT_CONTEXT_NO_SINGLE)))
#define scheme_optimize_tail_context(c) scheme_optimize_result_context(c) #define scheme_optimize_tail_context(c) scheme_optimize_result_context(c)
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
@ -2711,8 +2735,7 @@ Scheme_Logger *scheme_optimize_info_logger(Optimize_Info *);
Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags);
int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos); int scheme_expr_produces_local_type(Scheme_Object *expr);
int scheme_expr_produces_flonum(Scheme_Object *expr);
Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax, Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax,
Scheme_Syntax_Expander *exp); Scheme_Syntax_Expander *exp);
@ -2794,15 +2817,19 @@ int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos);
#define SCHEME_WAS_SET_BANGED 0x2 #define SCHEME_WAS_SET_BANGED 0x2
#define SCHEME_WAS_ONLY_APPLIED 0x4 #define SCHEME_WAS_ONLY_APPLIED 0x4
#define SCHEME_WAS_APPLIED_EXCEPT_ONCE 0x8 #define SCHEME_WAS_APPLIED_EXCEPT_ONCE 0x8
#define SCHEME_WAS_FLONUM_ARGUMENT 0x80
#define SCHEME_USE_COUNT_MASK 0x70 #define SCHEME_USE_COUNT_MASK 0x70
#define SCHEME_USE_COUNT_SHIFT 4 #define SCHEME_USE_COUNT_SHIFT 4
#define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT) #define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
#define SCHEME_WAS_TYPED_ARGUMENT_SHIFT 7
#define SCHEME_WAS_TYPED_ARGUMENT_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_WAS_TYPED_ARGUMENT_SHIFT)
#define SCHEME_WAS_TYPED_ARGUMENT(f) ((f & SCHEME_WAS_TYPED_ARGUMENT_MASK) >> SCHEME_WAS_TYPED_ARGUMENT_SHIFT)
/* flags reported by scheme_resolve_info_flags */ /* flags reported by scheme_resolve_info_flags */
#define SCHEME_INFO_BOXED 0x1 #define SCHEME_INFO_BOXED 0x1
#define SCHEME_INFO_FLONUM_ARG 0x2 #define SCHEME_INFO_TYPED_VAL_SHIFT 4
#define SCHEME_INFO_TYPED_VAL_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_INFO_TYPED_VAL_SHIFT)
/* flags used with scheme_new_frame */ /* flags used with scheme_new_frame */
#define SCHEME_TOPLEVEL_FRAME 1 #define SCHEME_TOPLEVEL_FRAME 1

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.3.1.6" #define MZSCHEME_VERSION "5.3.1.7"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 6 #define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

4
src/racket/src/sfs.c
View File

@ -697,7 +697,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
et = scheme_get_eval_type(lo->value); et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = (et SCHEME_LET_EVAL_TYPE(lo) = (et
| (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)) | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_TYPE_MASK))
| (unused ? LET_ONE_UNUSED : 0)); | (unused ? LET_ONE_UNUSED : 0));
return o; return o;
@ -1188,7 +1188,7 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_
case scheme_local_unbox_type: case scheme_local_unbox_type:
if (!info->pass) if (!info->pass)
scheme_sfs_used(info, SCHEME_LOCAL_POS(expr)); scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) { else if (!SCHEME_GET_LOCAL_TYPE(expr)) {
int pos, at_ip; int pos, at_ip;
pos = SCHEME_LOCAL_POS(expr); pos = SCHEME_LOCAL_POS(expr);
at_ip = info->max_used[info->stackpos + pos]; at_ip = info->max_used[info->stackpos + pos];

120
src/racket/src/validate.c
View File

@ -41,7 +41,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
mzshort *tl_state, mzshort tl_timestamp, mzshort *tl_state, mzshort tl_timestamp,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, struct Validate_Clearing *vc, int result_ignored, struct Validate_Clearing *vc,
int tailpos, int need_flonum, Scheme_Hash_Tree *procs, int tailpos, int need_local_type, Scheme_Hash_Tree *procs,
int expected_results, int expected_results,
Scheme_Hash_Table **_st_ht); Scheme_Hash_Table **_st_ht);
static int validate_rator_wants_box(Scheme_Object *app_rator, int pos, static int validate_rator_wants_box(Scheme_Object *app_rator, int pos,
@ -67,7 +67,7 @@ void scheme_init_validate()
#define VALID_TOPLEVELS 4 #define VALID_TOPLEVELS 4
#define VALID_VAL_NOCLEAR 5 #define VALID_VAL_NOCLEAR 5
#define VALID_BOX_NOCLEAR 6 #define VALID_BOX_NOCLEAR 6
#define VALID_FLONUM 7 #define VALID_TYPED 7
typedef struct Validate_Clearing { typedef struct Validate_Clearing {
MZTAG_IF_REQUIRED MZTAG_IF_REQUIRED
@ -342,8 +342,9 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
new_a[0] = -sz; new_a[0] = -sz;
new_a[sz+1] = !!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST); new_a[sz+1] = !!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST);
for (i = 0; i < sz; i++) { for (i = 0; i < sz; i++) {
int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); int ct;
if (data->closure_map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) ct = scheme_boxmap_get(data->closure_map, i, data->closure_size);
if (ct == CLOS_TYPE_BOXED)
new_a[i + 1] = 1; new_a[i + 1] = 1;
else else
new_a[i + 1] = 0; new_a[i + 1] = 0;
@ -852,8 +853,9 @@ int validate_rator_wants_box(Scheme_Object *app_rator, int pos,
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
if (pos < data->num_params) { if (pos < data->num_params) {
int bit = ((mzshort)1 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); int ct;
if (data->closure_map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) ct = scheme_boxmap_get(data->closure_map, pos, data->closure_size);
if (ct == CLOS_TYPE_BOXED)
return 1; return 1;
} }
} }
@ -990,12 +992,13 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
cnt = data->num_params; cnt = data->num_params;
base = sz - cnt; base = sz - cnt;
for (i = 0; i < cnt; i++) { for (i = 0; i < cnt; i++) {
int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); int ct;
if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) { ct = scheme_boxmap_get(map, i, data->closure_size);
if (ct == CLOS_TYPE_BOXED) {
vld = VALID_BOX; vld = VALID_BOX;
typed_arg = 1; typed_arg = 1;
} else if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & (bit << 1)) { } else if (ct) {
vld = VALID_FLONUM; vld = (VALID_TYPED + (ct - CLOS_TYPE_TYPE_OFFSET));
typed_arg = 1; typed_arg = 1;
} else } else
vld = VALID_VAL; vld = VALID_VAL;
@ -1024,13 +1027,14 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr,
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
int pos = data->num_params + i; int pos = data->num_params + i;
int bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); int ct;
if (map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) { ct = scheme_boxmap_get(map, pos, data->closure_size);
if (vld != VALID_FLONUM) if (ct > CLOS_TYPE_TYPE_OFFSET) {
if (vld != (VALID_TYPED + (ct - CLOS_TYPE_TYPE_OFFSET)))
vld = VALID_NOT; vld = VALID_NOT;
} else if (vld == VALID_FLONUM) } else if (vld > VALID_TYPED)
vld = VALID_NOT; vld = VALID_NOT;
} else if (vld == VALID_FLONUM) } else if (vld > VALID_TYPED)
vld = VALID_NOT; vld = VALID_NOT;
closure_stack[i + base] = vld; closure_stack[i + base] = vld;
@ -1151,15 +1155,15 @@ static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port,
{ {
} }
static void no_flo(int need_flonum, Mz_CPort *port) static void no_typed(int need_local_type, Mz_CPort *port)
{ {
if (need_flonum) scheme_ill_formed_code(port); if (need_local_type) scheme_ill_formed_code(port);
} }
static void check_flo(Scheme_Object *expr, int need_flonum, Mz_CPort *port) static void check_typed(Scheme_Object *expr, int need_local_type, Mz_CPort *port)
{ {
if (need_flonum) { if (need_local_type) {
if (!scheme_expr_produces_flonum(expr)) if (scheme_expr_produces_local_type(expr) != need_local_type)
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
} }
} }
@ -1187,7 +1191,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, int result_ignored,
struct Validate_Clearing *vc, int tailpos, struct Validate_Clearing *vc, int tailpos,
int need_flonum, Scheme_Hash_Tree *procs, int need_local_type, Scheme_Hash_Tree *procs,
int expected_results, int expected_results,
Scheme_Hash_Table **_st_ht) Scheme_Hash_Table **_st_ht)
/* result is 1 if result is `expected_results' values with no /* result is 1 if result is `expected_results' values with no
@ -1228,7 +1232,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
args[6] = proc_with_refs_ok; args[6] = proc_with_refs_ok;
args[7] = result_ignored; args[7] = result_ignored;
args[8] = tailpos; args[8] = tailpos;
args[9] = need_flonum; args[9] = need_local_type;
args[10] = tl_timestamp; args[10] = tl_timestamp;
args[11] = expected_results; args[11] = expected_results;
@ -1276,7 +1280,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
int p = SCHEME_TOPLEVEL_POS(expr); int p = SCHEME_TOPLEVEL_POS(expr);
int flags = (SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); int flags = (SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
no_flo(need_flonum, port); no_typed(need_local_type, port);
if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) if ((c < 0) || (p < 0) || (d < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS) || (stack[d] != VALID_TOPLEVELS)
@ -1364,21 +1368,23 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
{ {
int q = SCHEME_LOCAL_POS(expr); int q = SCHEME_LOCAL_POS(expr);
int p = q + delta; int p = q + delta;
int ct;
if ((q < 0) || (p >= depth) || (p < 0)) if ((q < 0) || (p >= depth) || (p < 0))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) ct = SCHEME_GET_LOCAL_TYPE(expr);
no_flo(need_flonum, port); if (!ct)
no_typed(need_local_type, port);
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) { if (ct) {
if (stack[p] != VALID_FLONUM) if (stack[p] != (VALID_TYPED + ct))
scheme_ill_formed_code(port); scheme_ill_formed_code(port);
} else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) { } else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) {
if (result_ignored && ((stack[p] == VALID_BOX) if (result_ignored && ((stack[p] == VALID_BOX)
|| (stack[p] == VALID_BOX_NOCLEAR) || (stack[p] == VALID_BOX_NOCLEAR)
|| (stack[p] == VALID_FLONUM))) { || (stack[p] >= VALID_TYPED))) {
/* ok to look up and ignore box or flonum */ /* ok to look up and ignore box or typed */
} else if ((proc_with_refs_ok >= 2) } else if ((proc_with_refs_ok >= 2)
&& ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR))
&& validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1, && validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1,
@ -1422,7 +1428,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
int q = SCHEME_LOCAL_POS(expr); int q = SCHEME_LOCAL_POS(expr);
int p = q + delta; int p = q + delta;
no_flo(need_flonum, port); no_typed(need_local_type, port);
if ((q < 0) || (p >= depth) || (p < 0) if ((q < 0) || (p >= depth) || (p < 0)
|| ((stack[p] != VALID_BOX) || ((stack[p] != VALID_BOX)
@ -1451,7 +1457,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_App_Rec *app = (Scheme_App_Rec *)expr; Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
int i, n, r; int i, n, r;
check_flo(expr, need_flonum, port); check_typed(expr, need_local_type, port);
n = app->num_args + 1; n = app->num_args + 1;
@ -1482,7 +1488,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
int r; int r;
check_flo(expr, need_flonum, port); check_typed(expr, need_local_type, port);
delta -= 1; delta -= 1;
if (delta < 0) if (delta < 0)
@ -1514,7 +1520,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
int r; int r;
check_flo(expr, need_flonum, port); check_typed(expr, need_local_type, port);
delta -= 2; delta -= 2;
if (delta < 0) if (delta < 0)
@ -1554,7 +1560,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
int cnt; int cnt;
int i, r; int i, r;
no_flo(need_flonum, port); no_typed(need_local_type, port);
cnt = seq->count; cnt = seq->count;
@ -1575,7 +1581,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
int vc_pos, vc_ncpos, r; int vc_pos, vc_ncpos, r;
no_flo(need_flonum, port); no_typed(need_local_type, port);
b = (Scheme_Branch_Rec *)expr; b = (Scheme_Branch_Rec *)expr;
r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta, r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta,
@ -1633,7 +1639,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr;
int r; int r;
no_flo(need_flonum, port); no_typed(need_local_type, port);
r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -1658,7 +1664,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
int p = qs->midpoint; int p = qs->midpoint;
int d = c + delta; int d = c + delta;
no_flo(need_flonum, port); no_typed(need_local_type, port);
if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) if ((c < 0) || (p < 0) || (d < 0) || (d >= depth)
|| (stack[d] != VALID_TOPLEVELS) || (stack[d] != VALID_TOPLEVELS)
@ -1671,7 +1677,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
break; break;
case scheme_unclosed_procedure_type: case scheme_unclosed_procedure_type:
{ {
no_flo(need_flonum, port); no_typed(need_local_type, port);
validate_unclosed_procedure(port, expr, stack, tls, depth, delta, validate_unclosed_procedure(port, expr, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1794,7 +1800,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
r = validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, r = validate_expr(port, lo->value, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs, NULL, 0, 0, vc, 0, SCHEME_LET_ONE_TYPE(lo), procs,
1, NULL); 1, NULL);
result = validate_join_seq(r, result); result = validate_join_seq(r, result);
@ -1805,8 +1811,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED) { if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED) {
stack[delta] = VALID_NOT; stack[delta] = VALID_NOT;
} else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) { } else if (SCHEME_LET_ONE_TYPE(lo)) {
stack[delta] = VALID_FLONUM; stack[delta] = (VALID_TYPED + SCHEME_LET_ONE_TYPE(lo));
/* FIXME: need to check that lo->value produces a flonum */ /* FIXME: need to check that lo->value produces a flonum */
} else } else
stack[delta] = VALID_VAL; stack[delta] = VALID_VAL;
@ -1817,7 +1823,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
break; break;
case scheme_define_values_type: case scheme_define_values_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
result = validate_join_seq(result, result = validate_join_seq(result,
define_values_validate(expr, port, stack, tls, depth, letlimit, delta, define_values_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -1826,21 +1832,21 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
_st_ht)); _st_ht));
break; break;
case scheme_define_syntaxes_type: case scheme_define_syntaxes_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
result_ignored, vc, tailpos, procs); result_ignored, vc, tailpos, procs);
break; break;
case scheme_begin_for_syntax_type: case scheme_begin_for_syntax_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
result_ignored, vc, tailpos, procs); result_ignored, vc, tailpos, procs);
break; break;
case scheme_set_bang_type: case scheme_set_bang_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
result = validate_join_seq(result, result = validate_join_seq(result,
set_validate(expr, port, stack, tls, depth, letlimit, delta, set_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -1848,7 +1854,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result_ignored, vc, tailpos, procs)); result_ignored, vc, tailpos, procs));
break; break;
case scheme_boxenv_type: case scheme_boxenv_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
result = validate_join_seq(result, result = validate_join_seq(result,
bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -1856,7 +1862,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result_ignored, vc, tailpos, procs, expected_results)); result_ignored, vc, tailpos, procs, expected_results));
break; break;
case scheme_begin0_sequence_type: case scheme_begin0_sequence_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
result = validate_join_seq(result, result = validate_join_seq(result,
begin0_validate(expr, port, stack, tls, depth, letlimit, delta, begin0_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
@ -1864,14 +1870,14 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result_ignored, vc, tailpos, procs, expected_results)); result_ignored, vc, tailpos, procs, expected_results));
break; break;
case scheme_require_form_type: case scheme_require_form_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta, top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
result_ignored, vc, tailpos, procs); result_ignored, vc, tailpos, procs);
break; break;
case scheme_varref_form_type: case scheme_varref_form_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
ref_validate(expr, port, stack, tls, depth, letlimit, delta, ref_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1879,7 +1885,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result = validate_join_const(result, expected_results); result = validate_join_const(result, expected_results);
break; break;
case scheme_apply_values_type: case scheme_apply_values_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
apply_values_validate(expr, port, stack, tls, depth, letlimit, delta, apply_values_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1887,7 +1893,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result = validate_join(0, result); result = validate_join(0, result);
break; break;
case scheme_case_lambda_sequence_type: case scheme_case_lambda_sequence_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta, case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1895,7 +1901,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result = validate_join_const(result, expected_results); result = validate_join_const(result, expected_results);
break; break;
case scheme_module_type: case scheme_module_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
module_validate(expr, port, stack, tls, depth, letlimit, delta, module_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1903,7 +1909,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
result = validate_join(0, result); result = validate_join(0, result);
break; break;
case scheme_inline_variant_type: case scheme_inline_variant_type:
no_flo(need_flonum, port); no_typed(need_local_type, port);
inline_variant_validate(expr, port, stack, tls, depth, letlimit, delta, inline_variant_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -1913,11 +1919,11 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
default: default:
/* All values are definitely ok, except pre-closed closures. /* All values are definitely ok, except pre-closed closures.
Such a closure can refer back to itself, so we use a flag Such a closure can refer back to itself, so we use a flag
to track cycles. Also check need_flonum. */ to track cycles. Also check need_local_type. */
result = validate_join_const(result, expected_results); result = validate_join_const(result, expected_results);
if (SAME_TYPE(type, scheme_closure_type)) { if (SAME_TYPE(type, scheme_closure_type)) {
Scheme_Closure_Data *data; Scheme_Closure_Data *data;
no_flo(need_flonum, port); no_typed(need_local_type, port);
expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr);
data = (Scheme_Closure_Data *)expr; data = (Scheme_Closure_Data *)expr;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) { if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) {
@ -1937,9 +1943,9 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, 0, vc, 0, 0, procs, 1, NULL); NULL, 0, 0, vc, 0, 0, procs, 1, NULL);
} }
} else if (need_flonum) { } else if (need_local_type) {
if (!SCHEME_FLOATP(expr)) if (!SCHEME_FLOATP(expr))
no_flo(need_flonum, port); no_typed(need_local_type, port);
} }
break; break;
} }