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

bytecode compiler: generalize local-type tracking for unboxing

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

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

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

88
collects/compiler/decompile.rkt
View File

@ -330,16 +330,14 @@
[(struct assign (id rhs undef-ok?))
`(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)
;; ----------------------------------------

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

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

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

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

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

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

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

@ -110,18 +110,11 @@ Many forms in the decompiled code, such as @racket[module],
@racketmodname[racket/flonum] and @racketmodname[racket/unsafe/ops]
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.}

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

@ -270,7 +270,7 @@ binding, constructor, etc.}
[flags (listof (or/c 'preserves-marks 'is-method 'single-result
'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?]

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

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

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

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

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

@ -855,16 +855,8 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
k = type - scheme_local_type;
/* 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];

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

@ -1,5 +1,5 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,54,84,0,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,55,84,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0,
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,

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

@ -311,10 +311,10 @@ Scheme_Object *scheme_apply_lightweight_continuation_stack(Scheme_Current_LWC *l
#ifdef USE_FLONUM_UNBOXING
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

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

@ -1087,6 +1087,11 @@ static void emit_indentation(mz_jit_state *jitter)
/**********************************************************************/
/* Does boxing a type require registers, possibly GC, etc.? */
#define JIT_TYPE_NEEDS_BOXING(t) ((t) == SCHEME_LOCAL_TYPE_FLONUM)
/**********************************************************************/
#ifdef MZ_USE_FUTURES
# 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))

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

@ -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 */

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

@ -124,7 +124,7 @@ static int is_unboxing_immediate(Scheme_Object *obj, int unsafely)
t = SCHEME_TYPE(obj);
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)

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

@ -1178,13 +1178,13 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
? alt_rands[i+1+args_already_in_place]
: 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. */

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

@ -708,14 +708,12 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
svec_size = data->closure_size;
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");
}
}

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

@ -10,7 +10,7 @@ static int mark_closure_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->local_flags, gc);
gcMARK2(i->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));

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

@ -19,6 +19,7 @@ static int mark_optimize_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->transitive_use_len, gc);
gcMARK2(i->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));

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

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

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

@ -77,14 +77,20 @@ struct Optimize_Info
Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */
};
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;

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

@ -3021,12 +3021,14 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED)
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))
{

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

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

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

@ -957,7 +957,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL;
Scheme_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;
}

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

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

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

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

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

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

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

@ -697,7 +697,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
et = scheme_get_eval_type(lo->value);
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];

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

@ -41,7 +41,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
mzshort *tl_state, mzshort tl_timestamp,
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;
}