From 53cd75b06c3009fc795a563be234bb530e4dd7e9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:11:28 -0600
Subject: [PATCH] Add string-nth intrinsic
---
basis/bootstrap/compiler/compiler.factor | 10 ++++
basis/compiler/cfg/def-use/def-use.factor | 2 +
basis/compiler/cfg/hats/hats.factor | 1 +
.../cfg/instructions/instructions.factor | 3 ++
.../compiler/cfg/intrinsics/intrinsics.factor | 3 ++
.../cfg/intrinsics/slots/slots.factor | 3 ++
.../propagate/propagate.factor | 4 ++
basis/compiler/codegen/codegen.factor | 8 +++
basis/cpu/architecture/architecture.factor | 2 +
basis/cpu/x86/x86.factor | 50 +++++++++++++------
10 files changed, 72 insertions(+), 14 deletions(-)
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index cbd2f0f41e..dabdeea741 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -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
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 2cbd7e54cb..7553407e00 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -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 ;
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 1c6480048c..e6e05abbd5 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -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
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5ea74e97ec..c39f517671 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -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 ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 3fd54d2e07..ef1cde337a 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -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> ] }
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index cbc5d04c0b..22fb4e747b 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -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 ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index d08f233995..a3c9725838 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -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 ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 0d36a88b45..cab86dcb54 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -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
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c86f236976..e4fa9419f0 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -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 -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 83c9ee7f0d..0e00ce60ee 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -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