O(1) <sbuf> and new-sequence on byte-arrays (work in progress)

diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index ceac5e960cfb20aa82372fb43fb8cedd9b8c4cc5..3a4c702bc563535758057098911c9a15c41c10eb 100644 (file)
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot
 
 : bytes>cells ( m -- n ) cell align cell /i ;
 
-:: emit-<byte-array> ( node -- )
-    [let | len [ node node-input-infos first literal>> ] |
-        len expand-<byte-array>? [
-            [let | elt [ 0 ^^load-literal ]
-                   reg [ len ^^allot-byte-array ] |
-                ds-drop
-                len reg store-length
-                elt reg len bytes>cells store-initial-element
-                reg ds-push
-            ]
-        ] [ node emit-primitive ] if
-    ] ;
+: emit-allot-byte-array ( len -- dst )
+    ds-drop
+    dup ^^allot-byte-array
+    [ store-length ] [ ds-push ] [ ] tri ;
+
+: emit-(byte-array) ( node -- )
+    dup node-input-infos first literal>> dup expand-<byte-array>?
+    [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
+
+: emit-<byte-array> ( node -- )
+    dup node-input-infos first literal>> dup expand-<byte-array>? [
+        nip
+        [ 0 ^^load-literal ] dip
+        [ emit-allot-byte-array ] keep
+        bytes>cells store-initial-element
+    ] [ drop emit-primitive ] if ;

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index cfc04fa036d7880a35b4f9c1e48f32e7fba7cf38..4e3249f15a739a317291503683a7763da80d37c3 100644 (file)
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -49,6 +49,7 @@ IN: compiler.cfg.intrinsics
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
+    byte-arrays:(byte-array)
     math.private:<complex>
     math.private:<ratio>
     kernel:<wrapper>
@@ -131,6 +132,7 @@ IN: compiler.cfg.intrinsics
         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
         { \ arrays:<array> [ emit-<array> iterate-next ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
+        { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
         { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
         { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
         { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }

diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor
index 0501458532e1faff6c55142422fefa4c9617a9f6..02e47ca140c00da8bb4fbcd32a637b7487957f25 100644 (file)
--- a/basis/specialized-arrays/double/double.factor
+++ b/basis/specialized-arrays/double/double.factor
@@ -9,6 +9,8 @@ USING: hints math.vectors arrays kernel math accessors sequences ;
 
 HINTS: <double-array> { 2 } { 3 } ;
 
+HINTS: (double-array) { 2 } { 3 } ;
+
 HINTS: vneg { array } { double-array } ;
 HINTS: v*n { array object } { double-array float } ;
 HINTS: n*v { array object } { float double-array } ;

diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor
index 52977dc22ad8d767fb33540c99903661eb3d8305..2a062105bb4179a7046a900a40b0ab47c167918d 100644 (file)
--- a/basis/specialized-arrays/functor/functor.factor
+++ b/basis/specialized-arrays/functor/functor.factor
@@ -10,10 +10,14 @@ ERROR: bad-byte-array-length byte-array type ;
 M: bad-byte-array-length summary
     drop "Byte array length doesn't divide type width" ;
 
+: (c-array) ( n c-type -- array )
+    heap-size * (byte-array) ; inline
+
 FUNCTOR: define-array ( T -- )
 
 A            DEFINES ${T}-array
 <A>          DEFINES <${A}>
+(A)          DEFINES (${A})
 >A           DEFINES >${A}
 byte-array>A DEFINES byte-array>${A}
 A{           DEFINES ${A}{
@@ -29,6 +33,8 @@ TUPLE: A
 
 : <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
 
+: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
+
 : byte-array>A ( byte-array -- specialized-array )
     dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
     swap A boa ; inline
@@ -45,7 +51,7 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
 
 M: A like drop dup A instance? [ >A execute ] unless ;
 
-M: A new-sequence drop <A> execute ;
+M: A new-sequence drop (A) execute ;
 
 M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
 

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 2cb3d1f006fd91f513626843b9b2e468c818f304..2ef181b179f63d33fe4f94eba086388bd6d76420 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -483,6 +483,9 @@ M: object infer-call*
 \ <byte-array> { integer } { byte-array } define-primitive
 \ <byte-array> make-flushable
 
+\ (byte-array) { integer } { byte-array } define-primitive
+\ (byte-array) make-flushable
+
 \ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
 \ <displaced-alien> make-flushable
 
@@ -611,6 +614,9 @@ M: object infer-call*
 \ <string> { integer integer } { string } define-primitive
 \ <string> make-flushable
 
+\ (string) { integer } { string } define-primitive
+\ (string) make-flushable
+
 \ array>quotation { array } { quotation } define-primitive
 \ array>quotation make-flushable
 

diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index 953291cc59d75ebc8871b0aca519a83298bcf80d..5410aef8c9799c4c7617e5a9f992e0a425d33b1b 100644 (file)
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
 sequences.private assocs models models.filter arrays accessors
-generic generic.standard definitions make ;
+generic generic.standard definitions make sbufs ;
 IN: tools.walker
 
 SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -147,10 +147,15 @@ SYMBOL: +stopped+
     { (call-next-method) [ (step-into-call-next-method) ] }
 } [ "step-into" set-word-prop ] assoc-each
 
+! Never step into these words
 {
     >n ndrop >c c>
     continue continue-with
     stop suspend (spawn)
+    ! Don't step into some sequence words since output of
+    ! (string) and new-sequence-unsafe may not print due to
+    ! memory safety issues
+    <sbuf> prepare-subseq subseq new-sequence-unsafe
 } [
     dup [ execute break ] curry
     "step-into" set-word-prop

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 0a7e5fe23331a72a4379dfb23275118b80b23bc2..d88247f3831af8d7e46d15cdb284e885b3d21195 100644 (file)
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -468,6 +468,7 @@ tuple
     { "dlsym" "alien" }
     { "dlclose" "alien" }
     { "<byte-array>" "byte-arrays" }
+    { "(byte-array)" "byte-arrays" }
     { "<displaced-alien>" "alien" }
     { "alien-signed-cell" "alien.accessors" }
     { "set-alien-signed-cell" "alien.accessors" }
@@ -519,6 +520,7 @@ tuple
     { "<wrapper>" "kernel" }
     { "(clone)" "kernel" }
     { "<string>" "strings" }
+    { "(string)" "strings.private" }
     { "array>quotation" "quotations.private" }
     { "quotation-xt" "quotations" }
     { "<tuple>" "classes.tuple.private" }

diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index f981e758d79e3bd3c76613a74405033c9df3ca8b..f0d188ce4a705855a356eb3b07c3e332a55e090a 100644 (file)
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -9,7 +9,7 @@ M: byte-array length length>> ;
 M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
 M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
 : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array new-sequence drop <byte-array> ;
+M: byte-array new-sequence drop (byte-array) ;
 
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;

diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
index 6938d02b2f0d79b1c5483a867589110052529889..c273cea867a857fa196bd84a7993c151ad2b15fc 100644 (file)
--- a/core/byte-vectors/byte-vectors.factor
+++ b/core/byte-vectors/byte-vectors.factor
@@ -9,7 +9,7 @@ TUPLE: byte-vector
 { length array-capacity } ;\r
 \r
 : <byte-vector> ( n -- byte-vector )\r
-    <byte-array> 0 byte-vector boa ; inline\r
+    (byte-array) 0 byte-vector boa ; inline\r
 \r
 : >byte-vector ( seq -- byte-vector )\r
     T{ byte-vector f B{ } 0 } clone-like ;\r
@@ -21,7 +21,7 @@ M: byte-vector like
     ] unless ;\r
 \r
 M: byte-vector new-sequence\r
-    drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ;\r
+    drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
 \r
 M: byte-vector equal?\r
     over byte-vector? [ sequence= ] [ 2drop f ] if ;\r

diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor
index 5590432ef4ca3908facee7aadd6fb31fcb704b26..0b6f089443d7b698c720a8b6d80faf7e6185bf0f 100644 (file)
--- a/core/sbufs/sbufs.factor
+++ b/core/sbufs/sbufs.factor
@@ -8,7 +8,7 @@ TUPLE: sbuf
 { underlying string }
 { length array-capacity } ;
 
-: <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
+: <sbuf> ( n -- sbuf ) (string) 0 sbuf boa ; inline
 
 M: sbuf set-nth-unsafe
     [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 08831579bb4c977fada07f422946c348f54a6970..b5e8c17d9f6d3319091e5ba00488f02bb4f5e04d 100644 (file)
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -59,7 +59,7 @@ HELP: immutable
 
 HELP: new-sequence
 { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
-{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
+{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } ". The initial contents of the sequence are undefined." } ;
 
 HELP: new-resizable
 { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 3461266081d9de2ac0d1529500d0656fe78c0cea..dfe1c2b9446b2869c52cafec1386bdbf7587ecc9 100644 (file)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -81,6 +81,7 @@ GENERIC: resize ( n seq -- newseq ) flushable
 ! Unsafe sequence protocol for inner loops
 GENERIC: nth-unsafe ( n seq -- elt ) flushable
 GENERIC: set-nth-unsafe ( elt n seq -- )
+GENERIC: new-sequence-unsafe ( len seq -- newseq ) flushable
 
 M: sequence nth bounds-check nth-unsafe ;
 M: sequence set-nth bounds-check set-nth-unsafe ;
@@ -88,6 +89,8 @@ M: sequence set-nth bounds-check set-nth-unsafe ;
 M: sequence nth-unsafe nth ;
 M: sequence set-nth-unsafe set-nth ;
 
+M: sequence new-sequence-unsafe new-sequence ;
+
 ! The f object supports the sequence protocol trivially
 M: f length drop 0 ;
 M: f nth-unsafe nip ;
@@ -256,7 +259,7 @@ INSTANCE: repetition immutable-sequence
 
 : prepare-subseq ( from to seq -- dst i src j n )
     #! The check-length call forces partial dispatch
-    [ [ swap - ] dip new-sequence dup 0 ] 3keep
+    [ [ swap - ] dip new-sequence-unsafe dup 0 ] 3keep
     -rot drop roll length check-length ; inline
 
 : check-copy ( src n dst -- )

diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 0c3f918fdca03879a8dd65c817b2e94272b0e8a6..6da7bfce0d57c96183150de3aca15d17c4c061aa 100644 (file)
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -56,4 +56,6 @@ M: string resize resize-string ;
 
 M: string new-sequence drop 0 <string> ;
 
+M: string new-sequence-unsafe drop (string) ;
+
 INSTANCE: string sequence

diff --git a/vm/primitives.c b/vm/primitives.c
index a01a8653b7879a6af41d873b1ab0fd1506fe3c6e..142db9e2048d695c15f47aecae66d704136604f3 100755 (executable)
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -74,6 +74,7 @@ void *primitives[] = {
        primitive_dlsym,
        primitive_dlclose,
        primitive_byte_array,
+       primitive_uninitialized_byte_array,
        primitive_displaced_alien,
        primitive_alien_signed_cell,
        primitive_set_alien_signed_cell,
@@ -125,6 +126,7 @@ void *primitives[] = {
        primitive_wrapper,
        primitive_clone,
        primitive_string,
+       primitive_uninitialized_string,
        primitive_array_to_quotation,
        primitive_quotation_xt,
        primitive_tuple,

diff --git a/vm/types.c b/vm/types.c
index a614011e7eef760ea9490aa77992e37a2808ccb0..2a18030566f05c1312b96f2838e4bd4a9a597655 100755 (executable)
--- a/vm/types.c
+++ b/vm/types.c
@@ -253,6 +253,12 @@ void primitive_byte_array(void)
        dpush(tag_object(allot_byte_array(size)));
 }
 
+void primitive_uninitialized_byte_array(void)
+{
+       CELL size = unbox_array_size();
+       dpush(tag_object(allot_byte_array_internal(size)));
+}
+
 F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
 {
        CELL to_copy = array_capacity(array);
@@ -433,6 +439,12 @@ void primitive_string(void)
        dpush(tag_object(allot_string(length,initial)));
 }
 
+void primitive_uninitialized_string(void)
+{
+       CELL length = unbox_array_size();
+       dpush(tag_object(allot_string_internal(length)));
+}
+
 F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
 {
        CELL to_copy = string_capacity(string);

diff --git a/vm/types.h b/vm/types.h
index 242939c502dc6bff6e36dcbf88f458e4b93c65fe..d8d69dc5415e69bb92792ddab1dd427fc47bfb33 100755 (executable)
--- a/vm/types.h
+++ b/vm/types.h
@@ -116,6 +116,7 @@ void primitive_tuple(void);
 void primitive_tuple_boa(void);
 void primitive_tuple_layout(void);
 void primitive_byte_array(void);
+void primitive_uninitialized_byte_array(void);
 void primitive_clone(void);
 
 F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
@@ -125,6 +126,7 @@ void primitive_resize_byte_array(void);
 
 F_STRING* allot_string_internal(CELL capacity);
 F_STRING* allot_string(CELL capacity, CELL fill);
+void primitive_uninitialized_string(void);
 void primitive_string(void);
 F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
 void primitive_resize_string(void);