Merge branch 'master' of git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-04-08 02:29:14 -05:00
commit 7c9fcc0f46
22 changed files with 185 additions and 68 deletions

View File

@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f ) : value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ; swap [ = nip ] curry assoc-find 2drop ;
: zip ( keys values -- alist )
2array flip ; inline
: search-alist ( key alist -- pair i ) : search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline [ first = ] with find swap ; inline
@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ; M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist ) M: enum >alist ( enum -- alist )
seq>> [ length ] keep 2array flip ; seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ; M: enum assoc-size seq>> length ;

View File

@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
] unit-test ] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test [ t ] [ \ another-forget-accessors-test class? ] unit-test
! Shadowing test
[ f ] [
t parser-notes? [
[
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
] with-string-writer empty?
] with-variable
] unit-test

View File

@ -55,6 +55,9 @@ PRIVATE>
"slot-names" word-prop "slot-names" word-prop
[ dup array? [ second ] when ] map ; [ dup array? [ second ] when ] map ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
<PRIVATE <PRIVATE
: tuple= ( tuple1 tuple2 -- ? ) : tuple= ( tuple1 tuple2 -- ? )
@ -119,9 +122,6 @@ PRIVATE>
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ; dup make-tuple-layout "layout" set-word-prop ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation ) : compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ; >r all-slot-names r> [ index ] curry map ;

View File

