unmaintained/arm/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays cpu.architecture cpu.arm.assembler
   4 cpu.arm.architecture cpu.arm.allot kernel kernel.private math
   5 math.private namespaces sequences words
   6 quotations byte-arrays hashtables.private hashtables generator
   7 generator.registers generator.fixup sequences.private sbufs
   8 sbufs.private vectors vectors.private system
   9 classes.tuple.private layouts strings.private slots.private ;
  10 IN: cpu.arm.intrinsics
  11
  12 : %slot-literal-known-tag
  13     "val" operand
  14     "obj" operand
  15     "n" get cells
  16     "obj" get operand-tag - <+/-> ;
  17
  18 : %slot-literal-any-tag
  19     "scratch" operand "obj" operand %untag
  20     "val" operand "scratch" operand "n" get cells <+> ;
  21
  22 : %slot-any
  23     "scratch" operand "obj" operand %untag
  24     "n" operand dup 1 <LSR> MOV
  25     "val" operand "scratch" operand "n" operand <+> ;
  26
  27 \ slot {
  28     ! Slot number is literal and the tag is known
  29     {
  30         [ %slot-literal-known-tag LDR ] H{
  31             { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
  32             { +scratch+ { { f "val" } } }
  33             { +output+ { "val" } }
  34         }
  35     }
  36     ! Slot number is literal
  37     {
  38         [ %slot-literal-any-tag LDR ] H{
  39             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
  40             { +scratch+ { { f "scratch" } { f "val" } } }
  41             { +output+ { "val" } }
  42         }
  43     }
  44     ! Slot number in a register
  45     {
  46         [ %slot-any LDR ] H{
  47             { +input+ { { f "obj" } { f "n" } } }
  48             { +scratch+ { { f "val" } { f "scratch" } } }
  49             { +output+ { "val" } }
  50             { +clobber+ { "n" } }
  51         }
  52     }
  53 } define-intrinsics
  54
  55 : %write-barrier ( -- )
  56     "val" get operand-immediate? "obj" get fresh-object? or [
  57         "cards_offset" f R12 %alien-global
  58         "scratch" operand R12 "obj" operand card-bits <LSR> ADD
  59         "val" operand "scratch" operand 0 <+> LDRB
  60         "val" operand dup card-mark ORR
  61         "val" operand "scratch" operand 0 <+> STRB
  62     ] unless ;
  63
  64 \ set-slot {
  65     ! Slot number is literal and tag is known
  66     {
  67         [ %slot-literal-known-tag STR %write-barrier ] H{
  68             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
  69             { +scratch+ { { f "scratch" } } }
  70             { +clobber+ { "val" } }
  71         }
  72     }
  73     ! Slot number is literal
  74     {
  75         [ %slot-literal-any-tag STR %write-barrier ] H{
  76             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
  77             { +scratch+ { { f "scratch" } } }
  78             { +clobber+ { "val" } }
  79         }
  80     }
  81     ! Slot number is in a register
  82     {
  83         [ %slot-any STR %write-barrier ] H{
  84             { +input+ { { f "val" } { f "obj" } { f "n" } } }
  85             { +scratch+ { { f "scratch" } } }
  86             { +clobber+ { "val" "n" } }
  87         }
  88     }
  89 } define-intrinsics
  90
  91 : fixnum-op ( op -- quot )
  92     [ "out" operand "x" operand "y" operand ] swap add ;
  93
  94 : fixnum-register-op ( op -- pair )
  95     fixnum-op H{
  96         { +input+ { { f "x" } { f "y" } } }
  97         { +scratch+ { { f "out" } } }
  98         { +output+ { "out" } }
  99     } 2array ;
 100
 101 : fixnum-value-op ( op -- pair )
 102     fixnum-op H{
 103         { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
 104         { +scratch+ { { f "out" } } }
 105         { +output+ { "out" } }
 106     } 2array ;
 107
 108 : define-fixnum-op ( word op -- )
 109     [ fixnum-value-op ] keep fixnum-register-op 2array
 110     define-intrinsics ;
 111
 112 {
 113     { fixnum+fast ADD }
 114     { fixnum-fast SUB }
 115     { fixnum-bitand AND }
 116     { fixnum-bitor ORR }
 117     { fixnum-bitxor EOR }
 118 } [
 119     first2 define-fixnum-op
 120 ] each
 121
 122 \ fixnum-bitnot [
 123     "x" operand dup MVN
 124     "x" operand dup %untag
 125 ] H{
 126     { +input+ { { f "x" } } }
 127     { +output+ { "x" } }
 128 } define-intrinsic
 129
 130 \ fixnum*fast [
 131     "out" operand "y" operand %untag-fixnum
 132     "out" operand "x" operand "out" operand MUL
 133 ] H{
 134     { +input+ { { f "x" } { f "y" } } }
 135     { +scratch+ { { f "out" } } }
 136     { +output+ { "out" } }
 137 } define-intrinsic
 138
 139 \ fixnum-shift [
 140     "out" operand "x" operand "y" get neg <ASR> MOV
 141     ! Mask off low bits
 142     "out" operand dup %untag
 143 ] H{
 144     { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
 145     { +scratch+ { { f "out" } } }
 146     { +output+ { "out" } }
 147 } define-intrinsic
 148
 149 : %untag-fixnums ( seq -- )
 150     [ dup %untag-fixnum ] unique-operands ;
 151
 152 : overflow-check ( insn -- )
 153     [
 154         "end" define-label
 155         [ "out" operand "x" operand "y" operand roll S execute ] keep
 156         "end" get VC B
 157         { "x" "y" } %untag-fixnums
 158         "x" operand "x" operand "y" operand roll execute
 159         "out" get "x" get %allot-bignum-signed-1
 160         "end" resolve-label
 161     ] with-scope ; inline
 162
 163 : overflow-template ( word insn -- )
 164     [ overflow-check ] curry H{
 165         { +input+ { { f "x" } { f "y" } } }
 166         { +scratch+ { { f "out" } } }
 167         { +output+ { "out" } }
 168         { +clobber+ { "x" "y" } }
 169     } define-intrinsic ;
 170
 171 \ fixnum+ \ ADD overflow-template
 172 \ fixnum- \ SUB overflow-template
 173
 174 \ fixnum>bignum [
 175     "x" operand dup %untag-fixnum
 176     "out" get "x" get %allot-bignum-signed-1
 177 ] H{
 178     { +input+ { { f "x" } } }
 179     { +scratch+ { { f "out" } } }
 180     { +clobber+ { "x" } }
 181     { +output+ { "out" } }
 182 } define-intrinsic
 183
 184 \ bignum>fixnum [
 185     "end" define-label
 186     "x" operand dup %untag
 187     "y" operand "x" operand cell <+> LDR
 188      ! if the length is 1, its just the sign and nothing else,
 189      ! so output 0
 190     "y" operand 1 v>operand CMP
 191     "y" operand 0 EQ MOV
 192     "end" get EQ B
 193     ! load the value
 194     "y" operand "x" operand 3 cells <+> LDR
 195     ! load the sign
 196     "x" operand "x" operand 2 cells <+> LDR
 197     ! is the sign negative?
 198     "x" operand 0 CMP
 199     ! Negate the value
 200     "y" operand "y" operand 0 NE RSB
 201     "y" operand dup %tag-fixnum
 202     "end" resolve-label
 203 ] H{
 204     { +input+ { { f "x" } } }
 205     { +scratch+ { { f "y" } } }
 206     { +clobber+ { "x" } }
 207     { +output+ { "y" } }
 208 } define-intrinsic
 209
 210 : fixnum-jump ( op -- quo )
 211     [ "x" operand "y" operand CMP ] swap
 212     1quotation [ B ] 3append ;
 213
 214 : fixnum-register-jump ( op -- pair )
 215    fixnum-jump { { f "x" } { f "y" } } 2array ;
 216
 217 : fixnum-value-jump ( op -- pair )
 218     fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ;
 219
 220 : define-fixnum-jump ( word op -- )
 221     [ fixnum-value-jump ] keep fixnum-register-jump
 222     2array define-if-intrinsics ;
 223
 224 {
 225     { fixnum< LT }
 226     { fixnum<= LE }
 227     { fixnum> GT }
 228     { fixnum>= GE }
 229     { eq? EQ }
 230 } [
 231     first2 define-fixnum-jump
 232 ] each
 233
 234 \ tag [
 235     "out" operand "in" operand tag-mask get AND
 236     "out" operand dup %tag-fixnum
 237 ] H{
 238     { +input+ { { f "in" } } }
 239     { +scratch+ { { f "out" } } }
 240     { +output+ { "out" } }
 241 } define-intrinsic
 242
 243 \ type [
 244     ! Get the tag
 245     "out" operand "obj" operand tag-mask get AND
 246     ! Compare with object tag number (3).
 247     "out" operand object tag-number CMP
 248     ! Tag the tag if it is not equal to 3
 249     "out" operand dup NE %tag-fixnum
 250     ! Load the object header if tag is equal to 3
 251     "out" operand "obj" operand object tag-number <-> EQ LDR
 252 ] H{
 253     { +input+ { { f "obj" } } }
 254     { +scratch+ { { f "out" } } }
 255     { +output+ { "out" } }
 256 } define-intrinsic
 257
 258 \ class-hash [
 259     "end" define-label
 260     ! Get the tag
 261     "out" operand "obj" operand tag-mask get AND
 262     ! Compare with tuple tag number (2).
 263     "out" operand tuple tag-number CMP
 264     "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
 265     "out" operand dup class-hash-offset <+/-> EQ LDR
 266     "end" get EQ B
 267     ! Compare with object tag number (3).
 268     "out" operand object tag-number CMP
 269     "out" operand "obj" operand object tag-number <-> EQ LDR
 270     ! Tag the tag
 271     "out" operand dup NE %tag-fixnum
 272     "end" resolve-label
 273 ] H{
 274     { +input+ { { f "obj" } } }
 275     { +scratch+ { { f "out" } } }
 276     { +output+ { "out" } }
 277 } define-intrinsic
 278
 279 : userenv ( reg -- )
 280     ! Load the userenv pointer in a register.
 281     "userenv" f rot compile-dlsym ;
 282
 283 \ getenv [
 284     "n" operand dup 1 <ASR> MOV
 285     "x" operand userenv
 286     "x" operand "x" operand "n" operand <+> LDR
 287 ] H{
 288     { +input+ { { f "n" } } }
 289     { +scratch+ { { f "x" } } }
 290     { +output+ { "x" } }
 291     { +clobber+ { "n" } }
 292 } define-intrinsic
 293
 294 \ setenv [
 295     "n" operand dup 1 <ASR> MOV
 296     "x" operand userenv
 297     "val" operand "x" operand "n" operand <+> STR
 298 ] H{
 299     { +input+ { { f "val" } { f "n" } } }
 300     { +scratch+ { { f "x" } } }
 301     { +clobber+ { "n" } }
 302 } define-intrinsic
 303
 304 : %set-slot R11 swap cells <+> STR ;
 305
 306 : %store-length
 307     R12 "n" operand MOV
 308     R12 1 %set-slot ;
 309
 310 : %fill-array swap 2 + %set-slot ;
 311
 312 \ <tuple> [
 313     tuple "n" get 2 + cells %allot
 314     %store-length
 315     ! Store class
 316     "class" operand 2 %set-slot
 317     ! Zero out the rest of the tuple
 318     "initial" operand f v>operand MOV
 319     "n" get 1- [ 1+ "initial" operand %fill-array ] each
 320     "out" get tuple %store-tagged
 321 ] H{
 322     { +input+ { { f "class" } { [ inline-array? ] "n" } } }
 323     { +scratch+ { { f "out" } { f "initial" } } }
 324     { +output+ { "out" } }
 325 } define-intrinsic
 326
 327 \ <array> [
 328     array "n" get 2 + cells %allot
 329     %store-length
 330     ! Store initial element
 331     "n" get [ "initial" operand %fill-array ] each
 332     "out" get object %store-tagged
 333 ] H{
 334     { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
 335     { +scratch+ { { f "out" } } }
 336     { +output+ { "out" } }
 337 } define-intrinsic
 338
 339 \ <byte-array> [
 340     byte-array "n" get 2 cells + %allot
 341     %store-length
 342     ! Store initial element
 343     R12 0 MOV
 344     "n" get cell align cell /i [ R12 %fill-array ] each
 345     "out" get object %store-tagged
 346 ] H{
 347     { +input+ { { [ inline-array? ] "n" } } }
 348     { +scratch+ { { f "out" } } }
 349     { +output+ { "out" } }
 350 } define-intrinsic
 351
 352 \ <ratio> [
 353     ratio 3 cells %allot
 354     "numerator" operand 1 %set-slot
 355     "denominator" operand 2 %set-slot
 356     "out" get ratio %store-tagged
 357 ] H{
 358     { +input+ { { f "numerator" } { f "denominator" } } }
 359     { +scratch+ { { f "out" } } }
 360     { +output+ { "out" } }
 361 } define-intrinsic
 362
 363 \ <complex> [
 364     complex 3 cells %allot
 365     "real" operand 1 %set-slot
 366     "imaginary" operand 2 %set-slot
 367     ! Store tagged ptr in reg
 368     "out" get complex %store-tagged
 369 ] H{
 370     { +input+ { { f "real" } { f "imaginary" } } }
 371     { +scratch+ { { f "out" } } }
 372     { +output+ { "out" } }
 373 } define-intrinsic
 374
 375 \ <wrapper> [
 376     wrapper 2 cells %allot
 377     "obj" operand 1 %set-slot
 378     ! Store tagged ptr in reg
 379     "out" get object %store-tagged
 380 ] H{
 381     { +input+ { { f "obj" } } }
 382     { +scratch+ { { f "out" } } }
 383     { +output+ { "out" } }
 384 } define-intrinsic
 385
 386 ! Alien intrinsics
 387 : %alien-accessor ( quot -- )
 388     "offset" operand dup %untag-fixnum
 389     "offset" operand dup "alien" operand ADD
 390     "value" operand "offset" operand 0 <+> roll call ; inline
 391
 392 : alien-integer-get-template
 393     H{
 394         { +input+ {
 395             { unboxed-c-ptr "alien" c-ptr }
 396             { f "offset" fixnum }
 397         } }
 398         { +scratch+ { { f "value" } } }
 399         { +output+ { "value" } }
 400         { +clobber+ { "offset" } }
 401     } ;
 402
 403 : %alien-integer-get ( quot -- )
 404     %alien-accessor
 405     "value" operand dup %tag-fixnum ; inline
 406
 407 : alien-integer-set-template
 408     H{
 409         { +input+ {
 410             { f "value" fixnum }
 411             { unboxed-c-ptr "alien" c-ptr }
 412             { f "offset" fixnum }
 413         } }
 414         { +clobber+ { "value" "offset" } }
 415     } ;
 416
 417 : %alien-integer-set ( quot -- )
 418     "offset" get "value" get = [
 419         "value" operand dup %untag-fixnum
 420     ] unless
 421     %alien-accessor ; inline
 422
 423 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
 424     [ %alien-integer-set ] curry
 425     alien-integer-set-template
 426     define-intrinsic
 427     [ %alien-integer-get ] curry
 428     alien-integer-get-template
 429     define-intrinsic ;
 430
 431 \ alien-unsigned-1 [ LDRB ]
 432 \ set-alien-unsigned-1 [ STRB ]
 433 define-alien-integer-intrinsics
 434
 435 : alien-cell-template
 436     H{
 437         { +input+ {
 438             { unboxed-c-ptr "alien" c-ptr }
 439             { f "offset" fixnum }
 440         } }
 441         { +scratch+ { { unboxed-alien "value" } } }
 442         { +output+ { "value" } }
 443         { +clobber+ { "offset" } }
 444     } ;
 445
 446 \ alien-cell
 447 [ [ LDR ] %alien-accessor ]
 448 alien-cell-template define-intrinsic
 449
 450 : set-alien-cell-template
 451     H{
 452         { +input+ {
 453             { unboxed-c-ptr "value" pinned-c-ptr }
 454             { unboxed-c-ptr "alien" c-ptr }
 455             { f "offset" fixnum }
 456         } }
 457         { +clobber+ { "offset" } }
 458     } ;
 459
 460 \ set-alien-cell
 461 [ [ STR ] %alien-accessor ]
 462 set-alien-cell-template define-intrinsic