core/compiler/ppc/intrinsics.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler
   4 USING: alien assembler kernel kernel-internals math
   5 math-internals namespaces sequences words ;
   6
   7 : generate-slot ( size quot -- )
   8     >r >r
   9     ! turn tagged fixnum slot # into an offset, multiple of 4
  10     "n" operand dup tag-bits r> - SRAWI
  11     ! compute slot address
  12     "obj" operand dup "n" operand ADD
  13     ! load slot value
  14     "obj" operand dup r> call ; inline
  15
  16 \ slot [
  17     "obj" operand dup %untag
  18     cell log2 [ 0 LWZ ] generate-slot
  19 ] H{
  20     { +input+ { { f "obj" } { f "n" } } }
  21     { +output+ { "obj" } }
  22 } define-intrinsic
  23
  24 \ char-slot [
  25     1 [ string-offset LHZ ] generate-slot
  26     "obj" operand dup %tag-fixnum
  27 ] H{
  28     { +input+ { { f "n" } { f "obj" } } }
  29     { +output+ { "obj" } }
  30 } define-intrinsic
  31
  32 : generate-set-slot ( size quot -- )
  33     >r >r
  34     ! turn tagged fixnum slot # into an offset, multiple of 4
  35     "slot" operand dup tag-bits r> - SRAWI
  36     ! compute slot address in 1st input
  37     "slot" operand dup "obj" operand ADD
  38     ! store new slot value
  39     "val" operand "slot" operand r> call ; inline
  40
  41 : generate-write-barrier ( -- )
  42     #! Mark the card pointed to by vreg.
  43     "obj" operand dup card-bits SRAWI
  44     "obj" operand dup 16 ADD
  45     "x" operand "obj" operand 0 LBZ
  46     "x" operand dup card-mark ORI
  47     "x" operand "obj" operand 0 STB ;
  48
  49 \ set-slot [
  50     "obj" operand dup %untag
  51     cell log2 [ 0 STW ] generate-set-slot generate-write-barrier
  52 ] H{
  53     { +input+ { { f "val" } { f "obj" } { f "slot" } } }
  54     { +scratch+ { { f "x" } } }
  55     { +clobber+ { "obj" "slot" } }
  56 } define-intrinsic
  57
  58 \ set-char-slot [
  59     ! untag the new value in 0th input
  60     "val" operand dup %untag-fixnum
  61     1 [ string-offset STH ] generate-set-slot
  62 ] H{
  63     { +input+ { { f "val" } { f "slot" } { f "obj" } } }
  64     { +scratch+ { { f "x" } } }
  65     { +clobber+ { "val" "slot" "obj" } }
  66 } define-intrinsic
  67
  68 : define-fixnum-op ( word op -- )
  69     [ [ "x" operand "y" operand "x" operand ] % , ] [ ] make H{
  70         { +input+ { { f "x" } { f "y" } } }
  71         { +output+ { "x" } }
  72     } define-intrinsic ;
  73
  74 {
  75     { fixnum+fast ADD }
  76     { fixnum-fast SUBF }
  77     { fixnum-bitand AND }
  78     { fixnum-bitor OR }
  79     { fixnum-bitxor XOR }
  80 } [
  81     first2 define-fixnum-op
  82 ] each
  83
  84 : generate-fixnum-mod
  85     #! PowerPC doesn't have a MOD instruction; so we compute
  86     #! x-(x/y)*y. Puts the result in "s" operand.
  87     "s" operand "r" operand "y" operand MULLW
  88     "s" operand "s" operand "x" operand SUBF ;
  89
  90 \ fixnum-mod [
  91     ! divide x by y, store result in x
  92     "r" operand "x" operand "y" operand DIVW
  93     generate-fixnum-mod
  94 ] H{
  95     { +input+ { { f "x" } { f "y" } } }
  96     { +scratch+ { { f "r" } { f "s" } } }
  97     { +output+ { "s" } }
  98 } define-intrinsic
  99
 100 \ fixnum-bitnot [
 101     "x" operand dup NOT
 102     "x" operand dup %untag
 103 ] H{
 104     { +input+ { { f "x" } } }
 105     { +output+ { "x" } }
 106 } define-intrinsic
 107
 108 : define-fixnum-jump ( word op -- )
 109     [ "x" operand 0 "y" operand CMP ] swap add
 110     { { f "x" } { f "y" } } define-if-intrinsic ;
 111
 112 {
 113     { fixnum< BLT }
 114     { fixnum<= BLE }
 115     { fixnum> BGT }
 116     { fixnum>= BGE }
 117     { eq? BEQ }
 118 } [
 119     first2 define-fixnum-jump
 120 ] each
 121
 122 : simple-overflow ( word -- )
 123     [
 124         >r
 125         "end" define-label
 126         "end" get BNO
 127         { "x" "y" } [ dup %untag-fixnum ] unique-operands
 128         "r" operand "y" operand "x" operand r> execute
 129         "r" operand %allot-bignum-signed-1
 130         "end" resolve-label
 131     ] with-scope ; inline
 132
 133 \ fixnum+ [
 134     0 MTXER
 135     "r" operand "y" operand "x" operand ADDO.
 136     \ ADD simple-overflow
 137 ] H{
 138     { +input+ { { f "x" } { f "y" } } }
 139     { +scratch+ { { f "r" } } }
 140     { +output+ { "r" } }
 141     { +clobber+ { "x" "y" } }
 142 } define-intrinsic
 143
 144 \ fixnum- [
 145     0 MTXER
 146     "r" operand "y" operand "x" operand SUBFO.
 147     \ SUBF simple-overflow
 148 ] H{
 149     { +input+ { { f "x" } { f "y" } } }
 150     { +scratch+ { { f "r" } } }
 151     { +output+ { "r" } }
 152     { +clobber+ { "x" "y" } }
 153 } define-intrinsic
 154
 155 ! \ fixnum* [
 156 !     "end" define-label
 157 !     "r" operand "x" operand %untag-fixnum
 158 !     0 MTXER
 159 !     "s" operand "y" operand "r" operand MULLWO.
 160 !     "end" get BNO
 161 !     "s" operand "y" operand 1 SRAWI
 162 !     "x" operand "s" operand "r" operand MULLWO.
 163 !     "x" operand dup 2 SRAWI
 164 !     "s" operand "s" operand "r" operand MULHW
 165 !     "s" operand "x" operand %allot-bignum-signed-2
 166 !     "end" resolve-label
 167 ! ] H{
 168 !     { +input+ { { f "x" } { f "y" } } }
 169 !     { +scratch+ { { f "r" } { f "s" } } }
 170 !     { +output+ { "s" } }
 171 !     { +clobber+ { "x" "y" } }
 172 ! } define-intrinsic
 173
 174 : generate-fixnum/i
 175     #! This VOP is funny. If there is an overflow, it falls
 176     #! through to the end, and the result is in "x" operand.
 177     #! Otherwise it jumps to the "no-overflow" label and the
 178     #! result is in "r" operand.
 179     "end" define-label
 180     "no-overflow" define-label
 181     "r" operand "x" operand "y" operand DIVW
 182     ! if the result is greater than the most positive fixnum,
 183     ! which can only ever happen if we do
 184     ! most-negative-fixnum -1 /i, then the result is a bignum.
 185     most-positive-fixnum "s" operand LOAD
 186     "r" operand 0 "s" operand CMP
 187     "no-overflow" get BLE
 188     most-negative-fixnum neg "x" operand LOAD
 189     "x" operand %allot-bignum-signed-1 ;
 190
 191 \ fixnum/i [
 192     generate-fixnum/i
 193     "end" get B
 194     "no-overflow" resolve-label
 195     "r" operand "x" operand %tag-fixnum
 196     "end" resolve-label
 197 ] H{
 198     { +input+ { { f "x" } { f "y" } } }
 199     { +scratch+ { { f "r" } { f "s" } } }
 200     { +output+ { "x" } }
 201     { +clobber+ { "y" } }
 202 } define-intrinsic
 203
 204 \ fixnum/mod [
 205     generate-fixnum/i
 206     0 "s" operand LI
 207     "end" get B
 208     "no-overflow" resolve-label
 209     generate-fixnum-mod
 210     "r" operand "x" operand %tag-fixnum
 211     "end" resolve-label
 212 ] H{
 213     { +input+ { { f "x" } { f "y" } } }
 214     { +scratch+ { { f "r" } { f "s" } } }
 215     { +output+ { "x" "s" } }
 216     { +clobber+ { "y" } }
 217 } define-intrinsic
 218
 219 \ fixnum>bignum [
 220     "nonzero" define-label
 221     "end" define-label
 222     0 "x" operand 0 CMPI ! is it zero?
 223     "nonzero" get BNE
 224     0 >bignum "x" get load-literal
 225     "end" get B
 226     "nonzero" resolve-label
 227     "x" operand dup %untag-fixnum
 228     "x" operand %allot-bignum-signed-1
 229     "end" resolve-label
 230 ] H{
 231     { +input+ { { f "x" } } }
 232     { +output+ { "x" } }
 233 } define-intrinsic
 234
 235 \ bignum>fixnum [
 236     "nonzero" define-label
 237     "positive" define-label
 238     "end" define-label
 239     "x" operand dup %untag
 240     "y" operand "x" operand cell LWZ
 241      ! if the length is 1, its just the sign and nothing else,
 242      ! so output 0
 243     0 "y" operand 1 tag-bits shift CMPI
 244     "nonzero" get BNE
 245     0 "y" operand LI
 246     "end" get B
 247     "nonzero" resolve-label
 248     ! load the value
 249     "y" operand "x" operand 3 cells LWZ
 250     ! load the sign
 251     "x" operand "x" operand 2 cells LWZ
 252     ! is the sign negative?
 253     0 "x" operand 0 CMPI
 254     "positive" get BEQ
 255     "y" operand dup -1 MULI
 256     "positive" resolve-label
 257     "y" operand dup %tag-fixnum
 258     "end" resolve-label
 259 ] H{
 260     { +input+ { { f "x" } } }
 261     { +scratch+ { { f "y" } } }
 262     { +clobber+ { "x" } }
 263     { +output+ { "y" } }
 264 } define-intrinsic
 265
 266 : define-float-op ( word op -- )
 267     [ [ "x" operand "x" operand "y" operand ] % , ] [ ] make H{
 268         { +input+ { { float "x" } { float "y" } } }
 269         { +output+ { "x" } }
 270     } define-intrinsic ;
 271
 272 {
 273     { float+ FADD }
 274     { float- FSUB }
 275     { float* FMUL }
 276     { float/f FDIV }
 277 } [
 278     first2 define-float-op
 279 ] each
 280
 281 : define-float-jump ( word op -- )
 282     [ "x" operand 0 "y" operand FCMPU ] swap add
 283     { { float "x" } { float "y" } } define-if-intrinsic ;
 284
 285 {
 286     { float< BLT }
 287     { float<= BLE }
 288     { float> BGT }
 289     { float>= BGE }
 290     { float= BEQ }
 291 } [
 292     first2 define-float-jump
 293 ] each
 294
 295 \ float>fixnum [
 296     "scratch" operand "in" operand FCTIWZ
 297     "scratch" operand 1 0 stack@ STFD
 298     "out" operand 1 cell stack@ LWZ
 299     "out" operand dup %tag-fixnum
 300 ] H{
 301     { +input+ { { float "in" } } }
 302     { +scratch+ { { float "scratch" } { f "out" } } }
 303     { +output+ { "out" } }
 304 } define-intrinsic
 305
 306 \ tag [
 307     "in" operand "out" operand tag-mask ANDI
 308     "out" operand dup %tag-fixnum
 309 ] H{
 310     { +input+ { { f "in" } } }
 311     { +scratch+ { { f "out" } } }
 312     { +output+ { "out" } }
 313 } define-intrinsic
 314
 315 \ type [
 316     "f" define-label
 317     "end" define-label
 318     ! Get the tag
 319     "obj" operand "y" operand tag-mask ANDI
 320     ! Tag the tag
 321     "y" operand "x" operand %tag-fixnum
 322     ! Compare with object tag number (3).
 323     0 "y" operand object-tag CMPI
 324     ! Jump if the object doesn't store type info in its header
 325     "end" get BNE
 326     ! It does store type info in its header
 327     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
 328     0 "obj" operand object-tag CMPI
 329     "f" get BEQ
 330     ! The pointer is not equal to 3. Load the object header.
 331     "x" operand "obj" operand object-tag neg LWZ
 332     "x" operand dup %untag
 333     "end" get B
 334     "f" resolve-label
 335     ! The pointer is equal to 3. Load F_TYPE (9).
 336     f type tag-bits shift "x" operand LI
 337     "end" resolve-label
 338 ] H{
 339     { +input+ { { f "obj" } } }
 340     { +scratch+ { { f "x" } { f "y" } } }
 341     { +output+ { "x" } }
 342 } define-intrinsic
 343
 344 : userenv ( reg -- )
 345     #! Load the userenv pointer in a register.
 346     "userenv" f rot compile-dlsym ;
 347
 348 \ getenv [
 349     "n" operand dup 1 SRAWI
 350     "x" operand userenv
 351     "x" operand "n" operand "x" operand ADD
 352     "x" operand dup 0 LWZ
 353 ] H{
 354     { +input+ { { f "n" } } }
 355     { +scratch+ { { f "x" } } }
 356     { +output+ { "x" } }
 357     { +clobber+ { "n" } }
 358 } define-intrinsic
 359
 360 \ setenv [
 361     "n" operand dup 1 SRAWI
 362     "x" operand userenv
 363     "x" operand "n" operand "x" operand ADD
 364     "val" operand "x" operand 0 STW
 365 ] H{
 366     { +input+ { { f "val" } { f "n" } } }
 367     { +scratch+ { { f "x" } } }
 368     { +clobber+ { "n" } }
 369 } define-intrinsic