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

extflonums

Browse Source 
An extflonum is like a flonum, but with 80-bit precision and
not a number in the sense of `number?': only operations such as
`extfl+' work on extflonums, and only on platforms where extflonums
can be implemented by hardware without interefering with flonums
(i.e., on platforms where SSE instructions are used for
double-precision floats).

[Patch provided by Michael Filonenko and revised by Matthew.]

The compiler tracks information about bindings that are known to
hold extflonums, but the JIT does not yet exploit this information
to unbox them (except as intermediate results).
This commit is contained in:
Michael Filonenko 2013-01-27 14:03:36 -07:00 committed by Matthew Flatt
parent aed3b39546
commit 17b8092641
74 changed files with 6113 additions and 1426 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/compiler/decompile.rkt
View File

@ -19,6 +19,7 @@
(namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(namespace-require ''#%flfxnum)
(namespace-require ''#%extfl)
(namespace-require ''#%futures)
(for/list ([l (namespace-mapped-symbols)])
(cons l (with-handlers ([exn:fail? (lambda (x) #f)])

6
collects/compiler/private/xform.rkt
View File

@ -885,11 +885,11 @@
__get_errno_ptr ; QNX preprocesses errno to __get_errno_ptr
strlen cos sin exp pow log sqrt atan2
strlen cos cosl sin sinl exp expl pow powl log logl sqrt sqrtl atan2 atan2l
isnan isinf fpclass _fpclass __fpclassify __fpclassifyf __fpclassifyl
_isnan __isfinited __isnanl __isnan
__isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf
floor ceil round fmod modf fabs __maskrune _errno __errno
floor floorl ceil ceill round roundl fmod fmodl modf modfl fabs fabsl __maskrune _errno __errno
isalpha isdigit isspace tolower toupper
fread fwrite socket fcntl setsockopt connect send recv close
__builtin_next_arg __builtin_saveregs
@ -1030,7 +1030,7 @@
;; Accum top-level typedefs for pointers and non-pointers as a list-of-sym:
(define pointer-types '())
(define non-pointer-types '(int char long unsigned intptr_t ulong uint uintptr_t void float double uchar wchar_t))
(define non-pointer-types '(int char long unsigned intptr_t ulong uint uintptr_t void float double |long double| uchar wchar_t))
;; Accum top-level struct decls as list of (cons sym (list (cons symbol vtype) ...))
(define struct-defs '())

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

@ -584,6 +584,7 @@
(case type
[(flonum) 1]
[(fixnum) 2]
[(extflonum) 3]
[else (error 'type->index "unknown type: ~e" type)]))
(define (out-anything v out)

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

@ -107,6 +107,7 @@
(case n
[(2) 'flonum]
[(3) 'fixnum]
[(4) 'extflonum]
[else (error "invaid type flag")]))]
[(arg-types) (let ([num-params ((if rest? sub1 values) num-params)])
(for/list ([i (in-range num-params)])
@ -373,8 +374,8 @@
[(27) 'inline-variant-type]
[(35) 'variable-type]
[(36) 'module-variable-type]
[(113) 'resolve-prefix-type]
[(162) 'free-id-info-type]
[(114) 'resolve-prefix-type]
[(164) 'free-id-info-type]
[else (error 'int->type "unknown type: ~e" i)]))
(define type-readers
@ -554,6 +555,7 @@
(define SCHEME_LOCAL_TYPE_FLONUM 1)
(define SCHEME_LOCAL_TYPE_FIXNUM 2)
(define SCHEME_LOCAL_TYPE_EXTFLONUM 3)
(define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ 1)
@ -565,6 +567,7 @@
(let ([t (- flags SCHEME_LOCAL_TYPE_OFFSET)])
(cond
[(= t SCHEME_LOCAL_TYPE_FLONUM) 'flonum]
[(= t SCHEME_LOCAL_TYPE_EXTFLONUM) 'extflonum]
[(= t SCHEME_LOCAL_TYPE_FIXNUM) 'fixnum]
[else #f]))))
@ -856,6 +859,7 @@
(case (read-compact-number cp)
[(1) 'flonum]
[(2) 'fixnum]
[(3) 'extflonum]
[else #f]))
(eq? cpt-tag 'let-one-unused))]
[(branch)

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

@ -146,10 +146,10 @@
[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 'fixnum))]
[param-types (listof (or/c 'val 'ref 'flonum 'fixnum 'extflonum))]
[rest? boolean?]
[closure-map (vectorof exact-nonnegative-integer?)]
[closure-types (listof (or/c 'val/ref 'flonum 'fixnum))]
[closure-types (listof (or/c 'val/ref 'flonum 'fixnum 'extflonum))]
[toplevel-map (or/c #f (set/c exact-nonnegative-integer?))]
[max-let-depth exact-nonnegative-integer?]
[body (or/c expr? seq? any/c)])) ; `lambda'
@ -158,7 +158,7 @@
(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)]
[type (or/c #f 'flonum 'fixnum 'extflonum)]
[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?]
@ -173,7 +173,7 @@
[pos exact-nonnegative-integer?]
[clear? boolean?]
[other-clears? boolean?]
[type (or/c #f 'flonum 'fixnum)])) ; access local via stack
[type (or/c #f 'flonum 'fixnum 'extflonum)])) ; 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)

1
collects/drracket/acks.rkt
View File

@ -26,6 +26,7 @@
"Moy Easwaran, "
"Will Farr, "
"Matthias Felleisen, "
"Michael Filonenko, "
"Robby Findler, "
"Kathi Fisler, "
"Cormac Flanagan, "

21
collects/racket/extflonum.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(require '#%extfl
'#%unsafe
"private/vector-wraps.rkt"
(for-syntax racket/base))
(provide (all-from-out '#%extfl)
in-extflvector for/extflvector for*/extflvector
extflvector-copy)
(define-vector-wraps "extflvector"
extflvector? extflvector-length extflvector-ref extflvector-set! make-extflvector
unsafe-extflvector-ref unsafe-extflvector-set! unsafe-extflvector-length
in-extflvector*
in-extflvector
for/extflvector
for*/extflvector
extflvector-copy
0.0T0)

10
collects/racket/unsafe/ops.rkt
View File

@ -1,10 +1,16 @@
#lang racket/base
(require '#%unsafe
'#%flfxnum)
'#%flfxnum
'#%extfl)
(provide (all-from-out '#%unsafe)
(prefix-out unsafe-
(combine-out flsin flcos fltan
flasin flacos flatan
fltruncate flround flfloor flceiling
flexp fllog flexpt)))
flexp fllog flexpt
extflsin extflcos extfltan
extflasin extflacos extflatan
extfltruncate extflround extflfloor extflceiling
extflexp extfllog extflexpt)))

4
collects/scribble/racket.rkt
View File

@ -5,6 +5,7 @@
"private/manual-sprop.rkt"
"private/on-demand.rkt"
file/convertible
racket/extflonum
(for-syntax racket/base))
(provide define-code
@ -262,7 +263,8 @@
(char? v)
(regexp? v)
(byte-regexp? v)
(boolean? v)))
(boolean? v)
(extflonum? v)))
value-color]
[(identifier? c)
(cond

201
collects/scribblings/reference/extflonums.scrbl Normal file
View File

@ -0,0 +1,201 @@
#lang scribble/doc
@(require "mz.rkt" (for-label racket/extflonum
racket/flonum))
@title[#:tag "extflonums"]{Extflonums}
@defmodule[racket/extflonum]
An @deftech{extflonum} is an extended-precision (80-bit)
floating-point number. extflonum arithmetic is supported on
platforms with extended-precision hardware and where the
extflonum implementation does not conflict with normal
double-precision arithmetic (i.e., on x86 and x86_64 platforms when
Racket is compiled to use SSE instructions for floating-point
operations).
A extflonum is @bold{not} a @tech{number} in the sense of
@racket[number?]. Only extflonum-specific operations such as
@racket[extfl+] perform extflonum arithmetic.
A literal extflonum is written like an @tech{inexact number},
but using an explicit @litchar{t} or @litchar{T} exponent marker (see
@secref["parse-extflonum"]). For example, @racket[3.5t0] is an
extflonum.
If @racket[(extflonum-available?)] produces @racket[#f], then all
operations exported by @racketmodname[racket/extflonum] raise
@racket[exn:fail:unsupported], except for @racket[extflonum?],
@racket[extflonum-available?], and @racket[extflvector?] (which always
work). The reader (see @secref["reader"]) always accepts extflonum
input; when extflonum operations are not supported, printing an
extflonum from the reader uses its source notation (as opposed to
normalizing the format).
Two extflonums are @racket[equal?] if @racket[extfl=]
produces @racket[#t] for the extflonums. If extflonums
are not supported in a platform, extflonums are @racket[equal?]
only if they are @racket[eq?].
@defproc[(extflonum? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is an extflonum, @racket[#f]
otherwise.}
@defproc[(extflonum-available?) boolean?]{
Returns @racket[#t] if @tech{extflonum} operations are supported on the
current platform, @racket[#f] otherwise.}
@; ------------------------------------------------------------------------
@section{Extflonum Arithmetic}
@deftogether[(
@defproc[(extfl+ [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(extfl- [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(extfl* [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(extfl/ [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(extflabs [a extflonum?]) extflonum?]
)]{
Like @racket[fl+], @racket[fl-], @racket[fl*], @racket[fl/], and @racket[flabs],
but for @tech{extflonums}.}
@deftogether[(
@defproc[(extfl= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(extfl< [a extflonum?] [b extflonum?]) boolean?]
@defproc[(extfl> [a extflonum?] [b extflonum?]) boolean?]
@defproc[(extfl<= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(extfl>= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(extflmin [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(extflmax [a extflonum?] [b extflonum?]) extflonum?]
)]{
Like @racket[fl=], @racket[fl<], @racket[fl>], @racket[fl<=], @racket[fl>=],
@racket[flmin], and @racket[flmax], but for @tech{extflonums}.}
@deftogether[(
@defproc[(extflround [a extflonum?]) extflonum?]
@defproc[(extflfloor [a extflonum?]) extflonum?]
@defproc[(extflceiling [a extflonum?]) extflonum?]
@defproc[(extfltruncate [a extflonum?]) extflonum?]
)]{
Like @racket[flround], @racket[flfloor], @racket[flceiling], and
@racket[fltruncate], but for @tech{extflonums}.}
@deftogether[(
@defproc[(extflsin [a extflonum?]) extflonum?]
@defproc[(extflcos [a extflonum?]) extflonum?]
@defproc[(extfltan [a extflonum?]) extflonum?]
@defproc[(extflasin [a extflonum?]) extflonum?]
@defproc[(extflacos [a extflonum?]) extflonum?]
@defproc[(extflatan [a extflonum?]) extflonum?]
@defproc[(extfllog [a extflonum?]) extflonum?]
@defproc[(extflexp [a extflonum?]) extflonum?]
@defproc[(extflsqrt [a extflonum?]) extflonum?]
@defproc[(extflexpt [a extflonum?] [b extflonum?]) extflonum?]
)]{
Like @racket[flsin], @racket[flcos], @racket[fltan], @racket[flasin],
@racket[flacos], @racket[flatan], @racket[fllog], @racket[flexp], and
@racket[flsqrt], and @racket[flexpt], but for @tech{extflonums}.}
@deftogether[(
@defproc[(->extfl [a exact-integer?]) extflonum?]
@defproc[(extfl->exact-integer [a extflonum?]) exact-integer?]
@defproc[(real->extfl [a real?]) extflonum?]
@defproc[(extfl->exact [a real?]) (and/c real? exact?)]
@defproc[(extfl->inexact [a real?]) flonum?]
)]{
The first four are like @racket[->fl], @racket[fl->exact],
@racket[fl->real], @racket[inexact->exact], but for @tech{extflonums}.
The @racket[extfl->inexact] function converts a @tech{extflonum} to
its closest @racket{flonum} approximation.}
@; ------------------------------------------------------------------------
@section[#:tag "extflvectors"]{Extflonum Vectors}
An @deftech{extflvector} is like an @tech{flvector}, but it holds only
@tech{extflonums}. See also @secref["unsafeextfl"].
Two @tech{extflvectors} are @racket[equal?] if they have the same length,
and if the values in corresponding slots of the @tech{extflvectors} are
@racket[equal?].
@deftogether[(
@defproc[(extflvector? [v any/c]) boolean?]
@defproc[(extflvector [x extflonum?] ...) extflvector?]
@defproc[(make-extflvector [size exact-nonnegative-integer?]
[x extflonum? 0.0l0])
extflvector?]
@defproc[(extflvector-length [vec extflvector?]) exact-nonnegative-integer?]
@defproc[(extflvector-ref [vec extflvector?] [pos exact-nonnegative-integer?])
extflonum?]
@defproc[(extflvector-set! [vec extflvector?] [pos exact-nonnegative-integer?]
[x extflonum?])
extflonum?]
@defproc[(extflvector-copy [vec extflvector?]
[start exact-nonnegative-integer? 0]
[end exact-nonnegative-integer? (vector-length v)])
extflvector?]
)]{
Like @racket[flvector?], @racket[flvector], @racket[make-flvector],
@racket[flvector-length], @racket[flvector-ref], @racket[flvector-set],
and @racket[flvector-copy], but for @tech{extflvectors}.}
@deftogether[(
@defproc[(in-extflvector [vec extflvector?]
[start exact-nonnegative-integer? 0]
[stop (or/c exact-integer? #f) #f]
[step (and/c exact-integer? (not/c zero?)) 1])
sequence?]
@defform[(for/extflvector maybe-length (for-clause ...) body ...)]
@defform/subs[(for*/extflvector maybe-length (for-clause ...) body ...)
([maybe-length (code:line)
(code:line #:length length-expr)
(code:line #:length length-expr #:fill fill-expr)])
#:contracts ([length-expr exact-nonnegative-integer?]
[fill-expr extflonum?])]
)]{
Like @racket[in-flvector], @racket[for/flvector], and @racket[for*/flvector],
but for @tech{extflvectors}.}
@defproc[(make-shared-extflvector [size exact-nonnegative-integer?]
[x extflonum? 0.0l0])
extflvector?]{
Like @racket[make-shared-flvector], but for @tech{extflvectors}.}
@; ------------------------------------------------------------
@section[#:tag "extflutils"]{Extflonum Byte Strings}
@defproc[(floating-point-bytes->extfl [bstr bytes?]
[big-endian? any/c (system-big-endian?)]
[start exact-nonnegative-integer? 0]
[end exact-nonnegative-integer? (bytes-length bstr)])
extflonum?]{
Like @racket[floating-point-bytes->real], but for @tech{extflonums}:
Converts the extended-precision floating-point number encoded in
@racket[bstr] from position @racket[start] (inclusive) to @racket[end]
(exclusive) to an @tech{extflonum}. The difference between
@racket[start] an @racket[end] must be 10 bytes.}
@defproc[(extfl->floating-point-bytes [x extflonum?]
[big-endian? any/c (system-big-endian?)]
[dest-bstr (and/c bytes? (not/c immutable?))
(make-bytes 10)]
[start exact-nonnegative-integer? 0])
bytes?]{
Like @racket[real->floating-point-bytes], but for @tech{extflonums}:
Converts @racket[x] to its representation in a byte
string of length 10.}

1
collects/scribblings/reference/numbers.scrbl
View File

@ -1196,6 +1196,7 @@ Returns @racket[#t] if @racket[z] is @racket[+inf.0], @racket[-inf.0], @racket[+
@include-section["flonums.scrbl"]
@include-section["fixnums.scrbl"]
@include-section["extflonums.scrbl"]
@; ----------------------------------------------------------------------

15
collects/scribblings/reference/printer.scrbl
View File

@ -101,7 +101,7 @@ of printing enclosing datatypes, a symbol is @tech{quotable}.
A @tech{number} prints the same way in @racket[write], @racket[display], and
@racket[print] modes. For the purposes of printing enclosing
datatypes, a symbol is @tech{quotable}.
datatypes, a number is @tech{quotable}.
A @tech{complex number} that is not a @tech{real number} always prints
as @nonterm{m}@litchar{+}@nonterm{n}@litchar{i}, where @nonterm{m} and
@ -126,6 +126,19 @@ determined by @racket[numerator] and @racket[denominator]).
A negative @tech{exact number} prints with a @litchar{-} prefix on the
printed form of the number's exact negation.
@section[#:tag "print-extflonum"]{Printing Extflonums}
An @tech{extflonum} prints the same way in @racket[write],
@racket[display], and @racket[print] modes. For the purposes of
printing enclosing datatypes, an extflonum is @tech{quotable}.
An extflonum prints in the same way an inexact number, but
always with a @litchar{t} or @litchar{T} exponent marker. When
extflonum operations are supported, printing always uses
@litchar{t}; when extflonum operations are not supported, an
extflonum prints the same as its reader (see @secref["reader"])
source, since reading is the only way to produce an extflonum.
@section[#:tag "print-booleans"]{Printing Booleans}
The @tech{boolean} constant @racket[#t] prints as @litchar{#true} or @litchar{#t} in

33
collects/scribblings/reference/reader.scrbl
View File

@ -64,7 +64,7 @@ characters are @defterm{delimiters}:
}
A delimited sequence that starts with any other character is typically
parsed as either a symbol or number, but a few non-delimiter
parsed as either a symbol, number, or @tech{extflonum}, but a few non-delimiter
characters play special roles:
@itemize[
@ -144,10 +144,10 @@ on the next character or characters in the input stream as follows:
@dispatch[@cilitchar{#i}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#e}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#x}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#o}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#d}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#b}]{starts a @tech{number}; see @secref["parse-number"]}
@dispatch[@cilitchar{#x}]{starts a @tech{number} or @tech{extflonum}; see @secref["parse-number"]}
@dispatch[@cilitchar{#o}]{starts a @tech{number} or @tech{extflonum}; see @secref["parse-number"]}
@dispatch[@cilitchar{#d}]{starts a @tech{number} or @tech{extflonum}; see @secref["parse-number"]}
@dispatch[@cilitchar{#b}]{starts a @tech{number} or @tech{extflonum}; see @secref["parse-number"]}
@dispatch[@cilitchar["#<<"]]{starts a @tech{string}; see @secref["parse-string"]}
@ -187,12 +187,14 @@ on the next character or characters in the input stream as follows:
@guideintro["symbols"]{the syntax of symbols}
A sequence that does not start with a delimiter or @litchar{#} is
parsed as either a @tech{symbol} or a @tech{number} (see
@secref["parse-number"]), except that @litchar{.} by itself is never
parsed as a symbol or character (unless the @racket[read-accept-dot]
parsed as either a @tech{symbol}, a @tech{number} (see
@secref["parse-number"]), or a @tech{extflonum}
(see @secref["parse-extflonum"]),
except that @litchar{.} by itself is never
parsed as a symbol or number (unless the @racket[read-accept-dot]
parameter is set to @racket[#f]). A @as-index{@litchar{#%}} also
starts a symbol. The resulting symbol is @tech{interned}. A successful
number parse takes precedence over a symbol parse.
number or extflonum parse takes precedence over a symbol parse.
@index["case-sensitivity"]{@index["case-insensitive"]{When}} the
@racket[read-case-sensitive] @tech{parameter} is set to @racket[#f],
@ -245,6 +247,7 @@ If the reader encounters @as-index{@litchar{#b}} (binary),
@as-index{@litchar{#o}} (octal), @as-index{@litchar{#d}} (decimal), or
@as-index{@litchar{#x}} (hexadecimal), it must be followed by a
sequence that is terminated by a delimiter or end-of-file, and that
is either an @tech{extflonum} (see @secref["parse-extflonum"]) or
matches the @nonterm{general-number@sub{2}},
@nonterm{general-number@sub{8}}, @nonterm{general-number@sub{10}}, or
@nonterm{general-number@sub{16}} grammar, respectively.
@ -324,6 +327,18 @@ that the digit's actual value is unknown.
"#b101"
]
@section[#:tag "parse-extflonum"]{Reading Extflonums}
An @tech{extflonum} has the same syntax as an @nunterm{inexact-real}
that includes an @nunterm{exp-mark}, but with @litchar{t} or
@litchar{T} in place of the @nunterm{exp-mark}. A @litchar{#b}
(binary), @litchar{#o} (octal), @litchar{#d} (decimal), or
@litchar{#x} (hexadecimal) radix specification can prefix an
extflonum, but @litchar{#i} or @litchar{#e} cannot, and a
extflonum cannot be used to form a @tech{complex number}. The
@racket[read-decimal-as-inexact] @tech{parameter} has no effect on
extflonum reading.
@section[#:tag "parse-boolean"]{Reading Booleans}
A @as-index{@litchar{#true}}, @as-index{@litchar{#t}},

85
collects/scribblings/reference/unsafe.scrbl
View File

@ -2,6 +2,7 @@
@(require "mz.rkt"
(for-label racket/unsafe/ops
racket/flonum
racket/extflonum
(only-in ffi/vector
f64vector?
f64vector-ref
@ -321,3 +322,87 @@ The index @racket[k] must be between @racket[0] (inclusive) and
the number of fields in the structure (exclusive). In the case of
@racket[unsafe-struct-set!], the field must be mutable.}
@; ------------------------------------------------------------------------
@section[#:tag "unsafeextfl"]{Unsafe Extflonum Operations}
@deftogether[(
@defproc[(unsafe-extfl+ [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(unsafe-extfl- [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(unsafe-extfl* [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(unsafe-extfl/ [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(unsafe-extflabs [a extflonum?]) extflonum?]
)]{
Unchecked versions of @racket[extfl+], @racket[extfl-],
@racket[extfl*], @racket[extfl/], and @racket[extflabs].}
@deftogether[(
@defproc[(unsafe-extfl= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(unsafe-extfl< [a extflonum?] [b extflonum?]) boolean?]
@defproc[(unsafe-extfl> [a extflonum?] [b extflonum?]) boolean?]
@defproc[(unsafe-extfl<= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(unsafe-extfl>= [a extflonum?] [b extflonum?]) boolean?]
@defproc[(unsafe-extflmin [a extflonum?] [b extflonum?]) extflonum?]
@defproc[(unsafe-extflmax [a extflonum?] [b extflonum?]) extflonum?]
)]{
Unchecked versions of @racket[extfl=], @racket[extfl<],
@racket[extfl>], @racket[extfl<=], @racket[extfl>=], @racket[extflmin], and
@racket[extflmax].}
@deftogether[(
@defproc[(unsafe-extflround [a extflonum?]) extflonum?]
@defproc[(unsafe-extflfloor [a extflonum?]) extflonum?]
@defproc[(unsafe-extflceiling [a extflonum?]) extflonum?]
@defproc[(unsafe-extfltruncate [a extflonum?]) extflonum?]
)]{
Unchecked (potentially) versions of @racket[extflround],
@racket[extflfloor], @racket[extflceiling], and
@racket[extfltruncate]. Currently, these bindings are simply aliases
for the corresponding safe bindings.}
@deftogether[(
@defproc[(unsafe-extflsin [a extflonum?]) extflonum?]
@defproc[(unsafe-extflcos [a extflonum?]) extflonum?]
@defproc[(unsafe-extfltan [a extflonum?]) extflonum?]
@defproc[(unsafe-extflasin [a extflonum?]) extflonum?]
@defproc[(unsafe-extflacos [a extflonum?]) extflonum?]
@defproc[(unsafe-extflatan [a extflonum?]) extflonum?]
@defproc[(unsafe-extfllog [a extflonum?]) extflonum?]
@defproc[(unsafe-extflexp [a extflonum?]) extflonum?]
@defproc[(unsafe-extflsqrt [a extflonum?]) extflonum?]
@defproc[(unsafe-extflexpt [a extflonum?] [b extflonum?]) extflonum?]
)]{
Unchecked (potentially) versions of @racket[extflsin],
@racket[extflcos], @racket[extfltan], @racket[extflasin],
@racket[extflacos], @racket[extflatan], @racket[extfllog],
@racket[extflexp], @racket[extflsqrt], and
@racket[extflexpt]. Currently, some of these bindings are simply
aliases for the corresponding safe bindings.}
@deftogether[(
@defproc[(unsafe-fx->extfl [a fixnum?]) extflonum?]
@defproc[(unsafe-extfl->fx [a extflonum?]) fixnum?]
)]{
Unchecked conversion of a @tech{fixnum} to an integer @tech{extflonum} and vice versa.
These are similar to the safe bindings @racket[->extfl] and @racket[extfl->exact-integer],
but further constrained to consume or produce a fixnum.
}
@deftogether[(
@defproc[(unsafe-extflvector-length [v extflvector?]) fixnum?]
@defproc[(unsafe-extflvector-ref [v extflvector?] [k fixnum?]) any/c]
@defproc[(unsafe-extflvector-set! [v extflvector?] [k fixnum?] [x extflonum?]) void?]
)]{
Unchecked versions of @racket[extflvector-length], @racket[extflvector-ref], and
@racket[extflvector-set!]. A @tech{extflvector}'s size can never be larger than a
@tech{fixnum} (so even @racket[extflvector-length] always returns a
fixnum).}

395
collects/tests/racket/extflonum.rktl Normal file
View File

@ -0,0 +1,395 @@
;; copypaste with small modifications from flonum.rkt
(load-relative "loadtest.rktl")
(Section 'extflonum)
(require racket/extflonum
"for-util.rkt")
(when (extflonum-available?)
;; ----------------------------------------
(define (extflonum-close? fl1 fl2)
(extfl<= (extflabs (fl- fl1 fl2))
(real->extfl 1e-8)))
;; in-extflvector tests.
(let ((flv (extflvector 1.0t0 2.0t0 3.0t0)))
(let ((flv-seq (in-extflvector flv)))
(for ((x (in-extflvector flv))
(xseq flv-seq)
(i (in-naturals)))
(test (->extfl (+ i 1)) 'in-extflvector-fast x)
(test (->extfl (+ i 1)) 'in-extflvector-sequence xseq))))
;; for/extflvector test
(let ((flv (extflvector 1.0t0 2.0t0 3.0t0))
(flv1 (for/extflvector ((i (in-range 3))) (->extfl (+ i 1))))
(flv2 (for/extflvector #:length 3 ((i (in-range 3))) (real->extfl (+ i 1.0)))))
(test flv 'for/extflvector flv1)
(test flv 'for/extflvector-fast flv2))
(test (extflvector 1.0t0 2.0t0 3.0t0 0.0t0 0.0t0)
'for/extflvector-fill
(for/extflvector #:length 5 ([i 3]) (real->extfl (+ i 1.0))))
(test (extflvector 1.0t0 2.0t0 3.0t0 -10.0t0 -10.0t0)
'for/extflvector-fill
(for/extflvector #:length 5 #:fill -10.0t0 ([i 3]) (real->extfl (+ i 1.0))))
(test (extflvector 1.0t0 2.0t0 3.0t0 0.0t0 0.0t0)
'for/extflvector-fill
(for/extflvector #:length 5 ([i 5]) #:break (= i 3) (real->extfl (+ i 1.0))))
(test (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 0.0t0)
'for/extflvector-fill
(for/extflvector #:length 5 ([i 5]) #:final (= i 3) (real->extfl (+ i 1.0))))
;; for*/extflvector test
(let ((flv (extflvector 0.0t0 0.0t0 0.0t0 0.0t0 1.0t0 2.0t0 0.0t0 2.0t0 4.0t0))
(flv1 (for*/extflvector ((i (in-range 3)) (j (in-range 3))) (->extfl (* 1 i j))))
(flv2 (for*/extflvector #:length 9 ((i (in-range 3)) (j (in-range 3))) (real->extfl (* 1.0 i j)))))
(test flv 'for*/extflvector flv1)
(test flv 'for*/extflvector-fast flv2))
;; Stop when a length is specified, even if the sequence continues:
(test (extflvector 0.0t0 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0 9.0t0)
'nat
(for/extflvector #:length 10 ([i (in-naturals)]) (real->extfl i)))
(test (extflvector 0.0t0 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0 9.0t0)
'nats
(for*/extflvector #:length 10 ([i (in-naturals)] [j (in-naturals)]) (real->extfl j)))
(test (extflvector 0.0t0 0.0t0 0.0t0 0.0t0 0.0t0 1.0t0 1.0t0 1.0t0 1.0t0 1.0t0)
'nat+5
(for*/extflvector #:length 10 ([i (in-naturals)] [j (in-range 5)]) (real->extfl i)))
;; Test for both length too long and length too short
(let ((v (make-extflvector 3)))
(extflvector-set! v 0 0.0t0)
(extflvector-set! v 1 1.0t0)
(let ((w (for/extflvector #:length 3 ((i (in-range 2))) (real->extfl i))))
(test v 'for/extflvector-short-iter w)))
(let ((v (make-extflvector 10)))
(for* ((i (in-range 3))
(j (in-range 3)))
(extflvector-set! v (+ j (* i 3)) (real->extfl (+ 1.0 i j))))
(let ((w (for*/extflvector #:length 10 ((i (in-range 3)) (j (in-range 3))) (real->extfl (+ 1.0 i j)))))
(test v 'for*/extflvector-short-iter w)))
(test 2 'for/extflvector-long-iter
(extflvector-length (for/extflvector #:length 2 ((i (in-range 10))) (real->extfl i))))
(test 5 'for*/extflvector-long-iter
(extflvector-length (for*/extflvector #:length 5 ((i (in-range 3)) (j (in-range 3))) (real->extfl (+ i j)))))
;; Test for many body expressions
(let* ((flv (extflvector 1.0t0 2.0t0 3.0t0))
(flv2 (for/extflvector ((i (in-range 3)))
(extflvector-set! flv i (extfl+ (extflvector-ref flv i) 1.0t0))
(extflvector-ref flv i)))
(flv3 (for/extflvector #:length 3 ((i (in-range 3)))
(extflvector-set! flv i (extfl+ (extflvector-ref flv i) 1.0t0))
(extflvector-ref flv i))))
(test (extflvector 2.0t0 3.0t0 4.0t0) 'for/extflvector-many-body flv2)
(test (extflvector 3.0t0 4.0t0 5.0t0) 'for/extflvector-length-many-body flv3))
;; extflvector-copy test
(let ((v (extflvector 0.0t0 1.0t0 2.0t0 3.0t0)))
(let ((vc (extflvector-copy v)))
(test (extflvector-length v) 'extflvector-copy (extflvector-length vc))
(for ((vx (in-extflvector v))
(vcx (in-extflvector vc)))
(test vx 'extflvector-copy vcx))
(extflvector-set! vc 2 -10.0t0)
(test 2.0t0 'extflvector-copy (extflvector-ref v 2))
(test -10.0t0 'extflvector-copy (extflvector-ref vc 2))
(test '(2.0t0 3.0t0) 'extflvector-copy (for/list ([i (in-extflvector (extflvector-copy v 2))]) i))
(test '(2.0t0) 'extflvector-copy (for/list ([i (in-extflvector (extflvector-copy v 2 3))]) i))))
;; Check empty clauses
(let ()
(define vector-iters 0)
(test (extflvector 3.4t0 0.0t0 0.0t0 0.0t0)
'no-clauses
(for/extflvector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4t0))
(test 1 values vector-iters)
(test (extflvector 3.4t0 0.0t0 0.0t0 0.0t0)
'no-clauses
(for*/extflvector #:length 4 ()
(set! vector-iters (+ 1 vector-iters))
3.4t0))
(test 2 values vector-iters))
;; Check #:when and #:unless:
(test (extflvector 0.0t0 1.0t0 2.0t0 1.0t0 2.0t0)
'when-#t
(for/extflvector #:length 5
([x (in-range 3)]
#:when #t
[y (in-range 3)])
(real->extfl (+ x y))))
(test (extflvector 0.0t0 1.0t0 2.0t0 2.0t0 3.0t0)
'when-...
(for/extflvector #:length 5
([x (in-range 3)]
#:when (even? x)
[y (in-range 3)])
(real->extfl (+ x y))))
(test (extflvector 0.0t0 1.0t0 2.0t0 1.0t0 2.0t0)
'unless-#f
(for/extflvector #:length 5
([x (in-range 3)]
#:unless #f
[y (in-range 3)])
(real->extfl (+ x y))))
(test (extflvector 1.0t0 2.0t0 3.0t0 0.0t0 0.0t0)
'unless-...
(for/extflvector #:length 5
([x (in-range 3)]
#:unless (even? x)
[y (in-range 3)])
(real->extfl (+ x y))))
;; in-extflvector tests, copied from for.rktl
;;;;
;;;; TODO replace for/sum, because extflonum do not support + (addition) and other operations
;;;;
(define-syntax (test-multi-sequence stx)
(syntax-case stx ()
[(_ [(v ...) ...] gen)
(with-syntax ([(id ...) (generate-temporaries #'((v ...) ...))]
[(id2 ...) (generate-temporaries #'((v ...) ...))]
[((v2 ...) ...)
(apply map list (map syntax->list (syntax->list #'((v ...) ...))))])
#'(begin
(test `((v2 ...) ...) 'gen (for/list ([(id ...) gen])
(list id ...)))
(test-values `((v ...) ...) (lambda ()
(for/lists (id2 ...) ([(id ...) gen])
(values id ...))))
(test #t 'gen (for/and ([(id ...) gen])
(and (member (list id ...) `((v2 ...) ...)) #t)))
(test (list (for/last ([(id ...) gen])
(list id ...)))
'gen (for/and ([(id ...) gen])
(member (list id ...) `((v2 ...) ...))))
;; (test (for/first ([(id ...) gen])
;; (list id ...))
;; 'gen (for/or ([(id ...) gen])
;; (car (member (list id ...) `((v2 ...) ...)))))
(void)))]))
(define-syntax test-sequence
(syntax-rules ()
[(_ [seq] gen) ; we assume that seq has at least 2 elements, and all are unique
(begin
;; Some tests specific to single-values:
(test `seq 'gen (for/list ([i gen]) i))
(test `seq 'gen (for/list ([i gen][b gen]) i))
(test `seq 'gen (for/list ([i gen][b gen]) b))
(test `seq 'gen (for*/list ([i gen][b '(#t)]) i))
(test (map (lambda (x) #t) `seq) 'gen (for*/list ([i gen][b '(#t)]) b))
(test (append `seq `seq) 'gen (for*/list ([b '(#f #t)][i gen]) i))
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:when #t [i gen]) i))
(test (append `seq `seq) 'gen (for/list ([b '(#t #t #f)] #:when b [i gen]) i))
(test (append `seq `seq) 'gen (for/list ([b '(#f #t)] #:unless #f [i gen]) i))
(test (append `seq `seq) 'gen (for/list ([b '(#f #f #t)] #:unless b [i gen]) i))
(test `seq 'gen (let ([g gen]) (for/list ([i g]) i)))
(test `seq 'gen (let ([r null])
(for ([i gen]) (set! r (cons i r)))
(reverse r)))
(test `seq 'gen (reverse (for/fold ([a null]) ([i gen])
(cons i a))))
(test `seq 'gen (let-values ([(more? next) (sequence-generate gen)])
(let loop ()
(if (more?)
(cons (next) (loop))
null))))
(test-values `(seq seq) (lambda ()
(for/lists (r1 r2) ([id gen])
(values id id))))
(test (list (for/last ([i gen]) i)) 'gen (for/and ([i gen]) (member i `seq)))
(test `seq 'gen (for/or ([i gen]) (member i `seq)))
(test (for/first ([i gen]) i) 'gen (for/or ([i gen]) (and (member i `seq) i)))
;; (test (for/sum ([i gen]) (if (number? i) i 0)) 'gen
;; (for/fold ([n 0]) ([i gen]) (if (number? i) (+ i n) n)))
;; (test (for/product ([i gen]) (if (number? i) i 1)) 'gen
;; (for/fold ([n 1]) ([i gen]) (if (number? i) (* i n) n)))
(test #t 'gen (for/and ([(i k) (in-parallel gen `seq)])
(equal? i k)))
(test #f 'gen (for/and ([i gen])
(member i (cdr (reverse `seq)))))
(test #f 'gen (for/or ([i gen]) (equal? i 'something-else)))
(let ([count 0])
(test #t 'or (for/or ([i gen]) (set! count (add1 count)) #t))
(test 1 'count count)
(test #f 'or (for/or ([i gen]) (set! count (add1 count)) #f))
(test (+ 1 (length `seq)) 'count count)
(set! count 0)
(let ([second (for/last ([(i pos) (in-parallel gen (in-naturals))] #:when (< pos 2))
(set! count (add1 count))
i)])
(test second list-ref `seq 1)
(test 2 values count)
(for ([i gen] #:when (equal? i second)) (set! count (add1 count)))
(for* ([i gen] #:when (equal? i second)) (set! count (add1 count)))
(test 4 values count)
(for ([i (stop-before gen (lambda (x) (equal? x second)))]) (set! count (add1 count)))
(test 5 values count)
(let ([g (stop-before gen (lambda (x) (equal? x second)))])
(for ([i g]) (set! count (add1 count))))
(test 6 values count)
(for ([i (stop-after gen (lambda (x) (equal? x second)))]) (set! count (add1 count)))
(test 8 values count)
(let ([g (stop-after gen (lambda (x) (equal? x second)))])
(for ([i g]) (set! count (add1 count))))
(test 10 values count))
(set! count 0)
(test #t 'and (for/and ([(e idx) (in-indexed gen)]) (set! count (add1 count)) (equal? idx (sub1 count))))
(test #t 'and (let ([g (in-indexed gen)])
(set! count 0)
(for/and ([(e idx) g]) (set! count (add1 count)) (equal? idx (sub1 count)))))
(void))
;; Run multi-value tests:
(test-multi-sequence [seq] gen))]
[(_ seqs gen)
(test-multi-sequence seqs gen)]))
(test-sequence [(1.0t0 2.0t0 3.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0)))
(test-sequence [(2.0t0 3.0t0 4.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0) 1))
(test-sequence [(2.0t0 3.0t0 4.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0) 1 4))
(test-sequence [(2.0t0 4.0t0 6.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0) 1 7 2))
(test-sequence [(8.0t0 6.0t0 4.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0) 7 1 -2))
(test-sequence [(2.0t0 4.0t0 6.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0) 1 6 2))
(test-sequence [(8.0t0 6.0t0 4.0t0)] (in-extflvector (extflvector 1.0t0 2.0t0 3.0t0 4.0t0 5.0t0 6.0t0 7.0t0 8.0t0) 7 2 -2))
;; ----------------------------------------
;; Check corners of `extflexpt':
;; Tests by Neil T.:
(let ()
(define-syntax-rule (check-equal? (extflexpt v1 v2) b)
(test b extflexpt v1 v2))
;; 2^53 and every larger flonum is even:
(define +big-even.0t0 (extflexpt 2.0t0 53.0t0))
;; The largest odd flonum:
(define +max-odd.0t0 (extfl- +big-even.0t0 1.0t0))
(define -big-even.0t0 (extfl- 0.0t0 +big-even.0t0))
(define -max-odd.0t0 (extfl- 0.0t0 +max-odd.0t0))
(check-equal? (extflexpt +0.0t0 +0.0t0) +1.0t0)
(check-equal? (extflexpt +0.0t0 +1.0t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +3.0t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +max-odd.0t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +0.5t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +1.5t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +2.0t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +2.5t0) +0.0t0)
(check-equal? (extflexpt +0.0t0 +big-even.0t0) +0.0t0)
(check-equal? (extflexpt -0.0t0 +0.0t0) +1.0t0)
(check-equal? (extflexpt -0.0t0 +1.0t0) -0.0t0)
(check-equal? (extflexpt -0.0t0 +3.0t0) -0.0t0)
(check-equal? (extflexpt -0.0t0 +max-odd.0t0) -0.0t0)
(check-equal? (extflexpt -0.0t0 +0.5t0) +0.0t0)
(check-equal? (extflexpt -0.0t0 +1.5t0) +0.0t0)
(check-equal? (extflexpt -0.0t0 +2.0t0) +0.0t0)
(check-equal? (extflexpt -0.0t0 +2.5t0) +0.0t0)
(check-equal? (extflexpt -0.0t0 +big-even.0t0) +0.0t0)
(check-equal? (extflexpt +1.0t0 +0.0t0) +1.0t0)
(check-equal? (extflexpt +1.0t0 +0.5t0) +1.0t0)
(check-equal? (extflexpt +1.0t0 +inf.t) +1.0t0)
(check-equal? (extflexpt -1.0t0 +0.0t0) +1.0t0)
(check-equal? (extflexpt -1.0t0 +0.5t0) +nan.t)
(check-equal? (extflexpt -1.0t0 +inf.t) +1.0t0)
(check-equal? (extflexpt +0.5t0 +inf.t) +0.0t0)
(check-equal? (extflexpt +1.5t0 +inf.t) +inf.t)
(check-equal? (extflexpt +inf.t +0.0t0) +1.0t0)
(check-equal? (extflexpt +inf.t +1.0t0) +inf.t)
(check-equal? (extflexpt +inf.t +2.0t0) +inf.t)
(check-equal? (extflexpt +inf.t +inf.t) +inf.t)
(check-equal? (extflexpt -inf.t +0.0t0) +1.0t0)
(check-equal? (extflexpt -inf.t +1.0t0) -inf.t)
(check-equal? (extflexpt -inf.t +3.0t0) -inf.t)
(check-equal? (extflexpt -inf.t +max-odd.0t0) -inf.t)
(check-equal? (extflexpt -inf.t +0.5t0) +inf.t)
(check-equal? (extflexpt -inf.t +1.5t0) +inf.t)
(check-equal? (extflexpt -inf.t +2.0t0) +inf.t)
(check-equal? (extflexpt -inf.t +2.5t0) +inf.t)
(check-equal? (extflexpt -inf.t +big-even.0t0) +inf.t)
(check-equal? (extflexpt -inf.t +inf.t) +inf.t)
;; Same tests as above, but with negated y
;; This identity should hold for these tests: (extflexpt x y) = (/ 1.0t0 (extflexpt x (- y)))
(check-equal? (extflexpt +0.0t0 -0.0t0) +1.0t0)
(check-equal? (extflexpt +0.0t0 -1.0t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -3.0t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -max-odd.0t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -0.5t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -1.5t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -2.0t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -2.5t0) +inf.t)
(check-equal? (extflexpt +0.0t0 -big-even.0t0) +inf.t)
(check-equal? (extflexpt -0.0t0 -0.0t0) +1.0t0)
(check-equal? (extflexpt -0.0t0 -1.0t0) -inf.t)
(check-equal? (extflexpt -0.0t0 -3.0t0) -inf.t)
(check-equal? (extflexpt -0.0t0 -max-odd.0t0) -inf.t)
(check-equal? (extflexpt -0.0t0 -0.5t0) +inf.t)
(check-equal? (extflexpt -0.0t0 -1.5t0) +inf.t)
(check-equal? (extflexpt -0.0t0 -2.0t0) +inf.t)
(check-equal? (extflexpt -0.0t0 -2.5t0) +inf.t)
(check-equal? (extflexpt -0.0t0 -big-even.0t0) +inf.t)
(check-equal? (extflexpt +1.0t0 -0.0t0) +1.0t0)
(check-equal? (extflexpt +1.0t0 -0.5t0) +1.0t0)
(check-equal? (extflexpt +1.0t0 -inf.t) +1.0t0)
(check-equal? (extflexpt -1.0t0 -0.0t0) +1.0t0)
(check-equal? (extflexpt -1.0t0 -0.5t0) +nan.t)
(check-equal? (extflexpt -1.0t0 -inf.t) +1.0t0)
(check-equal? (extflexpt +0.5t0 -inf.t) +inf.t)
(check-equal? (extflexpt +1.5t0 -inf.t) +0.0t0)
(check-equal? (extflexpt +inf.t -0.0t0) +1.0t0)
(check-equal? (extflexpt +inf.t -1.0t0) +0.0t0)
(check-equal? (extflexpt +inf.t -2.0t0) +0.0t0)
(check-equal? (extflexpt +inf.t -inf.t) +0.0t0)
(check-equal? (extflexpt -inf.t -0.0t0) +1.0t0)
(check-equal? (extflexpt -inf.t -1.0t0) -0.0t0)
(check-equal? (extflexpt -inf.t -3.0t0) -0.0t0)
(check-equal? (extflexpt -inf.t -max-odd.0t0) -0.0t0)
(check-equal? (extflexpt -inf.t -0.5t0) +0.0t0)
(check-equal? (extflexpt -inf.t -1.5t0) +0.0t0)
(check-equal? (extflexpt -inf.t -2.0t0) +0.0t0)
(check-equal? (extflexpt -inf.t -2.5t0) +0.0t0)
(check-equal? (extflexpt -inf.t -big-even.0t0) +0.0t0)
(check-equal? (extflexpt -inf.t -inf.t) +0.0t0)
;; NaN input
(check-equal? (extflexpt +nan.t +0.0t0) +1.0t0)
(check-equal? (extflexpt +nan.t -0.0t0) +1.0t0)
(check-equal? (extflexpt +1.0t0 +nan.t) +1.0t0)
(check-equal? (extflexpt -1.0t0 +nan.t) +nan.t))
;; ----------------------------------------
)
(report-errs)

14
collects/tests/racket/numstrs.rktl
View File

@ -230,7 +230,19 @@
(#f "1@3+4i")
(#f "@2")
(#f "+a@2")
(DBZ "1/0+inf.0i")
(#f "3.0t0+4.0i")
(#f "3.0+4.0t0i")
(#f "3.0t0@4.0")
(#f "3.0@4.0t0")
(#f "inf.t+4.0i")
(#f "3.0+int.ti")
(#f "inf.t@4.0")
(#f "3.0@inf.t")
(#f "1/0+inf.t")
(#f "1/0@3.0t0")
(#f "1/0+3.0t0i")
(X "#e3.0t0")
(X "#i3.0t0")
(DBZ "+inf.0+1/0i")
(DBZ "1/0@+inf.0")
(DBZ "+inf.0@1/0")

21
collects/tests/racket/read.rktl
View File

@ -1148,6 +1148,27 @@
(err/rt-test (read-syntax 'x (open-input-string "#fx()")) exn:fail:read?)
(err/rt-test (read-syntax 'x (open-input-string "#fl()")) exn:fail:read?)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/extflonum)
(test #t extflonum? (readstr "0.0t0"))
(test #t extflonum? (readstr "-0.0t0"))
(test #t extflonum? (readstr "3.0t0"))
(test #t extflonum? (readstr "#b1.0t0"))
(test #t extflonum? (readstr "#d3.0t0"))
(test #t extflonum? (readstr "#o3.0t0"))
(test #t extflonum? (readstr "#x3.0t0"))
(test #f string->number "3.0t0")
(test #t extflonum? (parameterize ([read-decimal-as-inexact #f])
(readstr "3.0t0")))
(when (extflonum-available?)
(test 3t0 readstr "3.0t0")
(test 3t0 readstr "#b11.0t0")
(test 9t0 readstr "#o11.0t0")
(test 17t0 readstr "#x11.0t0"))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

128
collects/tests/racket/unsafe.rktl
View File

@ -3,10 +3,11 @@
(Section 'unsafe)
(require scheme/unsafe/ops
scheme/flonum
scheme/fixnum
scheme/foreign)
(require racket/unsafe/ops
racket/flonum
racket/fixnum
ffi/vector
racket/extflonum)
(let ()
(define ((add-star str) sym)
@ -136,6 +137,54 @@
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
(test-bin 1.5 'unsafe-fl/ 1.5 1.0)
(when (extflonum-available?)
(test-bin 3.4t0 'unsafe-extfl+ 1.4t0 2.0t0)
(test-bin -1.0999999999999999999t0 'unsafe-extfl+ 1.0t0 -2.1t0)
(test-bin +inf.t 'unsafe-extfl+ 1.0t0 +inf.t)
(test-bin -inf.t 'unsafe-extfl+ 1.0t0 -inf.t)
(test-bin +nan.t 'unsafe-extfl+ +nan.t -inf.t)
(test-bin 1.5t0 'unsafe-extfl+ 1.5t0 0.0t0)
(test-bin 1.7t0 'unsafe-extfl+ 0.0t0 1.7t0)
(test-bin 7.9t0 'unsafe-extfl- 10.0t0 2.1t0)
(test-bin 3.7t0 'unsafe-extfl- 1.0t0 -2.7t0)
(test-bin 1.5t0 'unsafe-extfl- 1.5t0 0.0t0)
(test-bin 20.002t0 'unsafe-extfl* 10.001t0 2.0t0)
(test-bin -20.002t0 'unsafe-extfl* 10.001t0 -2.0t0)
(test-bin +nan.t 'unsafe-extfl* +inf.t 0.0t0)
(test-bin 1.8t0 'unsafe-extfl* 1.0t0 1.8t0)
(test-bin 1.81t0 'unsafe-extfl* 1.81t0 1.0t0)
(test-bin (real->extfl 17/5) 'unsafe-extfl/ 17.0t0 5.0t0)
(test-bin +inf.t 'unsafe-extfl/ 17.0t0 0.0t0)
(test-bin -inf.t 'unsafe-extfl/ -17.0t0 0.0t0)
(test-bin 1.5t0 'unsafe-extfl/ 1.5t0 1.0t0)
(test-un 5.0t0 unsafe-extflabs 5.0t0)
(test-un 5.0t0 unsafe-extflabs -5.0t0)
(test-un 0.0t0 unsafe-extflabs -0.0t0)
(test-un +inf.t unsafe-extflabs -inf.t)
(test-un 5.0t0 unsafe-extflsqrt 25.0t0)
(test-un 0.5t0 unsafe-extflsqrt 0.25t0)
(test-un +nan.t unsafe-extflsqrt -1.0t0)
(test-un 8.0t0 'unsafe-fx->extfl 8)
(test-un -8.0t0 'unsafe-fx->extfl -8)
(test-un 8 'unsafe-extfl->fx 8.0t0)
(test-un -8 'unsafe-extfl->fx -8.0t0)
(test-bin 3.7t0 'unsafe-extflmin 3.7t0 4.1t0)
(test-bin 2.1t0 'unsafe-extflmin 3.7t0 2.1t0)
(test-bin +nan.t 'unsafe-extflmin +nan.t 2.1t0)
(test-bin +nan.t 'unsafe-extflmin 2.1t0 +nan.t)
(test-bin 3.7t0 'unsafe-extflmax 3.7t0 2.1t0)
(test-bin 4.1t0 'unsafe-extflmax 3.7t0 4.1t0)
(test-bin +nan.t 'unsafe-extflmax +nan.t 2.1t0)
(test-bin +nan.t 'unsafe-extflmax 2.1t0 +nan.t))
(test-bin 3 'unsafe-fxand 7 3)
(test-bin 2 'unsafe-fxand 6 3)
(test-bin 3 'unsafe-fxand -1 3)
@ -201,6 +250,20 @@
(test-tri 'yes '(lambda (x y z) (if (unsafe-fl< (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
(test-tri #f '(lambda (x y z) (unsafe-fl> (unsafe-fl+ x y) z)) 1.2 3.4 5.0)
(test-tri 'no '(lambda (x y z) (if (unsafe-fl> (unsafe-fl+ x y) z) 'yes 'no)) 1.2 3.4 5.0)
(when (extflonum-available?)
(test-tri 9.0t0 '(lambda (x y z) (unsafe-extfl+ (unsafe-extfl- x z) y)) 4.5t0 7.0t0 2.5t0)
(test-tri 9.0t0 '(lambda (x y z) (unsafe-extfl+ y (unsafe-extfl- x z))) 4.5t0 7.0t0 2.5t0)
(test-bin 10.0t0 '(lambda (x y) (unsafe-extfl+ (unsafe-fx->extfl x) y)) 2 8.0t0)
(test-bin 10.0t0 '(lambda (x y) (unsafe-extfl+ (unsafe-fx->extfl x) y)) 2 8.0t0)
(test-bin 9.5t0 '(lambda (x y) (unsafe-extfl+ (unsafe-extflabs x) y)) -2.0t0 7.5t0)
(test-tri (unsafe-extfl/ 20.0t0 0.8t0) '(lambda (x y z) (unsafe-extfl/ (unsafe-extfl* x z) y)) 4.0t0 0.8t0 5.0t0)
(test-tri (unsafe-extfl/ 0.8t0 20.0t0) '(lambda (x y z) (unsafe-extfl/ y (unsafe-extfl* x z))) 4.0t0 0.8t0 5.0t0)
(test-tri #t '(lambda (x y z) (unsafe-extfl< (unsafe-extfl+ x y) z)) 1.2t0 3.4t0 5.0t0)
(test-tri 'yes '(lambda (x y z) (if (unsafe-extfl< (unsafe-extfl+ x y) z) 'yes 'no)) 1.2t0 3.4t0 5.0t0)
(test-tri #f '(lambda (x y z) (unsafe-extfl> (unsafe-extfl+ x y) z)) 1.2t0 3.4t0 5.0t0)
(test-tri 'no '(lambda (x y z) (if (unsafe-extfl> (unsafe-extfl+ x y) z) 'yes 'no)) 1.2t0 3.4t0 5.0t0))
;; test unboxing interaction with free variables:
(test-tri 4.4 '(lambda (x y z) (with-handlers ([exn:fail:contract:variable?
@ -208,6 +271,12 @@
(unsafe-fl- (unsafe-fl+ x y) NO-SUCH-VARIABLE)))
1.1 3.3 5.2)
(when (extflonum-available?)
(test-tri 4.4t0 '(lambda (x y z) (with-handlers ([exn:fail:contract:variable?
(lambda (exn) (unsafe-extfl+ x y))])
(unsafe-extfl- (unsafe-extfl+ x y) NO-SUCH-VARIABLE)))
1.1t0 3.3t0 5.2t0))
(test-un 5 'unsafe-car (cons 5 9))
(test-un 9 'unsafe-cdr (cons 5 9))
(test-un 15 'unsafe-mcar (mcons 15 19))
@ -304,6 +373,15 @@
#:post (lambda (x) (list x (f64vector-ref v 2)))
#:literal-ok? #f))
(when (extflonum-available?)
(test-bin 9.5t0 'unsafe-extflvector-ref (extflvector 1.0t0 9.5t0 18.7t0) 1)
(test-un 5 'unsafe-extflvector-length (extflvector 1.1t0 2.0t0 3.1t0 4.5t0 5.7t0))
(let ([v (extflvector 1.0t0 9.5t0 18.7t0)])
(test-tri (list (void) 27.4t0) 'unsafe-extflvector-set! v 2 27.4t0
#:pre (lambda () (extflvector-set! v 2 0.0t0))
#:post (lambda (x) (list x (extflvector-ref v 2)))
#:literal-ok? #f)))
(test-bin 95 'unsafe-fxvector-ref (fxvector 10 95 187) 1)
(test-un 5 'unsafe-fxvector-length (fxvector 11 20 31 45 57))
(let ([v (fxvector 10 95 187)])
@ -394,6 +472,38 @@
(- n 1))))))])
(test 500000.0 f 1.0))
(when (extflonum-available?)
(let ([f (lambda (x)
(let ([x (unsafe-extfl+ x 1.0t0)])
(let loop ([v 0.0t0][n 10000])
(if (zero? n)
v
(loop (unsafe-extfl+ v x)
(- n 1))))))])
(test 20000.0t0 f 1.0t0))
(let ([f (lambda (x)
(let ([x (unsafe-extfl+ x 1.0t0)])
(let loop ([v 0.0t0][n 10000][q 2.0t0])
(if (zero? n)
(unsafe-extfl+ v q)
(loop (unsafe-extfl+ v x)
(- n 1)
(unsafe-extfl- 0.0t0 q))))))])
(test 20002.0t0 f 1.0t0))
(let ([f (lambda (x)
(let loop ([a 0.0t0][v 0.0t0][n 1000000])
(if (zero? n)
v
(if (odd? n)
(let ([b (unsafe-extfl+ a a)])
(loop b v (sub1 n)))
;; First arg is un place, but may need re-boxing
(loop a
(unsafe-extfl+ v x)
(- n 1))))))])
(test 1000000.0t0 f 2.0t0)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that compiling a misapplication of `unsafe-car' and `unsafe-cdr'
@ -422,6 +532,16 @@
(test 15388.0 floor (* 1000.0 (weird (lambda () 64.0)))))
(when (extflonum-available?)
(define weird #f)
(set! weird
(lambda (get-M)
(let* ([M (get-M)]
[N1 (unsafe-extfl/ M (unsafe-extfllog M))])
(get-M) ; triggers safe-for-space clearing of M
N1)))
(test 15388.0t0 unsafe-extflfloor (unsafe-extfl* 1000.0t0 (weird (lambda () 64.0t0)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

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

@ -1,3 +1,8 @@
Version 5.3.2.2
Added extflonums
racket/extflonum: added
racket/unsafe/ops: added extflonum operations
Version 5.3.2.2
Added file-truncate
scribble/latex-properties: added command-extras

18
src/README
View File

@ -367,6 +367,21 @@ directory) has been modified slightly from Boehm's standard
distribution. Mostly, the change modify the way that object
finalization is handled.
Floating point, x87, SSE, Extflonums, and the JIT
-------------------------------------------------
Pre-processor tests in "sconfig.h" and "scheme.h" attempt to determine
when the x87 floating-point processor needs to be configured for
double-precision mode, when JIT can use SSE instructions, and when
extflonums can be supported because both the JIT and C code use SSE
for double-precision floating-point while `long double' is available
for extflonums.
In particular, "scheme.h" looks for __SSE_MATH__ to indicate that gcc
is compiling floating-point operations as SSE, so be sure to include
flags like "-mfpmath=sse" or "-mfpmath=387" in CPPFLAGS, and not just
CFLAGS. See related configuration options below.
Configuration Options
---------------------
@ -380,6 +395,9 @@ Some CPP flags control default settings in "racket/sconfig.h":
* MZ_USE_DETERMINSTIC_FUEL - disables use of itimer or pthread for
Racket thread scheduling.
* C_COMPILER_USES_SSE - declares that the C compiler is using SSE
instructions to implement `double' floating-point operations.
Modifying Racket
----------------

17
src/configure vendored
View File

@ -1343,6 +1343,7 @@ Optional Features:
--enable-futures support futures (usually enabled by default)
--enable-float support single-precision floats (enabled by default)
--enable-floatinstead use single-precision by default
--enable-extflonum support extflonums (enabled by default, if available)
--enable-racket=<path> use <path> as Racket executable to build Racket
--enable-origtree install with original directory structure
--enable-pkgscope=<s> set `raco pkg' default: installation, user, or shared
@ -2006,6 +2007,13 @@ if test "${enable_floatinstead+set}" = set; then
enableval=$enable_floatinstead;
fi
# Check whether --enable-extflonum was given.
if test "${enable_extflonum+set}" = set; then
enableval=$enable_extflonum;
else
enable_extflonum=yes
fi
# Check whether --enable-racket was given.
if test "${enable_racket+set}" = set; then
@ -2355,6 +2363,7 @@ show_explicitly_enabled "${enable_backtrace}" "3m GC backtraces"
show_explicitly_disabled "${enable_float}" "Single-precision floats"
show_explicitly_enabled "${enable_floatinstead}" "Single-precision default floats"
show_explicitly_disabled "${enable_extflonum}" "Extflonums"
show_explicitly_enabled "${enable_pthread}" "pthreads"
show_explicitly_enabled "${enable_oskit}" "OSKit"
@ -2508,6 +2517,14 @@ _ACEOF
fi
if test "${enable_extflonum}" = "no" ; then
cat >>confdefs.h <<\_ACEOF
#define MZ_NO_EXTFLONUMS 1
_ACEOF
fi
###### Autoconfigure #######
COMPFLAGS=""

6
src/racket/configure.ac
View File

@ -33,6 +33,7 @@ AC_ARG_ENABLE(places, [ --enable-places support places (3m only; usual
AC_ARG_ENABLE(futures, [ --enable-futures support futures (usually enabled by default)])
AC_ARG_ENABLE(float, [ --enable-float support single-precision floats (enabled by default)], , enable_float=yes)
AC_ARG_ENABLE(floatinstead, [ --enable-floatinstead use single-precision by default])
AC_ARG_ENABLE(extflonum, [ --enable-extflonum support extflonums (enabled by default, if available)], , enable_extflonum=yes)
AC_ARG_ENABLE(racket, [ --enable-racket=<path> use <path> as Racket executable to build Racket])
@ -274,6 +275,7 @@ show_explicitly_enabled "${enable_backtrace}" "3m GC backtraces"
show_explicitly_disabled "${enable_float}" "Single-precision floats"
show_explicitly_enabled "${enable_floatinstead}" "Single-precision default floats"
show_explicitly_disabled "${enable_extflonum}" "Extflonums"
show_explicitly_enabled "${enable_pthread}" "pthreads"
show_explicitly_enabled "${enable_oskit}" "OSKit"
@ -415,6 +417,10 @@ if test "${enable_float}" = "yes" ; then
AC_DEFINE(USE_SINGLE_FLOATS,1,[Single-precision floats])
fi
if test "${enable_extflonum}" = "no" ; then
AC_DEFINE(MZ_NO_EXTFLONUMS,1,[Extflonums disabled])
fi
###### Autoconfigure #######
COMPFLAGS=""

51
src/racket/include/scheme.h
View File

@ -63,6 +63,26 @@
# define MZ_USE_SINGLE_FLOATS
#endif
/* gcc defines __SSE_MATH__ when SSE floating point is enabled: */
#ifdef __SSE_MATH__
# define C_COMPILER_USES_SSE 1
#endif
#ifdef C_COMPILER_USES_SSE
# if defined(MZ_TRY_EXTFLONUMS) && !defined(MZ_NO_EXTFLONUMS)
# define MZ_LONG_DOUBLE
# ifdef ASM_DBLPREC_CONTROL_87
# define ASM_EXTPREC_CONTROL_87
# endif
# endif
# ifdef ASM_DBLPREC_CONTROL_87
# undef ASM_DBLPREC_CONTROL_87
# endif
# if defined(MZ_USE_JIT_I386) && !defined(MZ_NO_JIT_SSE)
# define MZ_USE_JIT_SSE
# endif
#endif
#ifdef DONT_ITIMER
# undef USE_ITIMER
#endif
@ -328,6 +348,18 @@ typedef struct {
double double_val;
} Scheme_Double;
#ifdef MZ_LONG_DOUBLE
typedef struct {
Scheme_Object so;
long double long_double_val;
} Scheme_Long_Double;
#else
typedef struct {
Scheme_Object so;
const char *printed_form;
} Scheme_Long_Double;
#endif
#ifdef MZ_USE_SINGLE_FLOATS
typedef struct {
Scheme_Object so;
@ -357,6 +389,14 @@ typedef struct Scheme_Double_Vector {
double els[mzFLEX_ARRAY_DECL];
} Scheme_Double_Vector;
#ifdef MZ_LONG_DOUBLE
typedef struct Scheme_Long_Double_Vector {
Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
intptr_t size;
long double els[mzFLEX_ARRAY_DECL];
} Scheme_Long_Double_Vector;
#endif
typedef struct Scheme_Print_Params Scheme_Print_Params;
typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
@ -416,6 +456,8 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_REALP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) < scheme_complex_type)))
#define SCHEME_NUMBERP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type)))
#define SCHEME_LONG_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_long_double_type)
#define SCHEME_CHAR_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_string_type)
#define SCHEME_MUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
@ -469,6 +511,7 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_IMMUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_FLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type)
#define SCHEME_EXTFLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_extflvector_type)
#define SCHEME_FXVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_fxvector_type)
#define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
@ -535,6 +578,9 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_CHAR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.char_val)
#define SCHEME_INT_VAL(obj) (OBJ_TO_LONG(obj)>>1)
#define SCHEME_DBL_VAL(obj) (((Scheme_Double *)(obj))->double_val)
#ifdef MZ_LONG_DOUBLE
#define SCHEME_LONG_DBL_VAL(obj) (((Scheme_Long_Double *)(obj))->long_double_val)
#endif
#ifdef MZ_USE_SINGLE_FLOATS
# define SCHEME_FLT_VAL(obj) (((Scheme_Float *)(obj))->float_val)
# define SCHEME_FLOAT_VAL(obj) (SCHEME_DBLP(obj) ? SCHEME_DBL_VAL(obj) : SCHEME_FLT_VAL(obj))
@ -581,6 +627,11 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
#define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size)
#define SCHEME_FLVEC_ELS(obj) (((Scheme_Double_Vector *)(obj))->els)
#ifdef MZ_LONG_DOUBLE
#define SCHEME_EXTFLVEC_SIZE(obj) (((Scheme_Long_Double_Vector *)(obj))->size)
#define SCHEME_EXTFLVEC_ELS(obj) (((Scheme_Long_Double_Vector *)(obj))->els)
#endif
#define SCHEME_FXVEC_SIZE(obj) SCHEME_VEC_SIZE(obj)
#define SCHEME_FXVEC_ELS(obj) SCHEME_VEC_ELS(obj)

8
src/racket/include/schthread.h
View File

@ -163,6 +163,10 @@ typedef struct Thread_Local_Variables {
void *retry_alloc_r1_;
double scheme_jit_save_fp_;
double scheme_jit_save_fp2_;
#ifdef MZ_LONG_DOUBLE
long double scheme_jit_save_extfp_;
long double scheme_jit_save_extfp2_;
#endif
struct Scheme_Bucket_Table *starts_table_;
struct Scheme_Bucket_Table *submodule_empty_modidx_table_;
struct Scheme_Modidx *modidx_caching_chain_;
@ -543,6 +547,10 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
#define retry_alloc_r1 XOA (scheme_get_thread_local_variables()->retry_alloc_r1_)
#define scheme_jit_save_fp XOA (scheme_get_thread_local_variables()->scheme_jit_save_fp_)
#define scheme_jit_save_fp2 XOA (scheme_get_thread_local_variables()->scheme_jit_save_fp2_)
#ifdef MZ_LONG_DOUBLE
#define scheme_jit_save_extfp XOA (scheme_get_thread_local_variables()->scheme_jit_save_extfp_)
#define scheme_jit_save_extfp2 XOA (scheme_get_thread_local_variables()->scheme_jit_save_extfp2_)
#endif
#define starts_table XOA (scheme_get_thread_local_variables()->starts_table_)
#define submodule_empty_modidx_table XOA (scheme_get_thread_local_variables()->submodule_empty_modidx_table_)
#define modidx_caching_chain XOA (scheme_get_thread_local_variables()->modidx_caching_chain_)

3
src/racket/mzconfig.h.in
View File

@ -82,4 +82,7 @@ typedef unsigned long uintptr_t;
#undef USE_SINGLE_FLOATS
#undef USE_SINGLE_FLOATS_AS_DEFAULT
/* To disable extflonums when they would otherwise work: */
#undef MZ_NO_EXTFLONUMS
#endif

58
src/racket/sconfig.h
View File

@ -159,9 +159,8 @@
# if defined(i386)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-linux"
# define REGISTER_POOR_MACHINE
# ifndef MZ_USE_JIT_SSE
# define ASM_DBLPREC_CONTROL_87
# endif
# define MZ_TRY_EXTFLONUMS
# define ASM_DBLPREC_CONTROL_87
# endif
# if defined(powerpc)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "ppc-linux"
@ -185,9 +184,8 @@
# if defined(__x86_64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "x86_64-linux"
# define REGISTER_POOR_MACHINE
# ifdef MZ_NO_JIT_SSE
# define ASM_DBLPREC_CONTROL_87
# endif
# define ASM_DBLPREC_CONTROL_87
# define MZ_TRY_EXTFLONUMS
# endif
# ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "unknown-linux"
@ -341,21 +339,19 @@
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-freebsd"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_I386
# ifndef MZ_JIT_X86_SSE
# if defined(__FreeBSD_kernel__)
# define ASM_DBLPREC_CONTROL_87
# else
# define FREEBSD_CONTROL_387
# endif
# define MZ_TRY_EXTFLONUMS
# if defined(__FreeBSD_kernel__)
# define ASM_DBLPREC_CONTROL_87
# else
# define FREEBSD_CONTROL_387
# endif
# elif defined(__amd64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "amd64-freebsd"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_X86_64
# ifdef MZ_NO_JIT_SSE
# if defined(__FreeBSD_kernel__)
# define ASM_DBLPREC_CONTROL_87
# endif
# define MZ_TRY_EXTFLONUMS
# if defined(__FreeBSD_kernel__)
# define ASM_DBLPREC_CONTROL_87
# endif
# elif defined(__sparc64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "sparc64-freebsd"
@ -632,6 +628,7 @@
# define IGNORE_BY_MS_CONTROL_87
#endif
#if defined(__MINGW32__)
# define MZ_TRY_EXTFLONUMS
# define ASM_DBLPREC_CONTROL_87
#endif
@ -646,6 +643,7 @@
# else
# define MZ_USE_JIT_I386
# endif
# define MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC
# define FLAGS_ALREADY_SET
@ -772,18 +770,16 @@
#if defined(__POWERPC__)
# define MZ_USE_JIT_PPC
#elif defined(__x86_64__)
# define MZ_USE_JIT_X86_64
#else
# define MZ_USE_JIT_I386
# ifndef MZ_NO_JIT_SSE
# define MZ_USE_JIT_SSE
# if defined(__x86_64__)
# define MZ_USE_JIT_X86_64
# else
# define MZ_USE_JIT_I386
# endif
# define ASM_DBLPREC_CONTROL_87
# define MZ_TRY_EXTFLONUMS
#endif
#ifdef MZ_NO_JIT_SSE
# define ASM_DBLPREC_CONTROL_87
#endif
# define POW_HANDLES_CASES_CORRECTLY
# define MZ_JIT_USE_MPROTECT
@ -1005,16 +1001,14 @@
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "i386-dragonfly"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_I386
# ifndef MZ_JIT_X86_SSE
# define ASM_DBLPREC_CONTROL_87
# endif
# define ASM_DBLPREC_CONTROL_87
# define MZ_TRY_EXTFLONUMS
# elif defined(__amd64__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "amd64-dragonfly"
# define REGISTER_POOR_MACHINE
# define MZ_USE_JIT_X86_64
# ifdef MZ_NO_JIT_SSE
# define ASM_DBLPREC_CONTROL_87
# endif
# define ASM_DBLPREC_CONTROL_87
# define MZ_TRY_EXTFLONUMS
# else
# error Unported platform.
# endif
@ -1348,7 +1342,9 @@
/* ASM_DBLPREC_CONTROL_87 uses inline assembly to set Intel '387
floating-point operations to double-precision instead of
extended-precision arithmetic. */
extended-precision arithmetic. This definition is turned off
if the C compiler and JIT use SSE, and ASM_EXTPREC_CONTROL_87
is turned on instead if extflonums are enabled. */
/* IGNORE_BY_BORLAND_CONTROL_87 turns off floating-point error for
Intel '387 with Borlad-style _control87. DONT_IGNORE_PIPE_SIGNAL

2
src/racket/sgc/checkreg
View File

@ -3,7 +3,7 @@ string=? ; exec "${PLTHOME}/bin/racket" -gqr $0 "$@"
; Script to check that global and static variables are registered
(define ignore-types (list "int" "long" "short" "double" "float" "DWORD"))
(define ignore-types (list "int" "long" "short" "double" "long double" "float" "DWORD"))
(define-struct decl (type file))

5
src/racket/src/Makefile.in
View File

@ -293,12 +293,13 @@ SCONFIG = $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h ../mzconfig.h
COMMON_HEADERS = $(srcdir)/schpriv.h $(srcdir)/schexn.h $(SCONFIG) $(srcdir)/../include/scheme.h \
$(srcdir)/../include/schthread.h $(srcdir)/mzrt.h $(srcdir)/mzrt_cas.inc
JIT_HEADERS = $(srcdir)/../src/jit.h \
JIT_HEADERS = $(srcdir)/../src/jit.h $(srcdir)/../src/jitfpu.h \
$(srcdir)/../src/stypes.h \
$(srcdir)/lightning/i386/core.h $(srcdir)/lightning/i386/core-common.h \
$(srcdir)/lightning/i386/asm.h $(srcdir)/lightning/i386/asm-common.h \
$(srcdir)/lightning/i386/funcs.h $(srcdir)/lightning/i386/funcs-common.h \
$(srcdir)/lightning/i386/fp.h $(srcdir)/lightning/i386/fp-sse.h $(srcdir)/lightning/i386/fp-common.h \
$(srcdir)/lightning/i386/fp.h $(srcdir)/lightning/i386/fp-sse.h \
$(srcdir)/lightning/i386/fp-common.h $(srcdir)/lightning/i386/fp-extfpu.h \
$(srcdir)/lightning/ppc/core.h $(srcdir)/lightning/ppc/core-common.h \
$(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \
$(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \

51
src/racket/src/bgnfloat.inc
View File

@ -3,13 +3,20 @@
START_XFORM_SKIP;
#endif
/* Optimization sometimes causes a problem: d is represented in an
extended format instead of a `double'. We don't want to turn off
floatng-point optimizations in the rest of the program, so we use a
little function to defeat the optimization: */
#ifndef FP_ZEROx
# define FP_ZEROx 0.0
# define FP_ONEx 1.0
# define FP_TWOx 2.0
# define FP_POWx pow
# define FP_MZ_IS_POS_INFINITY(x) MZ_IS_POS_INFINITY(x)
# define FP_scheme_floating_point_nzero scheme_floating_point_nzero
#endif
/* Optimization sometimes causes a problem?
See note in "ratfloat.inc". */
int IS_FLOAT_INF(FP_TYPE d)
{
return MZ_IS_POS_INFINITY(d);
return FP_MZ_IS_POS_INFINITY(d);
}
/* Must not trigger GC! (Required by xform in number.c) */
@ -26,13 +33,13 @@ FP_TYPE SCHEME_BIGNUM_TO_FLOAT_INFO(const Scheme_Object *n, intptr_t skip, intpt
if (skip >= nl) {
if (SCHEME_BIGPOS(n))
return 0.0;
return FP_ZEROx;
else
return scheme_floating_point_nzero;
return FP_scheme_floating_point_nzero;
} else
nl -= skip;
d = 0;
d = FP_ZEROx;
while (nl--) {
d *= (FP_TYPE)BIG_RADIX;
d += *(--na);
@ -66,35 +73,35 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
FP_TYPE r;
Scheme_Object *n, *m;
r = 1;
r = FP_ONEx;
SCHEME_CHECK_FLOAT("inexact->exact", d, "integer");
if (d < 0) {
if (d < FP_ZEROx) {
negate = 1;
d = -d;
} else
negate = 0;
if (d < 1.0)
if (d < FP_ONEx)
return scheme_make_integer(0);
log = 0;
while (r < d) {
log++;
r *= 2.0;
r *= FP_TWOx;
}
if (log > USE_FLOAT_BITS) {
times = log - USE_FLOAT_BITS;
log = USE_FLOAT_BITS;
for (i = 0; i < times; i++) {
d /= 2;
d /= FP_TWOx;
}
} else
times = 0;
r = pow(2.0, (FP_TYPE)log);
r = pow(FP_TWOx, (FP_TYPE)log);
n = scheme_make_small_bignum(0, &s1);
@ -105,7 +112,7 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
d -= r;
bignum_add1_inplace(&n);
}
r /= 2;
r /= FP_TWOx;
}
if (times) {
@ -123,3 +130,17 @@ Scheme_Object *SCHEME_BIGNUM_FROM_FLOAT(FP_TYPE d)
return n;
}
#undef USE_FLOAT_BITS
#undef FP_TYPE
#undef IS_FLOAT_INF
#undef SCHEME_BIGNUM_TO_FLOAT_INFO
#undef SCHEME_BIGNUM_TO_FLOAT
#undef SCHEME_CHECK_FLOAT
#undef SCHEME_BIGNUM_FROM_FLOAT
#undef FP_ZEROx
#undef FP_ONEx
#undef FP_TWOx
#undef FP_POWx
#undef FP_MZ_IS_POS_INFINITY
#undef FP_scheme_floating_point_nzero

24
src/racket/src/bignum.c
View File

@ -1432,14 +1432,6 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o)
#include "bgnfloat.inc"
#ifdef MZ_USE_SINGLE_FLOATS
# undef USE_FLOAT_BITS
# undef FP_TYPE
# undef IS_FLOAT_INF
# undef SCHEME_BIGNUM_TO_FLOAT_INFO
# undef SCHEME_BIGNUM_TO_FLOAT
# undef SCHEME_CHECK_FLOAT
# undef SCHEME_BIGNUM_FROM_FLOAT
# define USE_FLOAT_BITS 24
# define FP_TYPE float
# define IS_FLOAT_INF scheme__is_float_inf
@ -1450,6 +1442,22 @@ static void bignum_add1_inplace(Scheme_Object **_stk_o)
# include "bgnfloat.inc"
#endif
#ifdef MZ_LONG_DOUBLE
# define USE_FLOAT_BITS 64
# define FP_TYPE long double
# define IS_FLOAT_INF scheme__is_long_double_inf
# define SCHEME_BIGNUM_TO_FLOAT_INFO scheme_bignum_to_long_double_inf_info
# define SCHEME_BIGNUM_TO_FLOAT scheme_bignum_to_long_double
# define SCHEME_CHECK_FLOAT scheme_check_long_double
# define SCHEME_BIGNUM_FROM_FLOAT scheme_bignum_from_long_double
# define FP_ZEROx 0.0L
# define FP_ONEx 1.0L
# define FP_TWOx 2.0L
# define FP_POWx powl
# define FP_MZ_IS_POS_INFINITY(x) MZ_IS_LONG_POS_INFINITY(x)
# define FP_scheme_floating_point_nzero scheme_long_floating_point_nzero
# include "bgnfloat.inc"
#endif
void scheme_bignum_divide(const Scheme_Object *n, const Scheme_Object *d,
Scheme_Object **_stk_qp, Scheme_Object **_stk_rp, int norm)

56
src/racket/src/bool.c
View File

@ -194,6 +194,43 @@ int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
return SAME_OBJ(obj1, obj2);
}
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static MZ_INLINE int long_double_eqv(long double a, long double b)
{
# ifndef NAN_EQUALS_ANYTHING
if (a != b) {
# endif
/* Double-check for NANs: */
if (MZ_IS_LONG_NAN(a)) {
if (MZ_IS_LONG_NAN(b))
return 1;
# ifdef NAN_EQUALS_ANYTHING
return 0;
# endif
}
# ifdef NAN_EQUALS_ANYTHING
if (MZ_IS_LONG_NAN(b))
return 0;
else {
if (a == 0.0L) {
if (b == 0.0L) {
return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
}
}
return (a == b);
}
# else
return 0;
}
if (a == 0.0L) {
if (b == 0.0L) {
return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
}
}
return 1;
# endif
}
#endif
XFORM_NONGCING static MZ_INLINE int double_eqv(double a, double b)
{
# ifndef NAN_EQUALS_ANYTHING
@ -249,6 +286,10 @@ XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
return -1;
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_long_double_type) {
return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
} else if (t1 == scheme_float_type) {
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
@ -471,6 +512,21 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
return 1;
}
return 0;
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_extflvector_type) {
intptr_t l1, l2, i;
l1 = SCHEME_EXTFLVEC_SIZE(obj1);
l2 = SCHEME_EXTFLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
SCHEME_EXTFLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
#endif
} else if ((t1 == scheme_byte_string_type)
|| ((t1 >= scheme_unix_path_type)
&& (t1 <= scheme_windows_path_type))) {

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

@ -2036,6 +2036,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
&& (!(scheme_is_kernel_modname(modname)
|| scheme_is_unsafe_modname(modname)
|| scheme_is_flfxnum_modname(modname)
|| scheme_is_extfl_modname(modname)
|| scheme_is_futures_modname(modname))
|| (flags & SCHEME_REFERENCING))) {
/* Create a module variable reference, so that idx is preserved: */
@ -2110,6 +2111,16 @@ Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o)
return NULL;
}
Scheme_Object *scheme_extract_extfl(Scheme_Object *o)
{
Scheme_Env *home;
home = scheme_get_bucket_home((Scheme_Bucket *)o);
if (home && home->module && scheme_is_extfl_modname(home->module->modname))
return (Scheme_Object *)((Scheme_Bucket *)o)->val;
else
return NULL;
}
Scheme_Object *scheme_extract_futures(Scheme_Object *o)
{
Scheme_Env *home;

24
src/racket/src/compile.c
View File

@ -4552,18 +4552,20 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp) {
scheme_compile_rec_done_local(rec, drec);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) {
if (scheme_extract_unsafe(var)) {
scheme_register_unsafe_in_prefix(env, rec, drec, menv);
return scheme_extract_unsafe(var);
} else if (scheme_extract_flfxnum(var)) {
return scheme_extract_flfxnum(var);
} else if (scheme_extract_extfl(var)) {
return scheme_extract_extfl(var);
} else if (scheme_extract_futures(var)) {
return scheme_extract_futures(var);
}
}
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
&& scheme_extract_unsafe(var)) {
scheme_register_unsafe_in_prefix(env, rec, drec, menv);
return scheme_extract_unsafe(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
&& scheme_extract_flfxnum(var)) {
return scheme_extract_flfxnum(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
&& scheme_extract_futures(var)) {
return scheme_extract_futures(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
return scheme_register_toplevel_in_prefix(var, env, rec, drec,
scheme_is_imported(var, env),
inline_variant);

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

@ -1,40 +1,40 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,50,46,50,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,50,46,51,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,
19,0,26,0,29,0,36,0,49,0,53,0,60,0,65,0,69,0,74,0,83,
27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,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,
163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129,
1,162,1,224,1,24,2,105,2,161,2,166,2,187,2,84,3,105,3,158,3,
225,3,114,4,2,5,56,5,67,5,150,5,0,0,112,7,0,0,69,35,37,
109,105,110,45,115,116,120,29,11,11,11,64,99,111,110,100,66,108,101,116,114,
101,99,62,111,114,66,117,110,108,101,115,115,72,112,97,114,97,109,101,116,101,
114,105,122,101,63,97,110,100,66,100,101,102,105,110,101,64,108,101,116,42,63,
108,101,116,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11,
109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114,
105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110,
108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42,
62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11,
65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29,
94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,
110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,
108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,
20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,
61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,
122,91,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,
20,2,10,2,2,2,7,2,2,2,5,2,2,2,6,2,2,2,3,2,2,
2,8,2,2,2,9,2,2,2,4,2,2,2,11,2,2,2,12,2,2,97,
37,11,8,240,122,91,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2,
37,2,13,2,2,2,13,96,38,11,8,240,122,91,0,0,16,0,96,11,11,
8,240,122,91,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14,
130,91,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,
20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2,
2,10,2,2,2,3,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,
37,11,8,240,130,91,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2,
37,2,13,2,2,2,13,96,11,11,8,240,130,91,0,0,16,0,96,38,11,
8,240,130,91,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14,
2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,163,4,195,249,22,
156,4,80,158,39,36,251,22,89,2,18,248,22,104,199,12,249,22,79,2,19,
248,22,106,201,27,248,22,163,4,195,249,22,156,4,80,158,39,36,251,22,89,
2,18,248,22,104,199,249,22,79,2,19,248,22,106,201,12,27,248,22,81,248,
22,163,4,196,28,248,22,87,193,20,14,159,37,36,37,28,248,22,87,248,22,
81,194,248,22,176,17,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,
22,176,17,199,249,22,79,2,8,248,22,177,17,201,11,18,100,10,13,16,6,
22,176,17,199,249,22,79,2,4,248,22,177,17,201,11,18,100,10,13,16,6,
36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,
20,3,1,8,101,110,118,49,55,52,51,50,16,4,11,11,2,21,3,1,8,
101,110,118,49,55,52,51,51,27,248,22,81,248,22,163,4,196,28,248,22,87,
193,20,14,159,37,36,37,28,248,22,87,248,22,81,194,248,22,176,17,193,249,
22,156,4,80,158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89,
2,23,248,22,176,17,201,251,22,89,2,18,2,23,2,23,249,22,79,2,5,
2,23,248,22,176,17,201,251,22,89,2,18,2,23,2,23,249,22,79,2,11,
248,22,177,17,204,18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,
8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,52,
51,53,16,4,11,11,2,21,3,1,8,101,110,118,49,55,52,51,54,248,22,
@ -52,7 +52,7 @@
37,47,11,9,222,33,43,248,22,163,4,248,22,80,201,248,22,177,17,198,27,
248,22,81,248,22,163,4,196,27,248,22,163,4,248,22,80,195,249,22,156,4,
80,158,40,36,28,248,22,87,195,250,22,90,2,22,9,248,22,81,199,250,22,
89,2,11,248,22,89,248,22,80,199,250,22,90,2,10,248,22,177,17,201,248,
89,2,6,248,22,89,248,22,80,199,250,22,90,2,10,248,22,177,17,201,248,
22,81,202,27,248,22,81,248,22,163,4,23,197,1,27,249,22,1,22,93,249,
22,2,22,163,4,248,22,163,4,248,22,80,199,248,22,183,4,249,22,156,4,
80,158,41,36,251,22,89,1,22,119,105,116,104,45,99,111,110,116,105,110,117,
@ -63,10 +63,10 @@
204,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14,159,37,36,37,
249,22,156,4,80,158,39,36,27,248,22,163,4,248,22,80,197,28,249,22,153,
9,62,61,62,248,22,157,4,248,22,104,196,250,22,89,2,22,248,22,89,249,
22,89,21,93,2,27,248,22,80,199,250,22,90,2,3,249,22,89,2,27,249,
22,89,21,93,2,27,248,22,80,199,250,22,90,2,8,249,22,89,2,27,249,
22,89,248,22,113,203,2,27,248,22,81,202,251,22,89,2,18,28,249,22,153,
9,248,22,157,4,248,22,80,200,64,101,108,115,101,10,248,22,176,17,197,250,
22,90,2,22,9,248,22,177,17,200,249,22,79,2,3,248,22,81,202,99,13,
22,90,2,22,9,248,22,177,17,200,249,22,79,2,8,248,22,81,202,99,13,
16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,
11,2,20,3,1,8,101,110,118,49,55,52,53,56,16,4,11,11,2,21,3,
1,8,101,110,118,49,55,52,53,57,18,158,94,10,64,118,111,105,100,8,48,
@ -74,33 +74,33 @@
248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,89,248,22,176,17,199,
248,22,104,198,27,248,22,157,4,248,22,176,17,197,250,22,89,2,28,248,22,
89,248,22,80,197,250,22,90,2,25,248,22,177,17,199,248,22,177,17,202,159,
36,20,113,159,36,16,1,11,16,0,20,26,149,9,2,1,2,1,2,2,9,
9,11,11,11,10,36,80,158,36,36,20,113,159,36,16,0,16,0,38,39,36,
36,20,114,159,36,16,1,11,16,0,20,26,149,9,2,1,2,1,2,2,9,
9,11,11,11,10,36,80,158,36,36,20,114,159,36,16,0,16,0,38,39,36,
16,0,36,16,0,36,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,
2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,11,11,
11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,
2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,0,16,
0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,11,20,
15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,113,159,36,16,1,2,
13,16,1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0,33,
34,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,12,88,163,8,36,
37,53,37,9,223,0,33,35,36,20,113,159,36,16,1,2,13,16,0,11,16,
5,2,8,88,163,8,36,37,53,37,9,223,0,33,36,36,20,113,159,36,16,
1,2,13,16,1,33,37,11,16,5,2,5,88,163,8,36,37,56,37,9,223,
0,33,38,36,20,113,159,36,16,1,2,13,16,1,33,39,11,16,5,2,11,
88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2,13,
16,0,11,16,5,2,4,88,163,8,36,37,53,37,9,223,0,33,44,36,20,
113,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,54,37,
9,223,0,33,45,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,7,
88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2,13,
16,0,11,16,5,2,3,88,163,8,36,37,58,37,9,223,0,33,47,36,20,
113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,9,88,163,8,36,37,
54,37,9,223,0,33,50,36,20,113,159,36,16,1,2,13,16,0,11,16,0,
15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,114,159,36,16,1,2,
13,16,1,33,33,10,16,5,2,7,88,163,8,36,37,53,37,9,223,0,33,
34,36,20,114,159,36,16,1,2,13,16,0,11,16,5,2,12,88,163,8,36,
37,53,37,9,223,0,33,35,36,20,114,159,36,16,1,2,13,16,0,11,16,
5,2,4,88,163,8,36,37,53,37,9,223,0,33,36,36,20,114,159,36,16,
1,2,13,16,1,33,37,11,16,5,2,11,88,163,8,36,37,56,37,9,223,
0,33,38,36,20,114,159,36,16,1,2,13,16,1,33,39,11,16,5,2,6,
88,163,8,36,37,58,37,9,223,0,33,42,36,20,114,159,36,16,1,2,13,
16,0,11,16,5,2,9,88,163,8,36,37,53,37,9,223,0,33,44,36,20,
114,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,54,37,
9,223,0,33,45,36,20,114,159,36,16,1,2,13,16,0,11,16,5,2,3,
88,163,8,36,37,56,37,9,223,0,33,46,36,20,114,159,36,16,1,2,13,
16,0,11,16,5,2,8,88,163,8,36,37,58,37,9,223,0,33,47,36,20,
114,159,36,16,1,2,13,16,1,33,49,11,16,5,2,5,88,163,8,36,37,
54,37,9,223,0,33,50,36,20,114,159,36,16,1,2,13,16,0,11,16,0,
94,2,16,2,17,93,2,16,9,9,36,0};
EVAL_ONE_SIZED_STR((char *)expr, 2048);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,50,46,50,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,50,46,51,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,
@ -376,7 +376,7 @@
38,48,11,9,223,3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,
20,18,159,11,80,158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,
18,159,11,80,158,42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,
9,88,163,8,32,37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,
8,88,163,8,32,37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,
7,35,114,120,34,47,43,34,28,248,22,143,7,23,195,2,27,249,22,187,15,
2,99,196,28,192,28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,146,
7,198,249,22,7,250,22,165,7,199,36,248,22,103,198,197,249,22,7,250,22,
@ -521,8 +521,8 @@
22,138,4,23,202,1,27,28,23,194,2,23,194,1,86,94,23,194,1,36,249,
22,134,6,23,199,1,20,20,95,88,163,8,36,36,48,11,9,224,4,2,33,
124,23,195,1,23,197,1,27,248,22,183,5,23,195,1,248,80,159,39,8,33,
39,193,159,36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2,1,
29,11,11,11,9,9,11,11,11,10,43,80,158,36,36,20,113,159,40,16,30,
39,193,159,36,20,114,159,36,16,1,11,16,0,20,26,144,9,2,1,2,1,
29,11,11,11,9,9,11,11,11,10,43,80,158,36,36,20,114,159,40,16,30,
2,2,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,
12,2,13,2,14,2,15,2,16,2,17,30,2,20,76,102,105,110,100,45,108,
105,110,107,115,45,112,97,116,104,33,11,4,30,2,21,1,20,112,97,114,97,
@ -582,7 +582,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 10044);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,50,46,50,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,50,46,51,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,
@ -594,9 +594,9 @@
33,79,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,105,110,
1,20,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,111,117,
116,249,80,158,38,39,195,36,249,80,158,38,39,195,36,249,80,158,38,39,195,
36,249,80,158,38,39,195,37,249,80,158,38,39,195,37,159,36,20,113,159,36,
36,249,80,158,38,39,195,37,249,80,158,38,39,195,37,159,36,20,114,159,36,
16,1,11,16,0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,
11,10,45,80,158,36,36,20,113,159,36,16,7,2,2,2,3,2,4,2,5,
11,10,45,80,158,36,36,20,114,159,36,16,7,2,2,2,3,2,4,2,5,
2,6,2,7,2,8,16,0,37,39,36,16,0,36,16,2,2,5,2,6,38,
11,11,11,16,5,2,3,2,7,2,8,2,4,2,2,16,5,11,11,11,11,
11,16,5,2,3,2,7,2,8,2,4,2,2,41,41,37,12,11,11,16,0,
@ -612,7 +612,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 548);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,50,46,50,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,50,46,51,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,
@ -969,9 +969,9 @@
159,37,56,38,248,22,171,5,80,159,37,37,39,248,22,165,14,80,159,37,45,
39,20,18,159,11,80,158,36,55,248,80,159,37,8,27,37,249,22,33,11,80,
159,39,57,37,20,18,159,11,80,158,36,55,248,80,159,37,8,27,37,249,22,
33,11,80,159,39,57,37,159,36,20,113,159,36,16,1,11,16,0,20,26,144,
33,11,80,159,39,57,37,159,36,20,114,159,36,16,1,11,16,0,20,26,144,
9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,38,80,158,36,36,20,
113,159,41,16,28,2,2,2,3,30,2,6,2,7,11,6,30,2,6,1,23,
114,159,41,16,28,2,2,2,3,30,2,6,2,7,11,6,30,2,6,1,23,
101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,
111,110,11,3,30,2,8,72,112,97,116,104,45,115,116,114,105,110,103,63,38,
196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112,97,116,104,40,196,
@ -1022,7 +1022,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 8526);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,50,46,50,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,50,46,51,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,
@ -1030,12 +1030,12 @@
114,107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,
74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66,
35,37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,11,
29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,148,93,
29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,160,93,
0,0,100,159,2,3,36,36,159,2,4,36,36,159,2,5,36,36,159,2,6,
36,36,159,2,7,36,36,159,2,8,36,36,159,2,9,36,36,159,2,9,36,
36,16,0,159,36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2,
36,16,0,159,36,20,114,159,36,16,1,11,16,0,20,26,144,9,2,1,2,
1,29,11,11,11,9,9,11,11,11,18,96,11,46,46,46,36,80,158,36,36,
20,113,159,36,16,0,16,0,37,39,36,16,0,36,16,0,36,11,11,11,16,
20,114,159,36,16,0,16,0,37,39,36,16,0,36,16,0,36,11,11,11,16,
0,16,0,16,0,36,36,37,12,11,11,16,0,16,0,16,0,36,36,11,12,
11,11,16,0,16,0,16,0,36,36,16,0,104,2,9,2,8,29,94,2,2,
69,35,37,102,111,114,101,105,103,110,11,29,94,2,2,68,35,37,117,110,115,

7
src/racket/src/dynext.inc
View File

@ -65,6 +65,9 @@
scheme_extension_table->scheme_make_vector = scheme_make_vector;
scheme_extension_table->scheme_make_integer_value = scheme_make_integer_value;
scheme_extension_table->scheme_make_double = scheme_make_double;
#ifdef MZ_LONG_DOUBLE
scheme_extension_table->scheme_make_long_double = scheme_make_long_double;
#endif
scheme_extension_table->scheme_make_char = scheme_make_char;
scheme_extension_table->scheme_make_compiled_syntax = scheme_make_compiled_syntax;
scheme_extension_table->scheme_make_promise = scheme_make_promise;
@ -72,6 +75,10 @@
scheme_extension_table->scheme_make_bignum = scheme_make_bignum;
scheme_extension_table->scheme_bignum_to_float = scheme_bignum_to_float;
scheme_extension_table->scheme_bignum_from_float = scheme_bignum_from_float;
#ifdef MZ_LONG_DOUBLE
scheme_extension_table->scheme_bignum_to_long_double = scheme_bignum_to_long_double;
scheme_extension_table->scheme_bignum_from_long_double = scheme_bignum_from_long_double;
#endif
scheme_extension_table->scheme_bignum_to_string = scheme_bignum_to_string;
scheme_extension_table->scheme_read_bignum = scheme_read_bignum;
scheme_extension_table->scheme_bignum_normalize = scheme_bignum_normalize;

54
src/racket/src/env.c
View File

@ -51,6 +51,7 @@ READ_ONLY static Scheme_Object *kernel_symbol;
READ_ONLY static Scheme_Env *kernel_env;
READ_ONLY static Scheme_Env *unsafe_env;
READ_ONLY static Scheme_Env *flfxnum_env;
READ_ONLY static Scheme_Env *extfl_env;
READ_ONLY static Scheme_Env *futures_env;
THREAD_LOCAL_DECL(static int builtin_ref_counter);
@ -323,6 +324,10 @@ static void init_unsafe(Scheme_Env *env)
scheme_init_unsafe_list(unsafe_env);
scheme_init_unsafe_vector(unsafe_env);
scheme_init_extfl_unsafe_number(unsafe_env);
scheme_init_extfl_unsafe_numarith(unsafe_env);
scheme_init_extfl_unsafe_numcomp(unsafe_env);
scheme_finish_primitive_module(unsafe_env);
pt = unsafe_env->module->me->rt;
scheme_populate_pt_ht(pt);
@ -365,6 +370,34 @@ static void init_flfxnum(Scheme_Env *env)
#endif
}
static void init_extfl(Scheme_Env *env)
{
Scheme_Module_Phase_Exports *pt;
REGISTER_SO(extfl_env);
extfl_env = scheme_primitive_module(scheme_intern_symbol("#%extfl"), env);
scheme_init_extfl_number(extfl_env);
scheme_init_extfl_numarith(extfl_env);
scheme_init_extfl_numcomp(extfl_env);
scheme_init_extfl_numstr(extfl_env);
scheme_finish_primitive_module(extfl_env);
pt = extfl_env->module->me->rt;
scheme_populate_pt_ht(pt);
scheme_protect_primitive_provide(extfl_env, NULL);
extfl_env->attached = 1;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT)) {
printf("extfl count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT,
EXPECTED_EXTFL_COUNT);
abort();
}
#endif
}
static void init_futures(Scheme_Env *env)
{
Scheme_Module_Phase_Exports *pt;
@ -381,9 +414,9 @@ static void init_futures(Scheme_Env *env)
futures_env->attached = 1;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_FUTURES_COUNT)) {
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) {
printf("Futures count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT, EXPECTED_FUTURES_COUNT);
builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT - EXPECTED_EXTFL_COUNT, EXPECTED_FUTURES_COUNT);
abort();
}
#endif
@ -397,6 +430,10 @@ Scheme_Env *scheme_get_flfxnum_env() {
return flfxnum_env;
}
Scheme_Env *scheme_get_extfl_env() {
return extfl_env;
}
Scheme_Env *scheme_get_futures_env() {
return futures_env;
}
@ -730,6 +767,7 @@ static void make_kernel_env(void)
init_unsafe(env);
init_flfxnum(env);
init_extfl(env);
init_futures(env);
scheme_init_print_global_constants();
@ -1383,13 +1421,15 @@ Scheme_Object **scheme_make_builtin_references_table(void)
t[j] = scheme_false;
}
for (j = 0; j < 4; j++) {
for (j = 0; j < 5; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
kenv = unsafe_env;
else if (j == 2)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
kenv = futures_env;
@ -1418,13 +1458,15 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
result = scheme_make_hash_table(SCHEME_hash_ptr);
for (j = 0; j < 4; j++) {
for (j = 0; j < 5; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
kenv = unsafe_env;
else if (j == 2)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
kenv = futures_env;
@ -1450,13 +1492,15 @@ const char *scheme_look_for_primitive(void *code)
intptr_t i;
int j;
for (j = 0; j < 4; j++) {
for (j = 0; j < 5; j++) {
if (!j)
kenv = kernel_env;
else if (j == 1)
kenv = unsafe_env;
else if (j == 2)
kenv = flfxnum_env;
else if (j == 3)
kenv = extfl_env;
else
kenv = futures_env;

92
src/racket/src/hash.c
View File

@ -1026,6 +1026,49 @@ XFORM_NONGCING static uintptr_t dbl_hash2_val(double d)
return to_unsigned_hash(e);
}
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static uintptr_t long_dbl_hash_val(long double d)
XFORM_SKIP_PROC
{
int e;
if (MZ_IS_LONG_NAN(d)) {
d = 0.0L;
e = 1000;
} else if (MZ_IS_LONG_POS_INFINITY(d)) {
d = 0.5L;
e = 1000;
} else if (MZ_IS_LONG_NEG_INFINITY(d)) {
d = -0.5L;
e = 1000;
} else if (!d && scheme_long_minus_zero_p(d)) {
d = 0L;
e = 1000;
} else {
/* frexpl should not be used on inf or nan: */
d = frexpl(d, &e);
}
return ((uintptr_t)(d * (1 << 30))) + e;
}
XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long double d)
XFORM_SKIP_PROC
{
int e;
if (MZ_IS_LONG_NAN(d)
|| MZ_IS_LONG_POS_INFINITY(d)
|| MZ_IS_LONG_NEG_INFINITY(d)) {
e = 1;
} else {
/* frexp should not be used on inf or nan: */
d = frexpl(d, &e);
}
return to_unsigned_hash(e);
}
#endif
#define OVERFLOW_HASH() overflow_equal_hash_key(o, k - t, hi)
/* Based on Bob Jenkins's one-at-a-time hash function at
@ -1060,6 +1103,12 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
{
return k + dbl_hash_val(SCHEME_DBL_VAL(o));
}
#ifdef MZ_LONG_DOUBLE
case scheme_long_double_type:
{
return k + long_dbl_hash_val(SCHEME_LONG_DBL_VAL(o));
}
#endif
case scheme_bignum_type:
{
int i = SCHEME_BIGLEN(o);
@ -1150,6 +1199,24 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi)
return k;
}
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
{
intptr_t len = SCHEME_EXTFLVEC_SIZE(o), i;
long double d;
if (!len)
return k + 1;
for (i = 0; i < len; i++) {
SCHEME_USE_FUEL(1);
d = SCHEME_EXTFLVEC_ELS(o)[i];
k = (k << 5) + k + long_dbl_hash_val(d);
}
return k;
}
#endif
case scheme_char_type:
return k + SCHEME_CHAR_VAL(o);
case scheme_byte_string_type:
@ -1514,6 +1581,12 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
{
return dbl_hash2_val(SCHEME_FLOAT_VAL(o));
}
#ifdef MZ_LONG_DOUBLE
case scheme_long_double_type:
{
return long_dbl_hash2_val(SCHEME_LONG_DBL_VAL(o));
}
#endif
case scheme_bignum_type:
return SCHEME_BIGDIG(o)[0];
case scheme_rational_type:
@ -1583,6 +1656,25 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
return k;
}
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
{
intptr_t len = SCHEME_EXTFLVEC_SIZE(o), i;
long double d;
uintptr_t k = 0;
if (!len)
return k + 1;
for (i = 0; i < len; i++) {
SCHEME_USE_FUEL(1);
d = SCHEME_EXTFLVEC_ELS(o)[i];
k = (k << 5) + k + long_dbl_hash2_val(d);
}
return k;
}
#endif
case scheme_char_type:
return t;
case scheme_byte_string_type:

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

@ -150,6 +150,9 @@ void scheme_fill_stack_lwc_end(void) XFORM_SKIP_PROC
{
#ifdef JIT_THREAD_LOCAL
scheme_current_lwc->saved_save_fp = scheme_jit_save_fp;
# ifdef MZ_LONG_DOUBLE
scheme_current_lwc->saved_save_extfp = scheme_jit_save_extfp;
# endif
#endif
}
@ -201,6 +204,9 @@ Scheme_Object *scheme_jit_continuation_apply_install(Apply_LWC_Args *args) XFORM
#ifdef USE_THREAD_LOCAL
args->new_threadlocal = &BOTTOM_VARIABLE;
scheme_jit_save_fp = lwc->saved_save_fp;
# ifdef MZ_LONG_DOUBLE
scheme_jit_save_extfp = lwc->saved_save_extfp;
# endif
#endif
delta = (intptr_t)new_stack_start - (intptr_t)lwc->stack_end;
@ -853,7 +859,7 @@ static int expression_avoids_clearing_local(Scheme_Object *wrt, int pos, int fue
}
int scheme_is_relatively_constant_and_avoids_r1_maybe_fp(Scheme_Object *obj, Scheme_Object *wrt,
int fp_ok)
int fp_ok, int extfl)
{
Scheme_Type t;
@ -865,7 +871,11 @@ int scheme_is_relatively_constant_and_avoids_r1_maybe_fp(Scheme_Object *obj, Sch
/* Must have clearing, other-clears, or type flag set,
otherwise is_constant_and_avoids_r1() would have returned 1. */
if (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM)
return fp_ok;
return (fp_ok && !extfl);
#ifdef MZ_LONG_DOUBLE
else if (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_EXTFLONUM)
return (fp_ok && extfl);
#endif
else if (expression_avoids_clearing_local(wrt, SCHEME_LOCAL_POS(obj), 3))
/* different local vars, sp order doesn't matter */
return 1;
@ -876,7 +886,7 @@ int scheme_is_relatively_constant_and_avoids_r1_maybe_fp(Scheme_Object *obj, Sch
int scheme_is_relatively_constant_and_avoids_r1(Scheme_Object *obj, Scheme_Object *wrt)
{
return scheme_is_relatively_constant_and_avoids_r1_maybe_fp(obj, wrt, 0);
return scheme_is_relatively_constant_and_avoids_r1_maybe_fp(obj, wrt, 0, 0);
}
int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder)
@ -1067,7 +1077,7 @@ static int finish_branch(mz_jit_state *jitter, int target, Branch_Info *for_bran
#ifdef USE_FLONUM_UNBOXING
int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offset, int target)
int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offset, int target, int extfl)
{
GC_CAN_IGNORE jit_insn *ref;
__START_TINY_JUMPS__(1);
@ -1075,7 +1085,9 @@ int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offse
__END_TINY_JUMPS__(1);
CHECK_LIMIT();
jit_movi_l(JIT_R0, offset);
(void)jit_calli(sjc.box_flonum_from_stack_code);
MZ_FPUSEL_STMT(extfl,
(void)jit_calli(sjc.box_extflonum_from_stack_code),
(void)jit_calli(sjc.box_flonum_from_stack_code));
mz_rs_stxi(pos, JIT_R0);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
@ -1096,27 +1108,31 @@ static int generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int local
jitter->unbox_depth++;
} else {
mz_rs_sync();
scheme_generate_flonum_local_boxing(jitter, pos, offset, target);
scheme_generate_flonum_local_boxing(jitter, pos, offset, target, 0);
}
return 1;
}
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push)
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int extfl)
/* Move FPR0 onto C stack */
{
if ((jitter->flostack_offset + sizeof(double)) > jitter->flostack_space) {
int sz, fpr0;
sz = MZ_FPUSEL(extfl, 2 * sizeof(double), sizeof(double));
if ((jitter->flostack_offset + sz) > jitter->flostack_space) {
int space = FLOSTACK_SPACE_CHUNK;
jitter->flostack_space += space;
jit_subi_l(JIT_SP, JIT_SP, space);
}
jitter->flostack_offset += sizeof(double);
if (push)
mz_runstack_flonum_pushed(jitter, jitter->flostack_offset);
jitter->flostack_offset += sz;
if (push) mz_runstack_flonum_pushed(jitter, jitter->flostack_offset);
CHECK_LIMIT();
mz_st_fppop(jitter->flostack_offset, JIT_FPR0);
fpr0 = MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0);
mz_st_fppop(jitter->flostack_offset, fpr0, extfl);
return 1;
}
@ -1162,7 +1178,7 @@ static int generate_closure(Scheme_Closure_Data *data,
# ifdef CAN_INLINE_ALLOC
if (immediately_filled) {
/* Inlined alloc */
scheme_inline_alloc(jitter, sz, scheme_native_closure_type, 0, 0, 0, 0);
scheme_inline_alloc(jitter, sz, scheme_native_closure_type, 0, 0, 0, 0,0 );
CHECK_LIMIT();
jit_addi_p(JIT_R0, JIT_V1, OBJHEAD_SIZE);
} else
@ -1528,7 +1544,7 @@ int scheme_generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inline
/* de-sync's;
inlined_ok == 2 => can generate directly; inlined_ok == 1 => non-tail unbox */
{
int saved;
mz_jit_unbox_state ubs;
if (inlined_ok) {
if (inlined_ok == 2)
@ -1548,11 +1564,12 @@ int scheme_generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inline
/* It probably would be useful to special-case a let-one
sequence down to something that can be unboxed. */
saved = jitter->unbox;
jitter->unbox = 0;
scheme_mz_unbox_save(jitter, &ubs);
scheme_generate_non_tail(obj, jitter, 0, 1, 0);
CHECK_LIMIT();
jitter->unbox = saved;
scheme_mz_unbox_restore(jitter, &ubs);
if (inlined_ok || unbox_anyway) {
/* Move result into floating-point register: */
@ -2382,7 +2399,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
p = SCHEME_PTR2_VAL(obj);
#ifdef CAN_INLINE_ALLOC
scheme_inline_alloc(jitter, sizeof(Scheme_Object*), -1, 0, 0, 0, 0);
scheme_inline_alloc(jitter, sizeof(Scheme_Object*), -1, 0, 0, 0, 0, 0);
CHECK_LIMIT();
jit_addi_p(JIT_R0, JIT_V1, OBJHEAD_SIZE);
jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos));
@ -2537,7 +2554,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
}
LOG_IT(("app 3\n"));
args[0] = app->rator;
args[1] = app->rand1;
args[2] = app->rand2;
@ -2607,15 +2624,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_let_value_type:
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)obj;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos, to_unbox = 0;
int ab = SCHEME_LET_AUTOBOX(lv), i, pos;
mz_jit_unbox_state ubs;
START_JIT_DATA();
LOG_IT(("let...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
scheme_mz_unbox_save(jitter, &ubs);
if (lv->count == 1) {
/* Expect one result: */
@ -2696,8 +2711,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
scheme_mz_unbox_restore(jitter, &ubs);
return scheme_generate(lv->body, jitter, is_tail, wcm_may_replace,
multi_ok, orig_target, for_branch);
@ -2705,15 +2719,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_let_void_type:
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)obj;
int c = lv->count, to_unbox = 0;
int c = lv->count;
mz_jit_unbox_state ubs;
START_JIT_DATA();
LOG_IT(("letv...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
scheme_mz_unbox_save(jitter, &ubs);
mz_rs_dec(c);
CHECK_RUNSTACK_OVERFLOW();
@ -2727,7 +2739,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
for (i = 0; i < c; i++) {
CHECK_LIMIT();
#ifdef CAN_INLINE_ALLOC
scheme_inline_alloc(jitter, sizeof(Scheme_Object*), -1, 0, 0, 0, 0);
scheme_inline_alloc(jitter, sizeof(Scheme_Object*), -1, 0, 0, 0, 0, 0);
CHECK_LIMIT();
jit_addi_p(JIT_R0, JIT_V1, OBJHEAD_SIZE);
(void)jit_movi_p(JIT_R1, scheme_undefined);
@ -2751,8 +2763,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
scheme_mz_unbox_restore(jitter, &ubs);
return scheme_generate(lv->body, jitter, is_tail, wcm_may_replace,
multi_ok, orig_target, for_branch);
@ -2760,15 +2771,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_letrec_type:
{
Scheme_Letrec *l = (Scheme_Letrec *)obj;
int i, nsrs, prepped = 0, to_unbox = 0;
int i, nsrs, prepped = 0;
mz_jit_unbox_state ubs;
START_JIT_DATA();
LOG_IT(("letrec...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
scheme_mz_unbox_save(jitter, &ubs);
mz_rs_sync();
@ -2821,8 +2830,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
jitter->need_set_rs = nsrs;
}
if (to_unbox)
jitter->unbox = to_unbox;
scheme_mz_unbox_restore(jitter, &ubs);
return scheme_generate(l->body, jitter, is_tail, wcm_may_replace,
multi_ok, orig_target, for_branch);
@ -2830,15 +2838,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_let_one_type:
{
Scheme_Let_One *lv = (Scheme_Let_One *)obj;
int flonum, to_unbox = 0, unused;
int flonum, unused;
mz_jit_unbox_state ubs;
START_JIT_DATA();
LOG_IT(("leto...\n"));
if (jitter->unbox) {
to_unbox = jitter->unbox;
jitter->unbox = 0;
}
scheme_mz_unbox_save(jitter, &ubs);
mz_runstack_skipped(jitter, 1);
@ -2852,10 +2858,10 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
PAUSE_JIT_DATA();
if (flonum) {
#ifdef USE_FLONUM_UNBOXING
if (scheme_can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0)) {
if (scheme_can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0, 0)) {
jitter->unbox++;
scheme_generate_unboxed(lv->value, jitter, 2, 0);
} else if (scheme_can_unbox_directly(lv->value)) {
} else if (scheme_can_unbox_directly(lv->value, 0)) {
jitter->unbox++;
scheme_generate_unboxed(lv->value, jitter, 1, 0);
} else {
@ -2885,7 +2891,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
--jitter->unbox_depth;
if (jitter->unbox_depth)
scheme_signal_error("internal error: flonum let RHS leaves unbox depth");
scheme_generate_flonum_local_unboxing(jitter, 1);
scheme_generate_flonum_local_unboxing(jitter, 1, 0);
CHECK_LIMIT();
(void)jit_movi_p(JIT_R0, NULL);
#endif
@ -2905,8 +2911,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
LOG_IT(("...in\n"));
if (to_unbox)
jitter->unbox = to_unbox;
scheme_mz_unbox_restore(jitter, &ubs);
return scheme_generate(lv->body, jitter, is_tail, wcm_may_replace,
multi_ok, orig_target, for_branch);
@ -3004,24 +3009,49 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
finish_branch_with_true(jitter, for_branch);
return 1;
} else if (jitter->unbox) {
double d;
int fpr0;
GC_CAN_IGNORE const char *bad = NULL;
if (SCHEME_FLOATP(obj))
d = SCHEME_FLOAT_VAL(obj);
else {
#ifdef MZ_LONG_DOUBLE
if (jitter->unbox_extflonum) {
long double d;
int fpr0;
if (SCHEME_LONG_DBLP(obj))
d = SCHEME_LONG_DBL_VAL(obj);
else {
bad = "ext";
d = 0.0L;
}
fpr0 = JIT_FPU_FPR_0(jitter->unbox_depth);
mz_fpu_movi_ld_fppush(fpr0, d, target);
} else
#endif
{
double d;
int fpr0;
if (SCHEME_FLOATP(obj))
d = SCHEME_FLOAT_VAL(obj);
else {
bad = "";
d = 0.0;
}
fpr0 = JIT_FPR_0(jitter->unbox_depth);
mz_movi_d_fppush(fpr0, d, target);
}
if (bad)
scheme_log(NULL,
SCHEME_LOG_WARNING,
0,
"warning: JIT detects flonum operation applied to non-flonum constant: %V",
"warning: JIT detects %sflonum operation applied to non-%sflonum constant: %V",
bad, bad,
obj);
d = 0.0;
}
fpr0 = JIT_FPR_0(jitter->unbox_depth);
mz_movi_d_fppush(fpr0, d, target);
jitter->unbox_depth++;
return 1;
} else if (!result_ignored) {
Scheme_Type type = SCHEME_TYPE(obj);
@ -3360,7 +3390,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
if (CLOSURE_ARGUMENT_IS_FLONUM(data, i)) {
mz_rs_ldxi(JIT_R1, i);
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
scheme_generate_flonum_local_unboxing(jitter, 1);
scheme_generate_flonum_local_unboxing(jitter, 1, 0);
CHECK_LIMIT();
} else {
mz_runstack_pushed(jitter, 1);
@ -3436,7 +3466,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
&& (CLOSURE_CONTENT_IS_FLONUM(data, i))) {
mz_rs_ldxi(JIT_R1, i);
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
scheme_generate_flonum_local_unboxing(jitter, 1);
scheme_generate_flonum_local_unboxing(jitter, 1, 0);
CHECK_LIMIT();
} else
#endif
@ -3455,7 +3485,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
if (CLOSURE_CONTENT_IS_FLONUM(data, i)) {
mz_rs_ldxi(JIT_R1, i);
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val);
scheme_generate_flonum_local_unboxing(jitter, 1);
scheme_generate_flonum_local_unboxing(jitter, 1, 0);
CHECK_LIMIT();
} else {
mz_runstack_pushed(jitter, 1);

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

@ -98,6 +98,17 @@ END_XFORM_ARITH;
#define JIT_LOG_DOUBLE_SIZE 3
#define JIT_DOUBLE_SIZE (1 << JIT_LOG_DOUBLE_SIZE)
#ifdef MZ_LONG_DOUBLE
# ifdef MZ_USE_JIT_X86_64
# define JIT_LOG_LONG_DOUBLE_SIZE 4
# define JIT_LONG_DOUBLE_SIZE (1 << JIT_LOG_LONG_DOUBLE_SIZE)
# else
# define JIT_LOG_LONG_DOUBLE_SIZE not_implemented
# define JIT_LONG_DOUBLE_SIZE 12
#endif
#endif
/* a mzchar is an int: */
#define LOG_MZCHAR_SIZE 2
@ -151,6 +162,8 @@ Fix me! See use.
# endif
#endif
#include "jitfpu.h"
#if 0
static void assert_failure(int where) { printf("JIT assert failed %d\n", where); }
#define JIT_ASSERT(v) if (!(v)) assert_failure(__LINE__);
@ -184,6 +197,10 @@ extern int scheme_jit_malloced;
#ifdef JIT_USE_FP_OPS
THREAD_LOCAL_DECL(extern double scheme_jit_save_fp);
THREAD_LOCAL_DECL(extern double scheme_jit_save_fp2);
# ifdef MZ_LONG_DOUBLE
THREAD_LOCAL_DECL(extern long double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(extern long double scheme_jit_save_extfp2);
# endif
#endif
typedef int (*Native_Check_Arity_Proc)(Scheme_Object *o, int argc, int dummy EXTRA_NATIVE_ARGUMENT_TYPE);
@ -215,6 +232,12 @@ typedef struct Apply_LWC_Args {
typedef Scheme_Object *(*Continuation_Apply_Indirect)(Apply_LWC_Args *, intptr_t);
typedef Scheme_Object *(*Continuation_Apply_Finish)(Apply_LWC_Args *args, void *stack, void *frame);
#ifdef MZ_LONG_DOUBLE
# define JIT_NUM_FL_KINDS 2
#else
# define JIT_NUM_FL_KINDS 1
#endif
struct scheme_jit_common_record {
int skip_checks;
@ -257,7 +280,8 @@ struct scheme_jit_common_record {
void *chap_vector_ref_code, *chap_vector_ref_check_index_code, *chap_vector_set_code, *chap_vector_set_check_index_code;
void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
void *flvector_ref_check_index_code, *flvector_set_check_index_code, *flvector_set_flonum_check_index_code;
void *flvector_ref_check_index_code[JIT_NUM_FL_KINDS];
void *flvector_set_check_index_code[JIT_NUM_FL_KINDS], *flvector_set_flonum_check_index_code[JIT_NUM_FL_KINDS];
void *fxvector_ref_code, *fxvector_ref_check_index_code, *fxvector_set_code, *fxvector_set_check_index_code;
void *struct_raw_ref_code, *struct_raw_set_code;
void *syntax_e_code;
@ -284,7 +308,12 @@ struct scheme_jit_common_record {
void *finish_tail_call_code, *finish_tail_call_fixup_code;
void *module_run_start_code, *module_exprun_start_code, *module_start_start_code;
void *box_flonum_from_stack_code, *box_flonum_from_reg_code;
void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2];
void *fl1_fail_code[JIT_NUM_FL_KINDS], *fl2rr_fail_code[2][JIT_NUM_FL_KINDS];
void *fl2fr_fail_code[2][JIT_NUM_FL_KINDS], *fl2rf_fail_code[2][JIT_NUM_FL_KINDS];
#ifdef MZ_LONG_DOUBLE
void *bad_extflvector_length_code;
void *box_extflonum_from_stack_code, *box_extflonum_from_reg_code;
#endif
void *wcm_code, *wcm_nontail_code, *wcm_chaperone;
void *apply_to_list_tail_code, *apply_to_list_code, *apply_to_list_multi_ok_code;
void *eqv_code, *eqv_branch_code;
@ -295,6 +324,9 @@ struct scheme_jit_common_record {
void *retry_alloc_code;
void *retry_alloc_code_keep_r0_r1;
void *retry_alloc_code_keep_fpr1;
# ifdef MZ_LONG_DOUBLE
void *retry_alloc_code_keep_extfpr1;
# endif
#endif
Continuation_Apply_Indirect continuation_apply_indirect_code;
@ -353,6 +385,9 @@ typedef struct mz_jit_state {
int rs_virtual_offset;
int unbox, unbox_depth;
int flostack_offset, flostack_space;
#ifdef MZ_LONG_DOUBLE
int unbox_extflonum;
#endif
int self_restart_offset, self_restart_space;
} mz_jit_state;
@ -415,6 +450,10 @@ typedef struct {
# define tl_fixup_already_in_place tl_delta(fixup_already_in_place)
# define tl_scheme_jit_save_fp tl_delta(scheme_jit_save_fp)
# define tl_scheme_jit_save_fp2 tl_delta(scheme_jit_save_fp2)
#ifdef MZ_LONG_DOUBLE
# define tl_scheme_jit_save_extfp tl_delta(scheme_jit_save_extfp)
# define tl_scheme_jit_save_extfp2 tl_delta(scheme_jit_save_extfp2)
#endif
# define tl_scheme_fuel_counter tl_delta(scheme_fuel_counter)
# define tl_scheme_jit_stack_boundary tl_delta(scheme_jit_stack_boundary)
# define tl_jit_future_storage tl_delta(jit_future_storage)
@ -439,6 +478,8 @@ void *scheme_jit_get_threadlocal_table();
# define mz_tl_ldr_i(reg, addr) jit_ldxi_i(reg, JIT_R14, addr)
# define mz_tl_str_d_fppop(tmp_reg, reg, addr) jit_stxi_d_fppop(addr, JIT_R14, reg)
# define mz_tl_ldr_d_fppush(reg, tmp_reg, addr) jit_ldxi_d_fppush(reg, JIT_R14, addr)
# define mz_fpu_tl_str_ld_fppop(tmp_reg, reg, addr) jit_fpu_stxi_ld_fppop(addr, JIT_R14, reg)
# define mz_fpu_tl_ldr_ld_fppush(reg, tmp_reg, addr) jit_fpu_ldxi_ld_fppush(reg, JIT_R14, addr)
# define mz_tl_addr_tmp_i(tmp_reg, addr) (void)0
# define mz_tl_addr_untmp_i(tmp_reg) (void)0
# define mz_tl_tmp_reg_i(tmp_reg) tmp_reg
@ -469,6 +510,8 @@ void *scheme_jit_get_threadlocal_table();
# define mz_tl_ldr_i(reg, addr) jit_ldr_i(reg, reg)
# define mz_tl_str_d_fppop(tmp_reg, reg, addr) jit_str_d_fppop(tmp_reg, reg)
# define mz_tl_ldr_d_fppush(reg, tmp_reg, addr) jit_ldr_d_fppush(reg, tmp_reg)
# define mz_fpu_tl_str_ld_fppop(tmp_reg, reg, addr) jit_fpu_str_ld_fppop(tmp_reg, reg)
# define mz_fpu_tl_ldr_ld_fppush(reg, tmp_reg, addr) jit_fpu_ldr_ld_fppush(reg, tmp_reg)
# endif
/* A given tmp_reg doesn't have to be unused; it just has to be distinct from other arguments. */
@ -480,6 +523,8 @@ void *scheme_jit_get_threadlocal_table();
# define mz_tl_ldi_i(reg, addr) (mz_tl_addr(reg, addr), mz_tl_ldr_i(reg, addr))
# define mz_tl_sti_d_fppop(addr, reg, tmp_reg) (mz_tl_addr(tmp_reg, addr), mz_tl_str_d_fppop(tmp_reg, reg, addr))
# define mz_tl_ldi_d_fppush(reg, addr, tmp_reg) (mz_tl_addr(tmp_reg, addr), mz_tl_ldr_d_fppush(reg, tmp_reg, addr))
# define mz_fpu_tl_sti_ld_fppop(addr, reg, tmp_reg) (mz_tl_addr(tmp_reg, addr), mz_fpu_tl_str_ld_fppop(tmp_reg, reg, addr))
# define mz_fpu_tl_ldi_ld_fppush(reg, addr, tmp_reg) (mz_tl_addr(tmp_reg, addr), mz_fpu_tl_ldr_ld_fppush(reg, tmp_reg, addr))
#else
# define mz_tl_sti_p(addr, reg, tmp_reg) jit_sti_p(addr, reg)
# define mz_tl_sti_l(addr, reg, tmp_reg) jit_sti_l(addr, reg)
@ -489,6 +534,8 @@ void *scheme_jit_get_threadlocal_table();
# define mz_tl_ldi_i(reg, addr) jit_ldi_i(reg, addr)
# define mz_tl_sti_d_fppop(addr, reg, tmp_reg) jit_sti_d_fppop(addr, reg)
# define mz_tl_ldi_d_fppush(reg, addr, tmp_reg) jit_ldi_d_fppush(reg, addr)
# define mz_fpu_tl_sti_ld_fppop(addr, reg, tmp_reg) jit_fpu_sti_ld_fppop(addr, reg)
# define mz_fpu_tl_ldi_ld_fppush(reg, addr, tmp_reg) jit_fpu_ldi_ld_fppush(reg, addr)
# define tl_MZ_RUNSTACK (&MZ_RUNSTACK)
# define tl_MZ_RUNSTACK_START (&MZ_RUNSTACK_START)
# define tl_GC_gen0_alloc_page_ptr (&GC_gen0_alloc_page_ptr)
@ -501,6 +548,10 @@ void *scheme_jit_get_threadlocal_table();
# define tl_fixup_already_in_place (&fixup_already_in_place)
# define tl_scheme_jit_save_fp (&scheme_jit_save_fp)
# define tl_scheme_jit_save_fp2 (&scheme_jit_save_fp2)
# ifdef MZ_LONG_DOUBLE
# define tl_scheme_jit_save_extfp (&scheme_jit_save_extfp)
# define tl_scheme_jit_save_extfp2 (&scheme_jit_save_extfp2)
# endif
# define tl_scheme_fuel_counter (&scheme_fuel_counter)
# define tl_scheme_jit_stack_boundary (&scheme_jit_stack_boundary)
#endif
@ -875,10 +926,10 @@ static jit_insn *fp_tmpr;
#endif
#define FLOSTACK_SPACE_CHUNK 16
# define mz_ld_fppush_x(r, i, FP) (check_fp_depth(i, FP), jit_ldxi_d_fppush(r, FP, (JIT_FRAME_FLOSTACK_OFFSET - (i))))
# define mz_ld_fppush(r, i) mz_ld_fppush_x(r, i, JIT_FP)
# define mz_st_fppop_x(i, r, FP) (check_fp_depth(i, FP), (void)jit_stxi_d_fppop((JIT_FRAME_FLOSTACK_OFFSET - (i)), FP, r))
# define mz_st_fppop(i, r) mz_st_fppop_x(i, r, JIT_FP)
# define mz_ld_fppush_x(r, i, FP, extfl) (check_fp_depth(i, FP), jit_FPSEL_ldxi_xd_fppush(extfl, r, FP, (JIT_FRAME_FLOSTACK_OFFSET - (i))))
# define mz_ld_fppush(r, i, extfl) mz_ld_fppush_x(r, i, JIT_FP, extfl)
# define mz_st_fppop_x(i, r, FP, extfl) (check_fp_depth(i, FP), (void)jit_FPSEL_stxi_xd_fppop(extfl, (JIT_FRAME_FLOSTACK_OFFSET - (i)), FP, r))
# define mz_st_fppop(i, r, extfl) mz_st_fppop_x(i, r, JIT_FP, extfl)
#define mz_patch_branch(a) mz_patch_branch_at(a, (_jit.x.pc))
#define mz_patch_ucbranch(a) mz_patch_ucbranch_at(a, (_jit.x.pc))
@ -1076,6 +1127,11 @@ static void emit_indentation(mz_jit_state *jitter)
#define JIT_FPR_1(r) JIT_FPR1
#endif
#ifdef MZ_LONG_DOUBLE
#define JIT_FPU_FPR_0(r) JIT_FPU_FPR0
#define JIT_FPU_FPR_1(r) JIT_FPU_FPR1
#endif
#if defined(MZ_USE_JIT_I386)
# define mz_movi_d_fppush(rd,immd,tmp) { GC_CAN_IGNORE void *addr; \
addr = scheme_mz_retain_double(jitter, immd); \
@ -1085,10 +1141,24 @@ static void emit_indentation(mz_jit_state *jitter)
# define mz_movi_d_fppush(rd,immd,tmp) jit_movi_d_fppush(rd,immd)
#endif
#ifdef MZ_LONG_DOUBLE
# define mz_fpu_movi_ld_fppush(rd,immd,tmp) { GC_CAN_IGNORE void *addr; \
addr = scheme_mz_retain_long_double(jitter, immd); \
(void)jit_patchable_movi_p(tmp, addr); \
jit_fpu_ldr_ld_fppush(rd, tmp); }
#endif
/**********************************************************************/
/* Does boxing a type require registers, possibly GC, etc.? */
#ifdef MZ_LONG_DOUBLE
#define JIT_TYPE_NEEDS_BOXING(t) ((t) == SCHEME_LOCAL_TYPE_FLONUM \
|| (t) == SCHEME_LOCAL_TYPE_EXTFLONUM)
#else
#define JIT_TYPE_NEEDS_BOXING(t) ((t) == SCHEME_LOCAL_TYPE_FLONUM)
#endif
/**********************************************************************/
@ -1189,6 +1259,9 @@ int scheme_mz_flostack_save(mz_jit_state *jitter, int *pos);
int scheme_mz_compute_runstack_restored(mz_jit_state *jitter, int adj, int skip);
int scheme_mz_retain_it(mz_jit_state *jitter, void *v);
double *scheme_mz_retain_double(mz_jit_state *jitter, double d);
#ifdef MZ_LONG_DOUBLE
long double *scheme_mz_retain_long_double(mz_jit_state *jitter, long double d);
#endif
int scheme_mz_remap_it(mz_jit_state *jitter, int i);
void scheme_mz_pushr_p_it(mz_jit_state *jitter, int reg);
void scheme_mz_popr_p_it(mz_jit_state *jitter, int reg, int discard);
@ -1215,6 +1288,16 @@ int scheme_mz_try_runstack_pop(mz_jit_state *jitter, int n);
#define mz_runstack_popped(j, n) scheme_mz_runstack_popped(j, n)
#define mz_try_runstack_pop(j, n) scheme_mz_try_runstack_pop(j, n)
typedef struct {
int unbox;
#ifdef MZ_LONG_DOUBLE
int unbox_extflonum;
#endif
} mz_jit_unbox_state;
void scheme_mz_unbox_save(mz_jit_state *jitter, mz_jit_unbox_state *r);
void scheme_mz_unbox_restore(mz_jit_state *jitter, mz_jit_unbox_state *r);
/**********************************************************************/
/* jitinline */
/**********************************************************************/
@ -1246,7 +1329,8 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
#ifdef CAN_INLINE_ALLOC
int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int flags,
int keep_r0_r1, int keep_fpr1, int inline_retry);
int keep_r0_r1, int keep_fpr1, int inline_retry
, int keep_extfpr1);
int scheme_generate_alloc_retry(mz_jit_state *jitter, int i);
#else
Scheme_Object *scheme_jit_make_list(GC_CAN_IGNORE Scheme_Object **rs, intptr_t n);
@ -1264,8 +1348,8 @@ Scheme_Object *scheme_jit_make_two_element_ivector(Scheme_Object *a, Scheme_Obje
/**********************************************************************/
int scheme_jit_is_fixnum(Scheme_Object *rand);
int scheme_can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely);
int scheme_can_unbox_directly(Scheme_Object *obj);
int scheme_can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely, int extfl);
int scheme_can_unbox_directly(Scheme_Object *obj, int extfl);
int scheme_generate_unboxing(mz_jit_state *jitter, int target);
int scheme_generate_pop_unboxed(mz_jit_state *jitter);
int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
@ -1278,6 +1362,16 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
int unsafe_fx, int unsafe_fl, GC_CAN_IGNORE jit_insn *overflow_refslow,
int dest);
#ifdef MZ_LONG_DOUBLE
int scheme_generate_alloc_long_double(mz_jit_state *jitter, int inline_retry, int dest);
int scheme_generate_extflonum_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,
int orig_args, int arith, int cmp, int v,
Branch_Info *for_branch, int branch_short, int unsafe_fx, int unsafe_extfl,
GC_CAN_IGNORE jit_insn *overflow_refslow, int dest);
#endif
int scheme_generate_alloc_X_double(mz_jit_state *jitter, int inline_retry, int dest, int extfl);
/**********************************************************************/
/* jitcall */
/**********************************************************************/
@ -1347,8 +1441,8 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int tail_ok, int w
int scheme_generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway);
#ifdef USE_FLONUM_UNBOXING
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push);
int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offset, int target);
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int extfl);
int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offset, int target, int extfl);
#endif
int scheme_generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inlined_ok, int unbox_anyway);
int scheme_generate_non_tail_mark_pos_prefix(mz_jit_state *jitter);
@ -1373,7 +1467,7 @@ int scheme_can_delay_and_avoids_r1(Scheme_Object *obj);
int scheme_can_delay_and_avoids_r1_r2(Scheme_Object *obj);
int scheme_is_constant_and_avoids_r1(Scheme_Object *obj);
int scheme_is_relatively_constant_and_avoids_r1_maybe_fp(Scheme_Object *obj, Scheme_Object *wrt,
int fp_ok);
int fp_ok, int extfl);
int scheme_is_relatively_constant_and_avoids_r1(Scheme_Object *obj, Scheme_Object *wrt);
int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder);
int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack_start);

20
src/racket/src/jit_ts.c
View File

@ -35,6 +35,9 @@ define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER)
#ifdef JITARITH_TS_PROCS
# if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC)
define_ts__s(malloc_double, FSRC_OTHER)
# ifdef MZ_LONG_DOUBLE
define_ts__s(malloc_long_double, FSRC_OTHER)
# endif
# endif
#endif
@ -74,11 +77,18 @@ define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_byte_string_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_set, FSRC_MARKS)
#ifdef MZ_LONG_DOUBLE
define_ts_iS_s(scheme_checked_extflvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_extflvector_set, FSRC_MARKS)
#endif
define_ts_iS_s(scheme_checked_fxvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_fxvector_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS)
define_ts_s_s(scheme_vector_length, FSRC_MARKS)
define_ts_s_s(scheme_flvector_length, FSRC_MARKS)
#ifdef MZ_LONG_DOUBLE
define_ts_s_s(scheme_extflvector_length, FSRC_MARKS)
#endif
define_ts_s_s(scheme_fxvector_length, FSRC_MARKS)
define_ts_s_s(scheme_unbox, FSRC_MARKS)
define_ts_si_s(scheme_struct_ref, FSRC_MARKS)
@ -134,6 +144,9 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_force_value_same_mark scheme_force_value_same_mark
# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark
# define ts_malloc_double malloc_double
#ifdef MZ_LONG_DOUBLE
# define ts_malloc_long_double malloc_long_double
#endif
# define ts_scheme_box scheme_box
# define ts_scheme_make_mutable_pair scheme_make_mutable_pair
# define ts_scheme_jit_make_list_star scheme_jit_make_list_star
@ -182,6 +195,9 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_chaperone_set_mark chaperone_set_mark
# define ts_scheme_vector_length scheme_vector_length
# define ts_scheme_flvector_length scheme_flvector_length
#ifdef MZ_LONG_DOUBLE
# define ts_scheme_extflvector_length scheme_extflvector_length
#endif
# define ts_scheme_fxvector_length scheme_fxvector_length
# define ts_scheme_struct_ref scheme_struct_ref
# define ts_scheme_struct_set scheme_struct_set
@ -199,6 +215,10 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set
# define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref
# define ts_scheme_checked_flvector_set scheme_checked_flvector_set
#ifdef MZ_LONG_DOUBLE
# define ts_scheme_checked_extflvector_ref scheme_checked_extflvector_ref
# define ts_scheme_checked_extflvector_set scheme_checked_extflvector_set
#endif
# define ts_scheme_checked_fxvector_ref scheme_checked_fxvector_ref
# define ts_scheme_checked_fxvector_set scheme_checked_fxvector_set
# define ts_scheme_checked_syntax_e scheme_checked_syntax_e

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

@ -44,6 +44,10 @@ THREAD_LOCAL_DECL(static void *retry_alloc_r1); /* set by prepare_retry_alloc()
#ifdef JIT_USE_FP_OPS
THREAD_LOCAL_DECL(double scheme_jit_save_fp);
THREAD_LOCAL_DECL(double scheme_jit_save_fp2);
# ifdef MZ_LONG_DOUBLE
THREAD_LOCAL_DECL(long double scheme_jit_save_extfp);
THREAD_LOCAL_DECL(long double scheme_jit_save_extfp2);
# endif
#endif
static void *prepare_retry_alloc(void *p, void *p2)
@ -115,7 +119,8 @@ static intptr_t initial_tag_word(Scheme_Type tag, int flags)
}
int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int flags,
int keep_r0_r1, int keep_fpr1, int inline_retry)
int keep_r0_r1, int keep_fpr1, int inline_retry,
int keep_extfpr1)
/* 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).
Save FP0 when FP ops are enabled. */
@ -145,7 +150,13 @@ int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int flags
}
} else if (keep_fpr1) {
(void)jit_calli(sjc.retry_alloc_code_keep_fpr1);
} else {
}
#ifdef MZ_LONG_DOUBLE
else if (keep_extfpr1) {
(void)jit_calli(sjc.retry_alloc_code_keep_extfpr1);
}
#endif
else {
(void)jit_calli(sjc.retry_alloc_code);
}
__START_TINY_JUMPS__(1);
@ -206,6 +217,12 @@ static void *malloc_double(void)
{
return scheme_make_double(scheme_jit_save_fp);
}
#ifdef MZ_LONG_DOUBLE
static void *malloc_long_double(void)
{
return scheme_make_long_double(scheme_jit_save_extfp);
}
#endif
#endif
#ifdef MZ_PRECISE_GC
@ -281,6 +298,8 @@ Scheme_Object *scheme_jit_make_two_element_ivector(Scheme_Object *a, Scheme_Obje
#endif
#ifdef CAN_INLINE_ALLOC
long double ld1;
int scheme_generate_alloc_retry(mz_jit_state *jitter, int i)
{
GC_CAN_IGNORE jit_insn *refr;
@ -289,6 +308,11 @@ int scheme_generate_alloc_retry(mz_jit_state *jitter, int i)
if (i == 2) {
(void)mz_tl_sti_d_fppop(tl_scheme_jit_save_fp, JIT_FPR0, JIT_R2);
}
# ifdef MZ_LONG_DOUBLE
if (i == 3) {
(void)mz_fpu_tl_sti_ld_fppop(tl_scheme_jit_save_extfp, JIT_FPU_FPR0, JIT_R2);
}
# endif
#endif
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2);
@ -310,6 +334,11 @@ int scheme_generate_alloc_retry(mz_jit_state *jitter, int i)
if (i == 2) {
(void)mz_tl_ldi_d_fppush(JIT_FPR0, tl_scheme_jit_save_fp, JIT_R2);
}
# ifdef MZ_LONG_DOUBLE
if (i == 3) {
(void)mz_fpu_tl_ldi_ld_fppush(JIT_FPU_FPR0, tl_scheme_jit_save_extfp, JIT_R2);
}
# endif
#endif
return 1;
}

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

File diff suppressed because it is too large Load Diff

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

@ -1123,7 +1123,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
rand = (alt_rands
? alt_rands[i+1+args_already_in_place]
: app->args[i+1+args_already_in_place]);
mz_ld_fppush(JIT_FPR0, arg_tmp_offset);
mz_ld_fppush(JIT_FPR0, arg_tmp_offset, 0);
arg_tmp_offset -= sizeof(double);
already_unboxed = 1;
if (!already_loaded && !SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
@ -1141,7 +1141,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
if (!already_unboxed)
jit_ldxi_d_fppush(JIT_FPR0, JIT_R0, &((Scheme_Double *)0x0)->double_val);
arg_offset += sizeof(double);
mz_st_fppop(arg_offset, JIT_FPR0);
mz_st_fppop(arg_offset, JIT_FPR0, 0);
}
#endif
CHECK_LIMIT();
@ -1536,8 +1536,8 @@ static int generate_fp_argument_shuffle(int direct_flostack_offset, mz_jit_state
i_pos = jitter->flostack_offset - direct_flostack_offset + i + sizeof(double);
a_pos = direct_flostack_offset - i;
if (i_pos != a_pos) {
mz_ld_fppush(JIT_FPR0, i_pos);
mz_st_fppop(a_pos, JIT_FPR0);
mz_ld_fppush(JIT_FPR0, i_pos, 0);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
}
@ -1548,10 +1548,10 @@ static int generate_fp_argument_shuffle(int direct_flostack_offset, mz_jit_state
int i_pos, j_pos;
i_pos = jitter->flostack_offset - direct_flostack_offset + i + sizeof(double);
j_pos = jitter->flostack_offset - direct_flostack_offset + j + sizeof(double);
mz_ld_fppush(JIT_FPR1, i_pos);
mz_ld_fppush(JIT_FPR0, j_pos);
mz_st_fppop(i_pos, JIT_FPR0);
mz_st_fppop(j_pos, JIT_FPR1);
mz_ld_fppush(JIT_FPR1, i_pos, 0);
mz_ld_fppush(JIT_FPR0, j_pos, 0);
mz_st_fppop(i_pos, JIT_FPR0, 0);
mz_st_fppop(j_pos, JIT_FPR1, 0);
CHECK_LIMIT();
}
@ -1560,9 +1560,9 @@ static int generate_fp_argument_shuffle(int direct_flostack_offset, mz_jit_state
for (i = 0; i < direct_flostack_offset; i += sizeof(double)) {
int i_pos, a_pos;
i_pos = jitter->flostack_offset - direct_flostack_offset + i + sizeof(double);
mz_ld_fppush(JIT_FPR0, i_pos);
mz_ld_fppush(JIT_FPR0, i_pos, 0);
a_pos = i + sizeof(double);
mz_st_fppop(a_pos, JIT_FPR0);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
}
@ -1593,8 +1593,8 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos
int i_pos, a_pos;
i_pos = jitter->flostack_offset - direct_flostack_offset + i + sizeof(double);
a_pos = direct_flostack_offset - i;
mz_ld_fppush_x(JIT_FPR0, i_pos, JIT_R2);
mz_st_fppop(a_pos, JIT_FPR0);
mz_ld_fppush_x(JIT_FPR0, i_pos, JIT_R2, 0);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
@ -1622,7 +1622,7 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos
offset = jitter->flostack_offset - direct_flostack_offset + k;
offset = JIT_FRAME_FLOSTACK_OFFSET - offset;
jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(i));
scheme_generate_flonum_local_boxing(jitter, i, offset, JIT_R0);
scheme_generate_flonum_local_boxing(jitter, i, offset, JIT_R0, 0);
}
}
@ -1882,7 +1882,8 @@ 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_TYPE(arg) != SCHEME_LOCAL_TYPE_FLONUM)))
&& (SCHEME_GET_LOCAL_TYPE(arg) != SCHEME_LOCAL_TYPE_FLONUM)
&& (SCHEME_GET_LOCAL_TYPE(arg) != SCHEME_LOCAL_TYPE_EXTFLONUM))
|| (t >= _scheme_values_types_))) {
/* App of something complex to a local variable. We
can move the proc directly to V1. */
@ -1920,9 +1921,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
&& (CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i+args_already_in_place))) {
int directly;
jitter->unbox++;
if (scheme_can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0))
if (scheme_can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0, 0))
directly = 2;
else if (scheme_can_unbox_directly(arg))
else if (scheme_can_unbox_directly(arg, 0))
directly = 1;
else
directly = 0;
@ -1930,7 +1931,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
--jitter->unbox;
--jitter->unbox_depth;
CHECK_LIMIT();
scheme_generate_flonum_local_unboxing(jitter, 0);
scheme_generate_flonum_local_unboxing(jitter, 0, 0);
CHECK_LIMIT();
if (SAME_TYPE(SCHEME_TYPE(arg), scheme_local_type)) {
/* Keep local Scheme_Object view, in case a box has been allocated */

269
src/racket/src/jitcommon.c
View File

@ -580,6 +580,18 @@ static int common1b(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, sjc.bad_flvector_length_code, scheme_false);
#ifdef MZ_LONG_DOUBLE
/* *** bad_extflvector_length_code *** */
/* R0 is argument */
sjc.bad_extflvector_length_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_extflvector_length, ref);
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, sjc.bad_extflvector_length_code, scheme_false);
#endif
/* *** bad_fxvector_length_code *** */
/* R0 is argument */
sjc.bad_fxvector_length_code = jit_get_ip().ptr;
@ -1658,51 +1670,57 @@ static int common4(mz_jit_state *jitter, void *_data)
/* *** {flvector}_{ref,set}_check_index_code *** */
/* Same calling convention as for vector ops. */
for (i = 0; i < 3; i++) {
void *code;
for (iii = 0; iii < JIT_NUM_FL_KINDS; iii++) {
for (i = 0; i < 3; i++) {
void *code;
code = jit_get_ip().ptr;
code = jit_get_ip().ptr;
if (!i) {
sjc.flvector_ref_check_index_code = code;
} else if (i == 1) {
sjc.flvector_set_check_index_code = code;
} else {
sjc.flvector_set_flonum_check_index_code = code;
}
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
CHECK_RUNSTACK_OVERFLOW();
jit_str_p(JIT_RUNSTACK, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
if (!i) {
jit_movi_i(JIT_R1, 2);
} else {
/* In set mode, value was already on run stack
or in FP register */
jit_movi_i(JIT_R1, 3);
if (i == 2) {
/* need to box flonum */
scheme_generate_alloc_double(jitter, 1, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R0);
if (!i) {
sjc.flvector_ref_check_index_code[iii] = code;
} else if (i == 1) {
sjc.flvector_set_check_index_code[iii] = code;
} else {
sjc.flvector_set_flonum_check_index_code[iii] = code;
}
}
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R1);
if (!i) {
(void)mz_finish_lwe(ts_scheme_checked_flvector_ref, ref);
} else {
(void)mz_finish_lwe(ts_scheme_checked_flvector_set, ref);
}
/* does not return */
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, code, scheme_false);
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
CHECK_RUNSTACK_OVERFLOW();
jit_str_p(JIT_RUNSTACK, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
if (!i) {
jit_movi_i(JIT_R1, 2);
} else {
/* In set mode, value was already on run stack
or in FP register */
jit_movi_i(JIT_R1, 3);
if (i == 2) {
/* need to box flonum */
scheme_generate_alloc_double(jitter, 1, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R0);
}
}
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R1);
if (!i) {
MZ_FPUSEL_STMT(iii,
(void)mz_finish_lwe(ts_scheme_checked_extflvector_ref, ref),
(void)mz_finish_lwe(ts_scheme_checked_flvector_ref, ref));
} else {
MZ_FPUSEL_STMT(iii,
(void)mz_finish_lwe(ts_scheme_checked_extflvector_set, ref),
(void)mz_finish_lwe(ts_scheme_checked_flvector_set, ref));
}
/* does not return */
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, code, scheme_false);
}
}
/* *** struct_raw_{ref,set}_code *** */
@ -2119,17 +2137,29 @@ static int common4c(mz_jit_state *jitter, void *_data)
static int common5(mz_jit_state *jitter, void *_data)
{
int i, ii;
int i, ii, iii;
#ifdef MZ_LONG_DOUBLE
# define END_OF_I 4
#else
# define END_OF_I 3
#endif
#ifdef CAN_INLINE_ALLOC
/* *** retry_alloc_code[{_keep_r0_r1,_keep_fpr1}] *** */
for (i = 0; i < 3; i++) {
for (i = 0; i < END_OF_I; i++) {
if (!i)
sjc.retry_alloc_code = jit_get_ip().ptr;
else if (i == 1)
sjc.retry_alloc_code_keep_r0_r1 = jit_get_ip().ptr;
else
else if (i == 2) {
sjc.retry_alloc_code_keep_fpr1 = jit_get_ip().ptr;
}
#ifdef MZ_LONG_DOUBLE
else if (i == 3) {
sjc.retry_alloc_code_keep_extfpr1 = jit_get_ip().ptr;
}
#endif
mz_prolog(JIT_V1);
scheme_generate_alloc_retry(jitter, i);
@ -2218,10 +2248,31 @@ static int common5(mz_jit_state *jitter, void *_data)
mz_epilog(JIT_R2);
}
/* *** fl1_code *** */
/* R0 has argument, V1 has primitive proc */
/* *** box_extflonum_from_reg_code *** */
/* JIT_FPU_FPR2 (reg-based) or JIT_FPU_FPR0 (stack-based) has value */
#ifdef MZ_LONG_DOUBLE
{
sjc.fl1_fail_code = jit_get_ip().ptr;
sjc.box_extflonum_from_reg_code = jit_get_ip().ptr;
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
#ifdef DISABLED_DIRECT_FPR_ACCESS
jit_fpu_movr_ld(JIT_FPU_FPR0, JIT_FPU_FPR2);
#endif
scheme_generate_alloc_long_double(jitter, 1, JIT_R0);
CHECK_LIMIT();
mz_epilog(JIT_R2);
}
#endif
/* *** fl1_fail_code *** */
/* R0 has argument, V1 has primitive proc */
for (iii = 0; iii < JIT_NUM_FL_KINDS; iii++) {
sjc.fl1_fail_code[iii] = jit_get_ip().ptr;
mz_prolog(JIT_R2);
@ -2240,73 +2291,77 @@ static int common5(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
}
scheme_jit_register_sub_func(jitter, sjc.fl1_fail_code, scheme_false);
scheme_jit_register_sub_func(jitter, sjc.fl1_fail_code[iii], scheme_false);
}
/* *** fl2{rf}{rf}_code *** */
/* *** fl2{rf}{rf}_fail_code *** */
/* R0 and/or R1 have arguments, V1 has primitive proc,
non-register argument is in FPR0 */
for (ii = 0; ii < 2; ii++) {
for (i = 0; i < 3; i++) {
void *code;
int a0, a1;
for (iii = 0; iii < JIT_NUM_FL_KINDS; iii++) {
for (ii = 0; ii < 2; ii++) {
for (i = 0; i < 3; i++) {
void *code;
int a0, a1;
code = jit_get_ip().ptr;
switch (i) {
case 0:
sjc.fl2rr_fail_code[ii] = code;
break;
case 1:
sjc.fl2fr_fail_code[ii] = code;
break;
case 2:
sjc.fl2rf_fail_code[ii] = code;
break;
}
if (!ii) {
a0 = 0; a1 = 1;
} else {
a0 = 1; a1 = 0;
}
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
if ((i == 0) || (i == 2))
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_R0);
else
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_V1);
if ((i == 0) || (i == 1))
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_R1);
else
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_V1);
if (i != 0) {
scheme_generate_alloc_double(jitter, 1, JIT_R0);
CHECK_LIMIT();
if (i == 1) {
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(a0));
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_R0);
} else {
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(a1));
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_R0);
code = jit_get_ip().ptr;
switch (i) {
case 0:
sjc.fl2rr_fail_code[ii][iii] = code;
break;
case 1:
sjc.fl2fr_fail_code[ii][iii] = code;
break;
case 2:
sjc.fl2rf_fail_code[ii][iii] = code;
break;
}
}
jit_movi_i(JIT_R1, 2);
CHECK_LIMIT();
mz_prepare_direct_prim(2);
{
mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK),
jit_pusharg_i(JIT_R1),
JIT_V1, scheme_noncm_prim_indirect);
CHECK_LIMIT();
}
scheme_jit_register_sub_func(jitter, code, scheme_false);
if (!ii) {
a0 = 0; a1 = 1;
} else {
a0 = 1; a1 = 0;
}
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
if ((i == 0) || (i == 2))
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_R0);
else
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_V1);
if ((i == 0) || (i == 1))
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_R1);
else
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_V1);
if (i != 0) {
MZ_FPUSEL_STMT(iii,
scheme_generate_alloc_long_double(jitter, 1, JIT_R0),
scheme_generate_alloc_double(jitter, 1, JIT_R0));
CHECK_LIMIT();
if (i == 1) {
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(a0));
jit_stxi_p(WORDS_TO_BYTES(a0), JIT_RUNSTACK, JIT_R0);
} else {
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(a1));
jit_stxi_p(WORDS_TO_BYTES(a1), JIT_RUNSTACK, JIT_R0);
}
}
jit_movi_i(JIT_R1, 2);
CHECK_LIMIT();
mz_prepare_direct_prim(2);
{
mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK),
jit_pusharg_i(JIT_R1),
JIT_V1, scheme_noncm_prim_indirect);
CHECK_LIMIT();
}
scheme_jit_register_sub_func(jitter, code, scheme_false);
}
}
}

124
src/racket/src/jitfpu.h Normal file
View File

@ -0,0 +1,124 @@
/* The ..._FPSEL..._xd... operations select fpu-and-_ld mode versus default-and-_d mode. */
#ifdef MZ_LONG_DOUBLE
# define MZ_FPUSEL(use_fpu, b1, b2) (use_fpu ? b1 : b2)
# define MZ_FPUSEL_STMT(use_fpu, b1, b2) if (use_fpu) { b1; } else { b2; }
# define MZ_FPUSEL_STMT_ONLY(use_fpu, b1) if (use_fpu) { b1; }
# define JIT_FPUSEL_FPR_NUM(use_fpu) (use_fpu ? JIT_FPU_FPR_NUM : JIT_FPR_NUM)
# define JIT_FPUSEL_FPR_0(use_fpu, d) (use_fpu ? JIT_FPU_FPR_0(d) : JIT_FPR_0(d))
# define JIT_FPUSEL_FPR_1(use_fpu, d) (use_fpu ? JIT_FPU_FPR_1(d) : JIT_FPR_1(d))
# define jit_FPSEL_fxch(use_fpu, rs, op) (use_fpu ? jit_fpu_fxch(rs, op) : jit_fxch(rs, op))
# define jit_FPSEL_addr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_addr_ld(rd,s1,s2) : jit_addr_d(rd,s1,s2))
# define jit_FPSEL_subr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_subr_ld(rd,s1,s2) : jit_subr_d(rd,s1,s2))
# define jit_FPSEL_subrr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_subrr_ld(rd,s1,s2) : jit_subrr_d(rd,s1,s2))
# define jit_FPSEL_mulr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_mulr_ld(rd,s1,s2) : jit_mulr_d(rd,s1,s2))
# define jit_FPSEL_ldivr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_ldivr_ld(rd,s1,s2) : jit_ldivr_d(rd,s1,s2))
# define jit_FPSEL_ldivrr_xd(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_ldivrr_ld(rd,s1,s2) : jit_ldivrr_d(rd,s1,s2))
# define jit_FPSEL_abs_xd(use_fpu, rd,rs) (use_fpu ? jit_fpu_abs_ld(rd,rs) : jit_abs_d(rd,rs))
# define jit_FPSEL_negr_xd(use_fpu, rd,rs) (use_fpu ? jit_fpu_negr_ld(rd,rs) : jit_negr_d(rd,rs))
# define jit_FPSEL_sqrt_xd(use_fpu, rd,rs) (use_fpu ? jit_fpu_sqrt_ld(rd,rs) : jit_sqrt_d(rd,rs))
# define jit_FPSEL_addr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_addr_ld_fppop(rd,s1,s2) : jit_addr_d_fppop(rd,s1,s2))
# define jit_FPSEL_subr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_subr_ld_fppop(rd,s1,s2) : jit_subr_d_fppop(rd,s1,s2))
# define jit_FPSEL_subrr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_subrr_ld_fppop(rd,s1,s2) : jit_subrr_d_fppop(rd,s1,s2))
# define jit_FPSEL_mulr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_mulr_ld_fppop(rd,s1,s2) : jit_mulr_d_fppop(rd,s1,s2))
# define jit_FPSEL_divr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_divr_ld_fppop(rd,s1,s2) : jit_divr_d_fppop(rd,s1,s2))
# define jit_FPSEL_divrr_xd_fppop(use_fpu, rd,s1,s2) (use_fpu ? jit_fpu_divrr_ld_fppop(rd,s1,s2) : jit_divrr_d_fppop(rd,s1,s2))
# define jit_FPSEL_negr_xd_fppop(use_fpu, rd,rs) (use_fpu ? jit_fpu_negr_ld_fppop(rd,rs) : jit_negr_d_fppop(rd,rs))
# define jit_FPSEL_abs_xd_fppop(use_fpu, rd,rs) (use_fpu ? jit_fpu_abs_ld_fppop(rd,rs) : jit_abs_d_fppop(rd,rs))
# define jit_FPSEL_sqrt_xd_fppop(use_fpu, rd,rs) (use_fpu ? jit_fpu_sqrt_ld_fppop(rd,rs) : jit_sqrt_d_fppop(rd,rs))
# define jit_FPSEL_movr_xd(use_fpu, rd,s1) (use_fpu ? jit_fpu_movr_ld(rd,s1) : jit_movr_d(rd,s1))
# define jit_FPSEL_movr_xd_rel(use_fpu, rd,s1) (use_fpu ? jit_fpu_movr_ld_rel(rd,s1) : jit_movr_d_rel(rd,s1))
# define jit_FPSEL_movr_xd_fppush(use_fpu, rd,s1) (use_fpu ? jit_fpu_movr_ld_fppush(rd,s1) : jit_movr_d_fppush(rd,s1))
# define jit_FPSEL_ldi_xd(use_fpu, rd, is) (use_fpu ? jit_fpu_ldi_ld(rd, is) : jit_ldi_d(rd, is))
# define jit_FPSEL_ldi_xd_fppush(use_fpu, rd, is) (use_fpu ? jit_fpu_ldi_ld_fppush(rd, is) : jit_ldi_d_fppush(rd, is))
# define jit_FPSEL_ldr_xd(use_fpu, rd, rs) (use_fpu ? jit_fpu_ldr_ld(rd, rs) : jit_ldr_d(rd, rs))
# define jit_FPSEL_ldr_xd_fppush(use_fpu, rd, rs) (use_fpu ? jit_fpu_ldr_ld_fppush(rd, rs) : jit_ldr_d_fppush(rd, rs))
# define jit_FPSEL_ldxi_xd(use_fpu, rd, rs, is) (use_fpu ? jit_fpu_ldxi_ld(rd, rs, is) : jit_ldxi_d(rd, rs, is))
# define jit_FPSEL_ldxi_xd_fppush(use_fpu, rd, rs, is) (use_fpu ? jit_fpu_ldxi_ld_fppush(rd, rs, is) : jit_ldxi_d_fppush(rd, rs, is))
# define jit_FPSEL_ldxr_xd(use_fpu, rd, s1, s2) (use_fpu ? jit_fpu_ldxr_ld(rd, s1, s2) : jit_ldxr_d(rd, s1, s2))
# define jit_FPSEL_ldxr_xd_fppush(use_fpu, rd, s1, s2) (use_fpu ? jit_fpu_ldxr_ld_fppush(rd, s1, s2) : jit_ldxr_d_fppush(rd, s1, s2))
# define jit_FPSEL_extr_i_xd_fppush(use_fpu, rd, rs) (use_fpu ? jit_fpu_extr_i_ld_fppush(rd, rs) : jit_extr_i_d_fppush(rd, rs))
# define jit_FPSEL_extr_l_xd_fppush(use_fpu, rd, rs) (use_fpu ? jit_fpu_extr_l_ld_fppush(rd, rs) : jit_extr_l_d_fppush(rd, rs))
# define jit_FPSEL_sti_xd_fppop(use_fpu, id, rs) (use_fpu ? jit_fpu_sti_ld_fppop(id, rs) : jit_sti_d_fppop(id, rs))
# define jit_FPSEL_stxi_xd_fppop(use_fpu, id, rd, rs) (use_fpu ? jit_fpu_stxi_ld_fppop(id, rd, rs) : jit_stxi_d_fppop(id, rd, rs))
# define jit_FPSEL_str_xd_fppop(use_fpu, rd, rs) (use_fpu ? jit_fpu_str_ld_fppop(rd, rs) : jit_str_d_fppop(rd, rs))
# define jit_FPSEL_stxr_xd_fppop(use_fpu, d1, d2, rs) (use_fpu ? jit_fpu_stxr_ld_fppop(d1, d2, rs) : jit_stxr_d_fppop(d1, d2, rs))
# define jit_FPSEL_roundr_xd_i(use_fpu, rd, rs) (use_fpu ? jit_fpu_roundr_ld_i(rd, rs) : jit_roundr_d_i(rd, rs))
# define jit_FPSEL_roundr_xd_l(use_fpu, rd, rs) (use_fpu ? jit_fpu_roundr_ld_l(rd, rs) : jit_roundr_d_l(rd, rs))
# define jit_FPSEL_roundr_xd_l_fppop(use_fpu, rd, rs) (use_fpu ? jit_fpu_roundr_ld_l_fppop(rd, rs) : jit_roundr_d_l_fppop(rd, rs))
# define jit_FPSEL_bger_xd(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bger_ld(d, s1, s2) : jit_bger_d(d, s1, s2))
# define jit_FPSEL_bltr_xd(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bltr_ld(d, s1, s2) : jit_bltr_d(d, s1, s2))
# define jit_FPSEL_beqr_xd(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_beqr_ld(d, s1, s2) : jit_beqr_d(d, s1, s2))
# define jit_FPSEL_bantieqr_xd(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantieqr_ld(d, s1, s2) : jit_bantieqr_d(d, s1, s2))
# define jit_FPSEL_bger_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bger_ld_fppop(d, s1, s2) : jit_bger_d_fppop(d, s1, s2))
# define jit_FPSEL_bantiger_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantiger_ld_fppop(d, s1, s2) : jit_bantiger_d_fppop(d, s1, s2))
# define jit_FPSEL_bler_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bler_ld_fppop(d, s1, s2) : jit_bler_d_fppop(d, s1, s2))
# define jit_FPSEL_bantiler_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantiler_ld_fppop(d, s1, s2) : jit_bantiler_d_fppop(d, s1, s2))
# define jit_FPSEL_bgtr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bgtr_ld_fppop(d, s1, s2) : jit_bgtr_d_fppop(d, s1, s2))
# define jit_FPSEL_bantigtr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantigtr_ld_fppop(d, s1, s2) : jit_bantigtr_d_fppop(d, s1, s2))
# define jit_FPSEL_bltr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bltr_ld_fppop(d, s1, s2) : jit_bltr_d_fppop(d, s1, s2))
# define jit_FPSEL_bantiltr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantiltr_ld_fppop(d, s1, s2) : jit_bantiltr_d_fppop(d, s1, s2))
# define jit_FPSEL_beqr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_beqr_ld_fppop(d, s1, s2) : jit_beqr_d_fppop(d, s1, s2))
# define jit_FPSEL_bantieqr_xd_fppop(use_fpu, d, s1, s2) (use_fpu ? jit_fpu_bantieqr_ld_fppop(d, s1, s2) : jit_bantieqr_d_fppop(d, s1, s2))
#else
# define MZ_FPUSEL(use_fpu, b1, b2) b2
# define MZ_FPUSEL_STMT(use_fpu, b1, b2) { b2; }
# define MZ_FPUSEL_STMT_ONLY(use_fpu, b1) /* empty */
# define JIT_FPUSEL_FPR_NUM(use_fpu) JIT_FPR_NUM
# define JIT_FPUSEL_FPR_0(use_fpu, d) JIT_FPR_0(d)
# define JIT_FPUSEL_FPR_1(use_fpu, d) JIT_FPR_1(d)
# define jit_FPSEL_fxch(use_fpu, rs, op) jit_fxch(rs, op)
# define jit_FPSEL_addr_xd(use_fpu, rd,s1,s2) jit_addr_d(rd,s1,s2)
# define jit_FPSEL_subr_xd(use_fpu, rd,s1,s2) jit_subr_d(rd,s1,s2)
# define jit_FPSEL_subrr_xd(use_fpu, rd,s1,s2) jit_subrr_d(rd,s1,s2)
# define jit_FPSEL_mulr_xd(use_fpu, rd,s1,s2) jit_mulr_d(rd,s1,s2)
# define jit_FPSEL_ldivr_xd(use_fpu, rd,s1,s2) jit_ldivr_d(rd,s1,s2)
# define jit_FPSEL_ldivrr_xd(use_fpu, rd,s1,s2) jit_ldivrr_d(rd,s1,s2)
# define jit_FPSEL_abs_xd(use_fpu, rd,rs) jit_abs_d(rd,rs)
# define jit_FPSEL_negr_xd(use_fpu, rd,rs) jit_negr_d(rd,rs)
# define jit_FPSEL_sqrt_xd(use_fpu, rd,rs) jit_sqrt_d(rd,rs)
# define jit_FPSEL_addr_xd_fppop(use_fpu, rd,s1,s2) jit_addr_d_fppop(rd,s1,s2)
# define jit_FPSEL_subr_xd_fppop(use_fpu, rd,s1,s2) jit_subr_d_fppop(rd,s1,s2)
# define jit_FPSEL_subrr_xd_fppop(use_fpu, rd,s1,s2) jit_subrr_d_fppop(rd,s1,s2)
# define jit_FPSEL_mulr_xd_fppop(use_fpu, rd,s1,s2) jit_mulr_d_fppop(rd,s1,s2)
# define jit_FPSEL_divr_xd_fppop(use_fpu, rd,s1,s2) jit_divr_d_fppop(rd,s1,s2)
# define jit_FPSEL_divrr_xd_fppop(use_fpu, rd,s1,s2) jit_divrr_d_fppop(rd,s1,s2)
# define jit_FPSEL_negr_xd_fppop(use_fpu, rd,rs) jit_negr_d_fppop(rd,rs)
# define jit_FPSEL_abs_xd_fppop(use_fpu, rd,rs) jit_abs_d_fppop(rd,rs)
# define jit_FPSEL_sqrt_xd_fppop(use_fpu, rd,rs) jit_sqrt_d_fppop(rd,rs)
# define jit_FPSEL_movr_xd(use_fpu, rd,s1) jit_movr_d(rd,s1)
# define jit_FPSEL_movr_xd_rel(use_fpu, rd,s1) jit_movr_d_rel(rd,s1)
# define jit_FPSEL_movr_xd_fppush(use_fpu, rd,s1) jit_movr_d_fppush(rd,s1)
# define jit_FPSEL_ldi_xd(use_fpu, rd, is) jit_ldi_d(rd, is)
# define jit_FPSEL_ldi_xd_fppush(use_fpu, rd, is) jit_ldi_d_fppush(rd, is)
# define jit_FPSEL_ldr_xd(use_fpu, rd, rs) jit_ldr_d(rd, rs)
# define jit_FPSEL_ldr_xd_fppush(use_fpu, rd, rs) jit_ldr_d_fppush(rd, rs)
# define jit_FPSEL_ldxi_xd(use_fpu, rd, rs, is) jit_ldxi_d(rd, rs, is)
# define jit_FPSEL_ldxi_xd_fppush(use_fpu, rd, rs, is) jit_ldxi_d_fppush(rd, rs, is)
# define jit_FPSEL_ldxr_xd(use_fpu, rd, s1, s2) jit_ldxr_d(rd, s1, s2)
# define jit_FPSEL_ldxr_xd_fppush(use_fpu, rd, s1, s2) jit_ldxr_d_fppush(rd, s1, s2)
# define jit_FPSEL_extr_i_xd_fppush(use_fpu, rd, rs) jit_extr_i_d_fppush(rd, rs)
# define jit_FPSEL_extr_l_xd_fppush(use_fpu, rd, rs) jit_extr_l_d_fppush(rd, rs)
# define jit_FPSEL_sti_xd_fppop(use_fpu, id, rs) jit_sti_d_fppop(id, rs)
# define jit_FPSEL_stxi_xd_fppop(use_fpu, id, rd, rs) jit_stxi_d_fppop(id, rd, rs)
# define jit_FPSEL_str_xd_fppop(use_fpu, rd, rs) jit_str_d_fppop(rd, rs)
# define jit_FPSEL_stxr_xd_fppop(use_fpu, d1, d2, rs) jit_stxr_d_fppop(d1, d2, rs)
# define jit_FPSEL_roundr_xd_i(use_fpu, rd, rs) jit_roundr_d_i(rd, rs)
# define jit_FPSEL_roundr_xd_l(use_fpu, rd, rs) jit_roundr_d_l(rd, rs)
# define jit_FPSEL_roundr_xd_l_fppop(use_fpu, rd, rs) jit_roundr_d_l_fppop(rd, rs)
# define jit_FPSEL_bger_xd(use_fpu, d, s1, s2) jit_bger_d(d, s1, s2)
# define jit_FPSEL_bltr_xd(use_fpu, d, s1, s2) jit_bltr_d(d, s1, s2)
# define jit_FPSEL_beqr_xd(use_fpu, d, s1, s2) jit_beqr_d(d, s1, s2)
# define jit_FPSEL_bantieqr_xd(use_fpu, d, s1, s2) jit_bantieqr_d(d, s1, s2)
# define jit_FPSEL_bger_xd_fppop(use_fpu, d, s1, s2) jit_bger_d_fppop(d, s1, s2)
# define jit_FPSEL_bantiger_xd_fppop(use_fpu, d, s1, s2) jit_bantiger_d_fppop(d, s1, s2)
# define jit_FPSEL_bler_xd_fppop(use_fpu, d, s1, s2) jit_bler_d_fppop(d, s1, s2)
# define jit_FPSEL_bantiler_xd_fppop(use_fpu, d, s1, s2) jit_bantiler_d_fppop(d, s1, s2)
# define jit_FPSEL_bgtr_xd_fppop(use_fpu, d, s1, s2) jit_bgtr_d_fppop(d, s1, s2)
# define jit_FPSEL_bantigtr_xd_fppop(use_fpu, d, s1, s2) jit_bantigtr_d_fppop(d, s1, s2)
# define jit_FPSEL_bltr_xd_fppop(use_fpu, d, s1, s2) jit_bltr_d_fppop(d, s1, s2)
# define jit_FPSEL_bantiltr_xd_fppop(use_fpu, d, s1, s2) jit_bantiltr_d_fppop(d, s1, s2)
# define jit_FPSEL_beqr_xd_fppop(use_fpu, d, s1, s2) jit_beqr_d_fppop(d, s1, s2)
# define jit_FPSEL_bantieqr_xd_fppop(use_fpu, d, s1, s2) jit_bantieqr_d_fppop(d, s1, s2)
#endif

338
src/racket/src/jitinline.c
View File

@ -551,7 +551,7 @@ static int inline_struct_alloc(mz_jit_state *jitter, int c, int inline_slow)
return scheme_inline_alloc(jitter,
sizeof(Scheme_Structure) + ((c - mzFLEX_DELTA) * sizeof(Scheme_Object*)),
scheme_structure_type,
0, 1, 0, inline_slow);
0, 1, 0, inline_slow, 0);
}
#endif
@ -1013,6 +1013,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "flonum?")) {
generate_inlined_type_test(jitter, app, scheme_double_type, scheme_double_type, 0, for_branch, branch_short, need_sync, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflonum?")) {
generate_inlined_type_test(jitter, app, scheme_long_double_type, scheme_long_double_type, 0, for_branch, branch_short, need_sync, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "single-flonum?")) {
generate_inlined_type_test(jitter, app, SCHEME_FLOAT_TYPE, SCHEME_FLOAT_TYPE, 0, for_branch, branch_short, need_sync, dest);
return 1;
@ -1348,9 +1351,12 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-length")
|| IS_NAMED_PRIM(rator, "flvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
|| IS_NAMED_PRIM(rator, "unsafe-flvector-length")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-extflvector-length"))) {
GC_CAN_IGNORE jit_insn *reffail, *ref;
int unsafe = 0, for_fl = 0, for_fx = 0, can_chaperone = 0;
int extfl = 0;
if (IS_NAMED_PRIM(rator, "unsafe-vector*-length")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-length")) {
@ -1365,6 +1371,12 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
for_fl = 1;
} else if (IS_NAMED_PRIM(rator, "fxvector-length")) {
for_fx = 1;
} else if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-length"))) {
extfl = 1;
unsafe = 1;
} else if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-length"))) {
extfl = 1;
unsafe = 1;
} else {
can_chaperone = 1;
}
@ -1386,9 +1398,11 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
if (for_fl)
(void)jit_calli(sjc.bad_flvector_length_code);
else if (for_fx)
if (for_fl) {
MZ_FPUSEL_STMT(extfl,
(void)jit_calli(sjc.bad_extflvector_length_code),
(void)jit_calli(sjc.bad_flvector_length_code));
} else if (for_fx)
(void)jit_calli(sjc.bad_fxvector_length_code);
else {
(void)jit_calli(sjc.bad_vector_length_code);
@ -1398,9 +1412,11 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
if (for_fl)
(void)mz_bnei_t(reffail, JIT_R0, scheme_flvector_type, JIT_R1);
else if (for_fx)
if (for_fl) {
MZ_FPUSEL_STMT(extfl,
(void)mz_bnei_t(reffail, JIT_R0, scheme_extflvector_type, JIT_R1),
(void)mz_bnei_t(reffail, JIT_R0, scheme_flvector_type, JIT_R1));
} else if (for_fx)
(void)mz_bnei_t(reffail, JIT_R0, scheme_fxvector_type, JIT_R1);
else
(void)mz_bnei_t(reffail, JIT_R0, scheme_vector_type, JIT_R1);
@ -1414,10 +1430,13 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
}
CHECK_LIMIT();
if (!for_fl)
if (for_fl) {
MZ_FPUSEL_STMT(extfl,
(void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_EXTFLVEC_SIZE(0x0)),
(void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_FLVEC_SIZE(0x0)));
} else
(void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0));
else
(void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_FLVEC_SIZE(0x0));
jit_fixnum_l(dest, JIT_R0);
return 1;
@ -1540,12 +1559,11 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|| IS_NAMED_PRIM(rator, "flreal-part")) {
GC_CAN_IGNORE jit_insn *reffail = NULL, *ref, *refdone;
const char *name = ((Scheme_Primitive_Proc *)rator)->name;
int unbox;
mz_jit_unbox_state ubs;
LOG_IT(("inlined %s\n", name));
unbox = jitter->unbox;
jitter->unbox = 0;
scheme_mz_unbox_save(jitter, &ubs);
mz_runstack_skipped(jitter, 1);
@ -1554,7 +1572,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_runstack_unskipped(jitter, 1);
jitter->unbox = unbox;
scheme_mz_unbox_restore(jitter, &ubs);
mz_rs_sync();
@ -1613,19 +1631,18 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "unsafe-flimag-part")
|| IS_NAMED_PRIM(rator, "unsafe-flreal-part")) {
const char *name = ((Scheme_Primitive_Proc *)rator)->name;
int unbox;
mz_jit_unbox_state ubs;
LOG_IT(("inlined %s\n", name));
mz_runstack_skipped(jitter, 1);
unbox = jitter->unbox;
jitter->unbox = 0;
scheme_mz_unbox_save(jitter, &ubs);
scheme_generate_non_tail(app->rand, jitter, 0, 1, 0);
CHECK_LIMIT();
jitter->unbox = unbox;
scheme_mz_unbox_restore(jitter, &ubs);
mz_runstack_unskipped(jitter, 1);
@ -1705,6 +1722,54 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|| IS_NAMED_PRIM(rator, "fl->fx")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
#ifdef MZ_LONG_DOUBLE
} else if (IS_NAMED_PRIM(rator, "unsafe-extflabs")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_ABS, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflabs")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_ABS, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extflsqrt")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_SQRT, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflsqrt")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_SQRT, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflfloor")
|| IS_NAMED_PRIM(rator, "extflceiling")
|| IS_NAMED_PRIM(rator, "extflround")
|| IS_NAMED_PRIM(rator, "extfltruncate")
|| IS_NAMED_PRIM(rator, "extflsin")
|| IS_NAMED_PRIM(rator, "extflcos")
|| IS_NAMED_PRIM(rator, "extfltan")
|| IS_NAMED_PRIM(rator, "extflasin")
|| IS_NAMED_PRIM(rator, "extflacos")
|| IS_NAMED_PRIM(rator, "extflatan")
|| IS_NAMED_PRIM(rator, "extflexp")
|| IS_NAMED_PRIM(rator, "extfllog")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_FLUNOP, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "real->extfl")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_EX_INEX, 0, 0, NULL, 1, 0, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fx->extfl")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_EX_INEX, 0, 0, NULL, 1, 1, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "->extfl")
|| IS_NAMED_PRIM(rator, "fx->extfl")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_EX_INEX, 0, 0, NULL, 1, -1, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl->exact")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 0, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl->fx")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl->exact-integer")
|| IS_NAMED_PRIM(rator, "extfl->fx")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand, NULL, 1, ARITH_INEX_EX, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
#endif
} else if (IS_NAMED_PRIM(rator, "bitwise-not")) {
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_NOT, 0, 9, NULL, 1, 0, 0, NULL, dest);
return 1;
@ -1744,7 +1809,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
#ifdef CAN_INLINE_ALLOC
/* Inlined alloc */
(void)jit_movi_p(JIT_R1, NULL); /* needed because R1 is marked during a GC */
scheme_inline_alloc(jitter, sizeof(Scheme_Small_Object), scheme_box_type, 0, 1, 0, 0);
scheme_inline_alloc(jitter, sizeof(Scheme_Small_Object), scheme_box_type, 0, 1, 0, 0, 0);
CHECK_LIMIT();
jit_stxi_p((intptr_t)&SCHEME_BOX_VAL(0x0) + OBJHEAD_SIZE, JIT_V1, JIT_R0);
@ -2024,7 +2089,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
}
static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset,
int for_fl, int unsafe,
int for_fl, int extfl, int unsafe,
int unbox_flonum, int result_ignored, int can_chaperone,
int for_struct, int for_fx, int check_mutable,
int known_fixnum_index, int known_fixnum_val,
@ -2060,9 +2125,9 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
else if (!for_fl)
(void)jit_calli(sjc.vector_set_check_index_code);
else if (unbox_flonum)
(void)jit_calli(sjc.flvector_set_flonum_check_index_code);
(void)jit_calli(sjc.flvector_set_flonum_check_index_code[extfl]);
else
(void)jit_calli(sjc.flvector_set_check_index_code);
(void)jit_calli(sjc.flvector_set_check_index_code[extfl]);
} else {
if (for_struct)
(void)jit_calli(sjc.struct_raw_ref_code);
@ -2071,7 +2136,7 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
else if (!for_fl)
(void)jit_calli(sjc.vector_ref_check_index_code);
else
(void)jit_calli(sjc.flvector_ref_check_index_code);
(void)jit_calli(sjc.flvector_ref_check_index_code[extfl]);
}
CHECK_LIMIT();
if (can_chaperone) {
@ -2102,8 +2167,12 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
}
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
} else {
(void)mz_bnei_t(reffail, JIT_R0, scheme_flvector_type, JIT_R2);
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0));
MZ_FPUSEL_STMT(extfl,
(void)mz_bnei_t(reffail, JIT_R0, scheme_extflvector_type, JIT_R2),
(void)mz_bnei_t(reffail, JIT_R0, scheme_flvector_type, JIT_R2));
MZ_FPUSEL_STMT(extfl,
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_EXTFLVEC_SIZE(0x0)),
jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0)));
}
if (!int_ready) {
jit_rshi_ul(JIT_V1, JIT_R1, 1);
@ -2116,7 +2185,9 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
if (for_fl && set && !unbox_flonum) {
jit_ldr_p(JIT_R2, JIT_RUNSTACK);
(void)jit_bmsi_ul(reffail, JIT_R2, 0x1);
(void)mz_bnei_t(reffail, JIT_R2, scheme_double_type, JIT_R2);
MZ_FPUSEL_STMT(extfl,
(void)mz_bnei_t(reffail, JIT_R2, scheme_long_double_type, JIT_R2),
(void)mz_bnei_t(reffail, JIT_R2, scheme_double_type, JIT_R2));
CHECK_LIMIT();
}
} else if (!int_ready) {
@ -2133,8 +2204,11 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
if (!int_ready) {
if (!for_fl)
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
else
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_DOUBLE_SIZE);
else {
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_V1, JIT_V1, sizeof(long double)),
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_DOUBLE_SIZE));
}
jit_addi_p(JIT_V1, JIT_V1, base_offset);
}
if (set) {
@ -2143,9 +2217,14 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
if (!for_fl) {
jit_stxr_p(JIT_V1, JIT_R0, JIT_R2);
} else {
if (!unbox_flonum)
jit_ldxi_d_fppush(JIT_FPR0, JIT_R2, &((Scheme_Double *)0x0)->double_val);
jit_stxr_d_fppop(JIT_V1, JIT_R0, JIT_FPR0);
if (!unbox_flonum) {
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxi_ld_fppush(JIT_FPU_FPR0, JIT_R2, &((Scheme_Long_Double *)0x0)->long_double_val),
jit_ldxi_d_fppush(JIT_FPR0, JIT_R2, &((Scheme_Double *)0x0)->double_val));
}
MZ_FPUSEL_STMT(extfl,
jit_fpu_stxr_ld_fppop(JIT_V1, JIT_R0, JIT_FPU_FPR0),
jit_stxr_d_fppop(JIT_V1, JIT_R0, JIT_FPR0));
if (unbox_flonum) {
--jitter->unbox_depth;
}
@ -2159,12 +2238,12 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
jit_ldxr_p(dest, JIT_R0, JIT_V1);
} else {
int fpr0;
fpr0 = JIT_FPR_0(jitter->unbox_depth);
jit_ldxr_d_fppush(fpr0, JIT_R0, JIT_V1);
fpr0 = JIT_FPUSEL_FPR_0(extfl, jitter->unbox_depth);
jit_FPSEL_ldxr_xd_fppush(extfl, fpr0, JIT_R0, JIT_V1);
if (unbox_flonum)
jitter->unbox_depth++;
else
scheme_generate_alloc_double(jitter, 0, dest);
scheme_generate_alloc_X_double(jitter, 0, dest, extfl);
}
if (can_chaperone)
mz_patch_ucbranch(pref);
@ -2177,7 +2256,7 @@ static int allocate_rectangular(mz_jit_state *jitter, int dest)
{
#ifdef CAN_INLINE_ALLOC
/* Inlined alloc */
scheme_inline_alloc(jitter, sizeof(Scheme_Complex), scheme_complex_type, 0, 1, 0, 0);
scheme_inline_alloc(jitter, sizeof(Scheme_Complex), scheme_complex_type, 0, 1, 0, 0, 0);
CHECK_LIMIT();
jit_stxi_p((intptr_t)&(((Scheme_Complex *)0x0)->r) + OBJHEAD_SIZE, JIT_V1, JIT_R0);
@ -2507,6 +2586,35 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "fl>")) {
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_GT, 0, for_branch, branch_short, 0, -1, NULL, dest);
return 1;
#ifdef MZ_LONG_DOUBLE
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl=")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_EQUAL, 0, for_branch, branch_short, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl<=")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_LEQ, 0, for_branch, branch_short, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl<=")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_LEQ, 0, for_branch, branch_short, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl<")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_LT, 0, for_branch, branch_short, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl<")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_LT, 0, for_branch, branch_short, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl>=")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_GEQ, 0, for_branch, branch_short, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl>=")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_GEQ, 0, for_branch, branch_short, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl>")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_GT, 0, for_branch, branch_short, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl>")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_GT, 0, for_branch, branch_short, 0, -1, NULL, dest);
return 1;
#endif
} else if (IS_NAMED_PRIM(rator, "bitwise-bit-set?")) {
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, CMP_BIT, 0, for_branch, branch_short, 0, 0, NULL, dest);
return 1;
@ -2670,6 +2778,47 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "flexpt")) {
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_EXPT, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
#ifdef MZ_LONG_DOUBLE
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl+")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl+")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl-")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl-")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl*")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl*")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extfl/")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_DIV, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extfl/")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_DIV, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extflmin")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MIN, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-extflmax")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MAX, 0, 0, NULL, 1, 0, 1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflmin")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MIN, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflmax")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MAX, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
} else if (IS_NAMED_PRIM(rator, "extflexpt")) {
scheme_generate_extflonum_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_EXPT, 0, 0, NULL, 1, 0, -1, NULL, dest);
return 1;
#endif
} else if (IS_NAMED_PRIM(rator, "vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-ref")
@ -2680,12 +2829,16 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|| IS_NAMED_PRIM(rator, "bytes-ref")
|| IS_NAMED_PRIM(rator, "unsafe-bytes-ref")
|| IS_NAMED_PRIM(rator, "flvector-ref")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-ref"))
|| IS_NAMED_PRIM(rator, "fxvector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-ref")) {
int simple;
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int unbox = jitter->unbox;
mz_jit_unbox_state ubs;
int can_chaperone = 1, for_struct = 0, for_fx = 0;
int extfl = 0;
scheme_mz_unbox_save(jitter, &ubs);
if (IS_NAMED_PRIM(rator, "vector-ref")) {
which = 0;
@ -2705,15 +2858,17 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
which = 0;
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "flvector-ref")) {
} else if (IS_NAMED_PRIM(rator, "flvector-ref")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-ref"))) {
which = 3;
base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
if (unbox) {
if (ubs.unbox) {
if (jitter->unbox_depth)
scheme_signal_error("internal error: bad depth for flvector-ref");
jitter->unbox = 0;
}
can_chaperone = 0;
if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-ref")))
extfl = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-struct*-ref")) {
which = 0;
unsafe = 1;
@ -2751,15 +2906,15 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which) {
/* vector-ref is relatively simple and worth inlining */
if (can_chaperone) scheme_mz_need_space(jitter, 3);
generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe,
generate_vector_op(jitter, 0, 0, base_offset, 0, 0, unsafe,
0, 0, can_chaperone, for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->rand2), 0,
dest);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct, for_fx, 0,
generate_vector_op(jitter, 0, 0, base_offset, 1, extfl, unsafe,
ubs.unbox, 0, can_chaperone, for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->rand2), 0,
dest);
CHECK_LIMIT();
@ -2807,22 +2962,22 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which)
offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 3)
offset = base_offset + (offset * sizeof(double));
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long double), sizeof(double)));
else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE;
jit_movi_l(JIT_V1, offset);
if (!which) {
/* vector-ref is relatively simple and worth inlining */
if (can_chaperone) scheme_mz_need_space(jitter, 3);
generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe,
generate_vector_op(jitter, 0, 1, base_offset, 0, 0, unsafe,
0, 0, can_chaperone, for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->rand2), 0,
dest);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct, for_fx, 0,
generate_vector_op(jitter, 0, 1, base_offset, 1, extfl, unsafe,
ubs.unbox, 0, can_chaperone, for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->rand2), 0,
dest);
CHECK_LIMIT();
@ -2853,19 +3008,23 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
mz_runstack_unskipped(jitter, 2);
}
if (unbox) jitter->unbox = unbox;
scheme_mz_unbox_restore(jitter, &ubs);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) {
int fpr0, unbox = jitter->unbox;
|| IS_NAMED_PRIM(rator, "unsafe-flvector-ref")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref"))) {
int fpr0;
int is_f64;
int extfl;
mz_jit_unbox_state ubs;
is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-ref");
jitter->unbox = 0; /* no unboxing of vector and index arguments */
extfl = MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref"));
scheme_mz_unbox_save(jitter, &ubs); /* no unboxing of vector and index arguments */
scheme_generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
jitter->unbox = unbox;
scheme_mz_unbox_restore(jitter, &ubs);
CHECK_LIMIT();
if (is_f64) {
@ -2873,24 +3032,30 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CPTR_VAL(0x0));
}
jit_rshi_ul(JIT_R1, JIT_R1, 1);
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE);
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long double)),
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE));
if (!is_f64) {
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0)));
MZ_FPUSEL_STMT(extfl,
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_EXTFLVEC_ELS(0x0))),
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0))));
}
if (jitter->unbox)
fpr0 = JIT_FPR_0(jitter->unbox_depth);
else
fpr0 = JIT_FPR0;
fpr0 = MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0);
jit_ldxr_d_fppush(fpr0, JIT_R0, JIT_R1);
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxr_ld_fppush(fpr0, JIT_R0, JIT_R1),
jit_ldxr_d_fppush(fpr0, JIT_R0, JIT_R1));
CHECK_LIMIT();
if (jitter->unbox)
jitter->unbox_depth++;
else {
mz_rs_sync();
scheme_generate_alloc_double(jitter, 0, dest);
scheme_generate_alloc_X_double(jitter, 0, dest, extfl);
}
return 1;
@ -3098,7 +3263,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
#ifdef CAN_INLINE_ALLOC
/* Inlined alloc */
scheme_inline_alloc(jitter, sizeof(Scheme_Simple_Object), scheme_mutable_pair_type, 0, 1, 0, 0);
scheme_inline_alloc(jitter, sizeof(Scheme_Simple_Object), scheme_mutable_pair_type, 0, 1, 0, 0, 0);
CHECK_LIMIT();
jit_stxi_p((intptr_t)&SCHEME_MCAR(0x0) + OBJHEAD_SIZE, JIT_V1, JIT_R0);
@ -3290,7 +3455,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
}
if (!for_branch) {
scheme_console_printf("Inlining expected.\n");
scheme_console_printf("Inlining expected for %s.\n", scheme_write_to_string(rator, NULL));
abort();
}
@ -3440,6 +3605,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
|| IS_NAMED_PRIM(rator, "unsafe-vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-set!")
|| IS_NAMED_PRIM(rator, "flvector-set!")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-set!"))
|| IS_NAMED_PRIM(rator, "fxvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct-set!")
@ -3454,6 +3620,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int pushed, flonum_arg;
int can_chaperone = 1, for_struct = 0, for_fx = 0, check_mutable = 0;
int extfl = 0;
if (IS_NAMED_PRIM(rator, "vector-set!")) {
which = 0;
@ -3480,6 +3647,10 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
} else if (IS_NAMED_PRIM(rator, "flvector-set!")) {
which = 3;
base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
} else if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-set!"))) {
extfl = 1;
which = 3;
base_offset = MZ_FPUSEL(extfl, ((int)&SCHEME_EXTFLVEC_ELS(0x0)), 0);
} else if (IS_NAMED_PRIM(rator, "unsafe-struct*-set!")) {
which = 0;
unsafe = 1;
@ -3529,9 +3700,9 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
constval = scheme_can_delay_and_avoids_r1(app->args[3]);
if (which == 3) {
if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0))
if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPUSEL_FPR_NUM(extfl)-3, 0, extfl))
flonum_arg = 2;
else if (scheme_can_unbox_directly(app->args[3]))
else if (scheme_can_unbox_directly(app->args[3], extfl))
flonum_arg = 1;
else
flonum_arg = 0;
@ -3593,8 +3764,10 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (flonum_arg) {
jitter->unbox++;
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++);
scheme_generate_unboxed(app->args[3], jitter, flonum_arg, 0);
--jitter->unbox;
MZ_FPUSEL_STMT_ONLY(extfl, --jitter->unbox_extflonum);
} else {
if (constval)
scheme_generate(app->args[3], jitter, 0, 0, 0, JIT_R2, NULL); /* sync'd below */
@ -3639,7 +3812,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
if (can_chaperone) scheme_mz_need_space(jitter, 3);
generate_vector_op(jitter, 1, 0, base_offset, 0, unsafe,
generate_vector_op(jitter, 1, 0, base_offset, 0, 0, unsafe,
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx, check_mutable,
scheme_jit_is_fixnum(app->args[2]), for_fx > 1,
@ -3647,7 +3820,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0, base_offset, 1, unsafe,
generate_vector_op(jitter, 1, 0, base_offset, 1, extfl, unsafe,
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->args[2]), for_fx > 1,
@ -3703,7 +3876,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which)
offset = base_offset + WORDS_TO_BYTES(offset);
else if (which == 3)
offset = base_offset + (offset * sizeof(double));
offset = base_offset + (offset * MZ_FPUSEL(extfl, sizeof(long double), sizeof(double)));
else if (which == 1)
offset = offset << LOG_MZCHAR_SIZE;
else if ((which == 4) || (which == 5))
@ -3712,7 +3885,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
if (can_chaperone) scheme_mz_need_space(jitter, 3);
generate_vector_op(jitter, 1, 1, base_offset, 0, unsafe,
generate_vector_op(jitter, 1, 1, base_offset, 0, 0, unsafe,
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx, check_mutable,
scheme_jit_is_fixnum(app->args[2]), for_fx > 1,
@ -3732,7 +3905,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
(void)jit_movi_p(dest, scheme_void);
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1, base_offset, 1, unsafe,
generate_vector_op(jitter, 1, 1, base_offset, 1, extfl, unsafe,
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx, 0,
scheme_jit_is_fixnum(app->args[2]), for_fx > 1,
@ -3776,12 +3949,15 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) {
|| IS_NAMED_PRIM(rator, "unsafe-flvector-set!")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-set!"))) {
int is_f64;
int can_direct, got_two;
int extfl;
is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-set!");
extfl = MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-set!"));
if (scheme_is_constant_and_avoids_r1(app->args[1])
&& scheme_is_constant_and_avoids_r1(app->args[2])) {
mz_runstack_skipped(jitter, 3);
@ -3792,16 +3968,18 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
scheme_generate_app(app, NULL, 2, jitter, 0, 0, 0, 2);
}
if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-1, 1))
if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPUSEL_FPR_NUM(extfl)-1, 1, extfl))
can_direct = 2;
else if (scheme_can_unbox_directly(app->args[3]))
else if (scheme_can_unbox_directly(app->args[3], extfl))
can_direct = 1;
else
can_direct = 0;
jitter->unbox++;
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++);
scheme_generate_unboxed(app->args[3], jitter, can_direct, 1);
--jitter->unbox;
MZ_FPUSEL_STMT_ONLY(extfl, --jitter->unbox_extflonum);
--jitter->unbox_depth;
CHECK_LIMIT();
@ -3824,11 +4002,17 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
jit_ldxi_p(JIT_R0, JIT_R0, (intptr_t)&SCHEME_CPTR_VAL(0x0));
}
jit_rshi_ul(JIT_R1, JIT_R1, 1);
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE);
MZ_FPUSEL_STMT(extfl,
jit_muli_ui(JIT_R1, JIT_R1, sizeof(long double)),
jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE));
if (!is_f64) {
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0)));
MZ_FPUSEL_STMT(extfl,
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_EXTFLVEC_ELS(0x0))),
jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0))));
}
jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0);
MZ_FPUSEL_STMT(extfl,
jit_fpu_stxr_ld_fppop(JIT_R1, JIT_R0, JIT_FPU_FPR0),
jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0));
CHECK_LIMIT();
if (!result_ignored)
@ -3960,7 +4144,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
}
if (!for_branch) {
scheme_console_printf("Inlining expected.\n");
scheme_console_printf("Inlining expected %s.\n", scheme_write_to_string(rator, NULL));
abort();
}
@ -3975,7 +4159,7 @@ int scheme_generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry,
#ifdef CAN_INLINE_ALLOC
/* Inlined alloc */
scheme_inline_alloc(jitter, sizeof(Scheme_Simple_Object), scheme_pair_type, 0, 1,
known_list ? PAIR_IS_LIST : 0, inline_retry);
known_list ? PAIR_IS_LIST : 0, inline_retry, 0);
CHECK_LIMIT();
if (rev) {
@ -4041,7 +4225,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
scheme_inline_alloc(jitter,
sizeof(Scheme_Vector) + ((c - mzFLEX_DELTA) * sizeof(Scheme_Object*)),
scheme_vector_type,
imm, app2 || app3, 0, 0);
imm, app2 || app3, 0, 0, 0);
CHECK_LIMIT();
if ((c == 2) || (c == 1)) {

44
src/racket/src/jitstate.c
View File

@ -106,6 +106,20 @@ double *scheme_mz_retain_double(mz_jit_state *jitter, double d)
}
#endif
#ifdef MZ_LONG_DOUBLE
long double *scheme_mz_retain_long_double(mz_jit_state *jitter, long double ld)
{
/* Save a long double into two cells of double */
void *p;
if (jitter->retain_start)
memcpy(&jitter->retain_double_start[jitter->retained_double], &ld, sizeof(long double));
p = jitter->retain_double_start + jitter->retained_double;
jitter->retained_double++;
jitter->retained_double++;
return p;
}
#endif
#ifdef SET_DEFAULT_LONG_JUMPS
static int check_long_mode(uintptr_t low, uintptr_t size)
{
@ -348,6 +362,8 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
/* That was big enough: */
if (jitter->unbox || jitter->unbox_depth)
scheme_signal_error("internal error: ended with unbox or depth");
if (MZ_LONG_DOUBLE_AND(jitter->unbox_extflonum))
scheme_signal_error("internal error: ended with unbox_extflonum");
if (known_size) {
/* That was in the permanent area, so return: */
jit_flush_code(buffer, jit_get_ip().ptr);
@ -355,22 +371,19 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
} else {
/* Allocate permanent area and jit again: */
known_size = ((uintptr_t)jit_get_ip().ptr) - (uintptr_t)buffer;
/* Make sure room for pointers is aligned: */
if (known_size & (JIT_WORD_SIZE - 1)) {
known_size += (JIT_WORD_SIZE - (known_size & (JIT_WORD_SIZE - 1)));
}
if (jitter->retained_double) {
/* even stronger: `double'-aligned: */
if (known_size & (JIT_DOUBLE_SIZE - 1)) {
known_size += (JIT_DOUBLE_SIZE - (known_size & (JIT_DOUBLE_SIZE - 1)));
}
}
}
num_retained = jitter->retained;
if (num_retained == 1) num_retained = 0;
num_retained_double = jitter->retained_double;
if (num_retained_double) {
if (known_size & (sizeof(double) - 1)) {
known_size += (sizeof(double) - (known_size & (sizeof(double) - 1)));
}
}
/* Keep this buffer? Don't if it's too big, or if it's
a part of old_jitter, or if there's already a bigger
cache. */
@ -776,4 +789,23 @@ int scheme_stack_safety(mz_jit_state *jitter, int cnt, int offset)
return 1;
}
void scheme_mz_unbox_save(mz_jit_state *jitter, mz_jit_unbox_state *r)
{
r->unbox = jitter->unbox;
jitter->unbox = 0;
#ifdef MZ_LONG_DOUBLE
r->unbox_extflonum = jitter->unbox_extflonum;
jitter->unbox_extflonum = 0;
#endif
}
void scheme_mz_unbox_restore(mz_jit_state *jitter, mz_jit_unbox_state *r)
{
jitter->unbox = r->unbox;
#ifdef MZ_LONG_DOUBLE
jitter->unbox_extflonum = r->unbox_extflonum;
#endif
}
#endif

5
src/racket/src/lightning/i386/asm.h
View File

@ -1164,8 +1164,11 @@ typedef _uc jit_insn;
#define XORQir(IM, RD) _qOs_Mrm_sL (0x81 ,_b11,_b110 ,_r8(RD) ,IM )
/* x87 instructions -- yay, we found a use for octal constants :-) */
#ifdef JIT_X86_64
#define ESCmi(D,B,I,S,OP) _qOd_r_X(0xd8|(OP >> 3), (OP & 7), D,B,I,S)
#else
#define ESCmi(D,B,I,S,OP) _O_r_X(0xd8|(OP >> 3), (OP & 7), D,B,I,S)
#endif
#define ESCri(RD,OP) _O_Mrm(0xd8|(OP >> 3), _b11, (OP & 7), RD)
#define ESCrri(RS,RD,OP) ((RS) == _ST0 ? ESCri(RD,(OP|040)) \

546
src/racket/src/lightning/i386/fp-extfpu.h Normal file
View File

@ -0,0 +1,546 @@
#ifndef FP_EXTFPU_H
#define FP_EXTFPU_H
/* We really must map the x87 stack onto a flat register file. In practice,
we can provide something sensible and make it work on the x86 using the
stack like a file of eight registers.
We use six or seven registers so as to have some freedom
for floor, ceil, round, (and log, tan, atn and exp).
Not hard at all, basically play with FXCH. FXCH is mostly free,
so the generated code is not bad. Of course we special case when one
of the operands turns out to be ST0.
Here are the macros that actually do the trick. */
#define JIT_FPU_FPR_NUM 6
#define JIT_FPU_FPR(i) (i)
#define JIT_FPU_FPR0 JIT_FPU_FPR(0)
#define JIT_FPU_FPR1 JIT_FPU_FPR(1)
#define JIT_FPU_FPR2 JIT_FPU_FPR(2)
#define JIT_FPU_FPR3 JIT_FPU_FPR(3)
#define JIT_FPU_FPR4 JIT_FPU_FPR(4)
#define JIT_FPU_FPR5 JIT_FPU_FPR(5)
#define jit_fpu_fxch(rs, op) (((rs) != 0 ? FXCHr(rs) : (void)0), \
op, ((rs) != 0 ? FXCHr(rs) : (void)0))
#define jit_fpu_fp_unary(rd, s1, op) \
((rd) == (s1) ? jit_fpu_fxch ((rd), op) \
: (rd) == 0 ? (FSTPr (0), FLDr ((s1)-1), op) \
: (FLDr ((s1)), op, FSTPr ((rd))))
#define jit_fpu_fp_binary(rd, s1, s2, op, opr) \
((rd) == (s1) ? \
((s2) == 0 ? opr(0, (rd)) \
: (s2) == (s1) ? jit_fpu_fxch((rd), op(0, 0)) \
: jit_fpu_fxch((rd), op((s2), 0))) \
: (rd) == (s2) ? ((s1) == 0 ? op((s1), (s2)) : jit_fpu_fxch((s2), opr((s1), 0))) \
: (FLDr (s1), op(0, (s2)+1), FSTPr((rd)+1)))
#define jit_fpu_addr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FADDrr,FADDrr)
#define jit_fpu_subr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FSUBrr,FSUBRrr)
#define jit_fpu_subrr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FSUBRrr,FSUBrr)
#define jit_fpu_mulr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FMULrr,FMULrr)
#define jit_fpu_divr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FDIVrr,FDIVRrr)
#define jit_fpu_divrr_d(rd,s1,s2) jit_fpu_fp_binary((rd),(s1),(s2),FDIVRrr,FDIVrr)
#define jit_fpu_abs_d(rd,rs) jit_fpu_fp_unary ((rd), (rs), _OO (0xd9e1))
#define jit_fpu_negr_d(rd,rs) jit_fpu_fp_unary ((rd), (rs), _OO (0xd9e0))
#define jit_fpu_sqrt_d(rd,rs) jit_fpu_fp_unary ((rd), (rs), _OO (0xd9fa))
#define jit_fpu_addr_d_fppop(rd,s1,s2) (FADDPr(1))
#define jit_fpu_subr_d_fppop(rd,s1,s2) (FSUBPr(1))
#define jit_fpu_subrr_d_fppop(rd,s1,s2) (FSUBRPr(1))
#define jit_fpu_mulr_d_fppop(rd,s1,s2) (FMULPr(1))
#define jit_fpu_divr_d_fppop(rd,s1,s2) (FDIVPr(1))
#define jit_fpu_divrr_d_fppop(rd,s1,s2) (FDIVRPr(1))
#define jit_fpu_negr_d_fppop(rd,rs) ( _OO (0xd9e0))
#define jit_fpu_abs_d_fppop(rd,rs) ( _OO (0xd9e1))
#define jit_fpu_sqrt_d_fppop(rd,rs) ( _OO (0xd9fa))
/* Except for memory loads and stores, _ld typed operations
are implemented the same as _d typed operations. Set the
FPU's precision to actually get one or the other. */
#define jit_fpu_addr_ld(rd,s1,s2) jit_fpu_addr_d(rd,s1,s2)
#define jit_fpu_subr_ld(rd,s1,s2) jit_fpu_subr_d(rd,s1,s2)
#define jit_fpu_subrr_ld(rd,s1,s2) jit_fpu_subrr_d(rd,s1,s2)
#define jit_fpu_mulr_ld(rd,s1,s2) jit_fpu_mulr_d(rd,s1,s2)
#define jit_fpu_ldivr_ld(rd,s1,s2) jit_fpu_ldivr_d(rd,s1,s2)
#define jit_fpu_ldivrr_ld(rd,s1,s2) jit_fpu_ldivrr_d(rd,s1,s2)
#define jit_fpu_abs_ld(rd,rs) jit_fpu_abs_d(rd,rs)
#define jit_fpu_negr_ld(rd,rs) jit_fpu_negr_d(rd,rs)
#define jit_fpu_sqrt_ld(rd,rs) jit_fpu_sqrt_d(rd,rs)
#define jit_fpu_addr_ld_fppop(rd,s1,s2) jit_fpu_addr_d_fppop(rd,s1,s2)
#define jit_fpu_subr_ld_fppop(rd,s1,s2) jit_fpu_subr_d_fppop(rd,s1,s2)
#define jit_fpu_subrr_ld_fppop(rd,s1,s2) jit_fpu_subrr_d_fppop(rd,s1,s2)
#define jit_fpu_mulr_ld_fppop(rd,s1,s2) jit_fpu_mulr_d_fppop(rd,s1,s2)
#define jit_fpu_divr_ld_fppop(rd,s1,s2) jit_fpu_divr_d_fppop(rd,s1,s2)
#define jit_fpu_divrr_ld_fppop(rd,s1,s2) jit_fpu_divrr_d_fppop(rd,s1,s2)
#define jit_fpu_negr_ld_fppop(rd,rs) jit_fpu_negr_d_fppop(rd,rs)
#define jit_fpu_abs_ld_fppop(rd,rs) jit_fpu_abs_d_fppop(rd,rs)
#define jit_fpu_sqrt_ld_fppop(rd,rs) jit_fpu_sqrt_d_fppop(rd,rs)
/* - moves:
move FPR0 to FPR3
FST ST3
move FPR3 to FPR0
FXCH ST3
FST ST3
move FPR3 to FPR1
FLD ST1
FST ST4 Stack is rotated, so FPRn becomes STn+1 */
#define jit_fpu_movr_d(rd,s1) \
((s1) == (rd) ? 0 \
: (rd) == 0 ? (FSTPr(0), FSTr (((s1)-1))) \
: (FLDr ((s1)), FSTPr ((rd)+1)))
#define jit_fpu_movr_d_rel(rd,s1) ((rd < s1) ? (FSTPr(0), FLDr(0)) : (FSTr(1)))
#define jit_fpu_movr_d_fppush(rd,s1) (FLDr(s1))
#define jit_fpu_movr_ld(rd,s1) jit_fpu_movr_d(rd,s1)
#define jit_fpu_movr_ld_rel(rd,s1) jit_fpu_movr_d_rel(rd,s1)
#define jit_fpu_movr_ld_fppush(rd,s1) jit_fpu_movr_d_fppush(rd,s1)
/* - loads:
load into FPR0
FSTP ST0
FLD [FUBAR]
load into FPR3
FSTP ST3 Save old st0 into destination register
FLD [FUBAR]
FXCH ST3 Get back old st0
(and similarly for immediates, using the stack) */
#define jit_fpu_movi_f(rd,immf) \
(_O (0x68), \
*((float *) _jit.x.pc) = (float) immf, \
_jit.x.uc_pc += sizeof (float), \
jit_fpu_ldr_f((rd), _ESP), \
ADDQir(4, _ESP))
union jit_fpu_double_imm {
double d;
int i[2];
};
#ifdef JIT_X86_64
# define jit_fpu_double_as_long(v) (*(double *)(_jit.x.uc_pc) = v, *(intptr_t *)(_jit.x.uc_pc))
# define _jit_fpu_push_d(immd) \
(MOVQir(jit_fpu_double_as_long(immd), JIT_REXTMP), \
PUSHQr(JIT_REXTMP))
# define FPX() (void)0 /* don't need _REX(0,0,0), apparently */
#else
# define _jit_fpu_push_d(immd) \
(_O (0x68), \
_jit.x.uc_pc[4] = 0x68, \
((union jit_fpu_double_imm *) (_jit.x.uc_pc + 5))->d = (double) immd, \
*((int *) _jit.x.uc_pc) = ((union jit_fpu_double_imm *) (_jit.x.uc_pc + 5))->i[1], \
_jit.x.uc_pc += 9)
# define FPX() ((void) 0)
#endif
#define jit_fpu_movi_d(rd,immd) \
(_jit_fpu_push_d(immd), \
jit_fpu_ldr_d((rd), _ESP), \
ADDQir(8, _ESP))
#ifdef JIT_X86_64
#define jit_fpu_ldi_d_fppush(rd, is) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_ldr_d_fppush(rd, JIT_R0), \
MOVQrr(JIT_REXTMP, JIT_R0))
#else
#define jit_fpu_ldi_f(rd, is) \
((rd) == 0 ? (FSTPr (0), FLDSm((is), 0, 0, 0)) \
: (FLDSm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldi_d(rd, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm((is), 0, 0, 0)) \
: (FPX(), FLDLm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldi_d_fppush(rd, is) (FPX(), FLDLm((is), 0, 0, 0))
#define jit_fpu_ldi_ld(rd, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm((is), 0, 0, 0)) \
: (FPX(), FLDTm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldi_ld_fppush(rd, is) (FPX(), FLDTm((is), 0, 0, 0))
#endif
#define jit_fpu_ldr_f(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm(0, (rs), 0, 0)) \
: (FPX(), FLDSm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldr_d(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (rs), 0, 0)) \
: (FPX(), FLDLm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldr_d_fppush(rd, rs) (FPX(), FLDLm(0, (rs), 0, 0))
#define jit_fpu_ldr_ld(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm(0, (rs), 0, 0)) \
: (FPX(), FLDTm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldr_ld_fppush(rd, rs) (FPX(), FLDTm(0, (rs), 0, 0))
#define jit_fpu_ldxi_f(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm((is), (rs), 0, 0)) \
: (FPX(), FLDSm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldxi_d(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm((is), (rs), 0, 0)) \
: (FPX(), FLDLm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldxi_d_fppush(rd, rs, is) (FPX(), FLDLm((is), (rs), 0, 0))
#define jit_fpu_ldxi_ld(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm((is), (rs), 0, 0)) \
: (FPX(), FLDTm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_fpu_ldxi_ld_fppush(rd, rs, is) (FPX(), FLDTm((is), (rs), 0, 0))
#define jit_fpu_ldxr_f(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm(0, (s1), (s2), 1)) \
: (FPX(), FLDSm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_fpu_ldxr_d(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (s1), (s2), 1)) \
: (FPX(), FLDLm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_fpu_ldxr_d_fppush(rd, s1, s2) (FPX(), FLDLm(0, (s1), (s2), 1))
#define jit_fpu_ldxr_ld(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDTm(0, (s1), (s2), 1)) \
: (FPX(), FLDTm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_fpu_ldxr_ld_fppush(rd, s1, s2) (FPX(), FLDTm(0, (s1), (s2), 1))
#define jit_fpu_extr_i_d(rd, rs) (PUSHLr((rs)), \
((rd) == 0 ? (FSTPr (0), FILDLm(0, _ESP, 0, 0)) \
: (FILDLm(0, _ESP, 0, 0), FSTPr ((rd) + 1))), \
POPLr((rs)))
#define jit_fpu_extr_i_d_fppush(rd, rs) \
(PUSHLr((rs)), FILDLm(0, _ESP, 0, 0), POPLr((rs)))
#define jit_fpu_extr_i_ld_fppush(rd, rs) \
(PUSHLr((rs)), FILDLm(0, _ESP, 0, 0), POPLr((rs)))
#ifdef JIT_X86_64
# define jit_fpu_extr_l_d_fppush(rd, rs) \
(PUSHQr((rs)), FILDQm(0, _ESP, 0, 0), POPQr((rs)))
# define jit_fpu_extr_l_ld_fppush(rd, rs) \
(PUSHQr((rs)), FILDQm(0, _ESP, 0, 0), POPQr((rs)))
#else
# define jit_fpu_extr_l_d_fppush(rd, rs) jit_fpu_extr_i_d_fppush(rd, rs)
# define jit_fpu_extr_l_ld_fppush(rd, rs) jit_fpu_extr_i_ld_fppush(rd, rs)
#endif
#define jit_fpu_stxi_f(id, rd, rs) jit_fpu_fxch ((rs), FPX(), FSTSm((id), (rd), 0, 0))
#define jit_fpu_stxr_f(d1, d2, rs) jit_fpu_fxch ((rs), FPX(), FSTSm(0, (d1), (d2), 1))
#define jit_fpu_stxi_d(id, rd, rs) jit_fpu_fxch ((rs), FPX(), FSTLm((id), (rd), 0, 0))
#define jit_fpu_stxr_d(d1, d2, rs) jit_fpu_fxch ((rs), FPX(), FSTLm(0, (d1), (d2), 1))
#ifdef JIT_X86_64
#define jit_fpu_sti_d_fppop(is, rd) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_str_d_fppop(JIT_R0, rd), \
MOVQrr(JIT_REXTMP, JIT_R0))
#else
#define jit_fpu_sti_f(id, rs) jit_fpu_fxch ((rs), FPX(), FSTSm((id), 0, 0, 0))
#define jit_fpu_str_f(rd, rs) jit_fpu_fxch ((rs), FPX(), FSTSm(0, (rd), 0, 0))
#define jit_fpu_sti_d(id, rs) jit_fpu_fxch ((rs), FPX(), FSTLm((id), 0, 0, 0))
#define jit_fpu_str_d(rd, rs) jit_fpu_fxch ((rs), FPX(), FSTLm(0, (rd), 0, 0))
#define jit_fpu_sti_d_fppop(id, rs) (FPX(), FSTPLm((id), 0, 0, 0))
#define jit_fpu_sti_ld_fppop(id, rs) (FPX(), FSTPTm((id), 0, 0, 0))
#endif
#define jit_fpu_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0))
#define jit_fpu_str_d_fppop(rd, rs) (FPX(), FSTPLm(0, (rd), 0, 0))
#define jit_fpu_stxr_d_fppop(d1, d2, rs) (FPX(), FSTPLm(0, (d1), (d2), 1))
#define jit_fpu_stxi_ld_fppop(id, rd, rs) (FPX(), FSTPTm((id), (rd), 0, 0))
#define jit_fpu_str_ld_fppop(rd, rs) (FPX(), FSTPTm(0, (rd), 0, 0))
#define jit_fpu_stxr_ld_fppop(d1, d2, rs) (FPX(), FSTPTm(0, (d1), (d2), 1))
/* Assume round to near mode */
#define jit_fpu_floorr_d_i(rd, rs) \
(FLDr (rs), jit_fpu_floor2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_fpu_ceilr_d_i(rd, rs) \
(FLDr (rs), jit_fpu_ceil2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_fpu_truncr_d_i(rd, rs) \
(FLDr (rs), jit_fpu_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_fpu_calc_diff(ofs) \
FISTLm(ofs, _ESP, 0, 0), \
FILDLm(ofs, _ESP, 0, 0), \
FSUBRPr(1), \
FSTPSm(4+ofs, _ESP, 0, 0) \
/* The real meat */
#define jit_fpu_floor2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_fpu_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
ADDLir(0x7FFFFFFF, aux), /* carry if x-round(x) < -0 */ \
SBBLir(0, rd), /* subtract 1 if carry */ \
POPLr(aux))
#define jit_fpu_ceil2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_fpu_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
TESTLrr(aux, aux), \
SETGr(jit_reg8(aux)), \
SHRLir(1, aux), \
ADCLir(0, rd), \
POPLr(aux))
/* a mingling of the two above */
#define jit_fpu_trunc2(rd, aux) \
(PUSHLr(aux), \
SUBLir(12, _ESP), \
FSTSm(0, _ESP, 0, 0), \
jit_fpu_calc_diff(4), \
POPLr(aux), \
POPLr(rd), \
TESTLrr(aux, aux), \
POPLr(aux), \
JSSm(_jit.x.pc + 11, 0, 0, 0), \
ADDLir(0x7FFFFFFF, aux), /* 6 */ \
SBBLir(0, rd), /* 3 */ \
JMPSm(_jit.x.pc + 10, 0, 0, 0), /* 2 */ \
TESTLrr(aux, aux), /* 2 */ \
SETGr(jit_reg8(aux)), /* 3 */ \
SHRLir(1, aux), /* 2 */ \
ADCLir(0, rd), /* 3 */ \
POPLr(aux))
/* the easy one */
#define jit_fpu_roundr_d_i(rd, rs) \
(PUSHLr(_EAX), \
jit_fpu_fxch ((rs), FISTPLm(0, _ESP, 0, 0)), \
POPLr((rd)))
#define jit_fpu_roundr_ld_i(rd, rs) jit_fpu_roundr_d_i(rd, rs)
#define jit_fpu_roundr_d_l(rd, rs) \
(PUSHQr(_EAX), \
jit_fpu_fxch ((rs), FISTPQm(0, _ESP, 0, 0)), \
POPQr((rd)))
#define jit_fpu_roundr_ld_l(rd, rs) jit_fpu_roundr_d_l(rd, rs)
#define jit_fpu_roundr_d_l_fppop(rd, rs) \
(PUSHQr(_EAX), \
FISTPQm(0, _ESP, 0, 0), \
POPQr((rd)))
#define jit_fpu_roundr_ld_l_fppop(rd, rs) jit_fpu_roundr_d_l_fppop(rd, rs)
#define jit_fpu_fp_test(d, s1, s2, n, _and, res) \
(((s1) == 0 ? FUCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
((d) != _EAX ? MOVLrr(_EAX, (d)) : 0), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir((_and), _EAX) : MOVLir(0, _EAX)), \
res, \
((d) != _EAX ? _O (0x90 + ((d) & 7)) : 0)) /* xchg */
#define jit_fpu_fp_btest(d, s1, s2, n, _and, cmp, res) \
(((s1) == 0 ? FCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fpu_fp_test_fppop(d, n, _and, res) \
(FUCOMPPr(1), \
((d) != _EAX ? MOVLrr(_EAX, (d)) : 0), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir((_and), _EAX) : MOVLir(0, _EAX)), \
res, \
((d) != _EAX ? _O (0x90 + ((d) & 7)) : 0)) /* xchg */
#define jit_fpu_fp_btest_fppop(d, n, _and, cmp, res) \
(FUCOMPPr(1), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
(void)((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fpu_fp_btest_fppop(d, n, _and, cmp, res) \
(FUCOMPPr(1), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
(void)((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fpu_fp_btest_fppop_2(d, res) \
(FUCOMIPr(1), FSTPr(0), res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fpu_nothing_needed(x)
/* After FNSTSW we have 1 if <, 40 if =, 0 if >, 45 if unordered. Here
is how to map the values of the status word's high byte to the
conditions.
< = > unord valid values condition
gt no no yes no 0 STSW & 45 == 0
lt yes no no no 1 STSW & 45 == 1
eq no yes no no 40 STSW & 45 == 40
unord no no no yes 45 bit 2 == 1
ge no yes no no 0, 40 bit 0 == 0
unlt yes no no yes 1, 45 bit 0 == 1
ltgt yes no yes no 0, 1 bit 6 == 0
uneq no yes no yes 40, 45 bit 6 == 1
le yes yes no no 1, 40 odd parity for STSW & 41
ungt no no yes yes 0, 45 even parity for STSW & 41
unle yes yes no yes 1, 40, 45 STSW & 45 != 0
unge no yes yes yes 0, 40, 45 STSW & 45 != 1
ne yes no yes yes 0, 1, 45 STSW & 45 != 40
ord yes yes yes no 0, 1, 40 bit 2 == 0
lt, le, ungt, unge are actually computed as gt, ge, unlt, unle with
the operands swapped; it is more efficient this way. */
#define jit_fpu_gtr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 8, 0x45, SETZr (_AL))
#define jit_fpu_ger_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 9, 0, SBBBir (-1, _AL))
#define jit_fpu_unler_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 8, 0x45, SETNZr (_AL))
#define jit_fpu_unltr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 9, 0, ADCBir (0, _AL))
#define jit_fpu_ltr_d(d, s1, s2) jit_fpu_fp_test((d), (s2), (s1), 8, 0x45, SETZr (_AL))
#define jit_fpu_ler_d(d, s1, s2) jit_fpu_fp_test((d), (s2), (s1), 9, 0, SBBBir (-1, _AL))
#define jit_fpu_unger_d(d, s1, s2) jit_fpu_fp_test((d), (s2), (s1), 8, 0x45, SETNZr (_AL))
#define jit_fpu_ungtr_d(d, s1, s2) jit_fpu_fp_test((d), (s2), (s1), 9, 0, ADCBir (0, _AL))
#define jit_fpu_eqr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETEr (_AL)))
#define jit_fpu_ner_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETNEr (_AL)))
#define jit_fpu_ltgtr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 15, 0, SBBBir (-1, _AL))
#define jit_fpu_uneqr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 15, 0, ADCBir (0, _AL))
#define jit_fpu_ordr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 11, 0, SBBBir (-1, _AL))
#define jit_fpu_unordr_d(d, s1, s2) jit_fpu_fp_test((d), (s1), (s2), 11, 0, ADCBir (0, _AL))
#define jit_fpu_bgtr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0, JZm)
#define jit_fpu_bger_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 9, 0, 0, JNCm)
#define jit_fpu_bger_ld(d, s1, s2) jit_fpu_bger_d(d, s1, s2)
#define jit_fpu_bantigtr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0, JNZm)
#define jit_fpu_bantiger_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 9, 0, 0, JCm)
#define jit_fpu_bunler_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0, JNZm)
#define jit_fpu_bunltr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 9, 0, 0, JCm)
#define jit_fpu_bltr_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 8, 0x45, 0, JZm)
#define jit_fpu_bltr_ld(d, s1, s2) jit_fpu_bltr_d(d, s1, s2)
#define jit_fpu_bler_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 9, 0, 0, JNCm)
#define jit_fpu_bantiltr_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 8, 0x45, 0, JNZm)
#define jit_fpu_bantiler_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 9, 0, 0, JCm)
#define jit_fpu_bunger_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 8, 0x45, 0, JNZm)
#define jit_fpu_bungtr_d(d, s1, s2) jit_fpu_fp_btest((d), (s2), (s1), 9, 0, 0, JCm)
#define jit_fpu_beqr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JZm)
#define jit_fpu_beqr_ld(d, s1, s2) jit_fpu_beqr_d(d, s1, s2)
#define jit_fpu_bantieqr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JNZm)
#define jit_fpu_bantieqr_ld(d, s1, s2) jit_fpu_bantieqr_d(d, s1, s2)
#define jit_fpu_bner_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JNZm)
#define jit_fpu_bltgtr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 15, 0, 0, JNCm)
#define jit_fpu_buneqr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 15, 0, 0, JCm)
#define jit_fpu_bordr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 11, 0, 0, JNCm)
#define jit_fpu_bunordr_d(d, s1, s2) jit_fpu_fp_btest((d), (s1), (s2), 11, 0, 0, JCm)
#define jit_fpu_bger_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 9, 0, 0, JNCm)
#define jit_fpu_bger_ld_fppop(d, s1, s2) jit_fpu_bger_d_fppop(d, s1, s2)
/* #define jit_fpu_bantiger_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 9, 0, 0, JCm) */
#define jit_fpu_bantiger_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop_2((d), JBm)
#define jit_fpu_bantiger_ld_fppop(d, s1, s2) jit_fpu_bantiger_d_fppop(d, s1, s2)
#define jit_fpu_bler_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bger_d_fppop(d, s1, s2))
#define jit_fpu_bler_ld_fppop(d, s1, s2) jit_fpu_bler_d_fppop(d, s1, s2)
#define jit_fpu_bantiler_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bantiger_d_fppop(d, s1, s2))
#define jit_fpu_bantiler_ld_fppop(d, s1, s2) jit_fpu_bantiler_d_fppop(d, s1, s2)
#define jit_fpu_bgtr_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 8, 0x45, 0, JZm)
#define jit_fpu_bgtr_ld_fppop(d, s1, s2) jit_fpu_bgtr_d_fppop(d, s1, s2)
/* #define jit_fpu_bantigtr_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 8, 0x45, 0, JNZm) */
#define jit_fpu_bantigtr_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop_2((d), JBEm)
#define jit_fpu_bantigtr_ld_fppop(d, s1, s2) jit_fpu_bantigtr_d_fppop(d, s1, s2)
#define jit_fpu_bltr_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bgtr_d_fppop(d, s1, s2))
#define jit_fpu_bltr_ld_fppop(d, s1, s2) jit_fpu_bltr_d_fppop(d, s1, s2)
#define jit_fpu_bantiltr_d_fppop(d, s1, s2) (FXCHr(1), jit_fpu_bantigtr_d_fppop(d, s1, s2))
#define jit_fpu_bantiltr_ld_fppop(d, s1, s2) jit_fpu_bantiltr_d_fppop(d, s1, s2)
#define jit_fpu_beqr_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 8, 0x45, 0x40, JZm)
#define jit_fpu_beqr_ld_fppop(d, s1, s2) jit_fpu_beqr_d_fppop(d, s1, s2)
#define jit_fpu_bantieqr_d_fppop(d, s1, s2) jit_fpu_fp_btest_fppop((d), 8, 0x45, 0x40, JNZm)
#define jit_fpu_bantieqr_ld_fppop(d, s1, s2) jit_fpu_bantieqr_d_fppop(d, s1, s2)
/* Doesn't work right with +nan.0: */
/* #define jit_bantieqr_d_fppop(d, s1, s2) jit_fp_btest_fppop_2((d), JNZm) */
#define jit_fpu_getarg_f(rd, ofs) jit_fpu_ldxi_f((rd), JIT_FP,(ofs))
#define jit_fpu_getarg_d(rd, ofs) jit_fpu_ldxi_d((rd), JIT_FP,(ofs))
#define jit_fpu_pusharg_d(rs) (jit_fpu_subi_i(JIT_SP,JIT_SP,sizeof(double)), jit_fpu_str_d(JIT_SP,(rs)))
#define jit_fpu_pusharg_f(rs) (jit_fpu_subi_i(JIT_SP,JIT_SP,sizeof(float)), jit_fpu_str_f(JIT_SP,(rs)))
#define jit_fpu_retval_d(op1) jit_fpu_movr_d(0, (op1))
#if 0
#define jit_sin() _OO(0xd9fe) /* fsin */
#define jit_cos() _OO(0xd9ff) /* fcos */
#define jit_tan() (_OO(0xd9f2), /* fptan */ \
FSTPr(0)) /* fstp st */
#define jit_atn() (_OO(0xd9e8), /* fld1 */ \
_OO(0xd9f3)) /* fpatan */
#define jit_exp() (_OO(0xd9ea), /* fldl2e */ \
FMULPr(1), /* fmulp */ \
_OO(0xd9c0), /* fld st */ \
_OO(0xd9fc), /* frndint */ \
_OO(0xdce9), /* fsubr */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f0), /* f2xm1 */ \
_OO(0xd9e8), /* fld1 */ \
_OO(0xdec1), /* faddp */ \
_OO(0xd9fd), /* fscale */ \
FSTPr(1)) /* fstp st(1) */
#define jit_log() (_OO(0xd9ed), /* fldln2 */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f1)) /* fyl2x */
#endif
#endif

598
src/racket/src/lightning/i386/fp.h
View File

@ -37,452 +37,162 @@
# include "fp-sse.h"
# ifdef MZ_LONG_DOUBLE
# include "fp-extfpu.h"
# endif
#else
/* We really must map the x87 stack onto a flat register file. In practice,
we can provide something sensible and make it work on the x86 using the
stack like a file of eight registers.
We use six or seven registers so as to have some freedom
for floor, ceil, round, (and log, tan, atn and exp).
Not hard at all, basically play with FXCH. FXCH is mostly free,
so the generated code is not bad. Of course we special case when one
of the operands turns out to be ST0.
Here are the macros that actually do the trick. */
#define JIT_FPR_NUM 6
#define JIT_FPR(i) (i)
#define jit_fxch(rs, op) (((rs) != 0 ? FXCHr(rs) : (void)0), \
op, ((rs) != 0 ? FXCHr(rs) : (void)0))
#define jit_fp_unary(rd, s1, op) \
((rd) == (s1) ? jit_fxch ((rd), op) \
: (rd) == 0 ? (FSTPr (0), FLDr ((s1)-1), op) \
: (FLDr ((s1)), op, FSTPr ((rd))))
#define jit_fp_binary(rd, s1, s2, op, opr) \
((rd) == (s1) ? \
((s2) == 0 ? opr(0, (rd)) \
: (s2) == (s1) ? jit_fxch((rd), op(0, 0)) \
: jit_fxch((rd), op((s2), 0))) \
: (rd) == (s2) ? ((s1) == 0 ? op((s1), (s2)) : jit_fxch((s2), opr((s1), 0))) \
: (FLDr (s1), op(0, (s2)+1), FSTPr((rd)+1)))
#define jit_addr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FADDrr,FADDrr)
#define jit_subr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FSUBrr,FSUBRrr)
#define jit_subrr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FSUBRrr,FSUBrr)
#define jit_mulr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FMULrr,FMULrr)
#define jit_divr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FDIVrr,FDIVRrr)
#define jit_divrr_d(rd,s1,s2) jit_fp_binary((rd),(s1),(s2),FDIVRrr,FDIVrr)
#define jit_abs_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9e1))
#define jit_negr_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9e0))
#define jit_sqrt_d(rd,rs) jit_fp_unary ((rd), (rs), _OO (0xd9fa))
#define jit_addr_d_fppop(rd,s1,s2) (FADDPr(1))
#define jit_subr_d_fppop(rd,s1,s2) (FSUBPr(1))
#define jit_subrr_d_fppop(rd,s1,s2) (FSUBRPr(1))
#define jit_mulr_d_fppop(rd,s1,s2) (FMULPr(1))
#define jit_divr_d_fppop(rd,s1,s2) (FDIVPr(1))
#define jit_divrr_d_fppop(rd,s1,s2) (FDIVRPr(1))
#define jit_negr_d_fppop(rd,rs) ( _OO (0xd9e0))
#define jit_abs_d_fppop(rd,rs) ( _OO (0xd9e1))
#define jit_sqrt_d_fppop(rd,rs) ( _OO (0xd9fa))
/* - moves:
move FPR0 to FPR3
FST ST3
move FPR3 to FPR0
FXCH ST3
FST ST3
move FPR3 to FPR1
FLD ST1
FST ST4 Stack is rotated, so FPRn becomes STn+1 */
#define jit_movr_d(rd,s1) \
((s1) == (rd) ? 0 \
: (rd) == 0 ? (FSTPr(0), FSTr (((s1)-1))) \
: (FLDr ((s1)), FSTPr ((rd)+1)))
#define jit_movr_d_rel(rd,s1) ((rd < s1) ? (FSTPr(0), FLDr(0)) : (FSTr(1)))
#define jit_movr_d_fppush(rd,s1) (FLDr(s1))
/* - loads:
load into FPR0
FSTP ST0
FLD [FUBAR]
load into FPR3
FSTP ST3 Save old st0 into destination register
FLD [FUBAR]
FXCH ST3 Get back old st0
(and similarly for immediates, using the stack) */
#define jit_movi_f(rd,immf) \
(_O (0x68), \
*((float *) _jit.x.pc) = (float) immf, \
_jit.x.uc_pc += sizeof (float), \
jit_ldr_f((rd), _ESP), \
ADDQir(4, _ESP))
union jit_double_imm {
double d;
int i[2];
};
#ifdef JIT_X86_64
# define jit_double_as_long(v) (*(double *)(_jit.x.uc_pc) = v, *(intptr_t *)(_jit.x.uc_pc))
# define _jit_push_d(immd) \
(MOVQir(jit_double_as_long(immd), JIT_REXTMP), \
PUSHQr(JIT_REXTMP))
# define FPX() (void)0 /* don't need _REX(0,0,0), apparently */
#else
# define _jit_push_d(immd) \
(_O (0x68), \
_jit.x.uc_pc[4] = 0x68, \
((union jit_double_imm *) (_jit.x.uc_pc + 5))->d = (double) immd, \
*((int *) _jit.x.uc_pc) = ((union jit_double_imm *) (_jit.x.uc_pc + 5))->i[1], \
_jit.x.uc_pc += 9)
# define FPX() ((void) 0)
#endif
#define jit_movi_d(rd,immd) \
(_jit_push_d(immd), \
jit_ldr_d((rd), _ESP), \
ADDQir(8, _ESP))
#define jit_movi_d_fppush(rd,immd) \
(_jit_push_d(immd), \
jit_ldr_d_fppush((rd), _ESP), \
ADDQir(8, _ESP))
#ifdef JIT_X86_64
#define jit_ldi_d_fppush(rd, is) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_ldr_d_fppush(rd, JIT_R0), \
MOVQrr(JIT_REXTMP, JIT_R0))
#else
#define jit_ldi_f(rd, is) \
((rd) == 0 ? (FSTPr (0), FLDSm((is), 0, 0, 0)) \
: (FLDSm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_ldi_d(rd, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm((is), 0, 0, 0)) \
: (FPX(), FLDLm((is), 0, 0, 0), FSTPr ((rd) + 1)))
#define jit_ldi_d_fppush(rd, is) (FPX(), FLDLm((is), 0, 0, 0))
#endif
#define jit_ldr_f(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm(0, (rs), 0, 0)) \
: (FPX(), FLDSm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldr_d(rd, rs) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (rs), 0, 0)) \
: (FPX(), FLDLm(0, (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldr_d_fppush(rd, rs) (FPX(), FLDLm(0, (rs), 0, 0))
#define jit_ldxi_f(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm((is), (rs), 0, 0)) \
: (FPX(), FLDSm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldxi_d(rd, rs, is) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm((is), (rs), 0, 0)) \
: (FPX(), FLDLm((is), (rs), 0, 0), FSTPr ((rd) + 1)))
#define jit_ldxi_d_fppush(rd, rs, is) (FPX(), FLDLm((is), (rs), 0, 0))
#define jit_ldxr_f(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDSm(0, (s1), (s2), 1)) \
: (FPX(), FLDSm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_ldxr_d(rd, s1, s2) \
((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (s1), (s2), 1)) \
: (FPX(), FLDLm(0, (s1), (s2), 1), FSTPr ((rd) + 1)))
#define jit_ldxr_d_fppush(rd, s1, s2) (FPX(), FLDLm(0, (s1), (s2), 1))
#define jit_extr_i_d(rd, rs) (PUSHLr((rs)), \
((rd) == 0 ? (FSTPr (0), FILDLm(0, _ESP, 0, 0)) \
: (FILDLm(0, _ESP, 0, 0), FSTPr ((rd) + 1))), \
POPLr((rs)))
#define jit_extr_i_d_fppush(rd, rs) \
(PUSHLr((rs)), FILDLm(0, _ESP, 0, 0), POPLr((rs)))
#ifdef JIT_X86_64
# define jit_extr_l_d_fppush(rd, rs) \
(PUSHQr((rs)), FILDQm(0, _ESP, 0, 0), POPQr((rs)))
#else
# define jit_extr_l_d_fppush(rd, rs) jit_extr_i_d_fppush(rd, rs)
#endif
#define jit_stxi_f(id, rd, rs) jit_fxch ((rs), FPX(), FSTSm((id), (rd), 0, 0))
#define jit_stxr_f(d1, d2, rs) jit_fxch ((rs), FPX(), FSTSm(0, (d1), (d2), 1))
#define jit_stxi_d(id, rd, rs) jit_fxch ((rs), FPX(), FSTLm((id), (rd), 0, 0))
#define jit_stxr_d(d1, d2, rs) jit_fxch ((rs), FPX(), FSTLm(0, (d1), (d2), 1))
#ifdef JIT_X86_64
#define jit_sti_d_fppop(is, rd) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_str_d_fppop(JIT_R0, rd), \
MOVQrr(JIT_REXTMP, JIT_R0))
#else
#define jit_sti_f(id, rs) jit_fxch ((rs), FPX(), FSTSm((id), 0, 0, 0))
#define jit_str_f(rd, rs) jit_fxch ((rs), FPX(), FSTSm(0, (rd), 0, 0))
#define jit_sti_d(id, rs) jit_fxch ((rs), FPX(), FSTLm((id), 0, 0, 0))
#define jit_str_d(rd, rs) jit_fxch ((rs), FPX(), FSTLm(0, (rd), 0, 0))
#define jit_sti_d_fppop(id, rs) (FPX(), FSTPLm((id), 0, 0, 0))
#endif
#define jit_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0))
#define jit_str_d_fppop(rd, rs) (FPX(), FSTPLm(0, (rd), 0, 0))
#define jit_stxr_d_fppop(d1, d2, rs) (FPX(), FSTPLm(0, (d1), (d2), 1))
/* Assume round to near mode */
#define jit_floorr_d_i(rd, rs) \
(FLDr (rs), jit_floor2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_ceilr_d_i(rd, rs) \
(FLDr (rs), jit_ceil2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_truncr_d_i(rd, rs) \
(FLDr (rs), jit_trunc2((rd), ((rd) == _EDX ? _EAX : _EDX)))
#define jit_calc_diff(ofs) \
FISTLm(ofs, _ESP, 0, 0), \
FILDLm(ofs, _ESP, 0, 0), \
FSUBRPr(1), \
FSTPSm(4+ofs, _ESP, 0, 0) \
/* The real meat */
#define jit_floor2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
ADDLir(0x7FFFFFFF, aux), /* carry if x-round(x) < -0 */ \
SBBLir(0, rd), /* subtract 1 if carry */ \
POPLr(aux))
#define jit_ceil2(rd, aux) \
(PUSHLr(aux), \
SUBLir(8, _ESP), \
jit_calc_diff(0), \
POPLr(rd), /* floor in rd */ \
POPLr(aux), /* x-round(x) in aux */ \
TESTLrr(aux, aux), \
SETGr(jit_reg8(aux)), \
SHRLir(1, aux), \
ADCLir(0, rd), \
POPLr(aux))
/* a mingling of the two above */
#define jit_trunc2(rd, aux) \
(PUSHLr(aux), \
SUBLir(12, _ESP), \
FSTSm(0, _ESP, 0, 0), \
jit_calc_diff(4), \
POPLr(aux), \
POPLr(rd), \
TESTLrr(aux, aux), \
POPLr(aux), \
JSSm(_jit.x.pc + 11, 0, 0, 0), \
ADDLir(0x7FFFFFFF, aux), /* 6 */ \
SBBLir(0, rd), /* 3 */ \
JMPSm(_jit.x.pc + 10, 0, 0, 0), /* 2 */ \
TESTLrr(aux, aux), /* 2 */ \
SETGr(jit_reg8(aux)), /* 3 */ \
SHRLir(1, aux), /* 2 */ \
ADCLir(0, rd), /* 3 */ \
POPLr(aux))
/* the easy one */
#define jit_roundr_d_i(rd, rs) \
(PUSHLr(_EAX), \
jit_fxch ((rs), FISTPLm(0, _ESP, 0, 0)), \
POPLr((rd)))
#define jit_roundr_d_l(rd, rs) \
(PUSHQr(_EAX), \
jit_fxch ((rs), FISTPQm(0, _ESP, 0, 0)), \
POPQr((rd)))
#define jit_roundr_d_l_fppop(rd, rs) \
(PUSHQr(_EAX), \
FISTPQm(0, _ESP, 0, 0), \
POPQr((rd)))
#define jit_fp_test(d, s1, s2, n, _and, res) \
(((s1) == 0 ? FUCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
((d) != _EAX ? MOVLrr(_EAX, (d)) : 0), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir((_and), _EAX) : MOVLir(0, _EAX)), \
res, \
((d) != _EAX ? _O (0x90 + ((d) & 7)) : 0)) /* xchg */
#define jit_fp_btest(d, s1, s2, n, _and, cmp, res) \
(((s1) == 0 ? FCOMr((s2)) : (FLDr((s1)), FUCOMPr((s2) + 1))), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fp_test_fppop(d, n, _and, res) \
(FUCOMPPr(1), \
((d) != _EAX ? MOVLrr(_EAX, (d)) : 0), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
((_and) ? ANDLir((_and), _EAX) : MOVLir(0, _EAX)), \
res, \
((d) != _EAX ? _O (0x90 + ((d) & 7)) : 0)) /* xchg */
#define jit_fp_btest_fppop(d, n, _and, cmp, res) \
(FUCOMPPr(1), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
(void)((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fp_btest_fppop(d, n, _and, cmp, res) \
(FUCOMPPr(1), \
(_jitl.r0_can_be_tmp ? 0 : PUSHQr(_EAX)), \
FNSTSWr(_EAX), \
SHRLir(n, _EAX), \
(void)((_and) ? ANDLir ((_and), _EAX) : 0), \
(void)((cmp) ? CMPLir ((cmp), _AL) : 0), \
(void) (_jitl.r0_can_be_tmp ? 0 : POPQr(_EAX)), \
res ((d), 0, 0, 0), _jit.x.pc)
#define jit_fp_btest_fppop_2(d, res) \
(FUCOMIPr(1), FSTPr(0), res ((d), 0, 0, 0), _jit.x.pc)
#define jit_nothing_needed(x)
/* After FNSTSW we have 1 if <, 40 if =, 0 if >, 45 if unordered. Here
is how to map the values of the status word's high byte to the
conditions.
< = > unord valid values condition
gt no no yes no 0 STSW & 45 == 0
lt yes no no no 1 STSW & 45 == 1
eq no yes no no 40 STSW & 45 == 40
unord no no no yes 45 bit 2 == 1
ge no yes no no 0, 40 bit 0 == 0
unlt yes no no yes 1, 45 bit 0 == 1
ltgt yes no yes no 0, 1 bit 6 == 0
uneq no yes no yes 40, 45 bit 6 == 1
le yes yes no no 1, 40 odd parity for STSW & 41
ungt no no yes yes 0, 45 even parity for STSW & 41
unle yes yes no yes 1, 40, 45 STSW & 45 != 0
unge no yes yes yes 0, 40, 45 STSW & 45 != 1
ne yes no yes yes 0, 1, 45 STSW & 45 != 40
ord yes yes yes no 0, 1, 40 bit 2 == 0
lt, le, ungt, unge are actually computed as gt, ge, unlt, unle with
the operands swapped; it is more efficient this way. */
#define jit_gtr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, SETZr (_AL))
#define jit_ger_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 9, 0, SBBBir (-1, _AL))
#define jit_unler_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, SETNZr (_AL))
#define jit_unltr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 9, 0, ADCBir (0, _AL))
#define jit_ltr_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 8, 0x45, SETZr (_AL))
#define jit_ler_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 9, 0, SBBBir (-1, _AL))
#define jit_unger_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 8, 0x45, SETNZr (_AL))
#define jit_ungtr_d(d, s1, s2) jit_fp_test((d), (s2), (s1), 9, 0, ADCBir (0, _AL))
#define jit_eqr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETEr (_AL)))
#define jit_ner_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 8, 0x45, (CMPBir (0x40, _AL), SETNEr (_AL)))
#define jit_ltgtr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 15, 0, SBBBir (-1, _AL))
#define jit_uneqr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 15, 0, ADCBir (0, _AL))
#define jit_ordr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 11, 0, SBBBir (-1, _AL))
#define jit_unordr_d(d, s1, s2) jit_fp_test((d), (s1), (s2), 11, 0, ADCBir (0, _AL))
#define jit_bgtr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0, JZm)
#define jit_bger_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 9, 0, 0, JNCm)
#define jit_bantigtr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0, JNZm)
#define jit_bantiger_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 9, 0, 0, JCm)
#define jit_bunler_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0, JNZm)
#define jit_bunltr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 9, 0, 0, JCm)
#define jit_bltr_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 8, 0x45, 0, JZm)
#define jit_bler_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 9, 0, 0, JNCm)
#define jit_bantiltr_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 8, 0x45, 0, JNZm)
#define jit_bantiler_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 9, 0, 0, JCm)
#define jit_bunger_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 8, 0x45, 0, JNZm)
#define jit_bungtr_d(d, s1, s2) jit_fp_btest((d), (s2), (s1), 9, 0, 0, JCm)
#define jit_beqr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JZm)
#define jit_bantieqr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JNZm)
#define jit_bner_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 8, 0x45, 0x40, JNZm)
#define jit_bltgtr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 15, 0, 0, JNCm)
#define jit_buneqr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 15, 0, 0, JCm)
#define jit_bordr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 11, 0, 0, JNCm)
#define jit_bunordr_d(d, s1, s2) jit_fp_btest((d), (s1), (s2), 11, 0, 0, JCm)
#define jit_bger_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 9, 0, 0, JNCm)
/* #define jit_bantiger_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 9, 0, 0, JCm) */
#define jit_bantiger_d_fppop(d, s1, s2) jit_fp_btest_fppop_2((d), JBm)
#define jit_bler_d_fppop(d, s1, s2) (FXCHr(1), jit_bger_d_fppop(d, s1, s2))
#define jit_bantiler_d_fppop(d, s1, s2) (FXCHr(1), jit_bantiger_d_fppop(d, s1, s2))
#define jit_bgtr_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 8, 0x45, 0, JZm)
/* #define jit_bantigtr_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 8, 0x45, 0, JNZm) */
#define jit_bantigtr_d_fppop(d, s1, s2) jit_fp_btest_fppop_2((d), JBEm)
#define jit_bltr_d_fppop(d, s1, s2) (FXCHr(1), jit_bgtr_d_fppop(d, s1, s2))
#define jit_bantiltr_d_fppop(d, s1, s2) (FXCHr(1), jit_bantigtr_d_fppop(d, s1, s2))
#define jit_beqr_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 8, 0x45, 0x40, JZm)
#define jit_bantieqr_d_fppop(d, s1, s2) jit_fp_btest_fppop((d), 8, 0x45, 0x40, JNZm)
/* Doesn't work right with +nan.0: */
/* #define jit_bantieqr_d_fppop(d, s1, s2) jit_fp_btest_fppop_2((d), JNZm) */
#define jit_getarg_f(rd, ofs) jit_ldxi_f((rd), JIT_FP,(ofs))
#define jit_getarg_d(rd, ofs) jit_ldxi_d((rd), JIT_FP,(ofs))
#define jit_pusharg_d(rs) (jit_subi_i(JIT_SP,JIT_SP,sizeof(double)), jit_str_d(JIT_SP,(rs)))
#define jit_pusharg_f(rs) (jit_subi_i(JIT_SP,JIT_SP,sizeof(float)), jit_str_f(JIT_SP,(rs)))
#define jit_retval_d(op1) jit_movr_d(0, (op1))
#if 0
#define jit_sin() _OO(0xd9fe) /* fsin */
#define jit_cos() _OO(0xd9ff) /* fcos */
#define jit_tan() (_OO(0xd9f2), /* fptan */ \
FSTPr(0)) /* fstp st */
#define jit_atn() (_OO(0xd9e8), /* fld1 */ \
_OO(0xd9f3)) /* fpatan */
#define jit_exp() (_OO(0xd9ea), /* fldl2e */ \
FMULPr(1), /* fmulp */ \
_OO(0xd9c0), /* fld st */ \
_OO(0xd9fc), /* frndint */ \
_OO(0xdce9), /* fsubr */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f0), /* f2xm1 */ \
_OO(0xd9e8), /* fld1 */ \
_OO(0xdec1), /* faddp */ \
_OO(0xd9fd), /* fscale */ \
FSTPr(1)) /* fstp st(1) */
#define jit_log() (_OO(0xd9ed), /* fldln2 */ \
FXCHr(1), /* fxch st(1) */ \
_OO(0xd9f1)) /* fyl2x */
#endif
# include "fp-extfpu.h"
# define JIT_FPR_NUM JIT_FPU_FPR_NUM
# define JIT_FPR(i) JIT_FPU_FPR(i)
# define jit_fxch(rs, op) jit_fpu_fxch(rs, op)
# define jit_addr_d(rd,s1,s2) jit_fpu_addr_d(rd,s1,s2)
# define jit_subr_d(rd,s1,s2) jit_fpu_subr_d(rd,s1,s2)
# define jit_subrr_d(rd,s1,s2) jit_fpu_subrr_d(rd,s1,s2)
# define jit_mulr_d(rd,s1,s2) jit_fpu_mulr_d(rd,s1,s2)
# define jit_divr_d(rd,s1,s2) jit_fpu_divr_d(rd,s1,s2)
# define jit_divrr_d(rd,s1,s2) jit_fpu_divrr_d(rd,s1,s2)
# define jit_abs_d(rd,rs) jit_fpu_abs_d(rd,rs)
# define jit_negr_d(rd,rs) jit_fpu_negr_d(rd,rs)
# define jit_sqrt_d(rd,rs) jit_fpu_sqrt_d(rd,rs)
# define jit_addr_d_fppop(rd,s1,s2) jit_fpu_addr_d_fppop(rd,s1,s2)
# define jit_subr_d_fppop(rd,s1,s2) jit_fpu_subr_d_fppop(rd,s1,s2)
# define jit_subrr_d_fppop(rd,s1,s2) jit_fpu_subrr_d_fppop(rd,s1,s2)
# define jit_mulr_d_fppop(rd,s1,s2) jit_fpu_mulr_d_fppop(rd,s1,s2)
# define jit_divr_d_fppop(rd,s1,s2) jit_fpu_divr_d_fppop(rd,s1,s2)
# define jit_divrr_d_fppop(rd,s1,s2) jit_fpu_divrr_d_fppop(rd,s1,s2)
# define jit_negr_d_fppop(rd,rs) jit_fpu_negr_d_fppop(rd,rs)
# define jit_abs_d_fppop(rd,rs) jit_fpu_abs_d_fppop(rd,rs)
# define jit_sqrt_d_fppop(rd,rs) jit_fpu_sqrt_d_fppop(rd,rs)
# define jit_addr_ld(rd,s1,s2) jit_fpu_addr_ld(rd,s1,s2)
# define jit_subr_ld(rd,s1,s2) jit_fpu_subr_ld(rd,s1,s2)
# define jit_subrr_ld(rd,s1,s2) jit_fpu_subrr_ld(rd,s1,s2)
# define jit_mulr_ld(rd,s1,s2) jit_fpu_mulr_ld(rd,s1,s2)
# define jit_ldivr_ld(rd,s1,s2) jit_fpu_ldivr_ld(rd,s1,s2)
# define jit_ldivrr_ld(rd,s1,s2) jit_fpu_ldivrr_ld(rd,s1,s2)
# define jit_abs_ld(rd,rs) jit_fpu_abs_ld(rd,rs)
# define jit_negr_ld(rd,rs) jit_fpu_negr_ld(rd,rs)
# define jit_sqrt_ld(rd,rs) jit_fpu_sqrt_ld(rd,rs)
# define jit_addr_ld_fppop(rd,s1,s2) jit_fpu_addr_ld_fppop(rd,s1,s2)
# define jit_subr_ld_fppop(rd,s1,s2) jit_fpu_subr_ld_fppop(rd,s1,s2)
# define jit_subrr_ld_fppop(rd,s1,s2) jit_fpu_subrr_ld_fppop(rd,s1,s2)
# define jit_mulr_ld_fppop(rd,s1,s2) jit_fpu_mulr_ld_fppop(rd,s1,s2)
# define jit_divr_ld_fppop(rd,s1,s2) jit_fpu_divr_ld_fppop(rd,s1,s2)
# define jit_divrr_ld_fppop(rd,s1,s2) jit_fpu_divrr_ld_fppop(rd,s1,s2)
# define jit_negr_ld_fppop(rd,rs) jit_fpu_negr_ld_fppop(rd,rs)
# define jit_abs_ld_fppop(rd,rs) jit_fpu_abs_ld_fppop(rd,rs)
# define jit_sqrt_ld_fppop(rd,rs) jit_fpu_sqrt_ld_fppop(rd,rs)
# define jit_movr_d(rd,s1) jit_fpu_movr_d(rd,s1)
# define jit_movr_d_rel(rd,s1) jit_fpu_movr_d_rel(rd,s1)
# define jit_movr_d_fppush(rd,s1) jit_fpu_movr_d_fppush(rd,s1)
# define jit_movr_ld(rd,s1) jit_fpu_movr_ld(rd,s1)
# define jit_movr_ld_rel(rd,s1) jit_fpu_movr_ld_rel(rd,s1)
# define jit_movr_ld_fppush(rd,s1) jit_fpu_movr_ld_fppush(rd,s1)
# define jit_movi_d(rd,immd) jit_fpu_movi_d(rd,immd)
# define jit_ldi_d(rd, is) jit_fpu_ldi_d(rd, is)
# define jit_ldi_d_fppush(rd, is) jit_fpu_ldi_d_fppush(rd, is)
# define jit_ldi_ld(rd, is) jit_fpu_ldi_ld(rd, is)
# define jit_ldi_ld_fppush(rd, is) jit_fpu_ldi_ld_fppush(rd, is)
# define jit_ldr_d(rd, rs) jit_fpu_ldr_d(rd, rs)
# define jit_ldr_d_fppush(rd, rs) jit_fpu_ldr_d_fppush(rd, rs)
# define jit_ldr_ld(rd, rs) jit_fpu_ldr_ld(rd, rs)
# define jit_ldr_ld_fppush(rd, rs) jit_fpu_ldr_ld_fppush(rd, rs)
# define jit_ldxi_d(rd, rs, is) jit_fpu_ldxi_d(rd, rs, is)
# define jit_ldxi_d_fppush(rd, rs, is) jit_fpu_ldxi_d_fppush(rd, rs, is)
# define jit_ldxi_ld(rd, rs, is) jit_fpu_ldxi_ld(rd, rs, is)
# define jit_ldxi_ld_fppush(rd, rs, is) jit_fpu_ldxi_ld_fppush(rd, rs, is)
# define jit_ldxr_d(rd, s1, s2) jit_fpu_ldxr_d(rd, s1, s2)
# define jit_ldxr_d_fppush(rd, s1, s2) jit_fpu_ldxr_d_fppush(rd, s1, s2)
# define jit_ldxr_ld(rd, s1, s2) jit_fpu_ldxr_ld(rd, s1, s2)
# define jit_ldxr_ld_fppush(rd, s1, s2) jit_fpu_ldxr_ld_fppush(rd, s1, s2)
# define jit_extr_i_d(rd, rs) jit_fpu_extr_i_d(rd, rs)
# define jit_extr_i_d_fppush(rd, rs) jit_fpu_extr_i_d_fppush(rd, rs)
# define jit_extr_i_ld_fppush(rd, rs) jit_fpu_extr_i_ld_fppush(rd, rs)
# define jit_extr_l_d_fppush(rd, rs) jit_fpu_extr_l_d_fppush(rd, rs)
# define jit_extr_l_ld_fppush(rd, rs) jit_fpu_extr_l_ld_fppush(rd, rs)
# define jit_stxi_f(id, rd, rs) jit_fpu_stxi_f(id, rd, rs)
# define jit_stxr_f(d1, d2, rs) jit_fpu_stxr_f(d1, d2, rs)
# define jit_stxi_d(id, rd, rs) jit_fpu_stxi_d(id, rd, rs)
# define jit_stxr_d(d1, d2, rs) jit_fpu_stxr_d(d1, d2, rs)
# define jit_sti_d(id, rs) jit_fpu_sti_d(id, rs)
# define jit_str_d(rd, rs) jit_fpu_str_d(rd, rs)
# define jit_sti_d_fppop(id, rs) jit_fpu_sti_d_fppop(id, rs)
# define jit_sti_ld_fppop(id, rs) jit_fpu_sti_ld_fppop(id, rs)
# define jit_stxi_d_fppop(id, rd, rs) jit_fpu_stxi_d_fppop(id, rd, rs)
# define jit_str_d_fppop(rd, rs) jit_fpu_str_d_fppop(rd, rs)
# define jit_stxr_d_fppop(d1, d2, rs) jit_fpu_stxr_d_fppop(d1, d2, rs)
# define jit_stxi_ld_fppop(id, rd, rs) jit_fpu_stxi_ld_fppop(id, rd, rs)
# define jit_str_ld_fppop(rd, rs) jit_fpu_str_ld_fppop(rd, rs)
# define jit_stxr_ld_fppop(d1, d2, rs) jit_fpu_stxr_ld_fppop(d1, d2, rs)
# define jit_floorr_d_i(rd, rs) jit_fpu_floorr_d_i(rd, rs)
# define jit_ceilr_d_i(rd, rs) jit_fpu_ceilr_d_i(rd, rs)
# define jit_truncr_d_i(rd, rs) jit_fpu_truncr_d_i(rd, rs)
# define jit_roundr_d_i(rd, rs) jit_fpu_roundr_d_i(rd, rs)
# define jit_roundr_ld_i(rd, rs) jit_fpu_roundr_ld_i(rd, rs)
# define jit_roundr_d_l(rd, rs) jit_fpu_roundr_d_l(rd, rs)
# define jit_roundr_ld_l(rd, rs) jit_fpu_roundr_ld_l(rd, rs)
# define jit_roundr_d_l_fppop(rd, rs) jit_fpu_roundr_d_l_fppop(rd, rs)
# define jit_roundr_ld_l_fppop(rd, rs) jit_fpu_roundr_ld_l_fppop(rd, rs)
# define jit_gtr_d(d, s1, s2) jit_fpu_gtr_d(d, s1, s2)
# define jit_ger_d(d, s1, s2) jit_fpu_ger_d(d, s1, s2)
# define jit_unler_d(d, s1, s2) jit_fpu_unler_d(d, s1, s2)
# define jit_unltr_d(d, s1, s2) jit_fpu_unltr_d(d, s1, s2)
# define jit_ltr_d(d, s1, s2) jit_fpu_ltr_d(d, s1, s2)
# define jit_ler_d(d, s1, s2) jit_fpu_ler_d(d, s1, s2)
# define jit_unger_d(d, s1, s2) jit_fpu_unger_d(d, s1, s2)
# define jit_ungtr_d(d, s1, s2) jit_fpu_ungtr_d(d, s1, s2)
# define jit_eqr_d(d, s1, s2) jit_fpu_eqr_d(d, s1, s2)
# define jit_ner_d(d, s1, s2) jit_fpu_ner_d(d, s1, s2)
# define jit_ltgtr_d(d, s1, s2) jit_fpu_ltgtr_d(d, s1, s2)
# define jit_uneqr_d(d, s1, s2) jit_fpu_uneqr_d(d, s1, s2)
# define jit_ordr_d(d, s1, s2) jit_fpu_ordr_d(d, s1, s2)
# define jit_unordr_d(d, s1, s2) jit_fpu_unordr_d(d, s1, s2)
# define jit_bgtr_d(d, s1, s2) jit_fpu_bgtr_d(d, s1, s2)
# define jit_bger_d(d, s1, s2) jit_fpu_bger_d(d, s1, s2)
# define jit_bger_ld(d, s1, s2) jit_fpu_bger_ld(d, s1, s2)
# define jit_bantigtr_d(d, s1, s2) jit_fpu_bantigtr_d(d, s1, s2)
# define jit_bantiger_d(d, s1, s2) jit_fpu_bantiger_d(d, s1, s2)
# define jit_bunler_d(d, s1, s2) jit_fpu_bunler_d(d, s1, s2)
# define jit_bunltr_d(d, s1, s2) jit_fpu_bunltr_d(d, s1, s2)
# define jit_bltr_d(d, s1, s2) jit_fpu_bltr_d(d, s1, s2)
# define jit_bltr_ld(d, s1, s2) jit_fpu_bltr_ld(d, s1, s2)
# define jit_bler_d(d, s1, s2) jit_fpu_bler_d(d, s1, s2)
# define jit_bantiltr_d(d, s1, s2) jit_fpu_bantiltr_d(d, s1, s2)
# define jit_bantiler_d(d, s1, s2) jit_fpu_bantiler_d(d, s1, s2)
# define jit_bunger_d(d, s1, s2) jit_fpu_bunger_d(d, s1, s2)
# define jit_bungtr_d(d, s1, s2) jit_fpu_bungtr_d(d, s1, s2)
# define jit_beqr_d(d, s1, s2) jit_fpu_beqr_d(d, s1, s2)
# define jit_beqr_ld(d, s1, s2) jit_fpu_beqr_ld(d, s1, s2)
# define jit_bantieqr_d(d, s1, s2) jit_fpu_bantieqr_d(d, s1, s2)
# define jit_bantieqr_ld(d, s1, s2) jit_fpu_bantieqr_ld(d, s1, s2)
# define jit_bner_d(d, s1, s2) jit_fpu_bner_d(d, s1, s2)
# define jit_bltgtr_d(d, s1, s2) jit_fpu_bltgtr_d(d, s1, s2)
# define jit_buneqr_d(d, s1, s2) jit_fpu_buneqr_d(d, s1, s2)
# define jit_bordr_d(d, s1, s2) jit_fpu_bordr_d(d, s1, s2)
# define jit_bunordr_d(d, s1, s2) jit_fpu_bunordr_d(d, s1, s2)
# define jit_bger_d_fppop(d, s1, s2) jit_fpu_bger_d_fppop(d, s1, s2)
# define jit_bger_ld_fppop(d, s1, s2) jit_fpu_bger_ld_fppop(d, s1, s2)
# define jit_bantiger_d_fppop(d, s1, s2) jit_fpu_bantiger_d_fppop(d, s1, s2)
# define jit_bantiger_ld_fppop(d, s1, s2) jit_fpu_bantiger_ld_fppop(d, s1, s2)
# define jit_bler_d_fppop(d, s1, s2) jit_fpu_bler_d_fppop(d, s1, s2)
# define jit_bler_ld_fppop(d, s1, s2) jit_fpu_bler_ld_fppop(d, s1, s2)
# define jit_bantiler_d_fppop(d, s1, s2) jit_fpu_bantiler_d_fppop(d, s1, s2)
# define jit_bantiler_ld_fppop(d, s1, s2) jit_fpu_bantiler_ld_fppop(d, s1, s2)
# define jit_bgtr_d_fppop(d, s1, s2) jit_fpu_bgtr_d_fppop(d, s1, s2)
# define jit_bgtr_ld_fppop(d, s1, s2) jit_fpu_bgtr_ld_fppop(d, s1, s2)
# define jit_bantigtr_d_fppop(d, s1, s2) jit_fpu_bantigtr_d_fppop(d, s1, s2)
# define jit_bantigtr_ld_fppop(d, s1, s2) jit_fpu_bantigtr_ld_fppop(d, s1, s2)
# define jit_bltr_d_fppop(d, s1, s2) jit_fpu_bltr_d_fppop(d, s1, s2)
# define jit_bltr_ld_fppop(d, s1, s2) jit_fpu_bltr_ld_fppop(d, s1, s2)
# define jit_bantiltr_d_fppop(d, s1, s2) jit_fpu_bantiltr_d_fppop(d, s1, s2)
# define jit_bantiltr_ld_fppop(d, s1, s2) jit_fpu_bantiltr_ld_fppop(d, s1, s2)
# define jit_beqr_d_fppop(d, s1, s2) jit_fpu_beqr_d_fppop(d, s1, s2)
# define jit_beqr_ld_fppop(d, s1, s2) jit_fpu_beqr_ld_fppop(d, s1, s2)
# define jit_bantieqr_d_fppop(d, s1, s2) jit_fpu_bantieqr_d_fppop(d, s1, s2)
# define jit_bantieqr_ld_fppop(d, s1, s2) jit_fpu_bantieqr_ld_fppop(d, s1, s2)
#endif

2
src/racket/src/makex.rkt
View File

@ -126,6 +126,8 @@
(values #t #f)]
[(regexp-match? #rx"#ifdef MZ_USE_SINGLE_FLOATS" l)
(values #t #f)]
[(regexp-match? #rx"#ifdef MZ_LONG_DOUBLE" l)
(values #t #f)]
[(and (exports-mode)
(regexp-match? #rx"#ifdef USE_MZ_SETJMP" l))
(values #t #f)]

28
src/racket/src/module.c
View File

@ -169,6 +169,8 @@ READ_ONLY static Scheme_Object *kernel_symbol;
READ_ONLY static Scheme_Object *kernel_modidx;
READ_ONLY static Scheme_Module *kernel;
READ_ONLY static Scheme_Object *flfxnum_modname;
READ_ONLY static Scheme_Object *extfl_modname;
READ_ONLY static Scheme_Object *extfl_unsafe_modname;
READ_ONLY static Scheme_Object *futures_modname;
READ_ONLY static Scheme_Object *unsafe_modname;
@ -396,6 +398,7 @@ void scheme_init_module(Scheme_Env *env)
REGISTER_SO(kernel_modidx);
REGISTER_SO(unsafe_modname);
REGISTER_SO(flfxnum_modname);
REGISTER_SO(extfl_modname);
REGISTER_SO(futures_modname);
kernel_symbol = scheme_intern_symbol("#%kernel");
kernel_modname = scheme_intern_resolved_module_path(kernel_symbol);
@ -406,6 +409,7 @@ void scheme_init_module(Scheme_Env *env)
(void)scheme_hash_key(kernel_modidx);
unsafe_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%unsafe"));
flfxnum_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%flfxnum"));
extfl_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%extfl"));
futures_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%futures"));
REGISTER_SO(module_begin_symbol);
@ -707,6 +711,11 @@ int scheme_is_flfxnum_modname(Scheme_Object *modname)
return SAME_OBJ(modname, flfxnum_modname);
}
int scheme_is_extfl_modname(Scheme_Object *modname)
{
return SAME_OBJ(modname, extfl_modname);
}
int scheme_is_futures_modname(Scheme_Object *modname)
{
return SAME_OBJ(modname, futures_modname);
@ -720,6 +729,8 @@ Scheme_Module *get_special_module(Scheme_Object *name)
return scheme_get_unsafe_env()->module;
else if (SAME_OBJ(name, flfxnum_modname))
return scheme_get_flfxnum_env()->module;
else if (SAME_OBJ(name, extfl_modname))
return scheme_get_extfl_env()->module;
else if (SAME_OBJ(name, futures_modname))
return scheme_get_futures_env()->module;
else
@ -732,6 +743,8 @@ Scheme_Env *get_special_modenv(Scheme_Object *name)
return scheme_get_kernel_env();
else if (SAME_OBJ(name, flfxnum_modname))
return scheme_get_flfxnum_env();
else if (SAME_OBJ(name, extfl_modname))
return scheme_get_extfl_env();
else if (SAME_OBJ(name, futures_modname))
return scheme_get_futures_env();
else if (SAME_OBJ(name, unsafe_modname))
@ -745,6 +758,7 @@ static int is_builtin_modname(Scheme_Object *modname)
return (SAME_OBJ(modname, kernel_modname)
|| SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname));
}
@ -2185,6 +2199,7 @@ static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]
if (!SAME_OBJ(name, kernel_modname)
&& !SAME_OBJ(name, flfxnum_modname)
&& !SAME_OBJ(name, extfl_modname)
&& !SAME_OBJ(name, futures_modname)) {
if (SAME_OBJ(name, unsafe_modname))
menv2 = scheme_get_unsafe_env();
@ -4549,6 +4564,7 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem
if (SAME_OBJ(modname, kernel_modname)
|| SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname))
return -1;
@ -4582,8 +4598,9 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env,
return scheme_lookup_in_table(kenv->syntax, (char *)name);
} else if (SAME_OBJ(modname, unsafe_modname)
|| SAME_OBJ(modname, flfxnum_modname)
|| SAME_OBJ(modname, extfl_modname)
|| SAME_OBJ(modname, futures_modname)) {
/* no unsafe, flfxnum, or futures syntax */
/* no unsafe, flfxnum, extfl, or futures syntax */
return NULL;
} else {
Scheme_Env *menv;
@ -5877,6 +5894,12 @@ Scheme_Object *scheme_builtin_value(const char *name)
if (v)
return v;
/* Try extfl next: */
a[0] = extfl_modname;
v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1);
if (v)
return v;
/* Try unsafe next: */
a[0] = unsafe_modname;
v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1);
@ -6924,6 +6947,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
if (SAME_OBJ(m->modname, kernel_modname)
|| SAME_OBJ(m->modname, unsafe_modname)
|| SAME_OBJ(m->modname, flfxnum_modname)
|| SAME_OBJ(m->modname, extfl_modname)
|| SAME_OBJ(m->modname, futures_modname)) {
/* Too confusing. Give it a different name while compiling. */
Scheme_Object *k2;
@ -6932,6 +6956,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
kname = "#%kernel";
else if (SAME_OBJ(m->modname, flfxnum_modname))
kname = "#%flfxnum";
else if (SAME_OBJ(m->modname, extfl_modname))
kname = "#%extfl";
else if (SAME_OBJ(m->modname, futures_modname))
kname = "#%futures";
else

74
src/racket/src/mzmark_type.inc
View File

@ -1334,6 +1334,50 @@ static int double_obj_FIXUP(void *p, struct NewGC *gc) {
#define double_obj_IS_CONST_SIZE 1
#ifdef MZ_LONG_DOUBLE
static int long_double_obj_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
static int long_double_obj_MARK(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
static int long_double_obj_FIXUP(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
#define long_double_obj_IS_ATOMIC 1
#define long_double_obj_IS_CONST_SIZE 1
#else
static int long_double_obj_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
static int long_double_obj_MARK(void *p, struct NewGC *gc) {
Scheme_Long_Double *ld = (Scheme_Long_Double *)p;
gcMARK2(ld->printed_form, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
static int long_double_obj_FIXUP(void *p, struct NewGC *gc) {
Scheme_Long_Double *ld = (Scheme_Long_Double *)p;
gcFIXUP2(ld->printed_form, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
#define long_double_obj_IS_ATOMIC 0
#define long_double_obj_IS_CONST_SIZE 1
#endif
static int complex_obj_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Complex));
@ -1559,6 +1603,36 @@ static int flvector_obj_FIXUP(void *p, struct NewGC *gc) {
#define flvector_obj_IS_CONST_SIZE 0
#ifdef MZ_LONG_DOUBLE
static int extflvector_obj_SIZE(void *p, struct NewGC *gc) {
Scheme_Long_Double_Vector *vec = (Scheme_Long_Double_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Long_Double_Vector)
+ ((vec->size - mzFLEX_DELTA) * sizeof(long double))));
}
static int extflvector_obj_MARK(void *p, struct NewGC *gc) {
Scheme_Long_Double_Vector *vec = (Scheme_Long_Double_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Long_Double_Vector)
+ ((vec->size - mzFLEX_DELTA) * sizeof(long double))));
}
static int extflvector_obj_FIXUP(void *p, struct NewGC *gc) {
Scheme_Long_Double_Vector *vec = (Scheme_Long_Double_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Long_Double_Vector)
+ ((vec->size - mzFLEX_DELTA) * sizeof(long double))));
}
#define extflvector_obj_IS_ATOMIC 1
#define extflvector_obj_IS_CONST_SIZE 0
#endif
static int input_port_SIZE(void *p, struct NewGC *gc) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Input_Port));

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

@ -517,6 +517,22 @@ double_obj {
gcBYTES_TO_WORDS(sizeof(Scheme_Double));
}
#ifdef MZ_LONG_DOUBLE
long_double_obj {
mark:
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
#else
long_double_obj {
mark:
Scheme_Long_Double *ld = (Scheme_Long_Double *)p;
gcMARK2(ld->printed_form, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Long_Double));
}
#endif
complex_obj {
mark:
Scheme_Complex *c = (Scheme_Complex *)p;
@ -596,6 +612,17 @@ flvector_obj {
+ ((vec->size - mzFLEX_DELTA) * sizeof(double))));
}
#ifdef MZ_LONG_DOUBLE
extflvector_obj {
Scheme_Long_Double_Vector *vec = (Scheme_Long_Double_Vector *)p;
mark:
size:
gcBYTES_TO_WORDS((sizeof(Scheme_Long_Double_Vector)
+ ((vec->size - mzFLEX_DELTA) * sizeof(long double))));
}
#endif
input_port {
mark:
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;

234
src/racket/src/numarith.c
View File

@ -65,6 +65,20 @@ static Scheme_Object *unsafe_fl_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_abs (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_sqrt (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_abs (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_sqrt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_abs (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_sqrt (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
#if defined(__POWERPC__) || defined(powerpc)
@ -229,6 +243,73 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env)
| SCHEME_PRIM_PRODUCES_FLONUM
| SCHEME_PRIM_WANTS_FLONUM_FIRST);
scheme_add_global_constant("flsqrt", p, env);
}
void scheme_init_extfl_numarith(Scheme_Env *env)
{
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(extfl_plus, "extfl+", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl+", p, env);
p = scheme_make_folding_prim(extfl_minus, "extfl-", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl-", p, env);
p = scheme_make_folding_prim(extfl_mult, "extfl*", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl*", p, env);
p = scheme_make_folding_prim(extfl_div, "extfl/", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl/", p, env);
p = scheme_make_folding_prim(extfl_abs, "extflabs", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
scheme_add_global_constant("extflabs", p, env);
p = scheme_make_folding_prim(extfl_sqrt, "extflsqrt", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
scheme_add_global_constant("extflsqrt", p, env);
}
void scheme_init_unsafe_numarith(Scheme_Env *env)
@ -346,6 +427,78 @@ void scheme_init_unsafe_numarith(Scheme_Env *env)
scheme_add_global_constant("unsafe-flsqrt", p, env);
}
void scheme_init_extfl_unsafe_numarith(Scheme_Env *env)
{
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(unsafe_extfl_plus, "unsafe-extfl+", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl+", p, env);
p = scheme_make_folding_prim(unsafe_extfl_minus, "unsafe-extfl-", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl-", p, env);
p = scheme_make_folding_prim(unsafe_extfl_mult, "unsafe-extfl*", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl*", p, env);
p = scheme_make_folding_prim(unsafe_extfl_div, "unsafe-extfl/", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_BINARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl/", p, env);
p = scheme_make_folding_prim(unsafe_extfl_abs, "unsafe-extflabs", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
scheme_add_global_constant("unsafe-extflabs", p, env);
p = scheme_make_folding_prim(unsafe_extfl_sqrt, "unsafe-extflsqrt", 1, 1, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
scheme_add_global_constant("unsafe-extflsqrt", p, env);
}
Scheme_Object *
scheme_add1 (int argc, Scheme_Object *argv[])
{
@ -1135,3 +1288,84 @@ SAFE_FL(fl_div, "fl/", /)
SAFE_FL1(fl_abs, "flabs", fabs)
SAFE_FL1(fl_sqrt, "flsqrt", sqrt)
#ifdef MZ_LONG_DOUBLE
# define UNSAFE_EXTFL(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
v = SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1]); \
return scheme_make_long_double(v); \
}
#else
# define UNSAFE_EXTFL(name, op) \
static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
{ \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
"unsafe-extfl" #op ": " NOT_SUPPORTED_STR); \
return NULL; \
}
#endif
UNSAFE_EXTFL(unsafe_extfl_plus, +)
UNSAFE_EXTFL(unsafe_extfl_minus, -)
UNSAFE_EXTFL(unsafe_extfl_mult, *)
UNSAFE_EXTFL(unsafe_extfl_div, /)
#ifdef MZ_LONG_DOUBLE
# define UNSAFE_EXTFL1(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
v = SCHEME_LONG_DBL_VAL(argv[0]); \
v = op(v); \
return scheme_make_long_double(v); \
}
#else
# define UNSAFE_EXTFL1(name, op) UNSAFE_EXTFL(name, op)
#endif
UNSAFE_EXTFL1(unsafe_extfl_abs, fabsl)
UNSAFE_EXTFL1(unsafe_extfl_sqrt, sqrtl)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL(name, sname, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
v = SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1]); \
return scheme_make_long_double(v); \
}
#else
# define SAFE_EXTFL(name, sname, op) \
static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
{ \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
sname ": " NOT_SUPPORTED_STR); \
return NULL; \
}
#endif
SAFE_EXTFL(extfl_plus, "extfl+", +)
SAFE_EXTFL(extfl_minus, "extfl-", -)
SAFE_EXTFL(extfl_mult, "extfl*", *)
SAFE_EXTFL(extfl_div, "extfl/", /)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL1(name, sname, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long double v; \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
v = SCHEME_LONG_DBL_VAL(argv[0]); \
v = op(v); \
return scheme_make_long_double(v); \
}
#else
# define SAFE_EXTFL1(name, sname, op) SAFE_EXTFL(name, sname, op)
#endif
SAFE_EXTFL1(extfl_abs, "extflabs", fabs)
SAFE_EXTFL1(extfl_sqrt, "extflsqrt", sqrt)

1122
src/racket/src/number.c
View File

File diff suppressed because it is too large Load Diff

244
src/racket/src/numcomp.c
View File

@ -70,6 +70,22 @@ static Scheme_Object *unsafe_fl_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_extfl_max (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
void scheme_init_numcomp(Scheme_Env *env)
@ -234,6 +250,77 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env)
scheme_add_global_constant("flmax", p, env);
}
void scheme_init_extfl_numcomp(Scheme_Env *env)
{
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(extfl_eq, "extfl=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl=", p, env);
p = scheme_make_folding_prim(extfl_lt, "extfl<", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl<", p, env);
p = scheme_make_folding_prim(extfl_gt, "extfl>", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl>", p, env);
p = scheme_make_folding_prim(extfl_lt_eq, "extfl<=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl<=", p, env);
p = scheme_make_folding_prim(extfl_gt_eq, "extfl>=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extfl>=", p, env);
p = scheme_make_folding_prim(extfl_min, "extflmin", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extflmin", p, env);
p = scheme_make_folding_prim(extfl_max, "extflmax", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("extflmax", p, env);
}
void scheme_init_unsafe_numcomp(Scheme_Env *env)
{
Scheme_Object *p;
@ -349,6 +436,84 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env)
scheme_add_global_constant("unsafe-flmax", p, env);
}
void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env)
{
Scheme_Object *p;
int flags;
p = scheme_make_folding_prim(unsafe_extfl_eq, "unsafe-extfl=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_lt, "unsafe-extfl<", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl<", p, env);
p = scheme_make_folding_prim(unsafe_extfl_gt, "unsafe-extfl>", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl>", p, env);
p = scheme_make_folding_prim(unsafe_extfl_lt_eq, "unsafe-extfl<=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl<=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_gt_eq, "unsafe-extfl>=", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_comp()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extfl>=", p, env);
p = scheme_make_folding_prim(unsafe_extfl_min, "unsafe-extflmin", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extflmin", p, env);
p = scheme_make_folding_prim(unsafe_extfl_max, "unsafe-extflmax", 2, 2, 1);
if (MZ_LONG_DOUBLE_AND(scheme_can_inline_fp_op()))
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
else
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_EXTFLONUM
| SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
scheme_add_global_constant("unsafe-extflmax", p, env);
}
/* Prototype needed for 3m conversion: */
static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr);
@ -656,3 +821,82 @@ UNSAFE_FL_COMP(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq)
UNSAFE_FL_BINOP(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN)
UNSAFE_FL_BINOP(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)
#ifdef MZ_LONG_DOUBLE
# define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
PRE_CHECK \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
}
#else
# define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \
static Scheme_Object * name(int argc, Scheme_Object *argv[]) \
{ \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
sname ": " NOT_SUPPORTED_STR); \
return NULL; \
}
#endif
#define SAFE_EXTFL(name, sname, op) SAFE_EXTFL_X(name, sname, op, scheme_true, scheme_false, ;)
SAFE_EXTFL(extfl_eq, "extfl=", ==)
SAFE_EXTFL(extfl_lt, "extfl<", <)
SAFE_EXTFL(extfl_gt, "extfl>", >)
SAFE_EXTFL(extfl_lt_eq, "extfl<=", <=)
SAFE_EXTFL(extfl_gt_eq, "extfl>=", >=)
#define CHECK_ARGV0_LONG_NAN { if (MZ_IS_LONG_NAN(SCHEME_LONG_DBL_VAL(argv[0]))) return argv[0]; }
SAFE_EXTFL_X(extfl_min, "extflmin", <, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
SAFE_EXTFL_X(extfl_max, "extflmax", >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
#ifdef MZ_LONG_DOUBLE
/* Unsafe EXTFL comparisons. Return boolean */
/* removed if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \ */
# define UNSAFE_EXTFL_COMP(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
}
/* Unsafe EXTFL binary operators. Return extflonum */
/* removed if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1])); \ */
# define UNSAFE_EXTFL_BINOP(name, op, T, F, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
PRE_CHECK \
if (SCHEME_LONG_DBL_VAL(argv[0]) op SCHEME_LONG_DBL_VAL(argv[1])) \
return T; \
else \
return F; \
}
#else
# define UNSAFE_EXTFL_COMP(name, op) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
"extfl" #op ": " NOT_SUPPORTED_STR); \
return NULL; \
}
# define UNSAFE_EXTFL_BINOP(name, op, T, F, PRE_CHECK) UNSAFE_EXTFL_COMP(name, op)
#endif
UNSAFE_EXTFL_COMP(unsafe_extfl_eq, ==)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt, <)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt, >)
UNSAFE_EXTFL_COMP(unsafe_extfl_lt_eq, <=)
UNSAFE_EXTFL_COMP(unsafe_extfl_gt_eq, >=)
UNSAFE_EXTFL_BINOP(unsafe_extfl_min, <, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
UNSAFE_EXTFL_BINOP(unsafe_extfl_max, >, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)

584
src/racket/src/numstr.c
View File

@ -42,6 +42,8 @@ static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[]);
static Scheme_Object *integer_to_bytes (int argc, Scheme_Object *argv[]);
static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[]);
static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[]);
static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[]);
static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[]);
static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *random_seed(int argc, Scheme_Object *argv[]);
@ -61,6 +63,12 @@ READ_ONLY static char *infinity_str = "+inf.0";
READ_ONLY static char *minus_infinity_str = "-inf.0";
READ_ONLY static char *not_a_number_str = "+nan.0";
READ_ONLY static char *other_not_a_number_str = "-nan.0";
READ_ONLY static char *long_infinity_str = "+inf.t";
READ_ONLY static char *long_minus_infinity_str = "-inf.t";
READ_ONLY static char *long_not_a_number_str = "+nan.t";
READ_ONLY static char *long_other_not_a_number_str = "-nan.t";
/* Single-precision float literals.
Due to the structure of the reader, they have to be exactly 6
characters long. */
@ -194,6 +202,20 @@ void scheme_init_numstr(Scheme_Env *env)
#endif
}
void scheme_init_extfl_numstr(Scheme_Env *env)
{
scheme_add_global_constant("floating-point-bytes->extfl",
scheme_make_prim_w_arity(bytes_to_long_double,
"floating-point-bytes->extfl",
1, 4),
env);
scheme_add_global_constant("extfl->floating-point-bytes",
scheme_make_prim_w_arity(long_double_to_bytes,
"extfl->floating-point-bytes",
1, 4),
env);
}
# ifdef SIN_COS_NEED_DEOPTIMIZE
# pragma optimize("g", off)
# define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { return c_trig(d); }
@ -209,6 +231,44 @@ MK_SCH_TRIG(SCH_COS, cos)
/* number parsing */
/*========================================================================*/
#ifndef MZ_LONG_DOUBLE
static Scheme_Object *wrap_as_long_double(const char *s, int radix)
{
Scheme_Long_Double *d;
d = MALLOC_ONE_TAGGED(Scheme_Long_Double);
d->so.type = scheme_long_double_type;
if (radix == 10)
d->printed_form = s;
else {
char *s2;
intptr_t len;
len = strlen(s);
s2 = (char *)scheme_malloc_atomic(len + 3);
memcpy(s2 + 2, s, len+1);
s2[0] = '#';
s2[1] = ((radix == 8)
? 'o'
: ((radix == 2)
? 'b'
: 'x'));
d->printed_form = s2;
}
return (Scheme_Object *)d;
}
#endif
Scheme_Object *make_any_long_double()
{
#ifdef MZ_LONG_DOUBLE
return scheme_make_long_double(0.0L);
#else
return wrap_as_long_double("1t0", 10);
#endif
}
static int u_strcmp(mzchar *s, const char *t)
{
int i;
@ -251,6 +311,28 @@ static Scheme_Object *read_special_number(const mzchar *str, int pos)
return scheme_single_nan_object;
#else
return scheme_nan_object;
#endif
}
else if (!u_strcmp(s, long_infinity_str)) {
#ifdef MZ_LONG_DOUBLE
return scheme_long_inf_object;
#else
return wrap_as_long_double(long_infinity_str, 10);
#endif
}
else if (!u_strcmp(s, long_minus_infinity_str)) {
#ifdef MZ_LONG_DOUBLE
return scheme_long_minus_inf_object;
#else
return wrap_as_long_double(long_minus_infinity_str, 10);
#endif
}
else if (!u_strcmp(s, long_not_a_number_str)
|| !u_strcmp(s, long_other_not_a_number_str)) {
#ifdef MZ_LONG_DOUBLE
return scheme_long_nan_object;
#else
return wrap_as_long_double(long_not_a_number_str, 10);
#endif
}
/* Single-precision specials
@ -282,14 +364,20 @@ static Scheme_Object *read_special_number(const mzchar *str, int pos)
return NULL;
}
#ifdef MZ_LONG_DOUBLE
# define WIDEST_DOUBLE long double
#else
# define WIDEST_DOUBLE double
#endif
/* Exponent threshold for obvious infinity. Must be at least
max(MAX_FAST_FLOATREAD_LEN, MAX_FLOATREAD_PRECISION_DIGITS) more
than the larget possible FP exponent. */
#define CHECK_INF_EXP_THRESHOLD 400
#define CHECK_INF_EXP_THRESHOLD(extfl) (extfl ? 6000 : 400)
/* Don't bother reading more than the following number of digits in a
floating-point mantissa: */
#define MAX_FLOATREAD_PRECISION_DIGITS CHECK_INF_EXP_THRESHOLD
#define MAX_FLOATREAD_PRECISION_DIGITS(extfl) CHECK_INF_EXP_THRESHOLD(extfl)
#ifdef USE_EXPLICT_FP_FORM_CHECK
@ -301,7 +389,7 @@ static Scheme_Object *read_special_number(const mzchar *str, int pos)
END_XFORM_ARITH;
# endif
static double STRTOD(const char *orig_c, char **f)
static WIDEST_DOUBLE STRTOD(const char *orig_c, char **f, int extfl)
{
int neg = 0;
int found_dot = 0, is_infinity = 0, is_zero = 0;
@ -348,7 +436,7 @@ static double STRTOD(const char *orig_c, char **f)
return 0; /* not a digit - bad! */
else {
e = (e * 10) + (ch - '0');
if (e > CHECK_INF_EXP_THRESHOLD) {
if (e > CHECK_INF_EXP_THRESHOLD(extfl)) {
if (neg_exp)
is_zero = 1;
else
@ -368,6 +456,24 @@ static double STRTOD(const char *orig_c, char **f)
*f = (char *)c;
#ifdef MZ_LONG_DOUBLE
if (is_infinity) {
if (neg)
return scheme_long_minus_infinity_val;
else
return scheme_long_infinity_val;
}
if (is_zero) {
if (neg)
return scheme_long_floating_point_nzero;
else
return scheme_long_floating_point_zero;
}
/* It's OK if c is ok: */
return strtold(orig_c, NULL);
#else
if (is_infinity) {
if (neg)
return scheme_minus_infinity_val;
@ -384,25 +490,40 @@ static double STRTOD(const char *orig_c, char **f)
/* It's OK if c is ok: */
return strtod(orig_c, NULL);
#endif
}
# ifdef MZ_XFORM_GC
START_XFORM_ARITH;
# endif
#else
#define STRTOD(x, y) strtod(x, y)
# ifdef MZ_LONG_DOUBLE
# define STRTOD(x, y, extfl) strtold(x, y)
# else
# define STRTOD(x, y, extfl) strtod(x, y)
# endif
#endif
#ifdef MZ_USE_SINGLE_FLOATS
static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s)
static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl)
{
if (s && SCHEME_DBLP(v))
return scheme_make_float((float)SCHEME_DBL_VAL(v));
else
return v;
}
#else
# define CHECK_SINGLE(v, s) v
if (SCHEME_DBLP(v)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (s)
return scheme_make_float((float)SCHEME_DBL_VAL(v));
#endif
}
return v;
}
#define DISALLOW_EXTFLONUM(special, other) \
if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \
if (report) \
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, \
"read: cannot combine extflonum into complex number: %u", \
str, len); \
return scheme_false; \
}
Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
int is_float,
@ -424,6 +545,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
#ifdef MZ_USE_SINGLE_FLOATS
int sgl;
#endif
int is_long_double = 0;
if (len < 0)
len = scheme_char_strlen(str);
@ -540,7 +662,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
s2[len - delta - 7 + 3] = '0';
s2[len - delta - 7 + 4] = 'i';
s2[len - delta - 7 + 5] = 0;
special = scheme_bin_mult(special, scheme_plus_i);
if (!SCHEME_LONG_DBLP(special))
special = scheme_bin_mult(special, scheme_plus_i);
} else
s2 = NULL;
}
@ -564,6 +687,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
stxsrc, line, col, pos, span,
indentation);
DISALLOW_EXTFLONUM(special, other);
if (dbz) {
if (div_by_zero)
*div_by_zero = 1;
@ -595,6 +720,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
return scheme_false;
}
DISALLOW_EXTFLONUM(special, special);
return special;
}
}
@ -648,6 +775,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
stxsrc, line, col, pos, span,
indentation);
DISALLOW_EXTFLONUM(special, other);
if (dbz) {
if (div_by_zero)
*div_by_zero = 1;
@ -683,7 +812,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
|| (ch == 's') || (ch == 'S') \
|| (ch == 'f') || (ch == 'F') \
|| (ch == 'd') || (ch == 'D') \
|| (ch == 'l') || (ch == 'L'))
|| (ch == 'l') || (ch == 'L') \
|| (ch == 't') || (ch == 'T'))
#define isAdigit(ch) ((ch >= '0') && (ch <= '9'))
@ -811,6 +941,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
return scheme_false;
}
DISALLOW_EXTFLONUM(n1, n2);
if (fdbz || sdbz) {
if (div_by_zero)
*div_by_zero = 1;
@ -877,7 +1009,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
stxsrc, line, col, pos, span,
indentation);
n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */
if (!SCHEME_LONG_DBLP(n2))
n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */
d2 = SCHEME_FLOAT_VAL(n2);
@ -897,13 +1030,15 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
if (n1 == zeroi)
return zeroi;
if (!SCHEME_FALSEP(n1))
if (!SCHEME_FALSEP(n1) && !SCHEME_LONG_DBLP(n1))
n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
} else {
n1 = NULL;
d2 = 0;
}
DISALLOW_EXTFLONUM(n1, n2);
if (fdbz || sdbz) {
if (div_by_zero)
*div_by_zero = 1;
@ -1064,14 +1199,21 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
}
#endif
if (has_expt && str[has_expt]) {
is_long_double = str[has_expt];
is_long_double = ((is_long_double == 't') || (is_long_double == 'T'));
} else {
is_long_double = 0;
}
#define MAX_FAST_FLOATREAD_LEN 50
/* When possible, use the standard floating-point parser */
if (!is_not_float && (is_float || decimal_means_float)
&& !has_slash && !has_hash && (radix == 10)
if (!is_not_float && (is_float || decimal_means_float)
&& !has_slash && !has_hash && (radix == 10)
&& (has_decimal || has_expt)
&& (len <= MAX_FAST_FLOATREAD_LEN)) {
double d;
&& (len <= MAX_FAST_FLOATREAD_LEN)
&& (!is_long_double || MZ_LONG_DOUBLE_AND(1))) {
WIDEST_DOUBLE d;
GC_CAN_IGNORE char *ptr;
if (has_expt && !(str[has_expt + 1])) {
@ -1104,25 +1246,36 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
loc = scheme_push_c_numeric_locale();
d = STRTOD(ffl_buf, &ptr);
d = STRTOD(ffl_buf, &ptr, is_long_double);
scheme_pop_c_numeric_locale(loc);
if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) {
if (report)
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
"read: bad decimal number %u",
str, len);
"read: bad decimal number %u",
str, len);
return scheme_false;
}
}
if (is_long_double && is_float) {
if (report)
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
"read: can convert extflonum to inexact: %u",
str, len);
return scheme_false;
}
if (!saw_nonzero_digit) {
/* Assert: d = 0.0 or -0.0 */
if (str[delta] == '-') {
/* Make sure it's -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
if (sgl) return scheme_nzerof;
#endif
#ifdef MZ_LONG_DOUBLE
if (is_long_double) return scheme_nzerol;
#endif
return scheme_nzerod;
}
@ -1133,6 +1286,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
/* Make sure it's -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
if (sgl) return scheme_nzerof;
#endif
#ifdef MZ_LONG_DOUBLE
if (is_long_double) return scheme_nzerol;
#endif
return scheme_nzerod;
}
@ -1141,6 +1297,9 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
#ifdef MZ_USE_SINGLE_FLOATS
if (sgl)
return scheme_make_float((float)d);
#endif
#ifdef MZ_LONG_DOUBLE
if (is_long_double) return scheme_make_long_double(d);
#endif
return scheme_make_double(d);
}
@ -1148,7 +1307,8 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
if (has_decimal || has_expt || (has_hash && !has_slash)) {
Scheme_Object *mantissa, *exponent, *power, *n;
Scheme_Object *args[2];
int result_is_float= (is_float || (!is_not_float && decimal_means_float));
int result_is_float = (is_float || (!is_not_float && (decimal_means_float
|| is_long_double)));
if (has_expt) {
mzchar *substr;
@ -1265,12 +1425,20 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
return scheme_false;
}
if (is_long_double && is_float) {
if (report)
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
"read: can convert extflonum to inexact: %u",
str, len);
return scheme_false;
}
/* Reduce unnecessary mantissa-reading work for inexact results.
This is also necessary to make the range check on `exponent'
correct. */
if (result_is_float && (dcp > MAX_FLOATREAD_PRECISION_DIGITS)) {
extra_power -= (dcp - MAX_FLOATREAD_PRECISION_DIGITS);
dcp = MAX_FLOATREAD_PRECISION_DIGITS;
if (result_is_float && (dcp > MAX_FLOATREAD_PRECISION_DIGITS(is_long_double))) {
extra_power -= (dcp - MAX_FLOATREAD_PRECISION_DIGITS(is_long_double));
dcp = MAX_FLOATREAD_PRECISION_DIGITS(is_long_double);
}
digits[dcp] = 0;
@ -1289,24 +1457,26 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
/* Don't calculate a huge exponential if we're returning a float: */
if (result_is_float) {
if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD))) {
if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD(is_long_double)))) {
if (scheme_is_negative(mantissa))
return CHECK_SINGLE(scheme_minus_inf_object, sgl);
return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double);
else
return CHECK_SINGLE(scheme_inf_object, sgl);
} else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD))) {
return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double);
} else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD(is_long_double)))) {
if (scheme_is_negative(mantissa))
return CHECK_SINGLE(scheme_nzerod, sgl);
return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double);
else
return CHECK_SINGLE(scheme_zerod, sgl);
return CHECK_SINGLE(scheme_zerod, sgl, is_long_double);
}
}
}
/* This is the important use of test_only, because it's the one
place where the read calculation is not linear in the input. */
if (test_only)
if (test_only) {
if (is_long_double) return make_any_long_double();
return scheme_make_integer(1);
}
args[0] = scheme_make_integer(radix);
args[1] = exponent;
@ -1314,10 +1484,29 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
n = scheme_bin_mult(mantissa, power);
if (result_is_float)
n = CHECK_SINGLE(TO_DOUBLE(n), sgl);
else
n = CHECK_SINGLE(n, sgl);
if (result_is_float) {
if (is_long_double) {
#ifdef MZ_LONG_DOUBLE
n = scheme_TO_LONG_DOUBLE(n);
if ((str[delta] == '-') && (SCHEME_LONG_DBL_VAL(n) == 0.0))
n = scheme_make_long_double(-SCHEME_LONG_DBL_VAL(n));
#else
/* simply preserve the printable format */
n = wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix);
#endif
} else {
n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0);
}
} else {
if (is_long_double) {
if (report)
scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
"read: cannot convert extflonum to exact: %u",
str, len);
return scheme_false;
}
n = CHECK_SINGLE(n, sgl, 0);
}
if (SCHEME_FLOATP(n) && str[delta] == '-') {
if (SCHEME_FLOAT_VAL(n) == 0.0) {
@ -1325,9 +1514,11 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(n)) {
n = scheme_make_float(-SCHEME_FLT_VAL(n));
} else
}
#endif
if (SCHEME_DBLP(n)) {
n = scheme_make_double(-SCHEME_DBL_VAL(n));
}
}
}
@ -1388,8 +1579,10 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
return scheme_false;
}
if (test_only)
if (test_only) {
if (is_long_double) return make_any_long_double();
return scheme_make_integer(1);
}
n1 = scheme_bin_div(n1, n2);
@ -1407,7 +1600,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
} else if (is_float)
n1 = TO_DOUBLE(n1);
return CHECK_SINGLE(n1, sgl);
return CHECK_SINGLE(n1, sgl, 0);
}
o = scheme_read_bignum(str, delta, radix);
@ -1425,7 +1618,7 @@ Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
return scheme_nzerod;
}
return CHECK_SINGLE(TO_DOUBLE(o), sgl);
return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0);
}
return o;
@ -1528,79 +1721,106 @@ string_to_number (int argc, Scheme_Object *argv[])
0, NULL, 0, 0, 0, 0,
NULL);
if (SCHEME_LONG_DBLP(v))
return scheme_false;
return v;
}
char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer)
char *scheme_X_double_to_string (WIDEST_DOUBLE d, char* s, int slen, int was_single, int extfl, int *used_buffer)
{
if (MZ_IS_NAN(d))
if (MZ_IS_NAN(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
s = single_not_a_number_str;
else
if (was_single) return single_not_a_number_str;
#endif
s = not_a_number_str;
else if (MZ_IS_POS_INFINITY(d))
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_not_a_number_str;
#endif
return not_a_number_str;
} else if (MZ_IS_POS_INFINITY(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
s = single_infinity_str;
else
if (was_single) return single_infinity_str;
#endif
s = infinity_str;
else if (MZ_IS_NEG_INFINITY(d))
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_infinity_str;
#endif
return infinity_str;
} else if (MZ_IS_NEG_INFINITY(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
s = single_minus_infinity_str;
else
if (was_single) return single_minus_infinity_str;
#endif
s = minus_infinity_str;
else if (d == 0.0) {
#ifdef MZ_LONG_DOUBLE
if (extfl) return long_minus_infinity_str;
#endif
return minus_infinity_str;
} else if (d == 0.0) {
/* Check for -0.0, since some printers get it wrong. */
if (scheme_minus_zero_p(d))
if (scheme_long_minus_zero_p(d)) {
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
/* The f0 suffix causes the string to be read as a single-
precision float. */
s = "-0.0f0";
else
if (was_single) return "-0.0f0";
#endif
s = "-0.0";
else
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single)
s = "0.0f0";
else
if (extfl) return "-0.0t0";
#endif
s = "0.0";
return "-0.0";
}
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) return "0.0f0";
#endif
#ifdef MZ_USE_SINGLE_FLOATS
if (extfl) return "0.0t0";
#endif
return "0.0";
} else {
/* Initial count for significant digits is 14 (double) or 6 digits
(single). That's big enough to get most right, small enough to
avoid nonsense digits. But we'll loop in case it's not precise
enough to get read-write invariance: */
/* Initial count for significant digits is 14 (double), 6 digits
(single), or 18 (extended). That's big enough to get most
right, small enough to avoid nonsense digits. But we'll loop in
case it's not precise enough to get read-write invariance: */
int i, l, digits;
GC_CAN_IGNORE char *loc;
char *buffer = s;
if (was_single)
digits = 6;
else if (extfl)
digits = 18;
else
digits = 14;
loc = scheme_push_c_numeric_locale();
while (digits < 30 && digits < slen) {
double check;
WIDEST_DOUBLE check;
GC_CAN_IGNORE char *ptr;
sprintf(buffer, "%.*g", digits, d);
#ifdef MZ_LONG_DOUBLE
if (extfl)
sprintf(buffer, "%.*Lg", digits, d);
else
#endif
sprintf(buffer, "%.*g", digits, (double)d);
/* Did we get read-write invariance, yet? */
check = strtod(buffer, &ptr);
if (was_single) {
#ifdef MZ_LONG_DOUBLE
if (extfl)
check = strtold(buffer, &ptr);
else
#endif
check = strtod(buffer, &ptr);
if (0)
break;
#ifdef MZ_USE_SINGLE_FLOATS
else if (was_single) {
if ((float)check == (float)d)
break;
} else {
#endif
#ifdef MZ_USE_SINGLE_FLOATS
} else if (extfl) {
if (check == d)
break;
}
#endif
} else
if ((double)check == (double)d)
break;
digits++;
}
scheme_pop_c_numeric_locale(loc);
@ -1616,22 +1836,22 @@ char *scheme_double_to_string (double d, char* s, int slen, int was_single, int
buffer[i + 2] = 0;
l += 2;
}
#ifdef MZ_USE_SINGLE_FLOATS
if (was_single) {
/* In case of a single-precision float, add the f0 suffix (or
replace the existing e exponent separator) to cause the
string to be read back as a single-precision float. */
#if defined(MZ_USE_SINGLE_FLOATS) || defined(MZ_LONG_DOUBLE)
if (was_single || extfl) {
/* In case of a single-precision or extend-prevision float, add
the f0 or t0 suffix, or replace the existing e exponent
separator. */
for (i = 0; i < l; i++) {
if (buffer[i] == 'e')
break;
}
if (i == l) {
buffer[l] = 'f';
buffer[l] = (was_single ? 'f' : 't');
buffer[l + 1] = '0';
buffer[l + 2] = 0;
l += 2;
} else {
buffer[i] = 'f';
buffer[i] = (was_single ? 'f' : 't');
}
}
#endif
@ -1641,12 +1861,17 @@ char *scheme_double_to_string (double d, char* s, int slen, int was_single, int
return s;
}
static char *double_to_string (double d, int alloc, int was_single)
char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer)
{
return scheme_X_double_to_string(d, s, slen, was_single, 0, used_buffer);
}
static char *double_to_string (WIDEST_DOUBLE d, int alloc, int was_single, int extfl)
{
char buffer[100];
char *s;
int used_buffer = 0;
s = scheme_double_to_string(d, buffer, 100, was_single, &used_buffer);
s = scheme_X_double_to_string(d, buffer, 100, was_single, extfl, &used_buffer);
if (used_buffer) {
s = (char *)scheme_malloc_atomic(strlen(buffer) + 1);
@ -1666,6 +1891,13 @@ static char *double_to_string (double d, int alloc, int was_single)
return s;
}
#ifdef MZ_LONG_DOUBLE
char *scheme_long_double_to_string (long double d, char* s, int slen, int *used_buffer)
{
return scheme_X_double_to_string(d, s, slen, 0, 1, used_buffer);
}
#endif
static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
{
char *s;
@ -1677,7 +1909,19 @@ static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc
"number", 1, obj,
"requested base", 1, scheme_make_integer(radix),
NULL);
s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc, SCHEME_FLTP(obj));
s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc, SCHEME_FLTP(obj), 0);
} else if (SCHEME_LONG_DBLP(obj)) {
if (radix != 10)
scheme_contract_error("number->string",
"extflonum numbers can only be printed in base 10",
"number", 1, obj,
"requested base", 1, scheme_make_integer(radix),
NULL);
#ifdef MZ_LONG_DOUBLE
s = double_to_string(SCHEME_LONG_DBL_VAL(obj), alloc, 0, 1);
#else
s = (char *)((Scheme_Long_Double *)obj)->printed_form;
#endif
} else if (SCHEME_RATIONALP(obj)) {
Scheme_Object *n, *d;
char *ns, *ds;
@ -1751,6 +1995,26 @@ int scheme_check_double(const char *where, double d, const char *dest)
return 1;
}
#ifdef MZ_LONG_DOUBLE
int scheme_check_long_double(const char *where, long double d, const char *dest)
{
if (MZ_IS_LONG_INFINITY(d)
|| MZ_IS_LONG_NAN(d)) {
if (where) {
char buf[36]; /* What is the length? */
sprintf(buf, "no %s representation", dest);
scheme_contract_error(where,
buf,
"number", 1, scheme_make_long_double(d),
NULL);
}
return 0;
}
return 1;
}
#endif
/*========================================================================*/
/* native representations */
/*========================================================================*/
@ -2232,6 +2496,138 @@ static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[])
return s;
}
/* Assume that the content of a `long double' occupies the first 10
bytes: */
#define LONG_DOUBLE_BYTE_LEN 10
static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
intptr_t offset = 0, slen;
char *str, buf[sizeof(long double)];
int bigend = MZ_IS_BIG_ENDIAN;
long double d;
if (!SCHEME_BYTE_STRINGP(argv[0]))
scheme_wrong_contract("floating-point-bytes->extfl", "bytes?", 0, argc, argv);
if (argc > 2) {
intptr_t start, finish;
scheme_get_substring_indices("floating-point-bytes->extfl", argv[0],
argc, argv,
2, 3, &start, &finish);
offset = start;
slen = finish - start;
} else {
offset = 0;
slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
}
if (slen != LONG_DOUBLE_BYTE_LEN)
scheme_contract_error("floating-point-bytes->extfl",
"length is not 10 bytes",
"length", 1, scheme_make_integer(slen),
NULL);
str = SCHEME_BYTE_STR_VAL(argv[0]);
if (argc > 1)
bigend = SCHEME_TRUEP(argv[1]);
if (bigend != MZ_IS_BIG_ENDIAN) {
int i;
for (i = 0; i < slen; i++) {
buf[slen - i - 1] = str[offset + i];
}
} else {
memcpy(buf, str + offset, slen);
}
str = buf;
memcpy(&d, str, LONG_DOUBLE_BYTE_LEN);
return scheme_make_long_double(d);
#else
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"floating-point-bytes->extfl: " NOT_SUPPORTED_STR);
return NULL;
#endif
}
static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
Scheme_Object *n, *s;
int size = LONG_DOUBLE_BYTE_LEN;
int bigend = MZ_IS_BIG_ENDIAN;
long double d;
intptr_t offset = 0;
n = argv[0];
if (!SCHEME_LONG_DBLP(n))
scheme_wrong_contract("extfl->floating-point-bytes", "extflonum?", 0, argc, argv);
if (argc > 1)
bigend = SCHEME_TRUEP(argv[1]);
if (argc > 2) {
s = argv[2];
if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
scheme_wrong_contract("extfl->floating-point-bytes", "(and/c bytes? (not/c immutable?))", 2, argc, argv);
if (argc > 3) {
intptr_t start, finish;
scheme_get_substring_indices("extfl->floating-point-bytes", s,
argc, argv,
3, 4, &start, &finish);
offset = start;
} else
offset = 0;
} else
s = scheme_make_sized_byte_string("1234567890", size, 1);
if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
scheme_contract_error("extfl->floating-point-bytes",
"byte string length is shorter than starting position plus size",
"byte string length", 1, scheme_make_integer(SCHEME_BYTE_STRLEN_VAL(s)),
"starting position", 1, scheme_make_integer(offset),
"size", 1, scheme_make_integer(size),
NULL);
return NULL;
}
d = SCHEME_LONG_DBL_VAL(n);
memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, LONG_DOUBLE_BYTE_LEN);
if (bigend != MZ_IS_BIG_ENDIAN) {
int i;
char buf[LONG_DOUBLE_BYTE_LEN], *str;
str = SCHEME_BYTE_STR_VAL(s);
for (i = 0; i < size; i++) {
buf[size - i - 1] = str[offset + i];
}
for (i = 0; i < size; i++) {
str[offset + i] = buf[i];
}
}
return s;
#else
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"extfl->floating-point-bytes: " NOT_SUPPORTED_STR);
return NULL;
#endif
}
static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[])
{
#if MZ_IS_BIG_ENDIAN

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

@ -1890,6 +1890,19 @@ static int wants_local_type_arguments(Scheme_Object *rator, int argpos)
if (flags & SCHEME_PRIM_WANTS_FLONUM_THIRD)
return SCHEME_LOCAL_TYPE_FLONUM;
}
#ifdef MZ_LONG_DOUBLE
if (argpos == 0) {
if (flags & SCHEME_PRIM_WANTS_EXTFLONUM_FIRST)
return SCHEME_LOCAL_TYPE_EXTFLONUM;
} else if (argpos == 1) {
if (flags & SCHEME_PRIM_WANTS_EXTFLONUM_SECOND)
return SCHEME_LOCAL_TYPE_EXTFLONUM;
} else if (argpos == 2) {
if (flags & SCHEME_PRIM_WANTS_EXTFLONUM_THIRD)
return SCHEME_LOCAL_TYPE_EXTFLONUM;
}
#endif
}
return 0;
@ -1945,6 +1958,10 @@ int scheme_expr_produces_local_type(Scheme_Object *expr)
default:
if (SCHEME_FLOATP(expr))
return SCHEME_LOCAL_TYPE_FLONUM;
#ifdef MZ_LONG_DOUBLE
if (SCHEME_LONG_DBLP(expr))
return SCHEME_LOCAL_TYPE_EXTFLONUM;
#endif
if (SCHEME_INTP(expr)
&& IN_FIXNUM_RANGE_ON_ALL_PLATFORMS(SCHEME_INT_VAL(expr)))
return SCHEME_LOCAL_TYPE_FIXNUM;
@ -2606,6 +2623,32 @@ static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimiz
if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0))
return scheme_make_double(0.0);
}
#ifdef MZ_LONG_DOUBLE
z1 = (SCHEME_LONG_DBLP(app->rand1) && (SCHEME_LONG_DBL_VAL(app->rand1) == 0.0L));
z2 = (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 0.0L));
if (IS_NAMED_PRIM(app->rator, "unsafe-extfl+")) {
if (z1)
return app->rand2;
else if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl-")) {
if (z2)
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl*")) {
if (SCHEME_LONG_DBLP(app->rand1) && (SCHEME_LONG_DBL_VAL(app->rand1) == 1.0L))
return app->rand2;
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extfl/")) {
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
return app->rand1;
} else if (IS_NAMED_PRIM(app->rator, "unsafe-extflremainder")
|| IS_NAMED_PRIM(app->rator, "unsafe-extflmodulo")) {
if (SCHEME_LONG_DBLP(app->rand2) && (SCHEME_LONG_DBL_VAL(app->rand2) == 1.0L))
return scheme_make_long_double(0.0L);
}
#endif
}
register_local_argument_types(NULL, NULL, app, info);

25
src/racket/src/place.c
View File

@ -1241,6 +1241,9 @@ static Scheme_Object *trivial_copy(Scheme_Object *so, Scheme_Object **master_cha
return so;
case scheme_byte_string_type:
case scheme_flvector_type:
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
#endif
case scheme_fxvector_type:
if (SHARED_ALLOCATEDP(so)) {
scheme_hash_key(so);
@ -1320,6 +1323,12 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h
if (copy_mode)
new_so = scheme_make_double(SCHEME_DBL_VAL(so));
break;
#ifdef MZ_LONG_DOUBLE
case scheme_long_double_type:
if (copy_mode)
new_so = scheme_make_long_double(SCHEME_LONG_DBL_VAL(so));
break;
#endif
case scheme_complex_type:
if (copy_mode) {
Scheme_Object *r;
@ -1408,6 +1417,22 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h
new_so = (Scheme_Object *) vec;
}
break;
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
/* not allocated as shared, since that's covered above */
if (copy_mode) {
Scheme_Long_Double_Vector *vec;
intptr_t i;
intptr_t size = SCHEME_EXTFLVEC_SIZE(so);
vec = scheme_alloc_extflvector(size);
for (i = 0; i < size; i++) {
SCHEME_EXTFLVEC_ELS(vec)[i] = SCHEME_EXTFLVEC_ELS(so)[i];
}
new_so = (Scheme_Object *) vec;
}
break;
#endif
case scheme_cpointer_type:
if (SCHEME_CPTR_FLAGS(so) & 0x1) {
if (copy_mode) {

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

@ -169,8 +169,6 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin
(SCHEME_PAIRP(obj) \
|| SCHEME_MUTABLE_PAIRP(obj) \
|| SCHEME_CHAPERONE_VECTORP(obj) \
|| SCHEME_FLVECTORP(obj) \
|| SCHEME_FXVECTORP(obj) \
|| (qk(pp->print_box, 1) && SCHEME_CHAPERONE_BOXP(obj)) \
|| (qk(pp->print_struct \
&& SCHEME_CHAPERONE_STRUCTP(obj) \
@ -536,8 +534,6 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
|| SCHEME_MUTABLE_PAIRP(obj)
|| (pp->print_box && SCHEME_CHAPERONE_BOXP(obj))
|| SCHEME_CHAPERONE_VECTORP(obj)
|| SCHEME_FLVECTORP(obj)
|| SCHEME_FXVECTORP(obj)
|| (SCHEME_CHAPERONE_STRUCTP(obj)
&& ((pp->print_struct
&& PRINTABLE_STRUCT(obj, pp))
@ -593,7 +589,8 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht
if ((for_write < 3) && res)
return res;
}
} else if (SCHEME_FLVECTORP(obj) || SCHEME_FXVECTORP(obj)) {
} else if (SCHEME_FLVECTORP(obj)
|| SCHEME_FXVECTORP(obj)) {
res = 0x1; /* escape for qq printing */
} else if (SCHEME_CHAPERONE_STRUCTP(obj)) {
if (scheme_is_writable_struct(obj)) {
@ -803,7 +800,8 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec
cycle = -1;
} else if (SCHEME_CHAPERONEP(obj))
cycle = -1; /* no fast checks for chaperones */
else if ((write >= 3) && (SCHEME_FLVECTORP(obj) || SCHEME_FXVECTORP(obj)))
else if ((write >= 3) && (SCHEME_FLVECTORP(obj)
|| SCHEME_FXVECTORP(obj)))
cycle = -1; /* needs unquote */
else
cycle = 0;
@ -2219,7 +2217,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_utf8_string(pp, quick_buffer, 0, -1);
}
}
else if (SCHEME_NUMBERP(obj))
else if (SCHEME_NUMBERP(obj) || SCHEME_LONG_DBLP(obj))
{
if (compact) {
print_escaped(pp, notdisplay, obj, ht, mt, 1);

46
src/racket/src/ratfloat.inc
View File

@ -1,14 +1,23 @@
/* Optimization sometimes causes a problem: n or d is represented in an
extended format instead of a `double'. We don't want to turn off
floatng-point optimizations in the rest of the program, so we use a
little function to defeat the optimization: */
/* Back when we didn't set force the FP mode to double-precision on
x87, compiler optimization would make n or d is represented in an
extended format instead of a `double'. We didn't want to turn off
floating-point optimizations in the rest of the program, so we used
a little function to defeat the optimization. This is almost
certainly not necessary anymore. */
FP_TYPE DO_FLOAT_DIV(FP_TYPE n, FP_TYPE d)
{
return n / d;
}
#ifndef FP_ZEROx
# define FP_ZEROx 0
# define FP_POWx pow
# define FP_MODFx modf
# define FP_FREXPx frexp
# define FP_DOUBLE_TYPE double
#endif
FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
{
@ -82,7 +91,7 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
else
res = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(n, 0, NULL);
res = res * pow(2, p - shift);
res = res * FP_POWx(2, p - shift);
if (SCHEME_INTP(r->num)) {
if (SCHEME_INT_VAL(r->num) < 0)
@ -99,12 +108,12 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
{
double frac, i;
FP_DOUBLE_TYPE frac, i;
int count, exponent, is_neg;
Scheme_Object *int_part, *frac_part, *frac_num, *frac_denom, *two, *result;
#ifdef COMPUTE_NEG_INEXACT_TO_EXACT_AS_POS
int negate;
if (d < 0) {
if (d < FP_ZEROx) {
d = -d;
negate = 1;
} else
@ -113,10 +122,10 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
SCHEME_CHECK_FLOAT("inexact->exact", d, "exact");
is_neg = (d < 0);
is_neg = (d < FP_ZEROx);
frac = modf((double)d, &i);
(void)frexp(d, &exponent);
frac = FP_MODFx((FP_DOUBLE_TYPE)d, &i);
(void)FP_FREXPx(d, &exponent);
int_part = SCHEME_BIGNUM_FROM_FLOAT(i);
@ -137,7 +146,7 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
count++;
frac_num = scheme_bin_mult(frac_num, two);
frac_denom = scheme_bin_mult(frac_denom, two);
frac = modf(ldexp(frac, 1), &i);
frac = FP_MODFx(ldexp(frac, 1), &i);
if (i) {
if (is_neg)
frac_num = scheme_bin_minus(frac_num, one);
@ -157,3 +166,18 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
return result;
}
#undef FP_TYPE
#undef SCHEME_RATIONAL_TO_FLOAT
#undef SCHEME_RATIONAL_FROM_FLOAT
#undef SCHEME_BIGNUM_TO_FLOAT_INF_INFO
#undef SCHEME_BIGNUM_FROM_FLOAT
#undef SCHEME_CHECK_FLOAT
#undef DO_FLOAT_DIV
#undef FLOAT_E_MIN
#undef FLOAT_M_BITS
#undef FP_ZEROx
#undef FP_POWx
#undef FP_MODFx
#undef FP_FREXPx
#undef FP_DOUBLE_TYPE

27
src/racket/src/rational.c
View File

@ -527,16 +527,6 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
#include "ratfloat.inc"
#ifdef MZ_USE_SINGLE_FLOATS
# undef FP_TYPE
# undef SCHEME_RATIONAL_TO_FLOAT
# undef SCHEME_RATIONAL_FROM_FLOAT
# undef SCHEME_BIGNUM_TO_FLOAT_INF_INFO
# undef SCHEME_BIGNUM_FROM_FLOAT
# undef SCHEME_CHECK_FLOAT
# undef DO_FLOAT_DIV
# undef FLOAT_E_MIN
# undef FLOAT_M_BITS
#define FP_TYPE float
#define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_float
#define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_float
@ -549,3 +539,20 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
#include "ratfloat.inc"
#endif
#ifdef MZ_LONG_DOUBLE
# define FP_TYPE long double
# define SCHEME_RATIONAL_TO_FLOAT scheme_rational_to_long_double
# define SCHEME_RATIONAL_FROM_FLOAT scheme_rational_from_long_double
# define SCHEME_BIGNUM_TO_FLOAT_INF_INFO scheme_bignum_to_long_double_inf_info
# define SCHEME_CHECK_FLOAT scheme_check_long_double
# define SCHEME_BIGNUM_FROM_FLOAT scheme_bignum_from_long_double
# define DO_FLOAT_DIV scheme__do_long_double_div
# define FLOAT_E_MIN -16383
# define FLOAT_M_BITS 64
# define FP_ZEROx 0L
# define FP_POWx powl
# define FP_MODFx modfl
# define FP_FREXPx frexpl
# define FP_DOUBLE_TYPE FP_TYPE
#include "ratfloat.inc"
#endif

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

@ -4776,6 +4776,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT
+ EXPECTED_UNSAFE_COUNT
+ EXPECTED_FLFXNUM_COUNT
+ EXPECTED_EXTFL_COUNT
+ EXPECTED_FUTURES_COUNT));
return variable_references[l];
break;

5
src/racket/src/salloc.c
View File

@ -2869,6 +2869,11 @@ intptr_t scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht)
case scheme_double_type:
s = sizeof(Scheme_Double);
break;
#ifdef MZ_LONG_DOUBLE
case scheme_long_double_type:
s = sizeof(Scheme_Long_Double);
break;
#endif
case scheme_float_type:
break;
case scheme_char_string_type:

17
src/racket/src/schemef.h
View File

@ -607,6 +607,9 @@ MZ_EXTERN mzchar *scheme_string_recase(mzchar *s, int d, int len, int mode, int
MZ_EXTERN Scheme_Object *scheme_make_vector(intptr_t size, Scheme_Object *fill);
MZ_EXTERN Scheme_Double_Vector *scheme_alloc_flvector(intptr_t size);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN Scheme_Long_Double_Vector *scheme_alloc_extflvector(intptr_t size);
#endif
MZ_EXTERN Scheme_Vector *scheme_alloc_fxvector(intptr_t size);
MZ_EXTERN Scheme_Object *scheme_make_integer_value(intptr_t i);
MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned(uintptr_t i);
@ -615,6 +618,9 @@ MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned_long_long(umzlo
MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_long_halves(uintptr_t lowhalf, uintptr_t hihalf);
MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned_long_halves(uintptr_t lowhalf, uintptr_t hihalf);
MZ_EXTERN Scheme_Object *scheme_make_double(double d);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN Scheme_Object *scheme_make_long_double(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
MZ_EXTERN Scheme_Object *scheme_make_float(float f) ;
#endif
@ -636,6 +642,9 @@ XFORM_NONGCING MZ_EXTERN int scheme_get_long_long_val(Scheme_Object *o, mzlonglo
XFORM_NONGCING MZ_EXTERN int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v);
MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN long double scheme_real_to_long_double(Scheme_Object *r);
#endif
MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, intptr_t offset, Scheme_Object *typetag);
@ -697,6 +706,10 @@ MZ_EXTERN Scheme_Object *scheme_make_bignum_from_long_long(mzlonglong v);
MZ_EXTERN Scheme_Object *scheme_make_bignum_from_unsigned_long_long(umzlonglong v);
XFORM_NONGCING MZ_EXTERN double scheme_bignum_to_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_double(double d);
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING MZ_EXTERN long double scheme_bignum_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_long_double(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
XFORM_NONGCING MZ_EXTERN float scheme_bignum_to_float(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_bignum_from_float(float d);
@ -717,6 +730,10 @@ XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_bignum_normalize(const Scheme_Obj
MZ_EXTERN Scheme_Object *scheme_make_rational(const Scheme_Object *r, const Scheme_Object *d);
MZ_EXTERN double scheme_rational_to_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_double(double d);
#ifdef MZ_LONG_DOUBLE
MZ_EXTERN long double scheme_rational_to_long_double(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_long_double(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
MZ_EXTERN float scheme_rational_to_float(const Scheme_Object *n);
MZ_EXTERN Scheme_Object *scheme_rational_from_float(float d);

17
src/racket/src/schemex.h
View File

@ -485,6 +485,9 @@ Scheme_Object *(*scheme_append_char_string)(Scheme_Object *, Scheme_Object *);
mzchar *(*scheme_string_recase)(mzchar *s, int d, int len, int mode, int inplace, int *_len);
Scheme_Object *(*scheme_make_vector)(intptr_t size, Scheme_Object *fill);
Scheme_Double_Vector *(*scheme_alloc_flvector)(intptr_t size);
#ifdef MZ_LONG_DOUBLE
Scheme_Long_Double_Vector *(*scheme_alloc_extflvector)(intptr_t size);
#endif
Scheme_Vector *(*scheme_alloc_fxvector)(intptr_t size);
Scheme_Object *(*scheme_make_integer_value)(intptr_t i);
Scheme_Object *(*scheme_make_integer_value_from_unsigned)(uintptr_t i);
@ -493,6 +496,9 @@ Scheme_Object *(*scheme_make_integer_value_from_unsigned_long_long)(umzlonglong
Scheme_Object *(*scheme_make_integer_value_from_long_halves)(uintptr_t lowhalf, uintptr_t hihalf);
Scheme_Object *(*scheme_make_integer_value_from_unsigned_long_halves)(uintptr_t lowhalf, uintptr_t hihalf);
Scheme_Object *(*scheme_make_double)(double d);
#ifdef MZ_LONG_DOUBLE
Scheme_Object *(*scheme_make_long_double)(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
Scheme_Object *(*scheme_make_float)(float f) ;
#endif
@ -511,6 +517,9 @@ int (*scheme_get_unsigned_int_val)(Scheme_Object *o, uintptr_t *v);
int (*scheme_get_long_long_val)(Scheme_Object *o, mzlonglong *v);
int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
double (*scheme_real_to_double)(Scheme_Object *r);
#ifdef MZ_LONG_DOUBLE
long double;
#endif
Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, intptr_t offset, Scheme_Object *typetag);
Scheme_Object *(*scheme_make_external_cptr)(void *cptr, Scheme_Object *typetag);
@ -561,6 +570,10 @@ Scheme_Object *(*scheme_make_bignum_from_long_long)(mzlonglong v);
Scheme_Object *(*scheme_make_bignum_from_unsigned_long_long)(umzlonglong v);
double (*scheme_bignum_to_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_bignum_from_double)(double d);
#ifdef MZ_LONG_DOUBLE
long double;
Scheme_Object *(*scheme_bignum_from_long_double)(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
float (*scheme_bignum_to_float)(const Scheme_Object *n);
Scheme_Object *(*scheme_bignum_from_float)(float d);
@ -579,6 +592,10 @@ Scheme_Object *(*scheme_bignum_normalize)(const Scheme_Object *n);
Scheme_Object *(*scheme_make_rational)(const Scheme_Object *r, const Scheme_Object *d);
double (*scheme_rational_to_double)(const Scheme_Object *n);
Scheme_Object *(*scheme_rational_from_double)(double d);
#ifdef MZ_LONG_DOUBLE
long double;
Scheme_Object *(*scheme_rational_from_long_double)(long double d);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
float (*scheme_rational_to_float)(const Scheme_Object *n);
Scheme_Object *(*scheme_rational_from_float)(float d);

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

@ -12,11 +12,12 @@
finally, set EXPECTED_PRIM_COUNT to the right value and
USE_COMPILED_STARTUP to 1 and `make' again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1085
#define EXPECTED_UNSAFE_COUNT 80
#define EXPECTED_UNSAFE_COUNT 98
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15
#ifdef MZSCHEME_SOMETHING_OMITTED

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

@ -37,10 +37,12 @@
/*========================================================================*/
/* 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_LOCAL_TYPE_FLONUM 1
#define SCHEME_LOCAL_TYPE_FIXNUM 2
#define SCHEME_LOCAL_TYPE_EXTFLONUM 3
#define SCHEME_MAX_LOCAL_TYPE 3
#define SCHEME_MAX_LOCAL_TYPE 2
#define SCHEME_MAX_LOCAL_TYPE_MASK 0x3
#define SCHEME_MAX_LOCAL_TYPE_BITS 2
@ -62,8 +64,11 @@
#define SCHEME_PRIM_WANTS_FLONUM_FIRST 64
#define SCHEME_PRIM_WANTS_FLONUM_SECOND 128
#define SCHEME_PRIM_WANTS_FLONUM_THIRD 256
#define SCHEME_PRIM_WANTS_EXTFLONUM_FIRST 512
#define SCHEME_PRIM_WANTS_EXTFLONUM_SECOND 1024
#define SCHEME_PRIM_WANTS_EXTFLONUM_THIRD 2048
#define SCHEME_PRIM_OPT_TYPE_SHIFT 9
#define SCHEME_PRIM_OPT_TYPE_SHIFT 12
#define SCHEME_PRIM_OPT_TYPE_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_PRIM_OPT_TYPE_SHIFT)
#define SCHEME_PRIM_OPT_TYPE(x) ((x & SCHEME_PRIM_OPT_TYPE_MASK) >> SCHEME_PRIM_OPT_TYPE_SHIFT)
@ -72,6 +77,9 @@
#define SCHEME_PRIM_WANTS_FLONUM_BOTH (SCHEME_PRIM_WANTS_FLONUM_FIRST | SCHEME_PRIM_WANTS_FLONUM_SECOND)
#define SCHEME_PRIM_PRODUCES_EXTFLONUM (SCHEME_LOCAL_TYPE_EXTFLONUM << SCHEME_PRIM_OPT_TYPE_SHIFT)
#define SCHEME_PRIM_WANTS_EXTFLONUM_BOTH (SCHEME_PRIM_WANTS_EXTFLONUM_FIRST | SCHEME_PRIM_WANTS_EXTFLONUM_SECOND)
extern int scheme_prim_opt_flags[]; /* uses an index from SCHEME_PRIM_OPT_INDEX_MASK */
extern XFORM_NONGCING int scheme_intern_prim_opt_flags(int);
@ -268,14 +276,21 @@ void scheme_init_unsafe_vector(Scheme_Env *env);
void scheme_init_string(Scheme_Env *env);
void scheme_init_number(Scheme_Env *env);
void scheme_init_flfxnum_number(Scheme_Env *env);
void scheme_init_extfl_number(Scheme_Env *env);
void scheme_init_unsafe_number(Scheme_Env *env);
void scheme_init_extfl_unsafe_number(Scheme_Env *env);
void scheme_init_numarith(Scheme_Env *env);
void scheme_init_flfxnum_numarith(Scheme_Env *env);
void scheme_init_extfl_numarith(Scheme_Env *env);
void scheme_init_unsafe_numarith(Scheme_Env *env);
void scheme_init_extfl_unsafe_numarith(Scheme_Env *env);
void scheme_init_numcomp(Scheme_Env *env);
void scheme_init_flfxnum_numcomp(Scheme_Env *env);
void scheme_init_extfl_numcomp(Scheme_Env *env);
void scheme_init_unsafe_numcomp(Scheme_Env *env);
void scheme_init_extfl_unsafe_numcomp(Scheme_Env *env);
void scheme_init_numstr(Scheme_Env *env);
void scheme_init_extfl_numstr(Scheme_Env *env);
void scheme_init_eval(Scheme_Env *env);
void scheme_init_promise(Scheme_Env *env);
void scheme_init_struct(Scheme_Env *env);
@ -1843,6 +1858,12 @@ intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p);
# define scheme_exact_one scheme_make_integer(1)
#endif
#ifdef MZ_LONG_DOUBLE
# define MZ_LONG_DOUBLE_AND(x) (x)
#else
# define MZ_LONG_DOUBLE_AND(x) 0
#endif
void scheme_configure_floating_point(void);
/****** Bignums *******/
@ -1880,6 +1901,9 @@ typedef struct {
XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(intptr_t v, Small_Bignum *s);
char *scheme_number_to_string(int radix, Scheme_Object *obj);
char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer);
#ifdef MZ_LONG_DOUBLE
char *scheme_long_double_to_string (long double d, char* s, int slen, int *used_buffer);
#endif
Scheme_Object *scheme_bignum_copy(const Scheme_Object *n);
@ -1914,6 +1938,9 @@ Scheme_Object *scheme_bignum_not(const Scheme_Object *a);
Scheme_Object *scheme_bignum_shift(const Scheme_Object *a, intptr_t shift);
XFORM_NONGCING double scheme_bignum_to_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING long double scheme_bignum_to_long_double_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
XFORM_NONGCING float scheme_bignum_to_float_inf_info(const Scheme_Object *n, intptr_t just_use, intptr_t *only_need);
#else
@ -1995,6 +2022,9 @@ XFORM_NONGCING int scheme_is_complex_exact(const Scheme_Object *o);
#define REAL_NUMBER_STR "real number"
int scheme_check_double(const char *where, double v, const char *dest);
#ifdef MZ_LONG_DOUBLE
int scheme_check_long_double(const char *where, long double v, const char *dest);
#endif
#ifdef MZ_USE_SINGLE_FLOATS
int scheme_check_float(const char *where, float v, const char *dest);
#else
@ -2004,6 +2034,13 @@ int scheme_check_float(const char *where, float v, const char *dest);
double scheme_get_val_as_double(const Scheme_Object *n);
XFORM_NONGCING int scheme_minus_zero_p(double d);
#ifdef MZ_LONG_DOUBLE
long double scheme_get_val_as_long_double(const Scheme_Object *n);
XFORM_NONGCING int scheme_long_minus_zero_p(long double d);
#else
# define scheme_long_minus_zero_p(d) scheme_minus_zero_p(d)
#endif
#ifdef MZ_USE_SINGLE_FLOATS
float scheme_get_val_as_float(const Scheme_Object *n);
#endif
@ -2046,10 +2083,10 @@ extern int scheme_is_nan(double);
# define MZ_IS_NAN(d) isnan(d)
# else
# ifdef USE_CARBON_FP_PREDS
# define MZ_IS_INFINITY(d) (!__isfinited(d))
# define MZ_IS_POS_INFINITY(d) (!__isfinited(d) && (d > 0))
# define MZ_IS_NEG_INFINITY(d) (!__isfinited(d) && (d < 0))
# define MZ_IS_NAN(d) __isnand(d)
# define MZ_IS_INFINITY(d) (!__isfinite(d))
# define MZ_IS_POS_INFINITY(d) (!__isfinite(d) && (d > 0))
# define MZ_IS_NEG_INFINITY(d) (!__isfinite(d) && (d < 0))
# define MZ_IS_NAN(d) __isnan(d)
# else
# ifdef USE_MSVC_FP_PREDS
# include <float.h>
@ -2070,6 +2107,11 @@ extern int scheme_is_nan(double);
# endif
#endif
#define MZ_IS_LONG_INFINITY(d) MZ_IS_INFINITY(d)
#define MZ_IS_LONG_POS_INFINITY(d) MZ_IS_POS_INFINITY(d)
#define MZ_IS_LONG_NEG_INFINITY(d) MZ_IS_NEG_INFINITY(d)
#define MZ_IS_LONG_NAN(d) MZ_IS_NAN(d)
#ifndef MZ_IS_INFINITY
# define MZ_IS_INFINITY(d) (MZ_IS_POS_INFINITY(d) || MZ_IS_NEG_INFINITY(d))
#endif
@ -2081,6 +2123,13 @@ extern double scheme_floating_point_zero;
extern double scheme_floating_point_nzero;
extern Scheme_Object *scheme_zerod, *scheme_nzerod, *scheme_pi, *scheme_half_pi, *scheme_plus_i, *scheme_minus_i;
extern Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
#ifdef MZ_LONG_DOUBLE
extern long double scheme_long_infinity_val, scheme_long_minus_infinity_val;
extern long double scheme_long_floating_point_zero;
extern long double scheme_long_floating_point_nzero;
extern Scheme_Object *scheme_zerol, *scheme_nzerol, *scheme_long_scheme_pi;
extern Scheme_Object *scheme_long_inf_object, *scheme_long_minus_inf_object, *scheme_long_nan_object;
#endif
#ifdef MZ_USE_SINGLE_FLOATS
extern Scheme_Object *scheme_zerof, *scheme_nzerof, *scheme_single_scheme_pi;
extern Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_object, *scheme_single_nan_object;
@ -2124,6 +2173,9 @@ Scheme_Object *scheme_inexact_to_exact(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_exact_to_inexact(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_inexact_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n);
#ifdef MZ_LONG_DOUBLE
Scheme_Object *scheme_TO_LONG_DOUBLE(const Scheme_Object *n);
#endif
Scheme_Object *scheme_to_bignum(const Scheme_Object *o);
XFORM_NONGCING int scheme_is_integer(const Scheme_Object *o);
XFORM_NONGCING int scheme_is_zero(const Scheme_Object *o);
@ -2184,6 +2236,22 @@ double scheme_double_log(double x);
double scheme_double_exp(double x);
double scheme_double_expt(double x, double y);
/***** extflonums *****/
#ifdef MZ_LONG_DOUBLE
long double scheme_long_double_truncate(long double x);
long double scheme_long_double_round(long double x);
long double scheme_long_double_floor(long double x);
long double scheme_long_double_ceiling(long double x);
long double scheme_long_double_sin(long double x);
long double scheme_long_double_cos(long double x);
long double scheme_long_double_tan(long double x);
long double scheme_long_double_asin(long double x);
long double scheme_long_double_acos(long double x);
long double scheme_long_double_atan(long double x);
long double scheme_long_double_log(long double x);
long double scheme_long_double_exp(long double x);
long double scheme_long_double_expt(long double x, long double y);
#endif
/*========================================================================*/
/* read, eval, print */
/*========================================================================*/
@ -2500,6 +2568,9 @@ typedef struct Scheme_Current_LWC {
void *original_dest;
void *saved_v1;
double saved_save_fp;
#ifdef MZ_LONG_DOUBLE
long double saved_save_extfp;
#endif
} Scheme_Current_LWC;
void scheme_init_thread_lwc(void);
@ -2612,6 +2683,7 @@ int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env);
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o);
Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o);
Scheme_Object *scheme_extract_extfl(Scheme_Object *o);
Scheme_Object *scheme_extract_futures(Scheme_Object *o);
Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
@ -3371,6 +3443,7 @@ Scheme_Env *scheme_get_kernel_env();
int scheme_is_kernel_env();
Scheme_Env *scheme_get_unsafe_env();
Scheme_Env *scheme_get_flfxnum_env();
Scheme_Env *scheme_get_extfl_env();
Scheme_Env *scheme_get_futures_env();
void scheme_install_initial_module_set(Scheme_Env *env);
@ -3385,6 +3458,7 @@ Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o);
int scheme_is_kernel_modname(Scheme_Object *modname);
int scheme_is_unsafe_modname(Scheme_Object *modname);
int scheme_is_flfxnum_modname(Scheme_Object *modname);
int scheme_is_extfl_modname(Scheme_Object *modname);
int scheme_is_futures_modname(Scheme_Object *modname);
void scheme_clear_modidx_cache(void);
@ -3803,6 +3877,9 @@ Scheme_Object *scheme_vector_length(Scheme_Object *v);
Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_flvector_length(Scheme_Object *v);
Scheme_Object *scheme_checked_extflvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_extflvector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_extflvector_length(Scheme_Object *v);
Scheme_Vector *scheme_alloc_fxvector(intptr_t size);
Scheme_Object *scheme_checked_fxvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_fxvector_set(int argc, Scheme_Object **argv);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.2.2"
#define MZSCHEME_VERSION "5.3.2.3"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 2
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

428
src/racket/src/stypes.h
View File

@ -65,219 +65,223 @@ enum {
/* structure type (plus one above for procs) */
scheme_structure_type, /* 48 */
/* basic types */
scheme_char_type, /* 49 */
scheme_integer_type, /* 50 */
scheme_bignum_type, /* 51 */
scheme_rational_type, /* 52 */
scheme_float_type, /* 53 */
scheme_double_type, /* 54 */
scheme_complex_type, /* 55 */
scheme_char_string_type, /* 56 */
scheme_byte_string_type, /* 57 */
scheme_unix_path_type, /* 58 */
scheme_windows_path_type, /* 59 */
scheme_symbol_type, /* 60 */
scheme_keyword_type, /* 61 */
scheme_null_type, /* 62 */
scheme_pair_type, /* 63 */
scheme_mutable_pair_type, /* 64 */
scheme_vector_type, /* 65 */
scheme_inspector_type, /* 66 */
scheme_input_port_type, /* 67 */
scheme_output_port_type, /* 68 */
scheme_eof_type, /* 69 */
scheme_true_type, /* 70 */
scheme_false_type, /* 71 */
scheme_void_type, /* 72 */
scheme_syntax_compiler_type, /* 73 */
scheme_macro_type, /* 74 */
scheme_box_type, /* 75 */
scheme_thread_type, /* 76 */
scheme_stx_offset_type, /* 77 */
scheme_cont_mark_set_type, /* 78 */
scheme_sema_type, /* 79 */
scheme_hash_table_type, /* 80 */
scheme_hash_tree_type, /* 81 */
scheme_cpointer_type, /* 82 */
scheme_prefix_type, /* 83 */
scheme_weak_box_type, /* 84 */
scheme_ephemeron_type, /* 85 */
scheme_struct_type_type, /* 86 */
scheme_module_index_type, /* 87 */
scheme_set_macro_type, /* 88 */
scheme_listener_type, /* 89 */
scheme_namespace_type, /* 90 */
scheme_config_type, /* 91 */
scheme_stx_type, /* 92 */
scheme_will_executor_type, /* 93 */
scheme_custodian_type, /* 94 */
scheme_random_state_type, /* 95 */
scheme_regexp_type, /* 96 */
scheme_bucket_type, /* 97 */
scheme_bucket_table_type, /* 98 */
scheme_subprocess_type, /* 99 */
scheme_compilation_top_type, /* 100 */
scheme_wrap_chunk_type, /* 101 */
scheme_eval_waiting_type, /* 102 */
scheme_tail_call_waiting_type, /* 103 */
scheme_undefined_type, /* 104 */
scheme_struct_property_type, /* 105 */
scheme_chaperone_property_type, /* 106 */
scheme_multiple_values_type, /* 107 */
scheme_placeholder_type, /* 108 */
scheme_table_placeholder_type, /* 109 */
scheme_rename_table_type, /* 110 */
scheme_rename_table_set_type, /* 111 */
scheme_svector_type, /* 112 */
scheme_resolve_prefix_type, /* 113 */
scheme_security_guard_type, /* 114 */
scheme_indent_type, /* 115 */
scheme_udp_type, /* 116 */
scheme_udp_evt_type, /* 117 */
scheme_tcp_accept_evt_type, /* 118 */
scheme_id_macro_type, /* 119 */
scheme_evt_set_type, /* 120 */
scheme_wrap_evt_type, /* 121 */
scheme_handle_evt_type, /* 122 */
scheme_nack_guard_evt_type, /* 123 */
scheme_semaphore_repost_type, /* 124 */
scheme_channel_type, /* 125 */
scheme_channel_put_type, /* 126 */
scheme_thread_resume_type, /* 127 */
scheme_thread_suspend_type, /* 128 */
scheme_thread_dead_type, /* 129 */
scheme_poll_evt_type, /* 130 */
scheme_nack_evt_type, /* 131 */
scheme_module_registry_type, /* 132 */
scheme_thread_set_type, /* 133 */
scheme_string_converter_type, /* 134 */
scheme_alarm_type, /* 135 */
scheme_thread_recv_evt_type, /* 136 */
scheme_thread_cell_type, /* 137 */
scheme_channel_syncer_type, /* 138 */
scheme_special_comment_type, /* 139 */
scheme_write_evt_type, /* 140 */
scheme_always_evt_type, /* 141 */
scheme_never_evt_type, /* 142 */
scheme_progress_evt_type, /* 143 */
scheme_place_dead_type, /* 144 */
scheme_already_comp_type, /* 145 */
scheme_readtable_type, /* 146 */
scheme_intdef_context_type, /* 147 */
scheme_lexical_rib_type, /* 148 */
scheme_thread_cell_values_type, /* 149 */
scheme_global_ref_type, /* 150 */
scheme_cont_mark_chain_type, /* 151 */
scheme_raw_pair_type, /* 152 */
scheme_prompt_type, /* 153 */
scheme_prompt_tag_type, /* 154 */
scheme_continuation_mark_key_type, /* 155 */
scheme_expanded_syntax_type, /* 156 */
scheme_delay_syntax_type, /* 157 */
scheme_cust_box_type, /* 158 */
scheme_resolved_module_path_type, /* 159 */
scheme_module_phase_exports_type, /* 160 */
scheme_logger_type, /* 161 */
scheme_log_reader_type, /* 162 */
scheme_free_id_info_type, /* 163 */
scheme_rib_delimiter_type, /* 164 */
scheme_noninline_proc_type, /* 165 */
scheme_prune_context_type, /* 166 */
scheme_future_type, /* 167 */
scheme_flvector_type, /* 168 */
scheme_fxvector_type, /* 169 */
scheme_place_type, /* 170 */
scheme_place_object_type, /* 171 */
scheme_place_async_channel_type, /* 172 */
scheme_place_bi_channel_type, /* 173 */
scheme_once_used_type, /* 174 */
scheme_serialized_symbol_type, /* 175 */
scheme_serialized_structure_type, /* 176 */
scheme_fsemaphore_type, /* 177 */
scheme_serialized_tcp_fd_type, /* 178 */
scheme_serialized_file_fd_type, /* 179 */
scheme_port_closed_evt_type, /* 180 */
scheme_proc_shape_type, /* 181 */
scheme_struct_proc_shape_type, /* 182 */
scheme_phantom_bytes_type, /* 183 */
/* number types (must be together) */
scheme_integer_type, /* 49 */
scheme_bignum_type, /* 50 */
scheme_rational_type, /* 51 */
scheme_float_type, /* 52 */
scheme_double_type, /* 53 */
scheme_complex_type, /* 54 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 184 */
scheme_rt_weak_array, /* 185 */
scheme_rt_comp_env, /* 186 */
scheme_rt_constant_binding, /* 187 */
scheme_rt_resolve_info, /* 188 */
scheme_rt_unresolve_info, /* 189 */
scheme_rt_optimize_info, /* 190 */
scheme_rt_compile_info, /* 191 */
scheme_rt_cont_mark, /* 192 */
scheme_rt_saved_stack, /* 193 */
scheme_rt_reply_item, /* 194 */
scheme_rt_closure_info, /* 195 */
scheme_rt_overflow, /* 196 */
scheme_rt_overflow_jmp, /* 197 */
scheme_rt_meta_cont, /* 198 */
scheme_rt_dyn_wind_cell, /* 199 */
scheme_rt_dyn_wind_info, /* 200 */
scheme_rt_dyn_wind, /* 201 */
scheme_rt_dup_check, /* 202 */
scheme_rt_thread_memory, /* 203 */
scheme_rt_input_file, /* 204 */
scheme_rt_input_fd, /* 205 */
scheme_rt_oskit_console_input, /* 206 */
scheme_rt_tested_input_file, /* 207 */
scheme_rt_tested_output_file, /* 208 */
scheme_rt_indexed_string, /* 209 */
scheme_rt_output_file, /* 210 */
scheme_rt_load_handler_data, /* 211 */
scheme_rt_pipe, /* 212 */
scheme_rt_beos_process, /* 213 */
scheme_rt_system_child, /* 214 */
scheme_rt_tcp, /* 215 */
scheme_rt_write_data, /* 216 */
scheme_rt_tcp_select_info, /* 217 */
scheme_rt_param_data, /* 218 */
scheme_rt_will, /* 219 */
scheme_rt_linker_name, /* 220 */
scheme_rt_param_map, /* 221 */
scheme_rt_finalization, /* 222 */
scheme_rt_finalizations, /* 223 */
scheme_rt_cpp_object, /* 224 */
scheme_rt_cpp_array_object, /* 225 */
scheme_rt_stack_object, /* 226 */
scheme_rt_preallocated_object, /* 227 */
scheme_thread_hop_type, /* 228 */
scheme_rt_srcloc, /* 229 */
scheme_rt_evt, /* 230 */
scheme_rt_syncing, /* 231 */
scheme_rt_comp_prefix, /* 232 */
scheme_rt_user_input, /* 233 */
scheme_rt_user_output, /* 234 */
scheme_rt_compact_port, /* 235 */
scheme_rt_read_special_dw, /* 236 */
scheme_rt_regwork, /* 237 */
scheme_rt_rx_lazy_string, /* 238 */
scheme_rt_buf_holder, /* 239 */
scheme_rt_parameterization, /* 240 */
scheme_rt_print_params, /* 241 */
scheme_rt_read_params, /* 242 */
scheme_rt_native_code, /* 243 */
scheme_rt_native_code_plus_case, /* 244 */
scheme_rt_jitter_data, /* 245 */
scheme_rt_module_exports, /* 246 */
scheme_rt_delay_load_info, /* 247 */
scheme_rt_marshal_info, /* 248 */
scheme_rt_unmarshal_info, /* 249 */
scheme_rt_runstack, /* 250 */
scheme_rt_sfs_info, /* 251 */
scheme_rt_validate_clearing, /* 252 */
scheme_rt_avl_node, /* 253 */
scheme_rt_lightweight_cont, /* 254 */
scheme_rt_export_info, /* 255 */
scheme_rt_cont_jmp, /* 256 */
/* other values */
scheme_char_type, /* 55 */
scheme_long_double_type, /* 56 */
scheme_char_string_type, /* 57 */
scheme_byte_string_type, /* 58 */
scheme_unix_path_type, /* 59 */
scheme_windows_path_type, /* 60 */
scheme_symbol_type, /* 61 */
scheme_keyword_type, /* 62 */
scheme_null_type, /* 63 */
scheme_pair_type, /* 64 */
scheme_mutable_pair_type, /* 65 */
scheme_vector_type, /* 66 */
scheme_inspector_type, /* 67 */
scheme_input_port_type, /* 68 */
scheme_output_port_type, /* 69 */
scheme_eof_type, /* 70 */
scheme_true_type, /* 71 */
scheme_false_type, /* 72 */
scheme_void_type, /* 73 */
scheme_syntax_compiler_type, /* 74 */
scheme_macro_type, /* 75 */
scheme_box_type, /* 76 */
scheme_thread_type, /* 77 */
scheme_stx_offset_type, /* 78 */
scheme_cont_mark_set_type, /* 79 */
scheme_sema_type, /* 80 */
scheme_hash_table_type, /* 81 */
scheme_hash_tree_type, /* 82 */
scheme_cpointer_type, /* 83 */
scheme_prefix_type, /* 84 */
scheme_weak_box_type, /* 85 */
scheme_ephemeron_type, /* 86 */
scheme_struct_type_type, /* 87 */
scheme_module_index_type, /* 88 */
scheme_set_macro_type, /* 89 */
scheme_listener_type, /* 90 */
scheme_namespace_type, /* 91 */
scheme_config_type, /* 92 */
scheme_stx_type, /* 93 */
scheme_will_executor_type, /* 94 */
scheme_custodian_type, /* 95 */
scheme_random_state_type, /* 96 */
scheme_regexp_type, /* 97 */
scheme_bucket_type, /* 98 */
scheme_bucket_table_type, /* 99 */
scheme_subprocess_type, /* 100 */
scheme_compilation_top_type, /* 101 */
scheme_wrap_chunk_type, /* 102 */
scheme_eval_waiting_type, /* 103 */
scheme_tail_call_waiting_type, /* 104 */
scheme_undefined_type, /* 105 */
scheme_struct_property_type, /* 106 */
scheme_chaperone_property_type, /* 107 */
scheme_multiple_values_type, /* 108 */
scheme_placeholder_type, /* 109 */
scheme_table_placeholder_type, /* 110 */
scheme_rename_table_type, /* 111 */
scheme_rename_table_set_type, /* 112 */
scheme_svector_type, /* 113 */
scheme_resolve_prefix_type, /* 114 */
scheme_security_guard_type, /* 115 */
scheme_indent_type, /* 116 */
scheme_udp_type, /* 117 */
scheme_udp_evt_type, /* 118 */
scheme_tcp_accept_evt_type, /* 119 */
scheme_id_macro_type, /* 120 */
scheme_evt_set_type, /* 121 */
scheme_wrap_evt_type, /* 122 */
scheme_handle_evt_type, /* 123 */
scheme_nack_guard_evt_type, /* 124 */
scheme_semaphore_repost_type, /* 125 */
scheme_channel_type, /* 126 */
scheme_channel_put_type, /* 127 */
scheme_thread_resume_type, /* 128 */
scheme_thread_suspend_type, /* 129 */
scheme_thread_dead_type, /* 130 */
scheme_poll_evt_type, /* 131 */
scheme_nack_evt_type, /* 132 */
scheme_module_registry_type, /* 133 */
scheme_thread_set_type, /* 134 */
scheme_string_converter_type, /* 135 */
scheme_alarm_type, /* 136 */
scheme_thread_recv_evt_type, /* 137 */
scheme_thread_cell_type, /* 138 */
scheme_channel_syncer_type, /* 139 */
scheme_special_comment_type, /* 140 */
scheme_write_evt_type, /* 141 */
scheme_always_evt_type, /* 142 */
scheme_never_evt_type, /* 143 */
scheme_progress_evt_type, /* 144 */
scheme_place_dead_type, /* 145 */
scheme_already_comp_type, /* 146 */
scheme_readtable_type, /* 147 */
scheme_intdef_context_type, /* 148 */
scheme_lexical_rib_type, /* 149 */
scheme_thread_cell_values_type, /* 150 */
scheme_global_ref_type, /* 151 */
scheme_cont_mark_chain_type, /* 152 */
scheme_raw_pair_type, /* 153 */
scheme_prompt_type, /* 154 */
scheme_prompt_tag_type, /* 155 */
scheme_continuation_mark_key_type, /* 156 */
scheme_expanded_syntax_type, /* 157 */
scheme_delay_syntax_type, /* 158 */
scheme_cust_box_type, /* 159 */
scheme_resolved_module_path_type, /* 160 */
scheme_module_phase_exports_type, /* 161 */
scheme_logger_type, /* 162 */
scheme_log_reader_type, /* 163 */
scheme_free_id_info_type, /* 164 */
scheme_rib_delimiter_type, /* 165 */
scheme_noninline_proc_type, /* 166 */
scheme_prune_context_type, /* 167 */
scheme_future_type, /* 168 */
scheme_flvector_type, /* 169 */
scheme_extflvector_type, /* 170 */
scheme_fxvector_type, /* 171 */
scheme_place_type, /* 172 */
scheme_place_object_type, /* 173 */
scheme_place_async_channel_type, /* 174 */
scheme_place_bi_channel_type, /* 175 */
scheme_once_used_type, /* 176 */
scheme_serialized_symbol_type, /* 177 */
scheme_serialized_structure_type, /* 178 */
scheme_fsemaphore_type, /* 179 */
scheme_serialized_tcp_fd_type, /* 180 */
scheme_serialized_file_fd_type, /* 181 */
scheme_port_closed_evt_type, /* 182 */
scheme_proc_shape_type, /* 183 */
scheme_struct_proc_shape_type, /* 184 */
scheme_phantom_bytes_type, /* 185 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 186 */
scheme_rt_weak_array, /* 187 */
scheme_rt_comp_env, /* 188 */
scheme_rt_constant_binding, /* 189 */
scheme_rt_resolve_info, /* 190 */
scheme_rt_unresolve_info, /* 191 */
scheme_rt_optimize_info, /* 192 */
scheme_rt_compile_info, /* 193 */
scheme_rt_cont_mark, /* 194 */
scheme_rt_saved_stack, /* 195 */
scheme_rt_reply_item, /* 196 */
scheme_rt_closure_info, /* 197 */
scheme_rt_overflow, /* 198 */
scheme_rt_overflow_jmp, /* 199 */
scheme_rt_meta_cont, /* 200 */
scheme_rt_dyn_wind_cell, /* 201 */
scheme_rt_dyn_wind_info, /* 202 */
scheme_rt_dyn_wind, /* 203 */
scheme_rt_dup_check, /* 204 */
scheme_rt_thread_memory, /* 205 */
scheme_rt_input_file, /* 206 */
scheme_rt_input_fd, /* 207 */
scheme_rt_oskit_console_input, /* 208 */
scheme_rt_tested_input_file, /* 209 */
scheme_rt_tested_output_file, /* 210 */
scheme_rt_indexed_string, /* 211 */
scheme_rt_output_file, /* 212 */
scheme_rt_load_handler_data, /* 213 */
scheme_rt_pipe, /* 214 */
scheme_rt_beos_process, /* 215 */
scheme_rt_system_child, /* 216 */
scheme_rt_tcp, /* 217 */
scheme_rt_write_data, /* 218 */
scheme_rt_tcp_select_info, /* 219 */
scheme_rt_param_data, /* 220 */
scheme_rt_will, /* 221 */
scheme_rt_linker_name, /* 222 */
scheme_rt_param_map, /* 223 */
scheme_rt_finalization, /* 224 */
scheme_rt_finalizations, /* 225 */
scheme_rt_cpp_object, /* 226 */
scheme_rt_cpp_array_object, /* 227 */
scheme_rt_stack_object, /* 228 */
scheme_rt_preallocated_object, /* 229 */
scheme_thread_hop_type, /* 230 */
scheme_rt_srcloc, /* 231 */
scheme_rt_evt, /* 232 */
scheme_rt_syncing, /* 233 */
scheme_rt_comp_prefix, /* 234 */
scheme_rt_user_input, /* 235 */
scheme_rt_user_output, /* 236 */
scheme_rt_compact_port, /* 237 */
scheme_rt_read_special_dw, /* 238 */
scheme_rt_regwork, /* 239 */
scheme_rt_rx_lazy_string, /* 240 */
scheme_rt_buf_holder, /* 241 */
scheme_rt_parameterization, /* 242 */
scheme_rt_print_params, /* 243 */
scheme_rt_read_params, /* 244 */
scheme_rt_native_code, /* 245 */
scheme_rt_native_code_plus_case, /* 246 */
scheme_rt_jitter_data, /* 247 */
scheme_rt_module_exports, /* 248 */
scheme_rt_delay_load_info, /* 249 */
scheme_rt_marshal_info, /* 250 */
scheme_rt_unmarshal_info, /* 251 */
scheme_rt_runstack, /* 252 */
scheme_rt_sfs_info, /* 253 */
scheme_rt_validate_clearing, /* 254 */
scheme_rt_avl_node, /* 255 */
scheme_rt_lightweight_cont, /* 256 */
scheme_rt_export_info, /* 257 */
scheme_rt_cont_jmp, /* 258 */
#endif
_scheme_last_type_

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

@ -161,6 +161,7 @@ scheme_init_type ()
set_name(scheme_box_type, "<box>");
set_name(scheme_integer_type, "<fixnum-integer>");
set_name(scheme_double_type, "<inexact-number>");
set_name(scheme_long_double_type, "<extflonum>");
set_name(scheme_float_type, "<inexact-number*>");
set_name(scheme_undefined_type, "<undefined>");
set_name(scheme_eof_type, "<eof>");
@ -187,6 +188,7 @@ scheme_init_type ()
set_name(scheme_macro_type, "<macro>");
set_name(scheme_vector_type, "<vector>");
set_name(scheme_flvector_type, "<flvector>");
set_name(scheme_extflvector_type, "<extflvector>");
set_name(scheme_fxvector_type, "<fxvector>");
set_name(scheme_bignum_type, "<bignum-integer>");
set_name(scheme_escaping_cont_type, "<escape-continuation>");
@ -602,6 +604,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_rational_type, rational_obj);
GC_REG_TRAV(scheme_float_type, float_obj);
GC_REG_TRAV(scheme_double_type, double_obj);
GC_REG_TRAV(scheme_long_double_type, long_double_obj);
GC_REG_TRAV(scheme_complex_type, complex_obj);
GC_REG_TRAV(scheme_char_string_type, string_obj);
GC_REG_TRAV(scheme_byte_string_type, bstring_obj);
@ -619,6 +622,9 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
GC_REG_TRAV(scheme_vector_type, vector_obj);
GC_REG_TRAV(scheme_flvector_type, flvector_obj);
#ifdef MZ_LONG_DOUBLE
GC_REG_TRAV(scheme_extflvector_type, extflvector_obj);
#endif
GC_REG_TRAV(scheme_fxvector_type, fxvector_obj);
GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);

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

@ -1946,7 +1946,11 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
NULL, 0, 0, vc, 0, 0, procs, 1, NULL);
}
} else if (need_local_type) {
if (!SCHEME_FLOATP(expr))
if (!SCHEME_FLOATP(expr)
#ifdef MZ_LONG_DOUBLE
&& !SCHEME_LONG_DBLP(expr)
#endif
)
no_typed(need_local_type, port);
}
break;

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

@ -382,13 +382,21 @@ void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *which, Schem
{
const char *type;
#ifdef MZ_LONG_DOUBLE
#define BAD_EXTFLVEC_INDEX (SCHEME_EXTFLVECTORP(vec)? "extflvector" : NULL)
#else
#define BAD_EXTFLVEC_INDEX NULL
#endif
type = (SCHEME_CHAPERONE_VECTORP(vec)
? "vector"
: (SCHEME_FLVECTORP(vec)
? "flvector"
: (SCHEME_FXVECTORP(vec)
? "fxvector"
: NULL)));
: BAD_EXTFLVEC_INDEX
)));
scheme_out_of_range(name, type, which, i, vec, bottom, len-1);
}