diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 2217060f65..5ba6948567 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -330,16 +330,14 @@ [(struct assign (id rhs undef-ok?)) `(set! ,(decompile-expr id 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 ([e (if unbox? `(#%unbox ,id) id)]) (if clear? `(#%sfs-clear ,e) - (if flonum? - `(#%from-flonum ,e) - e))))] + e)))] [(? lam?) `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) @@ -347,13 +345,10 @@ ,@(map (lambda (lam) (decompile-lam lam globs stack closed)) lams))] - [(struct let-one (rhs body flonum? unused?)) + [(struct let-one (rhs body type unused?)) (let ([id (or (extract-id rhs) - (gensym (if unused? 'unused 'local)))]) - `(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)]) - (if flonum? - (list '#%as-flonum v) - v))]) + (gensym (or type (if unused? 'unused 'local))))]) + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) @@ -428,7 +423,10 @@ (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" - (case type [(ref) "argbox"] [(flonum) "argfl"] [else "arg"]) + (case type + [(ref) "argbox"] + [(val) "arg"] + [else (format "arg~a" type)]) i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) @@ -444,8 +442,8 @@ ,@(if (null? captures) null `('(captures: ,@(map (lambda (c t) - (if (eq? t 'flonum) - `(flonum ,c) + (if t + `(,t ,c) c)) captures closure-types) @@ -465,70 +463,10 @@ closed)))])) (define (annotate-inline a) - (if (and (symbol? (car 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)) + a) (define (annotate-unboxed args a) - (define (unboxable? e s) - (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)) + a) ;; ---------------------------------------- diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index b9e1333a99..d3cc61ce3f 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -725,7 +725,7 @@ (out-marshaled set-bang-type-num (cons undef-ok? (cons id rhs)) 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?) (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) (out-byte (+ (if unbox? @@ -735,17 +735,16 @@ out) (begin (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) (begin (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) + (out-number (cond + [clear? 1] + [other-clears? 2] + [else (+ 2 (case type + [(flonum) 1] + [(fixnum) 2]))]) out)))))] [(? lam?) (out-lam v out)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 18e7426b01..63b964fb19 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -88,6 +88,7 @@ (define CLOS_IS_METHOD 16) (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) + (define BITS_PER_ARG 4) (match v [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) @@ -95,31 +96,32 @@ (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) (values (vector-length v) v rest) (values v (car rest) (cdr rest)))] - [(check-bit) (lambda (i) + [(get-flags) (lambda (i) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) 0 (let ([byte (vector-ref closed-over - (+ closure-size (quotient (* 2 i) BITS_PER_MZSHORT)))]) - (+ (if (bitwise-bit-set? byte (remainder (* 2 i) BITS_PER_MZSHORT)) - 1 - 0) - (if (bitwise-bit-set? byte (add1 (remainder (* 2 i) BITS_PER_MZSHORT))) - 2 - 0)))))] + (+ closure-size (quotient (* BITS_PER_ARG i) BITS_PER_MZSHORT)))]) + (bitwise-and (arithmetic-shift byte (- (remainder (* BITS_PER_ARG i) BITS_PER_MZSHORT))) + (sub1 (arithmetic-shift 1 BITS_PER_ARG))))))] + [(num->type) (lambda (n) + (case n + [(2) 'flonum] + [(3) 'fixnum] + [else (error "invaid type flag")]))] [(arg-types) (let ([num-params ((if rest? sub1 values) num-params)]) (for/list ([i (in-range num-params)]) - (case (check-bit i) + (define v (get-flags i)) + (case v [(0) 'val] [(1) 'ref] - [(2) 'flonum] - [else (error "both 'ref and 'flonum argument?")])))] + [else (num->type v)])))] [(closure-types) (for/list ([i (in-range closure-size)] [j (in-naturals num-params)]) - (case (check-bit j) + (define v (get-flags j)) + (case v [(0) 'val/ref] [(1) (error "invalid 'ref closure variable")] - [(2) 'flonum] - [else (error "both 'ref and 'flonum closure var?")]))]) + [else (num->type v)]))]) (make-lam name (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) @@ -467,7 +469,7 @@ [16 vector] [17 hash-table] [18 stx] - [19 let-one-flonum] + [19 let-one-typed] [20 marshalled] [21 quote] [22 reference] @@ -550,14 +552,21 @@ [reader (get-reader type)]) (reader l))) +(define SCHEME_LOCAL_TYPE_FLONUM 1) +(define SCHEME_LOCAL_TYPE_FIXNUM 2) + (define (make-local unbox? pos flags) - (define SCHEME_LOCAL_CLEAR_ON_READ #x01) - (define SCHEME_LOCAL_OTHER_CLEARS #x02) - (define SCHEME_LOCAL_FLONUM #x03) + (define SCHEME_LOCAL_CLEAR_ON_READ 1) + (define SCHEME_LOCAL_OTHER_CLEARS 2) + (define SCHEME_LOCAL_TYPE_OFFSET 2) (make-localref unbox? pos (= flags SCHEME_LOCAL_CLEAR_ON_READ) (= 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) (arithmetic-shift a b)) @@ -841,9 +850,13 @@ (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) (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) - (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))] [(branch) (make-branch (read-compact cp) (read-compact cp) (read-compact cp))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index a2aa9c284b..bdac336473 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -146,17 +146,20 @@ [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] - [param-types (listof (or/c 'val 'ref 'flonum))] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))] [rest? boolean?] [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?))] [max-let-depth exact-nonnegative-integer?] [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 (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 (install-value expr) ([count 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 (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) diff --git a/collects/scribblings/raco/decompile.scrbl b/collects/scribblings/raco/decompile.scrbl index 6ec50a4959..7f4b74be68 100644 --- a/collects/scribblings/raco/decompile.scrbl +++ b/collects/scribblings/raco/decompile.scrbl @@ -110,18 +110,11 @@ Many forms in the decompiled code, such as @racket[module], @racketmodname[racket/flonum] and @racketmodname[racket/unsafe/ops] are always inlined, so @racketidfont{#%in} is not shown for them.} -@item{Some applications of flonum operations from @racketmodname[racket/flonum] - and @racketmodname[racket/unsafe/ops] are annotated with - @racketidfont{#%flonum}, indicating a place where the JIT compiler - might avoid allocation for intermediate flonum results. A single - @racketidfont{#%flonum} by itself is not useful, but a - @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{Function arguments and local bindings that are known to have a + particular type have names that embed the known type. For example, an + argument might have a name that starts @racketidfont{argflonum} or a + local binding might have a name that starts @racketidfont{flonum} to + indicate a flonum value.} @item{A @racketidfont{#%decode-syntax} form corresponds to a syntax object.} diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index bfdb580fe4..17b0d6739c 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -270,7 +270,7 @@ binding, constructor, etc.} [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used 'sfs-clear-rest-args))] [num-params exact-nonnegative-integer?] - [param-types (listof (or/c 'val 'ref 'flonum))] + [param-types (listof (or/c 'val 'ref 'flonum 'fixnum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] [closure-types (listof (or/c 'val/ref 'flonum))] @@ -339,13 +339,13 @@ binding, constructor, etc.} @defstruct+[(let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] - [flonum? boolean?] + [type (or/c #f 'flonum 'fixnum)] [unused? boolean?])]{ Pushes an uninitialized slot onto the stack, evaluates @racket[rhs] and puts its value into the slot, and then runs @racket[body]. If - @racket[flonum?] is @racket[#t], then @racket[rhs] must produce a - flonum, and the slot must be accessed by @racket[localref]s that - expect a flonum. If @racket[unused?] is @racket[#t], then the slot + @racket[type] is not @racket[#f], then @racket[rhs] must produce a + value of the corresponding type, and the slot must be accessed by @racket[localref]s that + 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 onto the stack (but @racket[rhs] is constrained to produce a single value). @@ -402,7 +402,7 @@ binding, constructor, etc.} [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] - [flonum? boolean?])]{ + [type (or/c #f 'flonum 'fixnum)])]{ Represents a local-variable reference; it accesses the value in the 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 @@ -410,8 +410,8 @@ binding, constructor, etc.} is obtained, the stack slot is cleared (to avoid retaining a reference that can prevent reclamation of the value as garbage). If @racket[other-clears?] is @racket[#t], then some later reference to - the same stack slot may clear after reading. If @racket[flonum?] is - @racket[#t], the slot holds to a flonum value.} + the same stack slot may clear after reading. If @racket[type] is + not @racket[#f], the slot is known to hold a specific type of value.} @defstruct+[(toplevel expr) ([depth exact-nonnegative-integer?] diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 3347adb1d8..f15460c513 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -2551,7 +2551,27 @@ (newline))) 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))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 10cd4a83e4..031c4ce23d 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -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 racket/unsafe/ops: added unsafe-cons-list diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index cf9d550c9c..f23baa624c 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -855,16 +855,8 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags) k = type - scheme_local_type; /* Helper for reading bytecode: make sure flags is a valid value */ - switch (flags) { - case 0: - case SCHEME_LOCAL_CLEAR_ON_READ: - case SCHEME_LOCAL_OTHER_CLEARS: - case SCHEME_LOCAL_FLONUM: - break; - default: - flags = SCHEME_LOCAL_OTHER_CLEARS; - break; - } + if ((flags < 0) || (flags > (SCHEME_MAX_LOCAL_TYPE + SCHEME_LOCAL_TYPE_OFFSET))) + flags = SCHEME_LOCAL_OTHER_CLEARS; if (pos < MAX_CONST_LOCAL_POS) { return scheme_local[pos][k][flags]; diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index ef10ea5f1b..f4698914db 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -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, 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, @@ -100,7 +100,7 @@ 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, 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, @@ -581,7 +581,7 @@ 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, 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, @@ -611,7 +611,7 @@ 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, 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, @@ -1020,7 +1020,7 @@ 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, 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, diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 756b58b40a..3ffce357d8 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -311,10 +311,10 @@ Scheme_Object *scheme_apply_lightweight_continuation_stack(Scheme_Current_LWC *l #ifdef USE_FLONUM_UNBOXING int scheme_jit_check_closure_flonum_bit(Scheme_Closure_Data *data, int pos, int delta) { - int bit; + int ct; pos += delta; - bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); - 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_TYPE_OFFSET + SCHEME_LOCAL_TYPE_FLONUM)) return 1; else return 0; @@ -443,7 +443,7 @@ static int no_sync_change(Scheme_Object *obj, int fuel) return no_sync_change(branch->fbranch, fuel); } 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; else return fuel - 1; @@ -716,7 +716,7 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth) break; 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 1; 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) { - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) - && !SCHEME_GET_LOCAL_FLAGS(obj)) { - return 1; - } else - return 0; + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) { + 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 0; } int scheme_ok_to_delay_local(Scheme_Object *obj) { if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type) - /* We can delay if the clears flag is set: */ - && (SCHEME_GET_LOCAL_FLAGS(obj) <= 1)) { + /* We can delay if the clears flag is set and no type: */ + && (SCHEME_GET_LOCAL_FLAGS(obj) <= SCHEME_LOCAL_CLEAR_ON_READ)) { return 1; } else return 0; @@ -827,7 +831,7 @@ static int expression_avoids_clearing_local(Scheme_Object *wrt, int pos, int fue return 1; else if (SAME_TYPE(t, scheme_local_type)) 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)) return 1; 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); 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. */ - if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) + if (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM) return fp_ok; else if (expression_avoids_clearing_local(wrt, SCHEME_LOCAL_POS(obj), 3)) /* 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); 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; - if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) + if (JIT_TYPE_NEEDS_BOXING(flags - SCHEME_LOCAL_TYPE_OFFSET)) return 0; return 1; } else @@ -1929,11 +1934,11 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w case scheme_local_type: { /* 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; START_JIT_DATA(); #ifdef USE_FLONUM_UNBOXING - flonum = (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM); + flonum = (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM); #else flonum = 0; #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); #ifdef USE_FLONUM_UNBOXING - flonum = SCHEME_LET_EVAL_TYPE(lv) & LET_ONE_FLONUM; + flonum = (SCHEME_LET_ONE_TYPE(lv) == SCHEME_LOCAL_TYPE_FLONUM); #else flonum = 0; #endif diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index 8299770a8e..8fb6235cbe 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -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 # 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)) diff --git a/src/racket/src/jitalloc.c b/src/racket/src/jitalloc.c index 44c695d3d7..9de8326671 100644 --- a/src/racket/src/jitalloc.c +++ b/src/racket/src/jitalloc.c @@ -100,16 +100,21 @@ static intptr_t read_first_word(void *sp) 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; memset(&sp, 0, sizeof(Scheme_Small_Object)); 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); } -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) /* 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). @@ -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); /* 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); } else { /* an array of pointers */ diff --git a/src/racket/src/jitarith.c b/src/racket/src/jitarith.c index 136daa1e10..8360ec6b4c 100644 --- a/src/racket/src/jitarith.c +++ b/src/racket/src/jitarith.c @@ -124,7 +124,7 @@ static int is_unboxing_immediate(Scheme_Object *obj, int unsafely) t = SCHEME_TYPE(obj); switch (t) { 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 unsafely; 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) || SCHEME_INTP(rand)); 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 (mz_CURRENT_REG_STATUS_VALID() && (jitter->r0_status >= 0) diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index af47b15b21..e3f5b84a8c 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -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] : app->args[i+1+args_already_in_place]); 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)); GC_CAN_IGNORE jit_insn *iref; if (i != num_rands - 1) mz_pushr_p(JIT_R0); 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 */ if (i != num_rands - 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] : app->args[i+1+args_already_in_place]); if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type) - && !SCHEME_GET_LOCAL_FLAGS(v)) { + && !SCHEME_GET_LOCAL_TYPE(v)) { pos = SCHEME_LOCAL_POS(v); for (j = 0; j < n; j++) { 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]); t = SCHEME_TYPE(arg); 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_))) { /* App of something complex to a local variable. We can move the proc directly to V1. */ diff --git a/src/racket/src/marshal.c b/src/racket/src/marshal.c index 4b6b2a5734..6a43ac00c7 100644 --- a/src/racket/src/marshal.c +++ b/src/racket/src/marshal.c @@ -708,14 +708,12 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj) svec_size = data->closure_size; 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; for (k = data->num_params + data->closure_size; --k; ) { - mv = ((data->closure_map[data->closure_size + ((2 * k) / BITS_PER_MZSHORT)] - >> ((2 * k) % BITS_PER_MZSHORT)) - & 0x3); - if (mv == 0x3) + mv = scheme_boxmap_get(data->closure_map, k, data->closure_size); + if (mv > (CLOS_TYPE_TYPE_OFFSET + SCHEME_MAX_LOCAL_TYPE)) scheme_signal_error("internal error: inconsistent closure/argument type"); } } diff --git a/src/racket/src/mzmark_fun.inc b/src/racket/src/mzmark_fun.inc index 830e0e1090..8a14ce24f7 100644 --- a/src/racket/src/mzmark_fun.inc +++ b/src/racket/src/mzmark_fun.inc @@ -10,7 +10,7 @@ static int mark_closure_info_MARK(void *p, struct NewGC *gc) { gcMARK2(i->local_flags, gc); gcMARK2(i->base_closure_map, gc); - gcMARK2(i->flonum_map, gc); + gcMARK2(i->local_type_map, gc); return 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->base_closure_map, gc); - gcFIXUP2(i->flonum_map, gc); + gcFIXUP2(i->local_type_map, gc); return gcBYTES_TO_WORDS(sizeof(Closure_Info)); diff --git a/src/racket/src/mzmark_optimize.inc b/src/racket/src/mzmark_optimize.inc index 4f37e259a4..20ecbdfd53 100644 --- a/src/racket/src/mzmark_optimize.inc +++ b/src/racket/src/mzmark_optimize.inc @@ -19,6 +19,7 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) { gcMARK2(i->transitive_use_len, gc); gcMARK2(i->context, gc); gcMARK2(i->logger, gc); + gcMARK2(i->types, gc); return 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->context, gc); gcFIXUP2(i->logger, gc); + gcFIXUP2(i->types, gc); return gcBYTES_TO_WORDS(sizeof(Optimize_Info)); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 9d6e841ac5..027996274e 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1383,7 +1383,7 @@ mark_closure_info { gcMARK2(i->local_flags, gc); gcMARK2(i->base_closure_map, gc); - gcMARK2(i->flonum_map, gc); + gcMARK2(i->local_type_map, gc); size: gcBYTES_TO_WORDS(sizeof(Closure_Info)); diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 8355748ee3..6f6610a279 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -77,14 +77,20 @@ struct Optimize_Info 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); -static void set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); -static void merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); +#define OPT_IS_MUTATED 0x1 +#define OPT_LOCAL_TYPE_ARG_SHIFT 2 +#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, Optimize_Info *info, int *is_leaf); static int closure_has_top_level(Scheme_Closure_Data *data); 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 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 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 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_is_mutated(Optimize_Info *info, int pos); -static int optimize_is_flonum_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_arg(Optimize_Info *info, int pos, int depth); +static int optimize_is_local_type_valued(Optimize_Info *info, int pos); static int env_uses_toplevel(Optimize_Info *frame); 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; else if (!optimize_is_mutated(info, pos + delta)) { if (check_space) { - if (optimize_is_flonum_valued(info, pos + delta)) + if (optimize_is_local_type_valued(info, pos + delta)) return 1; /* the value of the identifier might be something that would retain significant memory, so we can't delay evaluation */ @@ -1616,21 +1622,23 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a 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)) - return 1; + int ty; + + ty = scheme_expr_produces_local_type(expr); + if (ty) return ty; if (SAME_TYPE(SCHEME_TYPE(expr), scheme_local_type)) { - if (optimize_is_flonum_valued(info, SCHEME_LOCAL_POS(expr))) - return 1; + ty = optimize_is_local_type_valued(info, SCHEME_LOCAL_POS(expr)); + if (ty) return ty; } return 0; } -static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, - Optimize_Info *info) +static void register_local_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, + Optimize_Info *info) { Scheme_Object *rator, *rand, *le; int n, i; @@ -1656,11 +1664,11 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec char *map; int ok; - map = get_closure_flonum_map(data, n, &ok); + map = get_closure_local_type_map(data, n, &ok); if (ok) { for (i = 0; i < n; i++) { - int is_flonum; + int ct; if (app) 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; } - is_flonum = is_flonum_expression(rand, info); - if (is_flonum) { + ct = is_local_type_expression(rand, info); + if (ct) { if (!map) { map = MALLOC_N_ATOMIC(char, n); - memset(map, 1, n); + memset(map, ct, n); memset(map, 0, i); } } - if (map && !is_flonum) - map[i] = 0; + if (map) + 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)) -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_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_NONMUTATING) { 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-flmax") || IS_NAMED_PRIM(rator, "unsafe-fl->fx")) - return 1; + return SCHEME_LOCAL_TYPE_FLONUM; } else if (SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { if (IS_NAMED_PRIM(rator, "flabs") || 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, "flmin") || IS_NAMED_PRIM(rator, "flmax")) - return 1; + return SCHEME_LOCAL_TYPE_FLONUM; if ((argpos == 2) - && IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) - return 1; - if ((argpos == 2) - && IS_NAMED_PRIM(rator, "flvector-set!")) - return 1; + && (IS_NAMED_PRIM(rator, "unsafe-flvector-set!") + || IS_NAMED_PRIM(rator, "flvector-set!"))) + return SCHEME_LOCAL_TYPE_FLONUM; } } 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_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-flmin") || IS_NAMED_PRIM(rator, "unsafe-flmax")))) - return 1; + return SCHEME_LOCAL_TYPE_FLONUM; if (((argc == 2) && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) - || ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } + || ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) + return SCHEME_LOCAL_TYPE_FLONUM; + 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)) { if (IS_NAMED_PRIM(rator, "flabs") || 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, "flexp") || IS_NAMED_PRIM(rator, "flimag-part") - || IS_NAMED_PRIM(rator, "flreal-part")) - return 1; - if (IS_NAMED_PRIM(rator, "->fl")) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } + || IS_NAMED_PRIM(rator, "flreal-part") + || IS_NAMED_PRIM(rator, "->fl") + || IS_NAMED_PRIM(rator, "fx->fl")) + return SCHEME_LOCAL_TYPE_FLONUM; + 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)) { if (IS_NAMED_PRIM(rator, "flabs") || 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, "flmin") || IS_NAMED_PRIM(rator, "flmax") - || IS_NAMED_PRIM(rator, "flexpt")) - return 1; - if (IS_NAMED_PRIM(rator, "flvector-ref")) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } + || IS_NAMED_PRIM(rator, "flexpt") + || IS_NAMED_PRIM(rator, "flvector-ref")) + return SCHEME_LOCAL_TYPE_FLONUM; + if (IS_NAMED_PRIM(rator, "fxabs") + || 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; } -int scheme_expr_produces_flonum(Scheme_Object *expr) +int scheme_expr_produces_local_type(Scheme_Object *expr) { while (1) { switch (SCHEME_TYPE(expr)) { case scheme_application_type: { 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; case scheme_application2_type: { Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - return produces_unboxed(app->rator, NULL, 1); + return produces_local_type(app->rator, 1); } break; case scheme_application3_type: { Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - return produces_unboxed(app->rator, NULL, 2); + return produces_local_type(app->rator, 2); } break; case scheme_compiled_let_void_type: @@ -2024,7 +2080,9 @@ int scheme_expr_produces_flonum(Scheme_Object *expr) break; default: if (SCHEME_FLOATP(expr)) - return 1; + return SCHEME_LOCAL_TYPE_FLONUM; + if (SCHEME_INTP(expr)) + return SCHEME_LOCAL_TYPE_FIXNUM; return 0; } } @@ -2142,8 +2200,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info } sub_context = 0; - if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1)) - sub_context = OPT_CONTEXT_FLONUM_ARG; + if (i > 0) { + 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); 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)) return scheme_null; - register_flonum_argument_types(app, NULL, NULL, info); + register_local_argument_types(app, NULL, NULL, info); return (Scheme_Object *)app; } @@ -2281,7 +2343,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf { Scheme_App2_Rec *app; Scheme_Object *le; - int rator_flags = 0, sub_context = 0; + int rator_flags = 0, sub_context = 0, ty; app = (Scheme_App2_Rec *)o; @@ -2302,8 +2364,9 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf return le; } - if (scheme_wants_flonum_arguments(app->rator, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; + ty = wants_local_type_arguments(app->rator, 0); + if (ty) + sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT); le = scheme_optimize_expr(app->rand, info, sub_context); 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; } @@ -2472,7 +2535,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf { Scheme_App3_Rec *app; Scheme_Object *le; - int rator_flags = 0, sub_context = 0; + int rator_flags = 0, sub_context = 0, ty; app = (Scheme_App3_Rec *)o; @@ -2499,18 +2562,20 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf /* 1st arg */ - if (scheme_wants_flonum_arguments(app->rator, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; + ty = wants_local_type_arguments(app->rator, 0); + if (ty) + sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT); le = scheme_optimize_expr(app->rand1, info, sub_context); app->rand1 = le; /* 2nd arg */ - if (scheme_wants_flonum_arguments(app->rator, 1)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; + ty = wants_local_type_arguments(app->rator, 1); + if (ty) + sub_context |= (ty << OPT_CONTEXT_TYPE_SHIFT); else - sub_context &= ~OPT_CONTEXT_FLONUM_ARG; + sub_context &= ~OPT_CONTEXT_TYPE_MASK; le = scheme_optimize_expr(app->rand2, info, sub_context); 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; } @@ -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, Scheme_Object *first, Scheme_Object *second, int set_flags, int mask_flags, int just_tentative, - int merge_flonum) + int merge_local_typed) { Scheme_Case_Lambda *cl, *cl2, *cl3; 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; } - if (merge_flonum) { - merge_closure_flonum_map(data, data2); - merge_closure_flonum_map(data, data3); - merge_closure_flonum_map(data, data2); + if (merge_local_typed) { + merge_closure_local_type_map(data, data2); + merge_closure_local_type_map(data, data3); + merge_closure_local_type_map(data, data2); } 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_Object *clones, int set_flags, int mask_flags, int just_tentative, - int merge_flonum) + int merge_local_typed) { Scheme_Compiled_Let_Value *clv; 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, SCHEME_CAR(first), SCHEME_CDR(first), set_flags, mask_flags, just_tentative, - merge_flonum); + merge_local_typed); 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; checked_once = 1; } else if (value && !is_rec) { - int cnt; + int cnt, ct; - if (scheme_expr_produces_flonum(value)) - optimize_produces_flonum(body_info, pos); + ct = scheme_expr_produces_local_type(value); + if (ct) + optimize_produces_local_type(body_info, pos, ct); if (!indirect) { checked_once = 1; @@ -4640,9 +4706,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } } else { for (j = pre_body->count; j--; ) { + int ct; + pre_body->flags[j] |= SCHEME_WAS_USED; - if (optimize_is_flonum_arg(body_info, pos+j, 0)) - pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT; + ct = optimize_is_local_type_arg(body_info, pos+j, 0); + 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->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); for (i = 0; i < data->num_params; i++) { - if (optimize_is_flonum_arg(info, i, 1)) - cl->local_flags[i] |= SCHEME_WAS_FLONUM_ARGUMENT; + int ct; + 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) { @@ -4829,7 +4900,7 @@ optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int cont 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; @@ -4839,60 +4910,60 @@ static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *o return NULL; } - if (cl->has_flomap && !cl->flonum_map) { + if (cl->has_tymap && !cl->local_type_map) { *ok = 0; return NULL; } *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; int i; - if (!cl->flonum_map) { - cl->has_flomap = 1; - cl->flonum_map = flonum_map; + if (!cl->local_type_map) { + cl->has_tymap = 1; + cl->local_type_map = local_type_map; } - if (flonum_map) { + if (local_type_map) { for (i = data->num_params; i--; ) { - if (flonum_map[i]) break; + if (local_type_map[i]) break; } 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 *cl2 = (Closure_Info *)data2->closure_map; - if (cl1->has_flomap) { - if (!cl1->flonum_map || !cl2->has_flomap) { - cl2->has_flomap = 1; - cl2->flonum_map = cl1->flonum_map; - } else if (cl2->flonum_map) { + if (cl1->has_tymap) { + if (!cl1->local_type_map || !cl2->has_tymap) { + cl2->has_tymap = 1; + cl2->local_type_map = cl1->local_type_map; + } else if (cl2->local_type_map) { int i; for (i = data1->num_params; i--; ) { - if (cl1->flonum_map[i] != cl2->flonum_map[i]) { - cl2->flonum_map = NULL; - cl1->flonum_map = NULL; + if (cl1->local_type_map[i] != cl2->local_type_map[i]) { + cl2->local_type_map = NULL; + cl1->local_type_map = NULL; break; } } } else { - cl1->flonum_map = NULL; + cl1->local_type_map = NULL; } - } else if (cl2->has_flomap) { - cl1->has_flomap = 1; - cl1->flonum_map = cl2->flonum_map; + } else if (cl2->has_tymap) { + cl1->has_tymap = 1; + 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; Closure_Info *cl; int *flags, sz; - char *flonum_map; + char *local_type_map; 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); cl->local_flags = flags; - if (cl->flonum_map) { + if (cl->local_type_map) { sz = data2->num_params; - flonum_map = (char *)scheme_malloc_atomic(sz); - memcpy(flonum_map, cl->flonum_map, sz); - cl->flonum_map = flonum_map; + local_type_map = (char *)scheme_malloc_atomic(sz); + memcpy(local_type_map, cl->local_type_map, sz); + cl->local_type_map = local_type_map; } 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) /* 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 */ { - 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) @@ -6541,7 +6612,7 @@ static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_ } if (unless_mutated) - if (info->use && (info->use[pos] & 0x1)) + if (info->use && (info->use[pos] & OPT_IS_MUTATED)) return NULL; if (disrupt_single_use) { @@ -6582,7 +6653,7 @@ static int optimize_is_used(Optimize_Info *info, int pos) 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 */ { while (info) { @@ -6592,8 +6663,8 @@ static int check_use(Optimize_Info *info, int pos, int flag) info = info->next; } - if (info->use && (info->use[pos] & flag)) - return 1; + if (info->use) + return (info->use[pos] >> shift) & mask; 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) /* 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 */ { - 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 */ { - 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) @@ -6661,11 +6732,11 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int info = info->next; } - if (context & OPT_CONTEXT_FLONUM_ARG) - register_use(info, pos, 0x2); + if (OPT_CONTEXT_TYPE(context)) + register_use(info, pos, OPT_CONTEXT_TYPE(context) << OPT_LOCAL_TYPE_ARG_SHIFT); if (is_mutated) - if (info->use && (info->use[pos] & 0x1)) + if (info->use && (info->use[pos] & OPT_IS_MUTATED)) *is_mutated = 1; if (just_test) return NULL; diff --git a/src/racket/src/print.c b/src/racket/src/print.c index d6410bb4d1..3e13329534 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -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) print_compact(pp, CPT_LET_ONE_UNUSED); - else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) - print_compact(pp, CPT_LET_ONE_FLONUM); + else if (SCHEME_LET_ONE_TYPE(lo)) + print_compact(pp, CPT_LET_ONE_TYPED); else print_compact(pp, CPT_LET_ONE); print(scheme_protect_quote(lo->value), 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)) { diff --git a/src/racket/src/read.c b/src/racket/src/read.c index f5bbd0a839..f2e5335617 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -4640,7 +4640,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) } break; case CPT_LET_ONE: - case CPT_LET_ONE_FLONUM: + case CPT_LET_ONE_TYPED: case CPT_LET_ONE_UNUSED: { Scheme_Let_One *lo; @@ -4654,9 +4654,11 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) v = read_compact(port, 1); lo->body = v; et = scheme_get_eval_type(lo->value); - if (ch == CPT_LET_ONE_FLONUM) - et |= LET_ONE_FLONUM; - if (ch == CPT_LET_ONE_UNUSED) + if (ch == CPT_LET_ONE_TYPED) { + int ty; + ty = read_compact_number(port); + et |= (ty << LET_ONE_TYPE_SHIFT); + } else if (ch == CPT_LET_ONE_UNUSED) et |= LET_ONE_UNUSED; SCHEME_LET_EVAL_TYPE(lo) = et; diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 5af659bff6..277a57de13 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -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_Letrec *letrec; 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; int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc; int rec_proc_nonapply = 0; @@ -1052,24 +1052,28 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) if (j <= NUM_SKIPS_FAST) { skips = skips_fast; lifted = lifted_fast; - flonums = flonums_fast; + local_types = local_types_fast; } else { skips = MALLOC_N_ATOMIC(mzshort, 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; for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { + int aty, pty; + if (!(clv->flags[0] & SCHEME_WAS_USED)) skips[i] = 1; else skips[i] = 0; - if ((clv->flags[0] & SCHEME_WAS_FLONUM_ARGUMENT) - && scheme_expr_produces_flonum(clv->value)) - flonums[i] = SCHEME_INFO_FLONUM_ARG; + + aty = SCHEME_WAS_TYPED_ARGUMENT(clv->flags[0]); + pty = scheme_expr_produces_local_type(clv->value); + if (pty && ((pty == aty) || ALWAYS_PREFER_UNBOX_TYPE(pty))) + local_types[i] = pty; else - flonums[i] = 0; + local_types[i] = 0; lifted[i] = NULL; } @@ -1099,9 +1103,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) for (j = i, k = 0; j >= 0; j--) { n = (rev_bind_order ? (head->count - j - 1) : 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 - 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; @@ -1143,8 +1147,8 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) lo->value = le; et = scheme_get_eval_type(lo->value); - if (flonums[i]) - et |= LET_ONE_FLONUM; + if (local_types[i]) + et |= (local_types[i] << LET_ONE_TYPE_SHIFT); SCHEME_LET_EVAL_TYPE(lo) = et; if (last) @@ -1170,9 +1174,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) n = (rev_bind_order ? (head->count - i - 1) : i); if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n"); 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 - 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); @@ -1666,7 +1670,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) 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) @@ -1681,17 +1685,17 @@ static mzshort *allocate_boxmap(int n) 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)))) - return 1; - else - return 0; + j *= CLOS_TYPE_BITS_PER_ARG; + return (boxmap[delta + (j / BITS_PER_MZSHORT)] >> (j & (BITS_PER_MZSHORT - 1)) + & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1)); } 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_size = data->closure_size; - if (cl->flonum_map) { + if (cl->local_type_map) { int at_least_one = 0; for (i = data->num_params; i--; ) { - if (cl->flonum_map[i]) { - if (cl->local_flags[i] & SCHEME_WAS_FLONUM_ARGUMENT) + if (cl->local_type_map[i]) { + if (SCHEME_WAS_TYPED_ARGUMENT(cl->local_flags[i]) == cl->local_type_map[i]) at_least_one = 1; else - cl->flonum_map[i] = 0; + cl->local_type_map[i] = 0; } } if (at_least_one) { closure_size += boxmap_size(data->num_params + closure_size); expanded_already = 1; } else - cl->flonum_map = NULL; + cl->local_type_map = NULL; } 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); has_tl = cl->has_tl; @@ -1809,17 +1813,21 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, } } else { closure_map[offset] = li; - if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_FLONUM_ARG))) { - /* The only problem with a boxed/flonum variable is that + if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_TYPED_VAL_MASK))) { + /* The only problem with a boxed/local_type variable is that it's more difficult to validate. We have to track which arguments are boxes. And the resulting procedure must be used only in application positions. */ if (!convert_boxes) 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 { - /* Currently, we only need flonum information as a closure type */ - if (flags & SCHEME_INFO_FLONUM_ARG) { + /* Currently, we only need local_type information as a closure type */ + if (flags & SCHEME_INFO_TYPED_VAL_MASK) { if (!expanded_already) { closure_size += boxmap_size(data->num_params + 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; 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++; @@ -1838,25 +1848,22 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, /* Add bindings introduced by closure conversion. The `captured' table maps old positions to new positions. */ while (lifteds) { - int j, cnt, boxed, flonumed; + int j, cnt, local_typed; Scheme_Object *vec, *loc; if (!captured) { captured = scheme_make_hash_table(SCHEME_hash_ptr); for (i = 0; i < offset; i++) { - int cp; + int cp, v; cp = i; if (convert_boxes) { - if (boxmap_get(convert_boxes, i, 1, 0)) - cp = -((2 * cp) + 1); - else if (boxmap_get(convert_boxes, i, 2, 0)) - cp = -((2 * cp) + 2); + v = scheme_boxmap_get(convert_boxes, i, 0); } else if (expanded_already) { - if (boxmap_get(closure_map, data->num_params + i, 1, data->closure_size)) - cp = -((2 * cp) + 1); - else if (boxmap_get(closure_map, data->num_params + i, 2, data->closure_size)) - cp = -((2 * cp) + 2); - } + v = scheme_boxmap_get(closure_map, data->num_params + i, data->closure_size); + } else + v = 0; + if (v) + cp = -((cp << CLOS_TYPE_BITS_PER_ARG) + v); 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]; if (SCHEME_BOXP(loc)) { loc = SCHEME_BOX_VAL(loc); - boxed = 1; - flonumed = 0; + local_typed = CLOS_TYPE_BOXED; } else if (SCHEME_VECTORP(loc)) { + local_typed = SCHEME_INT_VAL(SCHEME_VEC_ELS(loc)[1]); loc = SCHEME_VEC_ELS(loc)[0]; - boxed = 0; - flonumed = 1; } else { - boxed = 0; - flonumed = 0; + local_typed = 0; } i = SCHEME_LOCAL_POS(loc); if (!scheme_hash_get(captured, scheme_make_integer(i))) { /* Need to capture an extra binding: */ int cp; cp = captured->count; - if (boxed) - cp = -((2 * cp) + 1); - else if (flonumed) - cp = -((2 * cp) + 2); + if (local_typed) + cp = -((cp << CLOS_TYPE_BITS_PER_ARG) + local_typed); 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. */ int old_pos, j, new_size, need_flags; 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; new_size += boxmap_size(data->num_params + new_size); } else @@ -1916,21 +1918,16 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, cp = SCHEME_INT_VAL(captured->vals[j]); old_pos = SCHEME_INT_VAL(captured->keys[j]); if (cp < 0) { - /* Boxed or flonum */ + /* Boxed or local_type */ int bit; cp = -cp; - if (cp & 0x1) { - cp = (cp - 1) / 2; - bit = 1; - } else { - cp = (cp - 2) / 2; - bit = 2; - } + bit = cp & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1); + cp >>= CLOS_TYPE_BITS_PER_ARG; if (!convert_boxes) convert_boxes = allocate_boxmap(offset); - boxmap_set(convert_boxes, cp, bit, 0); + scheme_boxmap_set(convert_boxes, cp, bit, 0); 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; } @@ -1944,7 +1941,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, convert_map = closure_map; 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 sz; new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); @@ -1995,7 +1992,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, } /* Set up environment mapping, initialized for arguments: */ - + np = num_params = data->num_params; if ((data->num_params == 1) && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) @@ -2014,12 +2011,14 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, (((cl->local_flags[i] & SCHEME_WAS_SET_BANGED) ? SCHEME_INFO_BOXED : 0) - | ((cl->flonum_map && cl->flonum_map[i]) - ? SCHEME_INFO_FLONUM_ARG + | ((convert && (cl->local_type_map && cl->local_type_map[i])) + ? (cl->local_type_map[i] << SCHEME_INFO_TYPED_VAL_SHIFT) : 0)), NULL); - if (cl->flonum_map && cl->flonum_map[i] && !just_compute_lift) - boxmap_set(closure_map, i + convert_size, 2, closure_size); + if (convert && cl->local_type_map && cl->local_type_map[i] && !just_compute_lift) + 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) SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; @@ -2063,36 +2062,37 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, --sz; cmap = MALLOC_N_ATOMIC(mzshort, sz); 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]; if (SCHEME_BOXP(loc)) { if (!boxmap) boxmap = allocate_boxmap(sz); - boxmap_set(boxmap, j, 1, 0); + scheme_boxmap_set(boxmap, j, CLOS_TYPE_BOXED, 0); loc = SCHEME_BOX_VAL(loc); is_boxed = 1; } else if (SCHEME_VECTORP(loc)) { if (!boxmap) 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]; - is_flonum = 1; + is_local_type = 1; } loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc))); cp = SCHEME_INT_VAL(loc); if (cp < 0) { + int v; cp = -cp; - if (cp & 0x1) { - cp = (cp - 1) / 2; + v = cp & ((1 << CLOS_TYPE_BITS_PER_ARG) - 1); + cp >>= CLOS_TYPE_BITS_PER_ARG; + if (v == CLOS_TYPE_BOXED) { if (convert && !is_boxed) scheme_signal_error("internal error: lift mismatch (boxed)"); } else { - cp = (cp - 2) / 2; - if (convert && !is_flonum) - scheme_signal_error("internal error: lift mismatch (flonum)"); + if (convert && !is_local_type) + scheme_signal_error("internal error: lift mismatch (local type) %d", v); } } else { - if (convert && (is_boxed || is_flonum)) + if (convert && (is_boxed || is_local_type)) scheme_signal_error("internal error: lift mismatch"); } 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_type, pos, - ((flags & SCHEME_INFO_FLONUM_ARG) - ? SCHEME_LOCAL_FLONUM + ((flags & SCHEME_INFO_TYPED_VAL_MASK) + ? (SCHEME_LOCAL_TYPE_OFFSET + + ((flags & SCHEME_INFO_TYPED_VAL_MASK) + >> SCHEME_INFO_TYPED_VAL_SHIFT)) : 0)); } } @@ -2886,15 +2888,16 @@ static int do_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Schem boxmap = (mzshort *)ca[3]; vec = scheme_make_vector(sz + 1, NULL); for (i = 0; i < sz; i++) { - int boxed = 0, flonumed = 0, flags = 0; + int boxed = 0, local_typed = 0, flags = 0; if (boxmap) { - int byte = boxmap[(2 * i) / BITS_PER_MZSHORT]; - if (byte & ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) + int lt; + lt = scheme_boxmap_get(boxmap, i, 0); + if (lt == CLOS_TYPE_BOXED) { boxed = 1; - if (byte & ((mzshort)2 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) { - flonumed = 1; - flags = SCHEME_LOCAL_FLONUM; + } else if (lt) { + local_typed = lt; + 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) loc = scheme_box(loc); - else if (flonumed) - loc = scheme_make_vector(1, loc); + else if (local_typed) { + loc = scheme_make_vector(2, loc); + SCHEME_VEC_ELS(loc)[1] = scheme_make_integer(local_typed); + } SCHEME_VEC_ELS(vec)[i+1] = loc; } diff --git a/src/racket/src/schcpt.h b/src/racket/src/schcpt.h index 4370f09f0f..529e99ffc1 100644 --- a/src/racket/src/schcpt.h +++ b/src/racket/src/schcpt.h @@ -19,7 +19,7 @@ enum { CPT_VECTOR, CPT_HASH_TABLE, CPT_STX, - CPT_LET_ONE_FLONUM, + CPT_LET_ONE_TYPED, CPT_MARSHALLED, /* 20 */ CPT_QUOTE, CPT_REFERENCE, diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 3559f60f46..53bec982c9 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1270,8 +1270,21 @@ typedef struct { Scheme_Object *body; } 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 { - 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; #ifdef MZ_PRECISE_GC # ifdef MZSHORT_IS_SHORT @@ -1284,12 +1297,12 @@ typedef struct Scheme_Local { #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_CLEAR_ON_READ 0x1 -#define SCHEME_LOCAL_OTHER_CLEARS 0x2 -#define SCHEME_LOCAL_FLONUM 0x3 -#define SCHEME_LOCAL_FLAGS_MASK 0x3 +#define SCHEME_LOCAL_CLEAR_ON_READ 1 +#define SCHEME_LOCAL_OTHER_CLEARS 2 +#define SCHEME_LOCAL_TYPE_OFFSET 2 -#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 { 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; #define SCHEME_LET_EVAL_TYPE(lh) MZ_OPT_HASH_KEY(&lh->iso) -#define LET_ONE_FLONUM 0x8 -#define LET_ONE_UNUSED 0x10 +#define LET_ONE_UNUSED 0x8 + +#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 { Scheme_Inclhash_Object iso; /* keyex used for autobox */ @@ -2293,9 +2309,9 @@ typedef struct Scheme_Comp_Env #define CLOS_IS_METHOD 16 #define CLOS_SINGLE_RESULT 32 #define CLOS_RESULT_TENTATIVE 64 -#define CLOS_SFS 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 { @@ -2338,8 +2354,8 @@ typedef struct { 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_map; - char *flonum_map; /* NULL when has_flomap set => no flonums */ - char has_tl, has_flomap, has_nonleaf; + char *local_type_map; /* NULL when has_tymap set => no local types */ + char has_tl, has_tymap, has_nonleaf; int body_size, body_psize; } Closure_Info; @@ -2362,7 +2378,7 @@ typedef struct Scheme_Closure_Data mzshort max_let_depth; mzshort closure_size; 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 *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 */ @@ -2377,6 +2393,13 @@ typedef struct Scheme_Closure_Data #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); 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_TYPES 2 -#define MAX_CONST_LOCAL_FLAG_VAL 3 -#define SCHEME_LOCAL_FLAGS_MASK 0x3 +#define MAX_CONST_LOCAL_FLAG_VAL (2 + SCHEME_MAX_LOCAL_TYPE) #define MAX_CONST_TOPLEVEL_DEPTH 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_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context); -#define OPT_CONTEXT_FLONUM_ARG 0x1 -#define OPT_CONTEXT_BOOLEAN 0x2 -#define OPT_CONTEXT_NO_SINGLE 0x4 +#define OPT_CONTEXT_BOOLEAN 0x1 +#define OPT_CONTEXT_NO_SINGLE 0x2 +#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) 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); -int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos); -int scheme_expr_produces_flonum(Scheme_Object *expr); +int scheme_expr_produces_local_type(Scheme_Object *expr); Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax, 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_ONLY_APPLIED 0x4 #define SCHEME_WAS_APPLIED_EXCEPT_ONCE 0x8 -#define SCHEME_WAS_FLONUM_ARGUMENT 0x80 #define SCHEME_USE_COUNT_MASK 0x70 #define SCHEME_USE_COUNT_SHIFT 4 #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 */ #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 */ #define SCHEME_TOPLEVEL_FRAME 1 diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index c3e4dbf795..d164db2cdd 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.1.6" +#define MZSCHEME_VERSION "5.3.1.7" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #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_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c index b6828cb69c..7203f89a7d 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -697,7 +697,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) et = scheme_get_eval_type(lo->value); 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)); return o; @@ -1188,7 +1188,7 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ case scheme_local_unbox_type: if (!info->pass) 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; pos = SCHEME_LOCAL_POS(expr); at_ip = info->max_used[info->stackpos + pos]; diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index ed8fe61150..d6d1a4d734 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -41,7 +41,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, mzshort *tl_state, mzshort tl_timestamp, Scheme_Object *app_rator, int proc_with_refs_ok, 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, Scheme_Hash_Table **_st_ht); 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_VAL_NOCLEAR 5 #define VALID_BOX_NOCLEAR 6 -#define VALID_FLONUM 7 +#define VALID_TYPED 7 typedef struct Validate_Clearing { MZTAG_IF_REQUIRED @@ -342,8 +342,9 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, new_a[0] = -sz; new_a[sz+1] = !!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST); for (i = 0; i < sz; i++) { - int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); - if (data->closure_map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) + int ct; + ct = scheme_boxmap_get(data->closure_map, i, data->closure_size); + if (ct == CLOS_TYPE_BOXED) new_a[i + 1] = 1; else 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 (pos < data->num_params) { - int bit = ((mzshort)1 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); - if (data->closure_map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) + int ct; + ct = scheme_boxmap_get(data->closure_map, pos, data->closure_size); + if (ct == CLOS_TYPE_BOXED) return 1; } } @@ -990,12 +992,13 @@ static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr, cnt = data->num_params; base = sz - cnt; for (i = 0; i < cnt; i++) { - int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); - if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) { + int ct; + ct = scheme_boxmap_get(map, i, data->closure_size); + if (ct == CLOS_TYPE_BOXED) { vld = VALID_BOX; typed_arg = 1; - } else if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & (bit << 1)) { - vld = VALID_FLONUM; + } else if (ct) { + vld = (VALID_TYPED + (ct - CLOS_TYPE_TYPE_OFFSET)); typed_arg = 1; } else 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) { int pos = data->num_params + i; - int bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); - if (map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) { - if (vld != VALID_FLONUM) + int ct; + ct = scheme_boxmap_get(map, pos, data->closure_size); + if (ct > CLOS_TYPE_TYPE_OFFSET) { + if (vld != (VALID_TYPED + (ct - CLOS_TYPE_TYPE_OFFSET))) vld = VALID_NOT; - } else if (vld == VALID_FLONUM) + } else if (vld > VALID_TYPED) vld = VALID_NOT; - } else if (vld == VALID_FLONUM) + } else if (vld > VALID_TYPED) vld = VALID_NOT; 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 (!scheme_expr_produces_flonum(expr)) + if (need_local_type) { + if (scheme_expr_produces_local_type(expr) != need_local_type) 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, int result_ignored, struct Validate_Clearing *vc, int tailpos, - int need_flonum, Scheme_Hash_Tree *procs, + int need_local_type, Scheme_Hash_Tree *procs, int expected_results, Scheme_Hash_Table **_st_ht) /* 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[7] = result_ignored; args[8] = tailpos; - args[9] = need_flonum; + args[9] = need_local_type; args[10] = tl_timestamp; 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 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) || (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 p = q + delta; + int ct; if ((q < 0) || (p >= depth) || (p < 0)) scheme_ill_formed_code(port); - if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) - no_flo(need_flonum, port); + ct = SCHEME_GET_LOCAL_TYPE(expr); + if (!ct) + no_typed(need_local_type, port); - if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) { - if (stack[p] != VALID_FLONUM) + if (ct) { + if (stack[p] != (VALID_TYPED + ct)) scheme_ill_formed_code(port); } else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) { if (result_ignored && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR) - || (stack[p] == VALID_FLONUM))) { - /* ok to look up and ignore box or flonum */ + || (stack[p] >= VALID_TYPED))) { + /* ok to look up and ignore box or typed */ } else if ((proc_with_refs_ok >= 2) && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) && 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 p = q + delta; - no_flo(need_flonum, port); + no_typed(need_local_type, port); if ((q < 0) || (p >= depth) || (p < 0) || ((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; int i, n, r; - check_flo(expr, need_flonum, port); + check_typed(expr, need_local_type, port); 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; int r; - check_flo(expr, need_flonum, port); + check_typed(expr, need_local_type, port); delta -= 1; 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; int r; - check_flo(expr, need_flonum, port); + check_typed(expr, need_local_type, port); delta -= 2; if (delta < 0) @@ -1554,7 +1560,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, int cnt; int i, r; - no_flo(need_flonum, port); + no_typed(need_local_type, port); cnt = seq->count; @@ -1575,7 +1581,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Branch_Rec *b; int vc_pos, vc_ncpos, r; - no_flo(need_flonum, port); + no_typed(need_local_type, port); b = (Scheme_Branch_Rec *)expr; 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; int r; - no_flo(need_flonum, port); + no_typed(need_local_type, port); r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, 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 d = c + delta; - no_flo(need_flonum, port); + no_typed(need_local_type, port); if ((c < 0) || (p < 0) || (d < 0) || (d >= depth) || (stack[d] != VALID_TOPLEVELS) @@ -1671,7 +1677,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, 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, num_toplevels, num_stxes, num_lifts, tl_use_map, 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); 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) { stack[delta] = VALID_NOT; - } else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) { - stack[delta] = VALID_FLONUM; + } else if (SCHEME_LET_ONE_TYPE(lo)) { + stack[delta] = (VALID_TYPED + SCHEME_LET_ONE_TYPE(lo)); /* FIXME: need to check that lo->value produces a flonum */ } else stack[delta] = VALID_VAL; @@ -1817,7 +1823,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, break; case scheme_define_values_type: - no_flo(need_flonum, port); + no_typed(need_local_type, port); result = validate_join_seq(result, define_values_validate(expr, port, stack, tls, depth, letlimit, delta, 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)); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs); break; case scheme_set_bang_type: - no_flo(need_flonum, port); + no_typed(need_local_type, port); result = validate_join_seq(result, set_validate(expr, port, stack, tls, depth, letlimit, delta, 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)); break; case scheme_boxenv_type: - no_flo(need_flonum, port); + no_typed(need_local_type, port); result = validate_join_seq(result, bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, 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)); break; case scheme_begin0_sequence_type: - no_flo(need_flonum, port); + no_typed(need_local_type, port); result = validate_join_seq(result, begin0_validate(expr, port, stack, tls, depth, letlimit, delta, 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)); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, result_ignored, vc, tailpos, procs); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, 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); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, @@ -1887,7 +1893,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, result = validate_join(0, result); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, 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); break; case scheme_module_type: - no_flo(need_flonum, port); + no_typed(need_local_type, port); module_validate(expr, port, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, @@ -1903,7 +1909,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, result = validate_join(0, result); break; 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, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, @@ -1913,11 +1919,11 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, default: /* All values are definitely ok, except pre-closed closures. 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); if (SAME_TYPE(type, scheme_closure_type)) { Scheme_Closure_Data *data; - no_flo(need_flonum, port); + no_typed(need_local_type, port); expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); data = (Scheme_Closure_Data *)expr; 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, NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } - } else if (need_flonum) { + } else if (need_local_type) { if (!SCHEME_FLOATP(expr)) - no_flo(need_flonum, port); + no_typed(need_local_type, port); } break; }