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 \
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 )
"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 ]
: 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 -- )
[ 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
[ 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
"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
[ 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 ;
: 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
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
-
-
! 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
: 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.
M: float '
[
float [
- align-here double>bits emit-64
+ 8 (align-here) double>bits emit-64
] emit-object
] cache-eql-object ;
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 ;
[
byte-array [
dup length emit-fixnum
+ bootstrap-cell 4 = [ 0 emit 0 emit ] when
pad-bytes emit-bytes
] emit-object
] cache-eq-object ;
"tools.deploy"
"tools.destructors"
"tools.disassembler"
+ "tools.dispatch"
"tools.memory"
"tools.profiler"
"tools.test"
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 ;
{
byte-array
- simple-alien
alien
POSTPONE: f
} [| class |
] 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
] 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
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
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
{
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
+M: insn defs-vreg drop f ;
+M: insn temp-vregs drop { } ;
+M: insn uses-vregs drop { } ;
+
M: ##phi uses-vregs inputs>> values ;
<PRIVATE
} case ;
: define-defs-vreg-method ( insn -- )
- [ \ defs-vreg create-method ]
- [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
- define ;
+ dup insn-def-slot dup [
+ [ \ defs-vreg create-method ]
+ [ name>> reader-word 1quotation ] bi*
+ define
+ ] [ 2drop ] if ;
: define-uses-vregs-method ( insn -- )
- [ \ uses-vregs create-method ]
- [ insn-use-slots [ name>> ] map slot-array-quot ] bi
- define ;
+ dup insn-use-slots [ drop ] [
+ [ \ uses-vregs create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
+ define
+ ] if-empty ;
: define-temp-vregs-method ( insn -- )
- [ \ temp-vregs create-method ]
- [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
- define ;
+ dup insn-temp-slots [ drop ] [
+ [ \ temp-vregs create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
+ define
+ ] if-empty ;
PRIVATE>
! 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
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 '[
: ^^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 ;
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 ;
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
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 ;
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
] [ 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 ;
: 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
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
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 ;
GENERIC: rename-insn-defs ( insn -- )
-insn-classes get [
+M: insn rename-insn-defs drop ;
+
+insn-classes get [ insn-def-slot ] filter [
[ \ rename-insn-defs create-method-in ]
- [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+ [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
define
] each
GENERIC: rename-insn-uses ( insn -- )
-insn-classes get { ##phi } diff [
+M: insn rename-insn-uses drop ;
+
+insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
GENERIC: rename-insn-temps ( insn -- )
-insn-classes get [
+M: insn rename-insn-temps drop ;
+
+insn-classes get [ insn-temp-slots empty? not ] filter [
[ \ rename-insn-temps create-method-in ]
[ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
define
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
+M: insn defs-vreg-rep drop f ;
+M: insn temp-vreg-reps drop { } ;
+M: insn uses-vreg-reps drop { } ;
+
<PRIVATE
: rep-getter-quot ( rep -- quot )
} case ;
: define-defs-vreg-rep-method ( insn -- )
- [ \ defs-vreg-rep create-method ]
- [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
- bi define ;
+ dup insn-def-slot dup [
+ [ \ defs-vreg-rep create-method ]
+ [ rep>> rep-getter-quot ]
+ bi* define
+ ] [ 2drop ] if ;
: reps-getter-quot ( reps -- quot )
dup [ rep>> { f scalar-rep } member-eq? not ] all? [
] if ;
: define-uses-vreg-reps-method ( insn -- )
- [ \ uses-vreg-reps create-method ]
- [ insn-use-slots reps-getter-quot ]
- bi define ;
+ dup insn-use-slots [ drop ] [
+ [ \ uses-vreg-reps create-method ]
+ [ reps-getter-quot ]
+ bi* define
+ ] if-empty ;
: define-temp-vreg-reps-method ( insn -- )
- [ \ temp-vreg-reps create-method ]
- [ insn-temp-slots reps-getter-quot ]
- bi define ;
+ dup insn-temp-slots [ drop ] [
+ [ \ temp-vreg-reps create-method ]
+ [ reps-getter-quot ]
+ bi* define
+ ] if-empty ;
PRIVATE>
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
dup ##compare-imm-branch? [
{
[ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ]
+ [ src2>> \ f type-number eq? ]
} 1&&
] [ drop f ] if ; inline
: 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
[ 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' )
:: 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 ;
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
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
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
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
{
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
! 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
[
{
- 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
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
{
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
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
! 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
] 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
[ -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
! 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
[ -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
! 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
"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
! loading immediates
[ f ] [
V{
- T{ ##load-immediate f 0 5 }
+ T{ ##load-immediate f 0 $[ \ f type-number ] }
} compile-test-bb
] unit-test
! 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
[ 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
[ 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 }
[ 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
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
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
] 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> } [
[ { 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
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 -- )
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 0 3 \ f tag-number CMPI\r
+ 0 3 \ f type-number CMPI\r
2 BEQ\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
\r
[ load-tag ] pic-tag jit-define\r
\r
-! Hi-tag\r
-[\r
- 3 4 MR\r
- load-tag\r
- 0 4 object tag-number tag-fixnum CMPI\r
- 2 BNE\r
- 4 3 object tag-number neg LWZ\r
-] pic-hi-tag jit-define\r
-\r
! Tuple\r
[\r
3 4 MR\r
load-tag\r
- 0 4 tuple tag-number tag-fixnum CMPI\r
+ 0 4 tuple type-number tag-fixnum CMPI\r
2 BNE\r
- 4 3 tuple tag-number neg bootstrap-cell + LWZ\r
+ 4 3 tuple type-number neg bootstrap-cell + LWZ\r
] pic-tuple jit-define\r
\r
-! Hi-tag and tuple\r
-[\r
- 3 4 MR\r
- load-tag\r
- ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
- 0 4 BIN: 110 tag-fixnum CMPI\r
- 5 BLT\r
- ! Untag r3\r
- 3 3 0 0 31 tag-bits get - RLWINM\r
- ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
- 4 4 1 tag-fixnum ANDI\r
- 4 4 1 SRAWI\r
- ! Load header cell or tuple layout cell\r
- 4 4 3 LWZX\r
-] pic-hi-tag-tuple jit-define\r
-\r
[\r
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
] pic-check-tag jit-define\r
[\r
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
4 0 5 CMP\r
-] pic-check jit-define\r
+] pic-check-tuple jit-define\r
\r
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
\r
[\r
! cache = ...\r
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
- ! key = class\r
- 5 4 MR\r
+ ! key = hashcode(class)\r
+ 5 4 3 SRAWI\r
+ 6 4 8 SRAWI\r
+ 5 5 6 ADD\r
+ 6 4 13 SRAWI\r
+ 5 5 6 ADD\r
+ 5 5 3 SLWI\r
! key &= cache.length - 1\r
5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
! cache += array-start-offset\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- 3 3 1 SRAWI\r
+ 3 3 2 SRAWI\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
2 swap execute( offset -- ) ! magic number\r
- \ f tag-number 3 LI\r
+ \ f type-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
4 ds-reg 0 LWZ\r
3 3 4 OR\r
3 3 tag-mask get ANDI\r
- \ f tag-number 4 LI\r
+ \ f type-number 4 LI\r
0 3 0 CMPI\r
2 BNE\r
1 tag-fixnum 4 LI\r
! 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?
"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 ;
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
! 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 ;
[ 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 -- )
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
:: (%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
} 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
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 } }
! 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
: 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 ;
[
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
-: fixnum>slot@ ( -- ) ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
[
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
->>
! 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
! ! ! 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
[
! 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
[
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
[
! 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
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
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
: 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) ]
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 ;
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 -- )
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 ;
[ 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
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
USING: sequences sequences.private math
-accessors alien.data ;
+accessors alien.c-types ;
IN: game.input.dinput.keys-array
TUPLE: keys-array
--- /dev/null
+USING: accessors alien.c-types alien.syntax half-floats kernel
+math tools.test specialized-arrays alien.data classes.struct ;
+SPECIALIZED-ARRAY: half
+IN: half-floats.tests
+
+[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
+[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
+[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
+[ HEX: be00 ] [ -1.5 half>bits ] unit-test
+[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
+[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
+[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
+
+! too-big floats overflow to infinity
+[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
+[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
+
+! too-small floats flush to zero
+[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
+[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
+
+[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
+[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
+[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
+[ -1.5 ] [ HEX: be00 bits>half ] unit-test
+[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
+[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+
+STRUCT: halves
+ { tom half }
+ { dick half }
+ { harry half }
+ { harry-jr half } ;
+
+[ 8 ] [ halves heap-size ] unit-test
+
+[ 3.0 ] [
+ halves <struct>
+ 3.0 >>dick
+ dick>>
+] unit-test
+
+[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
+[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.accessors alien.c-types alien.data
+alien.syntax kernel math math.order ;
+FROM: math => float ;
+IN: half-floats
+
+: half>bits ( float -- bits )
+ float>bits
+ [ -31 shift 15 shift ] [
+ HEX: 7fffffff bitand
+ dup zero? [
+ dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
+ -13 shift
+ 112 10 shift -
+ 0 HEX: 7c00 clamp
+ ] if
+ ] unless
+ ] bi bitor ;
+
+: bits>half ( bits -- float )
+ [ -15 shift 31 shift ] [
+ HEX: 7fff bitand
+ dup zero? [
+ dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
+ 13 shift
+ 112 23 shift +
+ ] if
+ ] unless
+ ] bi bitor bits>float ;
+
+SYMBOL: half
+
+<<
+
+<c-type>
+ float >>class
+ float >>boxed-class
+ [ alien-unsigned-2 bits>half ] >>getter
+ [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ [ >float ] >>unboxer-quot
+\ half define-primitive-type
+
+>>
--- /dev/null
+Half-precision float support for FFI
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel images ;
+IN: images.normalization
+
+HELP: normalize-image
+{ $values
+ { "image" image }
+ { "image" image }
+}
+{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
+
+HELP: reorder-components
+{ $values
+ { "image" image } { "component-order" component-order }
+ { "image" image }
+}
+{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
+{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
+$nl
+"You cannot use this word to reorder " { $link DEPTH } ", " { $link DEPTH-STENCIL } " or " { $link INTENSITY } " component orders." } ;
+
+ARTICLE: "images.normalization" "Image normalization"
+"The " { $vocab-link "images.normalization" } " vocab can be used to convert between " { $link image } " representations."
+$nl
+"You can normalize any image to a RGBA with ubyte-components representation:"
+{ $subsections normalize-image }
+"Convert an image's pixel layout to match an arbitrary " { $link component-order } ":"
+{ $subsections reorder-components } ;
+
+ABOUT: "images.normalization"
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images images.normalization images.normalization.private
+sequences tools.test ;
+IN: images.normalization.tests
+
+! 1>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 } A L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 } A RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 } A BGR permute ] unit-test
+
+[ B{ 0 255 255 255 1 255 255 255 } ]
+[ B{ 0 1 } A ABGR permute ] unit-test
+
+! 2>x
+
+[ B{ 0 2 } ]
+[ B{ 0 1 2 3 } LA L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 2 3 } LA RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 2 3 } LA BGR permute ] unit-test
+
+[ B{ 1 255 255 255 3 255 255 255 } ]
+[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
+
+! 3>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
+
+[ B{ 0 1 3 4 } ]
+[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
+
+[ B{ 2 1 0 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
+
+[ B{ 255 2 1 0 255 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
+
+! 4>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
+
+[ B{ 0 1 4 5 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
+
+[ B{ 2 1 0 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
+
+[ B{ 3 2 1 0 7 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
+
+! Edge cases
+
+[ B{ 0 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
+
+[ B{ 255 0 1 2 255 4 5 6 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
+
+[ B{ 1 2 3 255 5 6 7 255 } ]
+[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 255 255 } ]
+[ B{ 0 1 } L RGBA permute ] unit-test
+
+! Invalid inputs
+
+[
+ T{ image f { 1 1 } DEPTH ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } DEPTH-STENCIL ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } INTENSITY ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ DEPTH reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ DEPTH-STENCIL reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ INTENSITY reorder-components
+] must-fail
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Keith Lazuka
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays combinators fry
+grouping images kernel locals math math.vectors
+sequences specialized-arrays half-floats ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: half
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: ushort
+IN: images.normalization
+
+<PRIVATE
+
+CONSTANT: don't-care 127
+CONSTANT: fill-value 255
+
+: permutation ( src dst -- seq )
+ swap '[ _ index [ don't-care ] unless* ] { } map-as
+ 4 don't-care pad-tail ;
+
+: pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
+
+: shuffle ( seq permutation -- newseq )
+ swap '[
+ dup 4 >= [ drop fill-value ] [ _ nth ] if
+ ] B{ } map-as ;
+
+:: permute ( bytes src-order dst-order -- new-bytes )
+ src-order name>> :> src
+ dst-order name>> :> dst
+ bytes src length group
+ [ pad4 src dst permutation shuffle dst length head ]
+ map concat ;
+
+: (reorder-components) ( image src-order dest-order -- image )
+ [ permute ] 2curry change-bitmap ;
+
+GENERIC: normalize-component-type* ( image component-type -- image )
+
+: normalize-floats ( float-array -- byte-array )
+ [ 255.0 * >integer ] B{ } map-as ;
+
+M: float-components normalize-component-type*
+ drop byte-array>float-array normalize-floats ;
+
+M: half-components normalize-component-type*
+ drop byte-array>half-array normalize-floats ;
+
+: ushorts>ubytes ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: ushort-components normalize-component-type*
+ drop ushorts>ubytes ;
+
+M: ubyte-components normalize-component-type*
+ drop ;
+
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
+
+: validate-request ( src-order dst-order -- src-order dst-order )
+ [
+ [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
+ or [ "Invalid component-order" throw ] when
+ ] 2keep ;
+
+PRIVATE>
+
+: reorder-components ( image component-order -- image )
+ [
+ dup component-type>> '[ _ normalize-component-type* ] change-bitmap
+ dup component-order>>
+ ] dip
+ validate-request [ (reorder-components) ] keep >>component-order ;
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ RGBA reorder-components
+ normalize-scan-line-order ;
+
+++ /dev/null
- PNGSUITE
-----------------
-
- testset for PNG-(de)coders
- created by Willem van Schaik
-------------------------------------
-
-This is a collection of graphics images created to test the png applications
-like viewers, converters and editors. All (as far as that is possible)
-formats supported by the PNG standard are represented.
-
-
-1. INTRODUCTION
---------------------
-
-1.1 PNG capabilities
-------------------------
-
-Supported color-types are:
-
- - grayscale
- - grayscale + alpha-channel
- - color palettes
- - rgb
- - rgb + alpha-channel
-
-Allowed bitdepths are depending on the color-type, but are in the range
-of 1-bit (grayscale, which is b&w) upto 16-bits.
-
-Special features are:
-
- - interlacing (Adam-7)
- - gamma-support
- - transparency (a poor-man's alpha solution)
-
-
-1.2 File naming
--------------------
-
-Where possible, the testfiles are 32x32 bits icons. This results in a still
-reasonable size of the suite even with a large number of tests. The name
-of each test-file reflects thetype in the following way:
-
- g04i2c08.png
- || |||+---- bit-depth
- || ||+----- color-type (descriptive)
- || |+------ color-type (numerical)
- || +------- interlaced or non-interlaced
- |+--------- parameter of test (in this case gamma-value)
- +---------- test feature (in this case gamma)
-
-
-1.3 PNG formats
--------------------
-
-color-type:
- 0g - grayscale
- 2c - rgb color
- 3p - paletted
- 4a - grayscale + alpha channel
- 6a - rgb color + alpha channel
-
-bit-depth:
- 01 - with color-type 0, 3
- 02 - with color-type 0, 3
- 04 - with color-type 0, 3
- 08 - with color-type 0, 2, 3, 4, 6
- 16 - with color-type 0, 2, 4, 6
-
-interlacing:
- n - non-interlaced
- i - interlaced
-
-
-2. THE TESTS
------------------
-
-2.1 Sizes
--------------
-
-These tests are there to check if your software handles pictures well, with
-picture sizes that are not a multiple of 8. This is particularly important
-with Adam-7 type interlacing. In the same way these tests check if pictures
-size 1x1 and similar are ok.
-
- s01 - 1x1 pixel picture
- s02 - 2x2 pixel picture
- s03 - 3x3 pixel picture
- s04 - 4x4 pixel picture
- s05 - 5x5 pixel picture
- s06 - 6x6 pixel picture
- s07 - 7x7 pixel picture
- s08 - 8x8 pixel picture
- s09 - 9x9 pixel picture
- s32 - 32x32 pixel picture
- s33 - 33x33 pixel picture
- s34 - 34x34 pixel picture
- s35 - 35x35 pixel picture
- s36 - 36x36 pixel picture
- s37 - 37x37 pixel picture
- s38 - 38x38 pixel picture
- s39 - 39x39 pixel picture
- s40 - 40x40 pixel picture
-
-
-2.2 Background
-------------------
-
-When the PNG file contains a background chunck, this should be used for
-pictures with alpha-channel or pictures with a transparency chunck. For
-pictures without this background-chunk, but with alpha, this testset
-assumes a black background.
-
-For the images in this test, the left-side should be 100% the background
-color, where moving to the right the color should gradually become the
-image pattern.
-
- bga - alpha + no background
- bgw - alpha + white background
- bgg - alpha + gray background
- bgb - alpha + black background
- bgy - alpha + yellow background
-
-
-2.3 Transparency
---------------------
-
-Transparency should be used together with a background chunk. To test the
-combination of the two the latter 4 tests are there. How to handle pictures
-with transparancy, but without a background, opinions can differ. Here we
-use black, but especially in the case of paletted images, the normal color
-would maybe even be better.
-
- tp0 - not transparent for reference
- tp1 - transparent, but no background chunk
- tbw - transparent + white background
- tbg - transparent + gray background
- tbb - transparent + black background
- tby - transparent + yellow background
-
-
-2.4 Gamma
--------------
-
-To test if your viewer handles gamma-correction, 6 testfiles are available.
-They contain corrected color-ramps and a corresponding gamma-chunk with the
-file-gamma value. These are created in such a way that when the viewer does
-the gamma correction right, all 6 should be displayed identical.
-
-If they are different, probably the gamma correction is omitted. In that
-case, have a look at the two right coloumns in the 6 pictures. The image
-where those two look the same (when looked from far) reflects the gamma of
-your system. However, because of the limited size of the image, you should
-do more elaborate tests to determine your display gamma.
-
- g03 - file-gamma = 0.35, for display with gamma = 2.8
- g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC)
- g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac)
- g07 - file-gamma = 0.70, for display with gamma = 1.4
- g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT)
- g25 - file-gamma = 2.50, for display with gamma = 0.4
-
-
-2.5 Filtering
------------------
-
-PNG uses file-filtering, for optimal compression. Normally the type is of
-filtering is adjusted to the contents of the picture, but here each file
-has the same picture, with a different filtering.
-
- f0 - no filtering
- f1 - sub filtering
- f2 - up filtering
- f3 - average filtering
- f4 - paeth filtering
-
-
-2.6 Additional palettes
----------------------------
-
-Besides the normal use of paletted images, palette chunks can in combination
-with true-color (and other) images also be used to select color lookup-tables
-when the video system is of limited capabilities. The suggested palette chunk
-is specially created for this purpose.
-
- pp - normal palette chunk
- ps - suggested palette chunk
-
-
-2.7 Ancillary chunks (under construction)
-------------------------
-
-To test the correct decoding of ancillary chunks, these test-files contain
-one or more examples of these chunkcs. Depending on the type of chunk, a
-number of typical values are selected to test. Unluckily, the testset can
-not contain all combinations, because that would be an endless set.
-
-The significant bits are used in files with the next higher bit-depth. They
-indicate howmany bits are valid.
-
- cs3 - 3 significant bits
- cs5 - 5 significant bits
- cs8 - 8 significant bits (reference)
- cs3 - 13 significant bits
-
-For the physical pixel dimensions, the result of each decoding should be
-a sqare picture. The first (cdf) image is an example of flat (horizontal)
-pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take
-care of the correction. The second is just the other way round. The last
-example uses the unit specifier, for 1000 pixels per meter. This should
-result in a picture of 3.2 cm square.
-
- cdf - physical pixel dimensions, 8x32 flat pixels
- cdh - physical pixel dimensions, 32x8 high pixels
- cds - physical pixel dimensions, 8x8 square pixels
- cdu - physical pixel dimensions, with unit-specifier
-
- ccw - primary chromaticities and white point
-
- ch1 - histogram 15 colors
- ch2 - histogram 256 colors
-
- cm7 - modification time, 01-jan-1970
- cm9 - modification time, 31-dec-1999
- cm0 - modification time, 01-jan-2000
-
-In the textual chunk, a number of the standard, and some non-standard
-text items are included.
-
- ct0 - no textual data
- ct1 - with textual data
- ctz - with compressed textual data
-
-
-2.8 Chunk ordering (still under construction)
-----------------------
-
-These testfiles will test the obligatory ordering relations between various
-chunk types (not yet) as well as the number of data chunks used for the image.
-
- oi1 - mother image with 1 idat-chunk
- oi2 - image with 2 idat-chunks
- oi4 - image with 4 unequal sized idat-chunks
- oi9 - all idat-chunks of length one
-
-
-2.9 Compression level
--------------------------
-
-Here you will find a set of images compressed by zlib, ranging from level 0
-for no compression at maximum speed upto level 9 for maximum compression.
-
- z00 - zlib compression level 0 - none
- z03 - zlib compression level 3
- z06 - zlib compression level 6 - default
- z09 - zlib compression level 9 - maximum
-
-
-2.10 Corrupted files (under construction)
------------------------
-
-All these files are illegal. When decoding they should generate appropriate
-error-messages.
-
- x00 - empty IDAT chunk
- xcr - added cr bytes
- xlf - added lf bytes
- xc0 - color type 0
- xc9 - color type 9
- xd0 - bit-depth 0
- xd3 - bit-depth 3
- xd9 - bit-depth 99
- xcs - incorrect IDAT checksum
-
-
-3. TEST FILES
-------------------
-
-For each of the tests listed above, one or more test-files are created. A
-selection is made (for each test) for the color-type and bitdepth to be used
-for the tests. Further for a number of tests, both a non-interlaced as well
-as an interlaced version is available.
-
-
-3.1 Basic format test files (non-interlaced)
-------------------------------------------------
-
- basn0g01 - black & white
- basn0g02 - 2 bit (4 level) grayscale
- basn0g04 - 4 bit (16 level) grayscale
- basn0g08 - 8 bit (256 level) grayscale
- basn0g16 - 16 bit (64k level) grayscale
- basn2c08 - 3x8 bits rgb color
- basn2c16 - 3x16 bits rgb color
- basn3p01 - 1 bit (2 color) paletted
- basn3p02 - 2 bit (4 color) paletted
- basn3p04 - 4 bit (16 color) paletted
- basn3p08 - 8 bit (256 color) paletted
- basn4a08 - 8 bit grayscale + 8 bit alpha-channel
- basn4a16 - 16 bit grayscale + 16 bit alpha-channel
- basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel
- basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel
-
-
-3.2 Basic format test files (Adam-7 interlaced)
----------------------------------------------------
-
- basi0g01 - black & white
- basi0g02 - 2 bit (4 level) grayscale
- basi0g04 - 4 bit (16 level) grayscale
- basi0g08 - 8 bit (256 level) grayscale
- basi0g16 - 16 bit (64k level) grayscale
- basi2c08 - 3x8 bits rgb color
- basi2c16 - 3x16 bits rgb color
- basi3p01 - 1 bit (2 color) paletted
- basi3p02 - 2 bit (4 color) paletted
- basi3p04 - 4 bit (16 color) paletted
- basi3p08 - 8 bit (256 color) paletted
- basi4a08 - 8 bit grayscale + 8 bit alpha-channel
- basi4a16 - 16 bit grayscale + 16 bit alpha-channel
- basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel
- basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel
-
-
-3.3 Sizes test files
------------------------
-
- s01n3p01 - 1x1 paletted file, no interlacing
- s02n3p01 - 2x2 paletted file, no interlacing
- s03n3p01 - 3x3 paletted file, no interlacing
- s04n3p01 - 4x4 paletted file, no interlacing
- s05n3p02 - 5x5 paletted file, no interlacing
- s06n3p02 - 6x6 paletted file, no interlacing
- s07n3p02 - 7x7 paletted file, no interlacing
- s08n3p02 - 8x8 paletted file, no interlacing
- s09n3p02 - 9x9 paletted file, no interlacing
- s32n3p04 - 32x32 paletted file, no interlacing
- s33n3p04 - 33x33 paletted file, no interlacing
- s34n3p04 - 34x34 paletted file, no interlacing
- s35n3p04 - 35x35 paletted file, no interlacing
- s36n3p04 - 36x36 paletted file, no interlacing
- s37n3p04 - 37x37 paletted file, no interlacing
- s38n3p04 - 38x38 paletted file, no interlacing
- s39n3p04 - 39x39 paletted file, no interlacing
- s40n3p04 - 40x40 paletted file, no interlacing
-
- s01i3p01 - 1x1 paletted file, interlaced
- s02i3p01 - 2x2 paletted file, interlaced
- s03i3p01 - 3x3 paletted file, interlaced
- s04i3p01 - 4x4 paletted file, interlaced
- s05i3p02 - 5x5 paletted file, interlaced
- s06i3p02 - 6x6 paletted file, interlaced
- s07i3p02 - 7x7 paletted file, interlaced
- s08i3p02 - 8x8 paletted file, interlaced
- s09i3p02 - 9x9 paletted file, interlaced
- s32i3p04 - 32x32 paletted file, interlaced
- s33i3p04 - 33x33 paletted file, interlaced
- s34i3p04 - 34x34 paletted file, interlaced
- s35i3p04 - 35x35 paletted file, interlaced
- s36i3p04 - 36x36 paletted file, interlaced
- s37i3p04 - 37x37 paletted file, interlaced
- s38i3p04 - 38x38 paletted file, interlaced
- s39i3p04 - 39x39 paletted file, interlaced
- s40i3p04 - 40x40 paletted file, interlaced
-
-
-3.4 Background test files (with alpha)
-------------------------------------------
-
- bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced
- bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced
- bgan6a08 - 3x8 bits rgb color, alpha, no background chunk
- bgan6a16 - 3x16 bits rgb color, alpha, no background chunk
-
- bgbn4a08 - 8 bit grayscale, alpha, black background chunk
- bggn4a16 - 16 bit grayscale, alpha, gray background chunk
- bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk
- bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk
-
-
-3.5 Transparency (and background) test files
-------------------------------------------------
-
- tp0n1g08 - not transparent for reference (logo on gray)
- tbbn1g04 - transparent, black background chunk
- tbwn1g16 - transparent, white background chunk
- tp0n2c08 - not transparent for reference (logo on gray)
- tbrn2c08 - transparent, red background chunk
- tbgn2c16 - transparent, green background chunk
- tbbn2c16 - transparent, blue background chunk
- tp0n3p08 - not transparent for reference (logo on gray)
- tp1n3p08 - transparent, but no background chunk
- tbbn3p08 - transparent, black background chunk
- tbgn3p08 - transparent, light-gray background chunk
- tbwn3p08 - transparent, white background chunk
- tbyn3p08 - transparent, yellow background chunk
-
-
-3.6 Gamma test files
-------------------------
-
- g03n0g16 - grayscale, file-gamma = 0.35
- g04n0g16 - grayscale, file-gamma = 0.45
- g05n0g16 - grayscale, file-gamma = 0.55
- g07n0g16 - grayscale, file-gamma = 0.70
- g10n0g16 - grayscale, file-gamma = 1.00
- g25n0g16 - grayscale, file-gamma = 2.50
- g03n2c08 - color, file-gamma = 0.35
- g04n2c08 - color, file-gamma = 0.45
- g05n2c08 - color, file-gamma = 0.55
- g07n2c08 - color, file-gamma = 0.70
- g10n2c08 - color, file-gamma = 1.00
- g25n2c08 - color, file-gamma = 2.50
- g03n3p04 - paletted, file-gamma = 0.35
- g04n3p04 - paletted, file-gamma = 0.45
- g05n3p04 - paletted, file-gamma = 0.55
- g07n3p04 - paletted, file-gamma = 0.70
- g10n3p04 - paletted, file-gamma = 1.00
- g25n3p04 - paletted, file-gamma = 2.50
-
-
-3.7 Filtering test files
-----------------------------
-
- f00n0g08 - grayscale, no interlacing, filter-type 0
- f01n0g08 - grayscale, no interlacing, filter-type 1
- f02n0g08 - grayscale, no interlacing, filter-type 2
- f03n0g08 - grayscale, no interlacing, filter-type 3
- f04n0g08 - grayscale, no interlacing, filter-type 4
- f00n2c08 - color, no interlacing, filter-type 0
- f01n2c08 - color, no interlacing, filter-type 1
- f02n2c08 - color, no interlacing, filter-type 2
- f03n2c08 - color, no interlacing, filter-type 3
- f04n2c08 - color, no interlacing, filter-type 4
-
-
-3.8 Additional palette chunk test files
--------------------------------------------
-
- pp0n2c16 - six-cube palette-chunk in true-color image
- pp0n6a08 - six-cube palette-chunk in true-color+alpha image
- ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image
- ps1n2c16 - six-cube suggested palette (1 byte) in true-color image
- ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image
- ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image
-
-
-3.9 Ancillary chunks test files
------------------------------------
-
- cs5n2c08 - color, 5 significant bits
- cs8n2c08 - color, 8 significant bits (reference)
- cs3n2c16 - color, 13 significant bits
- cs3n3p08 - paletted, 3 significant bits
- cs5n3p08 - paletted, 5 significant bits
- cs8n3p08 - paletted, 8 significant bits (reference)
-
- cdfn2c08 - physical pixel dimensions, 8x32 flat pixels
- cdhn2c08 - physical pixel dimensions, 32x8 high pixels
- cdsn2c08 - physical pixel dimensions, 8x8 square pixels
- cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter
-
- ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
- ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
-
- ch1n3p04 - histogram 15 colors
- ch2n3p08 - histogram 256 colors
-
- cm7n0g04 - modification time, 01-jan-1970 00:00:00
- cm9n0g04 - modification time, 31-dec-1999 23:59:59
- cm0n0g04 - modification time, 01-jan-2000 12:34:56
-
- ct0n0g04 - no textual data
- ct1n0g04 - with textual data
- ctzn0g04 - with compressed textual data
-
-
-
-3.10 Chunk ordering
-----------------------
-
- oi1n0g16 - grayscale mother image with 1 idat-chunk
- oi2n0g16 - grayscale image with 2 idat-chunks
- oi4n0g16 - grayscale image with 4 unequal sized idat-chunks
- oi9n0g16 - grayscale image with all idat-chunks length one
- oi1n2c16 - color mother image with 1 idat-chunk
- oi2n2c16 - color image with 2 idat-chunks
- oi4n2c16 - color image with 4 unequal sized idat-chunks
- oi9n2c16 - color image with all idat-chunks length one
-
-
-
-3.11 Compression level
--------------------------
-
- z00n2c08 - color, no interlacing, compression level 0 (none)
- z03n2c08 - color, no interlacing, compression level 3
- z06n2c08 - color, no interlacing, compression level 6 (default)
- z09n2c08 - color, no interlacing, compression level 9 (maximum)
-
-
-
-3.12 Currupted files
------------------------
-
- x00n0g01 - empty 0x0 grayscale file
- xcrn0g04 - added cr bytes
- xlfn0g04 - added lf bytes
- xc0n0c08 - color type 0
- xc9n0c08 - color type 9
- xd0n2c00 - bit-depth 0
- xd3n2c03 - bit-depth 3
- xd9n2c99 - bit-depth 99
- xcsn2c08 - incorrect IDAT checksum
-
-
---------
- (c) Willem van Schaik
- willem@schaik.com
- Singapore, October 1996
+++ /dev/null
-\89PNG
-
-
-\1a
-
-
-IHDR \ 4\93áÈ)ÈIDATx\9c]ÑÁ
-Â0\f\ 5P\1f*@\bð\b\1d¡#°
-
-#TâÈ\ 51\ 1\e0\ 2lPF`\ 3Ø F=\95\ 2\9fÄIQâ\1c*çÅuí\94`\16%qk\81
-H\9eñ\9a\88©ñ´\80m\ 2÷\7fÍ\büµàß\9f Ñ\8d=,\14¸fìOK
-
-ç\a Ðt\8eÀ(Èï\ 5ä\92×\1e¦íF\v;èPº\80¯¾{xpç]\ 39\87/\ap\8f*$(ì*éyìÕ\83 ×þ\1eÚéçè@÷C¼ \12 cÔq\16\9e\8bNÛU#\84)11·.\8d\81\15r\10äðf\ 3\17ä0°\81ägh(¥\81tý\1eÙÂEøÿ\89kIEND®B`\82
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax images images.viewer kernel
-quotations strings ;
-IN: images.testing
-
-HELP: decode-test
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image decoder. The image is decoded and compared against its corresponding " { $link { "images" "testing" "reference" } } "." } ;
-
-HELP: encode-test
-{ $values
- { "path" "a pathname string" } { "image-class" object }
-}
-{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." }
-{ $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ;
-
-HELP: images.
-{ $values
- { "dirpath" "a pathname string" } { "extension" string }
-}
-{ $description "Renders each image at " { $snippet "dirpath" } " directly to the Listener tool." } ;
-{ images. image. } related-words
-
-HELP: load-reference-image
-{ $values
- { "path" "a pathname string" }
- { "image" image }
-}
-{ $description "Loads the " { $link { "images" "testing" "reference" } } " that corresponds to the original image at " { $snippet "path" } " into memory." } ;
-
-HELP: ls
-{ $values
- { "dirpath" "a pathname string" } { "extension" object }
-}
-{ $description "Prints out the name of each file surrounded in double quotes so that you can easily copy and paste into your unit test." } ;
-
-HELP: save-all-as-reference-images
-{ $values
- { "dirpath" "a pathname string" } { "extension" object }
-}
-{ $description "Saves a " { $link { "images" "testing" "reference" } } " for each image in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." }
-{ $warning "You should only call this word after you have manually verified that every image in " { $snippet "dirpath" } " decodes and renders correctly!" } ;
-
-HELP: save-as-reference-image
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "Saves a " { $link { "images" "testing" "reference" } } " for the image at " { $snippet "path" } "." }
-{ $warning "You should only call this word after you have manually verified that the image at " { $snippet "path" } " decodes and renders correctly!" } ;
-
-HELP: with-matching-files
-{ $values
- { "dirpath" "a pathname string" } { "extension" string } { "quot" quotation }
-}
-{ $description "Perform an operation on each file in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } ;
-
-ARTICLE: { "images" "testing" "reference" } "Reference image"
-"For the purposes of the " { $vocab-link "images.testing" } " vocab, a reference image is an " { $link image } " which has been serialized to disk by the " { $vocab-link "serialize" } " vocab. The file on disk has a " { $snippet ".fig" } " extension."
-$nl
-"Reference images are used by " { $link decode-test } " to compare the decoder's output against a saved image that is known to be correct."
-$nl
-"You can create your own reference image after you verify that the image has been correctly decoded:"
-{ $subsections
- save-as-reference-image
- save-all-as-reference-images
-}
-"A reference image can be loaded by the path of the original image:"
-{ $subsections load-reference-image }
-;
-
-ARTICLE: "images.testing" "Testing image encoders and decoders"
-"The " { $vocab-link "images.testing" } " vocab facilitates writing unit tests for image encoders and decoders by providing common functionality"
-$nl
-"Creating a unit test:"
-{ $subsections
- decode-test
- encode-test
-}
-"Establishing a " { $link { "images" "testing" "reference" } } ":"
-{ $subsections save-as-reference-image }
-"You should only create a reference image after you manually verify that your decoder is generating a valid " { $link image } " object and that it renders correctly to the screen. The following words are useful for manual verification:"
-{ $subsections
- image.
- images.
-}
-"Helpful words for writing potentially tedious unit tests for each image file under test:"
-{ $subsections
- save-all-as-reference-images
- ls
- with-matching-files
-}
-{ $notes "This vocabulary is only intended for implementors of image encoders and image decoders. If you are an end-user, you are in the wrong place :-)" }
-;
-
-ABOUT: "images.testing"
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry images.loader images.normalization images.viewer io
-io.directories io.encodings.binary io.files io.pathnames
-io.streams.byte-array kernel locals namespaces quotations
-sequences serialize tools.test io.backend ;
-IN: images.testing
-
-<PRIVATE
-
-: fig-name ( path -- newpath )
- [ parent-directory normalize-path ]
- [ file-stem ".fig" append ] bi
- append-path ;
-
-PRIVATE>
-
-:: with-matching-files ( dirpath extension quot -- )
- dirpath [
- [
- dup file-extension extension = quot [ drop ] if
- ] each
- ] with-directory-files ; inline
-
-: images. ( dirpath extension -- )
- [ image. ] with-matching-files ;
-
-: ls ( dirpath extension -- )
- [ "\"" dup surround print ] with-matching-files ;
-
-: save-as-reference-image ( path -- )
- [ load-image ] [ fig-name ] bi
- binary [ serialize ] with-file-writer ;
-
-: save-all-as-reference-images ( dirpath extension -- )
- [ save-as-reference-image ] with-matching-files ;
-
-: load-reference-image ( path -- image )
- fig-name binary [ deserialize ] with-file-reader ;
-
-:: encode-test ( path image-class -- )
- f verbose-tests? [
- path load-image dup clone normalize-image 1quotation swap
- '[
- binary [ _ image-class image>stream ] with-byte-writer
- image-class load-image* normalize-image
- ] unit-test
- ] with-variable ;
-
-: decode-test ( path -- )
- f verbose-tests? [
- [ load-image 1quotation ]
- [ '[ _ load-reference-image ] ] bi
- unit-test
- ] with-variable ;
TUPLE: buffer
{ size fixnum }
-{ ptr simple-alien }
+{ ptr alien }
{ fill fixnum }
{ pos fixnum }
disposed ;
{ "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" }
--- /dev/null
+#
+# 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
"syntax"
"tools.annotations"
"tools.crossref"
+ "tools.deprecation"
"tools.destructors"
"tools.disassembler"
+ "tools.dispatch"
"tools.errors"
"tools.memory"
"tools.profiler"
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
] with-row
] each
] tabular-output nl ;
+
+: object-table. ( obj alist -- )
+ [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
+ simple-table. ;
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: sequences.merged
+
+ARTICLE: "sequences-merge" "Merging sequences"
+"When multiple sequences are merged into one sequence, the new sequence takes an element from each input sequence in turn. For example, if we merge " { $code "{ 1 2 3 }" } "and" { $code "{ \"a\" \"b\" \"c\" }" } "we get:" { $code "{ 1 \"a\" 2 \"b\" 3 \"c\" }" } "."
+{ $subsections
+ merge
+ 2merge
+ 3merge
+ <merged>
+ <2merged>
+ <3merged>
+} ;
+
+ABOUT: "sequences-merge"
+
+HELP: merged
+{ $class-description "A virtual sequence which presents a merged view of its underlying elements. New instances are created by calling one of " { $link <merged> } ", " { $link <2merged> } ", or " { $link <3merged> } "." }
+{ $see-also merge } ;
+
+HELP: <merged> ( seqs -- merged )
+{ $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence." }
+{ $see-also <2merged> <3merged> merge } ;
+
+HELP: <2merged> ( seq1 seq2 -- merged )
+{ $values { "seq1" sequence } { "seq2" sequence } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the two input sequences." }
+{ $see-also <merged> <3merged> 2merge } ;
+
+HELP: <3merged> ( seq1 seq2 seq3 -- merged )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the three input sequences." }
+{ $see-also <merged> <2merged> 3merge } ;
+
+HELP: merge ( seqs -- seq )
+{ $values { "seqs" "a sequence of sequences to merge" } { "seq" "a new sequence" } }
+{ $description "Outputs a new sequence which merges the elements of each sequence in " { $snippet "seqs" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.merged ;" "{ { 1 2 } { 3 4 } { 5 6 } } merge ." "{ 1 3 5 2 4 6 }" }
+ { $example "USING: prettyprint sequences.merged ;" "{ \"abc\" \"def\" } merge ." "\"adbecf\"" }
+}
+{ $see-also 2merge 3merge <merged> } ;
+
+HELP: 2merge ( seq1 seq2 -- seq )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq" "a new sequence" } }
+{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of " { $snippet "seq1" } " and " { $snippet "seq2" } }
+{ $see-also merge 3merge <2merged> } ;
+
+HELP: 3merge ( seq1 seq2 seq3 -- seq )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "seq" "a new sequence" } }
+{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of all three sequences" }
+{ $see-also merge 2merge <3merged> } ;
--- /dev/null
+USING: sequences sequences.merged tools.test ;
+IN: sequences.merged.tests
+
+[ 0 { 1 2 } ] [ 0 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 0 { 3 4 } ] [ 1 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 1 { 1 2 } ] [ 2 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 4 ] [ 3 { { 1 2 3 4 } } <merged> nth ] unit-test
+[ 4 { { 1 2 3 4 } } <merged> nth ] must-fail
+
+[ 1 ] [ 0 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 4 ] [ 1 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 2 ] [ 2 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 5 ] [ 3 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 3 ] [ 4 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+
+[ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math sequences ;
+IN: sequences.merged
+
+TUPLE: merged seqs ;
+C: <merged> merged
+
+: <2merged> ( seq1 seq2 -- merged ) 2array <merged> ;
+: <3merged> ( seq1 seq2 seq3 -- merged ) 3array <merged> ;
+
+: merge ( seqs -- seq )
+ dup <merged> swap first like ;
+
+: 2merge ( seq1 seq2 -- seq )
+ dupd <2merged> swap like ;
+
+: 3merge ( seq1 seq2 seq3 -- seq )
+ pick [ <3merged> ] dip like ;
+
+M: merged length seqs>> [ length ] map sum ;
+
+M: merged virtual@ ( n seq -- n' seq' )
+ seqs>> [ length /mod ] [ nth ] bi ;
+
+M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ;
+
+INSTANCE: merged virtual-sequence
--- /dev/null
+A virtual sequence which merges (interleaves) other sequences.
--- /dev/null
+collections
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax quotations sequences ;
+IN: sequences.product
+
+HELP: product-sequence
+{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
+{ $examples
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+""" """{
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}""" } } ;
+
+HELP: <product-sequence>
+{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
+{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
+{ $examples
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}""" } } ;
+
+{ product-sequence <product-sequence> } related-words
+
+HELP: product-map
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
+{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
+
+HELP: product-each
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
+{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
+
+{ product-map product-each } related-words
+
+ARTICLE: "sequences.product" "Product sequences"
+"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
+{ $subsections
+ product-sequence
+ <product-sequence>
+ product-map
+ product-each
+} ;
+
+ABOUT: "sequences.product"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel make sequences sequences.product tools.test ;
+IN: sequences.product.tests
+
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
+
+: x ( n s -- sss ) <repetition> concat ;
+
+[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
+[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
+
+[
+ {
+ { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
+ { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
+ }
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
+
+[ "a1b1c1a2b2c2" ] [
+ [
+ { { "a" "b" "c" } { "1" "2" } }
+ [ [ % ] each ] product-each
+ ] "" make
+] unit-test
+
+[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
+[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays kernel locals math sequences ;
+IN: sequences.product
+
+TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
+
+: <product-sequence> ( sequences -- product-sequence )
+ >array dup [ length ] map product-sequence boa ;
+
+INSTANCE: product-sequence sequence
+
+M: product-sequence length lengths>> product ;
+
+<PRIVATE
+
+: ns ( n lengths -- ns )
+ [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+
+: nths ( ns seqs -- nths )
+ [ nth ] { } 2map-as ;
+
+: product@ ( n product-sequence -- ns seqs )
+ [ lengths>> ns ] [ nip sequences>> ] 2bi ;
+
+:: (carry-n) ( ns lengths i -- )
+ ns length i 1 + = [
+ i ns nth i lengths nth = [
+ 0 i ns set-nth
+ i 1 + ns [ 1 + ] change-nth
+ ns lengths i 1 + (carry-n)
+ ] when
+ ] unless ;
+
+: carry-ns ( ns lengths -- )
+ 0 (carry-n) ;
+
+: product-iter ( ns lengths -- )
+ [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
+
+: start-product-iter ( sequences -- ns lengths )
+ [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+
+: end-product-iter? ( ns lengths -- ? )
+ [ 1 tail* first ] bi@ = ;
+
+PRIVATE>
+
+M: product-sequence nth
+ product@ nths ;
+
+:: product-each ( sequences quot -- )
+ sequences start-product-iter :> ( ns lengths )
+ lengths [ 0 = ] any? [
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until
+ ] unless ; inline
+
+:: product-map ( sequences quot -- sequence )
+ 0 :> i!
+ sequences [ length ] [ * ] map-reduce sequences
+ [| result |
+ sequences [ quot call i result set-nth i 1 + i! ] product-each
+ result
+ ] new-like ; inline
+
--- /dev/null
+Cartesian products of sequences
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
\ 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
\ 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
\ 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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 } "." } ;
--- /dev/null
+! 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
-USING: help.markup help.syntax memory sequences ;
+USING: help.markup help.syntax memory sequences vm ;
IN: tools.memory
ARTICLE: "tools.memory" "Object memory tools"
{ $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." } ;
-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
-! 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 ;
-
-: write-headings ( seq -- )
- [ [ write-cell ] each ] with-row ;
-
-: (data-room.) ( -- )
- data-room 2 <groups> [
- [ first2 ] [ number>string "Generation " prepend ] bi*
- write-total/used/free
- ] each-index
- "Decks" write-total
- "Cards" write-total ;
-
-: write-labeled-size ( n string -- )
- [ write-cell write-size ] with-row ;
-
-: (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 ;
+: micros>string ( n -- str )
+ commas " µs" append ;
+
+: copying-room. ( copying-sizes -- )
+ {
+ { "Size:" [ size>> kilobytes ] }
+ { "Occupied:" [ occupied>> kilobytes ] }
+ { "Free:" [ free>> kilobytes ] }
+ } object-table. ;
+
+: nursery-room. ( data-room -- )
+ "- Nursery space" print nursery>> copying-room. ;
+
+: aging-room. ( data-room -- )
+ "- Aging space" print aging>> copying-room. ;
+
+: 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 ]
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
] 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. ;
method-profile.
"profiler-limitations"
}
-{ $see-also "ui.tools.profiler" } ;
+{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ;
ABOUT: "profiling"
-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." } ;
-! 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
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 } ;
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 )
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
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 ;
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
"system"
"system.private"
"threads.private"
+ "tools.dispatch.private"
"tools.profiler.private"
"words"
"words.private"
"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 ]
{ "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 )) }
{ "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 )) }
{ "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# -- ? )) }
{ "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
flatten-class\r
flatten-builtin-class\r
class-types\r
- class-tags\r
} ;\r
\r
ARTICLE: "class-linearization" "Class linearization"\r
\r
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
\r
-[ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
-\r
[ t ] [\r
growable tuple sequence class-and class<=\r
] unit-test\r
flatten-builtin-class keys\r
[ "type" word-prop ] map natural-sort ;\r
\r
-: class-tags ( class -- seq )\r
- class-types [\r
- dup num-tags get >=\r
- [ drop \ hi-tag tag-number ] when\r
- ] map prune ;\r
-\r
-: class-tag ( class -- tag/f )\r
- class-tags dup length 1 = [ first ] [ drop f ] if ;\r
+: class-type ( class -- tag/f )\r
+ class-types dup length 1 = [ first ] [ drop f ] if ;\r
: 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 ;
[ 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 )
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 ;
: <engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
- convert-hi-tag-methods
<tag-dispatch-engine> ;
! ! ! Compile engine ! ! !
: 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
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 } }
: declare ( spec -- ) drop ;
-: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
-
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
{ $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 } } }
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
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." ;
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
: 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 ;
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
{ { { $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
{ [ 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 ;
+++ /dev/null
-USING: accessors alien.c-types alien.syntax half-floats kernel
-math tools.test specialized-arrays alien.data classes.struct ;
-SPECIALIZED-ARRAY: half
-IN: half-floats.tests
-
-[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
-[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
-[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
-[ HEX: be00 ] [ -1.5 half>bits ] unit-test
-[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
-[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
-[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
-
-! too-big floats overflow to infinity
-[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
-[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
-
-! too-small floats flush to zero
-[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
-[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
-
-[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
-[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
-[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
-[ -1.5 ] [ HEX: be00 bits>half ] unit-test
-[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
-[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
-
-STRUCT: halves
- { tom half }
- { dick half }
- { harry half }
- { harry-jr half } ;
-
-[ 8 ] [ halves heap-size ] unit-test
-
-[ 3.0 ] [
- halves <struct>
- 3.0 >>dick
- dick>>
-] unit-test
-
-[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
-[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
-
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors alien.accessors alien.c-types alien.data
-alien.syntax kernel math math.order ;
-FROM: math => float ;
-IN: half-floats
-
-: half>bits ( float -- bits )
- float>bits
- [ -31 shift 15 shift ] [
- HEX: 7fffffff bitand
- dup zero? [
- dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
- -13 shift
- 112 10 shift -
- 0 HEX: 7c00 clamp
- ] if
- ] unless
- ] bi bitor ;
-
-: bits>half ( bits -- float )
- [ -15 shift 31 shift ] [
- HEX: 7fff bitand
- dup zero? [
- dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
- 13 shift
- 112 23 shift +
- ] if
- ] unless
- ] bi bitor bits>float ;
-
-SYMBOL: half
-
-<<
-
-<c-type>
- float >>class
- float >>boxed-class
- [ alien-unsigned-2 bits>half ] >>getter
- [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
- 2 >>size
- 2 >>align
- [ >float ] >>unboxer-quot
-\ half define-primitive-type
-
->>
+++ /dev/null
-Half-precision float support for FFI
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel images ;
-IN: images.normalization
-
-HELP: normalize-image
-{ $values
- { "image" image }
- { "image" image }
-}
-{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
-
-HELP: reorder-components
-{ $values
- { "image" image } { "component-order" component-order }
- { "image" image }
-}
-{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
-{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
-$nl
-"You cannot use this word to reorder " { $link DEPTH } ", " { $link DEPTH-STENCIL } " or " { $link INTENSITY } " component orders." } ;
-
-ARTICLE: "images.normalization" "Image normalization"
-"The " { $vocab-link "images.normalization" } " vocab can be used to convert between " { $link image } " representations."
-$nl
-"You can normalize any image to a RGBA with ubyte-components representation:"
-{ $subsections normalize-image }
-"Convert an image's pixel layout to match an arbitrary " { $link component-order } ":"
-{ $subsections reorder-components } ;
-
-ABOUT: "images.normalization"
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images images.normalization images.normalization.private
-sequences tools.test ;
-IN: images.normalization.tests
-
-! 1>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 } A L permute ] unit-test
-
-[ B{ 255 255 255 255 } ]
-[ B{ 0 1 } A RG permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 } A BGR permute ] unit-test
-
-[ B{ 0 255 255 255 1 255 255 255 } ]
-[ B{ 0 1 } A ABGR permute ] unit-test
-
-! 2>x
-
-[ B{ 0 2 } ]
-[ B{ 0 1 2 3 } LA L permute ] unit-test
-
-[ B{ 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA RG permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA BGR permute ] unit-test
-
-[ B{ 1 255 255 255 3 255 255 255 } ]
-[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
-
-! 3>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
-
-[ B{ 0 1 3 4 } ]
-[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
-
-[ B{ 2 1 0 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
-
-[ B{ 255 2 1 0 255 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
-
-! 4>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
-
-[ B{ 0 1 4 5 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
-
-[ B{ 2 1 0 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
-
-[ B{ 3 2 1 0 7 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
-
-! Edge cases
-
-[ B{ 0 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
-
-[ B{ 255 0 1 2 255 4 5 6 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
-
-[ B{ 1 2 3 255 5 6 7 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 255 255 } ]
-[ B{ 0 1 } L RGBA permute ] unit-test
-
-! Invalid inputs
-
-[
- T{ image f { 1 1 } DEPTH ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } DEPTH-STENCIL ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } INTENSITY ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- DEPTH reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- DEPTH-STENCIL reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- INTENSITY reorder-components
-] must-fail
-
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman, Keith Lazuka
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays combinators fry
-grouping images kernel locals math math.vectors
-sequences specialized-arrays half-floats ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: half
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: ushort
-IN: images.normalization
-
-<PRIVATE
-
-CONSTANT: don't-care 127
-CONSTANT: fill-value 255
-
-: permutation ( src dst -- seq )
- swap '[ _ index [ don't-care ] unless* ] { } map-as
- 4 don't-care pad-tail ;
-
-: pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
-
-: shuffle ( seq permutation -- newseq )
- swap '[
- dup 4 >= [ drop fill-value ] [ _ nth ] if
- ] B{ } map-as ;
-
-:: permute ( bytes src-order dst-order -- new-bytes )
- src-order name>> :> src
- dst-order name>> :> dst
- bytes src length group
- [ pad4 src dst permutation shuffle dst length head ]
- map concat ;
-
-: (reorder-components) ( image src-order dest-order -- image )
- [ permute ] 2curry change-bitmap ;
-
-GENERIC: normalize-component-type* ( image component-type -- image )
-
-: normalize-floats ( float-array -- byte-array )
- [ 255.0 * >integer ] B{ } map-as ;
-
-M: float-components normalize-component-type*
- drop byte-array>float-array normalize-floats ;
-
-M: half-components normalize-component-type*
- drop byte-array>half-array normalize-floats ;
-
-: ushorts>ubytes ( bitmap -- bitmap' )
- byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: ushort-components normalize-component-type*
- drop ushorts>ubytes ;
-
-M: ubyte-components normalize-component-type*
- drop ;
-
-: normalize-scan-line-order ( image -- image )
- dup upside-down?>> [
- dup dim>> first 4 * '[
- _ <groups> reverse concat
- ] change-bitmap
- f >>upside-down?
- ] when ;
-
-: validate-request ( src-order dst-order -- src-order dst-order )
- [
- [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
- or [ "Invalid component-order" throw ] when
- ] 2keep ;
-
-PRIVATE>
-
-: reorder-components ( image component-order -- image )
- [
- dup component-type>> '[ _ normalize-component-type* ] change-bitmap
- dup component-order>>
- ] dip
- validate-request [ (reorder-components) ] keep >>component-order ;
-
-: normalize-image ( image -- image )
- [ >byte-array ] change-bitmap
- RGBA reorder-components
- normalize-scan-line-order ;
-
--- /dev/null
+ PNGSUITE
+----------------
+
+ testset for PNG-(de)coders
+ created by Willem van Schaik
+------------------------------------
+
+This is a collection of graphics images created to test the png applications
+like viewers, converters and editors. All (as far as that is possible)
+formats supported by the PNG standard are represented.
+
+
+1. INTRODUCTION
+--------------------
+
+1.1 PNG capabilities
+------------------------
+
+Supported color-types are:
+
+ - grayscale
+ - grayscale + alpha-channel
+ - color palettes
+ - rgb
+ - rgb + alpha-channel
+
+Allowed bitdepths are depending on the color-type, but are in the range
+of 1-bit (grayscale, which is b&w) upto 16-bits.
+
+Special features are:
+
+ - interlacing (Adam-7)
+ - gamma-support
+ - transparency (a poor-man's alpha solution)
+
+
+1.2 File naming
+-------------------
+
+Where possible, the testfiles are 32x32 bits icons. This results in a still
+reasonable size of the suite even with a large number of tests. The name
+of each test-file reflects thetype in the following way:
+
+ g04i2c08.png
+ || |||+---- bit-depth
+ || ||+----- color-type (descriptive)
+ || |+------ color-type (numerical)
+ || +------- interlaced or non-interlaced
+ |+--------- parameter of test (in this case gamma-value)
+ +---------- test feature (in this case gamma)
+
+
+1.3 PNG formats
+-------------------
+
+color-type:
+ 0g - grayscale
+ 2c - rgb color
+ 3p - paletted
+ 4a - grayscale + alpha channel
+ 6a - rgb color + alpha channel
+
+bit-depth:
+ 01 - with color-type 0, 3
+ 02 - with color-type 0, 3
+ 04 - with color-type 0, 3
+ 08 - with color-type 0, 2, 3, 4, 6
+ 16 - with color-type 0, 2, 4, 6
+
+interlacing:
+ n - non-interlaced
+ i - interlaced
+
+
+2. THE TESTS
+-----------------
+
+2.1 Sizes
+-------------
+
+These tests are there to check if your software handles pictures well, with
+picture sizes that are not a multiple of 8. This is particularly important
+with Adam-7 type interlacing. In the same way these tests check if pictures
+size 1x1 and similar are ok.
+
+ s01 - 1x1 pixel picture
+ s02 - 2x2 pixel picture
+ s03 - 3x3 pixel picture
+ s04 - 4x4 pixel picture
+ s05 - 5x5 pixel picture
+ s06 - 6x6 pixel picture
+ s07 - 7x7 pixel picture
+ s08 - 8x8 pixel picture
+ s09 - 9x9 pixel picture
+ s32 - 32x32 pixel picture
+ s33 - 33x33 pixel picture
+ s34 - 34x34 pixel picture
+ s35 - 35x35 pixel picture
+ s36 - 36x36 pixel picture
+ s37 - 37x37 pixel picture
+ s38 - 38x38 pixel picture
+ s39 - 39x39 pixel picture
+ s40 - 40x40 pixel picture
+
+
+2.2 Background
+------------------
+
+When the PNG file contains a background chunck, this should be used for
+pictures with alpha-channel or pictures with a transparency chunck. For
+pictures without this background-chunk, but with alpha, this testset
+assumes a black background.
+
+For the images in this test, the left-side should be 100% the background
+color, where moving to the right the color should gradually become the
+image pattern.
+
+ bga - alpha + no background
+ bgw - alpha + white background
+ bgg - alpha + gray background
+ bgb - alpha + black background
+ bgy - alpha + yellow background
+
+
+2.3 Transparency
+--------------------
+
+Transparency should be used together with a background chunk. To test the
+combination of the two the latter 4 tests are there. How to handle pictures
+with transparancy, but without a background, opinions can differ. Here we
+use black, but especially in the case of paletted images, the normal color
+would maybe even be better.
+
+ tp0 - not transparent for reference
+ tp1 - transparent, but no background chunk
+ tbw - transparent + white background
+ tbg - transparent + gray background
+ tbb - transparent + black background
+ tby - transparent + yellow background
+
+
+2.4 Gamma
+-------------
+
+To test if your viewer handles gamma-correction, 6 testfiles are available.
+They contain corrected color-ramps and a corresponding gamma-chunk with the
+file-gamma value. These are created in such a way that when the viewer does
+the gamma correction right, all 6 should be displayed identical.
+
+If they are different, probably the gamma correction is omitted. In that
+case, have a look at the two right coloumns in the 6 pictures. The image
+where those two look the same (when looked from far) reflects the gamma of
+your system. However, because of the limited size of the image, you should
+do more elaborate tests to determine your display gamma.
+
+ g03 - file-gamma = 0.35, for display with gamma = 2.8
+ g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC)
+ g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac)
+ g07 - file-gamma = 0.70, for display with gamma = 1.4
+ g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT)
+ g25 - file-gamma = 2.50, for display with gamma = 0.4
+
+
+2.5 Filtering
+-----------------
+
+PNG uses file-filtering, for optimal compression. Normally the type is of
+filtering is adjusted to the contents of the picture, but here each file
+has the same picture, with a different filtering.
+
+ f0 - no filtering
+ f1 - sub filtering
+ f2 - up filtering
+ f3 - average filtering
+ f4 - paeth filtering
+
+
+2.6 Additional palettes
+---------------------------
+
+Besides the normal use of paletted images, palette chunks can in combination
+with true-color (and other) images also be used to select color lookup-tables
+when the video system is of limited capabilities. The suggested palette chunk
+is specially created for this purpose.
+
+ pp - normal palette chunk
+ ps - suggested palette chunk
+
+
+2.7 Ancillary chunks (under construction)
+------------------------
+
+To test the correct decoding of ancillary chunks, these test-files contain
+one or more examples of these chunkcs. Depending on the type of chunk, a
+number of typical values are selected to test. Unluckily, the testset can
+not contain all combinations, because that would be an endless set.
+
+The significant bits are used in files with the next higher bit-depth. They
+indicate howmany bits are valid.
+
+ cs3 - 3 significant bits
+ cs5 - 5 significant bits
+ cs8 - 8 significant bits (reference)
+ cs3 - 13 significant bits
+
+For the physical pixel dimensions, the result of each decoding should be
+a sqare picture. The first (cdf) image is an example of flat (horizontal)
+pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take
+care of the correction. The second is just the other way round. The last
+example uses the unit specifier, for 1000 pixels per meter. This should
+result in a picture of 3.2 cm square.
+
+ cdf - physical pixel dimensions, 8x32 flat pixels
+ cdh - physical pixel dimensions, 32x8 high pixels
+ cds - physical pixel dimensions, 8x8 square pixels
+ cdu - physical pixel dimensions, with unit-specifier
+
+ ccw - primary chromaticities and white point
+
+ ch1 - histogram 15 colors
+ ch2 - histogram 256 colors
+
+ cm7 - modification time, 01-jan-1970
+ cm9 - modification time, 31-dec-1999
+ cm0 - modification time, 01-jan-2000
+
+In the textual chunk, a number of the standard, and some non-standard
+text items are included.
+
+ ct0 - no textual data
+ ct1 - with textual data
+ ctz - with compressed textual data
+
+
+2.8 Chunk ordering (still under construction)
+----------------------
+
+These testfiles will test the obligatory ordering relations between various
+chunk types (not yet) as well as the number of data chunks used for the image.
+
+ oi1 - mother image with 1 idat-chunk
+ oi2 - image with 2 idat-chunks
+ oi4 - image with 4 unequal sized idat-chunks
+ oi9 - all idat-chunks of length one
+
+
+2.9 Compression level
+-------------------------
+
+Here you will find a set of images compressed by zlib, ranging from level 0
+for no compression at maximum speed upto level 9 for maximum compression.
+
+ z00 - zlib compression level 0 - none
+ z03 - zlib compression level 3
+ z06 - zlib compression level 6 - default
+ z09 - zlib compression level 9 - maximum
+
+
+2.10 Corrupted files (under construction)
+-----------------------
+
+All these files are illegal. When decoding they should generate appropriate
+error-messages.
+
+ x00 - empty IDAT chunk
+ xcr - added cr bytes
+ xlf - added lf bytes
+ xc0 - color type 0
+ xc9 - color type 9
+ xd0 - bit-depth 0
+ xd3 - bit-depth 3
+ xd9 - bit-depth 99
+ xcs - incorrect IDAT checksum
+
+
+3. TEST FILES
+------------------
+
+For each of the tests listed above, one or more test-files are created. A
+selection is made (for each test) for the color-type and bitdepth to be used
+for the tests. Further for a number of tests, both a non-interlaced as well
+as an interlaced version is available.
+
+
+3.1 Basic format test files (non-interlaced)
+------------------------------------------------
+
+ basn0g01 - black & white
+ basn0g02 - 2 bit (4 level) grayscale
+ basn0g04 - 4 bit (16 level) grayscale
+ basn0g08 - 8 bit (256 level) grayscale
+ basn0g16 - 16 bit (64k level) grayscale
+ basn2c08 - 3x8 bits rgb color
+ basn2c16 - 3x16 bits rgb color
+ basn3p01 - 1 bit (2 color) paletted
+ basn3p02 - 2 bit (4 color) paletted
+ basn3p04 - 4 bit (16 color) paletted
+ basn3p08 - 8 bit (256 color) paletted
+ basn4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basn4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.2 Basic format test files (Adam-7 interlaced)
+---------------------------------------------------
+
+ basi0g01 - black & white
+ basi0g02 - 2 bit (4 level) grayscale
+ basi0g04 - 4 bit (16 level) grayscale
+ basi0g08 - 8 bit (256 level) grayscale
+ basi0g16 - 16 bit (64k level) grayscale
+ basi2c08 - 3x8 bits rgb color
+ basi2c16 - 3x16 bits rgb color
+ basi3p01 - 1 bit (2 color) paletted
+ basi3p02 - 2 bit (4 color) paletted
+ basi3p04 - 4 bit (16 color) paletted
+ basi3p08 - 8 bit (256 color) paletted
+ basi4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basi4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.3 Sizes test files
+-----------------------
+
+ s01n3p01 - 1x1 paletted file, no interlacing
+ s02n3p01 - 2x2 paletted file, no interlacing
+ s03n3p01 - 3x3 paletted file, no interlacing
+ s04n3p01 - 4x4 paletted file, no interlacing
+ s05n3p02 - 5x5 paletted file, no interlacing
+ s06n3p02 - 6x6 paletted file, no interlacing
+ s07n3p02 - 7x7 paletted file, no interlacing
+ s08n3p02 - 8x8 paletted file, no interlacing
+ s09n3p02 - 9x9 paletted file, no interlacing
+ s32n3p04 - 32x32 paletted file, no interlacing
+ s33n3p04 - 33x33 paletted file, no interlacing
+ s34n3p04 - 34x34 paletted file, no interlacing
+ s35n3p04 - 35x35 paletted file, no interlacing
+ s36n3p04 - 36x36 paletted file, no interlacing
+ s37n3p04 - 37x37 paletted file, no interlacing
+ s38n3p04 - 38x38 paletted file, no interlacing
+ s39n3p04 - 39x39 paletted file, no interlacing
+ s40n3p04 - 40x40 paletted file, no interlacing
+
+ s01i3p01 - 1x1 paletted file, interlaced
+ s02i3p01 - 2x2 paletted file, interlaced
+ s03i3p01 - 3x3 paletted file, interlaced
+ s04i3p01 - 4x4 paletted file, interlaced
+ s05i3p02 - 5x5 paletted file, interlaced
+ s06i3p02 - 6x6 paletted file, interlaced
+ s07i3p02 - 7x7 paletted file, interlaced
+ s08i3p02 - 8x8 paletted file, interlaced
+ s09i3p02 - 9x9 paletted file, interlaced
+ s32i3p04 - 32x32 paletted file, interlaced
+ s33i3p04 - 33x33 paletted file, interlaced
+ s34i3p04 - 34x34 paletted file, interlaced
+ s35i3p04 - 35x35 paletted file, interlaced
+ s36i3p04 - 36x36 paletted file, interlaced
+ s37i3p04 - 37x37 paletted file, interlaced
+ s38i3p04 - 38x38 paletted file, interlaced
+ s39i3p04 - 39x39 paletted file, interlaced
+ s40i3p04 - 40x40 paletted file, interlaced
+
+
+3.4 Background test files (with alpha)
+------------------------------------------
+
+ bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced
+ bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced
+ bgan6a08 - 3x8 bits rgb color, alpha, no background chunk
+ bgan6a16 - 3x16 bits rgb color, alpha, no background chunk
+
+ bgbn4a08 - 8 bit grayscale, alpha, black background chunk
+ bggn4a16 - 16 bit grayscale, alpha, gray background chunk
+ bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk
+ bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk
+
+
+3.5 Transparency (and background) test files
+------------------------------------------------
+
+ tp0n1g08 - not transparent for reference (logo on gray)
+ tbbn1g04 - transparent, black background chunk
+ tbwn1g16 - transparent, white background chunk
+ tp0n2c08 - not transparent for reference (logo on gray)
+ tbrn2c08 - transparent, red background chunk
+ tbgn2c16 - transparent, green background chunk
+ tbbn2c16 - transparent, blue background chunk
+ tp0n3p08 - not transparent for reference (logo on gray)
+ tp1n3p08 - transparent, but no background chunk
+ tbbn3p08 - transparent, black background chunk
+ tbgn3p08 - transparent, light-gray background chunk
+ tbwn3p08 - transparent, white background chunk
+ tbyn3p08 - transparent, yellow background chunk
+
+
+3.6 Gamma test files
+------------------------
+
+ g03n0g16 - grayscale, file-gamma = 0.35
+ g04n0g16 - grayscale, file-gamma = 0.45
+ g05n0g16 - grayscale, file-gamma = 0.55
+ g07n0g16 - grayscale, file-gamma = 0.70
+ g10n0g16 - grayscale, file-gamma = 1.00
+ g25n0g16 - grayscale, file-gamma = 2.50
+ g03n2c08 - color, file-gamma = 0.35
+ g04n2c08 - color, file-gamma = 0.45
+ g05n2c08 - color, file-gamma = 0.55
+ g07n2c08 - color, file-gamma = 0.70
+ g10n2c08 - color, file-gamma = 1.00
+ g25n2c08 - color, file-gamma = 2.50
+ g03n3p04 - paletted, file-gamma = 0.35
+ g04n3p04 - paletted, file-gamma = 0.45
+ g05n3p04 - paletted, file-gamma = 0.55
+ g07n3p04 - paletted, file-gamma = 0.70
+ g10n3p04 - paletted, file-gamma = 1.00
+ g25n3p04 - paletted, file-gamma = 2.50
+
+
+3.7 Filtering test files
+----------------------------
+
+ f00n0g08 - grayscale, no interlacing, filter-type 0
+ f01n0g08 - grayscale, no interlacing, filter-type 1
+ f02n0g08 - grayscale, no interlacing, filter-type 2
+ f03n0g08 - grayscale, no interlacing, filter-type 3
+ f04n0g08 - grayscale, no interlacing, filter-type 4
+ f00n2c08 - color, no interlacing, filter-type 0
+ f01n2c08 - color, no interlacing, filter-type 1
+ f02n2c08 - color, no interlacing, filter-type 2
+ f03n2c08 - color, no interlacing, filter-type 3
+ f04n2c08 - color, no interlacing, filter-type 4
+
+
+3.8 Additional palette chunk test files
+-------------------------------------------
+
+ pp0n2c16 - six-cube palette-chunk in true-color image
+ pp0n6a08 - six-cube palette-chunk in true-color+alpha image
+ ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image
+ ps1n2c16 - six-cube suggested palette (1 byte) in true-color image
+ ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image
+ ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image
+
+
+3.9 Ancillary chunks test files
+-----------------------------------
+
+ cs5n2c08 - color, 5 significant bits
+ cs8n2c08 - color, 8 significant bits (reference)
+ cs3n2c16 - color, 13 significant bits
+ cs3n3p08 - paletted, 3 significant bits
+ cs5n3p08 - paletted, 5 significant bits
+ cs8n3p08 - paletted, 8 significant bits (reference)
+
+ cdfn2c08 - physical pixel dimensions, 8x32 flat pixels
+ cdhn2c08 - physical pixel dimensions, 32x8 high pixels
+ cdsn2c08 - physical pixel dimensions, 8x8 square pixels
+ cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter
+
+ ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+ ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+
+ ch1n3p04 - histogram 15 colors
+ ch2n3p08 - histogram 256 colors
+
+ cm7n0g04 - modification time, 01-jan-1970 00:00:00
+ cm9n0g04 - modification time, 31-dec-1999 23:59:59
+ cm0n0g04 - modification time, 01-jan-2000 12:34:56
+
+ ct0n0g04 - no textual data
+ ct1n0g04 - with textual data
+ ctzn0g04 - with compressed textual data
+
+
+
+3.10 Chunk ordering
+----------------------
+
+ oi1n0g16 - grayscale mother image with 1 idat-chunk
+ oi2n0g16 - grayscale image with 2 idat-chunks
+ oi4n0g16 - grayscale image with 4 unequal sized idat-chunks
+ oi9n0g16 - grayscale image with all idat-chunks length one
+ oi1n2c16 - color mother image with 1 idat-chunk
+ oi2n2c16 - color image with 2 idat-chunks
+ oi4n2c16 - color image with 4 unequal sized idat-chunks
+ oi9n2c16 - color image with all idat-chunks length one
+
+
+
+3.11 Compression level
+-------------------------
+
+ z00n2c08 - color, no interlacing, compression level 0 (none)
+ z03n2c08 - color, no interlacing, compression level 3
+ z06n2c08 - color, no interlacing, compression level 6 (default)
+ z09n2c08 - color, no interlacing, compression level 9 (maximum)
+
+
+
+3.12 Currupted files
+-----------------------
+
+ x00n0g01 - empty 0x0 grayscale file
+ xcrn0g04 - added cr bytes
+ xlfn0g04 - added lf bytes
+ xc0n0c08 - color type 0
+ xc9n0c08 - color type 9
+ xd0n2c00 - bit-depth 0
+ xd3n2c03 - bit-depth 3
+ xd9n2c99 - bit-depth 99
+ xcsn2c08 - incorrect IDAT checksum
+
+
+--------
+ (c) Willem van Schaik
+ willem@schaik.com
+ Singapore, October 1996
--- /dev/null
+\89PNG
+
+
+\1a
+
+
+IHDR \ 4\93áÈ)ÈIDATx\9c]ÑÁ
+Â0\f\ 5P\1f*@\bð\b\1d¡#°
+
+#TâÈ\ 51\ 1\e0\ 2lPF`\ 3Ø F=\95\ 2\9fÄIQâ\1c*çÅuí\94`\16%qk\81
+H\9eñ\9a\88©ñ´\80m\ 2÷\7fÍ\büµàß\9f Ñ\8d=,\14¸fìOK
+
+ç\a Ðt\8eÀ(Èï\ 5ä\92×\1e¦íF\v;èPº\80¯¾{xpç]\ 39\87/\ap\8f*$(ì*éyìÕ\83 ×þ\1eÚéçè@÷C¼ \12 cÔq\16\9e\8bNÛU#\84)11·.\8d\81\15r\10äðf\ 3\17ä0°\81ägh(¥\81tý\1eÙÂEøÿ\89kIEND®B`\82
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax images images.viewer kernel
+quotations strings ;
+IN: images.testing
+
+HELP: decode-test
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image decoder. The image is decoded and compared against its corresponding " { $link { "images" "testing" "reference" } } "." } ;
+
+HELP: encode-test
+{ $values
+ { "path" "a pathname string" } { "image-class" object }
+}
+{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." }
+{ $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ;
+
+HELP: images.
+{ $values
+ { "dirpath" "a pathname string" } { "extension" string }
+}
+{ $description "Renders each image at " { $snippet "dirpath" } " directly to the Listener tool." } ;
+{ images. image. } related-words
+
+HELP: load-reference-image
+{ $values
+ { "path" "a pathname string" }
+ { "image" image }
+}
+{ $description "Loads the " { $link { "images" "testing" "reference" } } " that corresponds to the original image at " { $snippet "path" } " into memory." } ;
+
+HELP: ls
+{ $values
+ { "dirpath" "a pathname string" } { "extension" object }
+}
+{ $description "Prints out the name of each file surrounded in double quotes so that you can easily copy and paste into your unit test." } ;
+
+HELP: save-all-as-reference-images
+{ $values
+ { "dirpath" "a pathname string" } { "extension" object }
+}
+{ $description "Saves a " { $link { "images" "testing" "reference" } } " for each image in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." }
+{ $warning "You should only call this word after you have manually verified that every image in " { $snippet "dirpath" } " decodes and renders correctly!" } ;
+
+HELP: save-as-reference-image
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Saves a " { $link { "images" "testing" "reference" } } " for the image at " { $snippet "path" } "." }
+{ $warning "You should only call this word after you have manually verified that the image at " { $snippet "path" } " decodes and renders correctly!" } ;
+
+HELP: with-matching-files
+{ $values
+ { "dirpath" "a pathname string" } { "extension" string } { "quot" quotation }
+}
+{ $description "Perform an operation on each file in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } ;
+
+ARTICLE: { "images" "testing" "reference" } "Reference image"
+"For the purposes of the " { $vocab-link "images.testing" } " vocab, a reference image is an " { $link image } " which has been serialized to disk by the " { $vocab-link "serialize" } " vocab. The file on disk has a " { $snippet ".fig" } " extension."
+$nl
+"Reference images are used by " { $link decode-test } " to compare the decoder's output against a saved image that is known to be correct."
+$nl
+"You can create your own reference image after you verify that the image has been correctly decoded:"
+{ $subsections
+ save-as-reference-image
+ save-all-as-reference-images
+}
+"A reference image can be loaded by the path of the original image:"
+{ $subsections load-reference-image }
+;
+
+ARTICLE: "images.testing" "Testing image encoders and decoders"
+"The " { $vocab-link "images.testing" } " vocab facilitates writing unit tests for image encoders and decoders by providing common functionality"
+$nl
+"Creating a unit test:"
+{ $subsections
+ decode-test
+ encode-test
+}
+"Establishing a " { $link { "images" "testing" "reference" } } ":"
+{ $subsections save-as-reference-image }
+"You should only create a reference image after you manually verify that your decoder is generating a valid " { $link image } " object and that it renders correctly to the screen. The following words are useful for manual verification:"
+{ $subsections
+ image.
+ images.
+}
+"Helpful words for writing potentially tedious unit tests for each image file under test:"
+{ $subsections
+ save-all-as-reference-images
+ ls
+ with-matching-files
+}
+{ $notes "This vocabulary is only intended for implementors of image encoders and image decoders. If you are an end-user, you are in the wrong place :-)" }
+;
+
+ABOUT: "images.testing"
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry images.loader images.normalization images.viewer io
+io.directories io.encodings.binary io.files io.pathnames
+io.streams.byte-array kernel locals namespaces quotations
+sequences serialize tools.test io.backend ;
+IN: images.testing
+
+<PRIVATE
+
+: fig-name ( path -- newpath )
+ [ parent-directory normalize-path ]
+ [ file-stem ".fig" append ] bi
+ append-path ;
+
+PRIVATE>
+
+:: with-matching-files ( dirpath extension quot -- )
+ dirpath [
+ [
+ dup file-extension extension = quot [ drop ] if
+ ] each
+ ] with-directory-files ; inline
+
+: images. ( dirpath extension -- )
+ [ image. ] with-matching-files ;
+
+: ls ( dirpath extension -- )
+ [ "\"" dup surround print ] with-matching-files ;
+
+: save-as-reference-image ( path -- )
+ [ load-image ] [ fig-name ] bi
+ binary [ serialize ] with-file-writer ;
+
+: save-all-as-reference-images ( dirpath extension -- )
+ [ save-as-reference-image ] with-matching-files ;
+
+: load-reference-image ( path -- image )
+ fig-name binary [ deserialize ] with-file-reader ;
+
+:: encode-test ( path image-class -- )
+ f verbose-tests? [
+ path load-image dup clone normalize-image 1quotation swap
+ '[
+ binary [ _ image-class image>stream ] with-byte-writer
+ image-class load-image* normalize-image
+ ] unit-test
+ ] with-variable ;
+
+: decode-test ( path -- )
+ f verbose-tests? [
+ [ load-image 1quotation ]
+ [ '[ _ load-reference-image ] ] bi
+ unit-test
+ ] with-variable ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: help.markup help.syntax sequences ;
-IN: sequences.merged
-
-ARTICLE: "sequences-merge" "Merging sequences"
-"When multiple sequences are merged into one sequence, the new sequence takes an element from each input sequence in turn. For example, if we merge " { $code "{ 1 2 3 }" } "and" { $code "{ \"a\" \"b\" \"c\" }" } "we get:" { $code "{ 1 \"a\" 2 \"b\" 3 \"c\" }" } "."
-{ $subsections
- merge
- 2merge
- 3merge
- <merged>
- <2merged>
- <3merged>
-} ;
-
-ABOUT: "sequences-merge"
-
-HELP: merged
-{ $class-description "A virtual sequence which presents a merged view of its underlying elements. New instances are created by calling one of " { $link <merged> } ", " { $link <2merged> } ", or " { $link <3merged> } "." }
-{ $see-also merge } ;
-
-HELP: <merged> ( seqs -- merged )
-{ $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence." }
-{ $see-also <2merged> <3merged> merge } ;
-
-HELP: <2merged> ( seq1 seq2 -- merged )
-{ $values { "seq1" sequence } { "seq2" sequence } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the two input sequences." }
-{ $see-also <merged> <3merged> 2merge } ;
-
-HELP: <3merged> ( seq1 seq2 seq3 -- merged )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the three input sequences." }
-{ $see-also <merged> <2merged> 3merge } ;
-
-HELP: merge ( seqs -- seq )
-{ $values { "seqs" "a sequence of sequences to merge" } { "seq" "a new sequence" } }
-{ $description "Outputs a new sequence which merges the elements of each sequence in " { $snippet "seqs" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.merged ;" "{ { 1 2 } { 3 4 } { 5 6 } } merge ." "{ 1 3 5 2 4 6 }" }
- { $example "USING: prettyprint sequences.merged ;" "{ \"abc\" \"def\" } merge ." "\"adbecf\"" }
-}
-{ $see-also 2merge 3merge <merged> } ;
-
-HELP: 2merge ( seq1 seq2 -- seq )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq" "a new sequence" } }
-{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of " { $snippet "seq1" } " and " { $snippet "seq2" } }
-{ $see-also merge 3merge <2merged> } ;
-
-HELP: 3merge ( seq1 seq2 seq3 -- seq )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "seq" "a new sequence" } }
-{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of all three sequences" }
-{ $see-also merge 2merge <3merged> } ;
+++ /dev/null
-USING: sequences sequences.merged tools.test ;
-IN: sequences.merged.tests
-
-[ 0 { 1 2 } ] [ 0 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 0 { 3 4 } ] [ 1 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 1 { 1 2 } ] [ 2 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 4 ] [ 3 { { 1 2 3 4 } } <merged> nth ] unit-test
-[ 4 { { 1 2 3 4 } } <merged> nth ] must-fail
-
-[ 1 ] [ 0 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 4 ] [ 1 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 2 ] [ 2 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 5 ] [ 3 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 3 ] [ 4 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-
-[ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences ;
-IN: sequences.merged
-
-TUPLE: merged seqs ;
-C: <merged> merged
-
-: <2merged> ( seq1 seq2 -- merged ) 2array <merged> ;
-: <3merged> ( seq1 seq2 seq3 -- merged ) 3array <merged> ;
-
-: merge ( seqs -- seq )
- dup <merged> swap first like ;
-
-: 2merge ( seq1 seq2 -- seq )
- dupd <2merged> swap like ;
-
-: 3merge ( seq1 seq2 seq3 -- seq )
- pick [ <3merged> ] dip like ;
-
-M: merged length seqs>> [ length ] map sum ;
-
-M: merged virtual@ ( n seq -- n' seq' )
- seqs>> [ length /mod ] [ nth ] bi ;
-
-M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ;
-
-INSTANCE: merged virtual-sequence
+++ /dev/null
-A virtual sequence which merges (interleaves) other sequences.
+++ /dev/null
-collections
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax quotations sequences ;
-IN: sequences.product
-
-HELP: product-sequence
-{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
-{ $examples
-{ $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-""" """{
- { 1 "a" }
- { 2 "a" }
- { 3 "a" }
- { 1 "b" }
- { 2 "b" }
- { 3 "b" }
- { 1 "c" }
- { 2 "c" }
- { 3 "c" }
-}""" } } ;
-
-HELP: <product-sequence>
-{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
-{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
-{ $examples
-{ $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
-"""{
- { 1 "a" }
- { 2 "a" }
- { 3 "a" }
- { 1 "b" }
- { 2 "b" }
- { 3 "b" }
- { 1 "c" }
- { 2 "c" }
- { 3 "c" }
-}""" } } ;
-
-{ product-sequence <product-sequence> } related-words
-
-HELP: product-map
-{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
-{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
-{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
-
-HELP: product-each
-{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
-{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
-{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
-
-{ product-map product-each } related-words
-
-ARTICLE: "sequences.product" "Product sequences"
-"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
-{ $subsections
- product-sequence
- <product-sequence>
- product-map
- product-each
-} ;
-
-ABOUT: "sequences.product"
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: arrays kernel make sequences sequences.product tools.test ;
-IN: sequences.product.tests
-
-
-[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
-[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
-
-: x ( n s -- sss ) <repetition> concat ;
-
-[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
-[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
-
-[
- {
- { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
- { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
- }
-] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
-
-[ "a1b1c1a2b2c2" ] [
- [
- { { "a" "b" "c" } { "1" "2" } }
- [ [ % ] each ] product-each
- ] "" make
-] unit-test
-
-[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
-[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors arrays kernel locals math sequences ;
-IN: sequences.product
-
-TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
-
-: <product-sequence> ( sequences -- product-sequence )
- >array dup [ length ] map product-sequence boa ;
-
-INSTANCE: product-sequence sequence
-
-M: product-sequence length lengths>> product ;
-
-<PRIVATE
-
-: ns ( n lengths -- ns )
- [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
-
-: nths ( ns seqs -- nths )
- [ nth ] { } 2map-as ;
-
-: product@ ( n product-sequence -- ns seqs )
- [ lengths>> ns ] [ nip sequences>> ] 2bi ;
-
-:: (carry-n) ( ns lengths i -- )
- ns length i 1 + = [
- i ns nth i lengths nth = [
- 0 i ns set-nth
- i 1 + ns [ 1 + ] change-nth
- ns lengths i 1 + (carry-n)
- ] when
- ] unless ;
-
-: carry-ns ( ns lengths -- )
- 0 (carry-n) ;
-
-: product-iter ( ns lengths -- )
- [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
-
-: start-product-iter ( sequences -- ns lengths )
- [ [ drop 0 ] map ] [ [ length ] map ] bi ;
-
-: end-product-iter? ( ns lengths -- ? )
- [ 1 tail* first ] bi@ = ;
-
-PRIVATE>
-
-M: product-sequence nth
- product@ nths ;
-
-:: product-each ( sequences quot -- )
- sequences start-product-iter :> ( ns lengths )
- lengths [ 0 = ] any? [
- [ ns lengths end-product-iter? ]
- [ ns sequences nths quot call ns lengths product-iter ] until
- ] unless ; inline
-
-:: product-map ( sequences quot -- sequence )
- 0 :> i!
- sequences [ length ] [ * ] map-reduce sequences
- [| result |
- sequences [ quot call i result set-nth i 1 + i! ] product-each
- result
- ] new-like ; inline
-
+++ /dev/null
-Cartesian products of sequences
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_)) {}
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;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
+ code->points_to_aging.clear();
}
}
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) {}
{
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_);
};
}
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;
+ }
};
}
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;
/* 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))
{
new_alien->displacement = displacement;
new_alien->expired = false_object;
+ new_alien->update_address();
return new_alien.value();
}
/* 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());
/* 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>();
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:
/* 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();
}
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();
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());
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);
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()))
{
#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;
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) {}
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);
}
--- /dev/null
+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));
+}
+
+}
--- /dev/null
+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;
+ }
+};
+
+}
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;
}
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()
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;
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) { }
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;
+}
+
}
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));
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);
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();
}
{
switch(frame_type(frame))
{
- case QUOTATION_TYPE:
+ case code_block_unoptimized:
{
cell quot = frame_executing(frame);
if(to_boolean(quot))
else
return false_object;
}
- case WORD_TYPE:
+ case code_block_optimized:
return false_object;
default:
critical_error("Bad frame type",frame_type(frame));
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());
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);
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);
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)
}
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);
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:
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);
}
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
{
}
};
-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);
}
/* 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
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();
--- /dev/null
+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);
+ }
+
+};
+
+}
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)
{
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)
/* 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);
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);
}
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());
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())
{
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
- WORD_TYPE,
+ code_block_optimized,
code,
labels,
owner,
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 */
-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()
+code_heap_room factor_vm::code_room()
{
- 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_) {}
+ code_heap_room room;
- void operator()(callback *stub)
- {
- stub->compiled = code->forward_code_block(stub->compiled);
- callbacks->update(stub);
- }
-};
+ 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();
-void factor_vm::forward_callback_xts()
-{
- callback_forwarder forwarder(code,callbacks);
- callbacks->iterate(forwarder);
+ return room;
}
-/* 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)
+void factor_vm::primitive_code_room()
{
- 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;
}
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;
/* 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;
};
}
--- /dev/null
+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();
+ }
+};
+
+}
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_) {}
return untagged;
}
- void trace_handle(cell *handle)
+ object *promote_object(object *untagged)
{
- cell pointer = *handle;
+ cell size = untagged->size();
+ object *newpointer = target->allot(size);
+ /* XXX not exception-safe */
+ if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
- if(immediate_p(pointer)) return;
+ memcpy(newpointer,untagged,size);
+ untagged->h.forward_to(newpointer);
- object *untagged = parent->untag<object>(pointer);
- if(!policy.should_copy_p(untagged))
- return;
+ policy.promoted_object(newpointer);
- object *forwarding = resolve_forwarding(untagged);
+ return newpointer;
+ }
+
+ object *operator()(object *obj)
+ {
+ if(!policy.should_copy_p(obj))
+ {
+ policy.visited_object(obj);
+ return obj;
+ }
+
+ object *forwarding = resolve_forwarding(obj);
- if(forwarding == untagged)
- untagged = promote_object(untagged);
+ if(forwarding == obj)
+ return promote_object(obj);
else if(policy.should_copy_p(forwarding))
- untagged = promote_object(forwarding);
+ return promote_object(forwarding);
else
- untagged = forwarding;
+ {
+ 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; }
+};
- *handle = RETAG(untagged,TAG(pointer));
+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_slots(object *ptr)
+ void trace_object(object *ptr)
{
- cell *slot = (cell *)ptr;
- cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr));
+ workhorse.visit_slots(ptr);
+ if(ptr->h.hi_tag() == ALIEN_TYPE)
+ ((alien *)ptr)->update_address();
+ }
- if(slot != end)
- {
- slot++;
- for(; slot < end; slot++) trace_handle(slot);
- }
+ void trace_roots()
+ {
+ workhorse.visit_roots();
}
- object *promote_object(object *untagged)
+ void trace_contexts()
{
- cell size = parent->untagged_object_size(untagged);
- object *newpointer = target->allot(size);
- /* XXX not exception-safe */
- if(!newpointer) longjmp(current_gc->gc_unwind,1);
+ workhorse.visit_contexts();
+ }
- memcpy(newpointer,untagged,size);
- untagged->h.forward_to(newpointer);
+ /* 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);
+ }
- stats->object_count++;
- stats->bytes_copied += size;
+ 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();
- return newpointer;
+ for(; iter != end; iter++)
+ {
+ trace_literal_references(*iter);
+ code_blocks_scanned++;
+ }
}
- void trace_stack_elements(segment *region, cell *top)
+ inline cell first_card_in_deck(cell deck)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- trace_handle(ptr);
+ return deck << (deck_bits - card_bits);
}
- void trace_registered_locals()
+ inline cell last_card_in_deck(cell deck)
{
- 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));
+ return first_card_in_deck(deck + 1);
}
- void trace_registered_bignums()
+ inline cell card_deck_for_address(cell a)
{
- std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
- std::vector<cell>::const_iterator end = parent->gc_bignums.end();
+ return addr_to_deck(a - data->start);
+ }
- for(; iter < end; iter++)
- {
- cell *handle = (cell *)(*iter);
+ inline cell card_start_address(cell card)
+ {
+ return (card << card_bits) + data->start;
+ }
- if(*handle)
- {
- *handle |= BIGNUM_TYPE;
- trace_handle(handle);
- *handle &= ~BIGNUM_TYPE;
- }
- }
+ inline cell card_end_address(cell card)
+ {
+ return ((card + 1) << card_bits) + data->start;
}
- /* 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()
+ void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
{
- trace_handle(&parent->true_object);
- trace_handle(&parent->bignum_zero);
- trace_handle(&parent->bignum_pos_one);
- trace_handle(&parent->bignum_neg_one);
+ if(card_start < end)
+ {
+ start += sizeof(cell);
+
+ if(start < card_start) start = card_start;
+ if(end > card_end) end = card_end;
- trace_registered_locals();
- trace_registered_bignums();
+ cell *slot_ptr = (cell *)start;
+ cell *end_ptr = (cell *)end;
- for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]);
+ if(slot_ptr != end_ptr)
+ {
+ for(; slot_ptr < end_ptr; slot_ptr++)
+ workhorse.visit_handle(slot_ptr);
+ }
+ }
}
- void trace_contexts()
+ template<typename SourceGeneration, typename Unmarker>
+ void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
{
- context *ctx = parent->ctx;
+ card_deck *decks = data->decks;
+ card_deck *cards = data->cards;
+
+ cell gen_start_card = addr_to_card(gen->start - data->start);
- while(ctx)
+ 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++)
{
- trace_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
- trace_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+ if(decks[deck_index] & mask)
+ {
+ decks_scanned++;
- trace_handle(&ctx->catchstack_save);
- trace_handle(&ctx->current_callback_save);
+ 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++;
- ctx = ctx->next;
+ 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]);
+ }
}
}
};
--- /dev/null
+#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();
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+}
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;
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;
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;
/* 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;
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);
}
}
};
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 */
#define PUSH_NONVOLATILE \
push %ebx ; \
- push %ebp ; \
push %ebp
#define POP_NONVOLATILE \
- pop %ebp ; \
pop %ebp ; \
pop %ebx
push %rdi ; \
push %rsi ; \
push %rbx ; \
- push %rbp ; \
push %rbp
#define POP_NONVOLATILE \
- pop %rbp ; \
pop %rbp ; \
pop %rbx ; \
pop %rsi ; \
push %rbx ; \
push %rbp ; \
push %r12 ; \
- push %r13 ; \
push %r13
#define POP_NONVOLATILE \
- pop %r13 ; \
pop %r13 ; \
pop %r12 ; \
pop %rbp ; \
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
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
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
/* Tear down register shadow area */
add $32,STACK_REG
+ /* Undo stack alignment */
+ mov (STACK_REG),STACK_REG
+
POP_NONVOLATILE
ret
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);
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);
}
delete aging;
delete aging_semispace;
delete tenured;
- delete tenured_semispace;
delete[] cards;
delete[] decks;
}
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 */
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:
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_data_room()
+void factor_vm::primitive_size()
{
- 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));
+ box_unsigned_cell(object_size(dpop()));
+}
- a.add(tag_fixnum((data->tenured->end - data->tenured->here) >> 10));
- a.add(tag_fixnum((data->tenured->size) >> 10));
+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;
+}
- a.trim();
- dpush(a.elements.value());
+void factor_vm::primitive_data_room()
+{
+ 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;
}
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 */
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()
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;
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;
};
}
--- /dev/null
+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)
+
+}
namespace factor
{
-void factor_vm::print_chars(string* str)
+std::ostream &operator<<(std::ostream &out, const string *str)
{
- cell i;
- for(i = 0; i < string_capacity(str); i++)
- putchar(string_nth(str,i));
+ for(cell i = 0; i < string_capacity(str); i++)
+ out << (char)str->nth(i);
+ return out;
}
void factor_vm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
- {
- print_chars(untag<string>(word->vocabulary));
- print_string(":");
- }
+ std::cout << untag<string>(word->vocabulary) << ":";
if(tagged<object>(word->name).type_p(STRING_TYPE))
- print_chars(untag<string>(word->name));
+ std::cout << untag<string>(word->name);
else
{
- print_string("#<not a string: ");
+ std::cout << "#<not a string: ";
print_nested_obj(word->name,nesting);
- print_string(">");
+ std::cout << ">";
}
}
-void factor_vm::print_factor_string(string* str)
+void factor_vm::print_factor_string(string *str)
{
- putchar('"');
- print_chars(str);
- putchar('"');
+ std::cout << '"' << str << '"';
}
void factor_vm::print_array(array* array, cell nesting)
for(i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_tuple(tuple *tuple, cell nesting)
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
- print_string(" ");
+ std::cout << " ";
print_nested_obj(layout->klass,nesting);
- cell i;
bool trimmed;
-
if(length > 10 && !full_output)
{
trimmed = true;
else
trimmed = false;
- for(i = 0; i < length; i++)
+ for(cell i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(tuple->data()[i],nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
- print_string(" ... ");
+ std::cout << " ... ";
return;
}
switch(tagged<object>(obj).type())
{
case FIXNUM_TYPE:
- print_fixnum(untag_fixnum(obj));
+ std::cout << untag_fixnum(obj);
break;
case WORD_TYPE:
print_word(untag<word>(obj),nesting - 1);
print_factor_string(untag<string>(obj));
break;
case F_TYPE:
- print_string("f");
+ std::cout << "f";
break;
case TUPLE_TYPE:
- print_string("T{");
+ std::cout << "T{";
print_tuple(untag<tuple>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case ARRAY_TYPE:
- print_string("{");
+ std::cout << "{";
print_array(untag<array>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case QUOTATION_TYPE:
- print_string("[");
+ std::cout << "[";
quot = untag<quotation>(obj);
print_array(untag<array>(quot->array),nesting - 1);
- print_string(" ]");
+ std::cout << " ]";
break;
default:
- print_string("#<type ");
- print_cell(tagged<object>(obj).type());
- print_string(" @ ");
- print_cell_hex(obj);
- print_string(">");
+ std::cout << "#<type " << tagged<object>(obj).type() << " @ ";
+ std::cout << std::hex << obj << std::dec << ">";
break;
}
}
for(; start <= end; start++)
{
print_obj(*start);
- nl();
+ std::cout << std::endl;
}
}
void factor_vm::print_datastack()
{
- print_string("==== DATA STACK:\n");
+ std::cout << "==== DATA STACK:\n";
print_objects((cell *)ds_bot,(cell *)ds);
}
void factor_vm::print_retainstack()
{
- print_string("==== RETAIN STACK:\n");
+ std::cout << "==== RETAIN STACK:\n";
print_objects((cell *)rs_bot,(cell *)rs);
}
void operator()(stack_frame *frame)
{
parent->print_obj(parent->frame_executing(frame));
- print_string("\n");
+ std::cout << std::endl;
parent->print_obj(parent->frame_scan(frame));
- print_string("\n");
- print_string("word/quot addr: ");
- print_cell_hex((cell)parent->frame_executing(frame));
- print_string("\n");
- print_string("word/quot xt: ");
- print_cell_hex((cell)frame->xt);
- print_string("\n");
- print_string("return address: ");
- print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,parent));
- print_string("\n");
+ std::cout << std::endl;
+ std::cout << "word/quot addr: ";
+ std::cout << std::hex << (cell)parent->frame_executing(frame) << std::dec;
+ std::cout << std::endl;
+ std::cout << "word/quot xt: ";
+ std::cout << std::hex << (cell)frame->xt << std::dec;
+ std::cout << std::endl;
+ std::cout << "return address: ";
+ std::cout << std::hex << (cell)FRAME_RETURN_ADDRESS(frame,parent) << std::dec;
+ std::cout << std::endl;
}
};
void factor_vm::print_callstack()
{
- print_string("==== CALL STACK:\n");
+ std::cout << "==== CALL STACK:\n";
stack_frame_printer printer(this);
iterate_callstack(ctx,printer);
}
+struct padded_address {
+ cell value;
+
+ explicit padded_address(cell value_) : value(value_) {}
+};
+
+std::ostream &operator<<(std::ostream &out, const padded_address &value)
+{
+ char prev = out.fill('0');
+ out.width(sizeof(cell) * 2);
+ out << std::hex << value.value << std::dec;
+ out.fill(prev);
+ return out;
+}
+
void factor_vm::dump_cell(cell x)
{
- print_cell_hex_pad(x); print_string(": ");
+ std::cout << padded_address(x) << ": ";
x = *(cell *)x;
- print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x));
- nl();
+ std::cout << padded_address(x) << " tag " << TAG(x) << std::endl;
}
void factor_vm::dump_memory(cell from, cell to)
dump_cell(from);
}
-void factor_vm::dump_zone(const char *name, zone *z)
+template<typename Generation>
+void factor_vm::dump_generation(const char *name, Generation *gen)
{
- print_string(name); print_string(": ");
- print_string("Start="); print_cell(z->start);
- print_string(", size="); print_cell(z->size);
- print_string(", here="); print_cell(z->here - z->start); nl();
+ std::cout << name << ": ";
+ std::cout << "Start=" << gen->start;
+ std::cout << ", size=" << gen->size;
+ std::cout << ", end=" << gen->end;
+ std::cout << std::endl;
}
void factor_vm::dump_generations()
{
- dump_zone("Nursery",&nursery);
- dump_zone("Aging",data->aging);
- dump_zone("Tenured",data->tenured);
-
- print_string("Cards: base=");
- print_cell((cell)data->cards);
- print_string(", size=");
- print_cell((cell)(data->cards_end - data->cards));
- nl();
+ dump_generation("Nursery",&nursery);
+ dump_generation("Aging",data->aging);
+ dump_generation("Tenured",data->tenured);
+
+ std::cout << "Cards:";
+ std::cout << "base=" << (cell)data->cards << ", ";
+ std::cout << "size=" << (cell)(data->cards_end - data->cards) << std::endl;
}
-void factor_vm::dump_objects(cell type)
-{
- primitive_full_gc();
- begin_scan();
+struct object_dumper {
+ factor_vm *parent;
+ cell type;
+
+ explicit object_dumper(factor_vm *parent_, cell type_) :
+ parent(parent_), type(type_) {}
- cell obj;
- while(to_boolean(obj = next_object()))
+ void operator()(cell obj)
{
if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
{
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
+ std::cout << padded_address(obj) << " ";
+ parent->print_nested_obj(obj,2);
+ std::cout << std::endl;
}
}
+};
- end_scan();
+void factor_vm::dump_objects(cell type)
+{
+ primitive_full_gc();
+ object_dumper dumper(this,type);
+ each_object(dumper);
}
-struct data_references_finder {
+struct data_reference_slot_visitor {
cell look_for, obj;
factor_vm *parent;
- explicit data_references_finder(cell look_for_, cell obj_, factor_vm *parent_)
- : look_for(look_for_), obj(obj_), parent(parent_) { }
+ explicit data_reference_slot_visitor(cell look_for_, cell obj_, factor_vm *parent_) :
+ look_for(look_for_), obj(obj_), parent(parent_) { }
void operator()(cell *scan)
{
if(look_for == *scan)
{
- print_cell_hex_pad(obj);
- print_string(" ");
+ std::cout << padded_address(obj) << " ";
parent->print_nested_obj(obj,2);
- nl();
+ std::cout << std::endl;
}
}
};
-void factor_vm::find_data_references(cell look_for)
-{
- begin_scan();
+struct data_reference_object_visitor {
+ cell look_for;
+ factor_vm *parent;
- cell obj;
+ explicit data_reference_object_visitor(cell look_for_, factor_vm *parent_) :
+ look_for(look_for_), parent(parent_) {}
- while(to_boolean(obj = next_object()))
+ void operator()(cell obj)
{
- data_references_finder finder(look_for,obj,this);
- do_slots(UNTAG(obj),finder);
+ data_reference_slot_visitor visitor(look_for,obj,parent);
+ parent->do_slots(UNTAG(obj),visitor);
}
+};
- end_scan();
+void factor_vm::find_data_references(cell look_for)
+{
+ data_reference_object_visitor visitor(look_for,this);
+ each_object(visitor);
}
-/* Dump all code blocks for debugging */
-void factor_vm::dump_code_heap()
-{
- cell reloc_size = 0, literal_size = 0;
+struct code_block_printer {
+ factor_vm *parent;
+ cell reloc_size, literal_size;
- heap_block *scan = code->first_block();
+ explicit code_block_printer(factor_vm *parent_) :
+ parent(parent_), reloc_size(0), literal_size(0) {}
- while(scan)
+ void operator()(code_block *scan, cell size)
{
const char *status;
- if(scan->type() == FREE_BLOCK_TYPE)
+ if(scan->free_p())
status = "free";
- else if(code->state->is_marked_p(scan))
+ else if(parent->code->marked_p(scan))
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "marked";
}
else
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "allocated";
}
- print_cell_hex((cell)scan); print_string(" ");
- print_cell_hex(scan->size()); print_string(" ");
- print_string(status); print_string("\n");
-
- scan = code->next_block(scan);
+ std::cout << std::hex << (cell)scan << std::dec << " ";
+ std::cout << std::hex << size << std::dec << " ";
+ std::cout << status << std::endl;
}
-
- print_cell(reloc_size); print_string(" bytes of relocation data\n");
- print_cell(literal_size); print_string(" bytes of literal data\n");
+};
+
+/* Dump all code blocks for debugging */
+void factor_vm::dump_code_heap()
+{
+ code_block_printer printer(this);
+ code->allocator->iterate(printer);
+ std::cout << printer.reloc_size << " bytes of relocation data\n";
+ std::cout << printer.literal_size << " bytes of literal data\n";
}
void factor_vm::factorbug()
{
if(fep_disabled)
{
- print_string("Low level debugger disabled\n");
+ std::cout << "Low level debugger disabled\n";
exit(1);
}
/* open_console(); */
- print_string("Starting low level debugger...\n");
- print_string(" Basic commands:\n");
- print_string("q -- continue executing Factor - NOT SAFE\n");
- print_string("im -- save image to fep.image\n");
- print_string("x -- exit Factor\n");
- print_string(" Advanced commands:\n");
- print_string("d <addr> <count> -- dump memory\n");
- print_string("u <addr> -- dump object at tagged <addr>\n");
- print_string(". <addr> -- print object at tagged <addr>\n");
- print_string("t -- toggle output trimming\n");
- print_string("s r -- dump data, retain stacks\n");
- print_string(".s .r .c -- print data, retain, call stacks\n");
- print_string("e -- dump environment\n");
- print_string("g -- dump generations\n");
- print_string("data -- data heap dump\n");
- print_string("words -- words dump\n");
- print_string("tuples -- tuples dump\n");
- print_string("refs <addr> -- find data heap references to object\n");
- print_string("push <addr> -- push object on data stack - NOT SAFE\n");
- print_string("code -- code heap dump\n");
+ std::cout << "Starting low level debugger...\n";
+ std::cout << " Basic commands:\n";
+ std::cout << "q -- continue executing Factor - NOT SAFE\n";
+ std::cout << "im -- save image to fep.image\n";
+ std::cout << "x -- exit Factor\n";
+ std::cout << " Advanced commands:\n";
+ std::cout << "d <addr> <count> -- dump memory\n";
+ std::cout << "u <addr> -- dump object at tagged <addr>\n";
+ std::cout << ". <addr> -- print object at tagged <addr>\n";
+ std::cout << "t -- toggle output trimming\n";
+ std::cout << "s r -- dump data, retain stacks\n";
+ std::cout << ".s .r .c -- print data, retain, call stacks\n";
+ std::cout << "e -- dump environment\n";
+ std::cout << "g -- dump generations\n";
+ std::cout << "data -- data heap dump\n";
+ std::cout << "words -- words dump\n";
+ std::cout << "tuples -- tuples dump\n";
+ std::cout << "refs <addr> -- find data heap references to object\n";
+ std::cout << "push <addr> -- push object on data stack - NOT SAFE\n";
+ std::cout << "code -- code heap dump\n";
bool seen_command = false;
{
char cmd[1024];
- print_string("READY\n");
+ std::cout << "READY\n";
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
{
cell addr = read_cell_hex();
print_obj(addr);
- print_string("\n");
+ std::cout << std::endl;
}
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
print_callstack();
else if(strcmp(cmd,"e") == 0)
{
- int i;
- for(i = 0; i < USER_ENV; i++)
- dump_cell((cell)&userenv[i]);
+ for(cell i = 0; i < special_object_count; i++)
+ dump_cell((cell)&special_objects[i]);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
else if(strcmp(cmd,"refs") == 0)
{
cell addr = read_cell_hex();
- print_string("Data heap references:\n");
+ std::cout << "Data heap references:\n";
find_data_references(addr);
- nl();
+ std::cout << std::endl;
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"code") == 0)
dump_code_heap();
else
- print_string("unknown command\n");
+ std::cout << "unknown command\n";
}
}
void factor_vm::primitive_die()
{
- print_string("The die word was called by the library. Unless you called it yourself,\n");
- print_string("you have triggered a bug in Factor. Please report.\n");
+ std::cout << "The die word was called by the library. Unless you called it yourself,\n";
+ std::cout << "you have triggered a bug in Factor. Please report.\n";
factorbug();
}
return false_object;
}
-cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
-{
- array *hi_tag_methods = untag<array>(methods);
- cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
-#ifdef FACTOR_DEBUG
- assert(tag < TYPE_COUNT - HEADER_TYPE);
-#endif
- return array_nth(hi_tag_methods,tag);
-}
-
cell factor_vm::lookup_method(cell obj, cell methods)
{
cell tag = TAG(obj);
else
return method;
}
- else if(tag == OBJECT_TYPE)
- {
- if(TAG(method) == ARRAY_TYPE)
- return lookup_hi_tag_method(obj,method);
- else
- return method;
- }
else
return method;
}
cell factor_vm::object_class(cell obj)
{
- switch(TAG(obj))
- {
- case TUPLE_TYPE:
+ cell tag = TAG(obj);
+ if(tag == TUPLE_TYPE)
return untag<tuple>(obj)->layout;
- case OBJECT_TYPE:
- return untag<object>(obj)->h.value;
- default:
- return tag_fixnum(TAG(obj));
- }
+ else
+ return tag_fixnum(tag);
}
cell factor_vm::method_cache_hashcode(cell klass, array *array)
void factor_vm::primitive_mega_cache_miss()
{
- megamorphic_cache_misses++;
+ dispatch_stats.megamorphic_cache_misses++;
cell cache = dpop();
fixnum index = untag_fixnum(dpop());
void factor_vm::primitive_reset_dispatch_stats()
{
- megamorphic_cache_hits = megamorphic_cache_misses = 0;
+ memset(&dispatch_stats,0,sizeof(dispatch_statistics));
}
void factor_vm::primitive_dispatch_stats()
{
- growable_array stats(this);
- stats.add(allot_cell(megamorphic_cache_hits));
- stats.add(allot_cell(megamorphic_cache_misses));
- stats.trim();
- dpush(stats.elements.value());
+ dpush(tag<byte_array>(byte_array_from_value(&dispatch_stats)));
}
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
-
gc_root<array> methods(methods_,parent);
-
gc_root<array> cache(cache_,parent);
+
data_root<array> methods(methods_,parent);
+
data_root<array> cache(cache_,parent);
/* Generate machine code to determine the object's class. */
- emit_class_lookup(index,PIC_HI_TAG_TUPLE);
+ emit_class_lookup(index,PIC_TUPLE);
/* Do a cache lookup. */
- emit_with(parent->userenv[MEGA_LOOKUP],cache.value());
+ emit_with(parent->special_objects[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(parent->userenv[MEGA_MISS_WORD]);
+ word_call(parent->special_objects[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
+struct dispatch_statistics {
+ cell 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;
+};
+
}
void fatal_error(const char *msg, cell tagged)
{
- print_string("fatal_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "fatal_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
exit(1);
}
void critical_error(const char *msg, cell tagged)
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("critical_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "critical_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
tls_vm()->factorbug();
}
void out_of_memory()
{
- print_string("Out of memory\n\n");
+ std::cout << "Out of memory\n\n";
tls_vm()->dump_generations();
exit(1);
}
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
- if(!current_gc && to_boolean(userenv[BREAK_ENV]))
+ if(!current_gc && to_boolean(special_objects[OBJ_BREAK]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* Reset local roots */
- gc_locals.clear();
- gc_bignums.clear();
+ data_roots.clear();
+ bignum_roots.clear();
+ code_roots.clear();
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
else
callstack_top = ctx->callstack_top;
- throw_impl(userenv[BREAK_ENV],callstack_top,this);
+ throw_impl(special_objects[OBJ_BREAK],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("early_error: ");
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "early_error: ";
print_obj(error);
- nl();
+ std::cout << std::endl;
factorbug();
}
}
void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
- throw_error(allot_array_4(userenv[ERROR_ENV],
+ throw_error(allot_array_4(special_objects[OBJ_ERROR],
tag_fixnum(error),arg1,arg2),callstack_top);
}
{
factor_vm *vm;
-unordered_map<THREADHANDLE, factor_vm*> thread_vms;
+std::map<THREADHANDLE, factor_vm*> thread_vms;
void init_globals()
{
{
p->image_path = NULL;
- /* We make a wild guess here that if we're running on ARM, we don't
- have a lot of memory. */
-#ifdef FACTOR_ARM
- p->ds_size = 8 * sizeof(cell);
- p->rs_size = 8 * sizeof(cell);
-
- p->code_size = 4;
- p->young_size = 1;
- p->aging_size = 1;
- p->tenured_size = 6;
-#else
p->ds_size = 32 * sizeof(cell);
p->rs_size = 32 * sizeof(cell);
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
- p->tenured_size = 4 * sizeof(cell);
-#endif
+ p->tenured_size = 24 * sizeof(cell);
p->max_pic_size = 3;
- p->secure_gc = false;
p->fep = false;
p->signals = true;
else if(factor_arg(arg,STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(factor_arg(arg,STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(factor_arg(arg,STRING_LITERAL("-callbacks=%d"),&p->callback_size));
- else if(STRCMP(arg,STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(arg,STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRCMP(arg,STRING_LITERAL("-nosignals")) == 0) p->signals = false;
else if(STRNCMP(arg,STRING_LITERAL("-i="),3) == 0) p->image_path = arg + 3;
/* Do some initialization that we do once only */
void factor_vm::do_stage1_init()
{
- print_string("*** Stage 2 early init... ");
+ std::cout << "*** Stage 2 early init... ";
fflush(stdout);
compile_all_words();
- userenv[STAGE2_ENV] = true_object;
+ special_objects[OBJ_STAGE2] = true_object;
- print_string("done\n");
- fflush(stdout);
+ std::cout << "done\n";
}
void factor_vm::init_factor(vm_parameters *p)
init_profiler();
- userenv[CPU_ENV] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
- userenv[OS_ENV] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
- userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path);
- userenv[ARGS_ENV] = false_object;
- userenv[EMBEDDED_ENV] = false_object;
+ special_objects[OBJ_CPU] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
+ special_objects[OBJ_OS] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
+ special_objects[OBJ_CELL_SIZE] = tag_fixnum(sizeof(cell));
+ special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
+ special_objects[OBJ_ARGS] = false_object;
+ special_objects[OBJ_EMBEDDED] = false_object;
/* We can GC now */
gc_off = false;
- if(!to_boolean(userenv[STAGE2_ENV]))
+ if(!to_boolean(special_objects[OBJ_STAGE2]))
do_stage1_init();
}
}
args.trim();
- userenv[ARGS_ENV] = args.elements.value();
+ special_objects[OBJ_ARGS] = args.elements.value();
}
void factor_vm::start_factor(vm_parameters *p)
if(p->fep) factorbug();
nest_stacks(NULL);
- c_to_factor_toplevel(userenv[BOOT_ENV]);
+ c_to_factor_toplevel(special_objects[OBJ_BOOT]);
unnest_stacks();
}
char *factor_vm::factor_eval_string(char *string)
{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
return callback(string);
}
void factor_vm::factor_yield()
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
callback();
}
void factor_vm::factor_sleep(long us)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
callback(us);
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void free_list::clear_free_list()
+{
+ for(cell i = 0; i < free_list_count; i++)
+ small_blocks[i].clear();
+ large_blocks.clear();
+ free_block_count = 0;
+ free_space = 0;
+}
+
+void free_list::initial_free_list(cell start, cell end, cell occupied)
+{
+ clear_free_list();
+ if(occupied != end - start)
+ {
+ free_heap_block *last_block = (free_heap_block *)(start + occupied);
+ last_block->make_free(end - (cell)last_block);
+ add_to_free_list(last_block);
+ }
+}
+
+void free_list::add_to_free_list(free_heap_block *block)
+{
+ cell size = block->size();
+
+ free_block_count++;
+ free_space += size;
+
+ if(size < free_list_count * block_granularity)
+ small_blocks[size / block_granularity].push_back(block);
+ else
+ large_blocks.insert(block);
+}
+
+free_heap_block *free_list::find_free_block(cell size)
+{
+ /* Check small free lists */
+ for(cell i = size / block_granularity; i < free_list_count; i++)
+ {
+ std::vector<free_heap_block *> &blocks = small_blocks[i];
+ if(blocks.size())
+ {
+ free_heap_block *block = blocks.back();
+ blocks.pop_back();
+
+ free_block_count--;
+ free_space -= block->size();
+
+ return block;
+ }
+ }
+
+ /* Check large free lists */
+ free_heap_block key;
+ key.make_free(size);
+ large_block_set::iterator iter = large_blocks.lower_bound(&key);
+ large_block_set::iterator end = large_blocks.end();
+
+ if(iter != end)
+ {
+ free_heap_block *block = *iter;
+ large_blocks.erase(iter);
+
+ free_block_count--;
+ free_space -= block->size();
+
+ return block;
+ }
+
+ return NULL;
+}
+
+free_heap_block *free_list::split_free_block(free_heap_block *block, cell size)
+{
+ if(block->size() != size)
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->make_free(block->size() - size);
+ block->make_free(size);
+ add_to_free_list(split);
+ }
+
+ return block;
+}
+
+bool free_list::can_allot_p(cell size)
+{
+ /* Check small free lists */
+ for(cell i = size / block_granularity; i < free_list_count; i++)
+ {
+ if(small_blocks[i].size()) return true;
+ }
+
+ /* Check large free lists */
+ large_block_set::const_iterator iter = large_blocks.begin();
+ large_block_set::const_iterator end = large_blocks.end();
+
+ for(; iter != end; iter++)
+ {
+ if((*iter)->size() >= size) return true;
+ }
+
+ return false;
+}
+
+cell free_list::largest_free_block()
+{
+ if(large_blocks.size())
+ {
+ large_block_set::reverse_iterator last = large_blocks.rbegin();
+ return (*last)->size();
+ }
+ else
+ {
+ for(int i = free_list_count - 1; i >= 0; i--)
+ {
+ if(small_blocks[i].size())
+ return small_blocks[i].back()->size();
+ }
+
+ return 0;
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell free_list_count = 32;
+
+struct free_heap_block
+{
+ cell header;
+
+ bool free_p() const
+ {
+ return header & 1 == 1;
+ }
+
+ cell size() const
+ {
+ return header >> 3;
+ }
+
+ void make_free(cell size)
+ {
+ header = (size << 3) | 1;
+ }
+};
+
+struct block_size_compare {
+ bool operator()(free_heap_block *a, free_heap_block *b)
+ {
+ return a->size() < b->size();
+ }
+};
+
+typedef std::multiset<free_heap_block *, block_size_compare> large_block_set;
+
+struct free_list {
+ std::vector<free_heap_block *> small_blocks[free_list_count];
+ large_block_set large_blocks;
+ cell free_block_count;
+ cell free_space;
+
+ void clear_free_list();
+ void initial_free_list(cell start, cell end, cell occupied);
+ void add_to_free_list(free_heap_block *block);
+ free_heap_block *find_free_block(cell size);
+ free_heap_block *split_free_block(free_heap_block *block, cell size);
+ bool can_allot_p(cell size);
+ cell largest_free_block();
+};
+
+}
--- /dev/null
+namespace factor
+{
+
+template<typename Block> struct free_list_allocator {
+ cell size;
+ cell start;
+ cell end;
+ free_list free_blocks;
+ mark_bits<Block> state;
+
+ explicit free_list_allocator(cell size, cell start);
+ void initial_free_list(cell occupied);
+ bool contains_p(Block *block);
+ Block *first_block();
+ Block *last_block();
+ Block *next_block_after(Block *block);
+ Block *next_allocated_block_after(Block *block);
+ bool can_allot_p(cell size);
+ Block *allot(cell size);
+ void free(Block *block);
+ cell occupied_space();
+ cell free_space();
+ cell largest_free_block();
+ cell free_block_count();
+ void sweep();
+ template<typename Iterator> void sweep(Iterator &iter);
+ template<typename Iterator, typename Sizer> void compact(Iterator &iter, Sizer &sizer);
+ template<typename Iterator, typename Sizer> void iterate(Iterator &iter, Sizer &sizer);
+ template<typename Iterator> void iterate(Iterator &iter);
+};
+
+template<typename Block>
+free_list_allocator<Block>::free_list_allocator(cell size_, cell start_) :
+ size(size_),
+ start(start_),
+ end(start_ + size_),
+ state(mark_bits<Block>(size_,start_))
+{
+ initial_free_list(0);
+}
+
+template<typename Block> void free_list_allocator<Block>::initial_free_list(cell occupied)
+{
+ free_blocks.initial_free_list(start,end,occupied);
+}
+
+template<typename Block> bool free_list_allocator<Block>::contains_p(Block *block)
+{
+ return ((cell)block - start) < size;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::first_block()
+{
+ return (Block *)start;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::last_block()
+{
+ return (Block *)end;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::next_block_after(Block *block)
+{
+ return (Block *)((cell)block + block->size());
+}
+
+template<typename Block> Block *free_list_allocator<Block>::next_allocated_block_after(Block *block)
+{
+ while(block != this->last_block() && block->free_p())
+ {
+ free_heap_block *free_block = (free_heap_block *)block;
+ block = (object *)((cell)free_block + free_block->size());
+ }
+
+ if(block == this->last_block())
+ return NULL;
+ else
+ return block;
+}
+
+template<typename Block> bool free_list_allocator<Block>::can_allot_p(cell size)
+{
+ return free_blocks.can_allot_p(size);
+}
+
+template<typename Block> Block *free_list_allocator<Block>::allot(cell size)
+{
+ size = align(size,block_granularity);
+
+ free_heap_block *block = free_blocks.find_free_block(size);
+ if(block)
+ {
+ block = free_blocks.split_free_block(block,size);
+ return (Block *)block;
+ }
+ else
+ return NULL;
+}
+
+template<typename Block> void free_list_allocator<Block>::free(Block *block)
+{
+ free_heap_block *free_block = (free_heap_block *)block;
+ free_block->make_free(block->size());
+ free_blocks.add_to_free_list(free_block);
+}
+
+template<typename Block> cell free_list_allocator<Block>::free_space()
+{
+ return free_blocks.free_space;
+}
+
+template<typename Block> cell free_list_allocator<Block>::occupied_space()
+{
+ return size - free_blocks.free_space;
+}
+
+template<typename Block> cell free_list_allocator<Block>::largest_free_block()
+{
+ return free_blocks.largest_free_block();
+}
+
+template<typename Block> cell free_list_allocator<Block>::free_block_count()
+{
+ return free_blocks.free_block_count;
+}
+
+template<typename Block>
+void free_list_allocator<Block>::sweep()
+{
+ free_blocks.clear_free_list();
+
+ Block *start = this->first_block();
+ Block *end = this->last_block();
+
+ while(start != end)
+ {
+ /* find next unmarked block */
+ start = state.next_unmarked_block_after(start);
+
+ if(start != end)
+ {
+ /* find size */
+ cell size = state.unmarked_block_size(start);
+ assert(size > 0);
+
+ free_heap_block *free_block = (free_heap_block *)start;
+ free_block->make_free(size);
+ free_blocks.add_to_free_list(free_block);
+
+ start = (Block *)((char *)start + size);
+ }
+ }
+}
+
+template<typename Block>
+template<typename Iterator>
+void free_list_allocator<Block>::sweep(Iterator &iter)
+{
+ free_blocks.clear_free_list();
+
+ Block *prev = NULL;
+ Block *scan = this->first_block();
+ Block *end = this->last_block();
+
+ while(scan != end)
+ {
+ cell size = scan->size();
+
+ if(scan->free_p())
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ prev = scan;
+ }
+ else if(this->state.marked_p(scan))
+ {
+ if(prev && prev->free_p())
+ free_blocks.add_to_free_list((free_heap_block *)prev);
+ prev = scan;
+ iter(scan,size);
+ }
+ else
+ {
+ if(prev && prev->free_p())
+ {
+ free_heap_block *free_prev = (free_heap_block *)prev;
+ free_prev->make_free(free_prev->size() + size);
+ }
+ else
+ {
+ free_heap_block *free_block = (free_heap_block *)scan;
+ free_block->make_free(size);
+ prev = scan;
+ }
+ }
+
+ scan = (Block *)((cell)scan + size);
+ }
+
+ if(prev && prev->free_p())
+ free_blocks.add_to_free_list((free_heap_block *)prev);
+}
+
+template<typename Block, typename Iterator> struct heap_compactor {
+ mark_bits<Block> *state;
+ char *address;
+ Iterator &iter;
+
+ explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_) :
+ state(state_), address((char *)address_), iter(iter_) {}
+
+ void operator()(Block *block, cell size)
+ {
+ if(this->state->marked_p(block))
+ {
+ iter(block,(Block *)address,size);
+ address += size;
+ }
+ }
+};
+
+/* The forwarding map must be computed first by calling
+state.compute_forwarding(). */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::compact(Iterator &iter, Sizer &sizer)
+{
+ heap_compactor<Block,Iterator> compactor(&state,first_block(),iter);
+ iterate(compactor,sizer);
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ free_blocks.initial_free_list(start,end,(cell)compactor.address - start);
+}
+
+/* During compaction we have to be careful and measure object sizes differently */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::iterate(Iterator &iter, Sizer &sizer)
+{
+ Block *scan = first_block();
+ Block *end = last_block();
+
+ while(scan != end)
+ {
+ cell size = sizer(scan);
+ Block *next = (Block *)((cell)scan + size);
+ if(!scan->free_p()) iter(scan,size);
+ scan = next;
+ }
+}
+
+template<typename Block> struct standard_sizer {
+ cell operator()(Block *block)
+ {
+ return block->size();
+ }
+};
+
+template<typename Block>
+template<typename Iterator>
+void free_list_allocator<Block>::iterate(Iterator &iter)
+{
+ standard_sizer<Block> sizer;
+ iterate(iter,sizer);
+}
+
+}
{
full_collector::full_collector(factor_vm *parent_) :
- copying_collector<tenured_space,full_policy>(
+ collector<tenured_space,full_policy>(
parent_,
- &parent_->gc_stats.full_stats,
parent_->data->tenured,
full_policy(parent_)) {}
-struct stack_frame_marker {
- factor_vm *parent;
- full_collector *collector;
+/* After a sweep, invalidate any code heap roots which are not marked,
+so that if a block makes a tail call to a generic word, and the PIC
+compiler triggers a GC, and the caller block gets gets GCd as a result,
+the PIC code won't try to overwrite the call site */
+void factor_vm::update_code_roots_for_sweep()
+{
+ std::vector<code_root *>::const_iterator iter = code_roots.begin();
+ std::vector<code_root *>::const_iterator end = code_roots.end();
- explicit stack_frame_marker(full_collector *collector_) :
- parent(collector_->parent), collector(collector_) {}
+ mark_bits<code_block> *state = &code->allocator->state;
- void operator()(stack_frame *frame)
+ for(; iter < end; iter++)
{
- collector->mark_code_block(parent->frame_code(frame));
+ code_root *root = *iter;
+ code_block *block = (code_block *)(root->value & -block_granularity);
+ if(root->valid && !state->marked_p(block))
+ root->valid = false;
}
-};
-
-/* Mark code blocks executing in currently active stack frames. */
-void full_collector::mark_active_blocks()
-{
- stack_frame_marker marker(this);
- parent->iterate_active_frames(marker);
}
-void full_collector::mark_object_code_block(object *obj)
+/* After a compaction, invalidate any code heap roots which are not
+marked as above, and also slide the valid roots up so that call sites
+can be updated correctly. */
+void factor_vm::update_code_roots_for_compaction()
{
- switch(obj->h.hi_tag())
- {
- case WORD_TYPE:
- {
- word *w = (word *)obj;
- if(w->code)
- mark_code_block(w->code);
- if(w->profiling)
- mark_code_block(w->profiling);
- break;
- }
- case QUOTATION_TYPE:
- {
- quotation *q = (quotation *)obj;
- if(q->code)
- mark_code_block(q->code);
- break;
- }
- case CALLSTACK_TYPE:
- {
- callstack *stack = (callstack *)obj;
- stack_frame_marker marker(this);
- parent->iterate_callstack_object(stack,marker);
- break;
- }
- }
-}
+ std::vector<code_root *>::const_iterator iter = code_roots.begin();
+ std::vector<code_root *>::const_iterator end = code_roots.end();
-struct callback_tracer {
- full_collector *collector;
+ mark_bits<code_block> *state = &code->allocator->state;
- callback_tracer(full_collector *collector_) : collector(collector_) {}
-
- void operator()(callback *stub)
+ for(; iter < end; iter++)
{
- collector->mark_code_block(stub->compiled);
- }
-};
+ code_root *root = *iter;
+ code_block *block = (code_block *)(root->value & -block_granularity);
-void full_collector::trace_callbacks()
-{
- callback_tracer tracer(this);
- parent->callbacks->iterate(tracer);
-}
-
-/* Trace all literals referenced from a code block. Only for aging and nursery collections */
-void full_collector::trace_literal_references(code_block *compiled)
-{
- this->trace_handle(&compiled->owner);
- this->trace_handle(&compiled->literals);
- this->trace_handle(&compiled->relocation);
-}
-
-/* Mark all literals referenced from a word XT. Only for tenured
-collections */
-void full_collector::mark_code_block(code_block *compiled)
-{
- this->code->mark_block(compiled);
- trace_literal_references(compiled);
-}
+ /* Offset of return address within 16-byte allocation line */
+ cell offset = root->value - (cell)block;
-void full_collector::cheneys_algorithm()
-{
- while(scan && scan < target->here)
- {
- object *obj = (object *)scan;
- this->trace_slots(obj);
- this->mark_object_code_block(obj);
- scan = target->next_object_after(this->parent,scan);
+ if(root->valid && state->marked_p((code_block *)root->value))
+ {
+ block = state->forward_block(block);
+ root->value = (cell)block + offset;
+ }
+ else
+ root->valid = false;
}
}
-/* After growing the heap, we have to perform a full relocation to update
-references to card and deck arrays. */
-struct big_code_heap_updater {
- factor_vm *parent;
+struct code_block_marker {
+ code_heap *code;
+ full_collector *collector;
- big_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+ explicit code_block_marker(code_heap *code_, full_collector *collector_) :
+ code(code_), collector(collector_) {}
- void operator()(heap_block *block)
+ code_block *operator()(code_block *compiled)
{
- parent->relocate_code_block((code_block *)block);
- }
-};
-
-/* After a full GC that did not grow the heap, we have to update references
-to literals and other words. */
-struct small_code_heap_updater {
- factor_vm *parent;
-
- small_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+ if(!code->marked_p(compiled))
+ {
+ code->set_marked_p(compiled);
+ collector->trace_literal_references(compiled);
+ }
- void operator()(heap_block *block)
- {
- parent->update_code_block_for_full_gc((code_block *)block);
+ return compiled;
}
};
-void factor_vm::collect_full_impl(bool trace_contexts_p)
+void factor_vm::collect_mark_impl(bool trace_contexts_p)
{
full_collector collector(this);
- code->state->clear_mark_bits();
+ code->clear_mark_bits();
+ data->tenured->clear_mark_bits();
+ data->tenured->clear_mark_stack();
+
+ code_block_visitor<code_block_marker> code_marker(this,code_block_marker(code,&collector));
collector.trace_roots();
if(trace_contexts_p)
{
collector.trace_contexts();
- collector.mark_active_blocks();
- collector.trace_callbacks();
+ code_marker.visit_context_code_blocks();
+ code_marker.visit_callback_code_blocks();
}
- collector.cheneys_algorithm();
-
- reset_generation(data->aging);
- nursery.here = nursery.start;
-}
-
-void factor_vm::collect_growing_heap(cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
-{
- /* Grow the data heap and copy all live objects to the new heap. */
- data_heap *old = data;
- set_data_heap(data->grow(requested_bytes));
- collect_full_impl(trace_contexts_p);
- delete old;
+ std::vector<object *> *mark_stack = &data->tenured->mark_stack;
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
- else
+ while(!mark_stack->empty())
{
- big_code_heap_updater updater(this);
- code->free_unmarked(updater);
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ collector.trace_object(obj);
+ code_marker.visit_object_code_block(obj);
}
+ data->reset_generation(data->tenured);
+ data->reset_generation(data->aging);
+ data->reset_generation(&nursery);
code->clear_remembered_set();
}
-void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p)
+void factor_vm::collect_sweep_impl()
{
- /* Copy all live objects to the tenured semispace. */
- std::swap(data->tenured,data->tenured_semispace);
- reset_generation(data->tenured);
- collect_full_impl(trace_contexts_p);
+ current_gc->event->started_data_sweep();
+ data->tenured->sweep();
+ update_code_roots_for_sweep();
+ current_gc->event->ended_data_sweep();
+}
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
+void factor_vm::collect_full(bool trace_contexts_p)
+{
+ collect_mark_impl(trace_contexts_p);
+ collect_sweep_impl();
+ if(data->tenured->largest_free_block() <= data->nursery->size + data->aging->size)
+ collect_compact_impl(trace_contexts_p);
else
- {
- small_code_heap_updater updater(this);
- code->free_unmarked(updater);
- }
+ update_code_heap_words_and_literals();
+}
- code->clear_remembered_set();
+void factor_vm::collect_compact(bool trace_contexts_p)
+{
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_impl(trace_contexts_p);
+}
+
+void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p)
+{
+ /* Grow the data heap and copy all live objects to the new heap. */
+ data_heap *old = data;
+ set_data_heap(data->grow(requested_bytes));
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_code_impl(trace_contexts_p);
+ delete old;
}
}
struct full_policy {
factor_vm *parent;
- zone *tenured;
+ tenured_space *tenured;
- full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
+ explicit full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_and_push(obj);
+ }
+
+ void visited_object(object *obj)
+ {
+ if(!tenured->marked_p(obj))
+ tenured->mark_and_push(obj);
+ }
};
-struct full_collector : copying_collector<tenured_space,full_policy> {
+struct full_collector : collector<tenured_space,full_policy> {
bool trace_contexts_p;
- full_collector(factor_vm *parent_);
- void mark_active_blocks();
- void mark_object_code_block(object *object);
- void trace_callbacks();
- void trace_literal_references(code_block *compiled);
- void mark_code_block(code_block *compiled);
- void cheneys_algorithm();
+ explicit full_collector(factor_vm *parent_);
};
}
namespace factor
{
-gc_state::gc_state(gc_op op_) : op(op_), start_time(current_micros()) {}
+gc_event::gc_event(gc_op op_, factor_vm *parent) :
+ op(op_),
+ cards_scanned(0),
+ decks_scanned(0),
+ code_blocks_scanned(0),
+ start_time(current_micros()),
+ card_scan_time(0),
+ code_scan_time(0),
+ data_sweep_time(0),
+ code_sweep_time(0),
+ compaction_time(0)
+{
+ data_heap_before = parent->data_room();
+ code_heap_before = parent->code_room();
+ start_time = current_micros();
+}
+
+void gc_event::started_card_scan()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_card_scan(cell cards_scanned_, cell decks_scanned_)
+{
+ cards_scanned += cards_scanned_;
+ decks_scanned += decks_scanned_;
+ card_scan_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_code_scan()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_code_scan(cell code_blocks_scanned_)
+{
+ code_blocks_scanned += code_blocks_scanned_;
+ code_scan_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_data_sweep()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_data_sweep()
+{
+ data_sweep_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_code_sweep()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_code_sweep()
+{
+ code_sweep_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_compaction()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_compaction()
+{
+ compaction_time = (current_micros() - temp_time);
+}
+
+void gc_event::ended_gc(factor_vm *parent)
+{
+ data_heap_after = parent->data_room();
+ code_heap_after = parent->code_room();
+ total_time = current_micros() - start_time;
+}
+
+gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_), start_time(current_micros())
+{
+ event = new gc_event(op,parent);
+}
+
+gc_state::~gc_state()
+{
+ delete event;
+ event = NULL;
+}
+
+void factor_vm::end_gc()
+{
+ current_gc->event->ended_gc(this);
+ if(gc_events) gc_events->push_back(*current_gc->event);
+ delete current_gc->event;
+ current_gc->event = NULL;
+}
+
+void factor_vm::start_gc_again()
+{
+ end_gc();
+
+ switch(current_gc->op)
+ {
+ case collect_nursery_op:
+ current_gc->op = collect_aging_op;
+ break;
+ case collect_aging_op:
+ current_gc->op = collect_to_tenured_op;
+ break;
+ case collect_to_tenured_op:
+ current_gc->op = collect_full_op;
+ break;
+ case collect_full_op:
+ case collect_compact_op:
+ current_gc->op = collect_growing_heap_op;
+ break;
+ default:
+ critical_error("Bad GC op",current_gc->op);
+ break;
+ }
-gc_state::~gc_state() {}
+ current_gc->event = new gc_event(current_gc->op,this);
+}
void factor_vm::update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set)
{
for(; iter != end; iter++) update_literal_references(*iter);
}
-void factor_vm::record_gc_stats(generation_statistics *stats)
-{
- cell gc_elapsed = (current_micros() - current_gc->start_time);
- stats->collections++;
- stats->gc_time += gc_elapsed;
- if(stats->max_gc_time < gc_elapsed)
- stats->max_gc_time = gc_elapsed;
-}
-
-void factor_vm::gc(gc_op op,
- cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
+void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
{
assert(!gc_off);
assert(!current_gc);
save_stacks();
- current_gc = new gc_state(op);
+ current_gc = new gc_state(op,this);
/* Keep trying to GC higher and higher generations until we don't run out
of space */
if(setjmp(current_gc->gc_unwind))
{
/* We come back here if a generation is full */
- switch(current_gc->op)
- {
- case collect_nursery_op:
- current_gc->op = collect_aging_op;
- break;
- case collect_aging_op:
- current_gc->op = collect_to_tenured_op;
- break;
- case collect_to_tenured_op:
- current_gc->op = collect_full_op;
- break;
- case collect_full_op:
- current_gc->op = collect_growing_heap_op;
- break;
- default:
- critical_error("Bad GC op\n",op);
- break;
- }
+ start_gc_again();
}
+ current_gc->event->op = current_gc->op;
+
switch(current_gc->op)
{
case collect_nursery_op:
collect_nursery();
- record_gc_stats(&gc_stats.nursery_stats);
break;
case collect_aging_op:
collect_aging();
- record_gc_stats(&gc_stats.aging_stats);
+ if(data->low_memory_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
break;
case collect_to_tenured_op:
collect_to_tenured();
- record_gc_stats(&gc_stats.aging_stats);
+ if(data->low_memory_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
break;
case collect_full_op:
- collect_full(trace_contexts_p,compact_code_heap_p);
- record_gc_stats(&gc_stats.full_stats);
+ collect_full(trace_contexts_p);
+ break;
+ case collect_compact_op:
+ collect_compact(trace_contexts_p);
break;
case collect_growing_heap_op:
- collect_growing_heap(requested_bytes,trace_contexts_p,compact_code_heap_p);
- record_gc_stats(&gc_stats.full_stats);
+ collect_growing_heap(requested_bytes,trace_contexts_p);
break;
default:
- critical_error("Bad GC op\n",op);
+ critical_error("Bad GC op\n",current_gc->op);
break;
}
+ end_gc();
+
delete current_gc;
current_gc = NULL;
}
{
gc(collect_nursery_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_full_gc()
{
gc(collect_full_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_compact_gc()
{
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- true, /* trace contexts? */
- true /* compact code heap? */);
-}
-
-void factor_vm::add_gc_stats(generation_statistics *stats, growable_array *result)
-{
- result->add(allot_cell(stats->collections));
- result->add(tag<bignum>(long_long_to_bignum(stats->gc_time)));
- result->add(tag<bignum>(long_long_to_bignum(stats->max_gc_time)));
- result->add(allot_cell(stats->collections == 0 ? 0 : stats->gc_time / stats->collections));
- result->add(allot_cell(stats->object_count));
- result->add(tag<bignum>(long_long_to_bignum(stats->bytes_copied)));
-}
-
-void factor_vm::primitive_gc_stats()
-{
- growable_array result(this);
-
- add_gc_stats(&gc_stats.nursery_stats,&result);
- add_gc_stats(&gc_stats.aging_stats,&result);
- add_gc_stats(&gc_stats.full_stats,&result);
-
- u64 total_gc_time =
- gc_stats.nursery_stats.gc_time +
- gc_stats.aging_stats.gc_time +
- gc_stats.full_stats.gc_time;
-
- result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.cards_scanned)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.decks_scanned)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.card_scan_time)));
- result.add(allot_cell(gc_stats.code_blocks_scanned));
-
- result.trim();
- dpush(result.elements.value());
-}
-
-void factor_vm::clear_gc_stats()
-{
- memset(&gc_stats,0,sizeof(gc_statistics));
-}
-
-void factor_vm::primitive_clear_gc_stats()
-{
- clear_gc_stats();
+ true /* trace contexts? */);
}
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
compile_all_words();
}
-void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
+void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
{
- for(cell i = 0; i < gc_roots_size; i++)
- gc_locals.push_back((cell)&gc_roots_base[i]);
+ for(cell i = 0; i < data_roots_size; i++)
+ data_roots.push_back((cell)&data_roots_base[i]);
primitive_minor_gc();
- for(cell i = 0; i < gc_roots_size; i++)
- gc_locals.pop_back();
+ for(cell i = 0; i < data_roots_size; i++)
+ data_roots.pop_back();
}
-VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
{
- parent->inline_gc(gc_roots_base,gc_roots_size);
+ parent->inline_gc(data_roots_base,data_roots_size);
}
/*
*/
object *factor_vm::allot_large_object(header header, cell size)
{
- /* If tenured space does not have enough room, collect */
- if(data->tenured->here + size > data->tenured->end)
- primitive_full_gc();
-
- /* If it still won't fit, grow the heap */
- if(data->tenured->here + size > data->tenured->end)
+ /* If tenured space does not have enough room, collect and compact */
+ if(!data->tenured->can_allot_p(size))
{
- gc(collect_growing_heap_op,
- size, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ primitive_compact_gc();
+
+ /* If it still won't fit, grow the heap */
+ if(!data->tenured->can_allot_p(size))
+ {
+ gc(collect_growing_heap_op,
+ size, /* requested size */
+ true /* trace contexts? */);
+ }
}
object *obj = data->tenured->allot(size);
return obj;
}
+void factor_vm::primitive_enable_gc_events()
+{
+ gc_events = new std::vector<gc_event>();
+}
+
+void factor_vm::primitive_disable_gc_events()
+{
+ if(gc_events)
+ {
+ byte_array *data = byte_array_from_values(&gc_events->front(),gc_events->size());
+ dpush(tag<byte_array>(data));
+
+ delete gc_events;
+ gc_events = NULL;
+ }
+ else
+ dpush(false_object);
+}
+
}
collect_aging_op,
collect_to_tenured_op,
collect_full_op,
+ collect_compact_op,
collect_growing_heap_op
};
-/* statistics */
-struct generation_statistics {
- cell collections;
- u64 gc_time;
- u64 max_gc_time;
- cell object_count;
- u64 bytes_copied;
-};
+struct gc_event {
+ gc_op op;
+ data_heap_room data_heap_before;
+ code_heap_room code_heap_before;
+ data_heap_room data_heap_after;
+ code_heap_room code_heap_after;
+ cell cards_scanned;
+ cell decks_scanned;
+ cell code_blocks_scanned;
+ u64 start_time;
+ cell total_time;
+ cell card_scan_time;
+ cell code_scan_time;
+ cell data_sweep_time;
+ cell code_sweep_time;
+ cell compaction_time;
+ cell temp_time;
-struct gc_statistics {
- generation_statistics nursery_stats;
- generation_statistics aging_stats;
- generation_statistics full_stats;
- u64 cards_scanned;
- u64 decks_scanned;
- u64 card_scan_time;
- u64 code_blocks_scanned;
+ explicit gc_event(gc_op op_, factor_vm *parent);
+ void started_card_scan();
+ void ended_card_scan(cell cards_scanned_, cell decks_scanned_);
+ void started_code_scan();
+ void ended_code_scan(cell code_blocks_scanned_);
+ void started_data_sweep();
+ void ended_data_sweep();
+ void started_code_sweep();
+ void ended_code_sweep();
+ void started_compaction();
+ void ended_compaction();
+ void ended_gc(factor_vm *parent);
};
struct gc_state {
gc_op op;
u64 start_time;
jmp_buf gc_unwind;
+ gc_event *event;
- explicit gc_state(gc_op op_);
+ explicit gc_state(gc_op op_, factor_vm *parent);
~gc_state();
+ void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
}
namespace factor
{
-template<typename Array> cell array_capacity(Array *array)
+template<typename Array> cell array_capacity(const Array *array)
{
#ifdef FACTOR_DEBUG
assert(array->h.hi_tag() == Array::type_number);
return array_size<Array>(array_capacity(array));
}
-template<typename Array> Array *factor_vm::allot_array_internal(cell capacity)
+template<typename Array> Array *factor_vm::allot_uninitialized_array(cell capacity)
{
Array *array = allot<Array>(array_size<Array>(capacity));
array->capacity = tag_fixnum(capacity);
template<typename Array> Array *factor_vm::reallot_array(Array *array_, cell capacity)
{
-
gc_root<Array> array(array_,this);
+
data_root<Array> array(array_,this);
if(reallot_array_in_place_p(array.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- Array *new_array = allot_
array_internal<Array>(capacity);
+ Array *new_array = allot_
uninitialized_array<Array>(capacity);
memcpy(new_array + 1,array.untagged() + 1,to_copy * Array::element_size);
memset((char *)(new_array + 1) + to_copy * Array::element_size,
+++ /dev/null
-#include "master.hpp"
-
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
-will be used for the data heap too, if we ever get mark/sweep/compact GC. */
-
-namespace factor
-{
-
-void heap::clear_free_list()
-{
- memset(&free,0,sizeof(heap_free_list));
-}
-
-heap::heap(bool secure_gc_, cell size, bool executable_p) : secure_gc(secure_gc_)
-{
- if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
- seg = new segment(align_page(size),executable_p);
- if(!seg) fatal_error("Out of memory in heap allocator",size);
- state = new mark_bits<heap_block,block_size_increment>(seg->start,size);
- clear_free_list();
-}
-
-heap::~heap()
-{
- delete seg;
- seg = NULL;
- delete state;
- state = NULL;
-}
-
-void heap::add_to_free_list(free_heap_block *block)
-{
- if(block->size() < free_list_count * block_size_increment)
- {
- int index = block->size() / block_size_increment;
- block->next_free = free.small_blocks[index];
- free.small_blocks[index] = block;
- }
- else
- {
- block->next_free = free.large_blocks;
- free.large_blocks = block;
- }
-}
-
-/* Called after reading the code heap from the image file, and after code heap
-compaction. Makes a free list consisting of one free block, at the very end. */
-void heap::build_free_list(cell size)
-{
- clear_free_list();
- free_heap_block *end = (free_heap_block *)(seg->start + size);
- end->set_type(FREE_BLOCK_TYPE);
- end->set_size(seg->end - (cell)end);
- add_to_free_list(end);
-}
-
-void heap::assert_free_block(free_heap_block *block)
-{
- if(block->type() != FREE_BLOCK_TYPE)
- critical_error("Invalid block in free list",(cell)block);
-}
-
-free_heap_block *heap::find_free_block(cell size)
-{
- cell attempt = size;
-
- while(attempt < free_list_count * block_size_increment)
- {
- int index = attempt / block_size_increment;
- free_heap_block *block = free.small_blocks[index];
- if(block)
- {
- assert_free_block(block);
- free.small_blocks[index] = block->next_free;
- return block;
- }
-
- attempt *= 2;
- }
-
- free_heap_block *prev = NULL;
- free_heap_block *block = free.large_blocks;
-
- while(block)
- {
- assert_free_block(block);
- if(block->size() >= size)
- {
- if(prev)
- prev->next_free = block->next_free;
- else
- free.large_blocks = block->next_free;
- return block;
- }
-
- prev = block;
- block = block->next_free;
- }
-
- return NULL;
-}
-
-free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
-{
- if(block->size() != size )
- {
- /* split the block in two */
- free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->set_type(FREE_BLOCK_TYPE);
- split->set_size(block->size() - size);
- split->next_free = block->next_free;
- block->set_size(size);
- add_to_free_list(split);
- }
-
- return block;
-}
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *heap::heap_allot(cell size, cell type)
-{
- size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
- free_heap_block *block = find_free_block(size);
- if(block)
- {
- block = split_free_block(block,size);
- block->set_type(type);
- return block;
- }
- else
- return NULL;
-}
-
-/* Deallocates a block manually */
-void heap::heap_free(heap_block *block)
-{
- block->set_type(FREE_BLOCK_TYPE);
- add_to_free_list((free_heap_block *)block);
-}
-
-void heap::mark_block(heap_block *block)
-{
- state->set_marked_p(block,true);
-}
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- heap_block *scan = first_block();
-
- while(scan)
- {
- cell size = scan->size();
-
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- *total_free += size;
- if(size > *max_free)
- *max_free = size;
- }
- else
- *used += size;
-
- scan = next_block(scan);
- }
-}
-
-/* The size of the heap after compaction */
-cell heap::heap_size()
-{
- heap_block *scan = first_block();
-
- while(scan)
- {
- if(scan->type() == FREE_BLOCK_TYPE) break;
- else scan = next_block(scan);
- }
-
- assert(scan->type() == FREE_BLOCK_TYPE);
- assert((cell)scan + scan->size() == seg->end);
-
- return (cell)scan - (cell)first_block();
-}
-
-void heap::compact_heap()
-{
- forwarding.clear();
-
- heap_block *scan = first_block();
- char *address = (char *)scan;
-
- /* Slide blocks up while building the forwarding hashtable. */
- while(scan)
- {
- heap_block *next = next_block(scan);
-
- if(state->is_marked_p(scan))
- {
- cell size = scan->size();
- memmove(address,scan,size);
- forwarding[scan] = address;
- address += size;
- }
-
- scan = next;
- }
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list((cell)address - seg->start);
-}
-
-heap_block *heap::free_allocated(heap_block *prev, heap_block *scan)
-{
- if(secure_gc)
- memset(scan + 1,0,scan->size() - sizeof(heap_block));
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- {
- prev->set_size(prev->size() + scan->size());
- return prev;
- }
- else
- {
- scan->set_type(FREE_BLOCK_TYPE);
- return scan;
- }
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell free_list_count = 32;
-static const cell block_size_increment = 16;
-
-struct heap_free_list {
- free_heap_block *small_blocks[free_list_count];
- free_heap_block *large_blocks;
-};
-
-struct heap {
- bool secure_gc;
- segment *seg;
- heap_free_list free;
- mark_bits<heap_block,block_size_increment> *state;
- unordered_map<heap_block *, char *> forwarding;
-
- explicit heap(bool secure_gc_, cell size, bool executable_p);
- ~heap();
-
- inline heap_block *next_block(heap_block *block)
- {
- cell next = ((cell)block + block->size());
- if(next == seg->end)
- return NULL;
- else
- return (heap_block *)next;
- }
-
- inline heap_block *first_block()
- {
- return (heap_block *)seg->start;
- }
-
- inline heap_block *last_block()
- {
- return (heap_block *)seg->end;
- }
-
- void clear_free_list();
- void new_heap(cell size);
- void add_to_free_list(free_heap_block *block);
- void build_free_list(cell size);
- void assert_free_block(free_heap_block *block);
- free_heap_block *find_free_block(cell size);
- free_heap_block *split_free_block(free_heap_block *block, cell size);
- heap_block *heap_allot(cell size, cell type);
- void heap_free(heap_block *block);
- void mark_block(heap_block *block);
- void heap_usage(cell *used, cell *total_free, cell *max_free);
- cell heap_size();
- void compact_heap();
-
- heap_block *free_allocated(heap_block *prev, heap_block *scan);
-
- /* After code GC, all referenced code blocks have status set to B_MARKED, so any
- which are allocated and not marked can be reclaimed. */
- template<typename Iterator> void free_unmarked(Iterator &iter)
- {
- clear_free_list();
-
- heap_block *prev = NULL;
- heap_block *scan = first_block();
-
- while(scan)
- {
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- prev->set_size(prev->size() + scan->size());
- else
- prev = scan;
- }
- else if(state->is_marked_p(scan))
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- prev = scan;
- iter(scan);
- }
- else
- prev = free_allocated(prev,scan);
-
- scan = next_block(scan);
- }
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- }
-};
-
-}
/* Certain special objects in the image are known to the runtime */
void factor_vm::init_objects(image_header *h)
{
- memcpy(userenv,h->userenv,sizeof(userenv));
+ memcpy(special_objects,h->special_objects,sizeof(special_objects));
true_object = h->true_object;
bignum_zero = h->bignum_zero;
void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
- cell good_size = h->data_size + (1 << 20);
-
- if(good_size > p->tenured_size)
- p->tenured_size = good_size;
+ p->tenured_size = std::max((h->data_size * 3) / 2,p->tenured_size);
init_data_heap(p->young_size,
p->aging_size,
- p->tenured_size,
- p->secure_gc);
-
- clear_gc_stats();
+ p->tenured_size);
fixnum bytes_read = fread((void*)data->tenured->start,1,h->data_size,file);
if((cell)bytes_read != h->data_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->data_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->data_size << " bytes expected\n";
fatal_error("load_data_heap failed",0);
}
- data->tenured->here = data->tenured->start + h->data_size;
+ data->tenured->initial_free_list(h->data_size);
}
void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
if(h->code_size != 0)
{
- size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
+ size_t bytes_read = fread(code->allocator->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->code_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->code_size << " bytes expected\n";
fatal_error("load_code_heap failed",0);
}
}
- code->build_free_list(h->code_size);
+ code->allocator->initial_free_list(h->code_size);
}
void factor_vm::data_fixup(cell *handle, cell data_relocation_base)
quot->xt = (void *)lazy_jit_compile;
}
-void factor_vm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *ptr)
{
- if(!to_boolean(d->base)) d->expired = true_object;
+ if(!to_boolean(ptr->base))
+ ptr->expired = true_object;
+ else
+ ptr->update_address();
}
struct stack_frame_fixupper {
data_fixup(&t->layout,data_relocation_base);
cell *scan = t->data();
- cell *end = (cell *)((cell)object + untagged_object_size(object));
+ cell *end = (cell *)((cell)object + object->size());
for(; scan < end; scan++)
data_fixup(scan,data_relocation_base);
where it is loaded, we need to fix up pointers in the image. */
void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_base)
{
- for(cell i = 0; i < USER_ENV; i++)
- data_fixup(&userenv[i],data_relocation_base);
+ for(cell i = 0; i < special_object_count; i++)
+ data_fixup(&special_objects[i],data_relocation_base);
data_fixup(&true_object,data_relocation_base);
data_fixup(&bignum_zero,data_relocation_base);
while(obj)
{
relocate_object((object *)obj,data_relocation_base,code_relocation_base);
- data->tenured->record_object_start_offset((object *)obj);
- obj = data->tenured->next_object_after(this,obj);
+ data->tenured->starts.record_object_start_offset((object *)obj);
+ obj = data->tenured->next_object_after(obj);
}
}
factor_vm *parent;
cell data_relocation_base;
- code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
+ explicit code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
parent(parent_), data_relocation_base(data_relocation_base_) { }
- void operator()(code_block *compiled)
+ void operator()(code_block *compiled, cell size)
{
parent->fixup_code_block(compiled,data_relocation_base);
}
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << p->image_path << std::endl;
+ std::cout << strerror(errno) << std::endl;
exit(1);
}
relocate_code(h.data_relocation_base);
/* Store image path name */
- userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path);
+ special_objects[OBJ_IMAGE] = allot_alien(false_object,(cell)p->image_path);
}
/* Save the current image to disk */
file = OPEN_WRITE(filename);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(filename); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << filename << std::endl;
+ std::cout << strerror(errno) << std::endl;
return false;
}
h.magic = image_magic;
h.version = image_version;
h.data_relocation_base = data->tenured->start;
- h.data_size = data->tenured->here - data->tenured->start;
+ h.data_size = data->tenured->occupied_space();
h.code_relocation_base = code->seg->start;
- h.code_size = code->heap_size();
+ h.code_size = code->allocator->occupied_space();
h.true_object = true_object;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
- for(cell i = 0; i < USER_ENV; i++)
- h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
+ for(cell i = 0; i < special_object_count; i++)
+ h.special_objects[i] = (save_env_p(i) ? special_objects[i] : false_object);
bool ok = true;
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
+ if(fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
if(!ok)
- {
- print_string("save-image failed: "); print_string(strerror(errno)); nl();
- }
+ std::cout << "save-image failed: " << strerror(errno) << std::endl;
return ok;
}
/* do a full GC to push everything into tenured space */
primitive_compact_gc();
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
path.untag_check(this);
save_image((vm_char *)(path.untagged() + 1));
}
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
path.untag_check(this);
- /* strip out userenv data which is set on startup anyway */
- for(cell i = 0; i < USER_ENV; i++)
- if(!save_env_p(i)) userenv[i] = false_object;
+ /* strip out special_objects data which is set on startup anyway */
+ for(cell i = 0; i < special_object_count; i++)
+ if(!save_env_p(i)) special_objects[i] = false_object;
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- false, /* discard objects only reachable from stacks */
- true /* compact the code heap */);
+ false /* discard objects only reachable from stacks */);
/* Save the image */
if(save_image((vm_char *)(path.untagged() + 1)))
/* tagged pointer to bignum -1 */
cell bignum_neg_one;
/* Initial user environment */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
};
struct vm_parameters {
cell ds_size, rs_size;
cell young_size, aging_size, tenured_size;
cell code_size;
- bool secure_gc;
bool fep;
bool console;
bool signals;
void factor_vm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
- cold_call_to_ic_transitions = 0;
- ic_to_pic_transitions = 0;
- pic_to_mega_transitions = 0;
- for(int i = 0; i < 4; i++) pic_counts[i] = 0;
}
void factor_vm::deallocate_inline_cache(cell return_address)
check_code_pointer((cell)old_xt);
code_block *old_block = (code_block *)old_xt - 1;
- cell old_type = old_block->type();
-#ifdef FACTOR_DEBUG
- /* The call target was either another PIC,
- or a compiled quotation (megamorphic stub) */
- assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
-#endif
-
- if(old_type == PIC_TYPE)
+ /* Free the old PIC since we know its unreachable */
+ if(old_block->pic_p())
code->code_heap_free(old_block);
}
it contains */
cell factor_vm::determine_inline_cache_type(array *cache_entries)
{
- bool seen_hi_tag = false, seen_tuple = false;
+ bool seen_tuple = false;
cell i;
for(i = 0; i < array_capacity(cache_entries); i += 2)
{
- cell klass = array_nth(cache_entries,i);
-
/* Is it a tuple layout? */
- switch(TAG(klass))
+ if(TAG(array_nth(cache_entries,i)) == ARRAY_TYPE)
{
- case FIXNUM_TYPE:
- {
- fixnum type = untag_fixnum(klass);
- if(type >= HEADER_TYPE)
- seen_hi_tag = true;
- }
- break;
- case ARRAY_TYPE:
seen_tuple = true;
break;
- default:
- critical_error("Expected a fixnum or array",klass);
- break;
}
}
- if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
- if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
- if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
- if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
-
- critical_error("Oops",0);
- return 0;
+ return seen_tuple ? PIC_TUPLE : PIC_TAG;
}
void factor_vm::update_pic_count(cell type)
{
- pic_counts[type - PIC_TAG]++;
+ if(type == PIC_TAG)
+ dispatch_stats.pic_tag_count++;
+ else
+ dispatch_stats.pic_tuple_count++;
}
struct inline_cache_jit : public jit {
fixnum index;
- explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
+ explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(code_block_pic,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
void inline_cache_jit::emit_check(cell klass)
{
cell code_template;
- if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = parent->userenv[PIC_CHECK_TAG];
+ if(TAG(klass) == FIXNUM_TYPE)
+ code_template = parent->special_objects[PIC_CHECK_TAG];
else
- code_template = parent->userenv[PIC_CHECK];
+ code_template = parent->special_objects[PIC_CHECK_TUPLE];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,parent);
-
gc_root<array> methods(methods_,parent);
-
gc_root<array> cache_entries(cache_entries_,parent);
+ data_root<word> generic_word(generic_word_,parent);
+
data_root<array> methods(methods_,parent);
+
data_root<array> cache_entries(cache_entries_,parent);
cell inline_cache_type = parent->determine_inline_cache_type(cache_entries.untagged());
parent->update_pic_count(inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(parent->userenv[PIC_HIT],method);
+ emit_with(parent->special_objects[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(parent->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(parent->special_objects[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
+code_block *factor_vm::compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,this);
-
gc_root<array> methods(methods_,this);
-
gc_root<array> cache_entries(cache_entries_,this);
+ data_root<word> generic_word(generic_word_,this);
+
data_root<array> methods(methods_,this);
+
data_root<array> cache_entries(cache_entries_,this);
inline_cache_jit jit(generic_word.value(),this);
jit.compile_inline_cache(index,
return code;
}
-/* A generic word's definition performs general method lookup. Allocates memory */
+/* A generic word's definition performs general method lookup. */
void *factor_vm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
/* Allocates memory */
cell factor_vm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
-
gc_root<array> cache_entries(cache_entries_,this);
- gc_root<object> klass(klass_,this);
- gc_root<word> method(method_,this);
+
data_root<array> cache_entries(cache_entries_,this);
+ data_root<object> klass(klass_,this);
+ data_root<word> method(method_,this);
cell pic_size = array_capacity(cache_entries.untagged());
-
gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
+
data_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
set_array_nth(new_cache_entries.untagged(),pic_size,klass.value());
set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value());
return new_cache_entries.value();
void factor_vm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
- pic_to_mega_transitions++;
+ dispatch_stats.pic_to_mega_transitions++;
else if(pic_size == 0)
- cold_call_to_ic_transitions++;
+ dispatch_stats.cold_call_to_ic_transitions++;
else if(pic_size == 1)
- ic_to_pic_transitions++;
+ dispatch_stats.ic_to_pic_transitions++;
}
-/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
-Called from assembly with the actual return address */
-void *factor_vm::inline_cache_miss(cell return_address)
+/* The cache_entries parameter is empty (on cold call site) or has entries
+(on cache miss). Called from assembly with the actual return address.
+Compilation of the inline cache may trigger a GC, which may trigger a compaction;
+also, the block containing the return address may now be dead. Use a code_root
+to take care of the details. */
+void *factor_vm::inline_cache_miss(cell return_address_)
{
- check_code_pointer(return_address);
+ code_root return_address(return_address_,this);
+
+ check_code_pointer(return_address.value);
/* Since each PIC is only referenced from a single call site,
if the old call target was a PIC, we can deallocate it immediately,
instead of leaving dead PICs around until the next GC. */
- deallocate_inline_cache(return_address);
+ deallocate_inline_cache(return_address.value);
-
gc_root<array> cache_entries(dpop(),this);
+
data_root<array> cache_entries(dpop(),this);
fixnum index = untag_fixnum(dpop());
-
gc_root<array> methods(dpop(),this);
- gc_root<word> generic_word(dpop(),this);
- gc_root<object> object(((cell *)ds)[-index],this);
+
data_root<array> methods(dpop(),this);
+ data_root<word> generic_word(dpop(),this);
+ data_root<object> object(((cell *)ds)[-index],this);
void *xt;
cell klass = object_class(object.value());
cell method = lookup_method(object.value(),methods.value());
-
gc_root<array> new_cache_entries(add_inline_cache_entry(
+
data_root<array> new_cache_entries(add_inline_cache_entry(
cache_entries.value(),
klass,
method),this);
generic_word.value(),
methods.value(),
new_cache_entries.value(),
- tail_call_site_p(return_address))->xt();
+ tail_call_site_p(return_address.value))->xt();
}
/* Install the new stub. */
- set_call_target(return_address,xt);
+ if(return_address.valid)
+ {
+ set_call_target(return_address.value,xt);
#ifdef PIC_DEBUG
- printf("Updated %s call site 0x%lx with 0x%lx\n",
- tail_call_site_p(return_address) ? "tail" : "non-tail",
- return_address,
- (cell)xt);
+ std::cout << "Updated "
+ << (tail_call_site_p(return_address) ? "tail" : "non-tail")
+ << " call site 0x" << std::hex << return_address << std::dec
+ << " with " << std::hex << (cell)xt << std::dec;
#endif
+ }
return xt;
}
return parent->inline_cache_miss(return_address);
}
-void factor_vm::primitive_reset_inline_cache_stats()
-{
- cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
- cell i;
- for(i = 0; i < 4; i++) pic_counts[i] = 0;
-}
-
-void factor_vm::primitive_inline_cache_stats()
-{
- growable_array stats(this);
- stats.add(allot_cell(cold_call_to_ic_transitions));
- stats.add(allot_cell(ic_to_pic_transitions));
- stats.add(allot_cell(pic_to_mega_transitions));
- cell i;
- for(i = 0; i < 4; i++)
- stats.add(allot_cell(pic_counts[i]));
- stats.trim();
- dpush(stats.elements.value());
-}
-
}
void factor_vm::init_c_io()
{
- userenv[STDIN_ENV] = allot_alien(false_object,(cell)stdin);
- userenv[STDOUT_ENV] = allot_alien(false_object,(cell)stdout);
- userenv[STDERR_ENV] = allot_alien(false_object,(cell)stderr);
+ special_objects[OBJ_STDIN] = allot_alien(false_object,(cell)stdin);
+ special_objects[OBJ_STDOUT] = allot_alien(false_object,(cell)stdout);
+ special_objects[OBJ_STDERR] = allot_alien(false_object,(cell)stderr);
}
void factor_vm::io_error()
void factor_vm::primitive_fopen()
{
- gc_root<byte_array> mode(dpop(),this);
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> mode(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
mode.untag_check(this);
path.untag_check(this);
return;
}
- gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
+ data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
for(;;)
{
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_, factor_vm *vm)
+jit::jit(code_block_type type_, cell owner_, factor_vm *vm)
: type(type_),
owner(owner_,vm),
code(vm),
void jit::emit_relocation(cell code_template_)
{
-
gc_root<array> code_template(code_template_,parent);
+
data_root<array> code_template(code_template_,parent);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
-
gc_root<array> code_template(code_template_,parent);
+
data_root<array> code_template(code_template_,parent);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent);
+ data_root<byte_array> insns(array_nth(code_template.untagged(),0),parent);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
-
gc_root<array> code_template(code_template_,parent);
- gc_root<object> argument(argument_,parent);
+
data_root<array> code_template(code_template_,parent);
+ data_root<object> argument(argument_,parent);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(parent->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(parent->userenv[type]);
+ emit_with(parent->special_objects[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(parent->special_objects[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
{
struct jit {
- cell type;
- gc_root<object> owner;
+ code_block_type type;
+ data_root<object> owner;
growable_byte_array code;
growable_byte_array relocation;
growable_array literals;
cell offset;
factor_vm *parent;
- explicit jit(cell jit_type, cell owner, factor_vm *vm);
+ explicit jit(code_block_type type, cell owner, factor_vm *parent);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void literal(cell literal) { literals.add(literal); }
void emit_with(cell code_template_, cell literal_);
- void push(cell literal) {
- emit_with(parent->userenv[JIT_PUSH_IMMEDIATE],literal);
+ void push(cell literal)
+ {
+ emit_with(parent->special_objects[JIT_PUSH_IMMEDIATE],literal);
}
- void word_jump(cell word_) {
- gc_root<word> word(word_,parent);
+ void word_jump(cell word_)
+ {
+ data_root<word> word(word_,parent);
literal(tag_fixnum(xt_tail_pic_offset));
literal(word.value());
- emit(parent->userenv[JIT_WORD_JUMP]);
+ emit(parent->special_objects[JIT_WORD_JUMP]);
}
- void word_call(cell word) {
- emit_with(parent->userenv[JIT_WORD_CALL],word);
+ void word_call(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_CALL],word);
}
- void word_special(cell word) {
- emit_with(parent->userenv[JIT_WORD_SPECIAL],word);
+ void word_special(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_SPECIAL],word);
}
- void emit_subprimitive(cell word_) {
- gc_root<word> word(word_,parent);
- gc_root<array> code_pair(word->subprimitive,parent);
- literals.append(parent->untag<array>(array_nth(code_pair.untagged(),0)));
+ void emit_subprimitive(cell word_)
+ {
+ data_root<word> word(word_,parent);
+ data_root<array> code_pair(word->subprimitive,parent);
+ literals.append(untag<array>(array_nth(code_pair.untagged(),0)));
emit(array_nth(code_pair.untagged(),1));
}
void emit_class_lookup(fixnum index, cell type);
- fixnum get_position() {
+ fixnum get_position()
+ {
if(computing_offset_p)
{
/* If this is still on, emit() didn't clear it,
return position;
}
- void set_position(fixnum position_) {
+ void set_position(fixnum position_)
+ {
if(computing_offset_p)
position = position_;
}
return (a + (b-1)) & ~(b-1);
}
-inline static cell align8(cell a)
-{
- return align(a,8);
-}
+static const cell data_alignment = 16;
#define WORD_SIZE (signed)(sizeof(cell)*8)
-#define TAG_MASK 7
-#define TAG_BITS 3
+#define TAG_MASK 15
+#define TAG_BITS 4
#define TAG(x) ((cell)(x) & TAG_MASK)
#define UNTAG(x) ((cell)(x) & ~TAG_MASK)
#define RETAG(x,tag) (UNTAG(x) | (tag))
/*** Tags ***/
#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
+#define F_TYPE 1
#define ARRAY_TYPE 2
#define FLOAT_TYPE 3
#define QUOTATION_TYPE 4
-#define F_TYPE 5
-#define OBJECT_TYPE 6
+#define BIGNUM_TYPE 5
+#define ALIEN_TYPE 6
#define TUPLE_TYPE 7
-
-#define HEADER_TYPE 8 /* anything less than this is a tag */
-
-#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
-
-/*** Header types ***/
#define WRAPPER_TYPE 8
#define BYTE_ARRAY_TYPE 9
#define CALLSTACK_TYPE 10
#define STRING_TYPE 11
#define WORD_TYPE 12
#define DLL_TYPE 13
-#define ALIEN_TYPE 14
-#define TYPE_COUNT 15
+#define TYPE_COUNT 14
-/* Not real types, but code_block's type can be set to this */
-#define PIC_TYPE 16
-#define FREE_BLOCK_TYPE 17
+#define FORWARDING_POINTER 5 /* can be anything other than FIXNUM_TYPE */
+
+enum code_block_type
+{
+ code_block_unoptimized,
+ code_block_optimized,
+ code_block_profiling,
+ code_block_pic
+};
/* Constants used when floating-point trap exceptions are thrown */
enum
inline static bool immediate_p(cell obj)
{
- return (obj == false_object || TAG(obj) == FIXNUM_TYPE);
+ /* We assume that fixnums have tag 0 and false_object has tag 1 */
+ return TAG(obj) <= F_TYPE;
}
inline static fixnum untag_fixnum(cell tagged)
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
-inline static cell tag_for(cell type)
-{
- return type < HEADER_TYPE ? type : OBJECT_TYPE;
-}
-
struct object;
struct header {
explicit header(cell value_) : value(value_ << TAG_BITS) {}
- void check_header() {
+ void check_header() const
+ {
#ifdef FACTOR_DEBUG
assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
#endif
}
- cell hi_tag() {
+ cell hi_tag() const
+ {
check_header();
return value >> TAG_BITS;
}
- bool forwarding_pointer_p() {
- return TAG(value) == GC_COLLECTED;
+ bool forwarding_pointer_p() const
+ {
+ return TAG(value) == FORWARDING_POINTER;
}
- object *forwarding_pointer() {
+ object *forwarding_pointer() const
+ {
return (object *)UNTAG(value);
}
- void forward_to(object *pointer) {
- value = RETAG(pointer,GC_COLLECTED);
+ void forward_to(object *pointer)
+ {
+ value = RETAG(pointer,FORWARDING_POINTER);
}
};
struct object {
NO_TYPE_CHECK;
header h;
- cell *slots() { return (cell *)this; }
+
+ cell size() const;
+ cell binary_payload_start() const;
+
+ cell *slots() const { return (cell *)this; }
+
+ /* Only valid for objects in tenured space; must fast to free_heap_block
+ to do anything with it if its free */
+ bool free_p() const
+ {
+ return h.value & 1 == 1;
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
/* These are really just arrays, but certain elements have special
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
struct byte_array : public object {
/* tagged */
cell capacity;
- template<typename Scalar> Scalar *data() { return (Scalar *)(this + 1); }
+#ifndef FACTOR_64
+ cell padding0;
+ cell padding1;
+#endif
+
+ template<typename Scalar> Scalar *data() const { return (Scalar *)(this + 1); }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell hashcode;
- u8 *data() { return (u8 *)(this + 1); }
+ u8 *data() const { return (u8 *)(this + 1); }
+
+ cell nth(cell i) const;
};
/* The compiled code heap is structured into blocks. */
-struct heap_block
+struct code_block
{
cell header;
+ cell owner; /* tagged pointer to word, quotation or f */
+ cell literals; /* tagged pointer to array or f */
+ cell relocation; /* tagged pointer to byte-array or f */
- cell type() { return (header >> 1) & 0x1f; }
- void set_type(cell type)
+ bool free_p() const
{
- header = ((header & ~(0x1f << 1)) | (type << 1));
+ return header & 1 == 1;
}
- cell size() { return (header >> 6); }
- void set_size(cell size)
+ code_block_type type() const
{
- header = (header & 0x2f) | (size << 6);
+ return (code_block_type)((header >> 1) & 0x3);
}
-};
-struct free_heap_block : public heap_block
-{
- free_heap_block *next_free;
-};
+ void set_type(code_block_type type)
+ {
+ header = ((header & ~0x7) | (type << 1));
+ }
-struct code_block : public heap_block
-{
- cell owner; /* tagged pointer to word, quotation or f */
- cell literals; /* tagged pointer to array or f */
- cell relocation; /* tagged pointer to byte-array or f */
+ bool pic_p() const
+ {
+ return type() == code_block_pic;
+ }
- void *xt() { return (void *)(this + 1); }
+ bool optimized_p() const
+ {
+ return type() == code_block_optimized;
+ }
+
+ cell size() const
+ {
+ return header >> 3;
+ }
+
+ void *xt() const
+ {
+ return (void *)(this + 1);
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
cell expired;
/* untagged */
cell displacement;
+ /* untagged */
+ cell address;
+
+ void update_address()
+ {
+ if(base == false_object)
+ address = displacement;
+ else
+ address = UNTAG(base) + sizeof(byte_array) + displacement;
+ }
};
struct dll : public object {
void *dll;
};
-struct stack_frame
-{
+struct stack_frame {
void *xt;
/* Frame size in bytes */
cell size;
/* tagged */
cell length;
- stack_frame *frame_at(cell offset)
+ stack_frame *frame_at(cell offset) const
{
return (stack_frame *)((char *)(this + 1) + offset);
}
- stack_frame *top() { return (stack_frame *)(this + 1); }
- stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+ stack_frame *top() const { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() const { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
};
struct tuple : public object {
/* tagged layout */
cell layout;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
}
+++ /dev/null
-namespace factor
-{
-
-template<typename Type>
-struct gc_root : public tagged<Type>
-{
- factor_vm *parent;
-
- void push() { parent->check_tagged_pointer(tagged<Type>::value()); parent->gc_locals.push_back((cell)this); }
-
- explicit gc_root(cell value_,factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
- explicit gc_root(Type *value_, factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
-
- const gc_root<Type>& operator=(const Type *x) { tagged<Type>::operator=(x); return *this; }
- const gc_root<Type>& operator=(const cell &x) { tagged<Type>::operator=(x); return *this; }
-
- ~gc_root() {
-#ifdef FACTOR_DEBUG
- assert(parent->gc_locals.back() == (cell)this);
-#endif
- parent->gc_locals.pop_back();
- }
-};
-
-/* A similar hack for the bignum implementation */
-struct gc_bignum
-{
- bignum **addr;
- factor_vm *parent;
- gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent(vm) {
- if(*addr_)
- parent->check_data_pointer(*addr_);
- parent->gc_bignums.push_back((cell)addr);
- }
-
- ~gc_bignum() {
-#ifdef FACTOR_DEBUG
- assert(parent->gc_bignums.back() == (cell)addr);
-#endif
- parent->gc_bignums.pop_back();
- }
-};
-
-#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x,this)
-
-}
{
THREADHANDLE thread_id = pthread_from_mach_thread_np(thread);
assert(thread_id);
- unordered_map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
+ std::map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
if (vm != thread_vms.end())
vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state);
}
namespace factor
{
-const int forwarding_granularity = 128;
+const int block_granularity = 16;
+const int forwarding_granularity = 64;
-template<typename Block, int Granularity> struct mark_bits {
- cell start;
+template<typename Block> struct mark_bits {
cell size;
+ cell start;
cell bits_size;
- unsigned int *marked;
- unsigned int *freed;
- cell forwarding_size;
+ u64 *marked;
cell *forwarding;
void clear_mark_bits()
{
- memset(marked,0,bits_size * sizeof(unsigned int));
- }
-
- void clear_free_bits()
- {
- memset(freed,0,bits_size * sizeof(unsigned int));
+ memset(marked,0,bits_size * sizeof(u64));
}
void clear_forwarding()
{
- memset(forwarding,0,forwarding_size * sizeof(cell));
+ memset(forwarding,0,bits_size * sizeof(cell));
}
- explicit mark_bits(cell start_, cell size_) :
- start(start_),
+ explicit mark_bits(cell size_, cell start_) :
size(size_),
- bits_size(size / Granularity / 32),
- marked(new unsigned int[bits_size]),
- freed(new unsigned int[bits_size]),
- forwarding_size(size / Granularity / forwarding_granularity),
- forwarding(new cell[forwarding_size])
+ start(start_),
+ bits_size(size / block_granularity / forwarding_granularity),
+ marked(new u64[bits_size]),
+ forwarding(new cell[bits_size])
{
clear_mark_bits();
- clear_free_bits();
clear_forwarding();
}
{
delete[] marked;
marked = NULL;
- delete[] freed;
- freed = NULL;
delete[] forwarding;
forwarding = NULL;
}
- std::pair<cell,cell> bitmap_deref(Block *address)
+ cell block_line(Block *address)
{
- cell word_number = (((cell)address - start) / Granularity);
- cell word_index = (word_number >> 5);
- cell word_shift = (word_number & 31);
+ return (((cell)address - start) / block_granularity);
+ }
-#ifdef FACTOR_DEBUG
- assert(word_index < bits_size);
-#endif
+ Block *line_block(cell line)
+ {
+ return (Block *)(line * block_granularity + start);
+ }
+ std::pair<cell,cell> bitmap_deref(Block *address)
+ {
+ cell line_number = block_line(address);
+ cell word_index = (line_number >> 6);
+ cell word_shift = (line_number & 63);
return std::make_pair(word_index,word_shift);
}
- bool bitmap_elt(unsigned int *bits, Block *address)
+ bool bitmap_elt(u64 *bits, Block *address)
+ {
+ std::pair<cell,cell> position = bitmap_deref(address);
+ return (bits[position.first] & ((u64)1 << position.second)) != 0;
+ }
+
+ Block *next_block_after(Block *block)
{
- std::pair<cell,cell> pair = bitmap_deref(address);
- return (bits[pair.first] & (1 << pair.second)) != 0;
+ return (Block *)((cell)block + block->size());
}
- void set_bitmap_elt(unsigned int *bits, Block *address, bool flag)
+ void set_bitmap_range(u64 *bits, Block *address)
{
- std::pair<cell,cell> pair = bitmap_deref(address);
- if(flag)
- bits[pair.first] |= (1 << pair.second);
+ std::pair<cell,cell> start = bitmap_deref(address);
+ std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
+
+ u64 start_mask = ((u64)1 << start.second) - 1;
+ u64 end_mask = ((u64)1 << end.second) - 1;
+
+ if(start.first == end.first)
+ bits[start.first] |= start_mask ^ end_mask;
else
- bits[pair.first] &= ~(1 << pair.second);
+ {
+#ifdef FACTOR_DEBUG
+ assert(start.first < bits_size);
+#endif
+ bits[start.first] |= ~start_mask;
+
+ for(cell index = start.first + 1; index < end.first; index++)
+ bits[index] = (u64)-1;
+
+ if(end_mask != 0)
+ {
+#ifdef FACTOR_DEBUG
+ assert(end.first < bits_size);
+#endif
+ bits[end.first] |= end_mask;
+ }
+ }
}
- bool is_marked_p(Block *address)
+ bool marked_p(Block *address)
{
return bitmap_elt(marked,address);
}
- void set_marked_p(Block *address, bool marked_p)
+ void set_marked_p(Block *address)
+ {
+ set_bitmap_range(marked,address);
+ }
+
+ /* The eventual destination of a block after compaction is just the number
+ of marked blocks before it. Live blocks must be marked on entry. */
+ void compute_forwarding()
+ {
+ cell accum = 0;
+ for(cell index = 0; index < bits_size; index++)
+ {
+ forwarding[index] = accum;
+ accum += popcount(marked[index]);
+ }
+ }
+
+ /* We have the popcount for every 64 entries; look up and compute the rest */
+ Block *forward_block(Block *original)
+ {
+#ifdef FACTOR_DEBUG
+ assert(marked_p(original));
+#endif
+ std::pair<cell,cell> position = bitmap_deref(original);
+
+ cell approx_popcount = forwarding[position.first];
+ u64 mask = ((u64)1 << position.second) - 1;
+
+ cell new_line_number = approx_popcount + popcount(marked[position.first] & mask);
+ Block *new_block = line_block(new_line_number);
+#ifdef FACTOR_DEBUG
+ assert(new_block <= original);
+#endif
+ return new_block;
+ }
+
+ Block *next_unmarked_block_after(Block *original)
{
- set_bitmap_elt(marked,address,marked_p);
+ std::pair<cell,cell> position = bitmap_deref(original);
+ cell bit_index = position.second;
+
+ for(cell index = position.first; index < bits_size; index++)
+ {
+ u64 mask = ((s64)marked[index] >> bit_index);
+ if(~mask)
+ {
+ /* Found an unmarked block on this page.
+ Stop, it's hammer time */
+ cell clear_bit = rightmost_clear_bit(mask);
+ return line_block(index * 64 + bit_index + clear_bit);
+ }
+ else
+ {
+ /* No unmarked blocks on this page.
+ Keep looking */
+ bit_index = 0;
+ }
+ }
+
+ /* No unmarked blocks were found */
+ return (Block *)(this->start + this->size);
}
- bool is_free_p(Block *address)
+ Block *next_marked_block_after(Block *original)
{
- return bitmap_elt(freed,address);
+ std::pair<cell,cell> position = bitmap_deref(original);
+ cell bit_index = position.second;
+
+ for(cell index = position.first; index < bits_size; index++)
+ {
+ u64 mask = (marked[index] >> bit_index);
+ if(mask)
+ {
+ /* Found an marked block on this page.
+ Stop, it's hammer time */
+ cell set_bit = rightmost_set_bit(mask);
+ return line_block(index * 64 + bit_index + set_bit);
+ }
+ else
+ {
+ /* No marked blocks on this page.
+ Keep looking */
+ bit_index = 0;
+ }
+ }
+
+ /* No marked blocks were found */
+ return (Block *)(this->start + this->size);
}
- void set_free_p(Block *address, bool free_p)
+ cell unmarked_block_size(Block *original)
{
- set_bitmap_elt(freed,address,free_p);
+ Block *next_marked = next_marked_block_after(original);
+ return ((char *)next_marked - (char *)original);
}
};
/* C++ headers */
#include <algorithm>
+#include <map>
#include <set>
#include <vector>
-
-#if __GNUC__ == 4
- #include <tr1/unordered_map>
-
- namespace factor
- {
- using std::tr1::unordered_map;
- }
-#elif __GNUC__ == 3
- #include <boost/unordered_map.hpp>
-
- namespace factor
- {
- using boost::unordered_map;
- }
-#else
- #error Factor requires GCC 3.x or later
-#endif
+#include <iostream>
/* Forward-declare this since it comes up in function prototypes */
namespace factor
#include "bignumint.hpp"
#include "bignum.hpp"
#include "code_block.hpp"
-#include "zone.hpp"
+#include "bump_allocator.hpp"
+#include "bitwise_hacks.hpp"
+#include "mark_bits.hpp"
+#include "free_list.hpp"
+#include "free_list_allocator.hpp"
#include "write_barrier.hpp"
-#include "old_space.hpp"
+#include "object_start_map.hpp"
+#include "nursery_space.hpp"
#include "aging_space.hpp"
#include "tenured_space.hpp"
#include "data_heap.hpp"
+#include "code_heap.hpp"
#include "gc.hpp"
#include "debug.hpp"
#include "strings.hpp"
#include "words.hpp"
#include "float_bits.hpp"
#include "io.hpp"
-#include "mark_bits.hpp"
-#include "heap.hpp"
#include "image.hpp"
#include "alien.hpp"
-#include "code_heap.hpp"
#include "callbacks.hpp"
+#include "dispatch.hpp"
#include "vm.hpp"
#include "allot.hpp"
#include "tagged.hpp"
-#include "local_roots.hpp"
+#include "data_roots.hpp"
+#include "code_roots.hpp"
+#include "slot_visitor.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "nursery_collector.hpp"
#include "aging_collector.hpp"
#include "to_tenured_collector.hpp"
+#include "code_block_visitor.hpp"
+#include "compaction.hpp"
#include "full_collector.hpp"
#include "callstack.hpp"
#include "generic_arrays.hpp"
#include "byte_arrays.hpp"
#include "jit.hpp"
#include "quotations.hpp"
-#include "dispatch.hpp"
#include "inline_cache.hpp"
#include "factor.hpp"
#include "utilities.hpp"
}
}
-VM_C_API fixnum to_fixnum(cell tagged,factor_vm *parent)
+VM_C_API fixnum to_fixnum(cell tagged, factor_vm *parent)
{
return parent->to_fixnum(tagged);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_1(s8 n,factor_vm *parent)
+VM_C_API void box_signed_1(s8 n, factor_vm *parent)
{
return parent->box_signed_1(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n,factor_vm *parent)
+VM_C_API void box_unsigned_1(u8 n, factor_vm *parent)
{
return parent->box_unsigned_1(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n,factor_vm *parent)
+VM_C_API void box_signed_2(s16 n, factor_vm *parent)
{
return parent->box_signed_2(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n,factor_vm *parent)
+VM_C_API void box_unsigned_2(u16 n, factor_vm *parent)
{
return parent->box_unsigned_2(n);
}
dpush(allot_integer(n));
}
-VM_C_API void box_signed_4(s32 n,factor_vm *parent)
+VM_C_API void box_signed_4(s32 n, factor_vm *parent)
{
return parent->box_signed_4(n);
}
dpush(allot_cell(n));
}
-VM_C_API void box_unsigned_4(u32 n,factor_vm *parent)
+VM_C_API void box_unsigned_4(u32 n, factor_vm *parent)
{
return parent->box_unsigned_4(n);
}
dpush(allot_integer(integer));
}
-VM_C_API void box_signed_cell(fixnum integer,factor_vm *parent)
+VM_C_API void box_signed_cell(fixnum integer, factor_vm *parent)
{
return parent->box_signed_cell(integer);
}
dpush(allot_cell(cell));
}
-VM_C_API void box_unsigned_cell(cell cell,factor_vm *parent)
+VM_C_API void box_unsigned_cell(cell cell, factor_vm *parent)
{
return parent->box_unsigned_cell(cell);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_8(s64 n,factor_vm *parent)
+VM_C_API void box_signed_8(s64 n, factor_vm *parent)
{
return parent->box_signed_8(n);
}
}
}
-VM_C_API s64 to_signed_8(cell obj,factor_vm *parent)
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
{
return parent->to_signed_8(obj);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_8(u64 n,factor_vm *parent)
+VM_C_API void box_unsigned_8(u64 n, factor_vm *parent)
{
return parent->box_unsigned_8(n);
}
}
}
-VM_C_API u64 to_unsigned_8(cell obj,factor_vm *parent)
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
{
return parent->to_unsigned_8(obj);
}
return untag_float_check(value);
}
-VM_C_API float to_float(cell value,factor_vm *parent)
+VM_C_API float to_float(cell value, factor_vm *parent)
{
return parent->to_float(value);
}
dpush(allot_float(flo));
}
-VM_C_API void box_double(double flo,factor_vm *parent)
+VM_C_API void box_double(double flo, factor_vm *parent)
{
return parent->box_double(flo);
}
return untag_float_check(value);
}
-VM_C_API double to_double(cell value,factor_vm *parent)
+VM_C_API double to_double(cell value, factor_vm *parent)
{
return parent->to_double(value);
}
nursery_collector::nursery_collector(factor_vm *parent_) :
copying_collector<aging_space,nursery_policy>(
parent_,
- &parent_->gc_stats.nursery_stats,
parent_->data->aging,
nursery_policy(parent_)) {}
collector.trace_roots();
collector.trace_contexts();
+
+ current_gc->event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_nursery,
simple_unmarker(card_points_to_nursery));
collector.trace_cards(data->aging,
card_points_to_nursery,
- simple_unmarker(card_mark_mask));
+ 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_nursery);
+ current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+
collector.cheneys_algorithm();
+
+ current_gc->event->started_code_sweep();
update_code_heap_for_minor_gc(&code->points_to_nursery);
+ current_gc->event->ended_code_sweep();
- nursery.here = nursery.start;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
}
struct nursery_policy {
factor_vm *parent;
- nursery_policy(factor_vm *parent_) : parent(parent_) {}
+ explicit nursery_policy(factor_vm *parent_) : parent(parent_) {}
- bool should_copy_p(object *untagged)
+ bool should_copy_p(object *obj)
{
- return parent->nursery.contains_p(untagged);
+ return parent->nursery.contains_p(obj);
}
+
+ void promoted_object(object *obj) {}
+
+ void visited_object(object *obj) {}
};
struct nursery_collector : copying_collector<aging_space,nursery_policy> {
- nursery_collector(factor_vm *parent_);
+ explicit nursery_collector(factor_vm *parent_);
};
}
--- /dev/null
+namespace factor
+{
+
+struct nursery_space : bump_allocator<object>
+{
+ explicit nursery_space(cell size, cell start) : bump_allocator<object>(size,start) {}
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+object_start_map::object_start_map(cell size_, cell start_) :
+ size(size_), start(start_)
+{
+ object_start_offsets = new card[addr_to_card(size_)];
+ object_start_offsets_end = object_start_offsets + addr_to_card(size_);
+ clear_object_start_offsets();
+}
+
+object_start_map::~object_start_map()
+{
+ delete[] object_start_offsets;
+}
+
+cell object_start_map::first_object_in_card(cell card_index)
+{
+ return object_start_offsets[card_index];
+}
+
+cell object_start_map::find_object_containing_card(cell card_index)
+{
+ if(card_index == 0)
+ return start;
+ else
+ {
+ card_index--;
+
+ while(first_object_in_card(card_index) == card_starts_inside_object)
+ {
+#ifdef FACTOR_DEBUG
+ /* First card should start with an object */
+ assert(card_index > 0);
+#endif
+ card_index--;
+ }
+
+ return start + (card_index << card_bits) + first_object_in_card(card_index);
+ }
+}
+
+/* we need to remember the first object allocated in the card */
+void object_start_map::record_object_start_offset(object *obj)
+{
+ cell idx = addr_to_card((cell)obj - start);
+ card obj_start = ((cell)obj & addr_card_mask);
+ object_start_offsets[idx] = std::min(object_start_offsets[idx],obj_start);
+}
+
+void object_start_map::clear_object_start_offsets()
+{
+ memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
+}
+
+void object_start_map::update_card_for_sweep(cell index, u16 mask)
+{
+ cell offset = object_start_offsets[index];
+ if(offset != card_starts_inside_object)
+ {
+ mask >>= (offset / block_granularity);
+
+ if(mask == 0)
+ {
+ /* The rest of the block after the old object start is free */
+ object_start_offsets[index] = card_starts_inside_object;
+ }
+ else
+ {
+ /* Move the object start forward if necessary */
+ object_start_offsets[index] = offset + (rightmost_set_bit(mask) * block_granularity);
+ }
+ }
+}
+
+void object_start_map::update_for_sweep(mark_bits<object> *state)
+{
+ for(cell index = 0; index < state->bits_size; index++)
+ {
+ u64 mask = state->marked[index];
+ update_card_for_sweep(index * 4, mask & 0xffff);
+ update_card_for_sweep(index * 4 + 1, (mask >> 16) & 0xffff);
+ update_card_for_sweep(index * 4 + 2, (mask >> 32) & 0xffff);
+ update_card_for_sweep(index * 4 + 3, (mask >> 48) & 0xffff);
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell card_starts_inside_object = 0xff;
+
+struct object_start_map {
+ cell size, start;
+ card *object_start_offsets;
+ card *object_start_offsets_end;
+
+ explicit object_start_map(cell size_, cell start_);
+ ~object_start_map();
+
+ cell first_object_in_card(cell card_index);
+ cell find_object_containing_card(cell card_index);
+ void record_object_start_offset(object *obj);
+ void clear_object_start_offsets();
+ void update_card_for_sweep(cell index, u16 mask);
+ void update_for_sweep(mark_bits<object> *state);
+};
+
+}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-old_space::old_space(cell size_, cell start_) : zone(size_,start_)
-{
- object_start_offsets = new card[addr_to_card(size_)];
- object_start_offsets_end = object_start_offsets + addr_to_card(size_);
-}
-
-old_space::~old_space()
-{
- delete[] object_start_offsets;
-}
-
-cell old_space::first_object_in_card(cell card_index)
-{
- return object_start_offsets[card_index];
-}
-
-cell old_space::find_object_containing_card(cell card_index)
-{
- if(card_index == 0)
- return start;
- else
- {
- card_index--;
-
- while(first_object_in_card(card_index) == card_starts_inside_object)
- {
-#ifdef FACTOR_DEBUG
- /* First card should start with an object */
- assert(card_index > 0);
-#endif
- card_index--;
- }
-
- return start + (card_index << card_bits) + first_object_in_card(card_index);
- }
-}
-
-/* we need to remember the first object allocated in the card */
-void old_space::record_object_start_offset(object *obj)
-{
- cell idx = addr_to_card((cell)obj - start);
- if(object_start_offsets[idx] == card_starts_inside_object)
- object_start_offsets[idx] = ((cell)obj & addr_card_mask);
-}
-
-object *old_space::allot(cell size)
-{
- if(here + size > end) return NULL;
-
- object *obj = zone::allot(size);
- record_object_start_offset(obj);
- return obj;
-}
-
-void old_space::clear_object_start_offsets()
-{
- memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
-}
-
-cell old_space::next_object_after(factor_vm *parent, cell scan)
-{
- cell size = parent->untagged_object_size((object *)scan);
- if(scan + size < here)
- return scan + size;
- else
- return 0;
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell card_starts_inside_object = 0xff;
-
-struct old_space : zone {
- card *object_start_offsets;
- card *object_start_offsets_end;
-
- old_space(cell size_, cell start_);
- ~old_space();
-
- cell first_object_in_card(cell card_index);
- cell find_object_containing_card(cell card_index);
- void record_object_start_offset(object *obj);
- object *allot(cell size);
- void clear_object_start_offsets();
- cell next_object_after(factor_vm *parent, cell scan);
-};
-
-}
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(false_object,(cell)localException));
- quot = userenv[COCOA_EXCEPTION_ENV];
+ quot = special_objects[OBJ_COCOA_EXCEPTION];
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{
/* No Cocoa exception handler was registered, so
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define print_native_string(string) wprintf(L"%s",string)
-
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
PRIMITIVE_FORWARD(minor_gc)
PRIMITIVE_FORWARD(full_gc)
PRIMITIVE_FORWARD(compact_gc)
-PRIMITIVE_FORWARD(gc_stats)
PRIMITIVE_FORWARD(save_image)
PRIMITIVE_FORWARD(save_image_and_exit)
PRIMITIVE_FORWARD(datastack)
PRIMITIVE_FORWARD(resize_byte_array)
PRIMITIVE_FORWARD(dll_validp)
PRIMITIVE_FORWARD(unimplemented)
-PRIMITIVE_FORWARD(clear_gc_stats)
PRIMITIVE_FORWARD(jit_compile)
PRIMITIVE_FORWARD(load_locals)
PRIMITIVE_FORWARD(check_datastack)
PRIMITIVE_FORWARD(lookup_method)
PRIMITIVE_FORWARD(reset_dispatch_stats)
PRIMITIVE_FORWARD(dispatch_stats)
-PRIMITIVE_FORWARD(reset_inline_cache_stats)
-PRIMITIVE_FORWARD(inline_cache_stats)
PRIMITIVE_FORWARD(optimized_p)
PRIMITIVE_FORWARD(quot_compiled_p)
PRIMITIVE_FORWARD(vm_ptr)
PRIMITIVE_FORWARD(strip_stack_traces)
PRIMITIVE_FORWARD(callback)
+PRIMITIVE_FORWARD(enable_gc_events)
+PRIMITIVE_FORWARD(disable_gc_events)
const primitive_type primitives[] = {
primitive_bignum_to_fixnum,
primitive_minor_gc,
primitive_full_gc,
primitive_compact_gc,
- primitive_gc_stats,
primitive_save_image,
primitive_save_image_and_exit,
primitive_datastack,
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
- primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
primitive_check_datastack,
primitive_lookup_method,
primitive_reset_dispatch_stats,
primitive_dispatch_stats,
- primitive_reset_inline_cache_stats,
- primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
primitive_vm_ptr,
primitive_strip_stack_traces,
primitive_callback,
+ primitive_enable_gc_events,
+ primitive_disable_gc_events,
};
}
/* Allocates memory */
code_block *factor_vm::compile_profiling_stub(cell word_)
{
- gc_root<word> word(word_,this);
+ data_root<word> word(word_,this);
- jit jit(WORD_TYPE,word.value(),this);
- jit.emit_with(userenv[JIT_PROFILING],word.value());
+ jit jit(code_block_profiling,word.value(),this);
+ jit.emit_with(special_objects[JIT_PROFILING],word.value());
return jit.to_code_block();
}
and allocate profiling blocks if necessary */
primitive_full_gc();
-
gc_root<array> words(find_all_words(),this);
+
data_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
tagged<word> word(array_nth(words.untagged(),i));
if(profiling)
word->counter = tag_fixnum(0);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
update_code_heap_words();
/* Simple non-optimizing compiler.
This is one of the two compilers implementing Factor; the second one is written
-in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+in Factor and performs advanced optimizations. See basis/compiler/compiler.factor.
The non-optimizing compiler compiles a quotation at a time by concatenating
machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
-code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+code chunks are generated from Factor code in basis/cpu/.../bootstrap.factor.
Calls to words and constant quotations (referenced by conditionals and dips)
are direct jumps to machine code blocks. Literals are also referenced directly
bool quotation_jit::primitive_call_p(cell i, cell length)
{
- return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_PRIMITIVE_WORD];
+ return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i, cell length)
{
return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == parent->userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == parent->special_objects[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_2DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_3DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i, cell length)
return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == parent->userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == parent->special_objects[MEGA_LOOKUP_WORD];
}
bool quotation_jit::declare_p(cell i, cell length)
{
return (i + 2) <= length
- && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DECLARE_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(!parent->to_boolean(parent->untag<word>(obj)->subprimitive))
+ if(!parent->to_boolean(untag<word>(obj)->subprimitive))
return true;
break;
case QUOTATION_TYPE:
void quotation_jit::emit_quot(cell quot_)
{
- gc_root<quotation> quot(quot_,parent);
+ data_root<quotation> quot(quot_,parent);
- array *elements =
parent->untag<array>(quot->array);
+ array *elements = untag<array>(quot->array);
/* If the quotation consists of a single word, compile a direct call
to the word. */
set_position(0);
if(stack_frame)
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i),parent);
+ data_root<object> obj(array_nth(elements.untagged(),i),parent);
switch(obj.type())
{
if(parent->to_boolean(obj.as<word>()->subprimitive))
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == parent->userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == parent->special_objects[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
else
- emit(parent->userenv[JIT_EXECUTE_CALL]);
+ emit(parent->special_objects[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == parent->userenv[PIC_MISS_WORD]
- || obj.value() == parent->userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == parent->special_objects[PIC_MISS_WORD]
+ || obj.value() == parent->special_objects[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
{
literal(tag_fixnum(0));
literal(obj.value());
- emit(parent->userenv[JIT_PRIMITIVE]);
+ emit(parent->special_objects[JIT_PRIMITIVE]);
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i,length))
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
emit_quot(array_nth(elements.untagged(),i));
emit_quot(array_nth(elements.untagged(),i + 1));
- emit(parent->userenv[JIT_IF]);
+ emit(parent->special_objects[JIT_IF]);
i += 2;
}
else if(fast_dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_DIP]);
+ emit(parent->special_objects[JIT_DIP]);
i++;
}
/* 2dip */
else if(fast_2dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_2DIP]);
+ emit(parent->special_objects[JIT_2DIP]);
i++;
}
/* 3dip */
else if(fast_3dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_3DIP]);
+ emit(parent->special_objects[JIT_3DIP]);
i++;
}
else
set_position(length);
if(stack_frame)
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_RETURN]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_RETURN]);
}
}
void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
- assert(code->type() == QUOTATION_TYPE);
quot->code = code;
quot->xt = code->xt();
}
/* Allocates memory */
void factor_vm::jit_compile(cell quot_, bool relocating)
{
- gc_root<quotation> quot(quot_,this);
+ data_root<quotation> quot(quot_,this);
if(quot->code) return;
quotation_jit compiler(quot.value(),true,relocating,this);
void factor_vm::compile_all_words()
{
-
gc_root<array> words(find_all_words(),this);
+
data_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
for(i = 0; i < length; i++)
{
- gc_root<word> word(array_nth(words.untagged(),i),this);
+ data_root<word> word(array_nth(words.untagged(),i),this);
- if(!word->code || !word_optimized_p(word.untagged()))
+ if(!word->code || !word->code->optimized_p())
jit_compile_word(word.value(),word->def,false);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
/* Allocates memory */
fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
{
- gc_root<quotation> quot(quot_,this);
-
gc_root<array> array(quot->array,this);
+ data_root<quotation> quot(quot_,this);
+
data_root<array> array(quot->array,this);
quotation_jit compiler(quot.value(),false,false,this);
compiler.compute_position(offset);
cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
- gc_root<quotation> quot(quot_,this);
+ data_root<quotation> quot(quot_,this);
ctx->callstack_top = stack;
jit_compile(quot.value(),true);
return quot.value();
{
struct quotation_jit : public jit {
-
gc_root<array> elements;
+
data_root<array> elements;
bool compiling, relocate;
explicit quotation_jit(cell quot, bool compiling_, bool relocate_, factor_vm *vm)
- : jit(QUOTATION_TYPE,quot,vm),
+ : jit(code_block_unoptimized,quot,vm),
elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
relocate(relocate_){};
void factor_vm::primitive_getenv()
{
fixnum e = untag_fixnum(dpeek());
- drepl(userenv[e]);
+ drepl(special_objects[e]);
}
void factor_vm::primitive_setenv()
{
fixnum e = untag_fixnum(dpop());
cell value = dpop();
- userenv[e] = value;
+ special_objects[e] = value;
}
void factor_vm::primitive_exit()
cell factor_vm::clone_object(cell obj_)
{
- gc_root<object> obj(obj_,this);
+ data_root<object> obj(obj_,this);
if(immediate_p(obj.value()))
return obj.value();
namespace factor
{
-#define USER_ENV 70
+static const cell special_object_count = 70;
enum special_object {
- NAMESTACK_ENV, /* used by library only */
- CATCHSTACK_ENV, /* used by library only, per-callback */
+ OBJ_NAMESTACK, /* used by library only */
+ OBJ_CATCHSTACK, /* used by library only, per-callback */
- CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
- WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
- CALLCC_1_ENV, /* used to pass the value in callcc1 */
+ OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
+ OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_CALLCC_1, /* used to pass the value in callcc1 */
- BREAK_ENV = 5, /* quotation called by throw primitive */
- ERROR_ENV, /* a marker consed onto kernel errors */
+ OBJ_BREAK = 5, /* quotation called by throw primitive */
+ OBJ_ERROR, /* a marker consed onto kernel errors */
- CELL_SIZE_ENV = 7, /* sizeof(cell) */
- CPU_ENV, /* CPU architecture */
- OS_ENV, /* operating system name */
+ OBJ_CELL_SIZE = 7, /* sizeof(cell) */
+ OBJ_CPU, /* CPU architecture */
+ OBJ_OS, /* operating system name */
- ARGS_ENV = 10, /* command line arguments */
- STDIN_ENV, /* stdin FILE* handle */
- STDOUT_ENV, /* stdout FILE* handle */
+ OBJ_ARGS = 10, /* command line arguments */
+ OBJ_STDIN, /* stdin FILE* handle */
+ OBJ_STDOUT, /* stdout FILE* handle */
- IMAGE_ENV = 13, /* image path name */
- EXECUTABLE_ENV, /* runtime executable path name */
+ OBJ_IMAGE = 13, /* image path name */
+ OBJ_EXECUTABLE, /* runtime executable path name */
- EMBEDDED_ENV = 15, /* are we embedded in another app? */
- EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ OBJ_EMBEDDED = 15, /* are we embedded in another app? */
+ OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
- COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
+ OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
- BOOT_ENV = 20, /* boot quotation */
- GLOBAL_ENV, /* global namespace */
+ OBJ_BOOT = 20, /* boot quotation */
+ OBJ_GLOBAL, /* global namespace */
/* Quotation compilation in quotations.c */
JIT_PROLOG = 23,
/* Polymorphic inline cache generation in inline_cache.c */
PIC_LOAD = 47,
PIC_TAG,
- PIC_HI_TAG,
PIC_TUPLE,
- PIC_HI_TAG_TUPLE,
PIC_CHECK_TAG,
- PIC_CHECK,
+ PIC_CHECK_TUPLE,
PIC_HIT,
PIC_MISS_WORD,
PIC_MISS_TAIL_WORD,
/* Megamorphic cache generation in dispatch.c */
MEGA_LOOKUP = 57,
MEGA_LOOKUP_WORD,
- MEGA_MISS_WORD,
+ MEGA_MISS_WORD,
- UNDEFINED_ENV = 60, /* default quotation for undefined words */
+ OBJ_UNDEFINED = 60, /* default quotation for undefined words */
- STDERR_ENV = 61, /* stderr FILE* handle */
+ OBJ_STDERR = 61, /* stderr FILE* handle */
- STAGE2_ENV = 62, /* have we bootstrapped? */
+ OBJ_STAGE2 = 62, /* have we bootstrapped? */
- CURRENT_THREAD_ENV = 63,
+ OBJ_CURRENT_THREAD = 63,
- THREADS_ENV = 64,
- RUN_QUEUE_ENV = 65,
- SLEEP_QUEUE_ENV = 66,
+ OBJ_THREADS = 64,
+ OBJ_RUN_QUEUE = 65,
+ OBJ_SLEEP_QUEUE = 66,
};
-#define FIRST_SAVE_ENV BOOT_ENV
-#define LAST_SAVE_ENV STAGE2_ENV
+#define OBJ_FIRST_SAVE OBJ_BOOT
+#define OBJ_LAST_SAVE OBJ_STAGE2
inline static bool save_env_p(cell i)
{
- return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV);
+ return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
}
}
--- /dev/null
+namespace factor
+{
+
+template<typename Visitor> struct slot_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit slot_visitor<Visitor>(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void visit_handle(cell *handle)
+ {
+ cell pointer = *handle;
+
+ if(immediate_p(pointer)) return;
+
+ object *untagged = untag<object>(pointer);
+ untagged = visitor(untagged);
+ *handle = RETAG(untagged,TAG(pointer));
+ }
+
+ void visit_slots(object *ptr, cell payload_start)
+ {
+ cell *slot = (cell *)ptr;
+ cell *end = (cell *)((cell)ptr + payload_start);
+
+ if(slot != end)
+ {
+ slot++;
+ for(; slot < end; slot++) visit_handle(slot);
+ }
+ }
+
+ void visit_slots(object *ptr)
+ {
+ visit_slots(ptr,ptr->binary_payload_start());
+ }
+
+ void visit_stack_elements(segment *region, cell *top)
+ {
+ for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
+ visit_handle(ptr);
+ }
+
+ void visit_data_roots()
+ {
+ std::vector<cell>::const_iterator iter = parent->data_roots.begin();
+ std::vector<cell>::const_iterator end = parent->data_roots.end();
+
+ for(; iter < end; iter++)
+ visit_handle((cell *)(*iter));
+ }
+
+ void visit_bignum_roots()
+ {
+ std::vector<cell>::const_iterator iter = parent->bignum_roots.begin();
+ std::vector<cell>::const_iterator end = parent->bignum_roots.end();
+
+ for(; iter < end; iter++)
+ {
+ cell *handle = (cell *)(*iter);
+
+ if(*handle)
+ *handle = (cell)visitor(*(object **)handle);
+ }
+ }
+
+ void visit_roots()
+ {
+ visit_handle(&parent->true_object);
+ visit_handle(&parent->bignum_zero);
+ visit_handle(&parent->bignum_pos_one);
+ visit_handle(&parent->bignum_neg_one);
+
+ visit_data_roots();
+ visit_bignum_roots();
+
+ for(cell i = 0; i < special_object_count; i++)
+ visit_handle(&parent->special_objects[i]);
+ }
+
+ void visit_contexts()
+ {
+ context *ctx = parent->ctx;
+
+ while(ctx)
+ {
+ visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
+ visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+
+ visit_handle(&ctx->catchstack_save);
+ visit_handle(&ctx->current_callback_save);
+
+ ctx = ctx->next;
+ }
+ }
+
+ void visit_literal_references(code_block *compiled)
+ {
+ visit_handle(&compiled->owner);
+ visit_handle(&compiled->literals);
+ visit_handle(&compiled->relocation);
+ }
+};
+
+}
namespace factor
{
-cell factor_vm::string_nth(string* str, cell index)
+cell string::nth(cell index) const
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
corresponding aux vector entry is negated, so that we can
XOR the two components together and get the original code point
back. */
- cell lo_bits = str->data()[index];
+ cell lo_bits = data()[index];
if((lo_bits & 0x80) == 0)
return lo_bits;
else
{
- byte_array *aux = untag<byte_array>(str->aux);
+ byte_array *aux = untag<byte_array>(this->aux);
cell hi_bits = aux->data<u16>()[index];
return (hi_bits << 7) ^ lo_bits;
}
void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
byte_array *aux;
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
- aux = allot_array_internal<byte_array>(untag_fixnum(str->length) * sizeof(u16));
+ aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
str->aux = tag<byte_array>(aux);
write_barrier(&str->aux);
/* Allocates memory */
void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
if(fill <= 0x7f)
memset(&str->data()[start],fill,capacity - start);
/* Allocates memory */
string *factor_vm::allot_string(cell capacity, cell fill)
{
- gc_root<string> str(allot_string_internal(capacity),this);
+ data_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
string* factor_vm::reallot_string(string *str_, cell capacity)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
if(reallot_string_in_place_p(str.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- gc_root<string> new_str(allot_string_internal(capacity),this);
+ data_root<string> new_str(allot_string_internal(capacity),this);
memcpy(new_str->data(),str->data(),to_copy);
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
- dpush(tag_fixnum(string_nth(str,index)));
+ dpush(tag_fixnum(str->nth(index)));
}
void factor_vm::primitive_set_string_nth_fast()
namespace factor
{
-inline static cell string_capacity(string *str)
+inline static cell string_capacity(const string *str)
{
return untag_fixnum(str->length);
}
template<typename Type> cell tag(Type *value)
{
- return RETAG(value,tag_for(Type::type_number));
+ return RETAG(value,Type::type_number);
}
inline static cell tag_dynamic(object *value)
{
- return RETAG(value,tag_for(value->h.hi_tag()));
+ return RETAG(value,value->h.hi_tag());
}
template<typename Type>
{
cell value_;
- cell value() const { return value_; }
- Type *untagged() const { return (Type *)(UNTAG(value_)); }
-
- cell type() const {
- cell tag = TAG(value_);
- if(tag == OBJECT_TYPE)
- return untagged()->h.hi_tag();
- else
- return tag;
+ cell type() const
+ {
+ return TAG(value_);
}
- bool type_p(cell type_) const { return type() == type_; }
+ bool type_p(cell type_) const
+ {
+ return type() == type_;
+ }
- Type *untag_check(factor_vm *parent) const {
- if(Type::type_number != TYPE_COUNT && !type_p(Type::type_number))
- parent->type_error(Type::type_number,value_);
- return untagged();
+ bool type_p() const
+ {
+ if(Type::type_number == TYPE_COUNT)
+ return true;
+ else
+ return type_p(Type::type_number);
}
- explicit tagged(cell tagged) : value_(tagged) {
+ cell value() const
+ {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return value_;
}
- explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {
+ Type *untagged() const
+ {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return (Type *)(UNTAG(value_));
}
+ Type *untag_check(factor_vm *parent) const
+ {
+ if(!type_p())
+ parent->type_error(Type::type_number,value_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {}
+ explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {}
+
Type *operator->() const { return untagged(); }
cell *operator&() const { return &value_; }
return tagged<Type>(value).untag_check(this);
}
-template<typename Type> Type *factor_vm::untag(cell value)
+template<typename Type> Type *untag(cell value)
{
return tagged<Type>(value).untagged();
}
namespace factor
{
-struct tenured_space : old_space {
- tenured_space(cell size, cell start) : old_space(size,start) {}
+struct tenured_space : free_list_allocator<object> {
+ object_start_map starts;
+ std::vector<object *> mark_stack;
+
+ explicit tenured_space(cell size, cell start) :
+ free_list_allocator<object>(size,start), starts(size,start) {}
+
+ object *allot(cell size)
+ {
+ object *obj = free_list_allocator<object>::allot(size);
+ if(obj)
+ {
+ starts.record_object_start_offset(obj);
+ return obj;
+ }
+ else
+ return NULL;
+ }
+
+ cell first_object()
+ {
+ return (cell)next_allocated_block_after(this->first_block());
+ }
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((object *)scan)->size();
+ object *next = (object *)(scan + size);
+ return (cell)next_allocated_block_after(next);
+ }
+
+ void clear_mark_bits()
+ {
+ state.clear_mark_bits();
+ }
+
+ void clear_mark_stack()
+ {
+ mark_stack.clear();
+ }
+
+ bool marked_p(object *obj)
+ {
+ return this->state.marked_p(obj);
+ }
+
+ void mark_and_push(object *obj)
+ {
+ this->state.set_marked_p(obj);
+ this->mark_stack.push_back(obj);
+ }
+
+ void sweep()
+ {
+ free_list_allocator<object>::sweep();
+ starts.update_for_sweep(&this->state);
+ }
};
}
{
to_tenured_collector::to_tenured_collector(factor_vm *myvm_) :
- copying_collector<tenured_space,to_tenured_policy>(
+ collector<tenured_space,to_tenured_policy>(
myvm_,
- &myvm_->gc_stats.aging_stats,
myvm_->data->tenured,
to_tenured_policy(myvm_)) {}
+void to_tenured_collector::tenure_reachable_objects()
+{
+ std::vector<object *> *mark_stack = &this->target->mark_stack;
+ while(!mark_stack->empty())
+ {
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ this->trace_object(obj);
+ }
+}
+
void factor_vm::collect_to_tenured()
{
/* Copy live objects from aging space to tenured space. */
to_tenured_collector collector(this);
+ data->tenured->clear_mark_stack();
+
collector.trace_roots();
collector.trace_contexts();
+
+ current_gc->event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
- dummy_unmarker());
+ 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);
- collector.cheneys_algorithm();
+ 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();
- nursery.here = nursery.start;
- reset_generation(data->aging);
- code->points_to_nursery.clear();
- code->points_to_aging.clear();
+ data->reset_generation(&nursery);
+ data->reset_generation(data->aging);
+ code->clear_remembered_set();
}
}
struct to_tenured_policy {
factor_vm *myvm;
- zone *tenured;
+ tenured_space *tenured;
- to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
+ explicit to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_stack.push_back(obj);
+ }
+
+ void visited_object(object *obj) {}
};
-struct to_tenured_collector : copying_collector<tenured_space,to_tenured_policy> {
- to_tenured_collector(factor_vm *myvm_);
+struct to_tenured_collector : collector<tenured_space,to_tenured_policy> {
+ explicit to_tenured_collector(factor_vm *myvm_);
+ void tenure_reachable_objects();
};
}
/* push a new tuple on the stack, filling its slots with f */
void factor_vm::primitive_tuple()
{
- gc_root<tuple_layout> layout(dpop(),this);
+ data_root<tuple_layout> layout(dpop(),this);
tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
t->layout = layout.value();
/* push a new tuple on the stack, filling its slots from the stack */
void factor_vm::primitive_tuple_boa()
{
- gc_root<tuple_layout> layout(dpop(),this);
+ data_root<tuple_layout> layout(dpop(),this);
tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
t->layout = layout.value();
namespace factor
{
-inline static cell tuple_size(tuple_layout *layout)
+inline static cell tuple_size(const tuple_layout *layout)
{
cell size = untag_fixnum(layout->size);
return sizeof(tuple) + size * sizeof(cell);
return ptr;
}
-/* We don't use printf directly, because format directives are not portable.
-Instead we define the common cases here. */
-void nl()
-{
- fputs("\n",stdout);
-}
-
-void print_string(const char *str)
-{
- fputs(str,stdout);
-}
-
-void print_cell(cell x)
-{
- printf(CELL_FORMAT,x);
-}
-
-void print_cell_hex(cell x)
-{
- printf(CELL_HEX_FORMAT,x);
-}
-
-void print_cell_hex_pad(cell x)
-{
- printf(CELL_HEX_PAD_FORMAT,x);
-}
-
-void print_fixnum(fixnum x)
-{
- printf(FIXNUM_FORMAT,x);
-}
-
cell read_cell_hex()
{
cell cell;
}
vm_char *safe_strdup(const vm_char *str);
-void print_string(const char *str);
-void nl();
-void print_cell(cell x);
-void print_cell_hex(cell x);
-void print_cell_hex_pad(cell x);
-void print_fixnum(fixnum x);
cell read_cell_hex();
}
factor_vm::factor_vm() :\r
nursery(0,0),\r
profiling_p(false),\r
- secure_gc(false),\r
gc_off(false),\r
current_gc(NULL),\r
+ gc_events(NULL),\r
fep_disabled(false),\r
full_output(false)\r
- { }\r
+{\r
+ primitive_reset_dispatch_stats();\r
+}\r
\r
}\r
{
struct growable_array;
+struct code_root;
struct factor_vm
{
context *ctx;
/* New objects are allocated here */
- zone nursery;
+ nursery_space nursery;
/* Add this to a shifted address to compute write barrier offsets */
cell cards_offset;
cell decks_offset;
/* TAGGED user environment data; see getenv/setenv prims */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
cell ds_size, rs_size;
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
- /* Zeroes out deallocated memory; set by the -securegc command line argument */
- bool secure_gc;
-
/* A heap walk allows useful things to be done, like finding all
references to an object for debugging purposes. */
cell heap_scan_ptr;
/* Only set if we're performing a GC */
gc_state *current_gc;
- /* Statistics */
- gc_statistics gc_stats;
+ /* If not NULL, we push GC events here */
+ std::vector<gc_event> *gc_events;
/* If a runtime function needs to call another function which potentially
- allocates memory, it must wrap any local variable references to Factor
- objects in gc_root instances */
- std::vector<cell> gc_locals;
- std::vector<cell> gc_bignums;
+ allocates memory, it must wrap any references to the data and code
+ heaps with data_root and code_root smart pointers, which register
+ themselves here. See data_roots.hpp and code_roots.hpp */
+ std::vector<cell> data_roots;
+ std::vector<cell> bignum_roots;
+ std::vector<code_root *> code_roots;
/* Debugger */
bool fep_disabled;
cell bignum_neg_one;
/* Method dispatch statistics */
- cell megamorphic_cache_hits;
- cell megamorphic_cache_misses;
-
- cell cold_call_to_ic_transitions;
- cell ic_to_pic_transitions;
- cell pic_to_mega_transitions;
- /* Indexed by PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- cell pic_counts[4];
+ dispatch_statistics dispatch_stats;
/* Number of entries in a polymorphic inline cache */
cell max_pic_size;
//data heap
void init_card_decks();
- void clear_cards(old_space *gen);
- void clear_decks(old_space *gen);
- void reset_generation(old_space *gen);
void set_data_heap(data_heap *data_);
- void init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_);
- cell untagged_object_size(object *pointer);
- cell unaligned_object_size(object *pointer);
+ void init_data_heap(cell young_size, cell aging_size, cell tenured_size);
void primitive_size();
- cell binary_payload_start(object *pointer);
+ data_heap_room data_room();
void primitive_data_room();
void begin_scan();
void end_scan();
cell next_object();
void primitive_next_object();
void primitive_end_scan();
- template<typename Iterator> void each_object(Iterator &iterator);
cell find_all_words();
cell object_size(cell tagged);
+ template<typename Iterator> inline void each_object(Iterator &iterator)
+ {
+ begin_scan();
+ cell obj;
+ while(to_boolean(obj = next_object()))
+ iterator(obj);
+ end_scan();
+ }
+
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
inline void write_barrier(cell *slot_ptr)
}
// gc
+ void end_gc();
+ void start_gc_again();
void update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set);
void collect_nursery();
void collect_aging();
void collect_to_tenured();
- void collect_full_impl(bool trace_contexts_p);
- void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
- void collect_full(bool trace_contexts_p, bool compact_code_heap_p);
- void record_gc_stats(generation_statistics *stats);
- void gc(gc_op op, cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
+ void update_code_roots_for_sweep();
+ void update_code_roots_for_compaction();
+ void collect_mark_impl(bool trace_contexts_p);
+ void collect_sweep_impl();
+ void collect_full(bool trace_contexts_p);
+ void collect_compact_impl(bool trace_contexts_p);
+ void collect_compact_code_impl(bool trace_contexts_p);
+ void collect_compact(bool trace_contexts_p);
+ void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
+ void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void primitive_gc_stats();
- void clear_gc_stats();
void primitive_become();
- void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+ void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void primitive_enable_gc_events();
+ void primitive_disable_gc_events();
object *allot_object(header header, cell size);
object *allot_large_object(header header, cell size);
- void add_gc_stats(generation_statistics *stats, growable_array *result);
- void primitive_clear_gc_stats();
template<typename Type> Type *allot(cell size)
{
#endif
}
- inline void check_tagged_pointer(cell tagged)
- {
- #ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
- #endif
- }
-
// generic arrays
- template<typename Array> Array *allot_array_internal(cell capacity);
+ template<typename Array> Array *allot_uninitialized_array(cell capacity);
template<typename Array> bool reallot_array_in_place_p(Array *array, cell capacity);
template<typename Array> Array *reallot_array(Array *array_, cell capacity);
void print_callstack();
void dump_cell(cell x);
void dump_memory(cell from, cell to);
- void dump_zone(const char *name, zone *z);
+ template<typename Generation> void dump_generation(const char *name, Generation *gen);
void dump_generations();
void dump_objects(cell type);
void find_data_references_step(cell *scan);
inline void set_array_nth(array *array, cell slot, cell value);
//strings
- cell string_nth(string* str, cell index);
+ cell string_nth(const string *str, cell index);
void set_string_nth_fast(string *str, cell index, cell ch);
void set_string_nth_slow(string *str_, cell index, cell ch);
void set_string_nth(string *str, cell index, cell ch);
void primitive_uninitialized_byte_array();
void primitive_resize_byte_array();
+ template<typename Type> byte_array *byte_array_from_value(Type *value);
+ template<typename Type> byte_array *byte_array_from_values(Type *values, cell len);
+
//tuples
void primitive_tuple();
void primitive_tuple_boa();
word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word();
void primitive_word_xt();
- void update_word_xt(cell w_);
+ void update_word_xt(word *w_);
void primitive_optimized_p();
void primitive_wrapper();
inline double untag_float_check(cell tagged);
inline fixnum float_to_fixnum(cell tagged);
inline double fixnum_to_float(cell tagged);
+
+ // tagged
template<typename Type> Type *untag_check(cell value);
- template<typename Type> Type *untag(cell value);
//io
void init_c_io();
void update_literal_references(code_block *compiled);
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
void update_word_references(code_block *compiled);
- void update_code_block_for_full_gc(code_block *compiled);
+ void update_code_block_words_and_literals(code_block *compiled);
void check_code_address(cell address);
void relocate_code_block(code_block *compiled);
void fixup_labels(array *labels, code_block *compiled);
- code_block *allot_code_block(cell size, cell type);
- code_block *add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
+ code_block *allot_code_block(cell size, code_block_type type);
+ code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
//code heap
inline void check_code_pointer(cell ptr)
bool in_code_heap_p(cell ptr);
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
+ void update_code_heap_words_and_literals();
+ void relocate_code_heap();
void primitive_modify_code_heap();
+ code_heap_room code_room();
void primitive_code_room();
- void forward_object_xts();
- void forward_context_xts();
- void forward_callback_xts();
- void compact_code_heap(bool trace_contexts_p);
void primitive_strip_stack_traces();
/* Apply a function to every code block */
template<typename Iterator> void iterate_code_heap(Iterator &iter)
{
- heap_block *scan = code->first_block();
-
- while(scan)
- {
- if(scan->type() != FREE_BLOCK_TYPE)
- iter((code_block *)scan);
- scan = code->next_block(scan);
- }
+ code->allocator->iterate(iter);
}
//callbacks
void primitive_callstack();
void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
- cell frame_type(stack_frame *frame);
+ code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
template<typename Iterator> void do_slots(cell obj, Iterator &iter)
{
cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
+ cell payload_start = ((object *)obj)->binary_payload_start();
cell end = obj + payload_start;
scan += sizeof(cell);
cell nth_superclass(tuple_layout *layout, fixnum echelon);
cell nth_hashcode(tuple_layout *layout, fixnum echelon);
cell lookup_tuple_method(cell obj, cell methods);
- cell lookup_hi_tag_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
void primitive_lookup_method();
cell object_class(cell obj);
cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- void primitive_reset_inline_cache_stats();
- void primitive_inline_cache_stats();
//factor
void default_parameters(vm_parameters *p);
};
-extern unordered_map<THREADHANDLE, factor_vm *> thread_vms;
+extern std::map<THREADHANDLE, factor_vm *> thread_vms;
}
word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
{
- gc_root<object> vocab(vocab_,this);
- gc_root<object> name(name_,this);
+ data_root<object> vocab(vocab_,this);
+ data_root<object> name(name_,this);
- gc_root<word> new_word(allot<word>(sizeof(word)),this);
+ data_root<word> new_word(allot<word>(sizeof(word)),this);
new_word->hashcode = hashcode_;
new_word->vocabulary = vocab.value();
new_word->name = name.value();
- new_word->def = userenv[UNDEFINED_ENV];
+ new_word->def = special_objects[OBJ_UNDEFINED];
new_word->props = false_object;
new_word->counter = tag_fixnum(0);
new_word->pic_def = false_object;
new_word->code = NULL;
jit_compile_word(new_word.value(),new_word->def,true);
- update_word_xt(new_word.value());
+ update_word_xt(new_word.untagged());
if(profiling_p)
relocate_code_block(new_word->profiling);
/* word-xt ( word -- start end ) */
void factor_vm::primitive_word_xt()
{
- gc_root<word> w(dpop(),this);
+ data_root<word> w(dpop(),this);
w.untag_check(this);
if(profiling_p)
}
/* Allocates memory */
-void factor_vm::update_word_xt(cell w_)
+void factor_vm::update_word_xt(word *w_)
{
- gc_root<word> w(w_,this);
+ data_root<word> w(w_,this);
if(profiling_p)
{
if(!w->profiling)
{
- /* Note: can't do w->profiling = ... since if LHS
- evaluates before RHS, since in that case if RHS does a
- GC, we will have an invalid pointer on the LHS */
+ /* Note: can't do w->profiling = ... since LHS evaluates
+ before RHS, and if RHS does a GC, we will have an
+ invalid pointer on the LHS */
code_block *profiling = compile_profiling_stub(w.value());
w->profiling = profiling;
}
void factor_vm::primitive_optimized_p()
{
- drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
+ word *w = untag_check<word>(dpeek());
+ drepl(tag_boolean(w->code->optimized_p()));
}
void factor_vm::primitive_wrapper()
namespace factor
{
-inline bool word_optimized_p(word *word)
-{
- return word->code->type() == WORD_TYPE;
-}
-
}
+++ /dev/null
-namespace factor
-{
-
-struct zone {
- /* offset of 'here' and 'end' is hardcoded in compiler backends */
- cell here;
- cell start;
- cell end;
- cell size;
-
- zone(cell size_, cell start_) : here(0), start(start_), end(start_ + size_), size(size_) {}
-
- inline bool contains_p(object *pointer)
- {
- return ((cell)pointer - start) < size;
- }
-
- inline object *allot(cell size)
- {
- cell h = here;
- here = h + align8(size);
- return (object *)h;
- }
-};
-
-}
projects / factor.git / commitdiff
