--- /dev/null
- <byte-array> 0 byte-vector boa ; inline\r
+ ! Copyright (C) 2008 Slava Pestov.\r
+ ! See http://factorcode.org/license.txt for BSD license.\r
+ USING: arrays kernel kernel.private math sequences\r
+ sequences.private growable byte-arrays accessors parser\r
+ prettyprint.custom ;\r
+ IN: byte-vectors\r
+ \r
+ TUPLE: byte-vector\r
+ { underlying byte-array }\r
+ { length array-capacity } ;\r
+ \r
+ : <byte-vector> ( n -- byte-vector )\r
- drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ;\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
+ \r
+ M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-vector boa ] [ >byte-vector ] if\r
+ ] unless ;\r
+ \r
+ M: byte-vector new-sequence\r
++ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+ \r
+ M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+ \r
+ M: byte-array like\r
+ #! If we have an byte-array, we're done.\r
+ #! If we have a byte-vector, and it's at full capacity,\r
+ #! we're done. Otherwise, call resize-byte-array, which is a\r
+ #! relatively fast primitive.\r
+ drop dup byte-array? [\r
+ dup byte-vector? [\r
+ [ length ] [ underlying>> ] bi\r
+ 2dup length eq?\r
+ [ nip ] [ resize-byte-array ] if\r
+ ] [ >byte-array ] if\r
+ ] unless ;\r
+ \r
+ M: byte-array new-resizable drop <byte-vector> ;\r
+ \r
+ : BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
+ \r
+ M: byte-vector pprint* pprint-object ;\r
+ M: byte-vector pprint-delims drop \ BV{ \ } ;\r
+ M: byte-vector >pprint-sequence ;\r
+ \r
+ INSTANCE: byte-vector growable\r
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
+ compiler.cfg.intrinsics.misc
compiler.cfg.iterator ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
+ QUALIFIED: math.integers.private
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
kernel.private:tag
+ kernel.private:getenv
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
+ byte-arrays:(byte-array)
math.private:<complex>
math.private:<ratio>
kernel:<wrapper>
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
+ : enable-fixnum-log2 ( -- )
+ \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
+ { \ kernel.private:getenv [ emit-getenv iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
+ { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
{ \ 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 ] }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
- USING: functors sequences sequences.private prettyprint.backend
+ USING: functors sequences sequences.private prettyprint.custom
kernel words classes math parser alien.c-types byte-arrays
accessors summary ;
IN: specialized-arrays.functor
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}{
: <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
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 ;
hashtables hashtables.private io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
- prettyprint quotations quotations.private sbufs sbufs.private
+ quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
- combinators locals locals.backend locals.private words.private
+ combinators locals locals.backend locals.types words.private
quotations.private stack-checker.values
stack-checker.alien
stack-checker.state
3 infer->r infer-call 3 infer-r> ;
: infer-dip ( -- )
- commit-literals
literals get
[ \ dip def>> infer-quot-here ]
[ pop 1 infer->r infer-quot-here 1 infer-r> ]
if-empty ;
: infer-2dip ( -- )
- commit-literals
literals get
[ \ 2dip def>> infer-quot-here ]
[ pop 2 infer->r infer-quot-here 2 infer-r> ]
if-empty ;
: infer-3dip ( -- )
- commit-literals
literals get
[ \ 3dip def>> infer-quot-here ]
[ pop 3 infer->r infer-quot-here 3 infer-r> ]
\ <complex> { real real } { complex } define-primitive
\ <complex> make-foldable
- \ both-fixnums? { object object } { object object object } define-primitive
+ \ both-fixnums? { object object } { object } define-primitive
\ fixnum+ { fixnum fixnum } { integer } define-primitive
\ fixnum+ make-foldable
\ <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
\ <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
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 -- )
{ (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
: walker-loop ( -- )
+running+ set-status
- [ status +stopped+ eq? not ] [
+ [ status +stopped+ eq? ] [
[
{
! ignore these commands while the thread is
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] while ;
+ ] [ ] until ;
: associate-thread ( walker -- )
walker-thread tset
"alien.accessors"
"arrays"
"byte-arrays"
- "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
} [ create-vocab drop ] each
! Builtin classes
- : define-builtin-predicate ( class -- )
- dup class>type [ builtin-instance? ] curry define-predicate ;
-
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
] [ ] make
define-predicate-class
+ "array-capacity" "sequences.private" lookup
+ [ >fixnum ] bootstrap-max-array-capacity <fake-bignum> [ fixnum-bitand ] curry append
+ "coercer" set-word-prop
+
! Catch-all class for providing a default method.
"object" "kernel" create
[ f f { } intersection-class define-class ]
{ "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" }
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "<string>" "strings" }
+ { "(string)" "strings.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
{ "<tuple>" "classes.tuple.private" }
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" } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
- HELP: cache-nth
- { $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
- { $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
- { $side-effects "seq" } ;
-
HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
"Changing elements:"
{ $subsection change-each }
{ $subsection change-nth }
- { $subsection cache-nth }
"Deleting elements:"
{ $subsection delete }
{ $subsection delq }
! 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 ;
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 ;
: 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 -- )
: harvest ( seq -- newseq )
[ empty? not ] filter ;
- : cache-nth ( i seq quot -- elt )
- 2over ?nth dup [
- [ 3drop ] dip
- ] [
- drop swap [ over [ call dup ] dip ] dip set-nth
- ] if ; inline
-
: mismatch ( seq1 seq2 -- i )
[ min-length ] 2keep
[ 2nth-unsafe = not ] 2curry
: supremum ( seq -- n ) dup first [ max ] reduce ;
- : flip ( matrix -- newmatrix )
- dup empty? [
- dup [ length ] map infimum
- swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
- ] unless ;
-
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+
+ ! We hand-optimize flip to such a degree because type hints
+ ! cannot express that an array is an array of arrays yet, and
+ ! this word happens to be performance-critical since the compiler
+ ! itself uses it. Optimizing it like this reduced compile time.
+ <PRIVATE
+
+ : generic-flip ( matrix -- newmatrix )
+ [ dup first length [ length min ] reduce ] keep
+ [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
+
+ USE: arrays
+
+ : array-length ( array -- len )
+ { array } declare length>> ;
+
+ : array-flip ( matrix -- newmatrix )
+ [ dup first array-length [ array-length min ] reduce ] keep
+ [ [ array-nth ] with { } map-as ] curry { } map-as ;
+
+ PRIVATE>
+
+ : flip ( matrix -- newmatrix )
+ dup empty? [
+ dup array? [
+ dup [ array? ] all?
+ [ array-flip ] [ generic-flip ] if
+ ] [ generic-flip ] if
+ ] unless ;
return tag_object(a);
}
- F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
+ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
{
- int i;
- F_ARRAY* new_array;
-
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
- REGISTER_ROOT(fill);
-
- new_array = allot_array_internal(untag_header(array->header),capacity);
-
- UNREGISTER_ROOT(fill);
+ F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
-
- for(i = to_copy; i < capacity; i++)
- put(AREF(new_array,i),fill);
+ memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity,F)));
+ dpush(tag_object(reallot_array(array,capacity)));
}
F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
if(*result_count == array_capacity(result))
{
- result = reallot_array(result,
- *result_count * 2,F);
+ result = reallot_array(result,*result_count * 2);
}
UNREGISTER_ROOT(elt);
CELL new_size = *result_count + elts_size;
if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2,F);
+ result = reallot_array(result,new_size * 2);
UNREGISTER_UNTAGGED(elts);
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);
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)
+ F_STRING* reallot_string(F_STRING* string, CELL capacity)
{
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,fill);
+ fill_string(new_string,to_copy,capacity,'\0');
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity,0)));
+ dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
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);
+ F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_resize_array(void);
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);
+ F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count,F))
+ result = tag_object(reallot_array(untag_object(result),result##_count))
/* Macros to simulate a byte vector in C */
#define GROWABLE_BYTE_ARRAY(result) \
projects / factor.git / commitdiff