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

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

db4
Joe Groff 2009-04-26 09:39:48 -05:00
parent d2e293eb5e cc44597ea7
commit 0f09d0ef2e
36 changed files with 220 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/calendar/calendar-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ;
continuations system math.order threads accessors ;
IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -163,3 +163,10 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test

64
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators combinators.short-circuit
kernel locals math math.functions math.order namespaces sequences strings
summary system threads vocabs.loader ;
USING: accessors arrays classes.tuple combinators
combinators.short-circuit kernel locals math math.functions
math.order sequences summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
[let* | a [ 14 month - 12 /i ]
y [ year 4800 + a - ]
m [ month 12 a * + 3 - ] |
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 -
] ;
14 month - 12 /i :> a
year 4800 + a - :> y
month 12 a * + 3 - :> m
day 153 m * 2 + 5 /i + 365 y * +
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
[let* | a [ n 32044 + ]
b [ 4 a * 3 + 146097 /i ]
c [ a 146097 b * 4 /i - ]
d [ 4 c * 3 + 1461 /i ]
e [ c 1461 d * 4 /i - ]
m [ 5 e * 2 + 153 /i ] |
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+
] ;
n 32044 + :> a
4 a * 3 + 146097 /i :> b
a 146097 b * 4 /i - :> c
4 c * 3 + 1461 /i :> d
c 1461 d * 4 /i - :> e
5 e * 2 + 153 /i :> m
100 b * d + 4800 -
m 10 /i + m 3 +
12 m 10 /i * -
e 153 m * 2 + 5 /i - 1+ ;
GENERIC: easter ( obj -- obj' )
:: easter-month-day ( year -- month day )
year 19 mod :> a
year 100 /mod :> c :> b
b 4 /mod :> e :> d
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
c 4 /mod :> k :> i
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
month day ;
M: integer easter ( year -- timestamp )
dup easter-month-day <date> ;
M: timestamp easter ( timestamp -- timestamp )
clone
dup year>> easter-month-day
swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ;

2
basis/compiler/tests/alien.factor
View File

@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
specialized-arrays.float alien.libraries io.pathnames
io.backend ;
IN: compiler.tests
IN: compiler.tests.alien
<<
: libfactor-ffi-tests-path ( -- string )

4
basis/compiler/tests/codegen.factor
View File

@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
IN: compiler.tests
IN: compiler.tests.codegen
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
@ -281,4 +281,4 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

2
basis/compiler/tests/curry.factor
View File

@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units compiler ;
IN: compiler.tests
IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

2
basis/compiler/tests/float.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;

2
basis/compiler/tests/folding.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.folding
! Calls to generic words were not folded away.

2
basis/compiler/tests/intrinsics.factor
View File

@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii
classes compiler ;
IN: compiler.tests
IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

2
basis/compiler/tests/optimizer.factor
View File

@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler ;
IN: optimizer.tests
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;

4
basis/compiler/tests/peg-regression-2.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
;EBNF
[ "foo" ] [ "a" parse-regexp ] unit-test
[ "foo" ] [ "a" parse-regexp ] unit-test

2
basis/compiler/tests/peg-regression.factor
View File

@ -5,7 +5,7 @@
! end of a compilation unit.
USING: kernel accessors peg.ebnf ;
IN: compiler.tests
IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ;

2
basis/compiler/tests/redefine0.factor
View File

@ -104,4 +104,4 @@ quot global delete-at
\ test-11 forget
\ quot forget
] with-compilation-unit
] unit-test
] unit-test

6
basis/compiler/tests/redefine1.factor
View File

@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ;
IN: compiler.tests
IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b )
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test

2
basis/compiler/tests/redefine10.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine11.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
IN: compiler.tests
IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine15.factor
View File

@ -17,4 +17,4 @@ DEFER: word-1
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
[ 2 3 ] [ 0 word-4 ] unit-test
[ 2 3 ] [ 0 word-4 ] unit-test

4
basis/compiler/tests/redefine2.factor
View File

@ -1,11 +1,11 @@
IN: compiler.tests
IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

4
basis/compiler/tests/redefine4.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

2
basis/compiler/tests/redefine5.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded.

2
basis/compiler/tests/redefine6.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine7.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine8.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
IN: compiler.tests
IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/redefine9.factor
View File

@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
IN: compiler.tests
IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words.

