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

full unboxing for extflonums, plus `ffi/unsafe' support

Browse Source 
Includes a repair for floating-point `min' and `max' that affects all
x86 builds that use SSE arithmetic, leaving the (otherwise unused)
floating-point stack in a bad state, which might have affected
x87-using C/foreign libraries running alongside Racket.
This commit is contained in:
Michael Filonenko 2013-02-15 11:29:59 -07:00 committed by Matthew Flatt
parent a348e5421d
commit 840fc9c657
22 changed files with 844 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/ffi/unsafe.rkt
View File

@ -10,12 +10,12 @@
cpointer? cpointer-gcable? prop:cpointer
ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno
vector->cpointer flvector->cpointer extflvector->cpointer saved-errno lookup-errno
ctype? make-ctype make-cstruct-type make-array-type make-union-type
make-sized-byte-string ctype->layout
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
_float _double _longdouble _double*
_bool _pointer _gcpointer _scheme (rename-out [_scheme _racket]) _fpointer function-ptr
memcpy memmove memset
malloc-immobile-cell free-immobile-cell

7
collects/ffi/vector.rkt
View File

@ -2,6 +2,8 @@
(require "unsafe.rkt"
racket/unsafe/ops
racket/extflonum
(for-syntax racket/extflonum)
(for-syntax racket/base))
(define-syntax define*
@ -37,6 +39,7 @@
[_TAG* (id "_" "*")]
[TAGname name]
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)]
[f80? (if (eq? (syntax-e #'TAG) 'f80) #'#t #'#f)]
[s16? (if (eq? (syntax-e #'TAG) 's16) #'#t #'#f)]
[u16? (if (eq? (syntax-e #'TAG) 'u16) #'#t #'#f)])
#'(begin
@ -62,6 +65,7 @@
;; use JIT-inlined operation if available:
(cond
[f64? (unsafe-f64vector-ref v i)]
[f80? (unsafe-f80vector-ref v i)]
[s16? (unsafe-s16vector-ref v i)]
[u16? (unsafe-u16vector-ref v i)]
[else (ptr-ref (TAG-ptr v) type i)])
@ -75,6 +79,8 @@
(cond
[(and f64? (inexact-real? x))
(unsafe-f64vector-set! v i x)]
[(and f80? (extflonum? x))
(unsafe-f80vector-set! v i x)]
[(and s16? (fixnum? x) (unsafe-fx<= -32768 x) (unsafe-fx<= x 32767))
(unsafe-s16vector-set! v i x)]
[(and u16? (fixnum? x) (unsafe-fx<= 0 x) (unsafe-fx<= x 65535))
@ -135,6 +141,7 @@
(srfi-4-define/provide u64 _uint64)
(srfi-4-define/provide f32 _float)
(srfi-4-define/provide f64 _double*)
(srfi-4-define/provide f80 _longdouble)
;; simply rename bytes* to implement the u8vector type
(provide (rename-out [bytes? u8vector? ]

7
collects/scribblings/foreign/types.scrbl
View File

@ -180,6 +180,13 @@ coerce C values to double-precision Racket numbers.
The type @racket[_double*]
coerces any Racket real number to a C @cpp{double}.}
@defthing[_longdouble ctype?]{
Represents the @cpp{long double} type on platforms where it is
supported, in which case Racket @tech[#:doc
reference.scrbl]{extflonums} convert to and from @cpp{long double}
values.}
@; ------------------------------------------------------------
@section{Other Atomic Types}

44
collects/scribblings/foreign/vector.scrbl
View File

@ -1,5 +1,8 @@
#lang scribble/doc
@(require "utils.rkt" (only-in scribble/decode make-splice))
@(require "utils.rkt"
(only-in scribble/decode make-splice)
scribble/racket
(for-label racket/extflonum))
@title[#:tag "homogeneous-vectors"]{Safe Homogenous Vectors}
@ -7,7 +10,7 @@
Homogenous vectors are similar to C vectors (see
@secref["foreign:cvector"]), except that they define different types
of vectors, each with a hard-wired type. An exception is the
of vectors, each with a fixed element type. An exception is the
@racketidfont{u8} family of bindings, which are just aliases for
byte-string bindings; for example, @racket[make-u8vector] is an alias
for @racket[make-bytes].
@ -16,12 +19,12 @@ for @racket[make-bytes].
(require (for-syntax scheme/base))
(define-syntax (srfi-4-vector stx)
(syntax-case stx ()
[(_ id elem)
#'(srfi-4-vector/desc id elem make-splice
[(_ id elem number?)
#'(srfi-4-vector/desc id elem number? make-splice
"Like " (racket make-vector) ", etc., but for " (racket elem) " elements.")]))
(define-syntax (srfi-4-vector/desc stx)
(syntax-case stx ()
[(_ id elem extra desc ...)
[(_ id elem as-number? extra desc ...)
(let ([mk
(lambda l
(datum->syntax
@ -44,7 +47,10 @@ for @racket[make-bytes].
[->list (mk #'id "vector->list")]
[->cpointer (mk #'id "vector->cpointer")]
[_vec (mk "_" #'id "vector")])
#`(begin
#`(let-syntax ([number? (make-element-id-transformer
(lambda (stx)
#'(racket as-number?)))])
(list
(defproc* ([(make [len exact-nonnegative-integer?]) ?]
[(vecr [val number?] (... ...)) ?]
[(? [v any/c]) boolean?]
@ -92,22 +98,22 @@ for @racket[make-bytes].
10))
_vec]
"Like " (racket _cvector) ", but for vectors of "
(racket elem) " elements."))))])))
(racket elem) " elements.")))))])))
@srfi-4-vector/desc[u8 _uint8 (lambda (x) (make-splice null))]{
@srfi-4-vector/desc[u8 _uint8 byte? (lambda (x) (make-splice null))]{
Like @racket[_cvector], but for vectors of @racket[_byte] elements. These are
Like @racket[_cvector], but for vectors of @racket[_uint8] elements. These are
aliases for @racketidfont{byte} operations, where @racket[u8vector->cpointer]
is the identity function.}
@srfi-4-vector[s8 _int8]
@srfi-4-vector[s16 _int16]
@srfi-4-vector[u16 _uint16]
@srfi-4-vector[s32 _int32]
@srfi-4-vector[u32 _uint32]
@srfi-4-vector[s64 _int64]
@srfi-4-vector[u64 _uint64]
@srfi-4-vector[f32 _float]
@srfi-4-vector[f64 _double*]
@srfi-4-vector[s8 _int8 (integer-in -128 127)]
@srfi-4-vector[s16 _int16 (integer-in -32768 32767)]
@srfi-4-vector[u16 _uint16 (integer-in 0 65535)]
@srfi-4-vector[s32 _int32 (integer-in -2147483648 2147483647)]
@srfi-4-vector[u32 _uint32 (integer-in 0 4294967295)]
@srfi-4-vector[s64 _int64 (integer-in -9223372036854775808 9223372036854775807)]
@srfi-4-vector[u64 _uint64 (integer-in 0 18446744073709551615)]
@srfi-4-vector[f32 _float real?]
@srfi-4-vector[f64 _double* real?]
@srfi-4-vector[f80 _longdouble extflonum?]

17
collects/tests/racket/foreign-test.rktl
View File

@ -3,8 +3,10 @@
(Section 'foreign)
(require mzlib/foreign)
(unsafe!)
(require ffi/unsafe
ffi/unsafe/cvector
ffi/vector
racket/extflonum)
(test #f malloc 0)
(test #f malloc 0 _int)
@ -481,6 +483,17 @@
(define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket)))
(test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three)))))
(when (extflonum-available?)
(define m (malloc _longdouble))
(ptr-set! m _longdouble 13.57t0)
(test 13.57t0 ptr-ref m _longdouble)
(define v (extflvector 1.1t0 2.2t0 3.3t0))
(test 3.3t0 extflvector-ref v 2)
(test (void) extflvector-set! v 2 4.4t0)
(test 4.4t0 extflvector-ref v 2)
(test 2.2t0 ptr-ref (ptr-add (extflvector->cpointer v) (ctype-sizeof _longdouble)) _longdouble))
(report-errs)
#| --- ignore everything below ---

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

@ -4,6 +4,7 @@
(Section 'optimization)
(require racket/flonum
racket/extflonum
racket/fixnum
racket/unsafe/ops
compiler/zo-parse
@ -15,6 +16,7 @@
(parameterize ([current-namespace (make-base-namespace)]
[eval-jit-enabled #t])
(namespace-require 'racket/flonum)
(namespace-require 'racket/extflonum)
(namespace-require 'racket/fixnum)
(eval '(define-values (prop:thing thing? thing-ref)
(make-struct-type-property 'thing)))
@ -25,7 +27,7 @@
[check-error-message (lambda (name proc [fixnum? #f])
(unless (memq name '(eq? eqv? equal?
not null? pair? list?
real? number? boolean?
real? number? boolean?
procedure? symbol?
string? bytes?
vector? box?
@ -71,7 +73,7 @@
[bin0 (lambda (v op arg1 arg2)
;; (printf "Trying ~a ~a ~a\n" op arg1 arg2);
(let ([name `(,op ,arg1 ,arg2)])
(test v name ((eval `(lambda (x) (,op x ',arg2))) arg1))
(test v name ((eval `(lambda (x) (,op x ',arg2))) arg1))
(test v name ((eval `(lambda (x) (,op ',arg1 x))) arg2))
(test v name ((eval `(lambda (x y) (,op x y))) arg1 arg2))
(test v name ((eval `(lambda (x y)
@ -172,6 +174,7 @@
(check-error-message op (eval `(lambda (x) (,op (,get-arg1) ,arg2 x)))))
(tri0 v op get-arg1 arg2 arg3 check-effect))])
(un #f 'null? 0)
(un-exact #t 'null? '())
(un #f 'pair? 0)
@ -662,6 +665,99 @@
(tri0 '(1 2 . 3) 'list* (lambda () 1) 2 3 void)
(un0 '#&1 'box 1)
(when (extflonum-available?)
(define (extflonum-close? fl1 fl2)
(extfl<= (extflabs (fl- fl1 fl2))
(real->extfl 1e-8)))
(bin-exact #t 'extfl< 100.0t0 200.0t0 #t)
(bin-exact #f 'extfl< 200.0t0 100.0t0)
(bin-exact #f 'extfl< 200.0t0 200.0t0)
(bin-exact #t 'extfl<= 100.0t0 200.0t0 #t)
(bin-exact #f 'extfl<= 200.0t0 100.0t0)
(bin-exact #t 'extfl<= 200.0t0 200.0t0)
(bin-exact #f 'extfl> 100.0t0 200.0t0 #t)
(bin-exact #t 'extfl> 200.0t0 100.0t0)
(bin-exact #f 'extfl> 200.0t0 200.0t0)
(bin-exact #f 'extfl>= 100.0t0 200.0t0 #t)
(bin-exact #t 'extfl>= 200.0t0 100.0t0)
(bin-exact #t 'extfl>= 200.0t0 200.0t0)
(bin-exact #f 'extfl= 100.0t0 200.0t0 #t)
(bin-exact #t 'extfl= 200.0t0 200.0t0)
(un-exact 3.0t0 'extflabs -3.0t0 #t)
(un-exact 3.0t0 'extflsqrt 9.0t0 #t)
(un-exact +nan.t 'extflsqrt -9.0t0)
(let ([test-trig
(lambda (trig extfltrig)
;;(un (real->extfl (trig 1.0)) extfltrig 1.0t0 #t)
(un +nan.t extfltrig +nan.t))])
(test-trig sin 'extflsin)
(test-trig cos 'extflcos)
(test-trig tan 'extfltan)
(test-trig asin 'extflasin)
(test-trig acos 'extflacos)
(test-trig atan 'extflatan)
(test-trig log 'extfllog)
(test-trig exp 'extflexp))
(when (extflonum-available?)
(for-each
(lambda (v)
(define (once v)
(define (->fl v) (extfl->inexact v))
(define (->extfl v) (real->extfl v))
(un-exact (->extfl (round (->fl v))) 'extflround v #t)
(un-exact (->extfl (ceiling (->fl v))) 'extflceiling v #t)
(un-exact (->extfl (floor (->fl v))) 'extflfloor v #t)
(un-exact (->extfl (truncate (->fl v))) 'extfltruncate v #t))
(once v)
(once (extfl- 0.0t0 v)))
'(3.0t0 3.1t0 3.5t0 3.8t0 4.0t0 4.1t0 4.5t0 4.8t0 0.0t0)))
(bin-exact 9.0t0 'extflexpt 3.0t0 2.0t0 #t)
(bin-exact (extflexpt 3.1t0 2.5t0) 'extflexpt 3.1t0 2.5t0 #t)
(bin-exact -1.0t0 'extflexpt -1.0t0 3.0t0 #t)
(bin-exact -0.125t0 'extflexpt -2.0t0 -3.0t0 #t)
(bin-exact +nan.t 'extflexpt -1.0t0 3.1t0 #t)
(bin-exact 0.0t0 'extflexpt 0.0t0 10.0t0 #t)
(bin-exact +inf.t 'extflexpt 0.0t0 -1.0t0 #t)
(bin-exact +1.0t0 'extflexpt 0.0t0 0.0t0 #t)
(bin-exact +nan.t 'extflexpt +nan.t 2.7t0 #t)
(bin-exact +nan.t 'extflexpt 2.7t0 +nan.t #t)
(bin-exact +nan.t 'extflexpt +nan.t +nan.t #t)
(un-exact 10.0t0 '->extfl 10)
(un-exact 10.0t0 'fx->extfl 10)
(un-exact 11 'extfl->exact-integer 11.0t0 #t)
(un-exact -1 'extfl->exact-integer -1.0t0)
(un-exact (inexact->exact 5e200) 'extfl->exact-integer (real->extfl 5e200))
(un-exact 11 'extfl->fx 11.0t0 #t)
(un-exact -11 'extfl->fx -11.0t0)
(bin-exact -0.75t0 'extfl- 1.5t0 2.25t0 #t)
(bin-exact 3.0t0 'extflmin 3.0t0 4.5t0 #t)
(bin-exact 2.5t0 'extflmin 3.0t0 2.5t0)
(bin0 3.5t0 '(lambda (x y) (extfl+ 1.0t0 (extflmin x y))) 3.0t0 2.5t0)
(bin0 4.0t0 '(lambda (x y) (extfl+ 1.0t0 (extflmin x y))) 3.0t0 4.5t0)
(bin-exact 4.5t0 'extflmax 3.0t0 4.5t0 #t)
(bin-exact 3.0t0 'extflmax 3.0t0 2.5t0)
(bin0 5.5t0 '(lambda (x y) (extfl+ 1.0t0 (extflmax x y))) 3.0t0 4.5t0)
(bin0 4.0t0 '(lambda (x y) (extfl+ 1.0t0 (extflmax x y))) 3.0t0 2.5t0)
(bin-exact 1.1t0 'extflvector-ref (extflvector 1.1t0 2.2t0 3.3t0) 0 #t)
(bin-exact 3.3t0 'extflvector-ref (extflvector 1.1t0 2.2t0 3.3t0) 2)
(un-exact 3 'extflvector-length (extflvector 1.1t0 2.2t0 3.3t0) #t)
)
(let ([test-setter
(lambda (make-X def-val set-val set-name set ref 3rd-all-ok?)
(let ([v (make-X 3 def-val)])
@ -1535,6 +1631,15 @@
(+ (unsafe-flvector-length x) (unsafe-flvector-length x)))
#f)
(when (extflonum-available?)
(test-comp '(lambda (x)
(let ([y (unsafe-extflvector-length x)])
(let ([f (lambda () y)])
(+ (f) (f)))))
'(lambda (x)
(+ (unsafe-extflvector-length x) (unsafe-extflvector-length x)))
#f))
;; don't delay an unsafe car, because it might be space-unsafe
(test-comp '(lambda (f x)
(let ([y (unsafe-car x)])
@ -1585,6 +1690,38 @@
f)))
#f)
(when (extflonum-available?)
;; don't duplicate formerly once-used variable due to inlining
(test-comp '(lambda (y)
(let ([q (unsafe-extfl* y y)]) ; => q is known flonum
(let ([x (unsafe-extfl* q q)]) ; can delay (but don't duplicate)
(define (f z) (unsafe-extfl+ z x))
(if y
(f 10)
f))))
'(lambda (y)
(let ([q (unsafe-extfl* y y)])
(let ([x (unsafe-extfl* q q)])
(define (f z) (unsafe-extfl+ z x))
(if y
(unsafe-extfl+ 10 x)
f)))))
;; double-check that previous test doesn't succeed due to copying
(test-comp '(lambda (y)
(let ([q (unsafe-extfl* y y)])
(let ([x (unsafe-extfl* q q)])
(define (f z) (unsafe-extfl+ z x))
(if y
(unsafe-extfl+ 10 x)
f))))
'(lambda (y)
(let ([q (unsafe-extfl* y y)])
(define (f z) (unsafe-extfl+ z (unsafe-extfl* q q)))
(if y
(unsafe-extfl+ 10 (unsafe-extfl* q q))
f)))
#f))
;; check move through an intermediate variable:
(test-comp '(lambda (n)
(let ([p (+ n n)])
@ -1768,7 +1905,18 @@
(unsafe-fxvector-set! x x x)
(unsafe-f64vector-set! x x x)
(unsafe-s16vector-set! x x x)
(unsafe-u16vector-set! x x x))))
(unsafe-u16vector-set! x x x)))
(when (extflonum-available?)
(map check-omit-ok
'((unsafe-extflvector-ref x x)
(unsafe-f80vector-ref x x)))
(map (lambda (x) (check-omit-ok x #f))
'((unsafe-extflvector-set! x x x)
(unsafe-f80vector-set! x x x)
))
))
(test-comp '(lambda (x)
(hash-ref '#hash((x . y)) x (lambda () 10)))
@ -1953,6 +2101,8 @@
(list (c? (c-q (c 1 2 3))))
5)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check splitting of definitions
(test-comp `(module m racket/base
@ -2191,6 +2341,22 @@
(f y (sub1 y)))))
(f 1.0 100)))
(when (extflonum-available?)
(test '(done)
'unboxing-inference-test
(let ()
(define (f x y)
(if (zero? y)
;; prevents inlining:
'(done)
(if (zero? y)
;; incorrectly triggered unboxing,
;; once upon a time:
(extfl+ x 1.0t0)
;; not a float argument => no unboxing of x:
(f y (sub1 y)))))
(f 1.0t0 100))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test against letrec-splitting bug:
@ -2257,6 +2423,19 @@
(regexp-match #rx"1e[+]?100" (exn-message exn))))
(test (inexact->exact 1e100) (lambda (x) (inexact->exact (fl/ (fl- x 0.0) 1.0))) 1e100)
(when (extflonum-available?)
(test 1 (lambda (x) (extfl->fx (extfl/ (extfl- x 0.0t0) 1.0t0))) 1.0t0)
(test 1 (lambda (x) (extfl->exact (extfl/ (extfl- x 0.0t0) 1.0t0))) 1.0t0)
(err/rt-test (let ([f (lambda (x) (extfl->fx (extfl/ (extfl- x 0.0t0) 1.0t0)))])
(set! f f)
(f 1t100))
;; make sure that exception reports actual bad argument, and
;; not some bad argument due to the fact that the original
;; was unboxed:
(lambda (exn)
(regexp-match #rx"1t[+]?100" (exn-message exn))))
(test (extfl->exact 1t100) (lambda (x) (extfl->exact (extfl/ (extfl- x 0.0t0) 1.0t0))) 1t100))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that compiler handles shifting `#%variable-reference'
@ -2396,6 +2575,51 @@
(test -2200000.0 non-tail2)
(test-values '(-100001.0 100001.0) tail))
(when (extflonum-available?)
(let ()
(define N 100000)
(define (non-tail)
(define-values (a b)
(let loop ([n N] [x -1.0t0] [y 1.0t0])
(cond
[(zero? n) (values x y)]
[else (loop (sub1 n)
(extfl+ x -1.0t0)
(extfl+ y 1.0t0))])))
(values a b))
(define (non-tail2ext)
(for/fold ([v 0.0t0]) ([i (in-range N)])
(define-values (a b)
(let loop ([n 10] [x -1.0t0] [y 1.0t0])
(cond
[(zero? n) (values x y)]
[else (loop (sub1 n)
(extfl+ x -1.0t0)
(extfl+ y 1.0t0))])))
(extfl+ v (extfl- a b))))
(define (tail)
(let loop ([n N] [x -1.0t0] [y 1.0t0])
(cond
[(zero? n) (values x y)]
[else (loop (sub1 n)
(extfl+ x -1.0t0)
(extfl+ y 1.0t0))])))
(define x-tail #f)
(define x-non-tail #f)
(define x-non-tail2ext #f)
(set! x-tail tail)
(set! x-non-tail non-tail)
(set! x-non-tail2ext non-tail2ext)
(test-values '(-100001.0t0 100001.0t0) non-tail)
(test -2200000.0t0 non-tail2ext)
(test-values '(-100001.0t0 100001.0t0) tail)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check for corect fixpoint calculation when lifting
@ -2614,6 +2838,24 @@
;; too-aggressive compilation produces a validator failure here
(read (open-input-bytes (get-output-bytes o)))))
(when (extflonum-available?)
(let ([m '(module m racket/base
(require racket/extflonum)
(define (f x)
(letrec ([z (if x (other 1) 'none)]
[collect (lambda (x)
(lambda (n)
(list '(1 2 3)
(extfl+ n x))))]
[a (collect 0.0t0)]
[other 6])
(values a z))))])
(define o (open-output-bytes))
(write (compile m) o)
(parameterize ([read-accept-compiled #t])
;; too-aggressive compilation produces a validator failure here
(read (open-input-bytes (get-output-bytes o))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; check error checking of JITted `continuation-mark-set-first'
@ -2636,6 +2878,19 @@
(test 4.0 (f 1.0) 2.0))
(when (extflonum-available?)
(let ()
(define f #f)
(set! f
(lambda (x)
(let ([x (extfl+ x x)])
(case-lambda
[() (extfl+ x x)]
[(y) (extfl+ x y)]))))
(test 4.0t0 (f 1.0t0) 2.0t0)
))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -380,7 +380,15 @@
(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)))
#:literal-ok? #f))
(test-bin 9.5t0 'unsafe-f80vector-ref (f80vector 1.0t0 9.5t0 18.7t0) 1)
(let ([v (f80vector 1.0t0 9.5t0 18.7t0)])
(test-tri (list (void) 27.4t0) 'unsafe-f80vector-set! v 2 27.4t0
#:pre (lambda () (f80vector-set! v 2 0.0t0))
#:post (lambda (x) (list x (f80vector-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))
@ -437,6 +445,13 @@
(unsafe-f64vector-ref y 1))
1.2 (f64vector 1.0 4.2 6.7) 2.0)
(when (extflonum-available?)
(test-tri 5.3999999999999999997t0 '(lambda (x y z) (unsafe-extfl+ x (unsafe-f80vector-ref y z))) 1.2t0 (f80vector 1.0t0 4.2t0 6.7t0) 1)
(test-tri 3.2t0 '(lambda (x y z)
(unsafe-f80vector-set! y 1 (unsafe-extfl+ x z))
(unsafe-f80vector-ref y 1))
1.2t0 (f80vector 1.0t0 4.2t0 6.7t0) 2.0t0))
(void))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -472,7 +487,7 @@
(- n 1))))))])
(test 500000.0 f 1.0))
(when (extflonum-available?)
(when (extflonum-available?)
(let ([f (lambda (x)
(let ([x (unsafe-extfl+ x 1.0t0)])
(let loop ([v 0.0t0][n 10000])
@ -490,7 +505,6 @@
(- 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)
@ -502,7 +516,7 @@
(loop a
(unsafe-extfl+ v x)
(- n 1))))))])
(test 1000000.0t0 f 2.0t0)))
(test 500000.0t0 f 1.0t0)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -1,3 +1,6 @@
Version 5.3.3.3
ffi/vector: added f8vectors
Version 5.3.3.2
Added port-counts-lines?

109
src/foreign/foreign.c
View File

@ -780,8 +780,42 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: scheme_make_double(<C>)
*/
#define ffi_type_slongdouble ffi_type_longdouble
#ifdef MZ_LONG_DOUBLE
typedef long double mz_long_double;
#else /* MZ_LONG_DOUBLE undefined */
typedef double mz_long_double;
#endif /* MZ_LONG_DOUBLE */
#ifdef MZ_LONG_DOUBLE
#define SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)
#else /* MZ_LONG_DOUBLE undefined */
#define SCHEME_MAYBE_LONG_DBL_VAL(x) unsupported_long_double_val()
static mz_long_double unsupported_long_double_val() {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
return 0.0;
}
#endif /* MZ_LONG_DOUBLE */
#ifdef MZ_LONG_DOUBLE
#define scheme_make_maybe_long_double(x) scheme_make_long_double(x)
#else /* MZ_LONG_DOUBLE undefined */
#define scheme_make_maybe_long_double(x) unsupported_make_long_double()
static Scheme_Object *unsupported_make_long_double() {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
return NULL;
}
#endif /* MZ_LONG_DOUBLE */
#define FOREIGN_longdouble (16)
/* Type Name: longdouble
* LibFfi type: ffi_type_slongdouble
* C type: mz_long_double
* Predicate: SCHEME_LONG_DBLP(<Scheme>)
* Racket->C: SCHEME_MAYBE_LONG_DBL_VAL(<Scheme>)
* S->C offset: 0
* C->Racket: scheme_make_maybe_long_double(<C>)
*/
/* A double that will coerce numbers to doubles: */
#define FOREIGN_doubleS (16)
#define FOREIGN_doubleS (17)
/* Type Name: double* (doubleS)
* LibFfi type: ffi_type_double
* C type: double
@ -792,7 +826,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
*/
/* Booleans -- implemented as an int which is 1 or 0: */
#define FOREIGN_bool (17)
#define FOREIGN_bool (18)
/* Type Name: bool
* LibFfi type: ffi_type_sint
* C type: int
@ -806,7 +840,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* #f is not NULL only for byte-strings, for other strings it is
* meaningless to use NULL. */
#define FOREIGN_string_ucs_4 (18)
#define FOREIGN_string_ucs_4 (19)
/* Type Name: string/ucs-4 (string_ucs_4)
* LibFfi type: ffi_type_gcpointer
* C type: mzchar*
@ -816,7 +850,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_utf_16 (19)
#define FOREIGN_string_utf_16 (20)
/* Type Name: string/utf-16 (string_utf_16)
* LibFfi type: ffi_type_gcpointer
* C type: unsigned short*
@ -829,7 +863,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Byte strings -- not copying C strings, #f is NULL.
* (note: these are not like char* which is just a pointer) */
#define FOREIGN_bytes (20)
#define FOREIGN_bytes (21)
/* Type Name: bytes
* LibFfi type: ffi_type_gcpointer
* C type: char*
@ -839,7 +873,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
*/
#define FOREIGN_path (21)
#define FOREIGN_path (22)
/* Type Name: path
* LibFfi type: ffi_type_gcpointer
* C type: char*
@ -849,7 +883,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
*/
#define FOREIGN_symbol (22)
#define FOREIGN_symbol (23)
/* Type Name: symbol
* LibFfi type: ffi_type_pointer
* C type: char*
@ -862,7 +896,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is for any C pointer: #f is NULL, cpointer values as well as
* ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */
#define FOREIGN_pointer (23)
#define FOREIGN_pointer (24)
/* Type Name: pointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -872,7 +906,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Racket: scheme_make_foreign_external_cpointer(<C>)
*/
#define FOREIGN_gcpointer (24)
#define FOREIGN_gcpointer (25)
/* Type Name: gcpointer
* LibFfi type: ffi_type_gcpointer
* C type: void*
@ -884,7 +918,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like Racket's. */
#define FOREIGN_scheme (25)
#define FOREIGN_scheme (26)
/* Type Name: scheme
* LibFfi type: ffi_type_gcpointer
* C type: Scheme_Object*
@ -897,7 +931,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
#define FOREIGN_fpointer (26)
#define FOREIGN_fpointer (27)
/* Type Name: fpointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -922,6 +956,7 @@ typedef union _ForeignAny {
uintptr_t x_ufixnum;
float x_float;
double x_double;
mz_long_double x_longdouble;
double x_doubleS;
int x_bool;
mzchar* x_string_ucs_4;
@ -936,9 +971,9 @@ typedef union _ForeignAny {
} ForeignAny;
/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (27)
#define FOREIGN_array (28)
#define FOREIGN_union (29)
#define FOREIGN_struct (28)
#define FOREIGN_array (29)
#define FOREIGN_union (30)
XFORM_NONGCING static int is_gcable_pointer(Scheme_Object *o) {
if (SCHEME_FFIOBJP(o)) return 0;
@ -1069,6 +1104,7 @@ XFORM_NONGCING static intptr_t ctype_sizeof(Scheme_Object *type)
case FOREIGN_ufixnum: return sizeof(uintptr_t);
case FOREIGN_float: return sizeof(float);
case FOREIGN_double: return sizeof(double);
case FOREIGN_longdouble: return sizeof(mz_long_double);
case FOREIGN_doubleS: return sizeof(double);
case FOREIGN_bool: return sizeof(int);
case FOREIGN_string_ucs_4: return sizeof(mzchar*);
@ -1667,6 +1703,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *already_ptr, Scheme_Object *type,
case FOREIGN_ufixnum: return scheme_make_integer_from_unsigned(REF_CTYPE(uintptr_t));
case FOREIGN_float: return scheme_make_double(REF_CTYPE(float));
case FOREIGN_double: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_longdouble: return scheme_make_maybe_long_double(REF_CTYPE(mz_long_double));
case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
@ -1902,6 +1939,21 @@ static void* SCHEME2C(const char *who,
wrong_value(who, "_double", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_longdouble:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(mz_long_double)<sizeof(intptr_t) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(intptr_t)-sizeof(mz_long_double));
}
# endif /* SCHEME_BIG_ENDIAN */
if (SCHEME_LONG_DBLP(val)) {
mz_long_double tmp;
tmp = (mz_long_double)(SCHEME_MAYBE_LONG_DBL_VAL(val));
(((mz_long_double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
} else {
wrong_value(who, "_longdouble", val);;
return NULL; /* hush the compiler */
}
case FOREIGN_doubleS:
# ifdef SCHEME_BIG_ENDIAN
if (sizeof(double)<sizeof(intptr_t) && ret_loc) {
@ -2273,7 +2325,7 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
break;
case 5: /* double */
if (intsize==0) RETSIZE(double);
else if (intsize==1) RETSIZE(long double);
else if (intsize==1) RETSIZE(mz_long_double);
else scheme_signal_error(MYNAME": bad qualifiers for 'double");
break;
default:
@ -2690,6 +2742,21 @@ static Scheme_Object *foreign_flvector_to_cpointer(int argc, Scheme_Object *argv
}
#undef MYNAME
#define MYNAME "extflvector->cpointer"
static Scheme_Object *foreign_extflvector_to_cpointer(int argc, Scheme_Object *argv[])
{
# ifdef MZ_LONG_DOUBLE
if (!SCHEME_EXTFLVECTORP(argv[0]))
scheme_wrong_contract(MYNAME, "extflvector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_EXTFLVEC_ELS((Scheme_Object *)0x0), NULL);
# else /* MZ_LONG_DOUBLE undefined */
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
MYNAME ": " NOT_SUPPORTED_STR);
return NULL;
# endif /* MZ_LONG_DOUBLE */
}
#undef MYNAME
#define MYNAME "memset"
static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[])
{
@ -3886,6 +3953,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv);
scheme_add_global("flvector->cpointer",
scheme_make_prim_w_arity(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv);
scheme_add_global("extflvector->cpointer",
scheme_make_prim_w_arity(foreign_extflvector_to_cpointer, "extflvector->cpointer", 1, 1), menv);
scheme_add_global("memset",
scheme_make_prim_w_arity(foreign_memset, "memset", 3, 5), menv);
scheme_add_global("memmove",
@ -4019,6 +4088,13 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_double));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_double);
scheme_add_global("_double", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("longdouble");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_slongdouble));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_longdouble);
scheme_add_global("_longdouble", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("double*");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
@ -4211,6 +4287,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "vector->cpointer", 1, 1), menv);
scheme_add_global("flvector->cpointer",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "flvector->cpointer", 1, 1), menv);
scheme_add_global("extflvector->cpointer",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "extflvector->cpointer", 1, 1), menv);
scheme_add_global("memset",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "memset", 3, 5), menv);
scheme_add_global("memmove",
@ -4254,6 +4332,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("_ufixnum", scheme_false, menv);
scheme_add_global("_float", scheme_false, menv);
scheme_add_global("_double", scheme_false, menv);
scheme_add_global("_longdouble", scheme_false, menv);
scheme_add_global("_double*", scheme_false, menv);
scheme_add_global("_bool", scheme_false, menv);
scheme_add_global("_string/ucs-4", scheme_false, menv);

39
src/foreign/foreign.rktc
View File

@ -738,9 +738,28 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
@(defctype* 'float "float" "FLOAT" "FLOAT" "double")
@(defctype* 'double "double" "FLOAT" "FLOAT" "double")
@;
@; Not useful? not implemented in any case.
@; (defctype* 'longdouble "long double" ...???...)
#define ffi_type_slongdouble ffi_type_longdouble
@@@IFDEF{MZ_LONG_DOUBLE}{typedef long double mz_long_double;}{typedef double mz_long_double;}
@@@IFDEF{MZ_LONG_DOUBLE}{
@DEFINE{SCHEME_MAYBE_LONG_DBL_VAL(x) SCHEME_LONG_DBL_VAL(x)}
}{
@DEFINE{SCHEME_MAYBE_LONG_DBL_VAL(x) unsupported_long_double_val()}
static mz_long_double unsupported_long_double_val() {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
return 0.0;
}
}
@@@IFDEF{MZ_LONG_DOUBLE}{
@DEFINE{scheme_make_maybe_long_double(x) scheme_make_long_double(x)}
}{
@DEFINE{scheme_make_maybe_long_double(x) unsupported_make_long_double()}
static Scheme_Object *unsupported_make_long_double() {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "_longdouble: " NOT_SUPPORTED_STR);
return NULL;
}
}
@(defctype* '(longdouble "longdouble") "mz_long_double" "LONG_DBL" "MAYBE_LONG_DBL" "maybe_long_double")
/* A double that will coerce numbers to doubles: */
@(defctype* '(double* "double") "double"
@ -1704,7 +1723,7 @@ static void* SCHEME2C(const char *who,
break;
case 5: /* double */
if (intsize==0) RETSIZE(double);
else if (intsize==1) RETSIZE(long double);
else if (intsize==1) RETSIZE(mz_long_double);
else scheme_signal_error(MYNAME": bad qualifiers for 'double");
break;
default:
@ -2073,6 +2092,18 @@ static Scheme_Object *do_memop(const char *who, int mode,
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL);
}
@cdefine[extflvector->cpointer 1]{
@@@IFDEF{MZ_LONG_DOUBLE}{
if (!SCHEME_EXTFLVECTORP(argv[0]))
scheme_wrong_contract(MYNAME, "extflvector?", 0, argc, argv);
return scheme_make_offset_cptr(argv[0], (intptr_t)SCHEME_EXTFLVEC_ELS((Scheme_Object *)0x0), NULL);
}{
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
MYNAME ": " NOT_SUPPORTED_STR);
return NULL;
}
}
@cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);}
@cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);}
@cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);}

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

@ -1,14 +1,14 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,51,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,51,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,32,0,37,0,40,0,47,0,54,0,59,0,63,0,67,0,74,0,83,
21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83,
0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0,
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,119,104,101,110,72,112,97,114,97,
109,101,116,101,114,105,122,101,64,99,111,110,100,62,111,114,66,100,101,102,105,
110,101,66,108,101,116,114,101,99,64,108,101,116,42,63,108,101,116,63,97,110,
109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,66,108,101,
116,114,101,99,64,108,101,116,42,63,97,110,100,62,111,114,64,119,104,101,110,
72,112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,64,99,111,110,
100,66,117,110,108,101,115,115,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,
@ -17,8 +17,8 @@
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,
110,91,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,
20,2,3,2,2,2,5,2,2,2,4,2,2,2,6,2,2,2,7,2,2,
2,8,2,2,2,9,2,2,2,10,2,2,2,11,2,2,2,12,2,2,97,
20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2,
2,8,2,2,2,11,2,2,2,10,2,2,2,9,2,2,2,12,2,2,97,
37,11,8,240,110,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,110,91,0,0,16,0,96,38,11,
8,240,110,91,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14,
@ -28,13 +28,13 @@
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,177,17,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,
22,177,17,199,249,22,79,2,11,248,22,178,17,201,11,18,100,10,13,16,6,
22,177,17,199,249,22,79,2,6,248,22,178,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,48,56,16,4,11,11,2,21,3,1,8,
101,110,118,49,55,52,48,57,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,177,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,177,17,201,251,22,89,2,18,2,23,2,23,249,22,79,2,6,
2,23,248,22,177,17,201,251,22,89,2,18,2,23,2,23,249,22,79,2,7,
248,22,178,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,
49,49,16,4,11,11,2,21,3,1,8,101,110,118,49,55,52,49,50,248,22,
@ -52,7 +52,7 @@
37,47,11,9,222,33,43,248,22,163,4,248,22,80,201,248,22,178,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,10,248,22,89,248,22,80,199,250,22,90,2,9,248,22,178,17,201,248,
89,2,10,248,22,89,248,22,80,199,250,22,90,2,5,248,22,178,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,154,
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,5,249,22,89,2,27,249,
22,89,21,93,2,27,248,22,80,199,250,22,90,2,11,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,154,
9,248,22,157,4,248,22,80,200,64,101,108,115,101,10,248,22,177,17,197,250,
22,90,2,22,9,248,22,178,17,200,249,22,79,2,5,248,22,81,202,99,13,
22,90,2,22,9,248,22,178,17,200,249,22,79,2,11,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,51,52,16,4,11,11,2,21,3,
1,8,101,110,118,49,55,52,51,53,18,158,94,10,64,118,111,105,100,8,48,
@ -83,24 +83,24 @@
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,114,159,36,16,1,2,
13,16,1,33,33,10,16,5,2,12,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,3,88,163,8,36,
34,36,20,114,159,36,16,1,2,13,16,0,11,16,5,2,8,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,11,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,6,88,163,8,36,37,56,37,9,223,
5,2,6,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,7,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,10,
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,8,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,9,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,4,
16,0,11,16,5,2,4,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,5,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,9,
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,5,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,7,88,163,8,36,37,
16,0,11,16,5,2,11,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,3,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,51,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,51,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,144,7,23,195,2,27,249,22,188,15,
2,99,196,28,192,28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,147,
7,198,249,22,7,250,22,166,7,199,36,248,22,103,198,197,249,22,7,250,22,
@ -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,51,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,51,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,
@ -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,51,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,51,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,
@ -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,51,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,51,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,

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

@ -325,6 +325,20 @@ int scheme_jit_check_closure_flonum_bit(Scheme_Closure_Data *data, int pos, int
else
return 0;
}
int scheme_jit_check_closure_extflonum_bit(Scheme_Closure_Data *data, int pos, int delta)
{
#ifdef MZ_LONG_DOUBLE
int ct;
pos += delta;
ct = scheme_boxmap_get(data->closure_map, pos, data->closure_size);
if (ct == (CLOS_TYPE_TYPE_OFFSET + SCHEME_LOCAL_TYPE_EXTFLONUM))
return 1;
else
return 0;
#else
return 0;
#endif
}
#endif
#ifdef NEED_LONG_BRANCHES
@ -1096,25 +1110,26 @@ int scheme_generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int offse
return 1;
}
static int generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int local_pos, int target)
static int generate_flonum_local_boxing(mz_jit_state *jitter, int pos, int local_pos, int target, int extfl)
{
int offset;
offset = scheme_mz_flostack_pos(jitter, local_pos);
offset = JIT_FRAME_FLOSTACK_OFFSET - offset;
if (jitter->unbox) {
int fpr0;
fpr0 = JIT_FPR_0(jitter->unbox_depth);
jit_ldxi_d_fppush(fpr0, JIT_FP, offset);
fpr0 = JIT_FPUSEL_FPR_0(extfl, jitter->unbox_depth);
jit_FPSEL_ldxi_xd_fppush(extfl, fpr0, JIT_FP, offset);
jitter->unbox_depth++;
} else {
mz_rs_sync();
scheme_generate_flonum_local_boxing(jitter, pos, offset, target, 0);
scheme_generate_flonum_local_boxing(jitter, pos, offset, target, extfl);
}
return 1;
}
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int extfl)
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int no_store, int extfl)
/* Move FPR0 onto C stack */
{
int sz, fpr0;
@ -1126,13 +1141,15 @@ int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int ex
jitter->flostack_space += space;
jit_subi_l(JIT_SP, JIT_SP, space);
}
jitter->flostack_offset += sz;
if (push) mz_runstack_flonum_pushed(jitter, jitter->flostack_offset);
CHECK_LIMIT();
fpr0 = MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0);
mz_st_fppop(jitter->flostack_offset, fpr0, extfl);
if (!no_store) {
fpr0 = MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0);
mz_st_fppop(jitter->flostack_offset, fpr0, extfl);
}
return 1;
}
@ -1253,10 +1270,13 @@ static int generate_closure_prep(Scheme_Closure_Data *data, mz_jit_state *jitter
size = data->closure_size;
map = data->closure_map;
for (j = 0; j < size; j++) {
if (CLOSURE_CONTENT_IS_FLONUM(data, j)) {
if (CLOSURE_CONTENT_IS_FLONUM(data, j)
|| CLOSURE_CONTENT_IS_EXTFLONUM(data, j)) {
int extfl;
extfl = CLOSURE_CONTENT_IS_EXTFLONUM(data, j);
pos = mz_remap(map[j]);
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(pos));
generate_flonum_local_boxing(jitter, pos, map[j], JIT_R1);
generate_flonum_local_boxing(jitter, pos, map[j], JIT_R1, extfl);
CHECK_LIMIT();
retval = 1;
}
@ -1964,12 +1984,17 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
{
/* Other parts of the JIT rely on this code modifying only the target register,
unless the type is SCHEME_FLONUM_TYPE */
int pos, flonum;
int pos, flonum, extfl;
START_JIT_DATA();
#ifdef USE_FLONUM_UNBOXING
flonum = (SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_FLONUM);
if (MZ_LONG_DOUBLE_AND(SCHEME_GET_LOCAL_TYPE(obj) == SCHEME_LOCAL_TYPE_EXTFLONUM))
flonum = extfl = 1;
else
extfl = 0;
#else
flonum = 0;
extfl = 0;
#endif
pos = mz_remap(SCHEME_LOCAL_POS(obj));
LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj)));
@ -2026,7 +2051,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
CHECK_LIMIT();
if (flonum && !result_ignored) {
#ifdef USE_FLONUM_UNBOXING
generate_flonum_local_boxing(jitter, pos, SCHEME_LOCAL_POS(obj), target);
generate_flonum_local_boxing(jitter, pos, SCHEME_LOCAL_POS(obj), target, extfl);
CHECK_LIMIT();
#endif
} else {
@ -2838,7 +2863,7 @@ 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, unused;
int flonum, unused, extfl;
mz_jit_unbox_state ubs;
START_JIT_DATA();
@ -2850,23 +2875,30 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
#ifdef USE_FLONUM_UNBOXING
flonum = (SCHEME_LET_ONE_TYPE(lv) == SCHEME_LOCAL_TYPE_FLONUM);
if (MZ_LONG_DOUBLE_AND(SCHEME_LET_ONE_TYPE(lv) == SCHEME_LOCAL_TYPE_EXTFLONUM))
flonum = extfl = 1;
else
extfl = 0;
#else
flonum = 0;
flonum = extfl = 0;
#endif
unused = SCHEME_LET_EVAL_TYPE(lv) & LET_ONE_UNUSED;
PAUSE_JIT_DATA();
if (flonum) {
#ifdef USE_FLONUM_UNBOXING
if (scheme_can_unbox_inline(lv->value, 5, JIT_FPR_NUM-1, 0, 0)) {
if (scheme_can_unbox_inline(lv->value, 5, JIT_FPUSEL_FPR_NUM(extfl)-1, 0, extfl)) {
jitter->unbox++;
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++;);
scheme_generate_unboxed(lv->value, jitter, 2, 0);
} else if (scheme_can_unbox_directly(lv->value, 0)) {
} else if (scheme_can_unbox_directly(lv->value, extfl)) {
jitter->unbox++;
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++;);
scheme_generate_unboxed(lv->value, jitter, 1, 0);
} else {
/* validator should ensure that this is ok */
jitter->unbox++;
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++;);
scheme_generate_unboxed(lv->value, jitter, 0, 1);
}
#endif
@ -2887,11 +2919,12 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
if (flonum) {
#ifdef USE_FLONUM_UNBOXING
MZ_FPUSEL_STMT_ONLY(extfl, --jitter->unbox_extflonum);
--jitter->unbox;
--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, 0);
scheme_generate_flonum_local_unboxing(jitter, 1, 0, extfl);
CHECK_LIMIT();
(void)jit_movi_p(JIT_R0, NULL);
#endif
@ -3387,10 +3420,15 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
zref = jit_bnei_l(jit_forward(), JIT_R1, f_offset);
for (i = data->num_params; i--; ) {
if (CLOSURE_ARGUMENT_IS_FLONUM(data, i)) {
if (CLOSURE_ARGUMENT_IS_FLONUM(data, i)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(data, i)) {
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(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, 0);
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxi_ld_fppush(JIT_FPU_FPR0, JIT_R1, &((Scheme_Long_Double *)0x0)->long_double_val),
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val));
scheme_generate_flonum_local_unboxing(jitter, 1, 0, extfl);
CHECK_LIMIT();
} else {
mz_runstack_pushed(jitter, 1);
@ -3463,10 +3501,15 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
} else {
#ifdef USE_FLONUM_UNBOXING
if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS)
&& (CLOSURE_CONTENT_IS_FLONUM(data, i))) {
&& (CLOSURE_CONTENT_IS_FLONUM(data, i)
|| CLOSURE_CONTENT_IS_EXTFLONUM(data, i))) {
int extfl;
extfl = CLOSURE_CONTENT_IS_EXTFLONUM(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, 0);
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxi_ld_fppush(JIT_FPU_FPR0, JIT_R1, &((Scheme_Long_Double *)0x0)->long_double_val),
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val));
scheme_generate_flonum_local_unboxing(jitter, 1, 0, extfl);
CHECK_LIMIT();
} else
#endif
@ -3482,10 +3525,15 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
/* Unpack flonum closure data */
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
for (i = data->closure_size; i--; ) {
if (CLOSURE_CONTENT_IS_FLONUM(data, i)) {
if (CLOSURE_CONTENT_IS_FLONUM(data, i)
|| CLOSURE_CONTENT_IS_EXTFLONUM(data, i)) {
int extfl;
extfl = CLOSURE_CONTENT_IS_EXTFLONUM(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, 0);
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxi_ld_fppush(JIT_FPU_FPR0, JIT_R1, &((Scheme_Long_Double *)0x0)->long_double_val),
jit_ldxi_d_fppush(JIT_FPR0, JIT_R1, &((Scheme_Double *)0x0)->double_val));
scheme_generate_flonum_local_unboxing(jitter, 1, 0, extfl);
CHECK_LIMIT();
} else {
mz_runstack_pushed(jitter, 1);

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

@ -523,8 +523,10 @@ 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))
# ifdef MZ_LONG_DOUBLE
# 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))
# endif
#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)
@ -1441,10 +1443,9 @@ 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 extfl);
int scheme_generate_flonum_local_unboxing(mz_jit_state *jitter, int push, int no_store, 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);
void scheme_generate_non_tail_mark_pos_suffix(mz_jit_state *jitter);
@ -1479,6 +1480,9 @@ int scheme_is_non_gc(Scheme_Object *obj, int depth);
int scheme_jit_check_closure_flonum_bit(Scheme_Closure_Data *data, int pos, int delta);
# define CLOSURE_ARGUMENT_IS_FLONUM(data, pos) scheme_jit_check_closure_flonum_bit(data, pos, 0)
# define CLOSURE_CONTENT_IS_FLONUM(data, pos) scheme_jit_check_closure_flonum_bit(data, pos, data->num_params)
int scheme_jit_check_closure_extflonum_bit(Scheme_Closure_Data *data, int pos, int delta);
# define CLOSURE_ARGUMENT_IS_EXTFLONUM(data, pos) scheme_jit_check_closure_extflonum_bit(data, pos, 0)
# define CLOSURE_CONTENT_IS_EXTFLONUM(data, pos) scheme_jit_check_closure_extflonum_bit(data, pos, data->num_params)
#endif
Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc, int local_only);
@ -1569,3 +1573,4 @@ Scheme_Object *scheme_jit_continuation_apply_install(Apply_LWC_Args *args);

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

@ -150,13 +150,11 @@ 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);
}
#ifdef MZ_LONG_DOUBLE
else if (keep_extfpr1) {
} else if (keep_extfpr1) {
(void)jit_calli(sjc.retry_alloc_code_keep_extfpr1);
}
#endif
else {
} else {
(void)jit_calli(sjc.retry_alloc_code);
}
__START_TINY_JUMPS__(1);

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

@ -119,6 +119,7 @@ static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely, in
if (IS_NAMED_PRIM(obj, "unsafe-extflmin")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-extflmax")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-fx->extfl")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-f80vector-ref")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-extflvector-ref")) return 1;
if (unsafely) {
@ -263,9 +264,10 @@ int scheme_can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely
return 1;
}
}
#ifdef MZ_LONG_DOUBLE_UNBOXED
#ifdef MZ_LONG_DOUBLE
if ((SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)
&& (IS_NAMED_PRIM(app->rator, "unsafe-extflvector-ref"))) {
&& (IS_NAMED_PRIM(app->rator, "unsafe-f80vector-ref")
|| IS_NAMED_PRIM(app->rator, "unsafe-extflvector-ref"))) {
if (is_unboxing_immediate(app->rand1, 1, extfl)
&& is_unboxing_immediate(app->rand2, 1, extfl)) {
return 1;
@ -303,7 +305,7 @@ int scheme_can_unbox_directly(Scheme_Object *obj, int extfl)
|| IS_NAMED_PRIM(app->rator, "fx->fl"))
return 1;
}
#ifdef MZ_LONG_DOUBLE_UNBOXED
#ifdef MZ_LONG_DOUBLE
if (extfl) {
if (IS_NAMED_PRIM(app->rator, "->extfl")
|| IS_NAMED_PRIM(app->rator, "fx->extfl"))
@ -324,7 +326,7 @@ int scheme_can_unbox_directly(Scheme_Object *obj, int extfl)
if (!extfl) {
if (IS_NAMED_PRIM(app->rator, "flvector-ref")) return 1;
}
#ifdef MZ_LONG_DOUBLE_UNBOXED
#ifdef MZ_LONG_DOUBLE
if (extfl) {
if (IS_NAMED_PRIM(app->rator, "extflvector-ref")) return 1;
}
@ -560,7 +562,7 @@ int scheme_generate_alloc_long_double(mz_jit_state *jitter, int inline_retry, in
{
#ifdef INLINE_FP_OPS
# ifdef CAN_INLINE_ALLOC
scheme_inline_alloc(jitter, sizeof(Scheme_Long_Double), scheme_long_double_type, 0, 0, 1, inline_retry, 1);
scheme_inline_alloc(jitter, sizeof(Scheme_Long_Double), scheme_long_double_type, 0, 0, 0, inline_retry, 1);
CHECK_LIMIT();
jit_addi_p(dest, JIT_V1, OBJHEAD_SIZE);
(void)jit_fpu_stxi_ld_fppop(&((Scheme_Long_Double *)0x0)->long_double_val, dest, JIT_FPU_FPR0);
@ -660,11 +662,12 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
/* inexact->exact needs no extra number */
} else {
#ifdef MZ_LONG_DOUBLE
long double ld = second_const;
#endif
long double d = second_const;
#else
double d = second_const;
#endif
MZ_FPUSEL_STMT(extfl,
mz_fpu_movi_ld_fppush(fpr1, ld, JIT_R2),
mz_fpu_movi_ld_fppush(fpr1, d, JIT_R2),
mz_movi_d_fppush(fpr1, d, JIT_R2));
reversed = !reversed;
cmp = -cmp;
@ -679,7 +682,13 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
}
#ifdef DIRECT_FPR_ACCESS
if (unboxed && !extfl) {
# define USES_DIRECT_FPR_ACCESS (!extfl)
#else
# define USES_DIRECT_FPR_ACCESS 0
#endif
#ifdef DIRECT_FPR_ACCESS
if (unboxed && USES_DIRECT_FPR_ACCESS) {
/* arguments are backward */
reversed = !reversed;
cmp = -cmp;
@ -783,9 +792,9 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
__START_TINY_JUMPS__(1);
refs2 = jit_bner_l(jit_forward(), JIT_R1, JIT_R2);
__END_TINY_JUMPS__(1);
#ifndef DIRECT_FPR_ACCESS
if (unboxed)
jit_FPSEL_roundr_xd_l_fppop(extfl, JIT_R1, fpr2); /* slow path won't be needed */
#if !defined(DIRECT_FPR_ACCESS) || defined(MZ_LONG_DOUBLE)
if (unboxed && !USES_DIRECT_FPR_ACCESS)
jit_FPSEL_roundr_xd_l_fppop(extfl, JIT_R1, fpr1+1); /* slow path won't be needed */
#endif
}
jit_fixnum_l(dest, JIT_R1);
@ -913,13 +922,13 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
scheme_generate_alloc_X_double(jitter, 0, dest, extfl);
CHECK_LIMIT();
#if defined(MZ_USE_JIT_I386)
if (need_post_pop)
if (need_post_pop && !USES_DIRECT_FPR_ACCESS)
FSTPr(0);
#endif
} else if (unboxed_result) {
jitter->unbox_depth++;
#if defined(MZ_USE_JIT_I386)
if (need_post_pop) {
if (need_post_pop && !USES_DIRECT_FPR_ACCESS) {
FXCHr(1);
FSTPr(0);
}
@ -1105,11 +1114,11 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
if (!rand) {
inlined_flonum1 = inlined_flonum2 = 1;
} else {
if (scheme_can_unbox_inline(rand, 5, MZ_FPUSEL(extfl, JIT_FPU_FPR_NUM, JIT_FPR_NUM)-2, unsafe_fl > 0, extfl))
if (scheme_can_unbox_inline(rand, 5, JIT_FPUSEL_FPR_NUM(extfl)-2, unsafe_fl > 0, extfl))
inlined_flonum1 = 1;
else
inlined_flonum1 = 0;
if (!rand2 || scheme_can_unbox_inline(rand2, 5, MZ_FPUSEL(extfl, JIT_FPU_FPR_NUM, JIT_FPR_NUM)-3, unsafe_fl > 0, extfl))
if (!rand2 || scheme_can_unbox_inline(rand2, 5, JIT_FPUSEL_FPR_NUM(extfl)-3, unsafe_fl > 0, extfl))
inlined_flonum2 = 1;
else
inlined_flonum2 = 0;
@ -1188,7 +1197,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
#ifdef USE_FLONUM_UNBOXING
flostack = scheme_mz_flostack_save(jitter, &flopos);
--jitter->unbox_depth;
scheme_generate_flonum_local_unboxing(jitter, 0, extfl);
scheme_generate_flonum_local_unboxing(jitter, 0, 0, extfl);
CHECK_LIMIT();
#endif
}
@ -1231,8 +1240,8 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
flonum_depth = 2;
}
if (args_unboxed) {
--jitter->unbox;
MZ_FPUSEL_STMT_ONLY(extfl, --jitter->unbox_extflonum);
--jitter->unbox;
}
jitter->unbox_depth -= flonum_depth;
if (!jitter->unbox && jitter->unbox_depth && rand)

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

@ -1071,7 +1071,8 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
}
static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, int num_rands, GC_CAN_IGNORE jit_insn *slow_code,
int args_already_in_place, Scheme_App_Rec *app, Scheme_Object **alt_rands)
int args_already_in_place, int direct_flostack_offset,
Scheme_App_Rec *app, Scheme_Object **alt_rands)
/* Last argument is in R0 */
{
GC_CAN_IGNORE jit_insn *refslow, *refagain;
@ -1107,7 +1108,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
offset = jitter->flostack_offset;
space = jitter->flostack_space;
#ifdef USE_FLONUM_UNBOXING
arg_tmp_offset = offset;
arg_tmp_offset = offset - direct_flostack_offset;
#endif
/* Copy args to runstack after closure data: */
@ -1116,32 +1117,37 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
for (i = num_rands; i--; ) {
int already_loaded = (i == num_rands - 1);
#ifdef USE_FLONUM_UNBOXING
int is_flonum, already_unboxed = 0;
int is_flonum, already_unboxed = 0, extfl = 0;
if ((SCHEME_CLOSURE_DATA_FLAGS(jitter->self_data) & CLOS_HAS_TYPED_ARGS)
&& CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i + args_already_in_place)) {
&& (CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i + args_already_in_place)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i + args_already_in_place))) {
is_flonum = 1;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i + args_already_in_place);
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, 0);
arg_tmp_offset -= sizeof(double);
arg_tmp_offset += MZ_FPUSEL(extfl, 2*sizeof(double), sizeof(double));
mz_ld_fppush(MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0), arg_tmp_offset, extfl);
already_unboxed = 1;
if (!already_loaded && !SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
already_loaded = 1;
(void)jit_movi_p(JIT_R0, NULL);
}
} else
is_flonum = 0;
is_flonum = extfl = 0;
#endif
if (!already_loaded)
jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(i));
jit_stxi_p(WORDS_TO_BYTES(i + closure_size + args_already_in_place), JIT_R2, JIT_R0);
#ifdef USE_FLONUM_UNBOXING
if (is_flonum) {
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, 0);
if (!already_unboxed) {
MZ_FPUSEL_STMT(extfl,
jit_fpu_ldxi_ld_fppush(JIT_FPU_FPR0, JIT_R0, &((Scheme_Long_Double *)0x0)->long_double_val),
jit_ldxi_d_fppush(JIT_FPR0, JIT_R0, &((Scheme_Double *)0x0)->double_val));
}
arg_offset += MZ_FPUSEL(extfl, 2*sizeof(double), sizeof(double));
mz_st_fppop(arg_offset, MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0), extfl);
}
#endif
CHECK_LIMIT();
@ -1171,20 +1177,27 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
#ifdef USE_FLONUM_UNBOXING
/* Need to box any arguments that we have only in flonum form */
if (SCHEME_CLOSURE_DATA_FLAGS(jitter->self_data) & CLOS_HAS_TYPED_ARGS) {
arg_tmp_offset = offset;
arg_tmp_offset = offset - direct_flostack_offset;
for (i = num_rands; i--; ) {
if (CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i + args_already_in_place)) {
if (CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i + args_already_in_place)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i + args_already_in_place)) {
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i + args_already_in_place);
rand = (alt_rands
? alt_rands[i+1+args_already_in_place]
: app->args[i+1+args_already_in_place]);
if (!SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)
|| (SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FLONUM)) {
int aoffset = JIT_FRAME_FLOSTACK_OFFSET - arg_tmp_offset;
|| (!extfl && (SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FLONUM))
|| (extfl && (SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_EXTFLONUM))) {
GC_CAN_IGNORE jit_insn *iref;
int aoffset;
arg_tmp_offset += MZ_FPUSEL(extfl, 2*sizeof(double), sizeof(double));
aoffset = JIT_FRAME_FLOSTACK_OFFSET - arg_tmp_offset;
if (i != num_rands - 1)
mz_pushr_p(JIT_R0);
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
/* assert: SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_FLONUM */
/* or SCHEME_GET_LOCAL_TYPE(rand) == SCHEME_LOCAL_TYPE_EXTFLONUM */
/* have to check for an existing box */
if (i != num_rands - 1)
mz_rs_ldxi(JIT_R0, i+1);
@ -1196,7 +1209,9 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
iref = NULL;
jit_movi_l(JIT_R0, aoffset);
mz_rs_sync();
(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));
if (i != num_rands - 1)
mz_rs_stxi(i+1, JIT_R0);
if (iref) {
@ -1207,7 +1222,6 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
CHECK_LIMIT();
if (i != num_rands - 1)
mz_popr_p(JIT_R0);
arg_tmp_offset -= sizeof(double);
}
}
}
@ -1215,8 +1229,11 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
/* Arguments already in place may also need to be boxed. */
arg_tmp_offset = jitter->self_restart_offset;
for (i = 0; i < args_already_in_place; i++) {
if (CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i)) {
if (CLOSURE_ARGUMENT_IS_FLONUM(jitter->self_data, i)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i)) {
GC_CAN_IGNORE jit_insn *iref;
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(jitter->self_data, i);
mz_pushr_p(JIT_R0);
mz_ld_runstack_base_alt(JIT_R2);
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_R2), WORDS_TO_BYTES(num_rands + args_already_in_place));
@ -1228,7 +1245,9 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
{
int aoffset = JIT_FRAME_FLOSTACK_OFFSET - arg_tmp_offset;
jit_movi_l(JIT_R0, aoffset);
(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_ld_runstack_base_alt(JIT_R2);
jit_subi_p(JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_R2), WORDS_TO_BYTES(num_rands + args_already_in_place));
jit_stxi_p(WORDS_TO_BYTES(i), JIT_R2, JIT_R0);
@ -1238,7 +1257,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i
__END_TINY_JUMPS__(1);
mz_popr_p(JIT_R0);
CHECK_LIMIT();
arg_tmp_offset -= sizeof(double);
arg_tmp_offset -= MZ_FPUSEL(extfl, 2*sizeof(double), sizeof(double));
}
}
}
@ -1515,58 +1534,24 @@ static jit_direct_arg *check_special_direct_args(Scheme_App_Rec *app, Scheme_Obj
#ifdef USE_FLONUM_UNBOXING
static int generate_fp_argument_shuffle(int direct_flostack_offset, mz_jit_state *jitter)
static int generate_fp_argument_shift(int direct_flostack_offset, mz_jit_state *jitter, int src_fp_reg)
{
int i, j;
int i;
/* Copy unboxed flonums into place where the target code expects them,
which is shifted and reverse of the order that we pushed. */
if (direct_flostack_offset
&& ((direct_flostack_offset > sizeof(double))
|| (direct_flostack_offset != jitter->flostack_offset))) {
/* If the source and target areas don't overlap (or if they
overlap only by one item), we can do it in one step, otherwise
reverse then shift. */
if (jitter->flostack_offset >= ((2 * direct_flostack_offset) - sizeof(double))) {
/* one step: */
if (direct_flostack_offset != jitter->flostack_offset) {
/* shift: */
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);
a_pos = direct_flostack_offset - i;
if (i_pos != a_pos) {
mz_ld_fppush(JIT_FPR0, i_pos, 0);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
}
}
} else {
/* reverse: */
for (i = 0, j = direct_flostack_offset-sizeof(double); i < j; i += sizeof(double), j -= sizeof(double)) {
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, 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();
}
if (direct_flostack_offset != jitter->flostack_offset) {
/* shift: */
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, 0);
a_pos = i + sizeof(double);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
}
}
if ((src_fp_reg == JIT_FP)
&& (jitter->flostack_offset == direct_flostack_offset))
/* no shift needed */
return 1;
/* Since we're just shifting bytes, it's ok to pretend that all
boxed values are `double's. */
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_x(JIT_FPR0, i_pos, src_fp_reg, 0);
a_pos = i + sizeof(double);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
return 1;
@ -1585,18 +1570,12 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos
/* Callback code to copy unboxed arguments.
R1 has the return address, R2 holds the old FP */
offset = FLOSTACK_SPACE_CHUNK * ((direct_flostack_offset + (FLOSTACK_SPACE_CHUNK - 1))
offset = FLOSTACK_SPACE_CHUNK * ((direct_flostack_offset + (FLOSTACK_SPACE_CHUNK - 1))
/ FLOSTACK_SPACE_CHUNK);
jit_subi_l(JIT_SP, JIT_SP, offset);
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);
a_pos = direct_flostack_offset - i;
mz_ld_fppush_x(JIT_FPR0, i_pos, JIT_R2, 0);
mz_st_fppop(a_pos, JIT_FPR0, 0);
CHECK_LIMIT();
}
generate_fp_argument_shift(direct_flostack_offset, jitter, JIT_R2);
CHECK_LIMIT();
jit_jmpr(JIT_R1);
@ -1617,12 +1596,16 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos
/* box arguments for slow path */
for (i = 0, k = 0; i < num_rands; i++) {
if ((SCHEME_CLOSURE_DATA_FLAGS(direct_data) & CLOS_HAS_TYPED_ARGS)
&& (CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i))) {
k += sizeof(double);
&& (CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_data, i))) {
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_data, i);
k += MZ_FPUSEL(extfl, 2*sizeof(double), sizeof(double));
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, 0);
scheme_generate_flonum_local_boxing(jitter, i, offset, JIT_R0, extfl);
}
}
@ -1632,7 +1615,6 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos
return 1;
}
#endif
int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands,
@ -1905,6 +1887,23 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
direct_data = jitter->self_data;
#endif
#ifdef USE_FLONUM_UNBOXING
/* we want to push flonums into local storage in reverse order
of evaluation, so make a pass to create space: */
if (direct_data
&& (SCHEME_CLOSURE_DATA_FLAGS(direct_data) & CLOS_HAS_TYPED_ARGS)) {
for (i = num_rands; i--; ) {
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_data, i+args_already_in_place);
if (extfl || CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i+args_already_in_place)) {
/* make space: */
scheme_generate_flonum_local_unboxing(jitter, 0, 1, extfl);
CHECK_LIMIT();
}
}
}
#endif
for (i = 0; i < num_rands; i++) {
PAUSE_JIT_DATA();
arg = (alt_rands
@ -1918,30 +1917,40 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
#ifdef USE_FLONUM_UNBOXING
if (direct_data
&& (SCHEME_CLOSURE_DATA_FLAGS(direct_data) & CLOS_HAS_TYPED_ARGS)
&& (CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i+args_already_in_place))) {
&& (CLOSURE_ARGUMENT_IS_FLONUM(direct_data, i+args_already_in_place)
|| CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_data, i+args_already_in_place))) {
int directly;
int extfl;
extfl = CLOSURE_ARGUMENT_IS_EXTFLONUM(direct_data, i+args_already_in_place);
jitter->unbox++;
if (scheme_can_unbox_inline(arg, 5, JIT_FPR_NUM-1, 0, 0))
MZ_FPUSEL_STMT_ONLY(extfl, jitter->unbox_extflonum++);
if (scheme_can_unbox_inline(arg, 5, JIT_FPUSEL_FPR_NUM(extfl)-1, 0, extfl))
directly = 2;
else if (scheme_can_unbox_directly(arg, 0))
else if (scheme_can_unbox_directly(arg, extfl))
directly = 1;
else
directly = 0;
scheme_generate_unboxed(arg, jitter, directly, 1);
MZ_FPUSEL_STMT_ONLY(extfl, --jitter->unbox_extflonum);
--jitter->unbox;
--jitter->unbox_depth;
CHECK_LIMIT();
scheme_generate_flonum_local_unboxing(jitter, 0, 0);
/* use space made by scheme_generate_flonum_local_unboxing() above: */
mz_st_fppop(jitter->flostack_offset - direct_flostack_offset,
MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0),
extfl);
direct_flostack_offset += MZ_FPUSEL(extfl, 2 * sizeof(double), sizeof(double));
CHECK_LIMIT();
if (SAME_TYPE(SCHEME_TYPE(arg), scheme_local_type)) {
/* Keep local Scheme_Object view, in case a box has been allocated */
/* Keep local Scheme_Object* view, in case a box has been allocated */
int apos;
apos = mz_remap(SCHEME_LOCAL_POS(arg));
mz_rs_ldxi(JIT_R0, apos);
} else {
(void)jit_movi_p(JIT_R0, NULL);
}
direct_flostack_offset += sizeof(double);
} else
#endif
if (inline_direct_args) {
@ -2051,13 +2060,14 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
code = sjc.shared_tail_code[dp][num_rands];
if (direct_self) {
LOG_IT(("<-self\n"));
generate_self_tail_call(rator, jitter, num_rands, code, args_already_in_place, app, alt_rands);
generate_self_tail_call(rator, jitter, num_rands, code, args_already_in_place, direct_flostack_offset,
app, alt_rands);
CHECK_LIMIT();
} else if (inline_direct_native) {
LOG_IT(("<-native-tail\n"));
#ifdef USE_FLONUM_UNBOXING
/* Copy unboxed flonums into place where the target code expects them: */
generate_fp_argument_shuffle(direct_flostack_offset, jitter);
generate_fp_argument_shift(direct_flostack_offset, jitter, JIT_FP);
CHECK_LIMIT();
#endif
scheme_mz_flostack_restore(jitter,

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

@ -1698,7 +1698,9 @@ static int common4(mz_jit_state *jitter, void *_data)
jit_movi_i(JIT_R1, 3);
if (i == 2) {
/* need to box flonum */
scheme_generate_alloc_double(jitter, 1, JIT_R0);
MZ_FPUSEL_STMT(iii,
scheme_generate_alloc_long_double(jitter, 1, JIT_R0),
scheme_generate_alloc_double(jitter, 1, JIT_R0));
jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R0);
}
}
@ -2152,13 +2154,11 @@ static int common5(mz_jit_state *jitter, void *_data)
sjc.retry_alloc_code = jit_get_ip().ptr;
else if (i == 1)
sjc.retry_alloc_code_keep_r0_r1 = jit_get_ip().ptr;
else if (i == 2) {
else if (i == 2)
sjc.retry_alloc_code_keep_fpr1 = jit_get_ip().ptr;
}
#ifdef MZ_LONG_DOUBLE
else if (i == 3) {
else if (i == 3)
sjc.retry_alloc_code_keep_extfpr1 = jit_get_ip().ptr;
}
#endif
mz_prolog(JIT_V1);
@ -2248,9 +2248,26 @@ static int common5(mz_jit_state *jitter, void *_data)
mz_epilog(JIT_R2);
}
#ifdef MZ_LONG_DOUBLE
/* *** box_extflonum_from_stack_code *** */
/* R0 has offset from frame pointer to long double on stack */
{
sjc.box_extflonum_from_stack_code = jit_get_ip().ptr;
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
jit_movr_p(JIT_R1, JIT_FP);
jit_fpu_ldxr_ld_fppush(JIT_FPU_FPR0, JIT_R1, JIT_R0);
scheme_generate_alloc_long_double(jitter, 1, JIT_R0);
CHECK_LIMIT();
mz_epilog(JIT_R2);
}
/* *** box_extflonum_from_reg_code *** */
/* JIT_FPU_FPR2 (reg-based) or JIT_FPU_FPR0 (stack-based) has value */
#ifdef MZ_LONG_DOUBLE
{
sjc.box_extflonum_from_reg_code = jit_get_ip().ptr;
@ -2258,10 +2275,6 @@ static int common5(mz_jit_state *jitter, void *_data)
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();

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

@ -1372,9 +1372,10 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "fxvector-length")) {
for_fx = 1;
} else if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "extflvector-length"))) {
for_fl = 1;
extfl = 1;
unsafe = 1;
} else if (MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-length"))) {
for_fl = 1;
extfl = 1;
unsafe = 1;
} else {
@ -2590,6 +2591,9 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} 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, "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;
@ -3013,14 +3017,17 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-ref")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref"))) {
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-f80vector-ref"))) {
int fpr0;
int is_f64;
int extfl;
mz_jit_unbox_state ubs;
is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-ref");
extfl = MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref"));
is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-ref")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-f80vector-ref"));
extfl = MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-f80vector-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);
@ -3042,7 +3049,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
}
if (jitter->unbox)
fpr0 = JIT_FPR_0(jitter->unbox_depth);
fpr0 = JIT_FPUSEL_FPR_0(jitter->unbox_extflonum, jitter->unbox_depth);
else
fpr0 = MZ_FPUSEL(extfl, JIT_FPU_FPR0, JIT_FPR0);
@ -3950,13 +3957,16 @@ 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!")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-set!"))) {
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-f80vector-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!"));
is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-set!")
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-f80vector-set!"));
extfl = MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-extflvector-set!"))
|| MZ_LONG_DOUBLE_AND(IS_NAMED_PRIM(rator, "unsafe-f80vector-set!"));
if (scheme_is_constant_and_avoids_r1(app->args[1])
&& scheme_is_constant_and_avoids_r1(app->args[2])) {

13
src/racket/src/lightning/i386/fp-extfpu.h
View File

@ -162,6 +162,12 @@ union jit_fpu_double_imm {
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_ldr_d_fppush(rd, JIT_R0), \
MOVQrr(JIT_REXTMP, JIT_R0))
#define jit_fpu_ldi_ld_fppush(rd, is) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_ldr_ld_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)) \
@ -261,6 +267,13 @@ union jit_fpu_double_imm {
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_str_d_fppop(JIT_R0, rd), \
MOVQrr(JIT_REXTMP, JIT_R0))
#define jit_fpu_sti_ld_fppop(is, rd) \
(MOVQrr(JIT_R0, JIT_REXTMP), \
MOVQir(((intptr_t)is), JIT_R0), \
jit_fpu_str_ld_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))

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

@ -208,6 +208,9 @@ static Scheme_Object *TO_FLOAT(const Scheme_Object *n);
#endif
Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n);
static Scheme_Object *extfl_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *extfl_set (int argc, Scheme_Object *argv[]);
#ifdef MZ_LONG_DOUBLE
static Scheme_Object *exact_to_extfl(int argc, Scheme_Object *argv[]);
#endif
@ -1487,6 +1490,28 @@ void scheme_init_extfl_unsafe_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_THIRD);
scheme_add_global_constant("unsafe-extflvector-set!", p, env);
p = scheme_make_immed_prim(extfl_ref, "unsafe-f80vector-ref",
2, 2);
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_OMITABLE
| SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_PRODUCES_EXTFLONUM);
scheme_add_global_constant("unsafe-f80vector-ref", p, env);
p = scheme_make_immed_prim(extfl_set, "unsafe-f80vector-set!",
3, 3);
if (MZ_LONG_DOUBLE_AND(1))
flags = SCHEME_PRIM_IS_NARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_WANTS_EXTFLONUM_THIRD);
scheme_add_global_constant("unsafe-f80vector-set!", p, env);
}
Scheme_Object *
@ -2485,8 +2510,40 @@ double scheme_double_floor(double x) { return floor(x); }
double scheme_double_ceiling(double x) { return ceil(x); }
#ifdef MZ_LONG_DOUBLE
XFORM_NONGCING static long double SCH_ROUNDL(long double d)
{
long double i, frac;
int invert;
#ifdef FMOD_CAN_RETURN_POS_ZERO
if ((d == 0.0L) && long_minus_zero_p(d))
return d;
#endif
if (d < 0.0L) {
d = -d;
invert = 1;
} else
invert = 0;
frac = modfl(d, &i);
if (frac < 0.5L)
d = i;
else if (frac > 0.5L)
d = i + 1;
else if (fmodl(i, 2.0L) != 0.0L)
d = i + 1;
else
d = i;
if (invert)
d = -d;
return d;
}
long double scheme_long_double_truncate(long double x) { return truncl(x); }
long double scheme_long_double_round(long double x) { return roundl(x); }
long double scheme_long_double_round(long double x) { return SCH_ROUNDL(x); }
long double scheme_long_double_floor(long double x) { return floorl(x); }
long double scheme_long_double_ceiling(long double x) { return ceill(x); }
#endif
@ -4618,6 +4675,31 @@ Scheme_Object *scheme_extflvector_length(Scheme_Object *vec)
#endif
}
static Scheme_Object *extfl_ref (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
long double v;
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
v = ((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
return scheme_make_long_double(v);
#else
return unsupported("unsafe-f80vector-ref");
#endif
}
static Scheme_Object *extfl_set (int argc, Scheme_Object *argv[])
{
#ifdef MZ_LONG_DOUBLE
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
((long double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_LONG_DBL_VAL(argv[2]);
return scheme_void;
#else
return unsupported("unsafe-f80vector-set!");
#endif
}
static Scheme_Object *extflvector_length (int argc, Scheme_Object *argv[])
{
return scheme_extflvector_length(argv[0]);
@ -4995,8 +5077,8 @@ static Scheme_Object *extfl_to_fx (int argc, Scheme_Object *argv[])
Scheme_Object *o;
if (!SCHEME_LONG_DBLP(argv[0])
&& !scheme_is_integer(argv[0]))
scheme_wrong_contract("extfl->fx", "(and/c extflonum? integer?)", 0, argc, argv);
/* && !scheme_is_integer(argv[0]) */)
scheme_wrong_contract("extfl->fx", "(and/c extflonum?)", 0, argc, argv);
d = SCHEME_LONG_DBL_VAL(argv[0]);
v = (intptr_t)d;

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

@ -15,7 +15,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1086
#define EXPECTED_UNSAFE_COUNT 98
#define EXPECTED_UNSAFE_COUNT 100
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.3.2"
#define MZSCHEME_VERSION "5.3.3.3"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 3
#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)