-! (c)Joe Groff bsd license
-USING: alien.syntax assocs biassocs combinators continuations
-generalizations kernel literals locals math math.bitwise
-sequences system ;
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators continuations generalizations
+kernel math math.bitwise sequences sets system vocabs ;
IN: math.floats.env
-
SINGLETONS:
+fp-invalid-operation+
+fp-overflow+
+fp-zero-divide+
+fp-inexact+ ;
+CONSTANT: all-fp-exceptions
+ {
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+
+ }
+
SINGLETONS:
+round-nearest+
+round-down+
<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 ;
+ assoc [| k v | bits v mask zero? ] assoc-reject keys ;
: >mask ( symbols assoc -- bits )
over empty?
[ 2drop 0 ]
: 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
+GENERIC: (set-fp-env-register) ( fp-env -- )
-: (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
+GENERIC: (get-exception-flags) ( fp-env -- exceptions )
+GENERIC#: (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
-: (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
+GENERIC: (get-fp-traps) ( fp-env -- exceptions )
+GENERIC#: (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
-: (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
+GENERIC: (get-rounding-mode) ( fp-env -- mode )
+GENERIC#: (set-rounding-mode) 1 ( fp-env mode -- fp-env )
-: change-control-register ( quot -- )
- get_fp_control_register swap call set_fp_control_register ; inline
+GENERIC: (get-denormal-mode) ( fp-env -- mode )
+GENERIC#: (set-denormal-mode) 1 ( fp-env mode -- fp-env )
-: 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 ;
+: change-fp-env-registers ( quot -- )
+ (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
-: get-fp-env ( -- exception-flags fp-traps rounding-mode denormals? )
- get_fp_control_register {
+: 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 ;
+
+CONSTANT: vm-error-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ 0x01 }
+ { +fp-overflow+ 0x02 }
+ { +fp-underflow+ 0x04 }
+ { +fp-zero-divide+ 0x08 }
+ { +fp-inexact+ 0x10 }
+ }
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-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
+: set-fp-exception-flags ( exceptions -- )
+ [ (set-exception-flags) ] curry change-fp-env-registers ; inline
: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
: collect-fp-exceptions ( quot -- exceptions )
- clear-fp-exception-flags call fp-exception-flags ; inline
+ [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
+
+: vm-error>exception-flags ( error -- exceptions )
+ third vm-error-exception-flag>bit mask> ;
+: vm-error-exception-flag? ( error flag -- ? )
+ vm-error>exception-flags member? ;
-: 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
+ quot [ orig set-denormal-mode ] finally ; 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
+ quot [ orig set-rounding-mode ] finally ; inline
-: fp-traps ( -- exceptions ) get_fp_control_register (get-fp-traps) ;
+: fp-traps ( -- exceptions )
+ (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
:: with-fp-traps ( exceptions quot -- )
+ clear-fp-exception-flags
fp-traps :> orig
exceptions set-fp-traps
- quot [ orig set-fp-traps ] [ ] cleanup ; inline
+ quot [ orig set-fp-traps ] finally ; inline
: 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
projects / factor.git / blobdiff