Merge branch 'constant_time_allocation'

basis/alien/c-types/c-types.factor

@@ -204,7 +204,7 @@ M: byte-array byte-length length ;
     dup length [ nip malloc dup ] 2keep memcpy ;
 
 : memory>byte-array ( alien len -- byte-array )
-    [ nip <byte-array> dup ] 2keep memcpy ;
+    [ nip (byte-array) dup ] 2keep memcpy ;
 
 : byte-array>memory ( byte-array base -- )
     swap dup length memcpy ;

basis/bootstrap/stage2.factor

@@ -100,4 +100,8 @@ SYMBOL: bootstrap-time
 
         "output-image" get save-image-and-exit
     ] if
-] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover
+] [
+    drop
+    load-help? off
+    "resource:basis/bootstrap/bootstrap-error.factor" run-file
+] recover

basis/byte-vectors/byte-vectors.factor

@@ -10,7 +10,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 ;
@@ -22,7 +22,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 ;

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 -- )
+: emit-allot-byte-array ( len -- dst )
-    [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
+    dup ^^allot-byte-array
-                elt reg len bytes>cells store-initial-element
+    [ store-length ] [ ds-push ] [ ] tri ;
-                reg ds-push
+
-            ]
+: emit-(byte-array) ( node -- )
-        ] [ node emit-primitive ] if
+    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

@@ -52,6 +52,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>
@@ -139,6 +140,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/compiler/tree/propagation/slots/slots.factor

@@ -14,12 +14,13 @@ IN: compiler.tree.propagation.slots
 UNION: fixed-length-sequence array byte-array string ;
 
 : sequence-constructor? ( word -- ? )
-    { <array> <byte-array> <string> } memq? ;
+    { <array> <byte-array> (byte-array) <string> } memq? ;
 
 : constructor-output-class ( word -- class )
     {
         { <array> array }
         { <byte-array> byte-array }
+        { (byte-array) byte-array }
         { <string> string }
     } at ;
 

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

@@ -480,6 +480,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
 

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,6 +147,7 @@ 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

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

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/sequences/sequences-docs.factor

@@ -1,6 +1,6 @@
 USING: arrays help.markup help.syntax math
 sequences.private vectors strings kernel math.order layouts
-quotations ;
+quotations generic.standard ;
 IN: sequences
 
 HELP: sequence
@@ -14,8 +14,8 @@ HELP: length
 
 HELP: set-length
 { $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
-{ $contract "Resizes the sequence. Not all sequences are resizable." }
+{ $contract "Resizes a sequence. The initial contents of the new area is undefined." }
-{ $errors "Throws a " { $link bounds-error } " if the new length is negative." }
+{ $errors "Throws a " { $link no-method  } " error if the sequence is not resizable, and a " { $link bounds-error } " if the new length is negative." }
 { $side-effects "seq" } ;
 
 HELP: lengthen
@@ -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" } }

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,

vm/types.c

@@ -243,6 +243,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);
@@ -250,7 +256,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
 		to_copy = capacity;
 
 	REGISTER_UNTAGGED(array);
-	F_BYTE_ARRAY *new_array = allot_byte_array(capacity);
+	F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
 	UNREGISTER_UNTAGGED(array);
 
 	memcpy(new_array + 1,array + 1,to_copy);

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);
@@ -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);
 void primitive_resize_string(void);