basis/math/floats/env/env.factor

   1 ! (c)Joe Groff bsd license
   2 USING: alien.syntax arrays assocs biassocs combinators
   3 combinators.short-circuit continuations generalizations kernel
   4 literals locals math math.bitwise sequences sets system
   5 vocabs ;
   6 IN: math.floats.env
   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 CONSTANT: all-fp-exceptions
  23     {
  24         +fp-invalid-operation+
  25         +fp-overflow+
  26         +fp-underflow+
  27         +fp-zero-divide+
  28         +fp-inexact+
  29     }
  30
  31 SINGLETONS:
  32     +round-nearest+
  33     +round-down+
  34     +round-up+
  35     +round-zero+ ;
  36
  37 UNION: fp-rounding-mode
  38     +round-nearest+
  39     +round-down+
  40     +round-up+
  41     +round-zero+ ;
  42
  43 SINGLETONS:
  44     +denormal-keep+
  45     +denormal-flush+ ;
  46
  47 UNION: fp-denormal-mode
  48     +denormal-keep+
  49     +denormal-flush+ ;
  50
  51 <PRIVATE
  52
  53 HOOK: (fp-env-registers) cpu ( -- registers )
  54
  55 : fp-env-register ( -- register ) (fp-env-registers) first ;
  56
  57 :: mask> ( bits assoc -- symbols )
  58     assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
  59 : >mask ( symbols assoc -- bits )
  60     over empty?
  61     [ 2drop 0 ]
  62     [ [ at ] curry [ bitor ] map-reduce ] if ;
  63
  64 : remask ( x new-bits mask-bits -- x' )
  65     [ unmask ] [ mask ] bi-curry bi* bitor ; inline
  66
  67 GENERIC: (set-fp-env-register) ( fp-env -- )
  68
  69 GENERIC: (get-exception-flags) ( fp-env -- exceptions )
  70 GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
  71
  72 GENERIC: (get-fp-traps) ( fp-env -- exceptions )
  73 GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
  74
  75 GENERIC: (get-rounding-mode) ( fp-env -- mode )
  76 GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
  77
  78 GENERIC: (get-denormal-mode) ( fp-env -- mode )
  79 GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
  80
  81 : change-fp-env-registers ( quot -- )
  82     (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
  83
  84 : set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
  85 : set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
  86 : set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
  87
  88 : get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
  89     fp-env-register {
  90         [ (get-exception-flags) ]
  91         [ (get-fp-traps) ]
  92         [ (get-rounding-mode) ]
  93         [ (get-denormal-mode) ]
  94     } cleave ;
  95
  96 : set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
  97     [
  98         {
  99             [ [ (set-exception-flags) ] when* ]
 100             [ [ (set-fp-traps) ] when* ]
 101             [ [ (set-rounding-mode) ] when* ]
 102             [ [ (set-denormal-mode) ] when* ]
 103         } spread
 104     ] 4 ncurry change-fp-env-registers ;
 105
 106 CONSTANT: vm-error-exception-flag>bit
 107     H{
 108         { +fp-invalid-operation+ 0x01 }
 109         { +fp-overflow+          0x02 }
 110         { +fp-underflow+         0x04 }
 111         { +fp-zero-divide+       0x08 }
 112         { +fp-inexact+           0x10 }
 113     }
 114
 115 PRIVATE>
 116
 117 : fp-exception-flags ( -- exceptions )
 118     (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
 119 : set-fp-exception-flags ( exceptions -- )
 120     [ (set-exception-flags) ] curry change-fp-env-registers ; inline
 121 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 122
 123 : collect-fp-exceptions ( quot -- exceptions )
 124     [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
 125
 126 : vm-error>exception-flags ( error -- exceptions )
 127     third vm-error-exception-flag>bit mask> ;
 128 : vm-error-exception-flag? ( error flag -- ? )
 129     vm-error>exception-flags member? ;
 130
 131 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
 132
 133 :: with-denormal-mode ( mode quot -- )
 134     denormal-mode :> orig
 135     mode set-denormal-mode
 136     quot [ orig set-denormal-mode ] [ ] cleanup ; inline
 137
 138 : rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
 139
 140 :: with-rounding-mode ( mode quot -- )
 141     rounding-mode :> orig
 142     mode set-rounding-mode
 143     quot [ orig set-rounding-mode ] [ ] cleanup ; inline
 144
 145 : fp-traps ( -- exceptions )
 146     (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
 147
 148 :: with-fp-traps ( exceptions quot -- )
 149     clear-fp-exception-flags
 150     fp-traps :> orig
 151     exceptions set-fp-traps
 152     quot [ orig set-fp-traps ] [ ] cleanup ; inline
 153
 154 : without-fp-traps ( quot -- )
 155     { } swap with-fp-traps ; inline
 156
 157 << {
 158     { [ cpu x86? ] [ "math.floats.env.x86" require ] }
 159     { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
 160     [ "CPU architecture unsupported by math.floats.env" throw ]
 161 } cond >>
 162