1 USING: accessors alien.syntax 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 ! defined in the vm, cpu-x86*.S
15 FUNCTION: void get_sse_env ( sse-env* env ) ;
16 FUNCTION: void set_sse_env ( sse-env* env ) ;
18 FUNCTION: void get_x87_env ( x87-env* env ) ;
19 FUNCTION: void set_x87_env ( x87-env* env ) ;
21 : <sse-env> ( -- sse-env )
22 sse-env (struct) [ get_sse_env ] keep ;
24 M: sse-env (set-fp-env-register)
27 : <x87-env> ( -- x87-env )
28 x87-env (struct) [ get_x87_env ] keep ;
30 M: x87-env (set-fp-env-register)
33 M: x86 (fp-env-registers)
34 sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
36 CONSTANT: sse-exception-flag-bits HEX: 3f
37 CONSTANT: sse-exception-flag>bit
39 { +fp-invalid-operation+ HEX: 01 }
40 { +fp-overflow+ HEX: 08 }
41 { +fp-underflow+ HEX: 10 }
42 { +fp-zero-divide+ HEX: 04 }
43 { +fp-inexact+ HEX: 20 }
46 CONSTANT: sse-fp-traps-bits HEX: 1f80
47 CONSTANT: sse-fp-traps>bit
49 { +fp-invalid-operation+ HEX: 0080 }
50 { +fp-overflow+ HEX: 0400 }
51 { +fp-underflow+ HEX: 0800 }
52 { +fp-zero-divide+ HEX: 0200 }
53 { +fp-inexact+ HEX: 1000 }
56 CONSTANT: sse-rounding-mode-bits HEX: 6000
57 CONSTANT: sse-rounding-mode>bit
59 { +round-nearest+ HEX: 0000 }
60 { +round-down+ HEX: 2000 }
61 { +round-up+ HEX: 4000 }
62 { +round-zero+ HEX: 6000 }
65 CONSTANT: sse-denormal-mode-bits HEX: 8040
67 M: sse-env (get-exception-flags) ( register -- exceptions )
68 mxcsr>> sse-exception-flag>bit mask> ; inline
69 M: sse-env (set-exception-flags) ( register exceptions -- register' )
70 [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
72 M: sse-env (get-fp-traps) ( register -- exceptions )
73 mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
74 M: sse-env (set-fp-traps) ( register exceptions -- register' )
75 [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
77 M: sse-env (get-rounding-mode) ( register -- mode )
78 mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
79 M: sse-env (set-rounding-mode) ( register mode -- register' )
80 [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
82 M: sse-env (get-denormal-mode) ( register -- mode )
83 mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
84 M: sse-env (set-denormal-mode) ( register mode -- register' )
87 { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
88 { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
90 ] curry change-mxcsr ; inline
92 CONSTANT: x87-exception-bits HEX: 3f
93 CONSTANT: x87-exception>bit
95 { +fp-invalid-operation+ HEX: 01 }
96 { +fp-overflow+ HEX: 08 }
97 { +fp-underflow+ HEX: 10 }
98 { +fp-zero-divide+ HEX: 04 }
99 { +fp-inexact+ HEX: 20 }
102 CONSTANT: x87-rounding-mode-bits HEX: 0c00
103 CONSTANT: x87-rounding-mode>bit
105 { +round-nearest+ HEX: 0000 }
106 { +round-down+ HEX: 0400 }
107 { +round-up+ HEX: 0800 }
108 { +round-zero+ HEX: 0c00 }
111 M: x87-env (get-exception-flags) ( register -- exceptions )
112 status>> x87-exception>bit mask> ; inline
113 M: x87-env (set-exception-flags) ( register exceptions -- register' )
116 M: x87-env (get-fp-traps) ( register -- exceptions )
117 control>> bitnot x87-exception>bit mask> ; inline
118 M: x87-env (set-fp-traps) ( register exceptions -- register' )
119 [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
121 M: x87-env (get-rounding-mode) ( register -- mode )
122 control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
123 M: x87-env (set-rounding-mode) ( register mode -- register' )
124 [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
126 M: x87-env (get-denormal-mode) ( register -- mode )
127 drop +denormal-keep+ ; inline
128 M: x87-env (set-denormal-mode) ( register mode -- register' )