2
basis/compiler/tests/reload.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.reload
USE: vocabs.loader
! "parser" reload

2
basis/compiler/tests/simple.factor
View File

@ -1,7 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test

2
basis/compiler/tests/spilling.factor
View File

@ -1,6 +1,6 @@
USING: math.private kernel combinators accessors arrays
generalizations tools.test ;
IN: compiler.tests
IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{

2
basis/compiler/tests/stack-trace.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;

2
basis/compiler/tests/tuples.factor
View File

@ -1,4 +1,4 @@
IN: compiler.tests
IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;

2
basis/listener/listener.factor
View File

@ -62,6 +62,8 @@ SYMBOL: max-stack-items
SYMBOL: error-summary?
t error-summary? set-global
<PRIVATE
: title. ( string -- )

8
extra/benchmark/fasta/fasta.factor
View File

@ -46,8 +46,8 @@ CONSTANT: homo-sapiens
}
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
swap values >double-array unclip [ + ] accumulate swap suffix ;
[ keys >byte-array ]
[ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
@ -55,7 +55,7 @@ CONSTANT: homo-sapiens
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
[ rot drop select-random ] 2curry B{ } map-as print ; inline
[ rot drop select-random ] 2curry "" map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
@ -71,7 +71,7 @@ CONSTANT: homo-sapiens
:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
len [ k + kn mod alu nth-unsafe ] "" map-as print
k len +
] ; inline

3
extra/morse/morse-tests.factor
View File

@ -3,7 +3,7 @@
USING: arrays morse strings tools.test ;
IN: morse.tests
[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
[ "?" ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
@ -41,3 +41,4 @@ IN: morse.tests
MORSE] ] unit-test
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
! [ ] [ "\n" play-as-morse ] unit-test

11
extra/morse/morse.factor
View File

@ -3,13 +3,15 @@
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse
ERROR: no-morse-code ch ;
<PRIVATE
CONSTANT: dot-char CHAR: .
CONSTANT: dash-char CHAR: -
CONSTANT: char-gap-char CHAR: \s
CONSTANT: word-gap-char CHAR: /
CONSTANT: unknown-char CHAR: ?
CONSTANT: unknown-char "?"
PRIVATE>
@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[
]
: ch>morse ( ch -- morse )
ch>lower morse-code-table at [ unknown-char ] unless* ;
ch>lower morse-code-table at unknown-char or ;
: morse>ch ( str -- ch )
morse-code-table value-at [ char-gap-char ] unless* ;
morse-code-table value-at char-gap-char or ;
<PRIVATE
@ -148,12 +150,13 @@ CONSTANT: beep-freq 880
source get source-play
] with-scope ; inline
: play-char ( ch -- )
: play-char ( string -- )
[ intra-char-gap ] [
{
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
[ drop intra-char-gap ]
} case
] interleave ;

166
vm/code_gc.c
View File

