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
8 sequences.private sbufs vectors system layouts
9 math.floats.private classes slots.private
14 compiler.generator.fixup
15 compiler.generator.registers ;
16 IN: cpu.ppc.intrinsics
18 : %slot-literal-known-tag ( -- out value offset )
22 "obj" get operand-tag - ;
24 : %slot-literal-any-tag ( -- out value offset )
25 "obj" operand "scratch1" operand %untag
26 "val" operand "scratch1" operand "n" get cells ;
28 : %slot-any ( -- out value offset )
29 "obj" operand "scratch1" operand %untag
30 "offset" operand "n" operand 1 SRAWI
31 "scratch1" operand "val" operand "offset" operand ;
34 ! Slot number is literal and the tag is known
36 [ %slot-literal-known-tag LWZ ] H{
37 { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
38 { +scratch+ { { f "val" } } }
39 { +output+ { "val" } }
42 ! Slot number is literal
44 [ %slot-literal-any-tag LWZ ] H{
45 { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
46 { +scratch+ { { f "scratch1" } { f "val" } } }
47 { +output+ { "val" } }
50 ! Slot number in a register
53 { +input+ { { f "obj" } { f "n" } } }
54 { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
55 { +output+ { "val" } }
60 : load-cards-offset ( dest -- )
61 "cards_offset" f pick %load-dlsym dup 0 LWZ ;
63 : load-decks-offset ( dest -- )
64 "decks_offset" f pick %load-dlsym dup 0 LWZ ;
66 : %write-barrier ( -- )
67 "val" get operand-immediate? "obj" get fresh-object? or [
68 card-mark "scratch1" operand LI
71 "val" operand load-cards-offset
72 "obj" operand "scratch2" operand card-bits SRWI
73 "scratch2" operand "scratch1" operand "val" operand STBX
76 "val" operand load-decks-offset
77 "obj" operand "scratch2" operand deck-bits SRWI
78 "scratch2" operand "scratch1" operand "val" operand STBX
82 ! Slot number is literal and tag is known
84 [ %slot-literal-known-tag STW %write-barrier ] H{
85 { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
86 { +scratch+ { { f "scratch1" } { f "scratch2" } } }
87 { +clobber+ { "val" } }
90 ! Slot number is literal
92 [ %slot-literal-any-tag STW %write-barrier ] H{
93 { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
94 { +scratch+ { { f "scratch1" } { f "scratch2" } } }
95 { +clobber+ { "val" } }
98 ! Slot number is in a register
100 [ %slot-any STWX %write-barrier ] H{
101 { +input+ { { f "val" } { f "obj" } { f "n" } } }
102 { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
103 { +clobber+ { "val" } }
108 : fixnum-register-op ( op -- pair )
109 [ "out" operand "y" operand "x" operand ] swap suffix H{
110 { +input+ { { f "x" } { f "y" } } }
111 { +scratch+ { { f "out" } } }
112 { +output+ { "out" } }
115 : fixnum-value-op ( op -- pair )
116 [ "out" operand "x" operand "y" operand ] swap suffix H{
117 { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
118 { +scratch+ { { f "out" } } }
119 { +output+ { "out" } }
122 : define-fixnum-op ( word imm-op reg-op -- )
123 >r fixnum-value-op r> fixnum-register-op 2array
127 { fixnum+fast ADDI ADD }
128 { fixnum-fast SUBI SUBF }
129 { fixnum-bitand ANDI AND }
130 { fixnum-bitor ORI OR }
131 { fixnum-bitxor XORI XOR }
133 first3 define-fixnum-op
139 "out" operand "x" operand "y" get MULLI
141 { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
142 { +scratch+ { { f "out" } } }
143 { +output+ { "out" } }
147 "out" operand "x" operand %untag-fixnum
148 "out" operand "y" operand "out" operand MULLW
150 { +input+ { { f "x" } { f "y" } } }
151 { +scratch+ { { f "out" } } }
152 { +output+ { "out" } }
157 : %untag-fixnums ( seq -- )
158 [ dup %untag-fixnum ] unique-operands ;
160 \ fixnum-shift-fast {
163 "out" operand "x" operand "y" get
164 dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
166 "out" operand dup %untag
168 { +input+ { { f "x" } { [ ] "y" } } }
169 { +scratch+ { { f "out" } } }
170 { +output+ { "out" } }
175 { "positive" "end" } [ define-label ] each
176 "out" operand "y" operand %untag-fixnum
179 "out" operand dup NEG
180 "out" operand "x" operand "out" operand SRAW
182 "positive" resolve-label
183 "out" operand "x" operand "out" operand SLW
186 "out" operand dup %untag
188 { +input+ { { f "x" } { f "y" } } }
189 { +scratch+ { { f "out" } } }
190 { +output+ { "out" } }
195 : generate-fixnum-mod ( -- )
196 #! PowerPC doesn't have a MOD instruction; so we compute
197 #! x-(x/y)*y. Puts the result in "s" operand.
198 "s" operand "r" operand "y" operand MULLW
199 "s" operand "s" operand "x" operand SUBF ;
202 ! divide x by y, store result in x
203 "r" operand "x" operand "y" operand DIVW
206 { +input+ { { f "x" } { f "y" } } }
207 { +scratch+ { { f "r" } { f "s" } } }
213 "x" operand dup %untag
215 { +input+ { { f "x" } } }
219 : fixnum-register-jump ( op -- pair )
220 [ "x" operand 0 "y" operand CMP ] swap suffix
221 { { f "x" } { f "y" } } 2array ;
223 : fixnum-value-jump ( op -- pair )
224 [ 0 "x" operand "y" operand CMPI ] swap suffix
225 { { f "x" } { [ small-tagged? ] "y" } } 2array ;
227 : define-fixnum-jump ( word op -- )
228 [ fixnum-value-jump ] keep fixnum-register-jump
229 2array define-if-intrinsics ;
238 first2 define-fixnum-jump
241 : overflow-check ( insn1 insn2 -- )
245 "r" operand "y" operand "x" operand r> execute
249 { "x" "y" } %untag-fixnums
250 "r" operand "y" operand "x" operand r> execute
251 "r" get %allot-bignum-signed-1
253 ] with-scope ; inline
255 : overflow-template ( word insn1 insn2 -- )
256 [ overflow-check ] 2curry H{
257 { +input+ { { f "x" } { f "y" } } }
258 { +scratch+ { { f "r" } } }
260 { +clobber+ { "x" "y" } }
263 \ fixnum+ \ ADD \ ADDO. overflow-template
264 \ fixnum- \ SUBF \ SUBFO. overflow-template
266 : generate-fixnum/i ( -- )
267 #! This VOP is funny. If there is an overflow, it falls
268 #! through to the end, and the result is in "x" operand.
269 #! Otherwise it jumps to the "no-overflow" label and the
270 #! result is in "r" operand.
272 "no-overflow" define-label
273 "r" operand "x" operand "y" operand DIVW
274 ! if the result is greater than the most positive fixnum,
275 ! which can only ever happen if we do
276 ! most-negative-fixnum -1 /i, then the result is a bignum.
277 most-positive-fixnum "s" operand LOAD
278 "r" operand 0 "s" operand CMP
279 "no-overflow" get BLE
280 most-negative-fixnum neg "x" operand LOAD
281 "x" get %allot-bignum-signed-1 ;
286 "no-overflow" resolve-label
287 "r" operand "x" operand %tag-fixnum
290 { +input+ { { f "x" } { f "y" } } }
291 { +scratch+ { { f "r" } { f "s" } } }
293 { +clobber+ { "y" } }
300 "no-overflow" resolve-label
302 "r" operand "x" operand %tag-fixnum
305 { +input+ { { f "x" } { f "y" } } }
306 { +scratch+ { { f "r" } { f "s" } } }
307 { +output+ { "x" "s" } }
308 { +clobber+ { "y" } }
312 "x" operand dup %untag-fixnum
313 "x" get %allot-bignum-signed-1
315 { +input+ { { f "x" } } }
320 "nonzero" define-label
321 "positive" define-label
323 "x" operand dup %untag
324 "y" operand "x" operand cell LWZ
325 ! if the length is 1, its just the sign and nothing else,
327 0 "y" operand 1 v>operand CMPI
331 "nonzero" resolve-label
333 "y" operand "x" operand 3 cells LWZ
335 "x" operand "x" operand 2 cells LWZ
336 ! is the sign negative?
339 "y" operand dup -1 MULI
340 "positive" resolve-label
341 "y" operand dup %tag-fixnum
344 { +input+ { { f "x" } } }
345 { +scratch+ { { f "y" } } }
346 { +clobber+ { "x" } }
350 : define-float-op ( word op -- )
351 [ "z" operand "x" operand "y" operand ] swap suffix H{
352 { +input+ { { float "x" } { float "y" } } }
353 { +scratch+ { { float "z" } } }
363 first2 define-float-op
366 : define-float-jump ( word op -- )
367 [ "x" operand 0 "y" operand FCMPU ] swap suffix
368 { { float "x" } { float "y" } } define-if-intrinsic ;
377 first2 define-float-jump
381 "scratch" operand "in" operand FCTIWZ
382 "scratch" operand 1 0 param@ STFD
383 "out" operand 1 cell param@ LWZ
384 "out" operand dup %tag-fixnum
386 { +input+ { { float "in" } } }
387 { +scratch+ { { float "scratch" } { f "out" } } }
388 { +output+ { "out" } }
392 HEX: 4330 "scratch" operand LIS
393 "scratch" operand 1 0 param@ STW
394 "scratch" operand "in" operand %untag-fixnum
395 "scratch" operand dup HEX: 8000 XORIS
396 "scratch" operand 1 cell param@ STW
397 "f1" operand 1 0 param@ LFD
398 4503601774854144.0 "scratch" operand load-indirect
399 "f2" operand "scratch" operand float-offset LFD
400 "f1" operand "f1" operand "f2" operand FSUB
402 { +input+ { { f "in" } } }
403 { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
404 { +output+ { "f1" } }
409 "out" operand "in" operand tag-mask get ANDI
410 "out" operand dup %tag-fixnum
412 { +input+ { { f "in" } } }
413 { +scratch+ { { f "out" } } }
414 { +output+ { "out" } }
418 #! Load the userenv pointer in a register.
419 "userenv" f rot %load-dlsym ;
422 "n" operand dup 1 SRAWI
424 "x" operand "n" operand "x" operand ADD
425 "x" operand dup 0 LWZ
427 { +input+ { { f "n" } } }
428 { +scratch+ { { f "x" } } }
430 { +clobber+ { "n" } }
434 "n" operand dup 1 SRAWI
436 "x" operand "n" operand "x" operand ADD
437 "val" operand "x" operand 0 STW
439 { +input+ { { f "val" } { f "n" } } }
440 { +scratch+ { { f "x" } } }
441 { +clobber+ { "n" } }
445 tuple "layout" get size>> 2 + cells %allot
447 "layout" get 12 load-indirect
449 ! Store tagged ptr in reg
450 "tuple" get tuple %store-tagged
452 { +input+ { { [ ] "layout" } } }
453 { +scratch+ { { f "tuple" } } }
454 { +output+ { "tuple" } }
458 array "n" get 2 + cells %allot
462 ! Store tagged ptr in reg
463 "array" get object %store-tagged
465 { +input+ { { [ ] "n" } } }
466 { +scratch+ { { f "array" } } }
467 { +output+ { "array" } }
471 byte-array "n" get 2 cells + %allot
475 ! Store tagged ptr in reg
476 "array" get object %store-tagged
478 { +input+ { { [ ] "n" } } }
479 { +scratch+ { { f "array" } } }
480 { +output+ { "array" } }
485 "numerator" operand 11 1 cells STW
486 "denominator" operand 11 2 cells STW
487 ! Store tagged ptr in reg
488 "ratio" get ratio %store-tagged
490 { +input+ { { f "numerator" } { f "denominator" } } }
491 { +scratch+ { { f "ratio" } } }
492 { +output+ { "ratio" } }
496 complex 3 cells %allot
497 "real" operand 11 1 cells STW
498 "imaginary" operand 11 2 cells STW
499 ! Store tagged ptr in reg
500 "complex" get complex %store-tagged
502 { +input+ { { f "real" } { f "imaginary" } } }
503 { +scratch+ { { f "complex" } } }
504 { +output+ { "complex" } }
508 wrapper 2 cells %allot
509 "obj" operand 11 1 cells STW
510 ! Store tagged ptr in reg
511 "wrapper" get object %store-tagged
513 { +input+ { { f "obj" } } }
514 { +scratch+ { { f "wrapper" } } }
515 { +output+ { "wrapper" } }
519 : %alien-accessor ( quot -- )
520 "offset" operand dup %untag-fixnum
521 "scratch" operand "offset" operand "alien" operand ADD
522 "value" operand "scratch" operand 0 roll call ; inline
524 : alien-integer-get-template
527 { unboxed-c-ptr "alien" c-ptr }
528 { f "offset" fixnum }
530 { +scratch+ { { f "value" } { f "scratch" } } }
531 { +output+ { "value" } }
532 { +clobber+ { "offset" } }
535 : %alien-integer-get ( quot -- )
537 "value" operand dup %tag-fixnum ; inline
539 : alien-integer-set-template
543 { unboxed-c-ptr "alien" c-ptr }
544 { f "offset" fixnum }
546 { +scratch+ { { f "scratch" } } }
547 { +clobber+ { "value" "offset" } }
550 : %alien-integer-set ( quot -- )
551 "offset" get "value" get = [
552 "value" operand dup %untag-fixnum
554 %alien-accessor ; inline
556 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
557 [ %alien-integer-set ] curry
558 alien-integer-set-template
560 [ %alien-integer-get ] curry
561 alien-integer-get-template
564 \ alien-unsigned-1 [ LBZ ]
565 \ set-alien-unsigned-1 [ STB ]
566 define-alien-integer-intrinsics
568 \ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
569 \ set-alien-signed-1 [ STB ]
570 define-alien-integer-intrinsics
572 \ alien-unsigned-2 [ LHZ ]
573 \ set-alien-unsigned-2 [ STH ]
574 define-alien-integer-intrinsics
576 \ alien-signed-2 [ LHA ]
577 \ set-alien-signed-2 [ STH ]
578 define-alien-integer-intrinsics
581 [ LWZ ] %alien-accessor
584 { unboxed-c-ptr "alien" c-ptr }
585 { f "offset" fixnum }
587 { +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
588 { +output+ { "value" } }
589 { +clobber+ { "offset" } }
593 [ STW ] %alien-accessor
596 { unboxed-c-ptr "value" pinned-c-ptr }
597 { unboxed-c-ptr "alien" c-ptr }
598 { f "offset" fixnum }
600 { +scratch+ { { f "scratch" } } }
601 { +clobber+ { "offset" } }
604 : alien-float-get-template
607 { unboxed-c-ptr "alien" c-ptr }
608 { f "offset" fixnum }
610 { +scratch+ { { float "value" } { f "scratch" } } }
611 { +output+ { "value" } }
612 { +clobber+ { "offset" } }
615 : alien-float-set-template
618 { float "value" float }
619 { unboxed-c-ptr "alien" c-ptr }
620 { f "offset" fixnum }
622 { +scratch+ { { f "scratch" } } }
623 { +clobber+ { "offset" } }
626 : define-alien-float-intrinsics ( word get-quot word set-quot -- )
627 [ %alien-accessor ] curry
628 alien-float-set-template
630 [ %alien-accessor ] curry
631 alien-float-get-template
634 \ alien-double [ LFD ]
635 \ set-alien-double [ STFD ]
636 define-alien-float-intrinsics
638 \ alien-float [ LFS ]
639 \ set-alien-float [ STFS ]
640 define-alien-float-intrinsics