Add string-nth intrinsic

db4
Slava Pestov 2008-11-06 01:11:28 -06:00
parent 9160e667a7
commit 53cd75b06c
10 changed files with 72 additions and 14 deletions

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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> ] }

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 -- )

View File

@ -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