Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
cb786538
Commit
cb786538
authored
Nov 12, 2008
by
rtoy
Browse files
Merge in SSE2 changes from sse2-packed-branch (tag
sse2-packed-2008-11-12).
parent
139b5ed6
Changes
48
Expand all
Hide whitespace changes
Inline
Side-by-side
bootfiles/19e/boot-2008-09-sse2.lisp
0 → 100644
View file @
cb786538
;; Bootstrap file for cross-compiling SSE2 support for x86.
(
in-package
:cl-user
)
;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
(
rename-package
"X86"
"OLD-X86"
'
(
"OLD-VM"
))
(
setf
(
c:backend-name
c:*native-backend*
)
"OLD-X86"
)
(
c::new-backend
"X86"
;; Features to add here. These are just examples. You may not
;; need to list anything here. We list them here anyway as a
;; record of typical features for all x86 ports.
'
(
:x86
:i486
:pentium
:stack-checking
; Catches stack overflow
:heap-overflow-check
; Catches heap overflows
:relative-package-names
; relative package names
:mp
; multiprocessing
:gencgc
; Generational GC
:conservative-float-type
:hash-new
:random-mt19937
:cmu
:cmu19
:cmu19e
; Version features
:double-double
; double-double float support
:sse2
; SSE2 support
:complex-fp-vops
; VOPs for complex arithmetic
)
;; Features to remove from current *features* here. Normally don't
;; need to list anything here unless you are trying to remove a
;; feature.
'
(
:x86-bootstrap
;; :alpha :osf1 :mips
:propagate-fun-type
:propagate-float-type
:constrain-float-type
;; :openbsd :freebsd :glibc2 :linux
:long-float
:new-random
:small
))
;;; Compile the new backend.
(
pushnew
:bootstrap
*features*
)
(
pushnew
:building-cross-compiler
*features*
)
(
pushnew
:sse2
*features*
)
(
pushnew
:complex-fp-vops
*features*
)
(
load
"target:tools/comcom"
)
;;; Load the new backend.
(
setf
(
search-list
"c:"
)
'
(
"target:compiler/"
))
(
setf
(
search-list
"vm:"
)
'
(
"c:x86/"
"c:generic/"
))
(
setf
(
search-list
"assem:"
)
'
(
"target:assembly/"
"target:assembly/x86/"
))
;; Load the backend of the compiler.
;; Why do it explicitly this way? Why not use loadbackend.lisp?
(
in-package
"C"
)
(
load
"vm:vm-macs"
)
(
load
"vm:parms"
)
(
load
"vm:objdef"
)
(
load
"vm:interr"
)
(
load
"assem:support"
)
(
load
"target:compiler/srctran"
)
(
load
"vm:vm-typetran"
)
(
load
"target:compiler/float-tran"
)
(
load
"target:compiler/saptran"
)
(
load
"vm:macros"
)
(
load
"vm:utils"
)
(
load
"vm:vm"
)
(
load
"vm:insts"
)
(
load
"vm:primtype"
)
(
load
"vm:move"
)
(
load
"vm:sap"
)
(
when
(
target-featurep
:sse2
)
(
load
"vm:sse2-sap"
))
(
load
"vm:system"
)
(
load
"vm:char"
)
(
if
(
target-featurep
:sse2
)
(
load
"vm:float-sse2"
)
(
load
"vm:float"
))
(
load
"vm:memory"
)
(
load
"vm:static-fn"
)
(
load
"vm:arith"
)
(
load
"vm:cell"
)
(
load
"vm:subprim"
)
(
load
"vm:debug"
)
(
load
"vm:c-call"
)
(
when
(
target-featurep
:sse2
)
(
load
"vm:sse2-c-call"
))
(
load
"vm:print"
)
(
load
"vm:alloc"
)
(
load
"vm:call"
)
(
load
"vm:nlx"
)
(
load
"vm:values"
)
;; These need to be loaded before array because array wants to use
;; some vops as templates.
(
load
(
if
(
target-featurep
:sse2
)
"vm:sse2-array"
"vm:x87-array"
))
(
load
"vm:array"
)
(
load
"vm:pred"
)
(
load
"vm:type-vops"
)
(
load
"assem:assem-rtns"
)
(
load
"assem:array"
)
(
load
"assem:arith"
)
(
load
"assem:alloc"
)
(
load
"c:pseudo-vops"
)
(
check-move-function-consistency
)
(
load
"vm:new-genesis"
)
;;; OK, the cross compiler backend is loaded.
(
setf
*features*
(
remove
:building-cross-compiler
*features*
))
;;; Info environment hacks.
(
macrolet
((
frob
(
&rest
syms
)
`
(
progn
,@
(
mapcar
#'
(
lambda
(
sym
)
`
(
defconstant
,
sym
(
symbol-value
(
find-symbol
,
(
symbol-name
sym
)
:vm
))))
syms
))))
(
frob
OLD-VM:BYTE-BITS
OLD-VM:WORD-BITS
#+
long-float
OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
#+
long-float
OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
OLD-VM:SIMPLE-BIT-VECTOR-TYPE
OLD-VM:SIMPLE-STRING-TYPE
OLD-VM:SIMPLE-VECTOR-TYPE
OLD-VM:SIMPLE-ARRAY-TYPE
OLD-VM:VECTOR-DATA-OFFSET
OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
)
#+
double-double
(
frob
OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE
))
;; Modular arith hacks
(
setf
(
fdefinition
'vm::ash-left-mod32
)
#'
old-vm::ash-left-mod32
)
(
setf
(
fdefinition
'vm::lognot-mod32
)
#'
old-vm::lognot-mod32
)
;; End arith hacks
(
let
((
function
(
symbol-function
'kernel:error-number-or-lose
)))
(
let
((
*info-environment*
(
c:backend-info-environment
c:*target-backend*
)))
(
setf
(
symbol-function
'kernel:error-number-or-lose
)
function
)
(
setf
(
info
function
kind
'kernel:error-number-or-lose
)
:function
)
(
setf
(
info
function
where-from
'kernel:error-number-or-lose
)
:defined
)))
(
defun
fix-class
(
name
)
(
let*
((
new-value
(
find-class
name
))
(
new-layout
(
kernel::%class-layout
new-value
))
(
new-cell
(
kernel::find-class-cell
name
))
(
*info-environment*
(
c:backend-info-environment
c:*target-backend*
)))
(
remhash
name
kernel::*forward-referenced-layouts*
)
(
kernel::%note-type-defined
name
)
(
setf
(
info
type
kind
name
)
:instance
)
(
setf
(
info
type
class
name
)
new-cell
)
(
setf
(
info
type
compiler-layout
name
)
new-layout
)
new-value
))
(
fix-class
'c::vop-parse
)
(
fix-class
'c::operand-parse
)
#+
random-mt19937
(
declaim
(
notinline
kernel:random-chunk
))
(
setf
c:*backend*
c:*target-backend*
)
;;; Extern-alien-name for the new backend.
(
in-package
:vm
)
(
defun
extern-alien-name
(
name
)
(
declare
(
type
simple-string
name
))
name
)
(
export
'extern-alien-name
)
(
export
'fixup-code-object
)
(
export
'sanctify-for-execution
)
(
in-package
:cl-user
)
;;; Don't load compiler parts from the target compilation
(
defparameter
*load-stuff*
nil
)
;; hack, hack, hack: Make old-vm::any-reg the same as
;; x86::any-reg as an SC. Do this by adding old-vm::any-reg
;; to the hash table with the same value as x86::any-reg.
(
let
((
ht
(
c::backend-sc-names
c::*target-backend*
)))
(
setf
(
gethash
'old-vm::any-reg
ht
)
(
gethash
'vm::any-reg
ht
)))
code/commandline.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.1
5
20
04/
08/1
7 20:24:37
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/commandline.lisp,v 1.1
6
2008/1
1/12 15:04:23
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -206,3 +206,5 @@
(
defswitch
"lib"
)
(
defswitch
"quiet"
)
(
defswitch
"debug-lisp-search"
)
#+
x86
(
defswitch
"fpu"
)
code/error.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.8
5
200
6/01/03
1
8
:0
9:55
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.8
6
200
8/11/12
1
5
:0
4:23
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -908,7 +908,7 @@
(
multiple-value-prog1
(
progn
,@
forms
)
;; Wait for any float exceptions
#+
x8
6
(
float-wait
))))
#+
x8
7
(
float-wait
))))
;;;; Condition definitions.
...
...
@@ -1172,8 +1172,8 @@
(
go
,
(
car
annotated-case
)))))
annotated-cases
)
(
return-from
,
tag
#-
x8
6
,
form
#+
x8
6
(
multiple-value-prog1
,
form
#-
x8
7
,
form
#+
x8
7
(
multiple-value-prog1
,
form
;; Need to catch FP errors here!
(
kernel::float-wait
))))
,@
(
mapcan
...
...
code/exports.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.27
2
2008/1
0/03 13:34:01
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.27
3
2008/1
1/12 15:04:23
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -2222,7 +2222,11 @@
"SIMPLE-UNDEFINED-FUNCTION"
"SIMPLE-PARSE-ERROR"
"SIMPLE-STREAM-ERROR"
"BYTE-FUNCTION-TYPE"
"SLOT-CLASS-PRINT-FUNCTION"
"REDEFINE-LAYOUT-WARNING"
"SLOT-CLASS"
"INSURED-FIND-CLASS"
"CONDITION-FUNCTION-NAME"
)
"CONDITION-FUNCTION-NAME"
"%COMPLEX-SINGLE-FLOAT"
"%COMPLEX-DOUBLE-FLOAT"
"%COMPLEX-DOUBLE-DOUBLE-FLOAT"
)
#+
heap-overflow-check
(
:export
"DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
"DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"
...
...
code/float-trap.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.3
2
2008/
0
1/
03 11:41:51 cshapiro
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float-trap.lisp,v 1.3
3
2008/
1
1/
12 15:04:23 rtoy
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -54,9 +54,42 @@
;;; Interpreter stubs.
;;;
#-
sse2
(
progn
(
defun
floating-point-modes
()
(
floating-point-modes
))
(
defun
(
setf
floating-point-modes
)
(
new
)
(
setf
(
floating-point-modes
)
new
))
)
#+
sse2
(
progn
(
defun
floating-point-modes
()
;; Combine the modes from the FPU and SSE2 units. Since the sse
;; mode contains all of the common information we want, we massage
;; the x87-modes to match, and then OR the x87 and sse2 modes
;; together. Note: We ignore the rounding control bits from the
;; FPU and only use the SSE2 rounding control bits.
(
let*
((
x87-modes
(
vm::x87-floating-point-modes
))
(
sse-modes
(
vm::sse2-floating-point-modes
))
(
final-mode
(
logior
sse-modes
(
ash
(
logand
#x3f
x87-modes
)
7
)
; control
(
logand
#x3f
(
ash
x87-modes
-16
)))))
final-mode
))
(
defun
(
setf
floating-point-modes
)
(
new-mode
)
(
declare
(
type
(
unsigned-byte
24
)
new-mode
))
;; Set the floating point modes for both X87 and SSE2. This
;; include the rounding control bits.
(
let*
((
rc
(
ldb
float-rounding-mode
new-mode
))
(
x87-modes
(
logior
(
ash
(
logand
#x3f
new-mode
)
16
)
(
ash
rc
10
)
(
logand
#x3f
(
ash
new-mode
-7
))
;; Set precision control to be 64-bit, always.
(
ash
3
8
))))
(
setf
(
vm::sse2-floating-point-modes
)
new-mode
)
(
setf
(
vm::x87-floating-point-modes
)
x87-modes
))
new-mode
)
)
;;; SET-FLOATING-POINT-MODES -- Public
;;;
...
...
@@ -188,6 +221,20 @@
(
setf
(
sigcontext-floating-point-modes
(
alien:sap-alien
scp
(
*
unix:sigcontext
)))
new-modes
))
#+
sse2
(
let*
((
new-modes
modes
)
(
new-exceptions
(
logandc2
(
ldb
float-exceptions-byte
new-modes
)
traps
)))
;; Clear out the status for any enabled traps. With SSE2, if
;; the current exception is enabled, the next FP instruction
;; will cause the exception to be signaled again. Hence, we
;; need to clear out the exceptions that we are handling here.
(
setf
(
ldb
float-exceptions-byte
new-modes
)
new-exceptions
)
;; XXX: This seems not right. Shouldn't we be setting the modes
;; in the sigcontext instead? This however seems to do what we
;; want.
(
setf
(
vm:floating-point-modes
)
new-modes
))
(
multiple-value-bind
(
fop
operands
)
(
let
((
sym
(
find-symbol
"GET-FP-OPERANDS"
"VM"
)))
(
if
(
fboundp
sym
)
...
...
@@ -216,7 +263,6 @@
(
t
(
error
"SIGFPE with no exceptions currently enabled?"
))))))
;;; WITH-FLOAT-TRAPS-MASKED -- Public
;;;
(
defmacro
with-float-traps-masked
(
traps
&body
body
)
...
...
code/irrat.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.5
7
2008/1
0/2
2 1
4
:0
2
:2
7
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/irrat.lisp,v 1.5
8
2008/1
1/1
2 1
5
:0
4
:2
3
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -59,13 +59,18 @@
;;; Please refer to the Unix man pages for details about these routines.
;;; Trigonometric.
#-
x86
(
def-math-rtn
"sin"
1
)
#-
x86
(
def-math-rtn
"cos"
1
)
#-
x86
(
def-math-rtn
"tan"
1
)
#-
(
and
x86
(
not
sse2
))
(
progn
;; For x86 (without sse2), we can use x87 instructions to implement
;; these. With sse2, we don't currently support that, so these
;; should be disabled.
(
def-math-rtn
"sin"
1
)
(
def-math-rtn
"cos"
1
)
(
def-math-rtn
"tan"
1
)
(
def-math-rtn
"atan"
1
)
(
def-math-rtn
"atan2"
2
))
(
def-math-rtn
"asin"
1
)
(
def-math-rtn
"acos"
1
)
#-
x86
(
def-math-rtn
"atan"
1
)
#-
x86
(
def-math-rtn
"atan2"
2
)
(
def-math-rtn
"sinh"
1
)
(
def-math-rtn
"cosh"
1
)
(
def-math-rtn
"tanh"
1
)
...
...
@@ -74,15 +79,25 @@
(
def-math-rtn
"atanh"
1
)
;;; Exponential and Logarithmic.
#-
x86
(
def-math-rtn
"exp"
1
)
#-
x86
(
def-math-rtn
"log"
1
)
#-
x86
(
def-math-rtn
"log10"
1
)
#-
(
and
x86
(
not
sse2
))
(
progn
(
def-math-rtn
"exp"
1
)
(
def-math-rtn
"log"
1
)
(
def-math-rtn
"log10"
1
))
(
def-math-rtn
"pow"
2
)
#-
(
or
x86
sparc-v7
sparc-v8
sparc-v9
)
(
def-math-rtn
"sqrt"
1
)
#-
(
or
x86
sparc-v7
sparc-v8
sparc-v9
)
(
def-math-rtn
"sqrt"
1
)
(
def-math-rtn
"hypot"
2
)
#-
(
or
hpux
x86
)
(
def-math-rtn
"log1p"
1
)
#+
x86
;; These are needed for use by byte-compiled files.
;; Don't want log1p to use the x87 instruction.
#-
(
or
hpux
(
and
x86
(
not
sse2
)))
(
def-math-rtn
"log1p"
1
)
;; These are needed for use by byte-compiled files. But don't use
;; these with sse2 since we don't support using the x87 instructions
;; here.
#+
(
and
x86
(
not
sse2
))
(
progn
#+
nil
(
defun
%sin
(
x
)
...
...
@@ -204,7 +219,7 @@
)
#+
ppc
#+
(
or
ppc
sse2
)
(
progn
(
declaim
(
inline
%%sin
%%cos
%%tan
))
(
macrolet
((
frob
(
alien-name
lisp-name
)
...
...
@@ -266,9 +281,10 @@
(
if
(
evenp
n
)
(
,
tan
reduced
)
(
-
(
/
(
,
tan
reduced
)))))))))))
#+
x86
;; Don't want %sin-quick and friends with sse2.
#+
(
and
x86
(
not
sse2
))
(
frob
%sin-quick
%cos-quick
%tan-quick
)
#+
ppc
#+
(
or
ppc
sse2
)
(
frob
%%sin
%%cos
%%tan
))
...
...
code/multi-proc.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; the Public domain, and is provided 'as is'.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.4
3
200
5/07/05 13:12:50
rtoy
Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.4
4
200
8/11/12 15:04:23
rtoy
Rel
$"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -1305,7 +1305,7 @@
"Allow other processes to run."
(
unless
*inhibit-scheduling*
;; Catch any FP exceptions before entering the scheduler.
(
kernel:float-wait
)
#+
x87
(
kernel:float-wait
)
;; Inhibit recursive entry of the scheduler.
(
setf
*inhibit-scheduling*
t
)
(
assert
(
eq
(
first
*remaining-processes*
)
*current-process*
))
...
...
code/sparc-svr4-vm.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.1
1
2008/
09
/1
6
1
9:19:5
3 rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sparc-svr4-vm.lisp,v 1.1
2
2008/
11
/1
2
1
5:04:2
3 rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -20,6 +20,8 @@
sigcontext-float-register
sigcontext-floating-point-modes
extern-alien-name
sanctify-for-execution
))
#+
complex-fp-vops
(
sys:register-lisp-feature
:complex-fp-vops
)
;;;; The sigcontext structure.
...
...
code/x86-vm.lisp
View file @
cb786538
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.
29
2008/
0
1/
03 11:41:52 cshapiro
Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.
30
2008/
1
1/
12 15:04:23 rtoy
Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -29,6 +29,14 @@
sigcontext-float-register
sigcontext-floating-point-modes
extern-alien-name
sanctify-for-execution
))
#+
sse2
(
sys:register-lisp-runtime-feature
:sse2
)
#+
complex-fp-vops
(
sys:register-lisp-feature
:complex-fp-vops
)
#+
(
or
x87
(
not
:sse2
))
(
sys:register-lisp-feature
:x87
)
;;;; The sigcontext structure.
...
...
@@ -270,6 +278,17 @@
(
*
sigcontext
)))))
(
alien-funcall
fn
scp
)))
(
defun
%set-sigcontext-floating-point-modes
(
scp
new-mode
)
(
declare
(
type
(
alien
(
*
sigcontext
))
scp
))
(
let
((
fn
(
extern-alien
"os_set_sigcontext_fpu_modes"
(
function
(
integer
32
)
(
*
sigcontext
)
c-call:unsigned-int
))))
(
alien-funcall
fn
scp
new-mode
)
new-mode
))
(
defsetf
sigcontext-floating-point-modes
%set-sigcontext-floating-point-modes
)
;;; EXTERN-ALIEN-NAME -- interface.
;;;
...
...
compiler/float-tran.lisp
View file @
cb786538
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.12
1
2008/
06/26 21
:0
0
:2
5
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.12
2
2008/
11/12 15
:0
4
:2
3
rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -75,6 +75,33 @@
(
kernel::float-ratio
n
'double-double-float
))))
)
; progn
(
defknown
%complex-single-float
(
number
)
(
complex
single-float
)
(
movable
foldable
flushable
))
(
defknown
%complex-double-float
(
number
)
(
complex
double-float
)
(
movable
foldable
flushable
))
(
defknown
%complex-double-double-float
(
number
)
(
complex
double-float
)
(
movable
foldable
flushable
))
(
macrolet
((
frob
(
type
)
(
let
((
name
(
symbolicate
"%COMPLEX-"
type
"-FLOAT"
))
(
convert
(
symbolicate
"%"
type
"-FLOAT"
)))
`
(
progn
(
defun
,
name
(
n
)
(
typecase
n
(
real
(
complex
(
,
convert
n
)))
(
complex
(
complex
(
,
convert
(
realpart
n
))
(
,
convert
(
imagpart
n
))))))
(
deftransform
,
name
((
n
)
((
complex
,
(
symbolicate
type
"-FLOAT"
)))
*
:when
:both
)
'n
)))))
(
frob
single
)
(
frob
double
)
#+
double-double
(
frob
double-double
))
(
deftransform
coerce
((
n
type
)
(
*
*
)
*
:when
:both
)
(
unless
(
constant-continuation-p
type
)
(
give-up
))
...
...
@@ -87,6 +114,13 @@
'
(
%double-float
n
))
((
csubtypep
tspec
(
specifier-type
'float
))
'
(
%single-float
n
))
#+
double-double
((
csubtypep
tspec
(
specifier-type
'
(
complex
double-double-float
)))
'
(
%complex-double-double-float
n
))
((
csubtypep
tspec
(
specifier-type
'
(
complex
double-float
)))
'
(
%complex-double-float
n
))
((
csubtypep
tspec
(
specifier-type
'
(
complex
single-float
)))
'
(
%complex-single-float
n
))
(
t
(
give-up
))))))
...
...
@@ -420,6 +454,7 @@
(
deftransform
scale-float
((
f
ex
)
(
single-float
*
)
*
:when
:both
)
(
if
(
and
(
backend-featurep
:x86
)
(
not
(
backend-featurep
:sse2
))
(
csubtypep
(
continuation-type
ex
)
(
specifier-type
'
(
signed-byte
32
)))
(
not
(
byte-compiling
)))
...
...
@@ -428,6 +463,7 @@
(
deftransform
scale-float
((
f
ex
)
(
double-float
*
)
*
:when
:both
)
(
if
(
and
(
backend-featurep
:x86
)
(
not
(
backend-featurep
:sse2
))
(
csubtypep
(
continuation-type
ex
)
(
specifier-type
'
(
signed-byte
32
))))
'
(
%scalbn
f
ex
)
...
...
@@ -653,7 +689,8 @@
(
destructuring-bind
(
name
prim
prim-quick
limit
)
stuff
(
deftransform
name
((
x
)
'
(
single-float
)
'*
:eval-name
t
)
(
if
(
backend-featurep
:x86
)
(
if
(
and
(
backend-featurep
:x86
)
(
not
(
backend-featurep
:sse2
)))
(
cond
((
csubtypep
(
continuation-type
x
)
(
specifier-type
`
(
single-float
(
,
(
-
(
expt
2f0
limit
)))
...
...
@@ -669,7 +706,8 @@
`
(
coerce
(
,
prim
(
coerce
x
'double-float
))
'single-float
)))
`
(
coerce
(
,
prim
(
coerce
x
'double-float
))
'single-float
)))
(
deftransform
name
((
x
)
'
(
double-float
)
'*
:eval-name
t
:when
:both
)
(
if
(
backend-featurep
:x86
)
(
if
(
and
(
backend-featurep
:x86
)
(
not
(
backend-featurep
:sse2
)))
(
cond
((
csubtypep
(
continuation-type
x
)
(
specifier-type
`
(
double-float
(
,
(
-
(
expt
2d0
limit
)))
...
...
@@ -1413,117 +1451,230 @@
;;; Define some transforms for complex operations. We do this in lieu
;;; of complex operation VOPs. Some architectures have vops, though.
;;;
#-
(
and
(
not
double-double
)
complex-fp-vops
)
(
macrolet
((
frob
(
type
)
`
(
progn
;; Negation
(
deftransform
%negate
((
z
)
((
complex
,
type
))
*
)
'
(
complex
(
%negate
(
realpart
z
))
(
%negate
(
imagpart
z