1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors alien.c-types arrays
4 cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
5 cpu.architecture kernel kernel.private math math.private
6 namespaces sequences words generic quotations byte-arrays
7 hashtables hashtables.private generator generator.registers
8 generator.fixup sequences.private sbufs vectors system layouts
9 math.floats.private classes slots.private combinators
10 compiler.constants optimizer.allot ;
11 IN: cpu.ppc.intrinsics
13 : %slot-literal-known-tag
17 "obj" get operand-tag - ;
19 : %slot-literal-any-tag
20 "obj" operand "scratch1" operand %untag
21 "val" operand "scratch1" operand "n" get cells ;
24 "obj" operand "scratch1" operand %untag
25 "offset" operand "n" operand 1 SRAWI
26 "scratch1" operand "val" operand "offset" operand ;
29 ! Slot number is literal and the tag is known
31 [ %slot-literal-known-tag LWZ ] H{
32 { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
33 { +scratch+ { { f "val" } } }
34 { +output+ { "val" } }
37 ! Slot number is literal
39 [ %slot-literal-any-tag LWZ ] H{
40 { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
41 { +scratch+ { { f "scratch1" } { f "val" } } }
42 { +output+ { "val" } }
45 ! Slot number in a register
48 { +input+ { { f "obj" } { f "n" } } }
49 { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
50 { +output+ { "val" } }
55 : load-cards-offset ( dest -- )
56 "cards_offset" f pick %load-dlsym dup 0 LWZ ;
58 : load-decks-offset ( dest -- )
59 "decks_offset" f pick %load-dlsym dup 0 LWZ ;
61 : %write-barrier ( -- )
62 "val" get operand-immediate? "obj" get fresh-object? or [
63 card-mark "scratch1" operand LI
66 "val" operand load-cards-offset
67 "obj" operand "scratch2" operand card-bits SRWI
68 "scratch2" operand "scratch1" operand "val" operand STBX
71 "val" operand load-decks-offset
72 "obj" operand "scratch2" operand deck-bits SRWI
73 "scratch2" operand "scratch1" operand "val" operand STBX
77 ! Slot number is literal and tag is known
79 [ %slot-literal-known-tag STW %write-barrier ] H{
80 { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
81 { +scratch+ { { f "scratch1" } { f "scratch2" } } }
82 { +clobber+ { "val" } }
85 ! Slot number is literal
87 [ %slot-literal-any-tag STW %write-barrier ] H{
88 { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
89 { +scratch+ { { f "scratch1" } { f "scratch2" } } }
90 { +clobber+ { "val" } }
93 ! Slot number is in a register
95 [ %slot-any STWX %write-barrier ] H{
96 { +input+ { { f "val" } { f "obj" } { f "n" } } }
97 { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
98 { +clobber+ { "val" } }
103 : fixnum-register-op ( op -- pair )
104 [ "out" operand "y" operand "x" operand ] swap suffix H{
105 { +input+ { { f "x" } { f "y" } } }
106 { +scratch+ { { f "out" } } }
107 { +output+ { "out" } }
110 : fixnum-value-op ( op -- pair )
111 [ "out" operand "x" operand "y" operand ] swap suffix H{
112 { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
113 { +scratch+ { { f "out" } } }
114 { +output+ { "out" } }
117 : define-fixnum-op ( word imm-op reg-op -- )
118 >r fixnum-value-op r> fixnum-register-op 2array
122 { fixnum+fast ADDI ADD }
123 { fixnum-fast SUBI SUBF }
124 { fixnum-bitand ANDI AND }
125 { fixnum-bitor ORI OR }
126 { fixnum-bitxor XORI XOR }
128 first3 define-fixnum-op
134 "out" operand "x" operand "y" get MULLI
136 { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
137 { +scratch+ { { f "out" } } }
138 { +output+ { "out" } }
142 "out" operand "x" operand %untag-fixnum
143 "out" operand "y" operand "out" operand MULLW
145 { +input+ { { f "x" } { f "y" } } }
146 { +scratch+ { { f "out" } } }
147 { +output+ { "out" } }
152 : %untag-fixnums ( seq -- )
153 [ dup %untag-fixnum ] unique-operands ;
155 \ fixnum-shift-fast {
158 "out" operand "x" operand "y" get
159 dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
161 "out" operand dup %untag
163 { +input+ { { f "x" } { [ ] "y" } } }
164 { +scratch+ { { f "out" } } }
165 { +output+ { "out" } }
170 { "positive" "end" } [ define-label ] each
171 "out" operand "y" operand %untag-fixnum
174 "out" operand dup NEG
175 "out" operand "x" operand "out" operand SRAW
177 "positive" resolve-label
178 "out" operand "x" operand "out" operand SLW
181 "out" operand dup %untag
183 { +input+ { { f "x" } { f "y" } } }
184 { +scratch+ { { f "out" } } }
185 { +output+ { "out" } }
190 : generate-fixnum-mod
191 #! PowerPC doesn't have a MOD instruction; so we compute
192 #! x-(x/y)*y. Puts the result in "s" operand.
193 "s" operand "r" operand "y" operand MULLW
194 "s" operand "s" operand "x" operand SUBF ;
197 ! divide x by y, store result in x
198 "r" operand "x" operand "y" operand DIVW
201 { +input+ { { f "x" } { f "y" } } }
202 { +scratch+ { { f "r" } { f "s" } } }
208 "x" operand dup %untag
210 { +input+ { { f "x" } } }
214 : fixnum-register-jump ( op -- pair )
215 [ "x" operand 0 "y" operand CMP ] swap suffix
216 { { f "x" } { f "y" } } 2array ;
218 : fixnum-value-jump ( op -- pair )
219 [ 0 "x" operand "y" operand CMPI ] swap suffix
220 { { f "x" } { [ small-tagged? ] "y" } } 2array ;
222 : define-fixnum-jump ( word op -- )
223 [ fixnum-value-jump ] keep fixnum-register-jump
224 2array define-if-intrinsics ;
233 first2 define-fixnum-jump
236 : overflow-check ( insn1 insn2 -- )
240 "r" operand "y" operand "x" operand r> execute
244 { "x" "y" } %untag-fixnums
245 "r" operand "y" operand "x" operand r> execute
246 "r" get %allot-bignum-signed-1
248 ] with-scope ; inline
250 : overflow-template ( word insn1 insn2 -- )
251 [ overflow-check ] 2curry H{
252 { +input+ { { f "x" } { f "y" } } }
253 { +scratch+ { { f "r" } } }
255 { +clobber+ { "x" "y" } }
258 \ fixnum+ \ ADD \ ADDO. overflow-template
259 \ fixnum- \ SUBF \ SUBFO. overflow-template
262 #! This VOP is funny. If there is an overflow, it falls
263 #! through to the end, and the result is in "x" operand.
264 #! Otherwise it jumps to the "no-overflow" label and the
265 #! result is in "r" operand.
267 "no-overflow" define-label
268 "r" operand "x" operand "y" operand DIVW
269 ! if the result is greater than the most positive fixnum,
270 ! which can only ever happen if we do
271 ! most-negative-fixnum -1 /i, then the result is a bignum.
272 most-positive-fixnum "s" operand LOAD
273 "r" operand 0 "s" operand CMP
274 "no-overflow" get BLE
275 most-negative-fixnum neg "x" operand LOAD
276 "x" get %allot-bignum-signed-1 ;
281 "no-overflow" resolve-label
282 "r" operand "x" operand %tag-fixnum
285 { +input+ { { f "x" } { f "y" } } }
286 { +scratch+ { { f "r" } { f "s" } } }
288 { +clobber+ { "y" } }
295 "no-overflow" resolve-label
297 "r" operand "x" operand %tag-fixnum
300 { +input+ { { f "x" } { f "y" } } }
301 { +scratch+ { { f "r" } { f "s" } } }
302 { +output+ { "x" "s" } }
303 { +clobber+ { "y" } }
307 "x" operand dup %untag-fixnum
308 "x" get %allot-bignum-signed-1
310 { +input+ { { f "x" } } }
315 "nonzero" define-label
316 "positive" define-label
318 "x" operand dup %untag
319 "y" operand "x" operand cell LWZ
320 ! if the length is 1, its just the sign and nothing else,
322 0 "y" operand 1 v>operand CMPI
326 "nonzero" resolve-label
328 "y" operand "x" operand 3 cells LWZ
330 "x" operand "x" operand 2 cells LWZ
331 ! is the sign negative?
334 "y" operand dup -1 MULI
335 "positive" resolve-label
336 "y" operand dup %tag-fixnum
339 { +input+ { { f "x" } } }
340 { +scratch+ { { f "y" } } }
341 { +clobber+ { "x" } }
345 : define-float-op ( word op -- )
346 [ "z" operand "x" operand "y" operand ] swap suffix H{
347 { +input+ { { float "x" } { float "y" } } }
348 { +scratch+ { { float "z" } } }
358 first2 define-float-op
361 : define-float-jump ( word op -- )
362 [ "x" operand 0 "y" operand FCMPU ] swap suffix
363 { { float "x" } { float "y" } } define-if-intrinsic ;
372 first2 define-float-jump
376 "scratch" operand "in" operand FCTIWZ
377 "scratch" operand 1 0 param@ STFD
378 "out" operand 1 cell param@ LWZ
379 "out" operand dup %tag-fixnum
381 { +input+ { { float "in" } } }
382 { +scratch+ { { float "scratch" } { f "out" } } }
383 { +output+ { "out" } }
387 HEX: 4330 "scratch" operand LIS
388 "scratch" operand 1 0 param@ STW
389 "scratch" operand "in" operand %untag-fixnum
390 "scratch" operand dup HEX: 8000 XORIS
391 "scratch" operand 1 cell param@ STW
392 "f1" operand 1 0 param@ LFD
393 4503601774854144.0 "scratch" operand load-indirect
394 "f2" operand "scratch" operand float-offset LFD
395 "f1" operand "f1" operand "f2" operand FSUB
397 { +input+ { { f "in" } } }
398 { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
399 { +output+ { "f1" } }
404 "out" operand "in" operand tag-mask get ANDI
405 "out" operand dup %tag-fixnum
407 { +input+ { { f "in" } } }
408 { +scratch+ { { f "out" } } }
409 { +output+ { "out" } }
413 #! Load the userenv pointer in a register.
414 "userenv" f rot %load-dlsym ;
417 "n" operand dup 1 SRAWI
419 "x" operand "n" operand "x" operand ADD
420 "x" operand dup 0 LWZ
422 { +input+ { { f "n" } } }
423 { +scratch+ { { f "x" } } }
425 { +clobber+ { "n" } }
429 "n" operand dup 1 SRAWI
431 "x" operand "n" operand "x" operand ADD
432 "val" operand "x" operand 0 STW
434 { +input+ { { f "val" } { f "n" } } }
435 { +scratch+ { { f "x" } } }
436 { +clobber+ { "n" } }
440 tuple "layout" get size>> 2 + cells %allot
442 "layout" get 12 load-indirect
444 ! Store tagged ptr in reg
445 "tuple" get tuple %store-tagged
447 { +input+ { { [ ] "layout" } } }
448 { +scratch+ { { f "tuple" } } }
449 { +output+ { "tuple" } }
453 array "n" get 2 + cells %allot
457 ! Store tagged ptr in reg
458 "array" get object %store-tagged
460 { +input+ { { [ ] "n" } } }
461 { +scratch+ { { f "array" } } }
462 { +output+ { "array" } }
466 byte-array "n" get 2 cells + %allot
470 ! Store tagged ptr in reg
471 "array" get object %store-tagged
473 { +input+ { { [ ] "n" } } }
474 { +scratch+ { { f "array" } } }
475 { +output+ { "array" } }
480 "numerator" operand 11 1 cells STW
481 "denominator" operand 11 2 cells STW
482 ! Store tagged ptr in reg
483 "ratio" get ratio %store-tagged
485 { +input+ { { f "numerator" } { f "denominator" } } }
486 { +scratch+ { { f "ratio" } } }
487 { +output+ { "ratio" } }
491 complex 3 cells %allot
492 "real" operand 11 1 cells STW
493 "imaginary" operand 11 2 cells STW
494 ! Store tagged ptr in reg
495 "complex" get complex %store-tagged
497 { +input+ { { f "real" } { f "imaginary" } } }
498 { +scratch+ { { f "complex" } } }
499 { +output+ { "complex" } }
503 wrapper 2 cells %allot
504 "obj" operand 11 1 cells STW
505 ! Store tagged ptr in reg
506 "wrapper" get object %store-tagged
508 { +input+ { { f "obj" } } }
509 { +scratch+ { { f "wrapper" } } }
510 { +output+ { "wrapper" } }
514 : %alien-accessor ( quot -- )
515 "offset" operand dup %untag-fixnum
516 "offset" operand dup "alien" operand ADD
517 "value" operand "offset" operand 0 roll call ; inline
519 : alien-integer-get-template
522 { unboxed-c-ptr "alien" c-ptr }
523 { f "offset" fixnum }
525 { +scratch+ { { f "value" } } }
526 { +output+ { "value" } }
527 { +clobber+ { "offset" } }
530 : %alien-integer-get ( quot -- )
532 "value" operand dup %tag-fixnum ; inline
534 : alien-integer-set-template
538 { unboxed-c-ptr "alien" c-ptr }
539 { f "offset" fixnum }
541 { +clobber+ { "value" "offset" } }
544 : %alien-integer-set ( quot -- )
545 "offset" get "value" get = [
546 "value" operand dup %untag-fixnum
548 %alien-accessor ; inline
550 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
551 [ %alien-integer-set ] curry
552 alien-integer-set-template
554 [ %alien-integer-get ] curry
555 alien-integer-get-template
558 \ alien-unsigned-1 [ LBZ ]
559 \ set-alien-unsigned-1 [ STB ]
560 define-alien-integer-intrinsics
562 \ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
563 \ set-alien-signed-1 [ STB ]
564 define-alien-integer-intrinsics
566 \ alien-unsigned-2 [ LHZ ]
567 \ set-alien-unsigned-2 [ STH ]
568 define-alien-integer-intrinsics
570 \ alien-signed-2 [ LHA ]
571 \ set-alien-signed-2 [ STH ]
572 define-alien-integer-intrinsics
575 [ LWZ ] %alien-accessor
578 { unboxed-c-ptr "alien" c-ptr }
579 { f "offset" fixnum }
581 { +scratch+ { { unboxed-alien "value" } } }
582 { +output+ { "value" } }
583 { +clobber+ { "offset" } }
587 [ STW ] %alien-accessor
590 { unboxed-c-ptr "value" pinned-c-ptr }
591 { unboxed-c-ptr "alien" c-ptr }
592 { f "offset" fixnum }
594 { +clobber+ { "offset" } }
597 : alien-float-get-template
600 { unboxed-c-ptr "alien" c-ptr }
601 { f "offset" fixnum }
603 { +scratch+ { { float "value" } } }
604 { +output+ { "value" } }
605 { +clobber+ { "offset" } }
608 : alien-float-set-template
611 { float "value" float }
612 { unboxed-c-ptr "alien" c-ptr }
613 { f "offset" fixnum }
615 { +clobber+ { "offset" } }
618 : define-alien-float-intrinsics ( word get-quot word set-quot -- )
619 [ %alien-accessor ] curry
620 alien-float-set-template
622 [ %alien-accessor ] curry
623 alien-float-get-template
626 \ alien-double [ LFD ]
627 \ set-alien-double [ STFD ]
628 define-alien-float-intrinsics
630 \ alien-float [ LFS ]
631 \ set-alien-float [ STFS ]
632 define-alien-float-intrinsics