+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays cpu.architecture cpu.arm.assembler
-cpu.arm.architecture cpu.arm.allot kernel kernel.private math
-math.private namespaces sequences words
-quotations byte-arrays hashtables.private hashtables generator
-generator.registers generator.fixup sequences.private sbufs
-sbufs.private vectors vectors.private system
-classes.tuple.private layouts strings.private slots.private ;
-IN: cpu.arm.intrinsics
-
-: %slot-literal-known-tag
- "val" operand
- "obj" operand
- "n" get cells
- "obj" get operand-tag - <+/-> ;
-
-: %slot-literal-any-tag
- "scratch" operand "obj" operand %untag
- "val" operand "scratch" operand "n" get cells <+> ;
-
-: %slot-any
- "scratch" operand "obj" operand %untag
- "n" operand dup 1 <LSR> MOV
- "val" operand "scratch" operand "n" operand <+> ;
-
-\ slot {
- ! Slot number is literal and the tag is known
- {
- [ %slot-literal-known-tag LDR ] H{
- { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag LDR ] H{
- { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } { f "val" } } }
- { +output+ { "val" } }
- }
- }
- ! Slot number in a register
- {
- [ %slot-any LDR ] H{
- { +input+ { { f "obj" } { f "n" } } }
- { +scratch+ { { f "val" } { f "scratch" } } }
- { +output+ { "val" } }
- { +clobber+ { "n" } }
- }
- }
-} define-intrinsics
-
-: %write-barrier ( -- )
- "val" get operand-immediate? "obj" get fresh-object? or [
- "cards_offset" f R12 %alien-global
- "scratch" operand R12 "obj" operand card-bits <LSR> ADD
- "val" operand "scratch" operand 0 <+> LDRB
- "val" operand dup card-mark ORR
- "val" operand "scratch" operand 0 <+> STRB
- ] unless ;
-
-\ set-slot {
- ! Slot number is literal and tag is known
- {
- [ %slot-literal-known-tag STR %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" } }
- }
- }
- ! Slot number is literal
- {
- [ %slot-literal-any-tag STR %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" } }
- }
- }
- ! Slot number is in a register
- {
- [ %slot-any STR %write-barrier ] H{
- { +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" "n" } }
- }
- }
-} define-intrinsics
-
-: fixnum-op ( op -- quot )
- [ "out" operand "x" operand "y" operand ] swap add ;
-
-: fixnum-register-op ( op -- pair )
- fixnum-op H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: fixnum-value-op ( op -- pair )
- fixnum-op H{
- { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- } 2array ;
-
-: define-fixnum-op ( word op -- )
- [ fixnum-value-op ] keep fixnum-register-op 2array
- define-intrinsics ;
-
-{
- { fixnum+fast ADD }
- { fixnum-fast SUB }
- { fixnum-bitand AND }
- { fixnum-bitor ORR }
- { fixnum-bitxor EOR }
-} [
- first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
- "x" operand dup MVN
- "x" operand dup %untag
-] H{
- { +input+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ fixnum*fast [
- "out" operand "y" operand %untag-fixnum
- "out" operand "x" operand "out" operand MUL
-] H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ fixnum-shift [
- "out" operand "x" operand "y" get neg <ASR> MOV
- ! Mask off low bits
- "out" operand dup %untag
-] H{
- { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-: %untag-fixnums ( seq -- )
- [ dup %untag-fixnum ] unique-operands ;
-
-: overflow-check ( insn -- )
- [
- "end" define-label
- [ "out" operand "x" operand "y" operand roll S execute ] keep
- "end" get VC B
- { "x" "y" } %untag-fixnums
- "x" operand "x" operand "y" operand roll execute
- "out" get "x" get %allot-bignum-signed-1
- "end" resolve-label
- ] with-scope ; inline
-
-: overflow-template ( word insn -- )
- [ overflow-check ] curry H{
- { +input+ { { f "x" } { f "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
- { +clobber+ { "x" "y" } }
- } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-\ fixnum>bignum [
- "x" operand dup %untag-fixnum
- "out" get "x" get %allot-bignum-signed-1
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "out" } } }
- { +clobber+ { "x" } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ bignum>fixnum [
- "end" define-label
- "x" operand dup %untag
- "y" operand "x" operand cell <+> LDR
- ! if the length is 1, its just the sign and nothing else,
- ! so output 0
- "y" operand 1 v>operand CMP
- "y" operand 0 EQ MOV
- "end" get EQ B
- ! load the value
- "y" operand "x" operand 3 cells <+> LDR
- ! load the sign
- "x" operand "x" operand 2 cells <+> LDR
- ! is the sign negative?
- "x" operand 0 CMP
- ! Negate the value
- "y" operand "y" operand 0 NE RSB
- "y" operand dup %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "x" } } }
- { +scratch+ { { f "y" } } }
- { +clobber+ { "x" } }
- { +output+ { "y" } }
-} define-intrinsic
-
-: fixnum-jump ( op -- quo )
- [ "x" operand "y" operand CMP ] swap
- 1quotation [ B ] 3append ;
-
-: fixnum-register-jump ( op -- pair )
- fixnum-jump { { f "x" } { f "y" } } 2array ;
-
-: fixnum-value-jump ( op -- pair )
- fixnum-jump { { f "x" } { [ small-tagged? ] "y" } } 2array ;
-
-: define-fixnum-jump ( word op -- )
- [ fixnum-value-jump ] keep fixnum-register-jump
- 2array define-if-intrinsics ;
-
-{
- { fixnum< LT }
- { fixnum<= LE }
- { fixnum> GT }
- { fixnum>= GE }
- { eq? EQ }
-} [
- first2 define-fixnum-jump
-] each
-
-\ tag [
- "out" operand "in" operand tag-mask get AND
- "out" operand dup %tag-fixnum
-] H{
- { +input+ { { f "in" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ type [
- ! Get the tag
- "out" operand "obj" operand tag-mask get AND
- ! Compare with object tag number (3).
- "out" operand object tag-number CMP
- ! Tag the tag if it is not equal to 3
- "out" operand dup NE %tag-fixnum
- ! Load the object header if tag is equal to 3
- "out" operand "obj" operand object tag-number <-> EQ LDR
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- ! Get the tag
- "out" operand "obj" operand tag-mask get AND
- ! Compare with tuple tag number (2).
- "out" operand tuple tag-number CMP
- "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
- "out" operand dup class-hash-offset <+/-> EQ LDR
- "end" get EQ B
- ! Compare with object tag number (3).
- "out" operand object tag-number CMP
- "out" operand "obj" operand object tag-number <-> EQ LDR
- ! Tag the tag
- "out" operand dup NE %tag-fixnum
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-: userenv ( reg -- )
- ! Load the userenv pointer in a register.
- "userenv" f rot compile-dlsym ;
-
-\ getenv [
- "n" operand dup 1 <ASR> MOV
- "x" operand userenv
- "x" operand "x" operand "n" operand <+> LDR
-] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-\ setenv [
- "n" operand dup 1 <ASR> MOV
- "x" operand userenv
- "val" operand "x" operand "n" operand <+> STR
-] H{
- { +input+ { { f "val" } { f "n" } } }
- { +scratch+ { { f "x" } } }
- { +clobber+ { "n" } }
-} define-intrinsic
-
-: %set-slot R11 swap cells <+> STR ;
-
-: %store-length
- R12 "n" operand MOV
- R12 1 %set-slot ;
-
-: %fill-array swap 2 + %set-slot ;
-
-\ <tuple> [
- tuple "n" get 2 + cells %allot
- %store-length
- ! Store class
- "class" operand 2 %set-slot
- ! Zero out the rest of the tuple
- "initial" operand f v>operand MOV
- "n" get 1- [ 1+ "initial" operand %fill-array ] each
- "out" get tuple %store-tagged
-] H{
- { +input+ { { f "class" } { [ inline-array? ] "n" } } }
- { +scratch+ { { f "out" } { f "initial" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <array> [
- array "n" get 2 + cells %allot
- %store-length
- ! Store initial element
- "n" get [ "initial" operand %fill-array ] each
- "out" get object %store-tagged
-] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <byte-array> [
- byte-array "n" get 2 cells + %allot
- %store-length
- ! Store initial element
- R12 0 MOV
- "n" get cell align cell /i [ R12 %fill-array ] each
- "out" get object %store-tagged
-] H{
- { +input+ { { [ inline-array? ] "n" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <ratio> [
- ratio 3 cells %allot
- "numerator" operand 1 %set-slot
- "denominator" operand 2 %set-slot
- "out" get ratio %store-tagged
-] H{
- { +input+ { { f "numerator" } { f "denominator" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <complex> [
- complex 3 cells %allot
- "real" operand 1 %set-slot
- "imaginary" operand 2 %set-slot
- ! Store tagged ptr in reg
- "out" get complex %store-tagged
-] H{
- { +input+ { { f "real" } { f "imaginary" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-\ <wrapper> [
- wrapper 2 cells %allot
- "obj" operand 1 %set-slot
- ! Store tagged ptr in reg
- "out" get object %store-tagged
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
- "offset" operand dup %untag-fixnum
- "offset" operand dup "alien" operand ADD
- "value" operand "offset" operand 0 <+> roll call ; inline
-
-: alien-integer-get-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { f "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-: %alien-integer-get ( quot -- )
- %alien-accessor
- "value" operand dup %tag-fixnum ; inline
-
-: alien-integer-set-template
- H{
- { +input+ {
- { f "value" fixnum }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +clobber+ { "value" "offset" } }
- } ;
-
-: %alien-integer-set ( quot -- )
- "offset" get "value" get = [
- "value" operand dup %untag-fixnum
- ] unless
- %alien-accessor ; inline
-
-: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
- [ %alien-integer-set ] curry
- alien-integer-set-template
- define-intrinsic
- [ %alien-integer-get ] curry
- alien-integer-get-template
- define-intrinsic ;
-
-\ alien-unsigned-1 [ LDRB ]
-\ set-alien-unsigned-1 [ STRB ]
-define-alien-integer-intrinsics
-
-: alien-cell-template
- H{
- { +input+ {
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +scratch+ { { unboxed-alien "value" } } }
- { +output+ { "value" } }
- { +clobber+ { "offset" } }
- } ;
-
-\ alien-cell
-[ [ LDR ] %alien-accessor ]
-alien-cell-template define-intrinsic
-
-: set-alien-cell-template
- H{
- { +input+ {
- { unboxed-c-ptr "value" pinned-c-ptr }
- { unboxed-c-ptr "alien" c-ptr }
- { f "offset" fixnum }
- } }
- { +clobber+ { "offset" } }
- } ;
-
-\ set-alien-cell
-[ [ STR ] %alien-accessor ]
-set-alien-cell-template define-intrinsic
projects / factor-unmaintained.git / blobdiff