Add string-nth intrinsic
parent
9160e667a7
commit
53cd75b06c
|
@ -89,14 +89,24 @@ nl
|
|||
. malloc calloc free memcpy
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{ build-tree } compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{ optimize-tree } compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{ optimize-cfg } compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
{ (compile) } compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
||||
vocabs [ words compile-uncompiled "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
|
|
|
@ -14,6 +14,7 @@ M: ##allot defs-vregs dst/tmp-vregs ;
|
|||
M: ##dispatch defs-vregs temp>> 1array ;
|
||||
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
||||
M: ##set-slot defs-vregs temp>> 1array ;
|
||||
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
|
||||
M: insn defs-vregs drop f ;
|
||||
|
||||
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: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
|
||||
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: ##compare-imm-branch uses-vregs src1>> 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-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; 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-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; 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-imm < ##write { obj vreg } { slot integer } { tag integer } ;
|
||||
|
||||
! String element access
|
||||
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
|
||||
|
||||
! Integer arithmetic
|
||||
INSN: ##add < ##commutative ;
|
||||
INSN: ##add-imm < ##commutative-imm ;
|
||||
|
|
|
@ -14,6 +14,7 @@ QUALIFIED: arrays
|
|||
QUALIFIED: byte-arrays
|
||||
QUALIFIED: kernel.private
|
||||
QUALIFIED: slots.private
|
||||
QUALIFIED: strings.private
|
||||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: alien.accessors
|
||||
|
@ -38,6 +39,7 @@ IN: compiler.cfg.intrinsics
|
|||
kernel:eq?
|
||||
slots.private:slot
|
||||
slots.private:set-slot
|
||||
strings.private:string-nth
|
||||
classes.tuple.private:<tuple-boa>
|
||||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
|
@ -114,6 +116,7 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ \ arrays:<array> [ emit-<array> ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||
|
|
|
@ -51,3 +51,6 @@ IN: compiler.cfg.intrinsics.slots
|
|||
] [ first class>> immediate class<= ] bi
|
||||
[ drop ] [ i i ##write-barrier ] 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-slot ;
|
||||
|
||||
M: ##string-nth propagate
|
||||
[ resolve ] change-obj
|
||||
[ resolve ] change-index ;
|
||||
|
||||
M: ##set-slot-imm propagate
|
||||
call-next-method
|
||||
[ resolve ] change-obj ;
|
||||
|
|
|
@ -123,6 +123,14 @@ M: ##set-slot generate-insn
|
|||
M: ##set-slot-imm generate-insn
|
||||
>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>> 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-imm cpu ( src obj slot tag -- )
|
||||
|
||||
HOOK: %string-nth cpu ( dst obj index temp -- )
|
||||
|
||||
HOOK: %add cpu ( dst src1 src2 -- )
|
||||
HOOK: %add-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sub cpu ( dst src1 src2 -- )
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! 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
|
||||
kernel kernel.private math memory namespaces make sequences
|
||||
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-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 -- )
|
||||
[ 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
|
||||
#! 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.
|
||||
dst small-reg-4 small-regs memq? [ dst src quot call ] [
|
||||
src small-reg-that-isn't
|
||||
[| new-dst |
|
||||
new-dst src quot call
|
||||
dst new-dst MOV
|
||||
] with-save/restore
|
||||
dst small-reg-4 small-regs memq? [ dst quot call ] [
|
||||
exclude small-reg-that-isn't
|
||||
[ quot call ] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
: %alien-integer-getter ( dst src size quot -- )
|
||||
'[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
|
||||
with-small-register ; inline
|
||||
: aux-offset 2 cells string tag-number - ; 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 -- )
|
||||
[ MOVZX ] %alien-integer-getter ; inline
|
||||
|
@ -320,7 +342,7 @@ M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
|
|||
M: x86 %alien-double [] MOVSD ;
|
||||
|
||||
:: %alien-integer-setter ( ptr value size -- )
|
||||
value ptr [| new-value ptr |
|
||||
value { ptr } [| new-value |
|
||||
new-value value ?MOV
|
||||
ptr [] new-value size small-reg MOV
|
||||
] with-small-register ; inline
|
||||
|
|
Loading…
Reference in New Issue