make public words for querying current rounding mode, denormal mode, and trap set
parent
7ba71a524e
commit
e705470d42
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue