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 ! defined in the vm, cpu-ppc*.S
  11 FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
  12 FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
  13
  14 : <ppc-fpu-env> ( -- ppc-fpu-env )
  15     ppc-fpu-env (struct)
  16     [ get_ppc_fpu_env ] keep ;
  17
  18 M: ppc-fpu-env (set-fp-env-register)
  19     set_ppc_fpu_env ;
  20
  21 M: ppc (fp-env-registers)
  22     <ppc-fpu-env> 1array ;
  23
  24 CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
  25 CONSTANT: ppc-exception-flag>bit
  26     H{
  27         { +fp-invalid-operation+ HEX: 2000,0000 }
  28         { +fp-overflow+          HEX: 1000,0000 }
  29         { +fp-underflow+         HEX: 0800,0000 }
  30         { +fp-zero-divide+       HEX: 0400,0000 }
  31         { +fp-inexact+           HEX: 0200,0000 }
  32     }
  33
  34 CONSTANT: ppc-fp-traps-bits HEX: f80
  35 CONSTANT: ppc-fp-traps>bit
  36     H{
  37         { +fp-invalid-operation+ HEX: 8000 }
  38         { +fp-overflow+          HEX: 4000 }
  39         { +fp-underflow+         HEX: 2000 }
  40         { +fp-zero-divide+       HEX: 1000 }
  41         { +fp-inexact+           HEX: 0800 }
  42     }
  43
  44 CONSTANT: ppc-rounding-mode-bits HEX: 3
  45 CONSTANT: ppc-rounding-mode>bit
  46     $[ H{
  47         { +round-nearest+ HEX: 0 }
  48         { +round-zero+    HEX: 1 }
  49         { +round-up+      HEX: 2 }
  50         { +round-down+    HEX: 3 }
  51     } >biassoc ]
  52
  53 CONSTANT: ppc-denormal-mode-bits HEX: 4
  54
  55 M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
  56     fpscr>> ppc-exception-flag>bit mask> ; inline
  57 M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
  58     [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
  59
  60 M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
  61     fpscr>> bitnot ppc-fp-traps>bit mask> ; inline
  62 M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
  63     [ ppc-fp-traps>bit >mask bitnot ppc-fp-traps-bits remask ] curry change-fpscr ; inline
  64
  65 M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
  66     fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
  67 M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
  68     [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
  69
  70 M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
  71     fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
  72 M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
  73     [
  74         {
  75             { +denormal-keep+  [ ppc-denormal-mode-bits unmask ] }
  76             { +denormal-flush+ [ ppc-denormal-mode-bits bitor  ] }
  77         } case
  78     ] curry change-fpscr ; inline
  79