HELP: set-fp-exception-flags
{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
-{ $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." } ;
+{ $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." }
+{ $notes "On Intel platforms, the legacy x87 floating-point unit does not support setting exception flags, so this word only clears the x87 exception flags. However, the SSE unit's flags are set as expected." } ;
HELP: clear-fp-exception-flags
{ $description "Clears all of the floating-point exception flags." } ;
{ $subsection with-rounding-mode }
{ $subsection denormal-mode }
{ $subsection with-denormal-mode }
-{ $notes
-"On x86, the above words only modify the SSE unit's state (in particular, the MXCSR register); the x87 unit is unaffected. On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is unaffected." } ;
+{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
ABOUT: "math.floats.env"
-USING: kernel math math.floats.env math.functions math.libm
-sets tools.test ;
+USING: kernel math math.floats.env math.floats.env.private
+math.functions math.libm sets tools.test ;
IN: math.floats.env.tests
+: set-default-fp-env ( -- )
+ { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
[ t ] [
[ 1.0 0.0 / drop ] collect-fp-exceptions
{ +fp-zero-divide+ } set=
! Ensure traps get cleared
[ 1/0. ] [ 1.0 0.0 /f ] unit-test
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
! (c)Joe Groff bsd license
USING: alien.syntax assocs biassocs combinators continuations
generalizations kernel literals locals math math.bitwise
-sequences system ;
+sequences system vocabs.loader ;
IN: math.floats.env
-
SINGLETONS:
+fp-invalid-operation+
+fp-overflow+
<PRIVATE
-! These functions are provided in the VM; see cpu-*.S
-FUNCTION: uint get_fp_control_register ( ) ;
-FUNCTION: void set_fp_control_register ( uint reg ) ;
-
-HOOK: exception-flag-bits cpu ( -- bits )
-HOOK: exception-flag>bit cpu ( -- assoc )
-HOOK: fp-traps-bits cpu ( -- bits )
-HOOK: fp-traps>bit cpu ( -- assoc )
-HOOK: >fp-traps cpu ( mask -- enable )
-HOOK: rounding-mode-bits cpu ( -- bits )
-HOOK: rounding-mode>bit cpu ( -- assoc )
-HOOK: denormal-mode-bits cpu ( -- bits )
-
-M: x86 exception-flag-bits HEX: 3f ;
-M: x86 exception-flag>bit
- H{
- { +fp-invalid-operation+ HEX: 01 }
- { +fp-overflow+ HEX: 08 }
- { +fp-underflow+ HEX: 10 }
- { +fp-zero-divide+ HEX: 04 }
- { +fp-inexact+ HEX: 20 }
- } ;
-
-M: x86 fp-traps-bits HEX: 1f80 ;
-M: x86 fp-traps>bit
- H{
- { +fp-invalid-operation+ HEX: 0080 }
- { +fp-overflow+ HEX: 0400 }
- { +fp-underflow+ HEX: 0800 }
- { +fp-zero-divide+ HEX: 0200 }
- { +fp-inexact+ HEX: 1000 }
- } ;
-
-M: x86 >fp-traps bitnot ;
-
-M: x86 rounding-mode-bits HEX: 6000 ;
-M: x86 rounding-mode>bit
- $[ H{
- { +round-nearest+ HEX: 0000 }
- { +round-down+ HEX: 2000 }
- { +round-up+ HEX: 4000 }
- { +round-zero+ HEX: 6000 }
- } >biassoc ] ;
-
-M: x86 denormal-mode-bits HEX: 8040 ;
-
-M: ppc exception-flag-bits HEX: 3e00,0000 ;
-M: ppc exception-flag>bit
- H{
- { +fp-invalid-operation+ HEX: 2000,0000 }
- { +fp-overflow+ HEX: 1000,0000 }
- { +fp-underflow+ HEX: 0800,0000 }
- { +fp-zero-divide+ HEX: 0400,0000 }
- { +fp-inexact+ HEX: 0200,0000 }
- } ;
-
-M: ppc fp-traps-bits HEX: f80 ;
-M: ppc fp-traps>bit
- H{
- { +fp-invalid-operation+ HEX: 8000 }
- { +fp-overflow+ HEX: 4000 }
- { +fp-underflow+ HEX: 2000 }
- { +fp-zero-divide+ HEX: 1000 }
- { +fp-inexact+ HEX: 0800 }
- } ;
-
-M: ppc >fp-traps ;
-
-M: ppc rounding-mode-bits HEX: 3 ;
-M: ppc rounding-mode>bit
- $[ H{
- { +round-nearest+ HEX: 0 }
- { +round-zero+ HEX: 1 }
- { +round-up+ HEX: 2 }
- { +round-down+ HEX: 3 }
- } >biassoc ] ;
-
-M: ppc denormal-mode-bits HEX: 4 ;
+HOOK: (fp-env-registers) cpu ( -- registers )
+
+: fp-env-register ( -- register ) (fp-env-registers) first ;
:: mask> ( bits assoc -- symbols )
assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
: remask ( x new-bits mask-bits -- x' )
[ unmask ] [ mask ] bi-curry bi* bitor ; inline
-: (get-exception-flags) ( register -- exceptions )
- exception-flag>bit mask> ; inline
-: (set-exception-flags) ( register exceptions -- register' )
- exception-flag>bit >mask exception-flag-bits remask ; inline
-
-: (get-fp-traps) ( register -- exceptions )
- >fp-traps fp-traps>bit mask> ; inline
-: (set-fp-traps) ( register exceptions -- register' )
- fp-traps>bit >mask >fp-traps fp-traps-bits remask ; inline
-
-: (get-rounding-mode) ( register -- mode )
- rounding-mode-bits mask rounding-mode>bit value-at ; inline
-: (set-rounding-mode) ( register mode -- register' )
- rounding-mode>bit at rounding-mode-bits remask ; inline
-
-: (get-denormal-mode) ( register -- mode )
- denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
-: (set-denormal-mode) ( register ? -- register' )
- {
- { +denormal-keep+ [ denormal-mode-bits unmask ] }
- { +denormal-flush+ [ denormal-mode-bits bitor ] }
- } case ; inline
-
-: change-control-register ( quot -- )
- get_fp_control_register swap call set_fp_control_register ; inline
-
-: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-control-register ;
-: set-rounding-mode ( exceptions -- ) [ (set-rounding-mode) ] curry change-control-register ;
-: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-control-register ;
-
-: get-fp-env ( -- exception-flags fp-traps rounding-mode denormals? )
- get_fp_control_register {
+GENERIC: (set-fp-env-register) ( fp-env -- )
+
+GENERIC: (get-exception-flags) ( fp-env -- exceptions )
+GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-fp-traps) ( fp-env -- exceptions )
+GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-rounding-mode) ( fp-env -- mode )
+GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+
+GENERIC: (get-denormal-mode) ( fp-env -- mode )
+GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+
+: change-fp-env-registers ( quot -- )
+ (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
+
+: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
+: set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
+: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
+
+: get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
+ fp-env-register {
[ (get-exception-flags) ]
[ (get-fp-traps) ]
[ (get-rounding-mode) ]
[ [ (set-rounding-mode) ] when* ]
[ [ (set-denormal-mode) ] when* ]
} spread
- ] 4 ncurry change-control-register ;
+ ] 4 ncurry change-fp-env-registers ;
PRIVATE>
-: fp-exception-flags ( -- exceptions ) get_fp_control_register (get-exception-flags) ;
-: set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-control-register ;
+: fp-exception-flags ( -- exceptions ) fp-env-register (get-exception-flags) ;
+: set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-fp-env-registers ;
: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
: collect-fp-exceptions ( quot -- exceptions )
clear-fp-exception-flags call fp-exception-flags ; inline
-: denormal-mode ( -- mode ) get_fp_control_register (get-denormal-mode) ;
+: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
:: with-denormal-mode ( mode quot -- )
denormal-mode :> orig
mode set-denormal-mode
quot [ orig set-denormal-mode ] [ ] cleanup ; inline
-: rounding-mode ( -- mode ) get_fp_control_register (get-rounding-mode) ;
+: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
:: with-rounding-mode ( mode quot -- )
rounding-mode :> orig
mode set-rounding-mode
quot [ orig set-rounding-mode ] [ ] cleanup ; inline
-: fp-traps ( -- exceptions ) get_fp_control_register (get-fp-traps) ;
+: fp-traps ( -- exceptions ) fp-env-register (get-fp-traps) ;
:: with-fp-traps ( exceptions quot -- )
fp-traps :> orig
: without-fp-traps ( quot -- )
{ } swap with-fp-traps ; inline
+
+<< {
+ { [ cpu x86? ] [ "math.floats.env.x86" require ] }
+ { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
+ [ "CPU architecture unsupported by math.floats.env" throw ]
+} cond >>
+
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators kernel literals math math.bitwise
+math.floats.env math.floats.env.private system ;
+IN: math.floats.env.ppc
+
+STRUCT: ppc-fpu-env
+ { padding uint }
+ { fpcsr uint } ;
+
+! defined in the vm, cpu-ppc*.S
+FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
+FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
+
+: <ppc-fpu-env> ( -- ppc-fpu-env )
+ ppc-fpu-env (struct)
+ [ get_ppc_fpu_env ] keep ;
+
+M: ppc-fpu-env (set-fp-env-register)
+ set_ppc_fpu_env ;
+
+M: ppc (fp-env-registers)
+ <ppc-fpu-env> 1array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
+CONSTANT: ppc-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 2000,0000 }
+ { +fp-overflow+ HEX: 1000,0000 }
+ { +fp-underflow+ HEX: 0800,0000 }
+ { +fp-zero-divide+ HEX: 0400,0000 }
+ { +fp-inexact+ HEX: 0200,0000 }
+ }
+
+CONSTANT: ppc-fp-traps-bits HEX: f80
+CONSTANT: ppc-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 8000 }
+ { +fp-overflow+ HEX: 4000 }
+ { +fp-underflow+ HEX: 2000 }
+ { +fp-zero-divide+ HEX: 1000 }
+ { +fp-inexact+ HEX: 0800 }
+ }
+
+CONSTANT: ppc-rounding-mode-bits HEX: 3
+CONSTANT: ppc-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0 }
+ { +round-zero+ HEX: 1 }
+ { +round-up+ HEX: 2 }
+ { +round-down+ HEX: 3 }
+ } >biassoc ]
+
+CONSTANT: ppc-denormal-mode-bits HEX: 4
+
+M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
+ fpcsr>> ppc-exception-flag>bit mask> ; inline
+M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
+ [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+ fpcsr>> not ppc-fp-traps>bit mask> ; inline
+M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+ [ ppc-fp-traps>bit >mask not ppc-fp-traps-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+ fpcsr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
+M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
+ [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+ fpcsr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ ppc-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-fpcsr ; inline
+
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators cpu.x86.features kernel literals
+math math.bitwise math.floats.env math.floats.env.private
+system ;
+IN: math.floats.env.x86
+
+STRUCT: sse-env
+ { mxcsr uint } ;
+
+STRUCT: x87-env
+ { status ushort }
+ { control ushort } ;
+
+! defined in the vm, cpu-x86*.S
+FUNCTION: void get_sse_env ( sse-env* env ) ;
+FUNCTION: void set_sse_env ( sse-env* env ) ;
+
+FUNCTION: void get_x87_env ( x87-env* env ) ;
+FUNCTION: void set_x87_env ( x87-env* env ) ;
+
+: <sse-env> ( -- sse-env )
+ sse-env (struct) [ get_sse_env ] keep ;
+
+M: sse-env (set-fp-env-register)
+ set_sse_env ;
+
+: <x87-env> ( -- x87-env )
+ x87-env (struct) [ get_x87_env ] keep ;
+
+M: x87-env (set-fp-env-register)
+ set_x87_env ;
+
+M: x86 (fp-env-registers)
+ sse2?
+ [ <sse-env> <x87-env> 2array ]
+ [ <x87-env> 1array ] if ;
+
+CONSTANT: sse-exception-flag-bits HEX: 3f
+CONSTANT: sse-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: sse-fp-traps-bits HEX: 1f80
+CONSTANT: sse-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 0080 }
+ { +fp-overflow+ HEX: 0400 }
+ { +fp-underflow+ HEX: 0800 }
+ { +fp-zero-divide+ HEX: 0200 }
+ { +fp-inexact+ HEX: 1000 }
+ }
+
+CONSTANT: sse-rounding-mode-bits HEX: 6000
+CONSTANT: sse-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 2000 }
+ { +round-up+ HEX: 4000 }
+ { +round-zero+ HEX: 6000 }
+ } >biassoc ]
+
+CONSTANT: sse-denormal-mode-bits HEX: 8040
+
+M: sse-env (get-exception-flags) ( register -- exceptions )
+ mxcsr>> sse-exception-flag>bit mask> ; inline
+M: sse-env (set-exception-flags) ( register exceptions -- register' )
+ [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-fp-traps) ( register -- exceptions )
+ mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
+M: sse-env (set-fp-traps) ( register exceptions -- register' )
+ [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-rounding-mode) ( register -- mode )
+ mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
+M: sse-env (set-rounding-mode) ( register mode -- register' )
+ [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-denormal-mode) ( register -- mode )
+ mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: sse-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-mxcsr ; inline
+
+CONSTANT: x87-exception-bits HEX: 3f
+CONSTANT: x87-exception>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: x87-rounding-mode-bits HEX: 0c00
+CONSTANT: x87-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 0400 }
+ { +round-up+ HEX: 0800 }
+ { +round-zero+ HEX: 0c00 }
+ } >biassoc ]
+
+M: x87-env (get-exception-flags) ( register -- exceptions )
+ status>> x87-exception>bit mask> ; inline
+M: x87-env (set-exception-flags) ( register exceptions -- register' )
+ drop ;
+
+M: x87-env (get-fp-traps) ( register -- exceptions )
+ control>> bitnot x87-exception>bit mask> ; inline
+M: x87-env (set-fp-traps) ( register exceptions -- register' )
+ [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
+
+M: x87-env (get-rounding-mode) ( register -- mode )
+ control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
+M: x87-env (set-rounding-mode) ( register mode -- register' )
+ [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
+
+M: x87-env (get-denormal-mode) ( register -- mode )
+ drop +denormal-keep+ ; inline
+M: x87-env (set-denormal-mode) ( register mode -- register' )
+ drop ;
+
mtctr r3
bctr
-DEF(unsigned,get_fp_control_register,(void)):
+DEF(void,get_ppc_fpu_env,(void*)):
mffs fr0
- li r2,-4
- stfiwx fr0,r2,r1
- lwzx r3,r2,r1
+ stfd fr0,0(r3)
blr
-DEF(void,set_fp_control_register,(unsigned)):
- li r2,-4
- stwx r3,r2,r1
- li r2,-8
- lfdx fr0,r2,r1
+DEF(void,set_ppc_fpu_env,(const void*)):
+ lfd fr0,0(r3)
mtfsf 0xff,fr0
blr
add $12,%esp
jmp *%eax
-DEF(unsigned,get_fp_control_register,(void)):
- push %eax
- stmxcsr (%esp)
- pop %eax
+DEF(void,get_sse_env,(void*)):
+ movl 4(%esp), %eax
+ stmxcsr (%eax)
ret
-DEF(void,set_fp_control_register,(unsigned reg)):
- ldmxcsr 4(%esp)
+DEF(void,set_sse_env,(const void*)):
+ movl 4(%esp), %eax
+ ldmxcsr (%eax)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ movl 4(%esp), %eax
+ fnstsw (%eax)
+ fnstcw 2(%eax)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ movl 4(%esp), %eax
+ fldcw 2(%eax)
+ movb 4(%eax), %dl
+ test %dl, %dl
+ jz 1f
+ fnclex
+1:
ret
#include "cpu-x86.S"
.section .drectve
.ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
+ .ascii " -export:get_sse_env"
+ .ascii " -export:set_sse_env"
+ .ascii " -export:get_x87_env"
+ .ascii " -export:set_x87_env"
#endif
add $STACK_PADDING,%rsp
jmp *%rax
-DEF(unsigned,get_fp_control_register,(void)):
- stmxcsr -4(%rsp)
- movl -4(%rsp), %eax
+DEF(void,get_sse_env,(void*)):
+ stmxcsr (%rdi)
ret
-DEF(void,set_fp_control_register,(unsigned reg)):
- movl %edi, -4(%rsp)
- ldmxcsr -4(%rsp)
+DEF(void,set_sse_env,(const void*)):
+ ldmxcsr (%rdi)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ fnstsw (%rdi)
+ fnstcw 2(%rdi)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ fnclex
+ fldcw 2(%rdi)
ret
#include "cpu-x86.S"
projects / factor.git / commitdiff