basis/math/floats/env/env.factor

   1 ! (c)Joe Groff bsd license
   2 USING: alien.syntax assocs biassocs combinators continuations
   3 generalizations kernel literals locals math math.bitwise
   4 sequences system ;
   5 IN: math.floats.env
   6
   7
   8 SINGLETONS:
   9     +fp-invalid-operation+
  10     +fp-overflow+
  11     +fp-underflow+
  12     +fp-zero-divide+
  13     +fp-inexact+ ;
  14
  15 UNION: fp-exception
  16     +fp-invalid-operation+
  17     +fp-overflow+
  18     +fp-underflow+
  19     +fp-zero-divide+
  20     +fp-inexact+ ;
  21
  22 SINGLETONS:
  23     +round-nearest+
  24     +round-down+
  25     +round-up+
  26     +round-zero+ ;
  27
  28 UNION: fp-rounding-mode
  29     +round-nearest+
  30     +round-down+
  31     +round-up+
  32     +round-zero+ ;
  33
  34 SINGLETONS:
  35     +denormal-keep+
  36     +denormal-flush+ ;
  37
  38 UNION: fp-denormal-mode
  39     +denormal-keep+
  40     +denormal-flush+ ;
  41
  42 <PRIVATE
  43
  44 ! These functions are provided in the VM; see cpu-*.S
  45 FUNCTION: uint get_fp_control_register ( ) ;
  46 FUNCTION: void set_fp_control_register ( uint reg ) ;
  47
  48 HOOK: exception-flag-bits    cpu ( -- bits )
  49 HOOK: exception-flag>bit     cpu ( -- assoc )
  50 HOOK: fp-traps-bits  cpu ( -- bits )
  51 HOOK: fp-traps>bit   cpu ( -- assoc )
  52 HOOK: >fp-traps      cpu ( mask -- enable )
  53 HOOK: rounding-mode-bits     cpu ( -- bits )
  54 HOOK: rounding-mode>bit      cpu ( -- assoc )
  55 HOOK: denormal-mode-bits     cpu ( -- bits )
  56
  57 M: x86 exception-flag-bits HEX: 3f ;
  58 M: x86 exception-flag>bit
  59     H{
  60         { +fp-invalid-operation+ HEX: 01 }
  61         { +fp-overflow+          HEX: 08 }
  62         { +fp-underflow+         HEX: 10 }
  63         { +fp-zero-divide+       HEX: 04 }
  64         { +fp-inexact+           HEX: 20 }
  65     } ;
  66
  67 M: x86 fp-traps-bits HEX: 1f80 ;
  68 M: x86 fp-traps>bit
  69     H{
  70         { +fp-invalid-operation+ HEX: 0080 }
  71         { +fp-overflow+          HEX: 0400 }
  72         { +fp-underflow+         HEX: 0800 }
  73         { +fp-zero-divide+       HEX: 0200 }
  74         { +fp-inexact+           HEX: 1000 }
  75     } ;
  76
  77 M: x86 >fp-traps bitnot ;
  78
  79 M: x86 rounding-mode-bits HEX: 6000 ;
  80 M: x86 rounding-mode>bit
  81     $[ H{
  82         { +round-nearest+ HEX: 0000 }
  83         { +round-down+    HEX: 2000 }
  84         { +round-up+      HEX: 4000 }
  85         { +round-zero+    HEX: 6000 }
  86     } >biassoc ] ;
  87
  88 M: x86 denormal-mode-bits HEX: 8040 ;
  89
  90 M: ppc exception-flag-bits HEX: 3e00,0000 ;
  91 M: ppc exception-flag>bit
  92     H{
  93         { +fp-invalid-operation+ HEX: 2000,0000 }
  94         { +fp-overflow+          HEX: 1000,0000 }
  95         { +fp-underflow+         HEX: 0800,0000 }
  96         { +fp-zero-divide+       HEX: 0400,0000 }
  97         { +fp-inexact+           HEX: 0200,0000 }
  98     } ;
  99
 100 M: ppc fp-traps-bits HEX: f80 ;
 101 M: ppc fp-traps>bit
 102     H{
 103         { +fp-invalid-operation+ HEX: 8000 }
 104         { +fp-overflow+          HEX: 4000 }
 105         { +fp-underflow+         HEX: 2000 }
 106         { +fp-zero-divide+       HEX: 1000 }
 107         { +fp-inexact+           HEX: 0800 }
 108     } ;
 109
 110 M: ppc >fp-traps ;
 111
 112 M: ppc rounding-mode-bits HEX: 3 ;
 113 M: ppc rounding-mode>bit
 114     $[ H{
 115         { +round-nearest+ HEX: 0 }
 116         { +round-zero+    HEX: 1 }
 117         { +round-up+      HEX: 2 }
 118         { +round-down+    HEX: 3 }
 119     } >biassoc ] ;
 120
 121 M: ppc denormal-mode-bits HEX: 4 ;
 122
 123 :: mask> ( bits assoc -- symbols )
 124     assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
 125 : >mask ( symbols assoc -- bits )
 126     over empty?
 127     [ 2drop 0 ]
 128     [ [ at ] curry [ bitor ] map-reduce ] if ;
 129
 130 : remask ( x new-bits mask-bits -- x' )
 131     [ unmask ] [ mask ] bi-curry bi* bitor ; inline
 132
 133 : (get-exception-flags) ( register -- exceptions )
 134     exception-flag>bit mask> ; inline
 135 : (set-exception-flags) ( register exceptions -- register' )
 136     exception-flag>bit >mask exception-flag-bits remask ; inline
 137
 138 : (get-fp-traps) ( register -- exceptions )
 139     >fp-traps fp-traps>bit mask> ; inline
 140 : (set-fp-traps) ( register exceptions -- register' )
 141     fp-traps>bit >mask >fp-traps fp-traps-bits remask ; inline
 142
 143 : (get-rounding-mode) ( register -- mode )
 144     rounding-mode-bits mask rounding-mode>bit value-at ; inline
 145 : (set-rounding-mode) ( register mode -- register' )
 146     rounding-mode>bit at rounding-mode-bits remask ; inline
 147
 148 : (get-denormal-mode) ( register -- mode )
 149     denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
 150 : (set-denormal-mode) ( register ? -- register' )
 151     {
 152         { +denormal-keep+  [ denormal-mode-bits unmask ] }
 153         { +denormal-flush+ [ denormal-mode-bits bitor  ] }
 154     } case ; inline
 155
 156 : change-control-register ( quot -- )
 157     get_fp_control_register swap call set_fp_control_register ; inline
 158
 159 : set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-control-register ;
 160 : set-rounding-mode ( exceptions -- ) [ (set-rounding-mode) ] curry change-control-register ;
 161 : set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-control-register ;
 162
 163 : get-fp-env ( -- exception-flags fp-traps rounding-mode denormals? )
 164     get_fp_control_register {
 165         [ (get-exception-flags) ]
 166         [ (get-fp-traps) ]
 167         [ (get-rounding-mode) ]
 168         [ (get-denormal-mode) ]
 169     } cleave ;
 170
 171 : set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
 172     [
 173         {
 174             [ [ (set-exception-flags) ] when* ]
 175             [ [ (set-fp-traps) ] when* ]
 176             [ [ (set-rounding-mode) ] when* ]
 177             [ [ (set-denormal-mode) ] when* ]
 178         } spread
 179     ] 4 ncurry change-control-register ;
 180
 181 PRIVATE>
 182
 183 : fp-exception-flags ( -- exceptions ) get_fp_control_register (get-exception-flags) ;
 184 : set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-control-register ;
 185 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 186
 187 : collect-fp-exceptions ( quot -- exceptions )
 188     clear-fp-exception-flags call fp-exception-flags ; inline
 189
 190 : denormal-mode ( -- mode ) get_fp_control_register (get-denormal-mode) ;
 191
 192 :: with-denormal-mode ( mode quot -- )
 193     denormal-mode :> orig
 194     mode set-denormal-mode
 195     quot [ orig set-denormal-mode ] [ ] cleanup ; inline
 196
 197 : rounding-mode ( -- mode ) get_fp_control_register (get-rounding-mode) ;
 198
 199 :: with-rounding-mode ( mode quot -- )
 200     rounding-mode :> orig
 201     mode set-rounding-mode
 202     quot [ orig set-rounding-mode ] [ ] cleanup ; inline
 203
 204 : fp-traps ( -- exceptions ) get_fp_control_register (get-fp-traps) ;
 205
 206 :: with-fp-traps ( exceptions quot -- )
 207     fp-traps :> orig
 208     exceptions set-fp-traps
 209     quot [ orig set-fp-traps ] [ ] cleanup ; inline
 210
 211 : without-fp-traps ( quot -- )
 212     { } swap with-fp-traps ; inline