1 USING: accessors alien.c-types arrays assocs biassocs
2 classes.struct combinators cpu.x86.features kernel literals
3 math math.bitwise math.floats.env math.floats.env.private
5 IN: math.floats.env.x86
14 HOOK: get-sse-env cpu ( sse-env -- )
15 HOOK: set-sse-env cpu ( sse-env -- )
17 HOOK: get-x87-env cpu ( x87-env -- )
18 HOOK: set-x87-env cpu ( x87-env -- )
20 : <sse-env> ( -- sse-env )
21 sse-env (struct) [ get-sse-env ] keep ;
23 M: sse-env (set-fp-env-register)
26 : <x87-env> ( -- x87-env )
27 x87-env (struct) [ get-x87-env ] keep ;
29 M: x87-env (set-fp-env-register)
32 M: x86 (fp-env-registers)
33 sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
35 CONSTANT: sse-exception-flag-bits 0x3f
36 CONSTANT: sse-exception-flag>bit
38 { +fp-invalid-operation+ 0x01 }
39 { +fp-overflow+ 0x08 }
40 { +fp-underflow+ 0x10 }
41 { +fp-zero-divide+ 0x04 }
45 CONSTANT: sse-fp-traps-bits 0x1f80
46 CONSTANT: sse-fp-traps>bit
48 { +fp-invalid-operation+ 0x0080 }
49 { +fp-overflow+ 0x0400 }
50 { +fp-underflow+ 0x0800 }
51 { +fp-zero-divide+ 0x0200 }
52 { +fp-inexact+ 0x1000 }
55 CONSTANT: sse-rounding-mode-bits 0x6000
56 CONSTANT: sse-rounding-mode>bit
58 { +round-nearest+ 0x0000 }
59 { +round-down+ 0x2000 }
61 { +round-zero+ 0x6000 }
64 CONSTANT: sse-denormal-mode-bits 0x8040
66 M: sse-env (get-exception-flags) ( register -- exceptions )
67 mxcsr>> sse-exception-flag>bit mask> ; inline
68 M: sse-env (set-exception-flags) ( register exceptions -- register' )
69 [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
71 M: sse-env (get-fp-traps) ( register -- exceptions )
72 mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
73 M: sse-env (set-fp-traps) ( register exceptions -- register' )
74 [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
76 M: sse-env (get-rounding-mode) ( register -- mode )
77 mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
78 M: sse-env (set-rounding-mode) ( register mode -- register' )
79 [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
81 M: sse-env (get-denormal-mode) ( register -- mode )
82 mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
83 M: sse-env (set-denormal-mode) ( register mode -- register' )
86 { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
87 { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
89 ] curry change-mxcsr ; inline
91 SINGLETON: +fp-x87-stack-fault+
93 CONSTANT: x87-exception-bits 0x7f
94 CONSTANT: x87-exception>bit
96 { +fp-invalid-operation+ 0x01 }
97 { +fp-overflow+ 0x08 }
98 { +fp-underflow+ 0x10 }
99 { +fp-zero-divide+ 0x04 }
100 { +fp-inexact+ 0x20 }
101 { +fp-x87-stack-fault+ 0x40 }
104 CONSTANT: x87-rounding-mode-bits 0x0c00
105 CONSTANT: x87-rounding-mode>bit
107 { +round-nearest+ 0x0000 }
108 { +round-down+ 0x0400 }
109 { +round-up+ 0x0800 }
110 { +round-zero+ 0x0c00 }
113 M: x87-env (get-exception-flags) ( register -- exceptions )
114 status>> x87-exception>bit mask> ; inline
115 M: x87-env (set-exception-flags) ( register exceptions -- register' )
118 M: x87-env (get-fp-traps) ( register -- exceptions )
119 control>> bitnot x87-exception>bit mask> ; inline
120 M: x87-env (set-fp-traps) ( register exceptions -- register' )
121 [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
123 M: x87-env (get-rounding-mode) ( register -- mode )
124 control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
125 M: x87-env (set-rounding-mode) ( register mode -- register' )
126 [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
128 M: x87-env (get-denormal-mode) ( register -- mode )
129 drop +denormal-keep+ ; inline
130 M: x87-env (set-denormal-mode) ( register mode -- register' )
134 { x86.32 [ "math.floats.env.x86.32" ] }
135 { x86.64 [ "math.floats.env.x86.64" ] }