@ -1,5 +1,10 @@
#include "master.h"
static void clear_free_list(F_HEAP *heap)
{
memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST));
}
/* This malloc-style heap code is reasonably generic. Maybe in the future, it
will be used for the data heap too, if we ever get incremental
mark/sweep/compact GC. */
@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size)
heap->segment = alloc_segment(align_page(size));
if(!heap->segment)
fatal_error("Out of memory in new_heap",size);
heap->free_list = NULL;
clear_free_list(heap);
}
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
{
if(prev)
prev->next_free = next_free;
if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = block->block.size / BLOCK_SIZE_INCREMENT;
block->next_free = heap->free.small[index];
heap->free.small[index] = block;
}
else
heap->free_list = next_free;
{
block->next_free = heap->free.large;
heap->free.large = block;
}
}
/* Called after reading the code heap from the image file, and after code GC.
@ -28,7 +39,11 @@ compiling.limit. */
void build_free_list(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_FREE_BLOCK *prev_free = NULL;
clear_free_list(heap);
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
F_BLOCK *scan = first_block(heap);
F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size)
switch(scan->status)
{
case B_FREE:
update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
prev_free = (F_FREE_BLOCK *)scan;
add_to_free_list(heap,(F_FREE_BLOCK *)scan);
break;
case B_ALLOCATED:
break;
@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size)
{
end->block.status = B_FREE;
end->block.size = heap->segment->end - (CELL)end;
end->next_free = NULL;
/* add final free block */
update_free_list(heap,prev_free,end);
add_to_free_list(heap,end);
}
/* This branch is taken if the newly loaded image fits exactly, or
after code GC */
@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size)
/* even if there's no room at the end of the heap for a new
free block, we might have to jigger it up by a few bytes in
case prev + prev->size */
if(prev)
prev->size = heap->segment->end - (CELL)prev;
/* this is the last free block */
update_free_list(heap,prev_free,NULL);
if(prev) prev->size = heap->segment->end - (CELL)prev;
}
}
static void assert_free_block(F_FREE_BLOCK *block)
{
if(block->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)block);
}
F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
{
CELL attempt = size;
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
{
int index = attempt / BLOCK_SIZE_INCREMENT;
F_FREE_BLOCK *block = heap->free.small[index];
if(block)
{
assert_free_block(block);
heap->free.small[index] = block->next_free;
return block;
}
attempt *= 2;
}
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *block = heap->free.large;
while(block)
{
assert_free_block(block);
if(block->block.size >= size)
{
if(prev)
prev->next_free = block->next_free;
else
heap->free.large = block->next_free;
return block;
}
prev = block;
block = block->next_free;
}
return NULL;
}
F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
{
if(block->block.size != size )
{
/* split the block in two */
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size);
split->block.status = B_FREE;
split->block.size = block->block.size - size;
split->next_free = block->next_free;
block->block.size = size;
add_to_free_list(heap,split);
}
return block;
}
/* Allocate a block of memory from the mark and sweep GC heap */
F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
{
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *scan = heap->free_list;
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
size = (size + 31) & ~31;
while(scan)
F_FREE_BLOCK *block = find_free_block(heap,size);
if(block)
{
if(scan->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)scan);
block = split_free_block(heap,block,size);
if(scan->block.size < size)
{
prev = scan;
scan = scan->next_free;
continue;
}
/* we found a candidate block */
F_FREE_BLOCK *next_free;
if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
{
/* too small to be split */
next_free = scan->next_free;
}
else
{
/* split the block in two */
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
split->block.status = B_FREE;
split->block.size = scan->block.size - size;
split->next_free = scan->next_free;
scan->block.size = size;
next_free = split;
}
/* update the free list */
update_free_list(heap,prev,next_free);
/* this is our new block */
scan->block.status = B_ALLOCATED;
return &scan->block;
block->block.status = B_ALLOCATED;
return &block->block;
}
return NULL;
else
return NULL;
}
void mark_block(F_BLOCK *block)
@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap)
/* After code GC, all referenced code blocks have status set to B_MARKED, so any
which are allocated and not marked can be reclaimed. */
void free_unmarked(F_HEAP *heap)
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter)
{
clear_free_list(heap);
F_BLOCK *prev = NULL;
F_BLOCK *scan = first_block(heap);
@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap)
case B_FREE:
if(prev && prev->status == B_FREE)
prev->size += scan->size;
else
prev = scan;
break;
case B_MARKED:
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
scan->status = B_ALLOCATED;
prev = scan;
iter(scan);
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap)
scan = next_block(heap,scan);
}
build_free_list(heap,heap->segment->size);
if(prev && prev->status == B_FREE)
add_to_free_list(heap,(F_FREE_BLOCK *)prev);
}
/* Compute total sum of sizes of free blocks, and size of largest free block */

14
vm/code_gc.h
View File

@ -1,14 +1,24 @@
#define FREE_LIST_COUNT 16
#define BLOCK_SIZE_INCREMENT 32
typedef struct {
F_FREE_BLOCK *small[FREE_LIST_COUNT];
F_FREE_BLOCK *large;
} F_HEAP_FREE_LIST;
typedef struct {
F_SEGMENT *segment;
F_FREE_BLOCK *free_list;
F_HEAP_FREE_LIST free;
} F_HEAP;
typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled);
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
CELL compute_heap_forwarding(F_HEAP *heap);

9
vm/data_gc.c
View File

@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed)
reset_generations(NURSERY,collecting_gen);
}
if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
free_unmarked(&code_heap);
}
collecting_aging_again = false;
}
@ -491,7 +484,7 @@ void garbage_collection(CELL gen,
code_heap_scans++;
if(collecting_gen == TENURED)
update_code_heap_roots();
free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references);
else
copy_code_heap_roots();