1 ! Copyright (C) 2009 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien.syntax arrays assocs biassocs combinators
4 combinators.short-circuit continuations generalizations kernel
5 literals locals math math.bitwise sequences sets system
10 +fp-invalid-operation+
17 +fp-invalid-operation+
23 CONSTANT: all-fp-exceptions
25 +fp-invalid-operation+
38 UNION: fp-rounding-mode
48 UNION: fp-denormal-mode
54 HOOK: (fp-env-registers) cpu ( -- registers )
56 : fp-env-register ( -- register ) (fp-env-registers) first ;
58 :: mask> ( bits assoc -- symbols )
59 assoc [| k v | bits v mask zero? ] assoc-reject keys ;
60 : >mask ( symbols assoc -- bits )
63 [ [ at ] curry [ bitor ] map-reduce ] if ;
65 : remask ( x new-bits mask-bits -- x' )
66 [ unmask ] [ mask ] bi-curry bi* bitor ; inline
68 GENERIC: (set-fp-env-register) ( fp-env -- )
70 GENERIC: (get-exception-flags) ( fp-env -- exceptions )
71 GENERIC#: (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
73 GENERIC: (get-fp-traps) ( fp-env -- exceptions )
74 GENERIC#: (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
76 GENERIC: (get-rounding-mode) ( fp-env -- mode )
77 GENERIC#: (set-rounding-mode) 1 ( fp-env mode -- fp-env )
79 GENERIC: (get-denormal-mode) ( fp-env -- mode )
80 GENERIC#: (set-denormal-mode) 1 ( fp-env mode -- fp-env )
82 : change-fp-env-registers ( quot -- )
83 (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
85 : set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
86 : set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
87 : set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
89 : get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
91 [ (get-exception-flags) ]
93 [ (get-rounding-mode) ]
94 [ (get-denormal-mode) ]
97 : set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
100 [ [ (set-exception-flags) ] when* ]
101 [ [ (set-fp-traps) ] when* ]
102 [ [ (set-rounding-mode) ] when* ]
103 [ [ (set-denormal-mode) ] when* ]
105 ] 4 ncurry change-fp-env-registers ;
107 CONSTANT: vm-error-exception-flag>bit
109 { +fp-invalid-operation+ 0x01 }
110 { +fp-overflow+ 0x02 }
111 { +fp-underflow+ 0x04 }
112 { +fp-zero-divide+ 0x08 }
113 { +fp-inexact+ 0x10 }
118 : fp-exception-flags ( -- exceptions )
119 (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
120 : set-fp-exception-flags ( exceptions -- )
121 [ (set-exception-flags) ] curry change-fp-env-registers ; inline
122 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
124 : collect-fp-exceptions ( quot -- exceptions )
125 [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
127 : vm-error>exception-flags ( error -- exceptions )
128 third vm-error-exception-flag>bit mask> ;
129 : vm-error-exception-flag? ( error flag -- ? )
130 vm-error>exception-flags member? ;
132 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
134 :: with-denormal-mode ( mode quot -- )
135 denormal-mode :> orig
136 mode set-denormal-mode
137 quot [ orig set-denormal-mode ] finally ; inline
139 : rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
141 :: with-rounding-mode ( mode quot -- )
142 rounding-mode :> orig
143 mode set-rounding-mode
144 quot [ orig set-rounding-mode ] finally ; inline
146 : fp-traps ( -- exceptions )
147 (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
149 :: with-fp-traps ( exceptions quot -- )
150 clear-fp-exception-flags
152 exceptions set-fp-traps
153 quot [ orig set-fp-traps ] finally ; inline
155 : without-fp-traps ( quot -- )
156 { } swap with-fp-traps ; inline
159 { [ cpu x86? ] [ "math.floats.env.x86" require ] }
160 { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
161 [ "CPU architecture unsupported by math.floats.env" throw ]