native/word.o native/compiler.o \
native/ffi.o native/boolean.o \
native/debug.o \
- native/hashtable.o \
- native/scan.o
+ native/hashtable.o
default:
@echo "Run 'make' with one of the following parameters:"
- #jump-f #jump-f-label\r
- extract word inside M:, C:, and structure browsing for these\r
- fix checkbox alignment\r
-- begin-scan, next-object, end-scan primitives\r
-- each-object, each-slot combinators\r
+- each-slot combinator\r
- references primitive\r
- resize window: world not updated until mouse moved\r
- x>offset\r
\r
"/library/io/files.factor"\r
"/library/eval-catch.factor"\r
- "/library/tools/heap-stats.factor"\r
+ "/library/tools/memory.factor"\r
"/library/tools/listener.factor"\r
"/library/cli.factor"\r
] [\r
"/library/syntax/parse-numbers.factor" parse-resource append,
"/library/syntax/parser.factor" parse-resource append,
"/library/syntax/parse-stream.factor" parse-resource append,
+ "/library/syntax/generic.factor" parse-resource append,
+ "/library/syntax/parse-syntax.factor" parse-resource append,
"delegate" [ "generic" ] search
"object" [ "generic" ] search
reveal
reveal
-
+
"/library/generic/generic.factor" parse-resource append,
"/library/generic/object.factor" parse-resource append,
"/library/generic/null.factor" parse-resource append,
"/library/generic/tuple.factor" parse-resource append,
"/library/bootstrap/init.factor" parse-resource append,
- "/library/syntax/parse-syntax.factor" parse-resource append,
] make-list
"boot" [ "kernel" ] search swons
[ "set-alien-2" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-1" "alien" [ [ alien integer ] [ fixnum ] ] ]
[ "set-alien-1" "alien" [ [ integer alien integer ] [ ] ] ]
- [ "heap-stats" "memory" [ [ ] [ general-list ] ] ]
[ "throw" "errors" [ [ object ] [ ] ] ]
[ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ]
[ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ]
[ ">tuple" "kernel-internals" [ [ object ] [ tuple ] ] ]
[ "begin-scan" "memory" [ [ ] [ ] ] ]
[ "next-object" "memory" [ [ ] [ object ] ] ]
- [ "end-scan" "memory" [ [ ] [ object ] ] ]
+ [ "end-scan" "memory" [ [ ] [ object ] ] ]
+ [ "size" "memory" [ [ ] [ object ] ] ]
] [
3unlist >r create >r 1 + r> 2dup swap f define r>
dup string? [
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
+USING: errors hashtables kernel lists namespaces parser strings
+words vectors ;
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
[ swap "builtin-type" set-word-property ] keep
builtin define-class ;
-: BUILTIN:
- #! Followed by type name and type number. Define a built-in
- #! type predicate with this number.
- CREATE scan-word swap builtin-class ; parsing
-
: builtin-type ( n -- symbol )
unit classes get hash ;
-
-M: object class ( obj -- class )
- #! Analogous to the type primitive. Pushes the builtin
- #! class of an object.
- type builtin-type ;
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
-USE: math
+USING: errors hashtables kernel lists math parser strings
+vectors words ;
! Complement metaclass, contains all objects not in a certain class.
SYMBOL: complement
[ complement-predicate define-compound ] keep
dupd "complement" set-word-property
complement define-class ;
-
-: COMPLEMENT: ( -- class predicate definition )
- #! Followed by a class name, then a complemented class.
- CREATE
- dup intern-symbol
- dup predicate-word
- [ dupd unit "predicate" set-word-property ] keep
- scan-word define-complement ; parsing
: single-combination ( obj vtable -- )
>r dup type r> dispatch ; inline
-: GENERIC:
- #! GENERIC: bar creates a generic word bar. Add methods to
- #! the generic word using M:.
- [ single-combination ]
- \ GENERIC: CREATE define-generic ; parsing
-
: arithmetic-combination ( n n vtable -- )
#! Note that the numbers remain on the stack, possibly after
#! being coerced to a maximal type.
>r arithmetic-type r> dispatch ; inline
-: 2GENERIC:
- #! 2GENERIC: bar creates a generic word bar. Add methods to
- #! the generic word using M:. 2GENERIC words dispatch on
- #! arithmetic types and should not be used for non-numerical
- #! types.
- [ arithmetic-combination ]
- \ 2GENERIC: CREATE define-generic ; parsing
-
-: M: ( -- class generic [ ] )
- #! M: foo bar begins a definition of the bar generic word
- #! specialized to the foo type.
- scan-word scan-word [ define-method ] [ ] ; parsing
-
! Maps lists of builtin type numbers to class objects.
SYMBOL: classes
classes get set-hash ;
classes get [ <namespace> classes set ] unless
-
-GENERIC: class ( obj -- class )
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: kernel
-USE: words
+USING: kernel words ;
! Null metaclass with no instances.
SYMBOL: null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
-USE: math
+USING: kernel lists math vectors words ;
! Catch-all metaclass for providing a default method.
SYMBOL: object
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
! Copyright (C) 2004, 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
+USING: errors hashtables kernel lists namespaces parser strings
+words vectors ;
! Predicate metaclass for generalized predicate dispatch.
SYMBOL: predicate
[ \ dup , append, , [ drop f ] , \ ifte , ] make-list
define-compound
predicate "metaclass" set-word-property ;
-
-: PREDICATE: ( -- class predicate definition )
- #! Followed by a superclass name, then a class name.
- scan-word
- CREATE dup intern-symbol
- dup rot "superclass" set-word-property
- dup predicate-word
-! 2dup swap "predicate" set-word-property
- [ dupd unit "predicate" set-word-property ] keep
- [ define-predicate ] [ ] ; parsing
USING: words parser kernel namespaces lists strings
kernel-internals math hashtables errors vectors ;
+: class ( obj -- class )
+ #! The class of an object.
+ dup tuple? [ 2 slot ] [ type builtin-type ] ifte ;
+
: make-tuple ( class -- tuple )
dup "tuple-size" word-property <tuple>
[ 0 swap set-array-nth ] keep ;
dup r> define-slots "slot-words" set-word-property
default-constructor ;
-: TUPLE:
- #! Followed by a tuple name, then slot names, then ;
- scan
- string-mode on
- [ string-mode off define-tuple ]
- f ; parsing
-
-: C:
- #! Followed by a tuple name, then constructor code, then ;
- #! Constructor code executes with the empty tuple on the
- #! stack.
- scan-word [ define-constructor ] f ; parsing
-
: tuple-delegate ( tuple -- obj )
dup tuple? [
dup class "delegate-field" word-property dup [
1 swap array-nth hashcode
] ifte ;
-M: tuple class ( obj -- class ) 2 slot ;
-
tuple [
( generic vtable definition class -- )
2drop add-tuple-dispatch
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
+USING: errors hashtables kernel lists namespaces parser strings
+words vectors ;
! Union metaclass for dispatch on multiple classes.
SYMBOL: union
[ union-predicate define-compound ] keep
dupd "members" set-word-property
union define-class ;
-
-: UNION: ( -- class predicate definition )
- #! Followed by a class name, then a list of union members.
- CREATE
- dup intern-symbol
- dup predicate-word
- [ dupd unit "predicate" set-word-property ] keep
- [ define-union ] [ ] ; parsing
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+
+! Bootstrapping trick; see doc/bootstrap.txt.
+IN: !syntax
+USING: syntax generic kernel lists namespaces parser words ;
+
+: GENERIC:
+ #! GENERIC: bar creates a generic word bar. Add methods to
+ #! the generic word using M:.
+ [ single-combination ]
+ \ GENERIC: CREATE define-generic ; parsing
+
+: 2GENERIC:
+ #! 2GENERIC: bar creates a generic word bar. Add methods to
+ #! the generic word using M:. 2GENERIC words dispatch on
+ #! arithmetic types and should not be used for non-numerical
+ #! types.
+ [ arithmetic-combination ]
+ \ 2GENERIC: CREATE define-generic ; parsing
+
+: BUILTIN:
+ #! Followed by type name and type number. Define a built-in
+ #! type predicate with this number.
+ CREATE scan-word swap builtin-class ; parsing
+
+: COMPLEMENT: ( -- class predicate definition )
+ #! Followed by a class name, then a complemented class.
+ CREATE
+ dup intern-symbol
+ dup predicate-word
+ [ dupd unit "predicate" set-word-property ] keep
+ scan-word define-complement ; parsing
+
+: UNION: ( -- class predicate definition )
+ #! Followed by a class name, then a list of union members.
+ CREATE
+ dup intern-symbol
+ dup predicate-word
+ [ dupd unit "predicate" set-word-property ] keep
+ [ define-union ] [ ] ; parsing
+
+: PREDICATE: ( -- class predicate definition )
+ #! Followed by a superclass name, then a class name.
+ scan-word
+ CREATE dup intern-symbol
+ dup rot "superclass" set-word-property
+ dup predicate-word
+ [ dupd unit "predicate" set-word-property ] keep
+ [ define-predicate ] [ ] ; parsing
+
+: TUPLE:
+ #! Followed by a tuple name, then slot names, then ;
+ scan
+ string-mode on
+ [ string-mode off define-tuple ]
+ f ; parsing
+
+: M: ( -- class generic [ ] )
+ #! M: foo bar begins a definition of the bar generic word
+ #! specialized to the foo type.
+ scan-word scan-word [ define-method ] [ ] ; parsing
+
+: C:
+ #! Followed by a tuple name, then constructor code, then ;
+ #! Constructor code executes with the empty tuple on the
+ #! stack.
+ scan-word [ define-constructor ] f ; parsing
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: memory
-USING: errors generic kernel lists math namespaces prettyprint
-stdio unparser vectors words ;
-
-! Printing an overview of heap usage.
-
-: kb. 1024 /i unparse write " KB" write ;
-
-: (room.) ( free total -- )
- 2dup swap - swap ( free used total )
- kb. " total " write
- kb. " used " write
- kb. " free" print ;
-
-: room. ( -- )
- room
- "Data space: " write (room.)
- "Code space: " write (room.) ;
-
-! Some words for iterating through the heap.
-
-: (each-object) ( quot -- )
- next-object dup [
- swap dup slip (each-object)
- ] [
- 2drop
- ] ifte ; inline
-
-: each-object ( quot -- )
- #! Applies the quotation to each object in the image.
- [
- begin-scan (each-object)
- ] [
- end-scan rethrow
- ] catch ; inline
-
-: instances ( class -- list )
- #! Return a list of all instances of a built-in or tuple
- #! class in the image.
- [
- [
- dup class pick = [ , ] [ drop ] ifte
- ] each-object drop
- ] make-list ;
-
-: heap-stat. ( type instances bytes -- )
- dup 0 = [
- 3drop
- ] [
- rot builtin-type word-name write ": " write
- unparse write " bytes, " write
- unparse write " instances" print
- ] ifte ;
-
-: heap-stats. ( -- )
- #! Print heap allocation breakdown.
- 0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: memory
+USING: errors generic kernel lists math namespaces prettyprint
+stdio unparser vectors words ;
+
+! Printing an overview of heap usage.
+
+: kb. 1024 /i unparse write " KB" write ;
+
+: (room.) ( free total -- )
+ 2dup swap - swap ( free used total )
+ kb. " total " write
+ kb. " used " write
+ kb. " free" print ;
+
+: room. ( -- )
+ room
+ "Data space: " write (room.)
+ "Code space: " write (room.) ;
+
+! Some words for iterating through the heap.
+
+: (each-object) ( quot -- )
+ next-object dup [
+ swap dup slip (each-object)
+ ] [
+ 2drop
+ ] ifte ; inline
+
+: each-object ( quot -- )
+ #! Applies the quotation to each object in the image.
+ [
+ begin-scan (each-object)
+ ] [
+ end-scan rethrow
+ ] catch ; inline
+
+: instances ( class -- list )
+ #! Return a list of all instances of a built-in or tuple
+ #! class in the image.
+ [
+ [
+ dup class pick = [ , ] [ drop ] ifte
+ ] each-object drop
+ ] make-list ;
+
+: vector+ ( n index vector -- )
+ [ vector-nth + ] 2keep set-vector-nth ;
+
+: heap-stat-step ( counts sizes obj -- )
+ [ dup size swap type rot vector+ ] keep
+ 1 swap type rot vector+ ;
+
+: zero-vector ( n -- vector )
+ [ drop 0 ] vector-project ;
+
+: heap-stats ( -- stats )
+ #! Return a list of instance count/total size pairs.
+ num-types zero-vector num-types zero-vector
+ [ >r 2dup r> heap-stat-step ] each-object
+ swap vector>list swap vector>list zip ;
+
+: heap-stat. ( type instances bytes -- )
+ dup 0 = [
+ 3drop
+ ] [
+ rot builtin-type word-name write ": " write
+ unparse write " bytes, " write
+ unparse write " instances" print
+ ] ifte ;
+
+: heap-stats. ( -- )
+ #! Print heap allocation breakdown.
+ 0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;
#include "relocate.h"
#include "ffi.h"
#include "debug.h"
-#include "scan.h"
#endif /* __FACTOR_H__ */
void primitive_address(void)
{
- dpush(tag_bignum(s48_ulong_to_bignum(dpop())));
+ drepl(tag_bignum(s48_ulong_to_bignum(dpeek())));
+}
+
+void primitive_size(void)
+{
+ drepl(tag_fixnum(object_size(dpeek())));
+}
+
+void primitive_begin_scan(void)
+{
+ primitive_gc();
+ heap_scan_ptr = active.base;
+ heap_scan_end = active.here;
+ heap_scan = true;
+}
+
+void primitive_next_object(void)
+{
+ CELL value = get(heap_scan_ptr);
+ CELL obj = heap_scan_ptr;
+ CELL size, type;
+
+ if(!heap_scan)
+ general_error(ERROR_HEAP_SCAN,F);
+
+ if(heap_scan_ptr >= heap_scan_end)
+ {
+ dpush(F);
+ return;
+ }
+
+ if(headerp(value))
+ {
+ size = align8(untagged_object_size(heap_scan_ptr));
+ type = untag_header(value);
+ }
+ else
+ {
+ size = CELLS * 2;
+ type = CONS_TYPE;
+ }
+
+ heap_scan_ptr += size;
+
+ if(type < HEADER_TYPE)
+ dpush(RETAG(obj,type));
+ else
+ dpush(RETAG(obj,OBJECT_TYPE));
+}
+
+void primitive_end_scan(void)
+{
+ heap_scan = false;
}
void primitive_room(void);
void primitive_allot_profiling(void);
void primitive_address(void);
-void primitive_memory_cell(void);
-void primitive_memory_4(void);
-void primitive_memory_1(void);
-void primitive_set_memory_cell(void);
-void primitive_set_memory_4(void);
-void primitive_set_memory_1(void);
+void primitive_size(void);
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* End of heap when walk was started; prevents infinite loop if
+walk consing */
+CELL heap_scan_end;
+
+void primitive_begin_scan(void);
+void primitive_next_object(void);
+void primitive_end_scan(void);
primitive_set_alien_2,
primitive_alien_1,
primitive_set_alien_1,
- primitive_heap_stats,
primitive_throw,
primitive_string_to_memory,
primitive_memory_to_string,
primitive_to_tuple,
primitive_begin_scan,
primitive_next_object,
- primitive_end_scan
+ primitive_end_scan,
+ primitive_size
};
CELL primitive_to_xt(CELL primitive)
+++ /dev/null
-#include "factor.h"
-
-void primitive_begin_scan(void)
-{
- primitive_gc();
- heap_scan_ptr = active.base;
- heap_scan_end = active.here;
- heap_scan = true;
-}
-
-void primitive_next_object(void)
-{
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
- CELL size, type;
-
- if(!heap_scan)
- general_error(ERROR_HEAP_SCAN,F);
-
- if(heap_scan_ptr >= heap_scan_end)
- {
- dpush(F);
- return;
- }
-
- if(headerp(value))
- {
- size = align8(untagged_object_size(heap_scan_ptr));
- type = untag_header(value);
- }
- else
- {
- size = CELLS * 2;
- type = CONS_TYPE;
- }
-
- heap_scan_ptr += size;
-
- if(type < HEADER_TYPE)
- dpush(RETAG(obj,type));
- else
- dpush(RETAG(obj,OBJECT_TYPE));
-}
-
-void primitive_end_scan(void)
-{
- heap_scan = false;
-}
-
-void primitive_heap_stats(void)
-{
- int instances[TYPE_COUNT], bytes[TYPE_COUNT];
- int i;
- CELL list = F;
-
- for(i = 0; i < TYPE_COUNT; i++)
- instances[i] = 0;
-
- for(i = 0; i < TYPE_COUNT; i++)
- bytes[i] = 0;
-
- begin_heap_scan();
-
- for(;;)
- {
- CELL size, type;
- heap_step(&size,&type);
-
- if(walk_donep())
- break;
-
- instances[type]++;
- bytes[type] += size;
- }
-
- for(i = TYPE_COUNT - 1; i >= 0; i--)
- {
- list = cons(
- cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
- list);
- }
-
- dpush(list);
-}
+++ /dev/null
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* End of heap when walk was started; prevents infinite loop if
-walk consing */
-CELL heap_scan_end;
-
-/* Begin iterating through the heap. This is not re-entrant. */
-INLINE void begin_heap_scan(void)
-{
- heap_scan_ptr = active.base;
-}
-
-INLINE CELL heap_step(CELL* size, CELL* type)
-{
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
-
- if(headerp(value))
- {
- *size = align8(untagged_object_size(heap_scan_ptr));
- *type = untag_header(value);
- }
- else
- {
- *size = CELLS * 2;
- *type = CONS_TYPE;
- }
-
- heap_scan_ptr += *size;
-
- if(*type < HEADER_TYPE)
- obj = RETAG(obj,*type);
- else
- obj = RETAG(obj,OBJECT_TYPE);
-
- return obj;
-}
-
-INLINE bool walk_donep(void)
-{
- return (heap_scan_ptr >= active.here);
-}
-
-void primitive_heap_stats(void);
-void primitive_instances(void);
-
-void primitive_begin_scan(void);
-void primitive_next_object(void);
-void primitive_end_scan(void);
projects / factor.git / commitdiff