steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

instances word, memory vocabulary

cvs
Slava Pestov 2005-02-15 02:58:07 +00:00
parent 24b2777a89
commit e9c3e62d09
25 changed files with 177 additions and 342 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -22,7 +22,8 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/word.o native/compiler.o \
native/ffi.o native/boolean.o \
native/debug.o \
native/hashtable.o
native/hashtable.o \
native/walk.o
default:
@echo "Run 'make' with one of the following parameters:"

4
TODO.FACTOR.txt
View File

@ -1,5 +1,6 @@
72/73:
- [ [ dup call ] dup call ] infer hangs
- move tuple to generic vocab
- update plugin docs
- extract word keeps indent
@ -20,6 +21,9 @@
- ppc register decls
- rename f* words to stream-*
- port leak
- references primitive
- ditch % for tuples?
- resize window: world not updated until mouse moved
- x>offset
- fix completion invoke in middle of word

2
library/bootstrap/boot-stage2.factor
View File

@ -65,6 +65,7 @@ USING: kernel lists parser stdio words namespaces ;
"/library/io/stdio-binary.factor"
"/library/io/files.factor"
"/library/eval-catch.factor"
"/library/tools/heap-stats.factor"
"/library/tools/listener.factor"
"/library/tools/word-tools.factor"
"/library/test/test.factor"
@ -72,7 +73,6 @@ USING: kernel lists parser stdio words namespaces ;
"/library/tools/telnetd.factor"
"/library/tools/jedit-wire.factor"
"/library/tools/profiler.factor"
"/library/tools/heap-stats.factor"
"/library/gensym.factor"
"/library/tools/interpreter.factor"

51
library/bootstrap/init-stage2.factor
View File

@ -1,50 +1,9 @@
! :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) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel
USE: alien
USE: compiler
USE: errors
USE: inference
USE: command-line
USE: listener
USE: lists
USE: math
USE: namespaces
USE: parser
USE: random
USE: streams
USE: stdio
USE: presentation
USE: words
USE: unparser
USE: kernel-internals
USE: console
USE: assembler
USING: alien compiler errors inference command-line listener
lists math namespaces parser random streams stdio presentation
words unparser kernel-internals console assembler memory ;
: default-cli-args
#! Some flags are *on* by default, unless user specifies