@ -59,6 +59,10 @@ ERROR: no-case ;
M: sequence hashcode* M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ; [ sequence-hashcode ] recursive-hashcode ;
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode* M: hashtable hashcode*
[ [
dup assoc-size 1 number= dup assoc-size 1 number=

View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words inference.state generator debugger words compiler.units
compiler.units continuations vocabs assocs alien.compiler dlists continuations vocabs assocs alien.compiler dlists optimizer
optimizer definitions math compiler.errors threads graphs definitions math compiler.errors threads graphs generic
generic inference ; inference ;
IN: compiler IN: compiler
: ripple-up ( word -- ) : ripple-up ( word -- )

View File

@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ; M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
GENERIC: STF ( src dst reg-class -- ) GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ; M: single-float-regs STF drop STFS ;
@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ; M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
GENERIC: LF ( src dst reg-class -- ) GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ; M: single-float-regs LF drop LFS ;

View File

@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq ) : (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved #! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi 2array flip [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset [ live-loc? ] assoc-subset
values ; values ;
@ -421,7 +421,7 @@ M: loc lazy-store
: slow-shuffle-mapping ( locs tmp -- pairs ) : slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r> >r dup length r>
[ swap - <ds-loc> ] curry map 2array flip ; [ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- ) : slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle #! We don't have enough free registers to load all shuffle

View File

@ -373,7 +373,7 @@ set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect \ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable \ data-room make-flushable
\ code-room { } { integer integer } <effect> set-primitive-effect \ code-room { } { integer integer integer integer } <effect> set-primitive-effect
\ code-room make-flushable \ code-room make-flushable
\ os-env { string } { object } <effect> set-primitive-effect \ os-env { string } { object } <effect> set-primitive-effect

View File

@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
M: mirror >alist ( mirror -- alist ) M: mirror >alist ( mirror -- alist )
>mirror< >mirror<
[ [ slot-spec-offset slot ] with map ] keep [ [ slot-spec-offset slot ] with map ] keep
[ slot-spec-name ] map swap 2array flip ; [ slot-spec-name ] map swap zip ;
M: mirror assoc-size mirror-slots length ; M: mirror assoc-size mirror-slots length ;

View File

@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ; HINTS: recursive-inline-hang-3 array ;
! Regression
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test

View File

@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
{ $subsection parse-file } { $subsection parse-file }
{ $subsection bootstrap-file } { $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions." "The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
$nl
"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
{ $see-also "source-files" } ; { $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage" ARTICLE: "parser-usage" "Reflective parser usage"
@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can also parse from a stream:" "The parser can also parse from a stream:"
{ $subsection parse-stream } ; { $subsection parse-stream } ;
ARTICLE: "top-level-forms" "Top level forms"
"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
$nl
"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
$nl
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
ARTICLE: "parser" "The parser" ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies." "This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl $nl
@ -168,6 +177,7 @@ $nl
{ $subsection "vocabulary-search" } { $subsection "vocabulary-search" }
{ $subsection "parser-files" } { $subsection "parser-files" }
{ $subsection "parser-usage" } { $subsection "parser-usage" }
{ $subsection "top-level-forms" }
"The parser can be extended." "The parser can be extended."
{ $subsection "parsing-words" } { $subsection "parsing-words" }
{ $subsection "parser-lexer" } { $subsection "parser-lexer" }

View File

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math USING: arrays definitions generic assocs kernel math namespaces
namespaces prettyprint sequences strings vectors words prettyprint sequences strings vectors words quotations inspector
quotations inspector io.styles io combinators sorting io.styles io combinators sorting splitting math.parser effects
splitting math.parser effects continuations debugger continuations debugger io.files io.streams.string vocabs
io.files io.streams.string vocabs io.encodings.utf8 io.encodings.utf8 source-files classes classes.tuple hashtables
source-files classes hashtables compiler.errors compiler.units compiler.errors compiler.units accessors ;
accessors ;
IN: parser IN: parser
TUPLE: lexer text line line-text line-length column ; TUPLE: lexer text line line-text line-length column ;
@ -285,13 +284,27 @@ M: no-word-error summary
: CREATE-METHOD ( -- method ) : CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ; scan-word bootstrap-word scan-word create-method-in ;
: shadowed-slots ( superclass slots -- shadowed )
>r all-slot-names r> seq-intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
[
"Definition of slot ``" %
%
"'' in class ``" %
word-name %
"'' shadows a superclass slot" %
] "" make note.
] with each ;
: parse-tuple-definition ( -- class superclass slots ) : parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS CREATE-CLASS
scan { scan {
{ ";" [ tuple f ] } { ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] } { "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> prefix ] [ >r tuple ";" parse-tokens r> prefix ]
} case ; } case 3dup check-slot-shadowing ;
ERROR: staging-violation word ; ERROR: staging-violation word ;

View File

@ -1,6 +1,6 @@
USING: arrays kernel math namespaces sequences kernel.private USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays sequences.private strings sbufs tools.test vectors bit-arrays
generic ; generic vocabs.loader ;
IN: sequences.tests IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test [ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
@ -100,6 +100,16 @@ unit-test
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test [ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
[ "blah" ] [ "blahxx" 2 head* ] unit-test
[ "xx" ] [ "blahxx" 2 tail* ] unit-test
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test [ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test [ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test [ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
@ -195,6 +205,12 @@ unit-test
! Pathological case ! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test [ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
[ -10 "hi" "bye" copy ] must-fail [ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail [ 10 "hi" "bye" copy ] must-fail
@ -244,3 +260,5 @@ unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
! Hardcore
[ ] [ "sequences" reload ] unit-test

View File

@ -172,7 +172,9 @@ TUPLE: reversed seq ;
C: <reversed> reversed C: <reversed> reversed
M: reversed virtual-seq reversed-seq ; M: reversed virtual-seq reversed-seq ;
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ; M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
M: reversed length reversed-seq length ; M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence INSTANCE: reversed virtual-sequence
@ -198,7 +200,9 @@ ERROR: slice-error reason ;
slice construct-boa ; inline slice construct-boa ; inline
M: slice virtual-seq slice-seq ; M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ; M: slice virtual@ [ slice-from + ] keep slice-seq ;
M: slice length dup slice-to swap slice-from - ; M: slice length dup slice-to swap slice-from - ;
: head-slice ( seq n -- slice ) (head) <slice> ; : head-slice ( seq n -- slice ) (head) <slice> ;
@ -466,6 +470,21 @@ M: sequence <=>
2dup [ length ] bi@ number= 2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline [ mismatch not ] [ 2drop f ] if ; inline
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum sequence-hashcode-step
] with each ; inline
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- ) : move ( to from seq -- )
2over number= 2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
@ -692,14 +711,3 @@ PRIVATE>
dup [ length ] map infimum dup [ length ] map infimum
[ <column> dup like ] with map [ <column> dup like ] with map
] unless ; ] unless ;
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum sequence-hashcode-step
] with each ; inline

View File

@ -37,9 +37,6 @@ IN: assocs.lib
: insert ( value variable -- ) namespace insert-at ; : insert ( value variable -- ) namespace insert-at ;
: 2seq>assoc ( keys values exemplar -- assoc )
>r 2array flip r> assoc-like ;
: generate-key ( assoc -- str ) : generate-key ( assoc -- str )
>r 256 random-bits >hex r> >r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ; 2dup key? [ nip generate-key ] [ drop ] if ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Chris Double. ! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser vectors arrays math.parser
unicode.categories sequences.lib compiler.units parser unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ; words quotations effects memoize accessors locals effects splitting ;
IN: peg IN: peg

View File

@ -4,7 +4,7 @@
USING: combinators.lib kernel sequences math namespaces assocs USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros arrays math.parser math.private sorting strings ascii macros
assocs.lib quotations ; assocs.lib quotations hashtables ;
IN: sequences.lib IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline : each-withn ( seq quot n -- ) nwith each ; inline
@ -231,7 +231,7 @@ PRIVATE>
[ swap nth ] with map ; [ swap nth ] with map ;
: replace ( str oldseq newseq -- str' ) : replace ( str oldseq newseq -- str' )
H{ } 2seq>assoc substitute ; zip >hashtable substitute ;
: remove-nth ( seq n -- seq' ) : remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ; cut-slice 1 tail-slice append ;

View File

@ -1,4 +1,8 @@
USING: tools.test tools.memory ; USING: tools.test tools.memory ;
IN: tools.memory.tests IN: tools.memory.tests
\ room. must-infer
[ ] [ room. ] unit-test
\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test [ ] [ heap-stats. ] unit-test

View File

@ -1,22 +1,29 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words namespaces parser prettyprint strings io.styles vectors words
system sorting splitting math.parser classes memory ; system sorting splitting math.parser classes memory combinators ;
IN: tools.memory IN: tools.memory
<PRIVATE
: write-size ( n -- )
number>string
dup length 4 > [ 3 cut* "," swap 3append ] when
" KB" append write-cell ;
: write-total/used/free ( free total str -- ) : write-total/used/free ( free total str -- )
[ [
write-cell write-cell
dup number>string write-cell dup write-size
over - number>string write-cell over - write-size
number>string write-cell write-size
] with-row ; ] with-row ;
: write-total ( n str -- ) : write-total ( n str -- )
[ [
write-cell write-cell
number>string write-cell write-size
[ ] with-cell [ ] with-cell
[ ] with-cell [ ] with-cell
] with-row ; ] with-row ;
@ -25,26 +32,41 @@ IN: tools.memory
[ [ write-cell ] each ] with-row ; [ [ write-cell ] each ] with-row ;
: (data-room.) ( -- ) : (data-room.) ( -- )
data-room 2 <groups> 0 [ data-room 2 <groups> dup length [
"Generation " pick number>string append [ first2 ] [ number>string "Generation " prepend ] bi*
>r first2 r> write-total/used/free 1+ write-total/used/free
] reduce drop ] 2each
"Cards" write-total ; "Cards" write-total ;
: (code-room.) ( -- ) : write-labelled-size ( n string -- )
code-room "Code space" write-total/used/free ; [ write-cell write-size ] with-row ;
: room. ( -- ) : (code-room.) ( -- )
standard-table-style [ code-room {
{ "" "Total" "Used" "Free" } write-headings [ "Size:" write-labelled-size ]
(data-room.) [ "Used:" write-labelled-size ]
(code-room.) [ "Total free space:" write-labelled-size ]
] tabular-output ; [ "Largest free block:" write-labelled-size ]
} spread ;
: heap-stat-step ( counts sizes obj -- ) : heap-stat-step ( counts sizes obj -- )
[ dup size swap class rot at+ ] keep [ dup size swap class rot at+ ] keep
1 swap class rot at+ ; 1 swap class rot at+ ;
PRIVATE>
: room. ( -- )
"==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
] tabular-output ;
: heap-stats ( -- counts sizes ) : heap-stats ( -- counts sizes )
H{ } clone H{ } clone H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ; [ >r 2dup r> heap-stat-step ] each-object ;

View File

@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
build_free_list(heap,heap->segment->size); build_free_list(heap,heap->segment->size);
} }
/* Compute total sum of sizes of free blocks */ /* Compute total sum of sizes of free blocks, and size of largest free block */
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status) void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{ {
CELL size = 0; *used = 0;
*total_free = 0;
*max_free = 0;
F_BLOCK *scan = first_block(heap); F_BLOCK *scan = first_block(heap);
while(scan) while(scan)
{ {
if(scan->status == status) switch(scan->status)
size += scan->size; {
scan = next_block(heap,scan); case B_ALLOCATED:
*used += scan->size;
break;
case B_FREE:
*total_free += scan->size;
if(scan->size > *max_free)
*max_free = scan->size;
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
} }
return size; scan = next_block(heap,scan);
}
} }
/* The size of the heap, not including the last block if it's free */ /* The size of the heap, not including the last block if it's free */
@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block)
/* Push the free space and total size of the code heap */ /* Push the free space and total size of the code heap */
DEFINE_PRIMITIVE(code_room) DEFINE_PRIMITIVE(code_room)
{ {
dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024)); CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024)); dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
} }
/* Dump all code blocks for debugging */ /* Dump all code blocks for debugging */

View File

@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
CELL heap_allot(F_HEAP *heap, CELL size); CELL heap_allot(F_HEAP *heap, CELL size);
void unmark_marked(F_HEAP *heap); void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap); void free_unmarked(F_HEAP *heap);
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status); void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap); CELL heap_size(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block) INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)

View File

@ -229,8 +229,17 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */ /* Insufficient room even after code GC, give up */
if(start == 0) if(start == 0)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
fprintf(stderr,"Code heap stats:\n");
fprintf(stderr,"Used: %ld\n",used);
fprintf(stderr,"Total free space: %ld\n",total_free);
fprintf(stderr,"Largest free block: %ld\n",max_free);
fatal_error("Out of memory in add-compiled-block",0); fatal_error("Out of memory in add-compiled-block",0);
} }
}
return start; return start;
} }