Add string-nth intrinsic

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

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 ;

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

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 ;

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

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 ;

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 ;

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
 

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

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 ] [
+    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
 
-: %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 -- )
     [ 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