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

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 ;

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

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

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 ;
 

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
 

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

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

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 ;

core/byte-vectors/byte-vectors.factor

@@ -9,7 +9,7 @@ TUPLE: byte-vector
 { length array-capacity } ;
 
 : <byte-vector> ( n -- byte-vector )
-    <byte-array> 0 byte-vector boa ; inline
+    (byte-array) 0 byte-vector boa ; inline
 
 : >byte-vector ( seq -- byte-vector )
     T{ byte-vector f B{ } 0 } clone-like ;
@@ -21,7 +21,7 @@ M: byte-vector like
     ] unless ;
 
 M: byte-vector new-sequence
-    drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ;
+    drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
 
 M: byte-vector equal?
     over byte-vector? [ sequence= ] [ 2drop f ] if ;

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 ;

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

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

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

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,

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

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