/unmaintained/arm/intrinsics/intrinsics.factor
Unknown | 462 lines | 411 code | 51 blank | 0 comment | 0 complexity | 69e9005e3170cb78baff9a0447954750 MD5 | raw file
1! Copyright (C) 2007 Slava Pestov. 2! See http://factorcode.org/license.txt for BSD license. 3USING: alien arrays cpu.architecture cpu.arm.assembler 4cpu.arm.architecture cpu.arm.allot kernel kernel.private math 5math.private namespaces sequences words 6quotations byte-arrays hashtables.private hashtables generator 7generator.registers generator.fixup sequences.private sbufs 8sbufs.private vectors vectors.private system 9classes.tuple.private layouts strings.private slots.private ; 10IN: 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 ] 433define-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 ] 448alien-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 ] 462set-alien-cell-template define-intrinsic