15
library/bootstrap/primitives.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: image
USING: kernel lists math namespaces parser words vectors
USING: kernel lists math memory namespaces parser words vectors
hashtables generic ;
! Bring up a bare cross-compiling vocabulary.
@ -125,9 +125,9 @@ vocabularies get [
[[ "io-internals" "open-file" ]]
[[ "files" "stat" ]]
[[ "files" "(directory)" ]]
[[ "kernel" "garbage-collection" ]]
[[ "kernel" "gc-time" ]]
[[ "kernel" "save-image" ]]
[[ "memory" "garbage-collection" ]]
[[ "memory" "gc-time" ]]
[[ "memory" "save-image" ]]
[[ "kernel" "datastack" ]]
[[ "kernel" "callstack" ]]
[[ "kernel" "set-datastack" ]]
@ -150,7 +150,7 @@ vocabularies get [
[[ "io-internals" "add-copy-io-task" ]]
[[ "io-internals" "pending-io-error" ]]
[[ "io-internals" "next-io-task" ]]
[[ "kernel" "room" ]]
[[ "memory" "room" ]]
[[ "kernel" "os-env" ]]
[[ "kernel" "millis" ]]
[[ "random" "init-random" ]]
@ -162,7 +162,7 @@ vocabularies get [
[[ "assembler" "set-compiled-offset" ]]
[[ "assembler" "literal-top" ]]
[[ "assembler" "set-literal-top" ]]
[[ "kernel" "address" ]]
[[ "memory" "address" ]]
[[ "alien" "dlopen" ]]
[[ "alien" "dlsym" ]]
[[ "alien" "dlclose" ]]
@ -176,7 +176,7 @@ vocabularies get [
[[ "alien" "set-alien-2" ]]
[[ "alien" "alien-1" ]]
[[ "alien" "set-alien-1" ]]
[[ "kernel" "heap-stats" ]]
[[ "memory" "heap-stats" ]]
[[ "errors" "throw" ]]
[[ "kernel-internals" "string>memory" ]]
[[ "kernel-internals" "memory>string" ]]
@ -197,6 +197,7 @@ vocabularies get [
[[ "kernel-internals" "<tuple>" ]]
[[ "kernel-internals" ">array" ]]
[[ "kernel-internals" ">tuple" ]]
[[ "memory" "(instances)" ]]
] [
unswons create swap 1 + [ f define ] keep
] each drop

6
library/compiler/assembler.factor
View File

@ -26,11 +26,7 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: assembler
USE: alien
USE: math
USE: kernel
USE: hashtables
USE: namespaces
USING: alien math memory kernel hashtables namespaces ;
SYMBOL: interned-literals

40
library/compiler/x86/generator.factor
View File

@ -1,40 +1,8 @@
! :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.
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USE: alien
USE: assembler
USE: inference
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
USE: words
USING: alien assembler inference kernel kernel-internals lists
math memory namespaces words ;
\ slot [
PEEK-DS

34
library/compiler/x86/stack.factor
View File

@ -1,37 +1,7 @@
! :folding=none: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: compiler
USE: inference
USE: kernel
USE: assembler
USE: words
USE: lists
USE: alien
USING: inference kernel assembler words lists alien memory ;
: rel-ds ( -- )
#! Add an entry to the relocation table for the 32-bit

3
library/generic/tuple.factor
View File

@ -58,8 +58,7 @@ kernel-internals math hashtables errors vectors ;
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word swap
[ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons
dup predicate-word swap [ swap class eq? ] cons
define-compound ;
: check-shape ( word slots -- )

24
library/httpd/browser-responder.factor
View File

@ -25,27 +25,9 @@
! cont-responder facilities.
!
IN: browser-responder
USE: html
USE: cont-responder
USE: kernel
USE: stdio
USE: namespaces
USE: words
USE: lists
USE: streams
USE: strings
USE: inspector
USE: kernel
USE: prettyprint
USE: words
USE: html
USE: parser
USE: errors
USE: unparser
USE: logging
USE: listener
USE: url-encoding
USE: hashtables
USING: html cont-responder kernel stdio namespaces words lists
streams strings inspector kernel prettyprint words html parser
errors unparser logging listener url-encoding hashtables memory ;
: <browser> ( allow-edit? vocab word -- )
#! An object for storing the current browser

3
library/primitives.factor
View File

@ -7,7 +7,7 @@ DEFER: dll
USING: alien assembler compiler errors files generic
io-internals kernel kernel-internals lists math math-internals
parser profiler random strings unparser vectors words
hashtables ;
hashtables memory ;
[
[ execute " word -- " f ]
@ -187,6 +187,7 @@ hashtables ;
[ <tuple> [ [ number ] [ tuple ] ] ]
[ >array [ [ object ] [ array ] ] ]
[ >tuple [ [ object ] [ tuple ] ] ]
[ (instances) [ [ integer ] [ general-list ] ] ]
] [
2unlist dup string? [
"stack-effect" set-word-property

40
library/syntax/unparser.factor
View File

@ -1,40 +1,8 @@
! :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: unparser
USE: generic
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: stdio
USE: strings
USE: words
USING: generic kernel lists math namespaces parser stdio strings
words memory ;
GENERIC: unparse ( obj -- str )

14
library/test/test.factor
View File

@ -1,18 +1,8 @@
! Factor test suite.
IN: test
USE: errors
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: prettyprint
USE: stdio
USE: strings
USE: words
USE: vectors
USE: unparser
USING: errors kernel lists math memory namespaces parser
prettyprint stdio strings words vectors unparser ;
: assert ( t -- )
[ "Assertion failed!" throw ] unless ;

56
library/tools/heap-stats.factor
View File

@ -1,41 +1,21 @@
! :folding=indent:collapseFolds=1:
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: memory
USING: kernel lists math namespaces prettyprint stdio words
vectors unparser generic ;
! $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.
: kb. 1024 /i unparse write " KB" write ;
IN: listener
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: prettyprint
USE: stdio
USE: words
USE: vectors
USE: unparser
USE: generic
: (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.) ;
: heap-stat. ( type instances bytes -- )
dup 0 = [
@ -49,3 +29,7 @@ USE: generic
: heap-stats. ( -- )
#! Print heap allocation breakdown.
0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ;
: instances ( class -- list )
#! Return a list of all instances of a built-in class.
"builtin-type" word-property (instances) ;

57
library/tools/listener.factor
View File

@ -1,44 +1,8 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 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) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: listener
USE: errors
USE: kernel
USE: lists
USE: math
USE: namespaces
USE: parser
USE: stdio
USE: strings
USE: presentation
USE: words
USE: unparser
USE: vectors
USE: ansi
USING: errors kernel lists math memory namespaces parser stdio
strings presentation words unparser vectors ansi ;
SYMBOL: cont-prompt
SYMBOL: listener-prompt
@ -87,19 +51,6 @@ global [
#! Run a listener loop that executes user input.
quit-flag get [ quit-flag off ] [ listen listener ] ifte ;
: 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.) ;
: print-banner ( -- )
"Factor " write version write
" (OS: " write os write

2
library/tools/word-tools.factor
View File

@ -84,4 +84,4 @@ M: generic word-uses? ( of in -- ? )
: reload ( word -- )
#! Reload the source file the word originated from.
word-file run-resource ;
word-file run-file ;

2
library/vocabularies.factor
View File

@ -78,7 +78,7 @@ IN: words USING: hashtables kernel lists namespaces strings ;
[
"compiler" "debugger" "errors" "files" "generic"
"hashtables" "inference" "interpreter" "jedit" "kernel"
"listener" "lists" "math" "namespaces" "parser"
"listener" "lists" "math" "memory" "namespaces" "parser"
"prettyprint" "processes" "profiler" "streams" "stdio"
"strings" "syntax" "test" "threads" "unparser" "vectors"
"words" "scratchpad"

2
native/debug.c
View File

@ -119,7 +119,7 @@ void print_obj(CELL obj)
switch(type_of(obj))
{
case FIXNUM_TYPE:
fprintf(stderr,"%d",untag_fixnum_fast(obj));
fprintf(stderr,"%ld",untag_fixnum_fast(obj));
break;
case CONS_TYPE:
print_cons(obj);

1
native/factor.h
View File

@ -123,5 +123,6 @@ typedef unsigned char BYTE;
#include "relocate.h"
#include "ffi.h"
#include "debug.h"
#include "walk.h"
#endif /* __FACTOR_H__ */

46
native/memory.c
View File

@ -119,49 +119,3 @@ void primitive_address(void)
{
dpush(tag_bignum(s48_ulong_to_bignum(dpop())));
}
void primitive_heap_stats(void)
{
int instances[TYPE_COUNT], bytes[TYPE_COUNT];
int i;
CELL ptr;
CELL list = F;
for(i = 0; i < TYPE_COUNT; i++)
instances[i] = 0;
for(i = 0; i < TYPE_COUNT; i++)
bytes[i] = 0;
ptr = active.base;
while(ptr < active.here)
{
CELL value = get(ptr);
CELL size;
CELL type;
if(headerp(value))
{
size = align8(untagged_object_size(ptr));
type = untag_header(value);
}
else
{
size = CELLS * 2;
type = CONS_TYPE;
}
instances[type]++;
bytes[type] += size;
ptr += size;
}
for(i = TYPE_COUNT - 1; i >= 0; i--)
{
list = cons(
cons(tag_fixnum(instances[i]),tag_fixnum(bytes[i])),
list);
}
dpush(list);
}

1
native/memory.h
View File

@ -72,4 +72,3 @@ 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_heap_stats(void);

3
native/primitives.c
View File

@ -178,7 +178,8 @@ void* primitives[] = {
primitive_array,
primitive_tuple,
primitive_to_array,
primitive_to_tuple
primitive_to_tuple,
primitive_instances
};
CELL primitive_to_xt(CELL primitive)

2
native/string.h
View File

@ -1,5 +1,3 @@
typedef struct {
CELL header;
/* untagged num of chars */

65
native/walk.c Normal file
View File

@ -0,0 +1,65 @@
#include "factor.h"
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_walk();
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);
}
void primitive_instances(void)
{
CELL list = F;
CELL search_type = to_fixnum(dpop());
CELL here = active.here;
begin_heap_walk();
for(;;)
{
CELL size, type;
CELL obj = heap_step(&size,&type);
if(walk_donep())
break;
/* don't want an infinite loop if we ask for a list of all
conses in the image! */
if(heap_walk_ptr >= here)
break;
if(search_type == type)
list = cons(obj,list);
}
dpush(list);
}

43
native/walk.h Normal file
View File

@ -0,0 +1,43 @@
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
CELL heap_walk_ptr;
/* Begin iterating through the heap. This is not re-entrant. */
INLINE void begin_heap_walk(void)
{
heap_walk_ptr = active.base;
}
INLINE bool heap_step(CELL* size, CELL* type)
{
CELL value = get(heap_walk_ptr);
CELL obj = heap_walk_ptr;
if(headerp(value))
{
*size = align8(untagged_object_size(heap_walk_ptr));
*type = untag_header(value);
}
else
{
*size = CELLS * 2;
*type = CONS_TYPE;
}
heap_walk_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_walk_ptr >= active.here);
}
void primitive_heap_stats(void);
void primitive_instances(void);