steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

make public words for querying current rounding mode, denormal mode, and trap set

db4
Joe Groff 2009-09-06 08:50:54 -05:00
parent 7ba71a524e
commit e705470d42
2 changed files with 51 additions and 33 deletions
basis/math/floats/env

27
basis/math/floats/env/env-docs.factor vendored
View File

@ -68,19 +68,31 @@ HELP: collect-fp-exceptions
{ $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
{ $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
{ fp-exception fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
{ fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
HELP: denormal-mode
{ $values { "mode" fp-denormal-mode } }
{ $description "Returns the current floating-point denormal mode." } ;
HELP: with-denormal-mode
{ $values { "mode" fp-denormal-mode } { "quot" quotation } }
{ $description "Sets the floating-point denormal mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the denormal mode to its original value on " { $snippet "quot" } "'s completion." } ;
{ fp-denormal-mode with-denormal-mode } related-words
{ denormal-mode with-denormal-mode } related-words
HELP: rounding-mode
{ $values { "mode" fp-rounding-mode } }
{ $description "Returns the current floating-point rounding mode." } ;
HELP: with-rounding-mode
{ $values { "mode" fp-rounding-mode } { "quot" quotation } }
{ $description "Sets the floating-point rounding mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the rounding mode to its original value on " { $snippet "quot" } "'s completion." } ;
{ fp-rounding-mode with-rounding-mode } related-words
{ rounding-mode with-rounding-mode } related-words
HELP: fp-traps
{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
{ $description "Returns the set of floating point exceptions with processor traps currently set." } ;
HELP: with-fp-traps
{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
@ -90,7 +102,7 @@ HELP: without-fp-traps
{ $values { "quot" quotation } }
{ $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
{ with-fp-traps without-fp-traps } related-words
{ fp-traps with-fp-traps without-fp-traps } related-words
ARTICLE: "math.floats.env" "Controlling the floating-point environment"
"The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
@ -100,11 +112,14 @@ $nl
{ $subsection set-fp-exception-flags }
{ $subsection clear-fp-exception-flags }
{ $subsection collect-fp-exceptions }
"Controlling processor traps for floating-point exceptions:"
"Querying and controlling processor traps for floating-point exceptions:"
{ $subsection fp-traps }
{ $subsection with-fp-traps }
{ $subsection without-fp-traps }
"Controlling the rounding mode and treatment of denormals:"
"Querying and controlling the rounding mode and treatment of denormals:"
{ $subsection rounding-mode }
{ $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 ignored by Factor and unaffected by " { $snippet "math.float.env" } ". On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec state is currently not exposed." } ;

57
basis/math/floats/env/env.factor vendored
View File

@ -47,9 +47,9 @@ FUNCTION: void set_fp_control_register ( uint reg ) ;
HOOK: exception-flag-bits cpu ( -- bits )
HOOK: exception-flag>bit cpu ( -- assoc )
HOOK: exception-enable-bits cpu ( -- bits )
HOOK: exception-enable>bit cpu ( -- assoc )
HOOK: >exception-enable cpu ( mask -- enable )
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 )
@ -64,8 +64,8 @@ M: x86 exception-flag>bit
{ +fp-inexact+ HEX: 20 }
} ;
M: x86 exception-enable-bits HEX: 1f80 ;
M: x86 exception-enable>bit
M: x86 fp-traps-bits HEX: 1f80 ;
M: x86 fp-traps>bit
H{
{ +fp-invalid-operation+ HEX: 0080 }
{ +fp-overflow+ HEX: 0400 }
@ -74,7 +74,7 @@ M: x86 exception-enable>bit
{ +fp-inexact+ HEX: 1000 }
} ;
M: x86 >exception-enable bitnot ;
M: x86 >fp-traps bitnot ;
M: x86 rounding-mode-bits HEX: 6000 ;
M: x86 rounding-mode>bit
@ -97,8 +97,8 @@ M: ppc exception-flag>bit
{ +fp-inexact+ HEX: 0200,0000 }
} ;
M: ppc exception-enable-bits HEX: f80 ;
M: ppc exception-enable>bit
M: ppc fp-traps-bits HEX: f80 ;
M: ppc fp-traps>bit
H{
{ +fp-invalid-operation+ HEX: 8000 }
{ +fp-overflow+ HEX: 4000 }
@ -107,7 +107,7 @@ M: ppc exception-enable>bit
{ +fp-inexact+ HEX: 0800 }
} ;
M: ppc >exception-enable ;
M: ppc >fp-traps ;
M: ppc rounding-mode-bits HEX: 3 ;
M: ppc rounding-mode>bit
@ -135,10 +135,10 @@ M: ppc denormal-mode-bits HEX: 4 ;
: (set-exception-flags) ( register exceptions -- register' )
exception-flag>bit >mask exception-flag-bits remask ; inline
: (get-exception-enable) ( register -- exceptions )
>exception-enable exception-enable>bit mask> ; inline
: (set-exception-enable) ( register exceptions -- register' )
exception-enable>bit >mask >exception-enable exception-enable-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
@ -156,26 +156,23 @@ M: ppc denormal-mode-bits HEX: 4 ;
: change-control-register ( quot -- )
get_fp_control_register swap call set_fp_control_register ; inline
: get-exception-enable ( -- exceptions ) get_fp_control_register (get-exception-enable) ;
: set-exception-enable ( exceptions -- ) [ (set-exception-enable) ] curry change-control-register ;
: get-rounding-mode ( -- rounding-mode ) get_fp_control_register (get-rounding-mode) ;
: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-control-register ;
: set-rounding-mode ( exceptions -- ) [ (set-rounding-mode) ] curry change-control-register ;
: get-denormal-mode ( -- ? ) get_fp_control_register (get-denormal-mode) ;
: set-denormal-mode ( ? -- ) [ (set-denormal-mode) ] curry change-control-register ;
: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-control-register ;
: get-fp-env ( -- exception-flags exception-enable rounding-mode denormals? )
: get-fp-env ( -- exception-flags fp-traps rounding-mode denormals? )
get_fp_control_register {
[ (get-exception-flags) ]
[ (get-exception-enable) ]
[ (get-fp-traps) ]
[ (get-rounding-mode) ]
[ (get-denormal-mode) ]
} cleave ;
: set-fp-env ( exception-flags exception-enable rounding-mode denormal-mode -- )
: set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
[
{
[ [ (set-exception-flags) ] when* ]
[ [ (set-exception-enable) ] when* ]
[ [ (set-fp-traps) ] when* ]
[ [ (set-rounding-mode) ] when* ]
[ [ (set-denormal-mode) ] when* ]
} spread
@ -190,20 +187,26 @@ PRIVATE>
: collect-fp-exceptions ( quot -- exceptions )
clear-fp-exception-flags call fp-exception-flags ; inline
: denormal-mode ( -- mode ) get_fp_control_register (get-denormal-mode) ;
:: with-denormal-mode ( mode quot -- )
get-denormal-mode :> orig
denormal-mode :> orig
mode set-denormal-mode
quot [ orig set-denormal-mode ] [ ] cleanup ; inline
: rounding-mode ( -- mode ) get_fp_control_register (get-rounding-mode) ;
:: with-rounding-mode ( mode quot -- )
get-rounding-mode :> orig
rounding-mode :> orig
mode set-rounding-mode
quot [ orig set-rounding-mode ] [ ] cleanup ; inline
: fp-traps ( -- exceptions ) get_fp_control_register (get-fp-traps) ;
:: with-fp-traps ( exceptions quot -- )
get-exception-enable :> orig
exceptions set-exception-enable
quot [ orig set-exception-enable ] [ ] cleanup ; inline
fp-traps :> orig
exceptions set-fp-traps
quot [ orig set-fp-traps ] [ ] cleanup ; inline
: without-fp-traps ( quot -- )
{ } swap with-fp-traps ; inline