1 USING: accessors alien alien.c-types alien.syntax arrays assocs
2 biassocs classes.struct combinators kernel literals math
3 math.bitwise math.floats.env math.floats.env.private system
5 IN: math.floats.env.ppc
14 : get_ppc_fpu_env ( env -- )
15 void { void* } cdecl [
20 : set_ppc_fpu_env ( env -- )
21 void { void* } cdecl [
26 : get_ppc_vmx_env ( env -- )
27 void { void* } cdecl [
38 : set_ppc_vmx_env ( env -- )
39 void { void* } cdecl [
50 : <ppc-fpu-env> ( -- ppc-fpu-env )
52 [ get_ppc_fpu_env ] keep ;
54 : <ppc-vmx-env> ( -- ppc-fpu-env )
56 [ get_ppc_vmx_env ] keep ;
58 M: ppc-fpu-env (set-fp-env-register)
61 M: ppc-vmx-env (set-fp-env-register)
64 M: ppc (fp-env-registers)
65 <ppc-fpu-env> 1array ;
67 CONSTANT: ppc-exception-flag-bits 0xfff8,0700
68 CONSTANT: ppc-exception-flag>bit
70 { +fp-invalid-operation+ 0x2000,0000 }
71 { +fp-overflow+ 0x1000,0000 }
72 { +fp-underflow+ 0x0800,0000 }
73 { +fp-zero-divide+ 0x0400,0000 }
74 { +fp-inexact+ 0x0200,0000 }
77 CONSTANT: ppc-fp-traps-bits 0xf8
78 CONSTANT: ppc-fp-traps>bit
80 { +fp-invalid-operation+ 0x80 }
81 { +fp-overflow+ 0x40 }
82 { +fp-underflow+ 0x20 }
83 { +fp-zero-divide+ 0x10 }
87 CONSTANT: ppc-rounding-mode-bits 0x3
88 CONSTANT: ppc-rounding-mode>bit
90 { +round-nearest+ 0x0 }
96 CONSTANT: ppc-denormal-mode-bits 0x4
98 M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
99 fpscr>> ppc-exception-flag>bit mask> ; inline
100 M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
101 [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
103 M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
104 fpscr>> ppc-fp-traps>bit mask> ; inline
105 M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
106 [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
108 M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
109 fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
110 M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
111 [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
113 M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
114 fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
115 M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
118 { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
119 { +denormal-flush+ [ ppc-denormal-mode-bits bitor ] }
121 ] curry change-fpscr ; inline
123 CONSTANT: vmx-denormal-mode-bits 0x10000
125 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
127 M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
130 M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
132 M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
135 M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
136 drop +round-nearest+ ;
137 M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
140 M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
141 vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
142 M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
145 { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] }
146 { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] }
148 ] curry change-vscr ; inline