Merge branch 'master' of git://factorcode.org/git/factor
commit
7c9fcc0f46
|
@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
|
|||
: value-at ( value assoc -- key/f )
|
||||
swap [ = nip ] curry assoc-find 2drop ;
|
||||
|
||||
: zip ( keys values -- alist )
|
||||
2array flip ; inline
|
||||
|
||||
: search-alist ( key alist -- pair i )
|
||||
[ 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 >alist ( enum -- alist )
|
||||
seq>> [ length ] keep 2array flip ;
|
||||
seq>> [ length ] keep zip ;
|
||||
|
||||
M: enum assoc-size seq>> length ;
|
||||
|
||||
|
|
|
@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
|
|||
] 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
|
||||
|
|
|
@ -55,6 +55,9 @@ PRIVATE>
|
|||
"slot-names" word-prop
|
||||
[ dup array? [ second ] when ] map ;
|
||||
|
||||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class prefix ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
|
@ -119,9 +122,6 @@ PRIVATE>
|
|||
: define-tuple-layout ( class -- )
|
||||
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 )
|
||||
>r all-slot-names r> [ index ] curry map ;
|
||||
|
||||
|
|
|
@ -59,6 +59,10 @@ ERROR: no-case ;
|
|||
M: sequence hashcode*
|
||||
[ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
|
||||
|
||||
M: hashtable hashcode*
|
||||
[
|
||||
dup assoc-size 1 number=
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces arrays sequences io inference.backend
|
||||
inference.state generator debugger math.parser prettyprint words
|
||||
compiler.units continuations vocabs assocs alien.compiler dlists
|
||||
optimizer definitions math compiler.errors threads graphs
|
||||
generic inference ;
|
||||
inference.state generator debugger words compiler.units
|
||||
continuations vocabs assocs alien.compiler dlists optimizer
|
||||
definitions math compiler.errors threads graphs generic
|
||||
inference ;
|
||||
IN: compiler
|
||||
|
||||
: ripple-up ( word -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
GENERIC: STF ( src dst reg-class -- )
|
||||
GENERIC: STF ( src dst off reg-class -- )
|
||||
|
||||
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 ;
|
||||
|
||||
GENERIC: LF ( src dst reg-class -- )
|
||||
GENERIC: LF ( dst src off reg-class -- )
|
||||
|
||||
M: single-float-regs LF drop LFS ;
|
||||
|
||||
|
|
|
@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
|
|||
|
||||
: (live-locs) ( phantom -- seq )
|
||||
#! Discard locs which haven't moved
|
||||
[ phantom-locs* ] [ stack>> ] bi 2array flip
|
||||
[ phantom-locs* ] [ stack>> ] bi zip
|
||||
[ live-loc? ] assoc-subset
|
||||
values ;
|
||||
|
||||
|
@ -421,7 +421,7 @@ M: loc lazy-store
|
|||
|
||||
: slow-shuffle-mapping ( locs tmp -- pairs )
|
||||
>r dup length r>
|
||||
[ swap - <ds-loc> ] curry map 2array flip ;
|
||||
[ swap - <ds-loc> ] curry map zip ;
|
||||
|
||||
: slow-shuffle ( locs -- )
|
||||
#! We don't have enough free registers to load all shuffle
|
||||
|
|
|
@ -373,7 +373,7 @@ set-primitive-effect
|
|||
\ data-room { } { integer array } <effect> set-primitive-effect
|
||||
\ 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
|
||||
|
||||
\ os-env { string } { object } <effect> set-primitive-effect
|
||||
|
|
|
@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
|
|||
M: mirror >alist ( mirror -- alist )
|
||||
>mirror<
|
||||
[ [ 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 ;
|
||||
|
||||
|
|
|
@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
|
|||
|
||||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
! Regression
|
||||
USE: sequences.private
|
||||
|
||||
[ ] [ { (3append) } compile ] unit-test
|
||||
|
|
|
@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
|
|||
{ $subsection parse-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."
|
||||
$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" } ;
|
||||
|
||||
ARTICLE: "parser-usage" "Reflective parser usage"
|
||||
|
@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
|
|||
"The parser can also parse from a 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"
|
||||
"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
|
||||
|
@ -168,6 +177,7 @@ $nl
|
|||
{ $subsection "vocabulary-search" }
|
||||
{ $subsection "parser-files" }
|
||||
{ $subsection "parser-usage" }
|
||||
{ $subsection "top-level-forms" }
|
||||
"The parser can be extended."
|
||||
{ $subsection "parsing-words" }
|
||||
{ $subsection "parser-lexer" }
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions generic assocs kernel math
|
||||
namespaces prettyprint sequences strings vectors words
|
||||
quotations inspector io.styles io combinators sorting
|
||||
splitting math.parser effects continuations debugger
|
||||
io.files io.streams.string vocabs io.encodings.utf8
|
||||
source-files classes hashtables compiler.errors compiler.units
|
||||
accessors ;
|
||||
USING: arrays definitions generic assocs kernel math namespaces
|
||||
prettyprint sequences strings vectors words quotations inspector
|
||||
io.styles io combinators sorting splitting math.parser effects
|
||||
continuations debugger io.files io.streams.string vocabs
|
||||
io.encodings.utf8 source-files classes classes.tuple hashtables
|
||||
compiler.errors compiler.units accessors ;
|
||||
IN: parser
|
||||
|
||||
TUPLE: lexer text line line-text line-length column ;
|
||||
|
@ -285,13 +284,27 @@ M: no-word-error summary
|
|||
: CREATE-METHOD ( -- method )
|
||||
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 )
|
||||
CREATE-CLASS
|
||||
scan {
|
||||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word ";" parse-tokens ] }
|
||||
[ >r tuple ";" parse-tokens r> prefix ]
|
||||
} case ;
|
||||
} case 3dup check-slot-shadowing ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel math namespaces sequences kernel.private
|
||||
sequences.private strings sbufs tools.test vectors bit-arrays
|
||||
generic ;
|
||||
generic vocabs.loader ;
|
||||
IN: sequences.tests
|
||||
|
||||
[ 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
|
||||
[ [ 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
|
||||
|
@ -195,6 +205,12 @@ unit-test
|
|||
! Pathological case
|
||||
[ "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
|
||||
|
||||
|
@ -244,3 +260,5 @@ unit-test
|
|||
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
|
||||
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
|
||||
|
||||
! Hardcore
|
||||
[ ] [ "sequences" reload ] unit-test
|
||||
|
|
|
@ -172,7 +172,9 @@ TUPLE: reversed seq ;
|
|||
C: <reversed> reversed
|
||||
|
||||
M: reversed virtual-seq reversed-seq ;
|
||||
|
||||
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
|
||||
|
||||
M: reversed length reversed-seq length ;
|
||||
|
||||
INSTANCE: reversed virtual-sequence
|
||||
|
@ -198,7 +200,9 @@ ERROR: slice-error reason ;
|
|||
slice construct-boa ; inline
|
||||
|
||||
M: slice virtual-seq slice-seq ;
|
||||
|
||||
M: slice virtual@ [ slice-from + ] keep slice-seq ;
|
||||
|
||||
M: slice length dup slice-to swap slice-from - ;
|
||||
|
||||
: head-slice ( seq n -- slice ) (head) <slice> ;
|
||||
|
@ -466,6 +470,21 @@ M: sequence <=>
|
|||
2dup [ length ] bi@ number=
|
||||
[ 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 -- )
|
||||
2over number=
|
||||
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
||||
|
@ -692,14 +711,3 @@ PRIVATE>
|
|||
dup [ length ] map infimum
|
||||
[ <column> dup like ] with map
|
||||
] 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
|
||||
|
|
|
@ -37,9 +37,6 @@ IN: assocs.lib
|
|||
|
||||
: insert ( value variable -- ) namespace insert-at ;
|
||||
|
||||
: 2seq>assoc ( keys values exemplar -- assoc )
|
||||
>r 2array flip r> assoc-like ;
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
>r 256 random-bits >hex r>
|
||||
2dup key? [ nip generate-key ] [ drop ] if ;
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences strings fry namespaces math assocs shuffle
|
||||
vectors arrays combinators.lib math.parser
|
||||
unicode.categories sequences.lib compiler.units parser
|
||||
vectors arrays math.parser
|
||||
unicode.categories compiler.units parser
|
||||
words quotations effects memoize accessors locals effects splitting ;
|
||||
IN: peg
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
USING: combinators.lib kernel sequences math namespaces assocs
|
||||
random sequences.private shuffle math.functions mirrors
|
||||
arrays math.parser math.private sorting strings ascii macros
|
||||
assocs.lib quotations ;
|
||||
assocs.lib quotations hashtables ;
|
||||
IN: sequences.lib
|
||||
|
||||
: each-withn ( seq quot n -- ) nwith each ; inline
|
||||
|
@ -231,7 +231,7 @@ PRIVATE>
|
|||
[ swap nth ] with map ;
|
||||
|
||||
: replace ( str oldseq newseq -- str' )
|
||||
H{ } 2seq>assoc substitute ;
|
||||
zip >hashtable substitute ;
|
||||
|
||||
: remove-nth ( seq n -- seq' )
|
||||
cut-slice 1 tail-slice append ;
|
||||
|
|
|
@ -1,4 +1,8 @@
|
|||
USING: tools.test tools.memory ;
|
||||
IN: tools.memory.tests
|
||||
|
||||
\ room. must-infer
|
||||
[ ] [ room. ] unit-test
|
||||
|
||||
\ heap-stats. must-infer
|
||||
[ ] [ heap-stats. ] unit-test
|
||||
|
|
|
@ -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.
|
||||
USING: kernel sequences vectors arrays generic assocs io math
|
||||
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
|
||||
|
||||
<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-cell
|
||||
dup number>string write-cell
|
||||
over - number>string write-cell
|
||||
number>string write-cell
|
||||
dup write-size
|
||||
over - write-size
|
||||
write-size
|
||||
] with-row ;
|
||||
|
||||
: write-total ( n str -- )
|
||||
[
|
||||
write-cell
|
||||
number>string write-cell
|
||||
write-size
|
||||
[ ] with-cell
|
||||
[ ] with-cell
|
||||
] with-row ;
|
||||
|
@ -25,26 +32,41 @@ IN: tools.memory
|
|||
[ [ write-cell ] each ] with-row ;
|
||||
|
||||
: (data-room.) ( -- )
|
||||
data-room 2 <groups> 0 [
|
||||
"Generation " pick number>string append
|
||||
>r first2 r> write-total/used/free 1+
|
||||
] reduce drop
|
||||
data-room 2 <groups> dup length [
|
||||
[ first2 ] [ number>string "Generation " prepend ] bi*
|
||||
write-total/used/free
|
||||
] 2each
|
||||
"Cards" write-total ;
|
||||
|
||||
: (code-room.) ( -- )
|
||||
code-room "Code space" write-total/used/free ;
|
||||
: write-labelled-size ( n string -- )
|
||||
[ write-cell write-size ] with-row ;
|
||||
|
||||
: room. ( -- )
|
||||
standard-table-style [
|
||||
{ "" "Total" "Used" "Free" } write-headings
|
||||
(data-room.)
|
||||
(code-room.)
|
||||
] tabular-output ;
|
||||
: (code-room.) ( -- )
|
||||
code-room {
|
||||
[ "Size:" write-labelled-size ]
|
||||
[ "Used:" write-labelled-size ]
|
||||
[ "Total free space:" write-labelled-size ]
|
||||
[ "Largest free block:" write-labelled-size ]
|
||||
} spread ;
|
||||
|
||||
: heap-stat-step ( counts sizes obj -- )
|
||||
[ dup size swap class rot at+ ] keep
|
||||
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 )
|
||||
H{ } clone H{ } clone
|
||||
[ >r 2dup r> heap-stat-step ] each-object ;
|
||||
|
|
33
vm/code_gc.c
33
vm/code_gc.c
|
@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
|
|||
build_free_list(heap,heap->segment->size);
|
||||
}
|
||||
|
||||
/* Compute total sum of sizes of free blocks */
|
||||
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
|
||||
/* Compute total sum of sizes of free blocks, and size of largest free block */
|
||||
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);
|
||||
|
||||
while(scan)
|
||||
{
|
||||
if(scan->status == status)
|
||||
size += scan->size;
|
||||
switch(scan->status)
|
||||
{
|
||||
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);
|
||||
}
|
||||
|
||||
scan = next_block(heap,scan);
|
||||
}
|
||||
|
||||
return size;
|
||||
}
|
||||
|
||||
/* 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 */
|
||||
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(used / 1024));
|
||||
dpush(tag_fixnum(total_free / 1024));
|
||||
dpush(tag_fixnum(max_free / 1024));
|
||||
}
|
||||
|
||||
/* Dump all code blocks for debugging */
|
||||
|
|
|
@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
|
|||
CELL heap_allot(F_HEAP *heap, CELL size);
|
||||
void unmark_marked(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);
|
||||
|
||||
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
|
||||
|
|
|
@ -229,7 +229,16 @@ CELL allot_code_block(CELL size)
|
|||
|
||||
/* Insufficient room even after code GC, give up */
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
return start;
|
||||
|
|
Loading…
Reference in New Issue