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

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

db4
Doug Coleman 2009-11-05 01:58:40 -06:00
parent 82ae52e109 6c87f20286
commit 2df2c1a339
157 changed files with 4047 additions and 2825 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Makefile
View File

@ -41,22 +41,23 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/debug.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
vm/heap.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
vm/old_space.o \
vm/object_start_map.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \

54
basis/alien/c-types/c-types.factor
View File

@ -230,6 +230,10 @@ M: byte-array byte-length length ; inline
M: f byte-length drop 0 ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
MIXIN: value-type
: c-getter ( name -- quot )
@ -256,6 +260,7 @@ PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
M: string typedef ( old new -- ) c-types get set-at ;
M: word typedef ( old new -- )
{
[ nip define-symbol ]
@ -292,7 +297,7 @@ M: long-long-type box-return ( c-type -- )
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
@ -338,7 +343,7 @@ SYMBOLS:
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
8 >>align
cpu x86.32? os windows? not and 4 8 ? >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
\ longlong define-primitive-type
@ -349,7 +354,7 @@ SYMBOLS:
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
8 >>align
cpu x86.32? os windows? not and 4 8 ? >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
\ ulonglong define-primitive-type
@ -442,14 +447,24 @@ SYMBOLS:
"to_cell" >>unboxer
\ uchar define-primitive-type
<c-type>
[ alien-unsigned-1 0 = not ] >>getter
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
\ bool define-primitive-type
cpu ppc? [
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
] [
<c-type>
[ alien-unsigned-1 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
\ bool define-primitive-type
] if
<c-type>
math:float >>class
@ -470,17 +485,24 @@ SYMBOLS:
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
cpu x86.32? os windows? not and 4 8 ? >>align
"box_double" >>boxer
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
\ double define-primitive-type
\ long c-type \ ptrdiff_t typedef
\ long c-type \ intptr_t typedef
\ ulong c-type \ uintptr_t typedef
\ ulong c-type \ size_t typedef
cpu x86.64? os windows? and [
\ longlong c-type \ ptrdiff_t typedef
\ longlong c-type \ intptr_t typedef
\ ulonglong c-type \ uintptr_t typedef
\ ulonglong c-type \ size_t typedef
] [
\ long c-type \ ptrdiff_t typedef
\ long c-type \ intptr_t typedef
\ ulong c-type \ uintptr_t typedef
\ ulong c-type \ size_t typedef
] if
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;

6
basis/alien/data/data.factor
View File

@ -65,10 +65,6 @@ M: memory-stream stream-read
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
: >c-bool ( ? -- int ) 1 0 ? ; inline
: c-bool> ( int -- ? ) 0 = not ; inline
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
@ -77,5 +73,3 @@ M: value-type c-type-getter
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;

28
basis/bootstrap/image/image.factor
View File

@ -176,14 +176,12 @@ USERENV: callback-stub 45
! PIC stubs
USERENV: pic-load 47
USERENV: pic-tag 48
USERENV: pic-hi-tag 49
USERENV: pic-tuple 50
USERENV: pic-hi-tag-tuple 51
USERENV: pic-check-tag 52
USERENV: pic-check 53
USERENV: pic-hit 54
USERENV: pic-miss-word 55
USERENV: pic-miss-tail-word 56
USERENV: pic-tuple 49
USERENV: pic-check-tag 50
USERENV: pic-check-tuple 51
USERENV: pic-hit 52
USERENV: pic-miss-word 53
USERENV: pic-miss-tail-word 54
! Megamorphic dispatch
USERENV: mega-lookup 57
@ -217,13 +215,18 @@ USERENV: undefined-quot 60
: here-as ( tag -- pointer ) here bitor ;
: (align-here) ( alignment -- )
[ here neg ] dip rem
[ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
: align-here ( -- )
here 8 mod 4 = [ 0 emit ] when ;
data-alignment get (align-here) ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( class quot -- addr )
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
[ type-number ] dip over here-as
[ swap tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
@ -292,7 +295,7 @@ M: fake-bignum ' n>> tag-fixnum ;
M: float '
[
float [
align-here double>bits emit-64
8 (align-here) double>bits emit-64
] emit-object
] cache-eql-object ;
@ -304,7 +307,7 @@ M: float '
M: f '
#! f is #define F RETAG(0,F_TYPE)
drop \ f tag-number ;
drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
@ -410,6 +413,7 @@ M: byte-array '
[
byte-array [
dup length emit-fixnum
bootstrap-cell 4 = [ 0 emit 0 emit ] when
pad-bytes emit-bytes
] emit-object
] cache-eq-object ;

1
basis/bootstrap/tools/tools.factor
View File

@ -12,6 +12,7 @@ IN: bootstrap.tools
"tools.deploy"
"tools.destructors"
"tools.disassembler"
"tools.dispatch"
"tools.memory"
"tools.profiler"
"tools.test"

2
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -284,7 +284,7 @@ M: ##copy analyze-aliases*
M: ##compare analyze-aliases*
call-next-method
dup useless-compare? [
dst>> \ f tag-number \ ##load-immediate new-insn
dst>> \ f type-number \ ##load-immediate new-insn
analyze-aliases*
] when ;

5
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -119,7 +119,6 @@ IN: compiler.cfg.builder.tests
{
byte-array
simple-alien
alien
POSTPONE: f
} [| class |
@ -192,7 +191,7 @@ IN: compiler.cfg.builder.tests
] unit-test
[ f t ] [
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
[ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
[ [ ##unbox-alien? ] contains-insn? ] bi
] unit-test
@ -205,7 +204,7 @@ IN: compiler.cfg.builder.tests
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
[ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##allot? ] contains-insn? ] bi
] unit-test

6
basis/compiler/cfg/builder/builder.factor
View File

@ -117,7 +117,7 @@ M: #recursive emit-node
and ;
: emit-trivial-if ( -- )
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
@ -126,12 +126,12 @@ M: #recursive emit-node
and ;
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
ds-pop \ f type-number cc= ^^compare-imm ds-push ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{

12
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs fry
cpu.architecture layouts
USING: accessors kernel sequences assocs fry math
cpu.architecture layouts namespaces
compiler.cfg.rpo
compiler.cfg.registers
compiler.cfg.instructions
@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
M: ##box-alien allocation-size* drop 4 cells ;
M: ##box-alien allocation-size* drop 5 cells ;
M: ##box-displaced-alien allocation-size* drop 4 cells ;
M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( bb -- n )
instructions>> [ ##allocation? ] filter [ allocation-size* ] map-sum ;
instructions>>
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
: insert-gc-check ( bb -- )
dup dup '[

4
basis/compiler/cfg/hats/hats.factor
View File

@ -43,14 +43,14 @@ insn-classes get [
: ^^load-literal ( obj -- dst )
[ next-vreg dup ] dip {
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
{ [ dup not ] [ drop \ f type-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
{ [ dup float? ] [ ##load-constant ] }
[ ##load-reference ]
} cond ;
: ^^offset>slot ( slot -- vreg' )
cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
cell 4 = 2 1 ? ^^shr-imm ;
: ^^tag-fixnum ( src -- dst )
tag-bits get ^^shl-imm ;

15
basis/compiler/cfg/instructions/instructions.factor
View File

@ -512,13 +512,12 @@ temp: temp/int-rep ;
PURE-INSN: ##box-displaced-alien
def: dst/int-rep
use: displacement/int-rep base/int-rep
temp: temp1/int-rep temp2/int-rep
temp: temp/int-rep
literal: base-class ;
PURE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
use: src/int-rep
temp: temp/int-rep ;
use: src/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -527,12 +526,12 @@ PURE-INSN: ##unbox-alien
def: dst/int-rep
use: src/int-rep ;
: ##unbox-c-ptr ( dst src class temp -- )
: ##unbox-c-ptr ( dst src class -- )
{
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
{ [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
[ nip ##unbox-any-c-ptr ]
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup alien class<= ] [ drop ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
[ drop ##unbox-any-c-ptr ]
} cond ;
! Alien accessors

2
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien
bi and ;
: ^^unbox-c-ptr ( src class -- dst )
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
[ next-vreg dup ] 2dip ##unbox-c-ptr ;
: prepare-alien-accessor ( info -- ptr-vreg offset )
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;

8
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -8,7 +8,7 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
'[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
'[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
@ -31,10 +31,10 @@ IN: compiler.cfg.intrinsics.allot
] [ drop emit-primitive ] if ;
: store-length ( len reg class -- )
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
@ -62,7 +62,7 @@ IN: compiler.cfg.intrinsics.allot
: bytes>cells ( m -- n ) cell align cell /i ;
: ^^allot-byte-array ( n -- dst )
2 cells + byte-array ^^allot ;
16 + byte-array ^^allot ;
: emit-allot-byte-array ( len -- dst )
ds-drop

2
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum
ds-push ;
: tag-literal ( n -- tagged )
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
: emit-fixnum-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline

2
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -8,7 +8,7 @@ compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ; inline
: value-tag ( info -- n ) class>> class-type ; inline
: ^^tag-offset>slot ( slot tag -- vreg' )
[ ^^offset>slot ] dip ^^sub-imm ;

2
basis/compiler/cfg/representations/representations.factor
View File

@ -47,7 +47,7 @@ M:: vector-rep emit-box ( dst src rep -- )
int-rep next-vreg-rep :> temp
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
temp 16 tag-fixnum ##load-immediate
temp dst 1 byte-array tag-number ##set-slot-imm
temp dst 1 byte-array type-number ##set-slot-imm
dst byte-array-offset src rep ##set-alien-vector ;
M: vector-rep emit-unbox

8
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -37,7 +37,7 @@ M: insn rewrite drop f ;
dup ##compare-imm-branch? [
{
[ cc>> cc/= eq? ]
[ src2>> \ f tag-number eq? ]
[ src2>> \ f type-number eq? ]
} 1&&
] [ drop f ] if ; inline
@ -110,7 +110,7 @@ M: ##compare-imm rewrite-tagged-comparison
: rewrite-redundant-comparison? ( insn -- ? )
{
[ src1>> vreg>expr general-compare-expr? ]
[ src2>> \ f tag-number = ]
[ src2>> \ f type-number = ]
[ cc>> { cc= cc/= } member-eq? ]
} 1&& ; inline
@ -204,7 +204,7 @@ M: ##compare-branch rewrite
[ dst>> ] dip
{
{ t [ t \ ##load-constant new-insn ] }
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
{ f [ \ f type-number \ ##load-immediate new-insn ] }
} case ;
: rewrite-self-compare ( insn -- insn' )
@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
[
next-vreg :> temp
temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
insn dst>> temp expr displacement>> vn>vreg ##add
] { } make ;

40
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -82,7 +82,7 @@ IN: compiler.cfg.value-numbering.tests
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc> }
T{ ##compare-imm f 6 4 5 cc/= }
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
@ -100,7 +100,7 @@ IN: compiler.cfg.value-numbering.tests
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
T{ ##compare-imm f 6 4 5 cc= }
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
@ -118,7 +118,7 @@ IN: compiler.cfg.value-numbering.tests
T{ ##peek f 8 D 0 }
T{ ##peek f 9 D -1 }
T{ ##compare-float-unordered f 12 8 9 cc< }
T{ ##compare-imm f 14 12 5 cc= }
T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
@ -135,7 +135,7 @@ IN: compiler.cfg.value-numbering.tests
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
T{ ##compare f 33 29 30 cc<= }
T{ ##compare-imm-branch f 33 5 cc/= }
T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
} value-numbering-step trim-temps
] unit-test
@ -149,7 +149,7 @@ IN: compiler.cfg.value-numbering.tests
{
T{ ##peek f 1 D -1 }
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
T{ ##compare-imm-branch f 2 5 cc/= }
T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
} value-numbering-step trim-temps
] unit-test
@ -1071,14 +1071,14 @@ cell 8 = [
! Branch folding
[
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
T{ ##load-immediate f 3 5 }
T{ ##load-immediate f 1 10 }
T{ ##load-immediate f 2 20 }
T{ ##load-immediate f 3 $[ \ f type-number ] }
}
] [
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
T{ ##load-immediate f 1 10 }
T{ ##load-immediate f 2 20 }
T{ ##compare f 3 1 2 cc= }
} value-numbering-step
] unit-test
@ -1113,14 +1113,14 @@ cell 8 = [
[
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
T{ ##load-immediate f 3 5 }
T{ ##load-immediate f 1 10 }
T{ ##load-immediate f 2 20 }
T{ ##load-immediate f 3 $[ \ f type-number ] }
}
] [
{
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 2 }
T{ ##load-immediate f 1 10 }
T{ ##load-immediate f 2 20 }
T{ ##compare f 3 2 1 cc< }
} value-numbering-step
] unit-test
@ -1128,7 +1128,7 @@ cell 8 = [
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 5 }
T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
@ -1152,7 +1152,7 @@ cell 8 = [
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 5 }
T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
@ -1176,7 +1176,7 @@ cell 8 = [
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 5 }
T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
@ -1557,7 +1557,7 @@ cell 8 = [
{
T{ ##peek f 0 D 0 }
T{ ##compare f 1 0 0 cc<= }
T{ ##compare-imm-branch f 1 5 cc/= }
T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
} test-branch-folding
] unit-test
@ -1659,7 +1659,7 @@ V{
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
T{ ##compare-imm-branch
{ src1 21 }
{ src2 5 }
{ src2 $[ \ f type-number ] }
{ cc cc/= }
}
} 1 test-bb

25
basis/compiler/constants/constants.factor
View File

@ -12,19 +12,18 @@ CONSTANT: deck-bits 18
! These constants must match vm/layouts.h
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
: float-offset ( -- n ) 8 float type-number - ; inline
: string-offset ( -- n ) 4 string type-number slot-offset ; inline
: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes

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

@ -175,20 +175,6 @@ TUPLE: my-tuple ;
] compile-call
] unit-test
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
[ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
0 alien-cell hi-tag
] compile-call alien type-number =
] unit-test
[ 2 1 ] [
2 1
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call

32
basis/compiler/tests/intrinsics.factor Normal file → Executable file
View File

@ -244,20 +244,20 @@ IN: compiler.tests.intrinsics
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ t ] [ f [ f eq? ] compile-call ] unit-test
@ -285,8 +285,8 @@ cell 8 = [
! 64-bit overflow
cell 8 = [
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
[ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
[ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
@ -301,9 +301,9 @@ cell 8 = [
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
[ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
[ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
] when
@ -311,12 +311,14 @@ cell 8 = [
! Some randomized tests
: compiled-fixnum* ( a b -- c ) fixnum* ;
ERROR: bug-in-fixnum* x y a b ;
[ ] [
10000 [
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if
32 random-bits >fixnum
32 random-bits >fixnum
2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
[ 2drop 2drop ] [ bug-in-fixnum* ] if
] times
] unit-test
@ -419,7 +421,7 @@ cell 8 = [
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ ] [ "b" get free ] unit-test

24
basis/compiler/tests/low-level-ir.factor
View File

@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir
! loading immediates
[ f ] [
V{
T{ ##load-immediate f 0 5 }
T{ ##load-immediate f 0 $[ \ f type-number ] }
} compile-test-bb
] unit-test
@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir
! one of the sources
[ t ] [
V{
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##slot f 0 0 1 }
} compile-test-bb
@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
T{ ##slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
] unit-test
[ t ] [
V{
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##set-slot f 0 0 1 }
} compile-test-bb
@ -75,12 +75,12 @@ IN: compiler.tests.low-level-ir
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
dup first eq?
] unit-test
[ 8 ] [
[ 4 ] [
V{
T{ ##load-immediate f 0 4 }
T{ ##shl f 0 0 0 }
@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir
[ 4 ] [
V{
T{ ##load-immediate f 0 4 }
T{ ##shl-imm f 0 0 3 }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 31 ] [
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f 0 1 2 }
T{ ##unbox-any-c-ptr f 0 1 }
T{ ##alien-unsigned-1 f 0 0 0 }
T{ ##shl-imm f 0 0 3 }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir
T{ ##load-reference f 0 "hello world" }
T{ ##load-immediate f 1 3 }
T{ ##string-nth f 0 0 1 2 }
T{ ##shl-imm f 0 0 3 }
T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
T{ ##load-immediate f 0 16 }
T{ ##add-imm f 0 0 -8 }
T{ ##load-immediate f 0 32 }
T{ ##add-imm f 0 0 -16 }
} compile-test-bb
] unit-test

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

@ -202,7 +202,7 @@ USE: binary-search.private
dup length 1 <= [
from>>
] [
[ midpoint swap call ] 3keep roll dup zero?
[ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
[ drop dup from>> swap midpoint@ + ]
[ drop dup midpoint@ head-slice old-binsearch ] if
] if ; inline recursive

2
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -279,7 +279,7 @@ generic-comparison-ops [
] each
\ alien-cell [
2drop simple-alien \ f class-or <class-info>
2drop alien \ f class-or <class-info>
] "outputs" set-word-prop
{ <tuple> <tuple-boa> } [

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -890,10 +890,10 @@ M: tuple-with-read-only-slot clone
[ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
] unit-test
! alien-cell outputs a simple-alien or f
! alien-cell outputs a alien or f
[ t ] [
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
first simple-alien class=
first alien class=
] unit-test
! Don't crash if bad literal inputs are passed to unsafe words

4
basis/cpu/architecture/architecture.factor
View File

@ -386,9 +386,9 @@ M: object %horizontal-shl-vector-imm-reps { } ;
M: object %horizontal-shr-vector-imm-reps { } ;
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
HOOK: %alien-unsigned-2 cpu ( dst src offset -- )

48
basis/cpu/ppc/bootstrap.factor
View File

@ -69,7 +69,7 @@ CONSTANT: rs-reg 14
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
0 3 \ f tag-number CMPI
0 3 \ f type-number CMPI
2 BEQ
0 B rc-relative-ppc-3 rt-xt jit-rel
0 B rc-relative-ppc-3 rt-xt jit-rel
@ -174,40 +174,15 @@ CONSTANT: rs-reg 14
[ load-tag ] pic-tag jit-define
! Hi-tag
[
3 4 MR
load-tag
0 4 object tag-number tag-fixnum CMPI
2 BNE
4 3 object tag-number neg LWZ
] pic-hi-tag jit-define
! Tuple
[
3 4 MR
load-tag
0 4 tuple tag-number tag-fixnum CMPI
0 4 tuple type-number tag-fixnum CMPI
2 BNE
4 3 tuple tag-number neg bootstrap-cell + LWZ
4 3 tuple type-number neg bootstrap-cell + LWZ
] pic-tuple jit-define
! Hi-tag and tuple
[
3 4 MR
load-tag
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
0 4 BIN: 110 tag-fixnum CMPI
5 BLT
! Untag r3
3 3 0 0 31 tag-bits get - RLWINM
! Set r4 to 0 for objects, and bootstrap-cell for tuples
4 4 1 tag-fixnum ANDI
4 4 1 SRAWI
! Load header cell or tuple layout cell
4 4 3 LWZX
] pic-hi-tag-tuple jit-define
[
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
] pic-check-tag jit-define
@ -215,7 +190,7 @@ CONSTANT: rs-reg 14
[
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
4 0 5 CMP
] pic-check jit-define
] pic-check-tuple jit-define
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
@ -224,8 +199,13 @@ CONSTANT: rs-reg 14
[
! cache = ...
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
! key = class
5 4 MR
! key = hashcode(class)
5 4 3 SRAWI
6 4 8 SRAWI
5 5 6 ADD
6 4 13 SRAWI
5 5 6 ADD
5 5 3 SLWI
! key &= cache.length - 1
5 5 mega-cache-size get 1 - bootstrap-cell * ANDI
! cache += array-start-offset
@ -278,7 +258,7 @@ CONSTANT: rs-reg 14
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
3 3 1 SRAWI
3 3 2 SRAWI
4 4 0 0 31 tag-bits get - RLWINM
4 3 3 LWZX
3 ds-reg 0 STW
@ -399,7 +379,7 @@ CONSTANT: rs-reg 14
5 ds-reg -4 LWZU
5 0 4 CMP
2 swap execute( offset -- ) ! magic number
\ f tag-number 3 LI
\ f type-number 3 LI
3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- )
@ -418,7 +398,7 @@ CONSTANT: rs-reg 14
4 ds-reg 0 LWZ
3 3 4 OR
3 3 tag-mask get ANDI
\ f tag-number 4 LI
\ f type-number 4 LI
0 3 0 CMPI
2 BNE
1 tag-fixnum 4 LI

44
basis/cpu/ppc/ppc.factor
View File

@ -266,7 +266,7 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 scratch-reg \ f tag-number CMPI
0 scratch-reg \ f type-number CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
@ -288,25 +288,20 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
"end" resolve-label
] with-scope ;
: alien@ ( n -- n' ) cells object tag-number - ;
:: %allot-alien ( dst displacement base temp -- )
dst 4 cells alien temp %allot
temp \ f tag-number %load-immediate
! Store underlying-alien slot
base dst 1 alien@ STW
! Store expired slot
temp dst 2 alien@ STW
! Store offset
displacement dst 3 alien@ STW ;
: alien@ ( n -- n' ) cells alien type-number - ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
dst \ f tag-number %load-immediate
dst %load-immediate
0 src 0 CMPI
"f" get BEQ
dst src temp temp %allot-alien
dst 5 cells alien temp %allot
temp \ f type-number %load-immediate
temp dst 1 alien@ STW
temp dst 2 alien@ STW
displacement dst 3 alien@ STW
displacement dst 4 alien@ STW
"f" resolve-label
] with-scope ;
@ -323,7 +318,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
displacement' :> temp
dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it
0 base \ f tag-number CMPI
0 base \ f type-number CMPI
"simple-case" get BEQ
temp base header-offset LWZ
0 temp alien type-number tag-fixnum CMPI
@ -343,7 +338,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
! Store offset
displacement' dst 3 alien@ STW
! Store expired slot (its ok to clobber displacement')
temp \ f tag-number %load-immediate
temp \ f type-number %load-immediate
temp dst 2 alien@ STW
"end" resolve-label
] with-scope ;
@ -374,7 +369,7 @@ M: ppc %set-alien-double -rot STFD ;
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
scratch-reg allot-ptr n 8 align ADDI
scratch-reg allot-ptr n data-alignment get align ADDI
scratch-reg nursery-ptr 0 STW ;
:: store-header ( dst class -- )
@ -382,7 +377,7 @@ M: ppc %set-alien-double -rot STFD ;
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
dupd tag-number ORI ;
dupd type-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
@ -460,7 +455,7 @@ M: ppc %epilogue ( n -- )
:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f tag-number %load-immediate
dst \ f type-number %load-immediate
"end" get branch1 execute( label -- )
branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
@ -742,14 +737,3 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
[
<c-type>
[ alien-unsigned-4 c-bool> ] >>getter
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
bool define-primitive-type
] with-compilation-unit

9
basis/cpu/x86/32/32.factor
View File

@ -11,9 +11,6 @@ cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned.
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
@ -327,10 +324,4 @@ M: x86.32 dummy-fp-params? f ;
! Dreadful
M: object flatten-value-type (flatten-int-type) ;
os windows? [
cell longlong c-type (>>align)
cell ulonglong c-type (>>align)
4 double c-type (>>align)
] unless
check-sse

2
basis/cpu/x86/32/bootstrap.factor
View File

@ -21,7 +21,7 @@ IN: bootstrap.x86
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
[

2
basis/cpu/x86/64/bootstrap.factor
View File

@ -18,7 +18,7 @@ IN: bootstrap.x86
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) ;
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
[

6
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -24,9 +24,3 @@ M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg RAX ;
<<
longlong ptrdiff_t typedef
longlong intptr_t typedef
int c-type long define-primitive-type
uint c-type ulong define-primitive-type
>>

44
basis/cpu/x86/bootstrap.factor
View File

@ -60,7 +60,7 @@ big-endian off
! pop boolean
ds-reg bootstrap-cell SUB
! compare boolean with f
temp0 \ f tag-number CMP
temp0 \ f type-number CMP
! jump to true branch if not equal
0 JNE rc-relative rt-xt jit-rel
! jump to false branch if equal
@ -154,7 +154,7 @@ big-endian off
! ! ! Polymorphic inline caches
! The PIC and megamorphic code stubs are not permitted to touch temp3.
! The PIC stubs are not permitted to touch temp3.
! Load a value from a stack position
[
@ -171,41 +171,15 @@ big-endian off
! The 'make' trick lets us compute the jump distance for the
! conditional branches there
! Hi-tag
[
temp0 temp1 MOV
load-tag
temp1 object tag-number tag-fixnum CMP
[ temp1 temp0 object tag-number neg [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-hi-tag jit-define
! Tuple
[
temp0 temp1 MOV
load-tag
temp1 tuple tag-number tag-fixnum CMP
[ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
temp1 tuple type-number tag-fixnum CMP
[ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-tuple jit-define
! Hi-tag and tuple
[
temp0 temp1 MOV
load-tag
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
temp1 BIN: 110 tag-fixnum CMP
[
! Untag temp0
temp0 tag-mask get bitnot AND
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
temp1 1 tag-fixnum AND
bootstrap-cell 4 = [ temp1 1 SHR ] when
! Load header cell or tuple layout cell
temp1 temp0 temp1 [+] MOV
] [ ] make [ length JL ] [ % ] bi
] pic-hi-tag-tuple jit-define
[
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
] pic-check-tag jit-define
@ -213,7 +187,7 @@ big-endian off
[
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
temp1 temp2 CMP
] pic-check jit-define
] pic-check-tuple jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
@ -222,9 +196,9 @@ big-endian off
[
! cache = ...
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! key = class
! key = hashcode(class)
temp2 temp1 MOV
bootstrap-cell 8 = [ temp2 1 SHL ] when
bootstrap-cell 4 = [ temp2 1 SHR ] when
! key &= cache.length - 1
temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
@ -410,7 +384,7 @@ big-endian off
t jit-literal
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
temp1 \ f tag-number MOV
temp1 \ f type-number MOV
! load first value
temp0 ds-reg [] MOV
! adjust stack pointer
@ -540,7 +514,7 @@ big-endian off
ds-reg bootstrap-cell SUB
temp0 ds-reg [] OR
temp0 tag-mask get AND
temp0 \ f tag-number MOV
temp0 \ f type-number MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV

155
basis/cpu/x86/x86.factor
View File

@ -45,8 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
: align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size ( stack-frame -- i )
[ (stack-frame-size) ]
@ -141,8 +140,10 @@ M: x86 %not int-rep one-operand NOT ;
M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
! since this induces partial register stalls
GENERIC: copy-register* ( dst src rep -- )
GENERIC: copy-unaligned* ( dst src rep -- )
GENERIC: copy-memory* ( dst src rep -- )
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
@ -152,17 +153,14 @@ M: float-4-rep copy-register* drop MOVAPS ;
M: double-2-rep copy-register* drop MOVAPS ;
M: vector-rep copy-register* drop MOVDQA ;
M: object copy-unaligned* copy-register* ;
M: float-rep copy-unaligned* drop MOVSS ;
M: double-rep copy-unaligned* drop MOVSD ;
M: float-4-rep copy-unaligned* drop MOVUPS ;
M: double-2-rep copy-unaligned* drop MOVUPS ;
M: vector-rep copy-unaligned* drop MOVDQU ;
M: object copy-memory* copy-register* ;
M: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-unaligned* ] if
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- )
@ -177,76 +175,109 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- )
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
M:: x86 %unbox-any-c-ptr ( dst src -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
dst 0 MOV
temp src MOV
! We come back here with displaced aliens
"start" resolve-label
"end" define-label
dst dst XOR
! Is the object f?
temp \ f tag-number CMP
src \ f type-number CMP
"end" get JE
! Compute tag in dst register
dst src MOV
dst tag-mask get AND
! Is the object an alien?
temp header-offset [+] alien type-number tag-fixnum CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
dst temp alien-offset [+] ADD
! Now recurse on the underlying alien
temp temp underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
dst temp ADD
dst alien type-number CMP
! Add an offset to start of byte array's data
dst byte-array-offset ADD
dst src byte-array-offset [+] LEA
"end" get JNE
! If so, load the offset and add it to the address
dst src alien-offset [+] MOV
"end" resolve-label
] with-scope ;
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
:: %allot-alien ( dst displacement base temp -- )
dst 4 cells alien temp %allot
dst 1 alien@ base MOV ! alien
dst 2 alien@ \ f tag-number MOV ! expired
dst 3 alien@ displacement MOV ! displacement
;
: alien@ ( reg n -- op ) cells alien type-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
dst \ f tag-number MOV
src 0 CMP
dst \ f type-number MOV
src src TEST
"end" get JE
dst src \ f tag-number temp %allot-alien
dst 5 cells alien temp %allot
dst 1 alien@ \ f type-number MOV ! base
dst 2 alien@ \ f type-number MOV ! expired
dst 3 alien@ src MOV ! displacement
dst 4 alien@ src MOV ! address
"end" resolve-label
] with-scope ;
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
! This is ridiculous
[
"end" define-label
"ok" define-label
"not-f" define-label
"not-alien" define-label
! If displacement is zero, return the base
dst base MOV
displacement 0 CMP
displacement displacement TEST
"end" get JE
! Quickly use displacement' before its needed for real, as allot temporary
dst 4 cells alien displacement' %allot
! If base is already a displaced alien, unpack it
base' base MOV
displacement' displacement MOV
base \ f tag-number CMP
"ok" get JE
base header-offset [+] alien type-number tag-fixnum CMP
"ok" get JNE
! displacement += base.displacement
displacement' base 3 alien@ ADD
! base = base.base
base' base 1 alien@ MOV
"ok" resolve-label
dst 1 alien@ base' MOV ! alien
dst 2 alien@ \ f tag-number MOV ! expired
dst 3 alien@ displacement' MOV ! displacement
! Displacement is non-zero, we're going to be allocating a new
! object
dst 5 cells alien temp %allot
! Set expired to f
dst 2 alien@ \ f type-number MOV
! Is base f?
base \ f type-number CMP
"not-f" get JNE
! Yes, it is f. Fill in new object
dst 1 alien@ base MOV
dst 3 alien@ displacement MOV
dst 4 alien@ displacement MOV
"end" get JMP
"not-f" resolve-label
! Check base type
temp base MOV
temp tag-mask get AND
! Is base an alien?
temp alien type-number CMP
"not-alien" get JNE
! Yes, it is an alien. Set new alien's base to base.base
temp base 1 alien@ MOV
dst 1 alien@ temp MOV
! Compute displacement
temp base 3 alien@ MOV
temp displacement ADD
dst 3 alien@ temp MOV
! Compute address
temp base 4 alien@ MOV
temp displacement ADD
dst 4 alien@ temp MOV
! We are done
"end" get JMP
! Is base a byte array? It has to be, by now...
"not-alien" resolve-label
dst 1 alien@ base MOV
dst 3 alien@ displacement MOV
temp base MOV
temp byte-array-offset ADD
temp displacement ADD
dst 4 alien@ temp MOV
"end" resolve-label
] with-scope ;
@ -396,13 +427,13 @@ M: x86 %vm-field-ptr ( dst field -- )
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ [] ] dip 8 align ADD ;
[ [] ] dip data-alignment get align ADD ;
: store-header ( temp class -- )
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst tag -- )
tag-number OR ;
type-number OR ;
M:: x86 %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
@ -444,7 +475,7 @@ M: x86 %alien-global ( dst symbol library -- )
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
dst \ f tag-number MOV
dst \ f type-number MOV
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline

2
basis/game/input/dinput/keys-array/keys-array.factor
View File

@ -1,5 +1,5 @@
USING: sequences sequences.private math
accessors alien.data ;
accessors alien.c-types ;
IN: game.input.dinput.keys-array
TUPLE: keys-array

2
basis/io/buffers/buffers.factor
View File

@ -8,7 +8,7 @@ IN: io.buffers
TUPLE: buffer
{ size fixnum }
{ ptr simple-alien }
{ ptr alien }
{ fill fixnum }
{ pos fixnum }
disposed ;

1
basis/io/encodings/8-bit/8-bit.factor
View File

@ -27,6 +27,7 @@ CONSTANT: mappings {
{ "latin9" "ISO-8859-15" "8859-15" }
{ "latin10" "ISO-8859-16" "8859-16" }
{ "koi8-r" "KOI8-R" "KOI8-R" }
{ "windows-1250" "windows-1250" "CP1250" }
{ "windows-1252" "windows-1252" "CP1252" }
{ "ebcdic" "IBM037" "CP037" }
{ "mac-roman" "macintosh" "ROMAN" }

274
basis/io/encodings/8-bit/CP1250.TXT Normal file
View File

@ -0,0 +1,274 @@
#
# Name: cp1250 to Unicode table
# Unicode version: 2.0
# Table version: 2.01
# Table format: Format A
# Date: 04/15/98
#
# Contact: Shawn.Steele@microsoft.com
#
# General notes: none
#
# Format: Three tab-separated columns
# Column #1 is the cp1250 code (in hex)
# Column #2 is the Unicode (in hex as 0xXXXX)
# Column #3 is the Unicode name (follows a comment sign, '#')
#
# The entries are in cp1250 order
#
0x00 0x0000 #NULL
0x01 0x0001 #START OF HEADING
0x02 0x0002 #START OF TEXT
0x03 0x0003 #END OF TEXT
0x04 0x0004 #END OF TRANSMISSION
0x05 0x0005 #ENQUIRY
0x06 0x0006 #ACKNOWLEDGE
0x07 0x0007 #BELL
0x08 0x0008 #BACKSPACE
0x09 0x0009 #HORIZONTAL TABULATION
0x0A 0x000A #LINE FEED
0x0B 0x000B #VERTICAL TABULATION
0x0C 0x000C #FORM FEED
0x0D 0x000D #CARRIAGE RETURN
0x0E 0x000E #SHIFT OUT
0x0F 0x000F #SHIFT IN
0x10 0x0010 #DATA LINK ESCAPE
0x11 0x0011 #DEVICE CONTROL ONE
0x12 0x0012 #DEVICE CONTROL TWO
0x13 0x0013 #DEVICE CONTROL THREE
0x14 0x0014 #DEVICE CONTROL FOUR
0x15 0x0015 #NEGATIVE ACKNOWLEDGE
0x16 0x0016 #SYNCHRONOUS IDLE
0x17 0x0017 #END OF TRANSMISSION BLOCK
0x18 0x0018 #CANCEL
0x19 0x0019 #END OF MEDIUM
0x1A 0x001A #SUBSTITUTE
0x1B 0x001B #ESCAPE
0x1C 0x001C #FILE SEPARATOR
0x1D 0x001D #GROUP SEPARATOR
0x1E 0x001E #RECORD SEPARATOR
0x1F 0x001F #UNIT SEPARATOR
0x20 0x0020 #SPACE
0x21 0x0021 #EXCLAMATION MARK
0x22 0x0022 #QUOTATION MARK
0x23 0x0023 #NUMBER SIGN
0x24 0x0024 #DOLLAR SIGN
0x25 0x0025 #PERCENT SIGN
0x26 0x0026 #AMPERSAND
0x27 0x0027 #APOSTROPHE
0x28 0x0028 #LEFT PARENTHESIS
0x29 0x0029 #RIGHT PARENTHESIS
0x2A 0x002A #ASTERISK
0x2B 0x002B #PLUS SIGN
0x2C 0x002C #COMMA
0x2D 0x002D #HYPHEN-MINUS
0x2E 0x002E #FULL STOP
0x2F 0x002F #SOLIDUS
0x30 0x0030 #DIGIT ZERO
0x31 0x0031 #DIGIT ONE
0x32 0x0032 #DIGIT TWO
0x33 0x0033 #DIGIT THREE
0x34 0x0034 #DIGIT FOUR
0x35 0x0035 #DIGIT FIVE
0x36 0x0036 #DIGIT SIX
0x37 0x0037 #DIGIT SEVEN
0x38 0x0038 #DIGIT EIGHT
0x39 0x0039 #DIGIT NINE
0x3A 0x003A #COLON
0x3B 0x003B #SEMICOLON
0x3C 0x003C #LESS-THAN SIGN
0x3D 0x003D #EQUALS SIGN
0x3E 0x003E #GREATER-THAN SIGN
0x3F 0x003F #QUESTION MARK
0x40 0x0040 #COMMERCIAL AT
0x41 0x0041 #LATIN CAPITAL LETTER A
0x42 0x0042 #LATIN CAPITAL LETTER B
0x43 0x0043 #LATIN CAPITAL LETTER C
0x44 0x0044 #LATIN CAPITAL LETTER D
0x45 0x0045 #LATIN CAPITAL LETTER E
0x46 0x0046 #LATIN CAPITAL LETTER F
0x47 0x0047 #LATIN CAPITAL LETTER G
0x48 0x0048 #LATIN CAPITAL LETTER H
0x49 0x0049 #LATIN CAPITAL LETTER I
0x4A 0x004A #LATIN CAPITAL LETTER J
0x4B 0x004B #LATIN CAPITAL LETTER K
0x4C 0x004C #LATIN CAPITAL LETTER L
0x4D 0x004D #LATIN CAPITAL LETTER M
0x4E 0x004E #LATIN CAPITAL LETTER N
0x4F 0x004F #LATIN CAPITAL LETTER O
0x50 0x0050 #LATIN CAPITAL LETTER P
0x51 0x0051 #LATIN CAPITAL LETTER Q
0x52 0x0052 #LATIN CAPITAL LETTER R
0x53 0x0053 #LATIN CAPITAL LETTER S
0x54 0x0054 #LATIN CAPITAL LETTER T
0x55 0x0055 #LATIN CAPITAL LETTER U
0x56 0x0056 #LATIN CAPITAL LETTER V
0x57 0x0057 #LATIN CAPITAL LETTER W
0x58 0x0058 #LATIN CAPITAL LETTER X
0x59 0x0059 #LATIN CAPITAL LETTER Y
0x5A 0x005A #LATIN CAPITAL LETTER Z
0x5B 0x005B #LEFT SQUARE BRACKET
0x5C 0x005C #REVERSE SOLIDUS
0x5D 0x005D #RIGHT SQUARE BRACKET
0x5E 0x005E #CIRCUMFLEX ACCENT
0x5F 0x005F #LOW LINE
0x60 0x0060 #GRAVE ACCENT
0x61 0x0061 #LATIN SMALL LETTER A
0x62 0x0062 #LATIN SMALL LETTER B
0x63 0x0063 #LATIN SMALL LETTER C
0x64 0x0064 #LATIN SMALL LETTER D
0x65 0x0065 #LATIN SMALL LETTER E
0x66 0x0066 #LATIN SMALL LETTER F
0x67 0x0067 #LATIN SMALL LETTER G
0x68 0x0068 #LATIN SMALL LETTER H
0x69 0x0069 #LATIN SMALL LETTER I
0x6A 0x006A #LATIN SMALL LETTER J
0x6B 0x006B #LATIN SMALL LETTER K
0x6C 0x006C #LATIN SMALL LETTER L
0x6D 0x006D #LATIN SMALL LETTER M
0x6E 0x006E #LATIN SMALL LETTER N
0x6F 0x006F #LATIN SMALL LETTER O
0x70 0x0070 #LATIN SMALL LETTER P
0x71 0x0071 #LATIN SMALL LETTER Q
0x72 0x0072 #LATIN SMALL LETTER R
0x73 0x0073 #LATIN SMALL LETTER S
0x74 0x0074 #LATIN SMALL LETTER T
0x75 0x0075 #LATIN SMALL LETTER U
0x76 0x0076 #LATIN SMALL LETTER V
0x77 0x0077 #LATIN SMALL LETTER W
0x78 0x0078 #LATIN SMALL LETTER X
0x79 0x0079 #LATIN SMALL LETTER Y
0x7A 0x007A #LATIN SMALL LETTER Z
0x7B 0x007B #LEFT CURLY BRACKET
0x7C 0x007C #VERTICAL LINE
0x7D 0x007D #RIGHT CURLY BRACKET
0x7E 0x007E #TILDE
0x7F 0x007F #DELETE
0x80 0x20AC #EURO SIGN
0x81 #UNDEFINED
0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
0x83 #UNDEFINED
0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
0x85 0x2026 #HORIZONTAL ELLIPSIS
0x86 0x2020 #DAGGER
0x87 0x2021 #DOUBLE DAGGER
0x88 #UNDEFINED
0x89 0x2030 #PER MILLE SIGN
0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON
0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
0x8C 0x015A #LATIN CAPITAL LETTER S WITH ACUTE
0x8D 0x0164 #LATIN CAPITAL LETTER T WITH CARON
0x8E 0x017D #LATIN CAPITAL LETTER Z WITH CARON
0x8F 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE
0x90 #UNDEFINED
0x91 0x2018 #LEFT SINGLE QUOTATION MARK
0x92 0x2019 #RIGHT SINGLE QUOTATION MARK
0x93 0x201C #LEFT DOUBLE QUOTATION MARK
0x94 0x201D #RIGHT DOUBLE QUOTATION MARK
0x95 0x2022 #BULLET
0x96 0x2013 #EN DASH
0x97 0x2014 #EM DASH
0x98 #UNDEFINED
0x99 0x2122 #TRADE MARK SIGN
0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON
0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
0x9C 0x015B #LATIN SMALL LETTER S WITH ACUTE
0x9D 0x0165 #LATIN SMALL LETTER T WITH CARON
0x9E 0x017E #LATIN SMALL LETTER Z WITH CARON
0x9F 0x017A #LATIN SMALL LETTER Z WITH ACUTE
0xA0 0x00A0 #NO-BREAK SPACE
0xA1 0x02C7 #CARON
0xA2 0x02D8 #BREVE
0xA3 0x0141 #LATIN CAPITAL LETTER L WITH STROKE
0xA4 0x00A4 #CURRENCY SIGN
0xA5 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK
0xA6 0x00A6 #BROKEN BAR
0xA7 0x00A7 #SECTION SIGN
0xA8 0x00A8 #DIAERESIS
0xA9 0x00A9 #COPYRIGHT SIGN
0xAA 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA
0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
0xAC 0x00AC #NOT SIGN
0xAD 0x00AD #SOFT HYPHEN
0xAE 0x00AE #REGISTERED SIGN
0xAF 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE
0xB0 0x00B0 #DEGREE SIGN
0xB1 0x00B1 #PLUS-MINUS SIGN
0xB2 0x02DB #OGONEK
0xB3 0x0142 #LATIN SMALL LETTER L WITH STROKE
0xB4 0x00B4 #ACUTE ACCENT
0xB5 0x00B5 #MICRO SIGN
0xB6 0x00B6 #PILCROW SIGN
0xB7 0x00B7 #MIDDLE DOT
0xB8 0x00B8 #CEDILLA
0xB9 0x0105 #LATIN SMALL LETTER A WITH OGONEK
0xBA 0x015F #LATIN SMALL LETTER S WITH CEDILLA
0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
0xBC 0x013D #LATIN CAPITAL LETTER L WITH CARON
0xBD 0x02DD #DOUBLE ACUTE ACCENT
0xBE 0x013E #LATIN SMALL LETTER L WITH CARON
0xBF 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE
0xC0 0x0154 #LATIN CAPITAL LETTER R WITH ACUTE
0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
0xC3 0x0102 #LATIN CAPITAL LETTER A WITH BREVE
0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
0xC5 0x0139 #LATIN CAPITAL LETTER L WITH ACUTE
0xC6 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE
0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON
0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
0xCA 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK
0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
0xCC 0x011A #LATIN CAPITAL LETTER E WITH CARON
0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
0xCF 0x010E #LATIN CAPITAL LETTER D WITH CARON
0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE
0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE
0xD2 0x0147 #LATIN CAPITAL LETTER N WITH CARON
0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
0xD5 0x0150 #LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
0xD7 0x00D7 #MULTIPLICATION SIGN
0xD8 0x0158 #LATIN CAPITAL LETTER R WITH CARON
0xD9 0x016E #LATIN CAPITAL LETTER U WITH RING ABOVE
0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
0xDB 0x0170 #LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
0xDD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE
0xDE 0x0162 #LATIN CAPITAL LETTER T WITH CEDILLA
0xDF 0x00DF #LATIN SMALL LETTER SHARP S
0xE0 0x0155 #LATIN SMALL LETTER R WITH ACUTE
0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
0xE3 0x0103 #LATIN SMALL LETTER A WITH BREVE
0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
0xE5 0x013A #LATIN SMALL LETTER L WITH ACUTE
0xE6 0x0107 #LATIN SMALL LETTER C WITH ACUTE
0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
0xE8 0x010D #LATIN SMALL LETTER C WITH CARON
0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
0xEA 0x0119 #LATIN SMALL LETTER E WITH OGONEK
0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
0xEC 0x011B #LATIN SMALL LETTER E WITH CARON
0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
0xEF 0x010F #LATIN SMALL LETTER D WITH CARON
0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE
0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE
0xF2 0x0148 #LATIN SMALL LETTER N WITH CARON
0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
0xF5 0x0151 #LATIN SMALL LETTER O WITH DOUBLE ACUTE
0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
0xF7 0x00F7 #DIVISION SIGN
0xF8 0x0159 #LATIN SMALL LETTER R WITH CARON
0xF9 0x016F #LATIN SMALL LETTER U WITH RING ABOVE
0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
0xFB 0x0171 #LATIN SMALL LETTER U WITH DOUBLE ACUTE
0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
0xFD 0x00FD #LATIN SMALL LETTER Y WITH ACUTE
0xFE 0x0163 #LATIN SMALL LETTER T WITH CEDILLA
0xFF 0x02D9 #DOT ABOVE

2
basis/listener/listener.factor
View File

@ -163,8 +163,10 @@ SYMBOL: interactive-vocabs
"syntax"
"tools.annotations"
"tools.crossref"
"tools.deprecation"
"tools.destructors"
"tools.disassembler"
"tools.dispatch"
"tools.errors"
"tools.memory"
"tools.profiler"

4
basis/math/vectors/simd/functor/functor.factor
View File

@ -146,7 +146,7 @@ TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ;
[ rep alien-vector class boa ] >>getter
[ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
16 >>size
8 >>align
16 >>align
rep >>rep
class c:typedef ;
@ -315,7 +315,7 @@ SLOT: underlying2
3bi
] >>setter
32 >>size
8 >>align
16 >>align
rep >>rep
class c:typedef ;

17
basis/math/vectors/simd/simd-tests.factor
View File

@ -582,3 +582,20 @@ STRUCT: simd-struct
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
[ compile-call ] [ call ] 3bi =
] unit-test
! Spilling SIMD values -- this basically just tests that the
! stack was aligned properly by the runtime
: simd-spill-test-1 ( a b c -- v )
{ float-4 float-4 float } declare
[ v+ ] dip sin v*n ;
[ float-4{ 0 0 0 0 } ]
[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
: simd-spill-test-2 ( a b d c -- v )
{ float float-4 float-4 float } declare
[ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
[ float-4{ 0 0 0 0 } ]
[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test

4
basis/prettyprint/prettyprint.factor
View File

@ -110,3 +110,7 @@ SYMBOL: pprint-string-cells?
] with-row
] each
] tabular-output nl ;
: object-table. ( obj alist -- )
[ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
simple-table. ;

21
basis/stack-checker/known-words/known-words.factor
View File

@ -13,7 +13,7 @@ words.private definitions assocs summary compiler.units
system.private combinators combinators.short-circuit locals
locals.backend locals.types combinators.private
stack-checker.values generic.single generic.single.private
alien.libraries
alien.libraries tools.dispatch.private tools.profiler.private
stack-checker.alien
stack-checker.state
stack-checker.errors
@ -501,16 +501,14 @@ M: bad-executable summary
\ compact-gc { } { } define-primitive
\ gc-stats { } { array } define-primitive
\ (save-image) { byte-array } { } define-primitive
\ (save-image-and-exit) { byte-array } { } define-primitive
\ data-room { } { integer integer array } define-primitive
\ data-room { } { byte-array } define-primitive
\ data-room make-flushable
\ code-room { } { integer integer integer integer } define-primitive
\ code-room { } { byte-array } define-primitive
\ code-room make-flushable
\ micros { } { integer } define-primitive
@ -594,7 +592,7 @@ M: bad-executable summary
\ set-alien-double { float c-ptr integer } { } define-primitive
\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
@ -701,21 +699,20 @@ M: bad-executable summary
\ unimplemented { } { } define-primitive
\ gc-reset { } { } define-primitive
\ gc-stats { } { array } define-primitive
\ jit-compile { quotation } { } define-primitive
\ lookup-method { object array } { word } define-primitive
\ reset-dispatch-stats { } { } define-primitive
\ dispatch-stats { } { array } define-primitive
\ reset-inline-cache-stats { } { } define-primitive
\ inline-cache-stats { } { array } define-primitive
\ optimized? { word } { object } define-primitive
\ strip-stack-traces { } { } define-primitive
\ <callback> { word } { alien } define-primitive
\ enable-gc-events { } { } define-primitive
\ disable-gc-events { } { object } define-primitive
\ profiling { object } { } define-primitive

1
basis/tools/dispatch/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

8
basis/tools/dispatch/dispatch-docs.factor Normal file
View File

@ -0,0 +1,8 @@
IN: tools.dispatch
USING: help.markup help.syntax vm quotations ;
HELP: last-dispatch-stats
{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ;
HELP: dispatch-stats.
{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ;

24
basis/tools/dispatch/dispatch.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces prettyprint classes.struct
vm tools.dispatch.private ;
IN: tools.dispatch
SYMBOL: last-dispatch-stats
: dispatch-stats. ( -- )
last-dispatch-stats get {
{ "Megamorphic hits" [ megamorphic-cache-hits>> ] }
{ "Megamorphic misses" [ megamorphic-cache-misses>> ] }
{ "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] }
{ "Mono to polymorphic" [ ic-to-pic-transitions>> ] }
{ "Poly to megamorphic" [ pic-to-mega-transitions>> ] }
{ "Tag check count" [ pic-tag-count>> ] }
{ "Tuple check count" [ pic-tuple-count>> ] }
} object-table. ;
: collect-dispatch-stats ( quot -- )
reset-dispatch-stats
call
dispatch-stats dispatch-statistics memory>struct
last-dispatch-stats set ; inline

14
basis/tools/memory/memory-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax memory sequences ;
USING: help.markup help.syntax memory sequences vm ;
IN: tools.memory
ARTICLE: "tools.memory" "Object memory tools"
@ -39,3 +39,15 @@ HELP: heap-stats.
{ $description "For each class, prints the number of instances and total memory consumed by those instances." } ;
{ heap-stats heap-stats. } related-words
HELP: gc-events.
{ $description "Prints all garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
HELP: gc-stats.
{ $description "Prints a breakdown of different garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
HELP: gc-summary.
{ $description "Prints aggregate garbage collection statistics from the last call to " { $link collect-gc-events } "." } ;
HELP: gc-events
{ $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ;

6
basis/tools/memory/memory-tests.factor
View File

@ -1,5 +1,9 @@
USING: tools.test tools.memory ;
USING: tools.test tools.memory memory ;
IN: tools.memory.tests
[ ] [ room. ] unit-test
[ ] [ heap-stats. ] unit-test
[ ] [ [ gc gc ] collect-gc-events ] unit-test
[ ] [ gc-events. ] unit-test
[ ] [ gc-stats. ] unit-test
[ ] [ gc-summary. ] unit-test

221
basis/tools/memory/memory.factor
View File

@ -1,55 +1,78 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays generic assocs io math
namespaces parser prettyprint strings io.styles words
system sorting splitting grouping math.parser classes memory
combinators fry ;
USING: accessors arrays assocs classes classes.struct
combinators combinators.smart continuations fry generalizations
generic grouping io io.styles kernel make math math.parser
math.statistics memory namespaces parser prettyprint sequences
sorting specialized-arrays splitting strings system vm words ;
SPECIALIZED-ARRAY: gc-event
IN: tools.memory
<PRIVATE
: write-size ( n -- )
number>string
dup length 4 > [ 3 cut* "," glue ] when
" KB" append write-cell ;
: commas ( n -- str )
dup 0 < [ neg commas "-" prepend ] [
number>string
reverse 3 group "," join reverse
] if ;
: write-total/used/free ( free total str -- )
[
write-cell
dup write-size
over - write-size
write-size
] with-row ;
: kilobytes ( n -- str )
1024 /i commas " KB" append ;
: write-total ( n str -- )
[
write-cell
write-size
[ ] with-cell
[ ] with-cell
] with-row ;
: micros>string ( n -- str )
commas " µs" append ;
: write-headings ( seq -- )
[ [ write-cell ] each ] with-row ;
: copying-room. ( copying-sizes -- )
{
{ "Size:" [ size>> kilobytes ] }
{ "Occupied:" [ occupied>> kilobytes ] }
{ "Free:" [ free>> kilobytes ] }
} object-table. ;
: (data-room.) ( -- )
data-room 2 <groups> [
[ first2 ] [ number>string "Generation " prepend ] bi*
write-total/used/free
] each-index
"Decks" write-total
"Cards" write-total ;
: nursery-room. ( data-room -- )
"- Nursery space" print nursery>> copying-room. ;
: write-labeled-size ( n string -- )
[ write-cell write-size ] with-row ;
: aging-room. ( data-room -- )
"- Aging space" print aging>> copying-room. ;
: (code-room.) ( -- )
code-room {
[ "Size:" write-labeled-size ]
[ "Used:" write-labeled-size ]
[ "Total free space:" write-labeled-size ]
[ "Largest free block:" write-labeled-size ]
} spread ;
: mark-sweep-table. ( mark-sweep-sizes -- )
{
{ "Size:" [ size>> kilobytes ] }
{ "Occupied:" [ occupied>> kilobytes ] }
{ "Total free:" [ total-free>> kilobytes ] }
{ "Contiguous free:" [ contiguous-free>> kilobytes ] }
{ "Free block count:" [ free-block-count>> number>string ] }
} object-table. ;
: tenured-room. ( data-room -- )
"- Tenured space" print tenured>> mark-sweep-table. ;
: misc-room. ( data-room -- )
"- Miscellaneous buffers" print
{
{ "Card array:" [ cards>> kilobytes ] }
{ "Deck array:" [ decks>> kilobytes ] }
{ "Mark stack:" [ mark-stack>> kilobytes ] }
} object-table. ;
: data-room. ( -- )
"== Data heap ==" print nl
data-room data-heap-room memory>struct {
[ nursery-room. nl ]
[ aging-room. nl ]
[ tenured-room. nl ]
[ misc-room. ]
} cleave ;
: code-room. ( -- )
"== Code heap ==" print nl
code-room mark-sweep-sizes memory>struct mark-sweep-table. ;
PRIVATE>
: room. ( -- ) data-room. nl code-room. ;
<PRIVATE
: heap-stat-step ( obj counts sizes -- )
[ [ class ] dip inc-at ]
@ -57,26 +80,13 @@ IN: tools.memory
PRIVATE>
: room. ( -- )
"==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
nl nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
] tabular-output
nl ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
[ '[ _ _ heap-stat-step ] each ] 2keep ;
: heap-stats. ( -- )
heap-stats dup keys natural-sort standard-table-style [
{ "Class" "Bytes" "Instances" } write-headings
[ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
[
[
dup pprint-cell
@ -85,3 +95,104 @@ PRIVATE>
] with-row
] each 2drop
] tabular-output nl ;
SYMBOL: gc-events
: collect-gc-events ( quot -- )
enable-gc-events
[ ] [ disable-gc-events drop ] cleanup
disable-gc-events byte-array>gc-event-array gc-events set ; inline
<PRIVATE
: gc-op-string ( op -- string )
{
{ collect-nursery-op [ "Copying from nursery" ] }
{ collect-aging-op [ "Copying from aging" ] }
{ collect-to-tenured-op [ "Copying to tenured" ] }
{ collect-full-op [ "Mark and sweep" ] }
{ collect-compact-op [ "Mark and compact" ] }
{ collect-growing-heap-op [ "Grow heap" ] }
} case ;
: (space-occupied) ( data-heap-room code-heap-room -- n )
[
[ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
[ occupied>> ]
bi*
] sum-outputs ;
: space-occupied-before ( event -- bytes )
[ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
: space-occupied-after ( event -- bytes )
[ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
: space-reclaimed ( event -- bytes )
[ space-occupied-before ] [ space-occupied-after ] bi - ;
TUPLE: gc-stats collections times ;
: <gc-stats> ( -- stats )
gc-stats new
0 >>collections
V{ } clone >>times ; inline
: compute-gc-stats ( events -- stats )
V{ } clone [
'[
dup op>> _ [ drop <gc-stats> ] cache
[ 1 + ] change-collections
[ total-time>> ] dip times>> push
] each
] keep sort-keys ;
: gc-stats-table-row ( pair -- row )
[
[ first gc-op-string ] [
second
[ collections>> ]
[
times>> {
[ sum micros>string ]
[ mean >integer micros>string ]
[ median >integer micros>string ]
[ infimum micros>string ]
[ supremum micros>string ]
} cleave
] bi
] bi
] output>array ;
: gc-stats-table ( stats -- table )
[ gc-stats-table-row ] map
{ "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
PRIVATE>
: gc-event. ( event -- )
{
{ "Event type:" [ op>> gc-op-string ] }
{ "Total time:" [ total-time>> micros>string ] }
{ "Space reclaimed:" [ space-reclaimed kilobytes ] }
} object-table. ;
: gc-events. ( -- )
gc-events get [ gc-event. nl ] each ;
: gc-stats. ( -- )
gc-events get compute-gc-stats gc-stats-table simple-table. ;
: gc-summary. ( -- )
gc-events get {
{ "Collections:" [ length commas ] }
{ "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
{ "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
{ "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
{ "Total time:" [ [ total-time>> ] map-sum micros>string ] }
{ "Card scan time:" [ [ card-scan-time>> ] map-sum micros>string ] }
{ "Code block scan time:" [ [ code-scan-time>> ] map-sum micros>string ] }
{ "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum micros>string ] }
{ "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum micros>string ] }
{ "Compaction time:" [ [ compaction-time>> ] map-sum micros>string ] }
} object-table. ;

2
basis/tools/profiler/profiler-docs.factor
View File

@ -25,7 +25,7 @@ $nl
method-profile.
"profiler-limitations"
}
{ $see-also "ui.tools.profiler" } ;
{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ;
ABOUT: "profiling"

32
basis/tools/time/time-docs.factor
View File

@ -1,28 +1,38 @@
USING: help.markup help.syntax memory system ;
USING: help.markup help.syntax memory system tools.dispatch
tools.memory quotations vm ;
IN: tools.time
ARTICLE: "timing" "Timing code"
ARTICLE: "timing" "Timing code and collecting statistics"
"You can time the execution of a quotation in the listener:"
{ $subsections time }
"This word also collects statistics about method dispatch and garbage collection:"
{ $subsections dispatch-stats. gc-events. gc-stats. gc-summary. }
"A lower-level word puts timings on the stack, intead of printing:"
{ $subsections benchmark }
"You can also read the system clock and garbage collection statistics directly:"
{ $subsections
micros
gc-stats
}
{ $see-also "profiling" } ;
"You can also read the system clock directly:"
{ $subsections micros }
{ $see-also "profiling" "calendar" } ;
ABOUT: "timing"
HELP: benchmark
{ $values { "quot" "a quotation" }
{ $values { "quot" quotation }
{ "runtime" "the runtime in microseconds" } }
{ $description "Runs a quotation, measuring the total wall clock time." }
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
HELP: time
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
{ $values { "quot" quotation } }
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
{ benchmark micros time } related-words
HELP: collect-gc-events
{ $values { "quot" quotation } }
{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
HELP: collect-dispatch-stats
{ $values { "quot" quotation } }
{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;

76
basis/tools/time/time.factor
View File

@ -1,74 +1,22 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math memory io io.styles prettyprint
namespaces system sequences splitting grouping assocs strings
generic.single combinators ;
USING: system kernel math io prettyprint tools.memory
tools.dispatch ;
IN: tools.time
: benchmark ( quot -- runtime )
micros [ call micros ] dip - ; inline
: time. ( time -- )
"== Running time ==" print nl 1000000 /f pprint " seconds" print ;
"Running time: " write 1000000 /f pprint " seconds" print ;
: gc-stats. ( stats -- )
5 cut*
"== Garbage collection ==" print nl
"Times are in microseconds." print nl
[
6 group
{
"GC count:"
"Total GC time:"
"Longest GC pause:"
"Average GC pause:"
"Objects copied:"
"Bytes copied:"
} prefix
flip
{ "" "Nursery" "Aging" "Tenured" } prefix
simple-table.
]
[
nl
{
"Total GC time:"
"Cards scanned:"
"Decks scanned:"
"Card scan time:"
"Code heap literal scans:"
} swap zip simple-table.
] bi* ;
: dispatch-stats. ( stats -- )
"== Megamorphic caches ==" print nl
{ "Hits" "Misses" } swap zip simple-table. ;
: inline-cache-stats. ( stats -- )
nl "== Polymorphic inline caches ==" print nl
3 cut
[
"Transitions:" print
{ "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
simple-table. nl
] [
"Type check stubs:" print
{ "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
simple-table.
] bi* ;
: time-banner. ( -- )
"Additional information was collected." print
"dispatch-stats. - Print method dispatch statistics" print
"gc-events. - Print all garbage collection events" print
"gc-stats. - Print breakdown of different garbage collection events" print
"gc-summary. - Print aggregate garbage collection statistics" print ;
: time ( quot -- )
gc-reset
reset-dispatch-stats
reset-inline-cache-stats
benchmark gc-stats dispatch-stats inline-cache-stats
H{ { table-gap { 20 20 } } } [
[
[ [ time. ] 3dip ] with-cell
[ ] with-cell
] with-row
[
[ [ gc-stats. ] 2dip ] with-cell
[ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
] with-row
] tabular-output nl ; inline
[ [ benchmark ] collect-dispatch-stats ] collect-gc-events
time. nl time-banner. ; inline

77
basis/vm/vm.factor
View File

@ -3,20 +3,77 @@
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
TYPEDEF: void* cell
TYPEDEF: intptr_t cell
C-TYPE: context
STRUCT: zone
{ start cell }
{ here cell }
{ size cell }
{ end cell } ;
{ start cell }
{ here cell }
{ size cell }
{ end cell } ;
STRUCT: vm
{ stack_chain context* }
{ nursery zone }
{ cards_offset cell }
{ decks_offset cell }
{ userenv cell[70] } ;
{ stack_chain context* }
{ nursery zone }
{ cards_offset cell }
{ decks_offset cell }
{ userenv cell[70] } ;
: vm-field-offset ( field -- offset ) vm offset-of ; inline
C-ENUM:
collect-nursery-op
collect-aging-op
collect-to-tenured-op
collect-full-op
collect-compact-op
collect-growing-heap-op ;
STRUCT: copying-sizes
{ size cell }
{ occupied cell }
{ free cell } ;
STRUCT: mark-sweep-sizes
{ size cell }
{ occupied cell }
{ total-free cell }
{ contiguous-free cell }
{ free-block-count cell } ;
STRUCT: data-heap-room
{ nursery copying-sizes }
{ aging copying-sizes }
{ tenured mark-sweep-sizes }
{ cards cell }
{ decks cell }
{ mark-stack cell } ;
STRUCT: gc-event
{ op uint }
{ data-heap-before data-heap-room }
{ code-heap-before mark-sweep-sizes }
{ data-heap-after data-heap-room }
{ code-heap-after mark-sweep-sizes }
{ cards-scanned cell }
{ decks-scanned cell }
{ code-blocks-scanned cell }
{ start-time ulonglong }
{ total-time cell }
{ card-scan-time cell }
{ code-scan-time cell }
{ data-sweep-time cell }
{ code-sweep-time cell }
{ compaction-time cell }
{ temp-time cell } ;
STRUCT: dispatch-statistics
{ megamorphic-cache-hits cell }
{ megamorphic-cache-misses cell }
{ cold-call-to-ic-transitions cell }
{ ic-to-pic-transitions cell }
{ pic-to-mega-transitions cell }
{ pic-tag-count cell }
{ pic-tuple-count cell } ;

19
core/alien/alien.factor
View File

@ -4,19 +4,9 @@ USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays init ;
IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: simple-alien < alien underlying>> not ;
PREDICATE: pinned-alien < alien underlying>> not ;
UNION: simple-c-ptr
simple-alien POSTPONE: f byte-array ;
DEFER: pinned-c-ptr?
PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
GENERIC: >c-ptr ( obj -- c-ptr )
@ -33,7 +23,7 @@ M: alien expired? expired>> ;
M: f expired? drop t ;
: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
f <displaced-alien> { pinned-c-ptr } declare ; inline
: <bad-alien> ( -- alien )
-1 <alien> t >>expired ; inline
@ -49,7 +39,8 @@ M: alien equal?
2drop f
] if ;
M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
M: pinned-alien hashcode*
nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
ERROR: alien-callback-error ;

32
core/bootstrap/layouts/layouts.factor
View File

@ -5,32 +5,28 @@ hashtables vectors strings sbufs arrays
quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
16 data-alignment set
15 num-types set
BIN: 1111 tag-mask set
4 tag-bits set
14 num-types set
32 mega-cache-size set
H{
{ fixnum BIN: 000 }
{ bignum BIN: 001 }
{ array BIN: 010 }
{ float BIN: 011 }
{ quotation BIN: 100 }
{ POSTPONE: f BIN: 101 }
{ object BIN: 110 }
{ hi-tag BIN: 110 }
{ tuple BIN: 111 }
} tag-numbers set
tag-numbers get H{
{ fixnum 0 }
{ POSTPONE: f 1 }
{ array 2 }
{ float 3 }
{ quotation 4 }
{ bignum 5 }
{ alien 6 }
{ tuple 7 }
{ wrapper 8 }
{ byte-array 9 }
{ callstack 10 }
{ string 11 }
{ word 12 }
{ dll 13 }
{ alien 14 }
} assoc-union type-numbers set
} type-numbers set

19
core/bootstrap/primitives.factor
View File

@ -99,6 +99,7 @@ bootstrapping? on
"system"
"system.private"
"threads.private"
"tools.dispatch.private"
"tools.profiler.private"
"words"
"words.private"
@ -177,10 +178,6 @@ bi
"object?" "kernel" vocab-words delete-at
! Class of objects with object tag
"hi-tag" "kernel.private" create
builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } f union-class define-class ]
@ -423,7 +420,6 @@ tuple
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
{ "compact-gc" "memory" (( -- )) }
{ "gc-stats" "memory" f }
{ "(save-image)" "memory.private" (( path -- )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
@ -433,8 +429,8 @@ tuple
{ "set-retainstack" "kernel" (( rs -- )) }
{ "set-callstack" "kernel" (( cs -- )) }
{ "exit" "system" (( n -- )) }
{ "data-room" "memory" (( -- cards decks generations )) }
{ "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
{ "data-room" "memory" (( -- data-room )) }
{ "code-room" "memory" (( -- code-room )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
@ -509,7 +505,6 @@ tuple
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
{ "dll-valid?" "alien.libraries" (( dll -- ? )) }
{ "unimplemented" "kernel.private" (( -- * )) }
{ "gc-reset" "memory" (( -- )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
@ -517,15 +512,15 @@ tuple
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
{ "reset-dispatch-stats" "generic.single" (( -- )) }
{ "dispatch-stats" "generic.single" (( -- stats )) }
{ "reset-inline-cache-stats" "generic.single" (( -- )) }
{ "inline-cache-stats" "generic.single" (( -- stats )) }
{ "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }
{ "dispatch-stats" "tools.dispatch.private" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
{ "vm-ptr" "vm" (( -- ptr )) }
{ "strip-stack-traces" "kernel.private" (( -- )) }
{ "<callback>" "alien" (( word -- alien )) }
{ "enable-gc-events" "memory" (( -- )) }
{ "disable-gc-events" "memory" (( -- events )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number

1
core/classes/algebra/algebra-docs.factor
View File

@ -17,7 +17,6 @@ ARTICLE: "class-operations" "Class operations"
flatten-class
flatten-builtin-class
class-types
class-tags
} ;
ARTICLE: "class-linearization" "Class linearization"

2
core/classes/algebra/algebra-tests.factor
View File

@ -95,8 +95,6 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<=
] unit-test

10
core/classes/algebra/algebra.factor
View File

@ -237,11 +237,5 @@ M: anonymous-union (flatten-class)
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-type ( class -- tag/f )
class-types dup length 1 = [ first ] [ drop f ] if ;

18
core/classes/builtin/builtin.factor
View File

@ -12,34 +12,20 @@ PREDICATE: builtin-class < class
: class>type ( class -- n ) "type" word-prop ; foldable
PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ; inline
M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
GENERIC: define-builtin-predicate ( class -- )
M: lo-tag-class define-builtin-predicate
M: builtin-class define-builtin-predicate
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
M: hi-tag-class define-builtin-predicate
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
[ dup tag 6 eq? ] [ [ drop f ] if ] surround
define-predicate ;
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
M: hi-tag-class instance?
over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;

1
core/classes/classes-tests.factor
View File

@ -11,7 +11,6 @@ IN: classes.tests
[ f ] [ 3 float instance? ] unit-test
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
GENERIC: method-forget-test ( obj -- obj )

27
core/generic/single/single.factor
View File

@ -112,15 +112,6 @@ TUPLE: tuple-dispatch-engine echelons ;
tuple bootstrap-word
\ <tuple-dispatch-engine> convert-methods ;
! 2.2 Convert hi-tag methods
TUPLE: hi-tag-dispatch-engine methods ;
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
: convert-hi-tag-methods ( assoc -- assoc' )
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
! 3 Tag methods
TUPLE: tag-dispatch-engine methods ;
@ -129,7 +120,6 @@ C: <tag-dispatch-engine> tag-dispatch-engine
: <engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
convert-hi-tag-methods
<tag-dispatch-engine> ;
! ! ! Compile engine ! ! !
@ -144,23 +134,12 @@ GENERIC: compile-engine ( engine -- obj )
: direct-dispatch-table ( assoc n -- table )
default get <array> [ <enum> swap update ] keep ;
: lo-tag-number ( class -- n )
"type" word-prop dup num-tags get iota member?
[ drop object tag-number ] unless ;
: tag-number ( class -- n ) "type" word-prop ;
M: tag-dispatch-engine compile-engine
methods>> compile-engines*
[ [ lo-tag-number ] dip ] assoc-map
num-tags get direct-dispatch-table ;
: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n ) "type" word-prop ;
M: hi-tag-dispatch-engine compile-engine
methods>> compile-engines*
[ [ hi-tag-number num-tags get - ] dip ] assoc-map
num-hi-tags direct-dispatch-table ;
[ [ tag-number ] dip ] assoc-map
num-types get direct-dispatch-table ;
: build-fast-hash ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets

2
core/kernel/kernel-docs.factor
View File

@ -651,7 +651,7 @@ HELP: declare
HELP: tag ( object -- n )
{ $values { "object" object } { "n" "a tag number" } }
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ;
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
HELP: getenv ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }

2
core/kernel/kernel.factor
View File

@ -230,8 +230,6 @@ ERROR: assert got expect ;
: declare ( spec -- ) drop ;
: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>

15
core/layouts/layouts-docs.factor
View File

@ -7,18 +7,11 @@ HELP: tag-bits
{ $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
{ $see-also tag } ;
HELP: num-tags
{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ;
HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ;
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ;
HELP: type-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
@ -76,7 +69,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
{ $subsections hi-tag }
{ $subsections tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsections
type>class
@ -88,14 +81,10 @@ ARTICLE: "layouts-types" "Type numbers"
ARTICLE: "layouts-tags" "Tagged pointers"
"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
$nl
"Getting the tag of an object:"
{ $link tag }
"Words for working with tagged pointers:"
{ $subsections
tag-bits
num-tags
tag-mask
tag-number
}
"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;

11
core/layouts/layouts.factor
View File

@ -4,16 +4,14 @@ USING: namespaces math words kernel assocs classes
math.order kernel.private ;
IN: layouts
SYMBOL: tag-mask
SYMBOL: data-alignment
SYMBOL: num-tags
SYMBOL: tag-mask
SYMBOL: tag-bits
SYMBOL: num-types
SYMBOL: tag-numbers
SYMBOL: type-numbers
SYMBOL: mega-cache-size
@ -21,9 +19,6 @@ SYMBOL: mega-cache-size
: type-number ( class -- n )
type-numbers get at ;
: tag-number ( class -- n )
type-number dup num-tags get >= [ drop object tag-number ] when ;
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
@ -58,7 +53,7 @@ SYMBOL: mega-cache-size
first-bignum neg >fixnum ; inline
: (max-array-capacity) ( b -- n )
5 - 2^ 1 - ; inline
6 - 2^ 1 - ; inline
: max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline

2
core/slots/slots-docs.factor
View File

@ -71,7 +71,7 @@ $nl
{ { { $link float } } { $snippet "0.0" } }
{ { { $link string } } { $snippet "\"\"" } }
{ { { $link byte-array } } { $snippet "B{ }" } }
{ { { $link simple-alien } } { $snippet "BAD-ALIEN" } }
{ { { $link pinned-alien } } { $snippet "BAD-ALIEN" } }
}
"All other classes are handled with one of two cases:"
{ $list

2
core/slots/slots.factor
View File

@ -173,7 +173,7 @@ M: class initial-value* no-initial-value ;
{ [ string bootstrap-word over class<= ] [ "" ] }
{ [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
{ [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
{ [ quotation bootstrap-word over class<= ] [ [ ] ] }
[ dup initial-value* ]
} cond nip ;

27
vm/aging_collector.cpp
View File

@ -6,7 +6,6 @@ namespace factor
aging_collector::aging_collector(factor_vm *parent_) :
copying_collector<aging_space,aging_policy>(
parent_,
&parent_->gc_stats.aging_stats,
parent_->data->aging,
aging_policy(parent_)) {}
@ -22,28 +21,40 @@ void factor_vm::collect_aging()
current_gc->op = collect_to_tenured_op;
to_tenured_collector collector(this);
current_gc->event->started_code_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
simple_unmarker(card_mark_mask));
collector.cheneys_algorithm();
full_unmarker());
current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
current_gc->event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_aging);
current_gc->event->ended_code_scan(collector.code_blocks_scanned);
collector.tenure_reachable_objects();
current_gc->event->started_code_sweep();
update_code_heap_for_minor_gc(&code->points_to_aging);
current_gc->event->ended_code_sweep();
}
{
/* If collection fails here, do a to_tenured collection. */
current_gc->op = collect_aging_op;
std::swap(data->aging,data->aging_semispace);
reset_generation(data->aging);
data->reset_generation(data->aging);
aging_collector collector(this);
collector.trace_roots();
collector.trace_contexts();
collector.trace_code_heap_roots(&code->points_to_aging);
collector.cheneys_algorithm();
update_code_heap_for_minor_gc(&code->points_to_aging);
nursery.here = nursery.start;
collector.cheneys_algorithm();
data->reset_generation(&nursery);
code->points_to_nursery.clear();
code->points_to_aging.clear();
}
}

11
vm/aging_collector.hpp
View File

@ -3,9 +3,10 @@ namespace factor
struct aging_policy {
factor_vm *parent;
zone *aging, *tenured;
aging_space *aging;
tenured_space *tenured;
aging_policy(factor_vm *parent_) :
explicit aging_policy(factor_vm *parent_) :
parent(parent_),
aging(parent->data->aging),
tenured(parent->data->tenured) {}
@ -14,10 +15,14 @@ struct aging_policy {
{
return !(aging->contains_p(untagged) || tenured->contains_p(untagged));
}
void promoted_object(object *obj) {}
void visited_object(object *obj) {}
};
struct aging_collector : copying_collector<aging_space,aging_policy> {
aging_collector(factor_vm *parent_);
explicit aging_collector(factor_vm *parent_);
};
}

25
vm/aging_space.hpp
View File

@ -1,8 +1,29 @@
namespace factor
{
struct aging_space : old_space {
aging_space(cell size, cell start) : old_space(size,start) {}
struct aging_space : bump_allocator<object> {
object_start_map starts;
explicit aging_space(cell size, cell start) :
bump_allocator<object>(size,start), starts(size,start) {}
object *allot(cell size)
{
if(here + size > end) return NULL;
object *obj = bump_allocator<object>::allot(size);
starts.record_object_start_offset(obj);
return obj;
}
cell next_object_after(cell scan)
{
cell size = ((object *)scan)->size();
if(scan + size < here)
return scan + size;
else
return 0;
}
};
}

25
vm/alien.cpp
View File

@ -14,7 +14,10 @@ char *factor_vm::pinned_alien_offset(cell obj)
alien *ptr = untag<alien>(obj);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
return pinned_alien_offset(ptr->base) + ptr->displacement;
if(to_boolean(ptr->base))
type_error(ALIEN_TYPE,obj);
else
return (char *)ptr->address;
}
case F_TYPE:
return NULL;
@ -27,8 +30,8 @@ char *factor_vm::pinned_alien_offset(cell obj)
/* make an alien */
cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
gc_root<object> delegate(delegate_,this);
gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
data_root<object> delegate(delegate_,this);
data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
if(delegate.type_p(ALIEN_TYPE))
{
@ -41,6 +44,7 @@ cell factor_vm::allot_alien(cell delegate_, cell displacement)
new_alien->displacement = displacement;
new_alien->expired = false_object;
new_alien->update_address();
return new_alien.value();
}
@ -113,9 +117,9 @@ DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
/* open a native library and push a handle */
void factor_vm::primitive_dlopen()
{
gc_root<byte_array> path(dpop(),this);
data_root<byte_array> path(dpop(),this);
path.untag_check(this);
gc_root<dll> library(allot<dll>(sizeof(dll)),this);
data_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
@ -124,8 +128,8 @@ void factor_vm::primitive_dlopen()
/* look up a symbol in a native library */
void factor_vm::primitive_dlsym()
{
gc_root<object> library(dpop(),this);
gc_root<byte_array> name(dpop(),this);
data_root<object> library(dpop(),this);
data_root<byte_array> name(dpop(),this);
name.untag_check(this);
symbol_char *sym = name->data<symbol_char>();
@ -168,12 +172,7 @@ char *factor_vm::alien_offset(cell obj)
case BYTE_ARRAY_TYPE:
return untag<byte_array>(obj)->data<char>();
case ALIEN_TYPE:
{
alien *ptr = untag<alien>(obj);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
return alien_offset(ptr->base) + ptr->displacement;
}
return (char *)untag<alien>(obj)->address;
case F_TYPE:
return NULL;
default:

28
vm/arrays.cpp
View File

@ -6,8 +6,8 @@ namespace factor
/* make a new array with an initial element */
array *factor_vm::allot_array(cell capacity, cell fill_)
{
gc_root<object> fill(fill_,this);
gc_root<array> new_array(allot_array_internal<array>(capacity),this);
data_root<object> fill(fill_,this);
data_root<array> new_array(allot_uninitialized_array<array>(capacity),this);
memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
return new_array.untagged();
}
@ -22,17 +22,17 @@ void factor_vm::primitive_array()
cell factor_vm::allot_array_1(cell obj_)
{
gc_root<object> obj(obj_,this);
gc_root<array> a(allot_array_internal<array>(1),this);
data_root<object> obj(obj_,this);
data_root<array> a(allot_uninitialized_array<array>(1),this);
set_array_nth(a.untagged(),0,obj.value());
return a.value();
}
cell factor_vm::allot_array_2(cell v1_, cell v2_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
gc_root<array> a(allot_array_internal<array>(2),this);
data_root<object> v1(v1_,this);
data_root<object> v2(v2_,this);
data_root<array> a(allot_uninitialized_array<array>(2),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
return a.value();
@ -40,11 +40,11 @@ cell factor_vm::allot_array_2(cell v1_, cell v2_)
cell factor_vm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
gc_root<object> v1(v1_,this);
gc_root<object> v2(v2_,this);
gc_root<object> v3(v3_,this);
gc_root<object> v4(v4_,this);
gc_root<array> a(allot_array_internal<array>(4),this);
data_root<object> v1(v1_,this);
data_root<object> v2(v2_,this);
data_root<object> v3(v3_,this);
data_root<object> v4(v4_,this);
data_root<array> a(allot_uninitialized_array<array>(4),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
set_array_nth(a.untagged(),2,v3.value());
@ -62,7 +62,7 @@ void factor_vm::primitive_resize_array()
void growable_array::add(cell elt_)
{
factor_vm *parent = elements.parent;
gc_root<object> elt(elt_,parent);
data_root<object> elt(elt_,parent);
if(count == array_capacity(elements.untagged()))
elements = parent->reallot_array(elements.untagged(),count * 2);
@ -72,7 +72,7 @@ void growable_array::add(cell elt_)
void growable_array::append(array *elts_)
{
factor_vm *parent = elements.parent;
gc_root<array> elts(elts_,parent);
data_root<array> elts(elts_,parent);
cell capacity = array_capacity(elts.untagged());
if(count + capacity > array_capacity(elements.untagged()))
{

3
vm/arrays.hpp
View File

@ -15,7 +15,6 @@ inline void factor_vm::set_array_nth(array *array, cell slot, cell value)
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(array->h.hi_tag() == ARRAY_TYPE);
check_tagged_pointer(value);
#endif
cell *slot_ptr = &array->data()[slot];
*slot_ptr = value;
@ -24,7 +23,7 @@ inline void factor_vm::set_array_nth(array *array, cell slot, cell value)
struct growable_array {
cell count;
gc_root<array> elements;
data_root<array> elements;
explicit growable_array(factor_vm *parent, cell capacity = 10) :
count(0), elements(parent->allot_array(capacity,false_object),parent) {}

2
vm/bignum.cpp
View File

@ -1299,7 +1299,7 @@ bignum *factor_vm::bignum_digit_to_bignum(bignum_digit_type digit, int negative_
bignum *factor_vm::allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
bignum * result = allot_array_internal<bignum>(length + 1);
bignum * result = allot_uninitialized_array<bignum>(length + 1);
BIGNUM_SET_NEGATIVE_P (result, negative_p);
return (result);
}

67
vm/bitwise_hacks.hpp Normal file
View File

@ -0,0 +1,67 @@
namespace factor
{
/* These algorithms were snarfed from various places. I did not come up with them myself */
inline cell popcount(u64 x)
{
u64 k1 = 0x5555555555555555ll;
u64 k2 = 0x3333333333333333ll;
u64 k4 = 0x0f0f0f0f0f0f0f0fll;
u64 kf = 0x0101010101010101ll;
x = x - ((x >> 1) & k1); // put count of each 2 bits into those 2 bits
x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits
x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits
x = (x * kf) >> 56; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
return (cell)x;
}
inline cell log2(u64 x)
{
#ifdef FACTOR_AMD64
cell n;
asm ("bsr %1, %0;":"=r"(n):"r"((cell)x));
#else
cell n = 0;
if (x >= (u64)1 << 32) { x >>= 32; n += 32; }
if (x >= (u64)1 << 16) { x >>= 16; n += 16; }
if (x >= (u64)1 << 8) { x >>= 8; n += 8; }
if (x >= (u64)1 << 4) { x >>= 4; n += 4; }
if (x >= (u64)1 << 2) { x >>= 2; n += 2; }
if (x >= (u64)1 << 1) { n += 1; }
#endif
return n;
}
inline cell log2(u16 x)
{
#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
cell n;
asm ("bsr %1, %0;":"=r"(n):"r"((cell)x));
#else
cell n = 0;
if (x >= 1 << 8) { x >>= 8; n += 8; }
if (x >= 1 << 4) { x >>= 4; n += 4; }
if (x >= 1 << 2) { x >>= 2; n += 2; }
if (x >= 1 << 1) { n += 1; }
#endif
return n;
}
inline cell rightmost_clear_bit(u64 x)
{
return log2(~x & (x + 1));
}
inline cell rightmost_set_bit(u64 x)
{
return log2(x & -x);
}
inline cell rightmost_set_bit(u16 x)
{
return log2((u16)(x & -x));
}
}

37
vm/bump_allocator.hpp Normal file
View File

@ -0,0 +1,37 @@
namespace factor
{
template<typename Block> struct bump_allocator {
/* offset of 'here' and 'end' is hardcoded in compiler backends */
cell here;
cell start;
cell end;
cell size;
explicit bump_allocator(cell size_, cell start_) :
here(start_), start(start_), end(start_ + size_), size(size_) {}
bool contains_p(Block *block)
{
return ((cell)block - start) < size;
}
Block *allot(cell size)
{
cell h = here;
here = h + align(size,data_alignment);
return (Block *)h;
}
cell occupied_space()
{
return here - start;
}
cell free_space()
{
return end - here;
}
};
}

6
vm/byte_arrays.cpp
View File

@ -5,7 +5,7 @@ namespace factor
byte_array *factor_vm::allot_byte_array(cell size)
{
byte_array *array = allot_array_internal<byte_array>(size);
byte_array *array = allot_uninitialized_array<byte_array>(size);
memset(array + 1,0,size);
return array;
}
@ -19,7 +19,7 @@ void factor_vm::primitive_byte_array()
void factor_vm::primitive_uninitialized_byte_array()
{
cell size = unbox_array_size();
dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
dpush(tag<byte_array>(allot_uninitialized_array<byte_array>(size)));
}
void factor_vm::primitive_resize_byte_array()
@ -43,7 +43,7 @@ void growable_byte_array::append_bytes(void *elts, cell len)
void growable_byte_array::append_byte_array(cell byte_array_)
{
gc_root<byte_array> byte_array(byte_array_,elements.parent);
data_root<byte_array> byte_array(byte_array_,elements.parent);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;

15
vm/byte_arrays.hpp
View File

@ -3,7 +3,7 @@ namespace factor
struct growable_byte_array {
cell count;
gc_root<byte_array> elements;
data_root<byte_array> elements;
explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { }
@ -13,4 +13,17 @@ struct growable_byte_array {
void trim();
};
template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value)
{
return byte_array_from_values(value,1);
}
template<typename Type> byte_array *factor_vm::byte_array_from_values(Type *values, cell len)
{
cell size = sizeof(Type) * len;
byte_array *data = allot_uninitialized_array<byte_array>(size);
memcpy(data->data<char>(),values,size);
return data;
}
}

8
vm/callbacks.cpp
View File

@ -21,7 +21,7 @@ void factor_vm::init_callbacks(cell size)
void callback_heap::update(callback *stub)
{
tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
@ -35,18 +35,18 @@ void callback_heap::update(callback *stub)
callback *callback_heap::add(code_block *compiled)
{
tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
tagged<byte_array> insns(array_nth(code_template.untagged(),0));
cell size = array_capacity(insns.untagged());
cell bump = align8(size) + sizeof(callback);
cell bump = align(size,sizeof(cell)) + sizeof(callback);
if(here + bump > seg->end) fatal_error("Out of callback space",0);
callback *stub = (callback *)here;
stub->compiled = compiled;
memcpy(stub + 1,insns->data<void>(),size);
stub->size = align8(size);
stub->size = align(size,sizeof(cell));
here += bump;
update(stub);

16
vm/callstack.cpp
View File

@ -76,7 +76,7 @@ code_block *factor_vm::frame_code(stack_frame *frame)
return (code_block *)frame->xt - 1;
}
cell factor_vm::frame_type(stack_frame *frame)
code_block_type factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type();
}
@ -97,7 +97,7 @@ cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
{
case QUOTATION_TYPE:
case code_block_unoptimized:
{
cell quot = frame_executing(frame);
if(to_boolean(quot))
@ -111,7 +111,7 @@ cell factor_vm::frame_scan(stack_frame *frame)
else
return false_object;
}
case WORD_TYPE:
case code_block_optimized:
return false_object;
default:
critical_error("Bad frame type",frame_type(frame));
@ -130,8 +130,8 @@ struct stack_frame_accumulator {
void operator()(stack_frame *frame)
{
gc_root<object> executing(parent->frame_executing(frame),parent);
gc_root<object> scan(parent->frame_scan(frame),parent);
data_root<object> executing(parent->frame_executing(frame),parent);
data_root<object> scan(parent->frame_scan(frame),parent);
frames.add(executing.value());
frames.add(scan.value());
@ -142,7 +142,7 @@ struct stack_frame_accumulator {
void factor_vm::primitive_callstack_to_array()
{
gc_root<callstack> callstack(dpop(),this);
data_root<callstack> callstack(dpop(),this);
stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
@ -184,8 +184,8 @@ void factor_vm::primitive_innermost_stack_frame_scan()
void factor_vm::primitive_set_innermost_stack_frame_quot()
{
gc_root<callstack> callstack(dpop(),this);
gc_root<quotation> quot(dpop(),this);
data_root<callstack> callstack(dpop(),this);
data_root<quotation> quot(dpop(),this);
callstack.untag_check(this);
quot.untag_check(this);

2
vm/callstack.hpp
View File

@ -12,7 +12,7 @@ VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *
keep the callstack in a GC root and use relative offsets */
template<typename Iterator> void factor_vm::iterate_callstack_object(callstack *stack_, Iterator &iterator)
{
gc_root<callstack> stack(stack_,this);
data_root<callstack> stack(stack_,this);
fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
while(frame_offset >= 0)

43
vm/code_block.cpp
View File

@ -127,9 +127,8 @@ void *factor_vm::get_rel_symbol(array *literals, cell index)
}
case ARRAY_TYPE:
{
cell i;
array *names = untag<array>(symbol);
for(i = 0; i < array_capacity(names); i++)
for(cell i = 0; i < array_capacity(names); i++)
{
symbol_char *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(d,name);
@ -179,7 +178,7 @@ cell factor_vm::compute_relocation(relocation_entry rel, cell index, code_block
case RT_UNTAGGED:
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
return (cell)&megamorphic_cache_hits;
return (cell)&dispatch_stats.megamorphic_cache_hits;
case RT_VM:
return (cell)this + untag_fixnum(ARG);
case RT_CARDS_OFFSET:
@ -286,7 +285,7 @@ struct literal_references_updater {
if(parent->relocation_type_of(rel) == RT_IMMEDIATE)
{
cell offset = parent->relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = parent->untag<array>(compiled->literals);
array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
parent->store_address_in_code_block(parent->relocation_class_of(rel),offset,absolute_value);
}
@ -346,7 +345,7 @@ void factor_vm::update_word_references(code_block *compiled)
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
else if(compiled->type() == PIC_TYPE)
else if(compiled->pic_p())
code->code_heap_free(compiled);
else
{
@ -379,7 +378,7 @@ struct literal_and_word_references_updater {
}
};
void factor_vm::update_code_block_for_full_gc(code_block *compiled)
void factor_vm::update_code_block_words_and_literals(code_block *compiled)
{
if(code->needs_fixup_p(compiled))
relocate_code_block(compiled);
@ -437,9 +436,9 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
}
/* Might GC */
code_block *factor_vm::allot_code_block(cell size, cell type)
code_block *factor_vm::allot_code_block(cell size, code_block_type type)
{
heap_block *block = code->heap_allot(size + sizeof(code_block),type);
code_block *block = code->allocator->allot(size + sizeof(code_block));
/* If allocation failed, do a full GC and compact the code heap.
A full GC that occurs as a result of the data heap filling up does not
@ -449,35 +448,31 @@ code_block *factor_vm::allot_code_block(cell size, cell type)
if(block == NULL)
{
primitive_compact_gc();
block = code->heap_allot(size + sizeof(code_block),type);
block = code->allocator->allot(size + sizeof(code_block));
/* Insufficient room even after code GC, give up */
if(block == NULL)
{
cell used, total_free, max_free;
code->heap_usage(&used,&total_free,&max_free);
print_string("Code heap stats:\n");
print_string("Used: "); print_cell(used); nl();
print_string("Total free space: "); print_cell(total_free); nl();
print_string("Largest free block: "); print_cell(max_free); nl();
std::cout << "Code heap used: " << code->allocator->occupied_space() << "\n";
std::cout << "Code heap free: " << code->allocator->free_space() << "\n";
fatal_error("Out of memory in add-compiled-block",0);
}
}
return (code_block *)block;
block->set_type(type);
return block;
}
/* Might GC */
code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
code_block *factor_vm::add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
{
gc_root<byte_array> code(code_,this);
gc_root<object> labels(labels_,this);
gc_root<object> owner(owner_,this);
gc_root<byte_array> relocation(relocation_,this);
gc_root<array> literals(literals_,this);
data_root<byte_array> code(code_,this);
data_root<object> labels(labels_,this);
data_root<object> owner(owner_,this);
data_root<byte_array> relocation(relocation_,this);
data_root<array> literals(literals_,this);
cell code_length = align8(array_capacity(code.untagged()));
cell code_length = array_capacity(code.untagged());
code_block *compiled = allot_code_block(code_length,type);
compiled->owner = owner.value();

89
vm/code_block_visitor.hpp Normal file
View File

@ -0,0 +1,89 @@
namespace factor
{
template<typename Visitor> struct call_frame_code_block_visitor {
factor_vm *parent;
Visitor visitor;
explicit call_frame_code_block_visitor(factor_vm *parent_, Visitor visitor_) :
parent(parent_), visitor(visitor_) {}
void operator()(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
code_block *new_block = visitor(parent->frame_code(frame));
frame->xt = new_block->xt();
FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
}
};
template<typename Visitor> struct callback_code_block_visitor {
callback_heap *callbacks;
Visitor visitor;
explicit callback_code_block_visitor(callback_heap *callbacks_, Visitor visitor_) :
callbacks(callbacks_), visitor(visitor_) {}
void operator()(callback *stub)
{
stub->compiled = visitor(stub->compiled);
callbacks->update(stub);
}
};
template<typename Visitor> struct code_block_visitor {
factor_vm *parent;
Visitor visitor;
explicit code_block_visitor(factor_vm *parent_, Visitor visitor_) :
parent(parent_), visitor(visitor_) {}
void visit_object_code_block(object *obj)
{
switch(obj->h.hi_tag())
{
case WORD_TYPE:
{
word *w = (word *)obj;
if(w->code)
w->code = visitor(w->code);
if(w->profiling)
w->code = visitor(w->profiling);
parent->update_word_xt(w);
break;
}
case QUOTATION_TYPE:
{
quotation *q = (quotation *)obj;
if(q->code)
parent->set_quot_xt(q,visitor(q->code));
break;
}
case CALLSTACK_TYPE:
{
callstack *stack = (callstack *)obj;
call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
parent->iterate_callstack_object(stack,call_frame_visitor);
break;
}
}
}
void visit_context_code_blocks()
{
call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
parent->iterate_active_frames(call_frame_visitor);
}
void visit_callback_code_blocks()
{
callback_code_block_visitor<Visitor> callback_visitor(parent->callbacks,visitor);
parent->callbacks->iterate(callback_visitor);
}
};
}

227
vm/code_heap.cpp
View File

@ -3,7 +3,21 @@
namespace factor
{
code_heap::code_heap(bool secure_gc, cell size) : heap(secure_gc,size,true) {}
code_heap::code_heap(cell size)
{
if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
seg = new segment(align_page(size),true);
if(!seg) fatal_error("Out of memory in heap allocator",size);
allocator = new free_list_allocator<code_block>(size,seg->start);
}
code_heap::~code_heap()
{
delete allocator;
allocator = NULL;
delete seg;
seg = NULL;
}
void code_heap::write_barrier(code_block *compiled)
{
@ -22,18 +36,33 @@ bool code_heap::needs_fixup_p(code_block *compiled)
return needs_fixup.count(compiled) > 0;
}
bool code_heap::marked_p(code_block *compiled)
{
return allocator->state.marked_p(compiled);
}
void code_heap::set_marked_p(code_block *compiled)
{
allocator->state.set_marked_p(compiled);
}
void code_heap::clear_mark_bits()
{
allocator->state.clear_mark_bits();
}
void code_heap::code_heap_free(code_block *compiled)
{
points_to_nursery.erase(compiled);
points_to_aging.erase(compiled);
needs_fixup.erase(compiled);
heap_free(compiled);
allocator->free(compiled);
}
/* Allocate a code heap during startup */
void factor_vm::init_code_heap(cell size)
{
code = new code_heap(secure_gc,size);
code = new code_heap(size);
}
bool factor_vm::in_code_heap_p(cell ptr)
@ -44,8 +73,8 @@ bool factor_vm::in_code_heap_p(cell ptr)
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
{
gc_root<word> word(word_,this);
gc_root<quotation> def(def_,this);
data_root<word> word(word_,this);
data_root<quotation> def(def_,this);
jit_compile(def.value(),relocate);
@ -59,7 +88,8 @@ struct word_updater {
factor_vm *parent;
explicit word_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(code_block *compiled)
void operator()(code_block *compiled, cell size)
{
parent->update_word_references(compiled);
}
@ -73,9 +103,49 @@ void factor_vm::update_code_heap_words()
iterate_code_heap(updater);
}
/* After a full GC that did not grow the heap, we have to update references
to literals and other words. */
struct word_and_literal_code_heap_updater {
factor_vm *parent;
explicit word_and_literal_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
void operator()(code_block *block, cell size)
{
parent->update_code_block_words_and_literals(block);
}
};
void factor_vm::update_code_heap_words_and_literals()
{
current_gc->event->started_code_sweep();
word_and_literal_code_heap_updater updater(this);
code->allocator->sweep(updater);
current_gc->event->ended_code_sweep();
}
/* After growing the heap, we have to perform a full relocation to update
references to card and deck arrays. */
struct code_heap_relocator {
factor_vm *parent;
explicit code_heap_relocator(factor_vm *parent_) : parent(parent_) {}
void operator()(code_block *block, cell size)
{
parent->relocate_code_block(block);
}
};
void factor_vm::relocate_code_heap()
{
code_heap_relocator relocator(this);
code->allocator->sweep(relocator);
}
void factor_vm::primitive_modify_code_heap()
{
gc_root<array> alist(dpop(),this);
data_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
@ -85,10 +155,10 @@ void factor_vm::primitive_modify_code_heap()
cell i;
for(i = 0; i < count; i++)
{
gc_root<array> pair(array_nth(alist.untagged(),i),this);
data_root<array> pair(array_nth(alist.untagged(),i),this);
gc_root<word> word(array_nth(pair.untagged(),0),this);
gc_root<object> data(array_nth(pair.untagged(),1),this);
data_root<word> word(array_nth(pair.untagged(),0),this);
data_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
@ -105,7 +175,7 @@ void factor_vm::primitive_modify_code_heap()
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
WORD_TYPE,
code_block_optimized,
code,
labels,
owner,
@ -120,136 +190,35 @@ void factor_vm::primitive_modify_code_heap()
break;
}
update_word_xt(word.value());
update_word_xt(word.untagged());
}
update_code_heap_words();
}
/* Push the free space and total size of the code heap */
code_heap_room factor_vm::code_room()
{
code_heap_room room;
room.size = code->allocator->size;
room.occupied_space = code->allocator->occupied_space();
room.total_free = code->allocator->free_space();
room.contiguous_free = code->allocator->largest_free_block();
room.free_block_count = code->allocator->free_block_count();
return room;
}
void factor_vm::primitive_code_room()
{
cell used, total_free, max_free;
code->heap_usage(&used,&total_free,&max_free);
dpush(tag_fixnum(code->seg->size / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
code_block *code_heap::forward_code_block(code_block *compiled)
{
return (code_block *)forwarding[compiled];
}
struct callframe_forwarder {
factor_vm *parent;
explicit callframe_forwarder(factor_vm *parent_) : parent(parent_) {}
void operator()(stack_frame *frame)
{
cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
code_block *forwarded = parent->code->forward_code_block(parent->frame_code(frame));
frame->xt = forwarded->xt();
FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
}
};
void factor_vm::forward_object_xts()
{
begin_scan();
cell obj;
while(to_boolean(obj = next_object()))
{
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
{
word *w = untag<word>(obj);
if(w->code)
w->code = code->forward_code_block(w->code);
if(w->profiling)
w->profiling = code->forward_code_block(w->profiling);
update_word_xt(obj);
}
break;
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
if(quot->code)
{
quot->code = code->forward_code_block(quot->code);
set_quot_xt(quot,quot->code);
}
}
break;
case CALLSTACK_TYPE:
{
callstack *stack = untag<callstack>(obj);
callframe_forwarder forwarder(this);
iterate_callstack_object(stack,forwarder);
}
break;
default:
break;
}
}
end_scan();
}
void factor_vm::forward_context_xts()
{
callframe_forwarder forwarder(this);
iterate_active_frames(forwarder);
}
struct callback_forwarder {
code_heap *code;
callback_heap *callbacks;
callback_forwarder(code_heap *code_, callback_heap *callbacks_) :
code(code_), callbacks(callbacks_) {}
void operator()(callback *stub)
{
stub->compiled = code->forward_code_block(stub->compiled);
callbacks->update(stub);
}
};
void factor_vm::forward_callback_xts()
{
callback_forwarder forwarder(code,callbacks);
callbacks->iterate(forwarder);
}
/* Move all free space to the end of the code heap. Live blocks must be marked
on entry to this function. XTs in code blocks must be updated after this
function returns. */
void factor_vm::compact_code_heap(bool trace_contexts_p)
{
code->compact_heap();
forward_object_xts();
if(trace_contexts_p)
{
forward_context_xts();
forward_callback_xts();
}
code_heap_room room = code_room();
dpush(tag<byte_array>(byte_array_from_value(&room)));
}
struct stack_trace_stripper {
explicit stack_trace_stripper() {}
void operator()(code_block *compiled)
void operator()(code_block *compiled, cell size)
{
compiled->owner = false_object;
}

23
vm/code_heap.hpp
View File

@ -1,7 +1,13 @@
namespace factor
{
struct code_heap : heap {
struct code_heap {
/* The actual memory area */
segment *seg;
/* Memory allocator */
free_list_allocator<code_block> *allocator;
/* Set of blocks which need full relocation. */
std::set<code_block *> needs_fixup;
@ -11,12 +17,23 @@ struct code_heap : heap {
/* Code blocks which may reference objects in aging space or the nursery */
std::set<code_block *> points_to_aging;
explicit code_heap(bool secure_gc, cell size);
explicit code_heap(cell size);
~code_heap();
void write_barrier(code_block *compiled);
void clear_remembered_set();
bool needs_fixup_p(code_block *compiled);
bool marked_p(code_block *compiled);
void set_marked_p(code_block *compiled);
void clear_mark_bits();
void code_heap_free(code_block *compiled);
code_block *forward_code_block(code_block *compiled);
};
struct code_heap_room {
cell size;
cell occupied_space;
cell total_free;
cell contiguous_free;
cell free_block_count;
};
}

29
vm/code_roots.hpp Normal file
View File

@ -0,0 +1,29 @@
namespace factor
{
struct code_root {
cell value;
bool valid;
factor_vm *parent;
void push()
{
parent->code_roots.push_back(this);
}
explicit code_root(cell value_, factor_vm *parent_) :
value(value_), valid(true), parent(parent_)
{
push();
}
~code_root()
{
#ifdef FACTOR_DEBUG
assert(parent->code_roots.back() == this);
#endif
parent->code_roots.pop_back();
}
};
}

300
vm/collector.hpp
View File

@ -1,21 +1,13 @@
namespace factor
{
template<typename TargetGeneration, typename Policy> struct collector {
template<typename TargetGeneration, typename Policy> struct collector_workhorse {
factor_vm *parent;
data_heap *data;
code_heap *code;
gc_state *current_gc;
generation_statistics *stats;
TargetGeneration *target;
Policy policy;
explicit collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
explicit collector_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
data(parent_->data),
code(parent_->code),
current_gc(parent_->current_gc),
stats(stats_),
target(target_),
policy(policy_) {}
@ -32,117 +24,239 @@ template<typename TargetGeneration, typename Policy> struct collector {
return untagged;
}
void trace_handle(cell *handle)
{
cell pointer = *handle;
if(immediate_p(pointer)) return;
object *untagged = parent->untag<object>(pointer);
if(!policy.should_copy_p(untagged))
return;
object *forwarding = resolve_forwarding(untagged);
if(forwarding == untagged)
untagged = promote_object(untagged);
else if(policy.should_copy_p(forwarding))
untagged = promote_object(forwarding);
else
untagged = forwarding;
*handle = RETAG(untagged,TAG(pointer));
}
void trace_slots(object *ptr)
{
cell *slot = (cell *)ptr;
cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr));
if(slot != end)
{
slot++;
for(; slot < end; slot++) trace_handle(slot);
}
}
object *promote_object(object *untagged)
{
cell size = parent->untagged_object_size(untagged);
cell size = untagged->size();
object *newpointer = target->allot(size);
/* XXX not exception-safe */
if(!newpointer) longjmp(current_gc->gc_unwind,1);
if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
memcpy(newpointer,untagged,size);
untagged->h.forward_to(newpointer);
stats->object_count++;
stats->bytes_copied += size;
policy.promoted_object(newpointer);
return newpointer;
}
void trace_stack_elements(segment *region, cell *top)
object *operator()(object *obj)
{
for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
trace_handle(ptr);
}
void trace_registered_locals()
{
std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
std::vector<cell>::const_iterator end = parent->gc_locals.end();
for(; iter < end; iter++)
trace_handle((cell *)(*iter));
}
void trace_registered_bignums()
{
std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
std::vector<cell>::const_iterator end = parent->gc_bignums.end();
for(; iter < end; iter++)
if(!policy.should_copy_p(obj))
{
cell *handle = (cell *)(*iter);
policy.visited_object(obj);
return obj;
}
if(*handle)
{
*handle |= BIGNUM_TYPE;
trace_handle(handle);
*handle &= ~BIGNUM_TYPE;
}
object *forwarding = resolve_forwarding(obj);
if(forwarding == obj)
return promote_object(obj);
else if(policy.should_copy_p(forwarding))
return promote_object(forwarding);
else
{
policy.visited_object(forwarding);
return forwarding;
}
}
};
template<typename TargetGeneration, typename Policy>
inline static slot_visitor<collector_workhorse<TargetGeneration,Policy> > make_collector_workhorse(
factor_vm *parent,
TargetGeneration *target,
Policy policy)
{
return slot_visitor<collector_workhorse<TargetGeneration,Policy> >(parent,
collector_workhorse<TargetGeneration,Policy>(parent,target,policy));
}
struct dummy_unmarker {
void operator()(card *ptr) {}
};
struct simple_unmarker {
card unmask;
explicit simple_unmarker(card unmask_) : unmask(unmask_) {}
void operator()(card *ptr) { *ptr &= ~unmask; }
};
struct full_unmarker {
explicit full_unmarker() {}
void operator()(card *ptr) { *ptr = 0; }
};
template<typename TargetGeneration, typename Policy> struct collector {
factor_vm *parent;
data_heap *data;
code_heap *code;
TargetGeneration *target;
slot_visitor<collector_workhorse<TargetGeneration,Policy> > workhorse;
cell cards_scanned;
cell decks_scanned;
cell code_blocks_scanned;
explicit collector(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
data(parent_->data),
code(parent_->code),
target(target_),
workhorse(make_collector_workhorse(parent_,target_,policy_)),
cards_scanned(0),
decks_scanned(0),
code_blocks_scanned(0) {}
void trace_handle(cell *handle)
{
workhorse.visit_handle(handle);
}
void trace_object(object *ptr)
{
workhorse.visit_slots(ptr);
if(ptr->h.hi_tag() == ALIEN_TYPE)
((alien *)ptr)->update_address();
}
/* Copy roots over at the start of GC, namely various constants, stacks,
the user environment and extra roots registered by local_roots.hpp */
void trace_roots()
{
trace_handle(&parent->true_object);
trace_handle(&parent->bignum_zero);
trace_handle(&parent->bignum_pos_one);
trace_handle(&parent->bignum_neg_one);
trace_registered_locals();
trace_registered_bignums();
for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]);
workhorse.visit_roots();
}
void trace_contexts()
{
context *ctx = parent->ctx;
workhorse.visit_contexts();
}
while(ctx)
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
void trace_literal_references(code_block *compiled)
{
workhorse.visit_literal_references(compiled);
}
void trace_code_heap_roots(std::set<code_block *> *remembered_set)
{
std::set<code_block *>::const_iterator iter = remembered_set->begin();
std::set<code_block *>::const_iterator end = remembered_set->end();
for(; iter != end; iter++)
{
trace_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
trace_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
trace_literal_references(*iter);
code_blocks_scanned++;
}
}
trace_handle(&ctx->catchstack_save);
trace_handle(&ctx->current_callback_save);
inline cell first_card_in_deck(cell deck)
{
return deck << (deck_bits - card_bits);
}
ctx = ctx->next;
inline cell last_card_in_deck(cell deck)
{
return first_card_in_deck(deck + 1);
}
inline cell card_deck_for_address(cell a)
{
return addr_to_deck(a - data->start);
}
inline cell card_start_address(cell card)
{
return (card << card_bits) + data->start;
}
inline cell card_end_address(cell card)
{
return ((card + 1) << card_bits) + data->start;
}
void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
{
if(card_start < end)
{
start += sizeof(cell);
if(start < card_start) start = card_start;
if(end > card_end) end = card_end;
cell *slot_ptr = (cell *)start;
cell *end_ptr = (cell *)end;
if(slot_ptr != end_ptr)
{
for(; slot_ptr < end_ptr; slot_ptr++)
workhorse.visit_handle(slot_ptr);
}
}
}
template<typename SourceGeneration, typename Unmarker>
void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
{
card_deck *decks = data->decks;
card_deck *cards = data->cards;
cell gen_start_card = addr_to_card(gen->start - data->start);
cell first_deck = card_deck_for_address(gen->start);
cell last_deck = card_deck_for_address(gen->end);
cell start = 0, binary_start = 0, end = 0;
for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
{
if(decks[deck_index] & mask)
{
decks_scanned++;
cell first_card = first_card_in_deck(deck_index);
cell last_card = last_card_in_deck(deck_index);
for(cell card_index = first_card; card_index < last_card; card_index++)
{
if(cards[card_index] & mask)
{
cards_scanned++;
if(end < card_start_address(card_index))
{
start = gen->starts.find_object_containing_card(card_index - gen_start_card);
binary_start = start + ((object *)start)->binary_payload_start();
end = start + ((object *)start)->size();
}
#ifdef FACTOR_DEBUG
assert(addr_to_card(start - data->start) <= card_index);
assert(start < card_end_address(card_index));
#endif
scan_next_object: {
trace_partial_objects(
start,
binary_start,
card_start_address(card_index),
card_end_address(card_index));
if(end < card_end_address(card_index))
{
start = gen->next_object_after(start);
if(start)
{
binary_start = start + ((object *)start)->binary_payload_start();
end = start + ((object *)start)->size();
goto scan_next_object;
}
}
}
unmarker(&cards[card_index]);
if(!start) return;
}
}
unmarker(&decks[deck_index]);
}
}
}
};

191
vm/compaction.cpp Normal file
View File

@ -0,0 +1,191 @@
#include "master.hpp"
namespace factor {
template<typename Block> struct forwarder {
mark_bits<Block> *forwarding_map;
explicit forwarder(mark_bits<Block> *forwarding_map_) :
forwarding_map(forwarding_map_) {}
Block *operator()(Block *block)
{
return forwarding_map->forward_block(block);
}
};
static inline cell tuple_size_with_forwarding(mark_bits<object> *forwarding_map, object *obj)
{
/* The tuple layout may or may not have been forwarded already. Tricky. */
object *layout_obj = (object *)UNTAG(((tuple *)obj)->layout);
tuple_layout *layout;
if(layout_obj < obj)
{
/* It's already been moved up; dereference through forwarding
map to get the size */
layout = (tuple_layout *)forwarding_map->forward_block(layout_obj);
}
else
{
/* It hasn't been moved up yet; dereference directly */
layout = (tuple_layout *)layout_obj;
}
return tuple_size(layout);
}
struct compaction_sizer {
mark_bits<object> *forwarding_map;
explicit compaction_sizer(mark_bits<object> *forwarding_map_) :
forwarding_map(forwarding_map_) {}
cell operator()(object *obj)
{
if(!forwarding_map->marked_p(obj))
return forwarding_map->unmarked_block_size(obj);
else if(obj->h.hi_tag() == TUPLE_TYPE)
return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
else
return obj->size();
}
};
struct object_compaction_updater {
factor_vm *parent;
slot_visitor<forwarder<object> > slot_forwarder;
code_block_visitor<forwarder<code_block> > code_forwarder;
mark_bits<object> *data_forwarding_map;
object_start_map *starts;
explicit object_compaction_updater(factor_vm *parent_,
slot_visitor<forwarder<object> > slot_forwarder_,
code_block_visitor<forwarder<code_block> > code_forwarder_,
mark_bits<object> *data_forwarding_map_) :
parent(parent_),
slot_forwarder(slot_forwarder_),
code_forwarder(code_forwarder_),
data_forwarding_map(data_forwarding_map_),
starts(&parent->data->tenured->starts) {}
void operator()(object *old_address, object *new_address, cell size)
{
cell payload_start;
if(old_address->h.hi_tag() == TUPLE_TYPE)
payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
else
payload_start = old_address->binary_payload_start();
memmove(new_address,old_address,size);
slot_forwarder.visit_slots(new_address,payload_start);
code_forwarder.visit_object_code_block(new_address);
starts->record_object_start_offset(new_address);
}
};
template<typename SlotForwarder> struct code_block_compaction_updater {
factor_vm *parent;
SlotForwarder slot_forwarder;
explicit code_block_compaction_updater(factor_vm *parent_, SlotForwarder slot_forwarder_) :
parent(parent_), slot_forwarder(slot_forwarder_) {}
void operator()(code_block *old_address, code_block *new_address, cell size)
{
memmove(new_address,old_address,size);
slot_forwarder.visit_literal_references(new_address);
parent->relocate_code_block(new_address);
}
};
/* Compact data and code heaps */
void factor_vm::collect_compact_impl(bool trace_contexts_p)
{
current_gc->event->started_compaction();
tenured_space *tenured = data->tenured;
mark_bits<object> *data_forwarding_map = &tenured->state;
mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
/* Figure out where blocks are going to go */
data_forwarding_map->compute_forwarding();
code_forwarding_map->compute_forwarding();
slot_visitor<forwarder<object> > slot_forwarder(this,forwarder<object>(data_forwarding_map));
code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
/* Object start offsets get recomputed by the object_compaction_updater */
data->tenured->starts.clear_object_start_offsets();
/* Slide everything in tenured space up, and update data and code heap
pointers inside objects. */
object_compaction_updater object_updater(this,slot_forwarder,code_forwarder,data_forwarding_map);
compaction_sizer object_sizer(data_forwarding_map);
tenured->compact(object_updater,object_sizer);
/* Slide everything in the code heap up, and update data and code heap
pointers inside code blocks. */
code_block_compaction_updater<slot_visitor<forwarder<object> > > code_block_updater(this,slot_forwarder);
standard_sizer<code_block> code_block_sizer;
code->allocator->compact(code_block_updater,code_block_sizer);
slot_forwarder.visit_roots();
if(trace_contexts_p)
{
slot_forwarder.visit_contexts();
code_forwarder.visit_context_code_blocks();
code_forwarder.visit_callback_code_blocks();
}
update_code_roots_for_compaction();
current_gc->event->ended_compaction();
}
struct object_code_block_updater {
code_block_visitor<forwarder<code_block> > *visitor;
explicit object_code_block_updater(code_block_visitor<forwarder<code_block> > *visitor_) :
visitor(visitor_) {}
void operator()(cell obj)
{
visitor->visit_object_code_block(tagged<object>(obj).untagged());
}
};
struct dummy_slot_forwarder {
void visit_literal_references(code_block *compiled) {}
};
/* Compact just the code heap */
void factor_vm::collect_compact_code_impl(bool trace_contexts_p)
{
/* Figure out where blocks are going to go */
mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
code_forwarding_map->compute_forwarding();
code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
if(trace_contexts_p)
{
code_forwarder.visit_context_code_blocks();
code_forwarder.visit_callback_code_blocks();
}
/* Update code heap references in data heap */
object_code_block_updater updater(&code_forwarder);
each_object(updater);
/* Slide everything in the code heap up, and update code heap
pointers inside code blocks. */
dummy_slot_forwarder slot_forwarder;
code_block_compaction_updater<dummy_slot_forwarder> code_block_updater(this,slot_forwarder);
standard_sizer<code_block> code_block_sizer;
code->allocator->compact(code_block_updater,code_block_sizer);
update_code_roots_for_compaction();
}
}

4
vm/compaction.hpp Normal file
View File

@ -0,0 +1,4 @@
namespace factor
{
}

14
vm/contexts.cpp
View File

@ -80,9 +80,9 @@ void factor_vm::nest_stacks(stack_frame *magic_frame)
new_ctx->magic_frame = magic_frame;
/* save per-callback userenv */
new_ctx->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
new_ctx->catchstack_save = userenv[CATCHSTACK_ENV];
/* save per-callback special_objects */
new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
new_ctx->next = ctx;
ctx = new_ctx;
@ -102,9 +102,9 @@ void factor_vm::unnest_stacks()
ds = ctx->datastack_save;
rs = ctx->retainstack_save;
/* restore per-callback userenv */
userenv[CURRENT_CALLBACK_ENV] = ctx->current_callback_save;
userenv[CATCHSTACK_ENV] = ctx->catchstack_save;
/* restore per-callback special_objects */
special_objects[OBJ_CURRENT_CALLBACK] = ctx->current_callback_save;
special_objects[OBJ_CATCHSTACK] = ctx->catchstack_save;
context *old_ctx = ctx;
ctx = old_ctx->next;
@ -133,7 +133,7 @@ bool factor_vm::stack_to_array(cell bottom, cell top)
return false;
else
{
array *a = allot_array_internal<array>(depth / sizeof(cell));
array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth);
dpush(tag<array>(a));
return true;

2
vm/contexts.hpp
View File

@ -41,7 +41,7 @@ struct context {
/* memory region holding current retain stack */
segment *retainstack_region;
/* saved userenv slots on entry to callback */
/* saved special_objects slots on entry to callback */
cell catchstack_save;
cell current_callback_save;

153
vm/copying_collector.hpp
View File

@ -1,164 +1,19 @@
namespace factor
{
struct dummy_unmarker {
void operator()(card *ptr) {}
};
struct simple_unmarker {
card unmask;
simple_unmarker(card unmask_) : unmask(unmask_) {}
void operator()(card *ptr) { *ptr &= ~unmask; }
};
template<typename TargetGeneration, typename Policy>
struct copying_collector : collector<TargetGeneration,Policy> {
cell scan;
explicit copying_collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(parent_,stats_,target_,policy_), scan(target_->here) {}
inline cell first_card_in_deck(cell deck)
{
return deck << (deck_bits - card_bits);
}
inline cell last_card_in_deck(cell deck)
{
return first_card_in_deck(deck + 1);
}
inline cell card_deck_for_address(cell a)
{
return addr_to_deck(a - this->data->start);
}
inline cell card_start_address(cell card)
{
return (card << card_bits) + this->data->start;
}
inline cell card_end_address(cell card)
{
return ((card + 1) << card_bits) + this->data->start;
}
void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
{
if(card_start < end)
{
start += sizeof(cell);
if(start < card_start) start = card_start;
if(end > card_end) end = card_end;
cell *slot_ptr = (cell *)start;
cell *end_ptr = (cell *)end;
if(slot_ptr != end_ptr)
{
for(; slot_ptr < end_ptr; slot_ptr++)
this->trace_handle(slot_ptr);
}
}
}
template<typename SourceGeneration, typename Unmarker>
void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
{
u64 start_time = current_micros();
card_deck *decks = this->data->decks;
card_deck *cards = this->data->cards;
cell gen_start_card = addr_to_card(gen->start - this->data->start);
cell first_deck = card_deck_for_address(gen->start);
cell last_deck = card_deck_for_address(gen->end);
cell start = 0, binary_start = 0, end = 0;
for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
{
if(decks[deck_index] & mask)
{
this->parent->gc_stats.decks_scanned++;
cell first_card = first_card_in_deck(deck_index);
cell last_card = last_card_in_deck(deck_index);
for(cell card_index = first_card; card_index < last_card; card_index++)
{
if(cards[card_index] & mask)
{
this->parent->gc_stats.cards_scanned++;
if(end < card_start_address(card_index))
{
start = gen->find_object_containing_card(card_index - gen_start_card);
binary_start = start + this->parent->binary_payload_start((object *)start);
end = start + this->parent->untagged_object_size((object *)start);
}
#ifdef FACTOR_DEBUG
assert(addr_to_card(start - this->data->start) <= card_index);
assert(start < card_end_address(card_index));
#endif
scan_next_object: {
trace_partial_objects(
start,
binary_start,
card_start_address(card_index),
card_end_address(card_index));
if(end < card_end_address(card_index))
{
start = gen->next_object_after(this->parent,start);
if(start)
{
binary_start = start + this->parent->binary_payload_start((object *)start);
end = start + this->parent->untagged_object_size((object *)start);
goto scan_next_object;
}
}
}
unmarker(&cards[card_index]);
if(!start) goto end;
}
}
unmarker(&decks[deck_index]);
}
}
end: this->parent->gc_stats.card_scan_time += (current_micros() - start_time);
}
/* Trace all literals referenced from a code block. Only for aging and nursery collections */
void trace_literal_references(code_block *compiled)
{
this->trace_handle(&compiled->owner);
this->trace_handle(&compiled->literals);
this->trace_handle(&compiled->relocation);
this->parent->gc_stats.code_blocks_scanned++;
}
void trace_code_heap_roots(std::set<code_block *> *remembered_set)
{
std::set<code_block *>::const_iterator iter = remembered_set->begin();
std::set<code_block *>::const_iterator end = remembered_set->end();
for(; iter != end; iter++) trace_literal_references(*iter);
}
explicit copying_collector(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
collector<TargetGeneration,Policy>(parent_,target_,policy_), scan(target_->here) {}
void cheneys_algorithm()
{
while(scan && scan < this->target->here)
{
this->trace_slots((object *)scan);
scan = this->target->next_object_after(this->parent,scan);
this->trace_object((object *)scan);
scan = this->target->next_object_after(scan);
}
}
};

4
vm/cpu-ppc.S
View File

@ -37,13 +37,13 @@ DEF(void,primitive_fixnum_multiply,(void *vm)):
lwz r3,0(DS_REG)
lwz r4,-4(DS_REG)
subi DS_REG,DS_REG,4
srawi r3,r3,3
srawi r3,r3,4
mullwo. r6,r3,r4
bso multiply_overflow
stw r6,0(DS_REG)
blr
multiply_overflow:
srawi r4,r4,3
srawi r4,r4,4
b MANGLE(overflow_fixnum_multiply)
/* Note that the XT is passed to the quotation in r11 */

2
vm/cpu-x86.32.S
View File

@ -19,11 +19,9 @@
#define PUSH_NONVOLATILE \
push %ebx ; \
push %ebp ; \
push %ebp
#define POP_NONVOLATILE \
pop %ebp ; \
pop %ebp ; \
pop %ebx

4
vm/cpu-x86.64.S
View File

@ -27,11 +27,9 @@
push %rdi ; \
push %rsi ; \
push %rbx ; \
push %rbp ; \
push %rbp
#define POP_NONVOLATILE \
pop %rbp ; \
pop %rbp ; \
pop %rbx ; \
pop %rsi ; \
@ -50,11 +48,9 @@
push %rbx ; \
push %rbp ; \
push %r12 ; \
push %r13 ; \
push %r13
#define POP_NONVOLATILE \
pop %r13 ; \
pop %r13 ; \
pop %r12 ; \
pop %rbp ; \

19
vm/cpu-x86.S
View File

@ -25,7 +25,7 @@ DEF(void,primitive_fixnum_multiply,(void *myvm)):
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
sar $3,ARITH_TEMP_2
sar $4,ARITH_TEMP_2
sub $CELL_SIZE,DS_REG
imul ARITH_TEMP_2
jo multiply_overflow
@ -33,7 +33,7 @@ DEF(void,primitive_fixnum_multiply,(void *myvm)):
pop ARG2
ret
multiply_overflow:
sar $3,ARITH_TEMP_1
sar $4,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
pop ARG2
@ -43,14 +43,20 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
PUSH_NONVOLATILE
mov ARG0,NV0
mov ARG1,NV1
/* Save old stack pointer and align */
mov STACK_REG,ARG0
and $-16,STACK_REG
add $CELL_SIZE,STACK_REG
push ARG0
/* Create register shadow area for Win64 */
sub $32,STACK_REG
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
call MANGLE(save_callstack_bottom)
/* Call quot-xt */
mov NV0,ARG0
mov NV1,ARG1
@ -59,6 +65,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot, void *vm)):
/* Tear down register shadow area */
add $32,STACK_REG
/* Undo stack alignment */
mov (STACK_REG),STACK_REG
POP_NONVOLATILE
ret

207
vm/data_heap.cpp
View File

@ -9,7 +9,9 @@ void factor_vm::init_card_decks()
decks_offset = (cell)data->decks - addr_to_deck(data->start);
}
data_heap::data_heap(cell young_size_, cell aging_size_, cell tenured_size_)
data_heap::data_heap(cell young_size_,
cell aging_size_,
cell tenured_size_)
{
young_size_ = align(young_size_,deck_size);
aging_size_ = align(aging_size_,deck_size);
@ -19,30 +21,27 @@ data_heap::data_heap(cell young_size_, cell aging_size_, cell tenured_size_)
aging_size = aging_size_;
tenured_size = tenured_size_;
cell total_size = young_size + 2 * aging_size + 2 * tenured_size;
total_size += deck_size;
cell total_size = young_size + 2 * aging_size + tenured_size + deck_size;
seg = new segment(total_size,false);
cell cards_size = addr_to_card(total_size);
cards = new card[cards_size];
cards_end = cards + cards_size;
memset(cards,0,cards_size);
cell decks_size = addr_to_deck(total_size);
decks = new card_deck[decks_size];
decks_end = decks + decks_size;
memset(decks,0,decks_size);
start = align(seg->start,deck_size);
tenured = new tenured_space(tenured_size,start);
tenured_semispace = new tenured_space(tenured_size,tenured->end);
aging = new aging_space(aging_size,tenured_semispace->end);
aging = new aging_space(aging_size,tenured->end);
aging_semispace = new aging_space(aging_size,aging->end);
nursery = new zone(young_size,aging_semispace->end);
nursery = new nursery_space(young_size,aging_semispace->end);
assert(seg->end - nursery->end <= deck_size);
}
@ -54,7 +53,6 @@ data_heap::~data_heap()
delete aging;
delete aging_semispace;
delete tenured;
delete tenured_semispace;
delete[] cards;
delete[] decks;
}
@ -62,49 +60,59 @@ data_heap::~data_heap()
data_heap *data_heap::grow(cell requested_bytes)
{
cell new_tenured_size = (tenured_size * 2) + requested_bytes;
return new data_heap(young_size,aging_size,new_tenured_size);
return new data_heap(young_size,
aging_size,
new_tenured_size);
}
void factor_vm::clear_cards(old_space *gen)
template<typename Generation> void data_heap::clear_cards(Generation *gen)
{
cell first_card = addr_to_card(gen->start - data->start);
cell last_card = addr_to_card(gen->end - data->start);
memset(&data->cards[first_card],0,last_card - first_card);
cell first_card = addr_to_card(gen->start - start);
cell last_card = addr_to_card(gen->end - start);
memset(&cards[first_card],0,last_card - first_card);
}
void factor_vm::clear_decks(old_space *gen)
template<typename Generation> void data_heap::clear_decks(Generation *gen)
{
cell first_deck = addr_to_deck(gen->start - data->start);
cell last_deck = addr_to_deck(gen->end - data->start);
memset(&data->decks[first_deck],0,last_deck - first_deck);
cell first_deck = addr_to_deck(gen->start - start);
cell last_deck = addr_to_deck(gen->end - start);
memset(&decks[first_deck],0,last_deck - first_deck);
}
/* After garbage collection, any generations which are now empty need to have
their allocation pointers and cards reset. */
void factor_vm::reset_generation(old_space *gen)
void data_heap::reset_generation(nursery_space *gen)
{
gen->here = gen->start;
if(secure_gc) memset((void*)gen->start,69,gen->size);
}
void data_heap::reset_generation(aging_space *gen)
{
gen->here = gen->start;
clear_cards(gen);
clear_decks(gen);
gen->clear_object_start_offsets();
gen->starts.clear_object_start_offsets();
}
void data_heap::reset_generation(tenured_space *gen)
{
clear_cards(gen);
clear_decks(gen);
}
bool data_heap::low_memory_p()
{
return (tenured->free_space() <= nursery->size + aging->size);
}
void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = *data->nursery;
nursery.here = nursery.start;
init_card_decks();
reset_generation(data->aging);
reset_generation(data->tenured);
}
void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_)
void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size)
{
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
secure_gc = secure_gc_;
}
/* Size of the object pointed to by a tagged pointer */
@ -113,61 +121,55 @@ cell factor_vm::object_size(cell tagged)
if(immediate_p(tagged))
return 0;
else
return untagged_object_size(untag<object>(tagged));
return untag<object>(tagged)->size();
}
/* Size of the object pointed to by an untagged pointer */
cell factor_vm::untagged_object_size(object *pointer)
cell object::size() const
{
return align8(unaligned_object_size(pointer));
}
if(free_p()) return ((free_heap_block *)this)->size();
/* Size of the data area of an object pointed to by an untagged pointer */
cell factor_vm::unaligned_object_size(object *pointer)
{
switch(pointer->h.hi_tag())
switch(h.hi_tag())
{
case ARRAY_TYPE:
return array_size((array*)pointer);
return align(array_size((array*)this),data_alignment);
case BIGNUM_TYPE:
return array_size((bignum*)pointer);
return align(array_size((bignum*)this),data_alignment);
case BYTE_ARRAY_TYPE:
return array_size((byte_array*)pointer);
return align(array_size((byte_array*)this),data_alignment);
case STRING_TYPE:
return string_size(string_capacity((string*)pointer));
return align(string_size(string_capacity((string*)this)),data_alignment);
case TUPLE_TYPE:
return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
{
tuple_layout *layout = (tuple_layout *)UNTAG(((tuple *)this)->layout);
return align(tuple_size(layout),data_alignment);
}
case QUOTATION_TYPE:
return sizeof(quotation);
return align(sizeof(quotation),data_alignment);
case WORD_TYPE:
return sizeof(word);
return align(sizeof(word),data_alignment);
case FLOAT_TYPE:
return sizeof(boxed_float);
return align(sizeof(boxed_float),data_alignment);
case DLL_TYPE:
return sizeof(dll);
return align(sizeof(dll),data_alignment);
case ALIEN_TYPE:
return sizeof(alien);
return align(sizeof(alien),data_alignment);
case WRAPPER_TYPE:
return sizeof(wrapper);
return align(sizeof(wrapper),data_alignment);
case CALLSTACK_TYPE:
return callstack_size(untag_fixnum(((callstack *)pointer)->length));
return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
default:
critical_error("Invalid header",(cell)pointer);
critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
void factor_vm::primitive_size()
{
box_unsigned_cell(object_size(dpop()));
}
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
cell factor_vm::binary_payload_start(object *pointer)
cell object::binary_payload_start() const
{
switch(pointer->h.hi_tag())
switch(h.hi_tag())
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
@ -188,42 +190,54 @@ cell factor_vm::binary_payload_start(object *pointer)
return sizeof(string);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
return array_size<array>(array_capacity((array*)pointer));
return array_size<array>(array_capacity((array*)this));
case TUPLE_TYPE:
return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
return tuple_size(untag<tuple_layout>(((tuple *)this)->layout));
case WRAPPER_TYPE:
return sizeof(wrapper);
default:
critical_error("Invalid header",(cell)pointer);
critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
/* Push memory usage statistics in data heap */
void factor_vm::primitive_size()
{
box_unsigned_cell(object_size(dpop()));
}
data_heap_room factor_vm::data_room()
{
data_heap_room room;
room.nursery_size = nursery.size;
room.nursery_occupied = nursery.occupied_space();
room.nursery_free = nursery.free_space();
room.aging_size = data->aging->size;
room.aging_occupied = data->aging->occupied_space();
room.aging_free = data->aging->free_space();
room.tenured_size = data->tenured->size;
room.tenured_occupied = data->tenured->occupied_space();
room.tenured_total_free = data->tenured->free_space();
room.tenured_contiguous_free = data->tenured->largest_free_block();
room.tenured_free_block_count = data->tenured->free_block_count();
room.cards = data->cards_end - data->cards;
room.decks = data->decks_end - data->decks;
room.mark_stack = data->tenured->mark_stack.capacity();
return room;
}
void factor_vm::primitive_data_room()
{
dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
growable_array a(this);
a.add(tag_fixnum((nursery.end - nursery.here) >> 10));
a.add(tag_fixnum((nursery.size) >> 10));
a.add(tag_fixnum((data->aging->end - data->aging->here) >> 10));
a.add(tag_fixnum((data->aging->size) >> 10));
a.add(tag_fixnum((data->tenured->end - data->tenured->here) >> 10));
a.add(tag_fixnum((data->tenured->size) >> 10));
a.trim();
dpush(a.elements.value());
data_heap_room room = data_room();
dpush(tag<byte_array>(byte_array_from_value(&room)));
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void factor_vm::begin_scan()
{
heap_scan_ptr = data->tenured->start;
heap_scan_ptr = data->tenured->first_object();
gc_off = true;
}
@ -242,12 +256,14 @@ cell factor_vm::next_object()
if(!gc_off)
general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL);
if(heap_scan_ptr >= data->tenured->here)
if(heap_scan_ptr)
{
cell current = heap_scan_ptr;
heap_scan_ptr = data->tenured->next_object_after(heap_scan_ptr);
return tag_dynamic((object *)current);
}
else
return false_object;
object *obj = (object *)heap_scan_ptr;
heap_scan_ptr += untagged_object_size(obj);
return tag_dynamic(obj);
}
/* Push object at heap scan cursor and advance; pushes f when done */
@ -262,25 +278,28 @@ void factor_vm::primitive_end_scan()
gc_off = false;
}
template<typename Iterator> void factor_vm::each_object(Iterator &iterator)
{
begin_scan();
cell obj;
while(to_boolean(obj = next_object()))
iterator(tagged<object>(obj));
end_scan();
}
struct word_counter {
cell count;
explicit word_counter() : count(0) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) count++; }
void operator()(cell obj)
{
if(tagged<object>(obj).type_p(WORD_TYPE))
count++;
}
};
struct word_accumulator {
growable_array words;
explicit word_accumulator(int count,factor_vm *vm) : words(vm,count) {}
void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
void operator()(cell obj)
{
if(tagged<object>(obj).type_p(WORD_TYPE))
words.add(obj);
}
};
cell factor_vm::find_all_words()

26
vm/data_heap.hpp
View File

@ -10,11 +10,10 @@ struct data_heap {
segment *seg;
zone *nursery;
nursery_space *nursery;
aging_space *aging;
aging_space *aging_semispace;
tenured_space *tenured;
tenured_space *tenured_semispace;
card *cards;
card *cards_end;
@ -25,6 +24,29 @@ struct data_heap {
explicit data_heap(cell young_size, cell aging_size, cell tenured_size);
~data_heap();
data_heap *grow(cell requested_size);
template<typename Generation> void clear_cards(Generation *gen);
template<typename Generation> void clear_decks(Generation *gen);
void reset_generation(nursery_space *gen);
void reset_generation(aging_space *gen);
void reset_generation(tenured_space *gen);
bool low_memory_p();
};
struct data_heap_room {
cell nursery_size;
cell nursery_occupied;
cell nursery_free;
cell aging_size;
cell aging_occupied;
cell aging_free;
cell tenured_size;
cell tenured_occupied;
cell tenured_total_free;
cell tenured_contiguous_free;
cell tenured_free_block_count;
cell cards;
cell decks;
cell mark_stack;
};
}

59
vm/data_roots.hpp Normal file
View File

@ -0,0 +1,59 @@
namespace factor
{
template<typename Type>
struct data_root : public tagged<Type> {
factor_vm *parent;
void push()
{
parent->data_roots.push_back((cell)this);
}
explicit data_root(cell value_, factor_vm *parent_)
: tagged<Type>(value_), parent(parent_)
{
push();
}
explicit data_root(Type *value_, factor_vm *parent_) :
tagged<Type>(value_), parent(parent_)
{
push();
}
const data_root<Type>& operator=(const Type *x) { tagged<Type>::operator=(x); return *this; }
const data_root<Type>& operator=(const cell &x) { tagged<Type>::operator=(x); return *this; }
~data_root()
{
#ifdef FACTOR_DEBUG
assert(parent->data_roots.back() == (cell)this);
#endif
parent->data_roots.pop_back();
}
};
/* A similar hack for the bignum implementation */
struct gc_bignum {
bignum **addr;
factor_vm *parent;
gc_bignum(bignum **addr_, factor_vm *parent_) : addr(addr_), parent(parent_)
{
if(*addr_) parent->check_data_pointer(*addr_);
parent->bignum_roots.push_back((cell)addr);
}
~gc_bignum()
{
#ifdef FACTOR_DEBUG
assert(parent->bignum_roots.back() == (cell)addr);
#endif
parent->bignum_roots.pop_back();
}
};
#define GC_BIGNUM(x) gc_bignum x##__data_root(&x,this)
}

Some files were not shown because too many files have changed in this diff Show More