Add string-nth intrinsic
parent
9160e667a7
commit
53cd75b06c
|
@ -89,14 +89,24 @@ nl
|
||||||
. malloc calloc free memcpy
|
. malloc calloc free memcpy
|
||||||
} compile-uncompiled
|
} compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
{ build-tree } compile-uncompiled
|
{ build-tree } compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
{ optimize-tree } compile-uncompiled
|
{ optimize-tree } compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
{ optimize-cfg } compile-uncompiled
|
{ optimize-cfg } compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
{ (compile) } compile-uncompiled
|
{ (compile) } compile-uncompiled
|
||||||
|
|
||||||
|
"." write flush
|
||||||
|
|
||||||
vocabs [ words compile-uncompiled "." write flush ] each
|
vocabs [ words compile-uncompiled "." write flush ] each
|
||||||
|
|
||||||
" done" print flush
|
" done" print flush
|
||||||
|
|
|
@ -14,6 +14,7 @@ M: ##allot defs-vregs dst/tmp-vregs ;
|
||||||
M: ##dispatch defs-vregs temp>> 1array ;
|
M: ##dispatch defs-vregs temp>> 1array ;
|
||||||
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
||||||
M: ##set-slot defs-vregs temp>> 1array ;
|
M: ##set-slot defs-vregs temp>> 1array ;
|
||||||
|
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
||||||
M: insn defs-vregs drop f ;
|
M: insn defs-vregs drop f ;
|
||||||
|
|
||||||
M: ##unary uses-vregs src>> 1array ;
|
M: ##unary uses-vregs src>> 1array ;
|
||||||
|
@ -24,6 +25,7 @@ M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
|
||||||
M: ##slot-imm uses-vregs obj>> 1array ;
|
M: ##slot-imm uses-vregs obj>> 1array ;
|
||||||
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
|
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
|
||||||
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
|
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
|
||||||
|
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
|
||||||
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||||
M: ##compare-imm-branch uses-vregs src1>> 1array ;
|
M: ##compare-imm-branch uses-vregs src1>> 1array ;
|
||||||
M: ##dispatch uses-vregs src>> 1array ;
|
M: ##dispatch uses-vregs src>> 1array ;
|
||||||
|
|
|
@ -22,6 +22,7 @@ IN: compiler.cfg.hats
|
||||||
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
|
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
|
||||||
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
|
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
|
||||||
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
|
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
|
||||||
|
: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
|
||||||
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
|
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
|
||||||
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
|
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
|
||||||
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
|
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
|
||||||
|
|
|
@ -71,6 +71,9 @@ INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
|
||||||
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
|
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
|
||||||
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
|
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
|
||||||
|
|
||||||
|
! String element access
|
||||||
|
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
|
||||||
|
|
||||||
! Integer arithmetic
|
! Integer arithmetic
|
||||||
INSN: ##add < ##commutative ;
|
INSN: ##add < ##commutative ;
|
||||||
INSN: ##add-imm < ##commutative-imm ;
|
INSN: ##add-imm < ##commutative-imm ;
|
||||||
|
|
|
@ -14,6 +14,7 @@ QUALIFIED: arrays
|
||||||
QUALIFIED: byte-arrays
|
QUALIFIED: byte-arrays
|
||||||
QUALIFIED: kernel.private
|
QUALIFIED: kernel.private
|
||||||
QUALIFIED: slots.private
|
QUALIFIED: slots.private
|
||||||
|
QUALIFIED: strings.private
|
||||||
QUALIFIED: classes.tuple.private
|
QUALIFIED: classes.tuple.private
|
||||||
QUALIFIED: math.private
|
QUALIFIED: math.private
|
||||||
QUALIFIED: alien.accessors
|
QUALIFIED: alien.accessors
|
||||||
|
@ -38,6 +39,7 @@ IN: compiler.cfg.intrinsics
|
||||||
kernel:eq?
|
kernel:eq?
|
||||||
slots.private:slot
|
slots.private:slot
|
||||||
slots.private:set-slot
|
slots.private:set-slot
|
||||||
|
strings.private:string-nth
|
||||||
classes.tuple.private:<tuple-boa>
|
classes.tuple.private:<tuple-boa>
|
||||||
arrays:<array>
|
arrays:<array>
|
||||||
byte-arrays:<byte-array>
|
byte-arrays:<byte-array>
|
||||||
|
@ -114,6 +116,7 @@ IN: compiler.cfg.intrinsics
|
||||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||||
{ \ slots.private:slot [ emit-slot ] }
|
{ \ slots.private:slot [ emit-slot ] }
|
||||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||||
|
{ \ strings.private:string-nth [ drop emit-string-nth ] }
|
||||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||||
{ \ arrays:<array> [ emit-<array> ] }
|
{ \ arrays:<array> [ emit-<array> ] }
|
||||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||||
|
|
|
@ -51,3 +51,6 @@ IN: compiler.cfg.intrinsics.slots
|
||||||
] [ first class>> immediate class<= ] bi
|
] [ first class>> immediate class<= ] bi
|
||||||
[ drop ] [ i i ##write-barrier ] if
|
[ drop ] [ i i ##write-barrier ] if
|
||||||
] [ drop emit-primitive ] if ;
|
] [ drop emit-primitive ] if ;
|
||||||
|
|
||||||
|
: emit-string-nth ( -- )
|
||||||
|
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
|
||||||
|
|
|
@ -36,6 +36,10 @@ M: ##set-slot propagate
|
||||||
[ resolve ] change-obj
|
[ resolve ] change-obj
|
||||||
[ resolve ] change-slot ;
|
[ resolve ] change-slot ;
|
||||||
|
|
||||||
|
M: ##string-nth propagate
|
||||||
|
[ resolve ] change-obj
|
||||||
|
[ resolve ] change-index ;
|
||||||
|
|
||||||
M: ##set-slot-imm propagate
|
M: ##set-slot-imm propagate
|
||||||
call-next-method
|
call-next-method
|
||||||
[ resolve ] change-obj ;
|
[ resolve ] change-obj ;
|
||||||
|
|
|
@ -123,6 +123,14 @@ M: ##set-slot generate-insn
|
||||||
M: ##set-slot-imm generate-insn
|
M: ##set-slot-imm generate-insn
|
||||||
>set-slot< %set-slot-imm ;
|
>set-slot< %set-slot-imm ;
|
||||||
|
|
||||||
|
M: ##string-nth generate-insn
|
||||||
|
{
|
||||||
|
[ dst>> register ]
|
||||||
|
[ obj>> register ]
|
||||||
|
[ index>> register ]
|
||||||
|
[ temp>> register ]
|
||||||
|
} cleave %string-nth ;
|
||||||
|
|
||||||
: dst/src ( insn -- dst src )
|
: dst/src ( insn -- dst src )
|
||||||
[ dst>> register ] [ src>> register ] bi ; inline
|
[ dst>> register ] [ src>> register ] bi ; inline
|
||||||
|
|
||||||
|
|
|
@ -58,6 +58,8 @@ HOOK: %slot-imm cpu ( dst obj slot tag -- )
|
||||||
HOOK: %set-slot cpu ( src obj slot tag temp -- )
|
HOOK: %set-slot cpu ( src obj slot tag temp -- )
|
||||||
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
|
HOOK: %set-slot-imm cpu ( src obj slot tag -- )
|
||||||
|
|
||||||
|
HOOK: %string-nth cpu ( dst obj index temp -- )
|
||||||
|
|
||||||
HOOK: %add cpu ( dst src1 src2 -- )
|
HOOK: %add cpu ( dst src1 src2 -- )
|
||||||
HOOK: %add-imm cpu ( dst src1 src2 -- )
|
HOOK: %add-imm cpu ( dst src1 src2 -- )
|
||||||
HOOK: %sub cpu ( dst src1 src2 -- )
|
HOOK: %sub cpu ( dst src1 src2 -- )
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs alien alien.c-types arrays
|
USING: accessors assocs alien alien.c-types arrays strings
|
||||||
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
|
||||||
kernel kernel.private math memory namespaces make sequences
|
kernel kernel.private math memory namespaces make sequences
|
||||||
words system layouts combinators math.order fry locals
|
words system layouts combinators math.order fry locals
|
||||||
|
@ -278,27 +278,49 @@ M:: x86 %box-alien ( dst src temp -- )
|
||||||
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
|
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
|
||||||
|
|
||||||
: small-reg-that-isn't ( exclude -- reg' )
|
: small-reg-that-isn't ( exclude -- reg' )
|
||||||
small-reg-4 small-regs [ eq? not ] with find nip ;
|
small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
|
||||||
|
|
||||||
: with-save/restore ( reg quot -- )
|
: with-save/restore ( reg quot -- )
|
||||||
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
|
||||||
|
|
||||||
:: with-small-register ( dst src quot: ( dst src -- ) -- )
|
:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
|
||||||
#! If the destination register overlaps a small register, we
|
#! If the destination register overlaps a small register, we
|
||||||
#! call the quot with that. Otherwise, we find a small
|
#! call the quot with that. Otherwise, we find a small
|
||||||
#! register that is not equal to src, and call quot, saving
|
#! register that is not in exclude, and call quot, saving
|
||||||
#! and restoring the small register.
|
#! and restoring the small register.
|
||||||
dst small-reg-4 small-regs memq? [ dst src quot call ] [
|
dst small-reg-4 small-regs memq? [ dst quot call ] [
|
||||||
src small-reg-that-isn't
|
exclude small-reg-that-isn't
|
||||||
[| new-dst |
|
[ quot call ] with-save/restore
|
||||||
new-dst src quot call
|
|
||||||
dst new-dst MOV
|
|
||||||
] with-save/restore
|
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: %alien-integer-getter ( dst src size quot -- )
|
: aux-offset 2 cells string tag-number - ; inline
|
||||||
'[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
|
|
||||||
with-small-register ; inline
|
M:: x86 %string-nth ( dst src index temp -- )
|
||||||
|
"end" define-label
|
||||||
|
dst { src index temp } [| new-dst |
|
||||||
|
temp src index [+] LEA
|
||||||
|
new-dst 1 small-reg temp string-offset [+] MOV
|
||||||
|
new-dst new-dst 1 small-reg MOVZX
|
||||||
|
temp src aux-offset [+] MOV
|
||||||
|
temp \ f tag-number CMP
|
||||||
|
"end" get JE
|
||||||
|
new-dst temp XCHG
|
||||||
|
new-dst index ADD
|
||||||
|
new-dst index ADD
|
||||||
|
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
|
||||||
|
new-dst new-dst 2 small-reg MOVZX
|
||||||
|
new-dst 8 SHL
|
||||||
|
new-dst temp OR
|
||||||
|
"end" resolve-label
|
||||||
|
dst new-dst ?MOV
|
||||||
|
] with-small-register ;
|
||||||
|
|
||||||
|
:: %alien-integer-getter ( dst src size quot -- )
|
||||||
|
dst { src } [| new-dst |
|
||||||
|
new-dst dup size small-reg dup src [] MOV
|
||||||
|
quot call
|
||||||
|
dst new-dst ?MOV
|
||||||
|
] with-small-register ; inline
|
||||||
|
|
||||||
: %alien-unsigned-getter ( dst src size -- )
|
: %alien-unsigned-getter ( dst src size -- )
|
||||||
[ MOVZX ] %alien-integer-getter ; inline
|
[ MOVZX ] %alien-integer-getter ; inline
|
||||||
|
@ -320,7 +342,7 @@ M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
|
||||||
M: x86 %alien-double [] MOVSD ;
|
M: x86 %alien-double [] MOVSD ;
|
||||||
|
|
||||||
:: %alien-integer-setter ( ptr value size -- )
|
:: %alien-integer-setter ( ptr value size -- )
|
||||||
value ptr [| new-value ptr |
|
value { ptr } [| new-value |
|
||||||
new-value value ?MOV
|
new-value value ?MOV
|
||||||
ptr [] new-value size small-reg MOV
|
ptr [] new-value size small-reg MOV
|
||||||
] with-small-register ; inline
|
] with-small-register ; inline
|
||||||
|
|
Loading…
Reference in New Issue