basis/math/floats/env/env.factor

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