basis/math/floats/env/ppc/ppc.factor

   1 USING: accessors alien.syntax arrays assocs biassocs
   2 classes.struct combinators kernel literals math math.bitwise
   3 math.floats.env math.floats.env.private system ;
   4 IN: math.floats.env.ppc
   5
   6 STRUCT: ppc-fpu-env
   7     { padding uint }
   8     { fpscr uint } ;
   9
  10 STRUCT: ppc-vmx-env
  11     { vscr uint } ;
  12
  13 ! defined in the vm, cpu-ppc*.S
  14 FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
  15 FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
  16
  17 FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
  18 FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
  19
  20 : <ppc-fpu-env> ( -- ppc-fpu-env )
  21     ppc-fpu-env (struct)
  22     [ get_ppc_fpu_env ] keep ;
  23
  24 : <ppc-vmx-env> ( -- ppc-fpu-env )
  25     ppc-vmx-env (struct)
  26     [ get_ppc_vmx_env ] keep ;
  27
  28 M: ppc-fpu-env (set-fp-env-register)
  29     set_ppc_fpu_env ;
  30
  31 M: ppc-vmx-env (set-fp-env-register)
  32     set_ppc_vmx_env ;
  33
  34 M: ppc (fp-env-registers)
  35     <ppc-fpu-env> <ppc-vmx-env> 2array ;
  36
  37 CONSTANT: ppc-exception-flag-bits HEX: fff8,0700
  38 CONSTANT: ppc-exception-flag>bit
  39     H{
  40         { +fp-invalid-operation+ HEX: 2000,0000 }
  41         { +fp-overflow+          HEX: 1000,0000 }
  42         { +fp-underflow+         HEX: 0800,0000 }
  43         { +fp-zero-divide+       HEX: 0400,0000 }
  44         { +fp-inexact+           HEX: 0200,0000 }
  45     }
  46
  47 CONSTANT: ppc-fp-traps-bits HEX: f8
  48 CONSTANT: ppc-fp-traps>bit
  49     H{
  50         { +fp-invalid-operation+ HEX: 80 }
  51         { +fp-overflow+          HEX: 40 }
  52         { +fp-underflow+         HEX: 20 }
  53         { +fp-zero-divide+       HEX: 10 }
  54         { +fp-inexact+           HEX: 08 }
  55     }
  56
  57 CONSTANT: ppc-rounding-mode-bits HEX: 3
  58 CONSTANT: ppc-rounding-mode>bit
  59     $[ H{
  60         { +round-nearest+ HEX: 0 }
  61         { +round-zero+    HEX: 1 }
  62         { +round-up+      HEX: 2 }
  63         { +round-down+    HEX: 3 }
  64     } >biassoc ]
  65
  66 CONSTANT: ppc-denormal-mode-bits HEX: 4
  67
  68 M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
  69     fpscr>> ppc-exception-flag>bit mask> ; inline
  70 M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
  71     [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
  72
  73 M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
  74     fpscr>> ppc-fp-traps>bit mask> ; inline
  75 M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
  76     [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
  77
  78 M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
  79     fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
  80 M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
  81     [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
  82
  83 M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
  84     fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
  85 M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
  86     [
  87         {
  88             { +denormal-keep+  [ ppc-denormal-mode-bits unmask ] }
  89             { +denormal-flush+ [ ppc-denormal-mode-bits bitor  ] }
  90         } case
  91     ] curry change-fpscr ; inline
  92
  93 CONSTANT: vmx-denormal-mode-bits HEX: 10000
  94
  95 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
  96     drop { } ; inline
  97 M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
  98     drop ;
  99
 100 M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
 101     drop { } ; inline
 102 M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
 103     drop ;
 104
 105 M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
 106     drop +round-nearest+ ;
 107 M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
 108     drop ;
 109
 110 M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
 111     vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
 112 M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
 113     [
 114         {
 115             { +denormal-keep+  [ vmx-denormal-mode-bits unmask ] }
 116             { +denormal-flush+ [ vmx-denormal-mode-bits bitor  ] }
 117         } case
 118     ] curry change-vscr ; inline
 119