Merge branch 'master' into simd-cleanup
Conflicts: basis/math/vectors/simd/functor/functor.factordb4
Joe Groff
commit
75d04922b9
5
Makefile
5
Makefile
|
|
@ -41,22 +41,23 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
vm/callstack.o \
|
||||
vm/code_block.o \
|
||||
vm/code_heap.o \
|
||||
vm/compaction.o \
|
||||
vm/contexts.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
vm/dispatch.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
vm/free_list.o \
|
||||
vm/full_collector.o \
|
||||
vm/gc.o \
|
||||
vm/heap.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/math.o \
|
||||
vm/nursery_collector.o \
|
||||
vm/old_space.o \
|
||||
vm/object_start_map.o \
|
||||
vm/primitives.o \
|
||||
vm/profiler.o \
|
||||
vm/quotations.o \
|
||||
|
|
|
|||
|
|
@ -230,6 +230,10 @@ M: byte-array byte-length length ; inline
|
|||
|
||||
M: f byte-length drop 0 ; inline
|
||||
|
||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||
|
||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||
|
||||
MIXIN: value-type
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
|
|
@ -256,6 +260,7 @@ PREDICATE: typedef-word < c-type-word
|
|||
"c-type" word-prop c-type-name? ;
|
||||
|
||||
M: string typedef ( old new -- ) c-types get set-at ;
|
||||
|
||||
M: word typedef ( old new -- )
|
||||
{
|
||||
[ nip define-symbol ]
|
||||
|
|
@ -292,7 +297,7 @@ M: long-long-type box-return ( c-type -- )
|
|||
|
||||
: define-out ( name -- )
|
||||
[ "alien.c-types" constructor-word ]
|
||||
[ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
|
||||
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
|
||||
(( value -- c-ptr )) define-inline ;
|
||||
|
||||
: define-primitive-type ( c-type name -- )
|
||||
|
|
@ -338,7 +343,7 @@ SYMBOLS:
|
|||
[ alien-signed-8 ] >>getter
|
||||
[ set-alien-signed-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
cpu x86.32? os windows? not and 4 8 ? >>align
|
||||
"box_signed_8" >>boxer
|
||||
"to_signed_8" >>unboxer
|
||||
\ longlong define-primitive-type
|
||||
|
|
@ -349,7 +354,7 @@ SYMBOLS:
|
|||
[ alien-unsigned-8 ] >>getter
|
||||
[ set-alien-unsigned-8 ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
cpu x86.32? os windows? not and 4 8 ? >>align
|
||||
"box_unsigned_8" >>boxer
|
||||
"to_unsigned_8" >>unboxer
|
||||
\ ulonglong define-primitive-type
|
||||
|
|
@ -442,14 +447,24 @@ SYMBOLS:
|
|||
"to_cell" >>unboxer
|
||||
\ uchar define-primitive-type
|
||||
|
||||
cpu ppc? [
|
||||
<c-type>
|
||||
[ alien-unsigned-1 0 = not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
|
||||
[ alien-unsigned-4 c-bool> ] >>getter
|
||||
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
] [
|
||||
<c-type>
|
||||
[ alien-unsigned-1 c-bool> ] >>getter
|
||||
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
\ bool define-primitive-type
|
||||
] if
|
||||
|
||||
<c-type>
|
||||
math:float >>class
|
||||
|
|
@ -470,17 +485,24 @@ SYMBOLS:
|
|||
[ alien-double ] >>getter
|
||||
[ [ >float ] 2dip set-alien-double ] >>setter
|
||||
8 >>size
|
||||
8 >>align
|
||||
cpu x86.32? os windows? not and 4 8 ? >>align
|
||||
"box_double" >>boxer
|
||||
"to_double" >>unboxer
|
||||
double-rep >>rep
|
||||
[ >float ] >>unboxer-quot
|
||||
\ double define-primitive-type
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -65,10 +65,6 @@ M: memory-stream stream-read
|
|||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup byte-length memcpy ; inline
|
||||
|
||||
: >c-bool ( ? -- int ) 1 0 ? ; inline
|
||||
|
||||
: c-bool> ( int -- ? ) 0 = not ; inline
|
||||
|
||||
M: value-type c-type-rep drop int-rep ;
|
||||
|
||||
M: value-type c-type-getter
|
||||
|
|
@ -77,5 +73,3 @@ M: value-type c-type-getter
|
|||
M: value-type c-type-setter ( type -- quot )
|
||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -176,14 +176,12 @@ USERENV: callback-stub 45
|
|||
! PIC stubs
|
||||
USERENV: pic-load 47
|
||||
USERENV: pic-tag 48
|
||||
USERENV: pic-hi-tag 49
|
||||
USERENV: pic-tuple 50
|
||||
USERENV: pic-hi-tag-tuple 51
|
||||
USERENV: pic-check-tag 52
|
||||
USERENV: pic-check 53
|
||||
USERENV: pic-hit 54
|
||||
USERENV: pic-miss-word 55
|
||||
USERENV: pic-miss-tail-word 56
|
||||
USERENV: pic-tuple 49
|
||||
USERENV: pic-check-tag 50
|
||||
USERENV: pic-check-tuple 51
|
||||
USERENV: pic-hit 52
|
||||
USERENV: pic-miss-word 53
|
||||
USERENV: pic-miss-tail-word 54
|
||||
|
||||
! Megamorphic dispatch
|
||||
USERENV: mega-lookup 57
|
||||
|
|
@ -217,13 +215,18 @@ USERENV: undefined-quot 60
|
|||
|
||||
: here-as ( tag -- pointer ) here bitor ;
|
||||
|
||||
: (align-here) ( alignment -- )
|
||||
[ here neg ] dip rem
|
||||
[ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
|
||||
|
||||
: align-here ( -- )
|
||||
here 8 mod 4 = [ 0 emit ] when ;
|
||||
data-alignment get (align-here) ;
|
||||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
: emit-object ( class quot -- addr )
|
||||
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
|
||||
[ type-number ] dip over here-as
|
||||
[ swap tag-fixnum emit call align-here ] dip ;
|
||||
inline
|
||||
|
||||
! Write an object to the image.
|
||||
|
|
@ -292,7 +295,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
|||
M: float '
|
||||
[
|
||||
float [
|
||||
align-here double>bits emit-64
|
||||
8 (align-here) double>bits emit-64
|
||||
] emit-object
|
||||
] cache-eql-object ;
|
||||
|
||||
|
|
@ -304,7 +307,7 @@ M: float '
|
|||
|
||||
M: f '
|
||||
#! f is #define F RETAG(0,F_TYPE)
|
||||
drop \ f tag-number ;
|
||||
drop \ f type-number ;
|
||||
|
||||
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
|
||||
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
|
||||
|
|
@ -410,6 +413,7 @@ M: byte-array '
|
|||
[
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
bootstrap-cell 4 = [ 0 emit 0 emit ] when
|
||||
pad-bytes emit-bytes
|
||||
] emit-object
|
||||
] cache-eq-object ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ IN: bootstrap.tools
|
|||
"tools.deploy"
|
||||
"tools.destructors"
|
||||
"tools.disassembler"
|
||||
"tools.dispatch"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
"tools.test"
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ M: ##copy analyze-aliases*
|
|||
M: ##compare analyze-aliases*
|
||||
call-next-method
|
||||
dup useless-compare? [
|
||||
dst>> \ f tag-number \ ##load-immediate new-insn
|
||||
dst>> \ f type-number \ ##load-immediate new-insn
|
||||
analyze-aliases*
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -119,7 +119,6 @@ IN: compiler.cfg.builder.tests
|
|||
|
||||
{
|
||||
byte-array
|
||||
simple-alien
|
||||
alien
|
||||
POSTPONE: f
|
||||
} [| class |
|
||||
|
|
@ -192,7 +191,7 @@ IN: compiler.cfg.builder.tests
|
|||
] unit-test
|
||||
|
||||
[ f t ] [
|
||||
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
|
||||
[ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
|
||||
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
||||
[ [ ##unbox-alien? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
|
@ -205,7 +204,7 @@ IN: compiler.cfg.builder.tests
|
|||
] unit-test
|
||||
|
||||
[ f t ] [
|
||||
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
|
||||
[ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
|
||||
[ [ ##box-alien? ] contains-insn? ]
|
||||
[ [ ##allot? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ M: #recursive emit-node
|
|||
and ;
|
||||
|
||||
: emit-trivial-if ( -- )
|
||||
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
|
||||
ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
|
||||
|
||||
: trivial-not-if? ( #if -- ? )
|
||||
children>> first2
|
||||
|
|
@ -126,12 +126,12 @@ M: #recursive emit-node
|
|||
and ;
|
||||
|
||||
: emit-trivial-not-if ( -- )
|
||||
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
|
||||
ds-pop \ f type-number cc= ^^compare-imm ds-push ;
|
||||
|
||||
: emit-actual-if ( #if -- )
|
||||
! Inputs to the final instruction need to be copied because of
|
||||
! loc>vreg sync
|
||||
ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
|
||||
ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
|
||||
|
||||
M: #if emit-node
|
||||
{
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@ GENERIC: defs-vreg ( insn -- vreg/f )
|
|||
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
|
||||
|
|
@ -24,19 +28,25 @@ M: ##phi uses-vregs inputs>> values ;
|
|||
} case ;
|
||||
|
||||
: define-defs-vreg-method ( insn -- )
|
||||
dup insn-def-slot dup [
|
||||
[ \ defs-vreg create-method ]
|
||||
[ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
|
||||
define ;
|
||||
[ name>> reader-word 1quotation ] bi*
|
||||
define
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: define-uses-vregs-method ( insn -- )
|
||||
dup insn-use-slots [ drop ] [
|
||||
[ \ uses-vregs create-method ]
|
||||
[ insn-use-slots [ name>> ] map slot-array-quot ] bi
|
||||
define ;
|
||||
[ [ name>> ] map slot-array-quot ] bi*
|
||||
define
|
||||
] if-empty ;
|
||||
|
||||
: define-temp-vregs-method ( insn -- )
|
||||
dup insn-temp-slots [ drop ] [
|
||||
[ \ temp-vregs create-method ]
|
||||
[ insn-temp-slots [ name>> ] map slot-array-quot ] bi
|
||||
define ;
|
||||
[ [ name>> ] map slot-array-quot ] bi*
|
||||
define
|
||||
] if-empty ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs fry
|
||||
cpu.architecture layouts
|
||||
USING: accessors kernel sequences assocs fry math
|
||||
cpu.architecture layouts namespaces
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -21,12 +21,14 @@ GENERIC: allocation-size* ( insn -- n )
|
|||
|
||||
M: ##allot allocation-size* size>> ;
|
||||
|
||||
M: ##box-alien allocation-size* drop 4 cells ;
|
||||
M: ##box-alien allocation-size* drop 5 cells ;
|
||||
|
||||
M: ##box-displaced-alien allocation-size* drop 4 cells ;
|
||||
M: ##box-displaced-alien allocation-size* drop 5 cells ;
|
||||
|
||||
: allocation-size ( bb -- n )
|
||||
instructions>> [ ##allocation? ] filter [ allocation-size* ] map-sum ;
|
||||
instructions>>
|
||||
[ ##allocation? ] filter
|
||||
[ allocation-size* data-alignment get align ] map-sum ;
|
||||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup dup '[
|
||||
|
|
|
|||
|
|
@ -43,14 +43,14 @@ insn-classes get [
|
|||
|
||||
: ^^load-literal ( obj -- dst )
|
||||
[ next-vreg dup ] dip {
|
||||
{ [ dup not ] [ drop \ f tag-number ##load-immediate ] }
|
||||
{ [ dup not ] [ drop \ f type-number ##load-immediate ] }
|
||||
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
|
||||
{ [ dup float? ] [ ##load-constant ] }
|
||||
[ ##load-reference ]
|
||||
} cond ;
|
||||
|
||||
: ^^offset>slot ( slot -- vreg' )
|
||||
cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
|
||||
cell 4 = 2 1 ? ^^shr-imm ;
|
||||
|
||||
: ^^tag-fixnum ( src -- dst )
|
||||
tag-bits get ^^shl-imm ;
|
||||
|
|
|
|||
|
|
@ -512,13 +512,12 @@ temp: temp/int-rep ;
|
|||
PURE-INSN: ##box-displaced-alien
|
||||
def: dst/int-rep
|
||||
use: displacement/int-rep base/int-rep
|
||||
temp: temp1/int-rep temp2/int-rep
|
||||
temp: temp/int-rep
|
||||
literal: base-class ;
|
||||
|
||||
PURE-INSN: ##unbox-any-c-ptr
|
||||
def: dst/int-rep
|
||||
use: src/int-rep
|
||||
temp: temp/int-rep ;
|
||||
use: src/int-rep ;
|
||||
|
||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||
|
|
@ -527,12 +526,12 @@ PURE-INSN: ##unbox-alien
|
|||
def: dst/int-rep
|
||||
use: src/int-rep ;
|
||||
|
||||
: ##unbox-c-ptr ( dst src class temp -- )
|
||||
: ##unbox-c-ptr ( dst src class -- )
|
||||
{
|
||||
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
|
||||
{ [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
|
||||
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
|
||||
[ nip ##unbox-any-c-ptr ]
|
||||
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
|
||||
{ [ dup alien class<= ] [ drop ##unbox-alien ] }
|
||||
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
|
||||
[ drop ##unbox-any-c-ptr ]
|
||||
} cond ;
|
||||
|
||||
! Alien accessors
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
bi and ;
|
||||
|
||||
: ^^unbox-c-ptr ( src class -- dst )
|
||||
[ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
|
||||
[ next-vreg dup ] 2dip ##unbox-c-ptr ;
|
||||
|
||||
: prepare-alien-accessor ( info -- ptr-vreg offset )
|
||||
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ compiler.cfg.utilities compiler.cfg.builder.blocks ;
|
|||
IN: compiler.cfg.intrinsics.allot
|
||||
|
||||
: ##set-slots ( regs obj class -- )
|
||||
'[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
|
||||
'[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
|
||||
|
||||
: emit-simple-allot ( node -- )
|
||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||
|
|
@ -31,10 +31,10 @@ IN: compiler.cfg.intrinsics.allot
|
|||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: store-length ( len reg class -- )
|
||||
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
|
||||
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
|
||||
|
||||
:: store-initial-element ( len reg elt class -- )
|
||||
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
|
||||
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
|
||||
|
||||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
|
@ -62,7 +62,7 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: bytes>cells ( m -- n ) cell align cell /i ;
|
||||
|
||||
: ^^allot-byte-array ( n -- dst )
|
||||
2 cells + byte-array ^^allot ;
|
||||
16 + byte-array ^^allot ;
|
||||
|
||||
: emit-allot-byte-array ( len -- dst )
|
||||
ds-drop
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-push ;
|
||||
|
||||
: tag-literal ( n -- tagged )
|
||||
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
|
||||
literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
|
||||
|
||||
: emit-fixnum-op ( insn -- )
|
||||
[ 2inputs ] dip call ds-push ; inline
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ compiler.cfg.instructions compiler.cfg.utilities
|
|||
compiler.cfg.builder.blocks compiler.constants ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
: value-tag ( info -- n ) class>> class-type ; inline
|
||||
|
||||
: ^^tag-offset>slot ( slot tag -- vreg' )
|
||||
[ ^^offset>slot ] dip ^^sub-imm ;
|
||||
|
|
|
|||
|
|
@ -20,15 +20,19 @@ WHERE
|
|||
|
||||
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
|
||||
|
|
@ -39,7 +43,9 @@ M: ##phi rename-insn-uses
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@ GENERIC: defs-vreg-rep ( insn -- rep/f )
|
|||
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 )
|
||||
|
|
@ -21,9 +25,11 @@ GENERIC: uses-vreg-reps ( insn -- reps )
|
|||
} case ;
|
||||
|
||||
: define-defs-vreg-rep-method ( insn -- )
|
||||
dup insn-def-slot dup [
|
||||
[ \ defs-vreg-rep create-method ]
|
||||
[ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
|
||||
bi define ;
|
||||
[ rep>> rep-getter-quot ]
|
||||
bi* define
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: reps-getter-quot ( reps -- quot )
|
||||
dup [ rep>> { f scalar-rep } member-eq? not ] all? [
|
||||
|
|
@ -38,14 +44,18 @@ GENERIC: uses-vreg-reps ( insn -- reps )
|
|||
] if ;
|
||||
|
||||
: define-uses-vreg-reps-method ( insn -- )
|
||||
dup insn-use-slots [ drop ] [
|
||||
[ \ uses-vreg-reps create-method ]
|
||||
[ insn-use-slots reps-getter-quot ]
|
||||
bi define ;
|
||||
[ reps-getter-quot ]
|
||||
bi* define
|
||||
] if-empty ;
|
||||
|
||||
: define-temp-vreg-reps-method ( insn -- )
|
||||
dup insn-temp-slots [ drop ] [
|
||||
[ \ temp-vreg-reps create-method ]
|
||||
[ insn-temp-slots reps-getter-quot ]
|
||||
bi define ;
|
||||
[ reps-getter-quot ]
|
||||
bi* define
|
||||
] if-empty ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ M:: vector-rep emit-box ( dst src rep -- )
|
|||
int-rep next-vreg-rep :> temp
|
||||
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
|
||||
temp 16 tag-fixnum ##load-immediate
|
||||
temp dst 1 byte-array tag-number ##set-slot-imm
|
||||
temp dst 1 byte-array type-number ##set-slot-imm
|
||||
dst byte-array-offset src rep ##set-alien-vector ;
|
||||
|
||||
M: vector-rep emit-unbox
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: insn rewrite drop f ;
|
|||
dup ##compare-imm-branch? [
|
||||
{
|
||||
[ cc>> cc/= eq? ]
|
||||
[ src2>> \ f tag-number eq? ]
|
||||
[ src2>> \ f type-number eq? ]
|
||||
} 1&&
|
||||
] [ drop f ] if ; inline
|
||||
|
||||
|
|
@ -110,7 +110,7 @@ M: ##compare-imm rewrite-tagged-comparison
|
|||
: rewrite-redundant-comparison? ( insn -- ? )
|
||||
{
|
||||
[ src1>> vreg>expr general-compare-expr? ]
|
||||
[ src2>> \ f tag-number = ]
|
||||
[ src2>> \ f type-number = ]
|
||||
[ cc>> { cc= cc/= } member-eq? ]
|
||||
} 1&& ; inline
|
||||
|
||||
|
|
@ -204,7 +204,7 @@ M: ##compare-branch rewrite
|
|||
[ dst>> ] dip
|
||||
{
|
||||
{ t [ t \ ##load-constant new-insn ] }
|
||||
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
|
||||
{ f [ \ f type-number \ ##load-immediate new-insn ] }
|
||||
} case ;
|
||||
|
||||
: rewrite-self-compare ( insn -- insn' )
|
||||
|
|
@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
|
|||
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
|
||||
[
|
||||
next-vreg :> temp
|
||||
temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
|
||||
temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
|
||||
insn dst>> temp expr displacement>> vn>vreg ##add
|
||||
] { } make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
T{ ##load-reference f 1 + }
|
||||
T{ ##peek f 2 D 0 }
|
||||
T{ ##compare f 4 2 1 cc> }
|
||||
T{ ##compare-imm f 6 4 5 cc/= }
|
||||
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
|
||||
T{ ##replace f 6 D 0 }
|
||||
} value-numbering-step trim-temps
|
||||
] unit-test
|
||||
|
|
@ -100,7 +100,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
T{ ##load-reference f 1 + }
|
||||
T{ ##peek f 2 D 0 }
|
||||
T{ ##compare f 4 2 1 cc<= }
|
||||
T{ ##compare-imm f 6 4 5 cc= }
|
||||
T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
|
||||
T{ ##replace f 6 D 0 }
|
||||
} value-numbering-step trim-temps
|
||||
] unit-test
|
||||
|
|
@ -118,7 +118,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
T{ ##peek f 8 D 0 }
|
||||
T{ ##peek f 9 D -1 }
|
||||
T{ ##compare-float-unordered f 12 8 9 cc< }
|
||||
T{ ##compare-imm f 14 12 5 cc= }
|
||||
T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
|
||||
T{ ##replace f 14 D 0 }
|
||||
} value-numbering-step trim-temps
|
||||
] unit-test
|
||||
|
|
@ -135,7 +135,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
T{ ##peek f 29 D -1 }
|
||||
T{ ##peek f 30 D -2 }
|
||||
T{ ##compare f 33 29 30 cc<= }
|
||||
T{ ##compare-imm-branch f 33 5 cc/= }
|
||||
T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
|
||||
} value-numbering-step trim-temps
|
||||
] unit-test
|
||||
|
||||
|
|
@ -149,7 +149,7 @@ IN: compiler.cfg.value-numbering.tests
|
|||
{
|
||||
T{ ##peek f 1 D -1 }
|
||||
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
|
||||
T{ ##compare-imm-branch f 2 5 cc/= }
|
||||
T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
|
||||
} value-numbering-step trim-temps
|
||||
] unit-test
|
||||
|
||||
|
|
@ -1071,14 +1071,14 @@ cell 8 = [
|
|||
! Branch folding
|
||||
[
|
||||
{
|
||||
T{ ##load-immediate f 1 1 }
|
||||
T{ ##load-immediate f 2 2 }
|
||||
T{ ##load-immediate f 3 5 }
|
||||
T{ ##load-immediate f 1 10 }
|
||||
T{ ##load-immediate f 2 20 }
|
||||
T{ ##load-immediate f 3 $[ \ f type-number ] }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##load-immediate f 1 1 }
|
||||
T{ ##load-immediate f 2 2 }
|
||||
T{ ##load-immediate f 1 10 }
|
||||
T{ ##load-immediate f 2 20 }
|
||||
T{ ##compare f 3 1 2 cc= }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -1113,14 +1113,14 @@ cell 8 = [
|
|||
|
||||
[
|
||||
{
|
||||
T{ ##load-immediate f 1 1 }
|
||||
T{ ##load-immediate f 2 2 }
|
||||
T{ ##load-immediate f 3 5 }
|
||||
T{ ##load-immediate f 1 10 }
|
||||
T{ ##load-immediate f 2 20 }
|
||||
T{ ##load-immediate f 3 $[ \ f type-number ] }
|
||||
}
|
||||
] [
|
||||
{
|
||||
T{ ##load-immediate f 1 1 }
|
||||
T{ ##load-immediate f 2 2 }
|
||||
T{ ##load-immediate f 1 10 }
|
||||
T{ ##load-immediate f 2 20 }
|
||||
T{ ##compare f 3 2 1 cc< }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -1128,7 +1128,7 @@ cell 8 = [
|
|||
[
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 1 5 }
|
||||
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -1152,7 +1152,7 @@ cell 8 = [
|
|||
[
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 1 5 }
|
||||
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -1176,7 +1176,7 @@ cell 8 = [
|
|||
[
|
||||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 1 5 }
|
||||
T{ ##load-immediate f 1 $[ \ f type-number ] }
|
||||
}
|
||||
] [
|
||||
{
|
||||
|
|
@ -1557,7 +1557,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##compare f 1 0 0 cc<= }
|
||||
T{ ##compare-imm-branch f 1 5 cc/= }
|
||||
T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
|
||||
} test-branch-folding
|
||||
] unit-test
|
||||
|
||||
|
|
@ -1659,7 +1659,7 @@ V{
|
|||
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
|
||||
T{ ##compare-imm-branch
|
||||
{ src1 21 }
|
||||
{ src2 5 }
|
||||
{ src2 $[ \ f type-number ] }
|
||||
{ cc cc/= }
|
||||
}
|
||||
} 1 test-bb
|
||||
|
|
|
|||
|
|
@ -12,19 +12,18 @@ CONSTANT: deck-bits 18
|
|||
! These constants must match vm/layouts.h
|
||||
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
|
||||
|
||||
: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
|
||||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
|
||||
: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
|
||||
: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
|
||||
: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
|
||||
: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
|
||||
: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
|
||||
: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
|
||||
: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
|
||||
: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
|
||||
: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
|
||||
: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
|
||||
: float-offset ( -- n ) 8 float type-number - ; inline
|
||||
: string-offset ( -- n ) 4 string type-number slot-offset ; inline
|
||||
: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
|
||||
: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
|
||||
: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
|
||||
: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
|
||||
: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
|
||||
: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
|
||||
: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
|
||||
: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
|
||||
: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
|
||||
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
|
|
|
|||
|
|
@ -175,20 +175,6 @@ TUPLE: my-tuple ;
|
|||
] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 1 t ] [
|
||||
B{ 1 2 3 4 } [
|
||||
{ c-ptr } declare
|
||||
[ 0 alien-unsigned-1 ] keep hi-tag
|
||||
] compile-call byte-array type-number =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
B{ 1 2 3 4 } [
|
||||
{ c-ptr } declare
|
||||
0 alien-cell hi-tag
|
||||
] compile-call alien type-number =
|
||||
] unit-test
|
||||
|
||||
[ 2 1 ] [
|
||||
2 1
|
||||
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
|
||||
|
|
|
|||
|
|
@ -244,20 +244,20 @@ IN: compiler.tests.intrinsics
|
|||
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
||||
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
||||
[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
|
||||
[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
|
||||
[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
|
||||
[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
|
||||
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
|
||||
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||
[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||
|
||||
[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||
[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ f [ f eq? ] compile-call ] unit-test
|
||||
|
||||
|
|
@ -285,8 +285,8 @@ cell 8 = [
|
|||
|
||||
! 64-bit overflow
|
||||
cell 8 = [
|
||||
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
|
||||
[ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
[ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
|
||||
[ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
|
||||
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
|
||||
|
|
@ -301,9 +301,9 @@ cell 8 = [
|
|||
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
|
||||
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
|
||||
|
||||
[ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||
[ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
|
||||
|
||||
[ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||
[ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
|
||||
|
||||
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
|
||||
] when
|
||||
|
|
@ -311,12 +311,14 @@ cell 8 = [
|
|||
! Some randomized tests
|
||||
: compiled-fixnum* ( a b -- c ) fixnum* ;
|
||||
|
||||
ERROR: bug-in-fixnum* x y a b ;
|
||||
|
||||
[ ] [
|
||||
10000 [
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
[ 2drop ] [ "Oops" throw ] if
|
||||
32 random-bits >fixnum
|
||||
32 random-bits >fixnum
|
||||
2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
|
||||
[ 2drop 2drop ] [ bug-in-fixnum* ] if
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
|
|
@ -419,7 +421,7 @@ cell 8 = [
|
|||
"b" get [
|
||||
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
|
||||
[ ] [ "b" get free ] unit-test
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ IN: compiler.tests.low-level-ir
|
|||
! loading immediates
|
||||
[ f ] [
|
||||
V{
|
||||
T{ ##load-immediate f 0 5 }
|
||||
T{ ##load-immediate f 0 $[ \ f type-number ] }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ IN: compiler.tests.low-level-ir
|
|||
! one of the sources
|
||||
[ t ] [
|
||||
V{
|
||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
|
||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
|
||||
T{ ##load-reference f 0 { t f t } }
|
||||
T{ ##slot f 0 0 1 }
|
||||
} compile-test-bb
|
||||
|
|
@ -59,13 +59,13 @@ IN: compiler.tests.low-level-ir
|
|||
[ t ] [
|
||||
V{
|
||||
T{ ##load-reference f 0 { t f t } }
|
||||
T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
|
||||
T{ ##slot-imm f 0 0 2 $[ array type-number ] }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
V{
|
||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
|
||||
T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
|
||||
T{ ##load-reference f 0 { t f t } }
|
||||
T{ ##set-slot f 0 0 1 }
|
||||
} compile-test-bb
|
||||
|
|
@ -75,12 +75,12 @@ IN: compiler.tests.low-level-ir
|
|||
[ t ] [
|
||||
V{
|
||||
T{ ##load-reference f 0 { t f t } }
|
||||
T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
|
||||
T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
|
||||
} compile-test-bb
|
||||
dup first eq?
|
||||
] unit-test
|
||||
|
||||
[ 8 ] [
|
||||
[ 4 ] [
|
||||
V{
|
||||
T{ ##load-immediate f 0 4 }
|
||||
T{ ##shl f 0 0 0 }
|
||||
|
|
@ -90,16 +90,16 @@ IN: compiler.tests.low-level-ir
|
|||
[ 4 ] [
|
||||
V{
|
||||
T{ ##load-immediate f 0 4 }
|
||||
T{ ##shl-imm f 0 0 3 }
|
||||
T{ ##shl-imm f 0 0 4 }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
||||
[ 31 ] [
|
||||
V{
|
||||
T{ ##load-reference f 1 B{ 31 67 52 } }
|
||||
T{ ##unbox-any-c-ptr f 0 1 2 }
|
||||
T{ ##unbox-any-c-ptr f 0 1 }
|
||||
T{ ##alien-unsigned-1 f 0 0 0 }
|
||||
T{ ##shl-imm f 0 0 3 }
|
||||
T{ ##shl-imm f 0 0 4 }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
||||
|
|
@ -108,13 +108,13 @@ IN: compiler.tests.low-level-ir
|
|||
T{ ##load-reference f 0 "hello world" }
|
||||
T{ ##load-immediate f 1 3 }
|
||||
T{ ##string-nth f 0 0 1 2 }
|
||||
T{ ##shl-imm f 0 0 3 }
|
||||
T{ ##shl-imm f 0 0 4 }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
V{
|
||||
T{ ##load-immediate f 0 16 }
|
||||
T{ ##add-imm f 0 0 -8 }
|
||||
T{ ##load-immediate f 0 32 }
|
||||
T{ ##add-imm f 0 0 -16 }
|
||||
} compile-test-bb
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -202,7 +202,7 @@ USE: binary-search.private
|
|||
dup length 1 <= [
|
||||
from>>
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
|
||||
[ drop dup from>> swap midpoint@ + ]
|
||||
[ drop dup midpoint@ head-slice old-binsearch ] if
|
||||
] if ; inline recursive
|
||||
|
|
|
|||
|
|
@ -278,7 +278,7 @@ generic-comparison-ops [
|
|||
] each
|
||||
|
||||
\ alien-cell [
|
||||
2drop simple-alien \ f class-or <class-info>
|
||||
2drop alien \ f class-or <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
|
|
|
|||
|
|
@ -890,10 +890,10 @@ M: tuple-with-read-only-slot clone
|
|||
[ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
|
||||
] unit-test
|
||||
|
||||
! alien-cell outputs a simple-alien or f
|
||||
! alien-cell outputs a alien or f
|
||||
[ t ] [
|
||||
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
|
||||
first simple-alien class=
|
||||
first alien class=
|
||||
] unit-test
|
||||
|
||||
! Don't crash if bad literal inputs are passed to unsafe words
|
||||
|
|
|
|||
|
|
@ -386,9 +386,9 @@ M: object %horizontal-shl-vector-imm-reps { } ;
|
|||
M: object %horizontal-shr-vector-imm-reps { } ;
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
|
||||
HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
|
||||
|
||||
HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
|
||||
HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ CONSTANT: rs-reg 14
|
|||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
0 3 \ f tag-number CMPI
|
||||
0 3 \ f type-number CMPI
|
||||
2 BEQ
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
|
|
@ -174,40 +174,15 @@ CONSTANT: rs-reg 14
|
|||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 object tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 object tag-number neg LWZ
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple tag-number tag-fixnum CMPI
|
||||
0 4 tuple type-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 tuple tag-number neg bootstrap-cell + LWZ
|
||||
4 3 tuple type-number neg bootstrap-cell + LWZ
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
0 4 BIN: 110 tag-fixnum CMPI
|
||||
5 BLT
|
||||
! Untag r3
|
||||
3 3 0 0 31 tag-bits get - RLWINM
|
||||
! Set r4 to 0 for objects, and bootstrap-cell for tuples
|
||||
4 4 1 tag-fixnum ANDI
|
||||
4 4 1 SRAWI
|
||||
! Load header cell or tuple layout cell
|
||||
4 4 3 LWZX
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
|
@ -215,7 +190,7 @@ CONSTANT: rs-reg 14
|
|||
[
|
||||
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 0 5 CMP
|
||||
] pic-check jit-define
|
||||
] pic-check-tuple jit-define
|
||||
|
||||
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
|
|
@ -224,8 +199,13 @@ CONSTANT: rs-reg 14
|
|||
[
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
! key = class
|
||||
5 4 MR
|
||||
! key = hashcode(class)
|
||||
5 4 3 SRAWI
|
||||
6 4 8 SRAWI
|
||||
5 5 6 ADD
|
||||
6 4 13 SRAWI
|
||||
5 5 6 ADD
|
||||
5 5 3 SLWI
|
||||
! key &= cache.length - 1
|
||||
5 5 mega-cache-size get 1 - bootstrap-cell * ANDI
|
||||
! cache += array-start-offset
|
||||
|
|
@ -278,7 +258,7 @@ CONSTANT: rs-reg 14
|
|||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZU
|
||||
3 3 1 SRAWI
|
||||
3 3 2 SRAWI
|
||||
4 4 0 0 31 tag-bits get - RLWINM
|
||||
4 3 3 LWZX
|
||||
3 ds-reg 0 STW
|
||||
|
|
@ -399,7 +379,7 @@ CONSTANT: rs-reg 14
|
|||
5 ds-reg -4 LWZU
|
||||
5 0 4 CMP
|
||||
2 swap execute( offset -- ) ! magic number
|
||||
\ f tag-number 3 LI
|
||||
\ f type-number 3 LI
|
||||
3 ds-reg 0 STW ;
|
||||
|
||||
: define-jit-compare ( insn word -- )
|
||||
|
|
@ -418,7 +398,7 @@ CONSTANT: rs-reg 14
|
|||
4 ds-reg 0 LWZ
|
||||
3 3 4 OR
|
||||
3 3 tag-mask get ANDI
|
||||
\ f tag-number 4 LI
|
||||
\ f type-number 4 LI
|
||||
0 3 0 CMPI
|
||||
2 BNE
|
||||
1 tag-fixnum 4 LI
|
||||
|
|
|
|||
|
|
@ -266,7 +266,7 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
|
|||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
! Is the object f?
|
||||
0 scratch-reg \ f tag-number CMPI
|
||||
0 scratch-reg \ f type-number CMPI
|
||||
! If so, done
|
||||
"end" get BEQ
|
||||
! Is the object an alien?
|
||||
|
|
@ -288,25 +288,20 @@ M:: ppc %unbox-any-c-ptr ( dst src temp -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: alien@ ( n -- n' ) cells object tag-number - ;
|
||||
|
||||
:: %allot-alien ( dst displacement base temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
temp \ f tag-number %load-immediate
|
||||
! Store underlying-alien slot
|
||||
base dst 1 alien@ STW
|
||||
! Store expired slot
|
||||
temp dst 2 alien@ STW
|
||||
! Store offset
|
||||
displacement dst 3 alien@ STW ;
|
||||
: alien@ ( n -- n' ) cells alien type-number - ;
|
||||
|
||||
M:: ppc %box-alien ( dst src temp -- )
|
||||
[
|
||||
"f" define-label
|
||||
dst \ f tag-number %load-immediate
|
||||
dst %load-immediate
|
||||
0 src 0 CMPI
|
||||
"f" get BEQ
|
||||
dst src temp temp %allot-alien
|
||||
dst 5 cells alien temp %allot
|
||||
temp \ f type-number %load-immediate
|
||||
temp dst 1 alien@ STW
|
||||
temp dst 2 alien@ STW
|
||||
displacement dst 3 alien@ STW
|
||||
displacement dst 4 alien@ STW
|
||||
"f" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -323,7 +318,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
|
|||
displacement' :> temp
|
||||
dst 4 cells alien temp %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
0 base \ f tag-number CMPI
|
||||
0 base \ f type-number CMPI
|
||||
"simple-case" get BEQ
|
||||
temp base header-offset LWZ
|
||||
0 temp alien type-number tag-fixnum CMPI
|
||||
|
|
@ -343,7 +338,7 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
|
|||
! Store offset
|
||||
displacement' dst 3 alien@ STW
|
||||
! Store expired slot (its ok to clobber displacement')
|
||||
temp \ f tag-number %load-immediate
|
||||
temp \ f type-number %load-immediate
|
||||
temp dst 2 alien@ STW
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
|
@ -374,7 +369,7 @@ M: ppc %set-alien-double -rot STFD ;
|
|||
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
|
||||
|
||||
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
|
||||
scratch-reg allot-ptr n 8 align ADDI
|
||||
scratch-reg allot-ptr n data-alignment get align ADDI
|
||||
scratch-reg nursery-ptr 0 STW ;
|
||||
|
||||
:: store-header ( dst class -- )
|
||||
|
|
@ -382,7 +377,7 @@ M: ppc %set-alien-double -rot STFD ;
|
|||
scratch-reg dst 0 STW ;
|
||||
|
||||
: store-tagged ( dst tag -- )
|
||||
dupd tag-number ORI ;
|
||||
dupd type-number ORI ;
|
||||
|
||||
M:: ppc %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
|
|
@ -460,7 +455,7 @@ M: ppc %epilogue ( n -- )
|
|||
|
||||
:: (%boolean) ( dst temp branch1 branch2 -- )
|
||||
"end" define-label
|
||||
dst \ f tag-number %load-immediate
|
||||
dst \ f type-number %load-immediate
|
||||
"end" get branch1 execute( label -- )
|
||||
branch2 [ "end" get branch2 execute( label -- ) ] when
|
||||
dst \ t %load-reference
|
||||
|
|
@ -742,14 +737,3 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
|
||||
[
|
||||
<c-type>
|
||||
[ alien-unsigned-4 c-bool> ] >>getter
|
||||
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
bool define-primitive-type
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -11,9 +11,6 @@ cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
|
|||
cpu.architecture ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
! We implement the FFI for Linux, OS X and Windows all at once.
|
||||
! OS X requires that the stack be 16-byte aligned.
|
||||
|
||||
M: x86.32 machine-registers
|
||||
{
|
||||
{ int-regs { EAX ECX EDX EBP EBX } }
|
||||
|
|
@ -327,10 +324,4 @@ M: x86.32 dummy-fp-params? f ;
|
|||
! Dreadful
|
||||
M: object flatten-value-type (flatten-int-type) ;
|
||||
|
||||
os windows? [
|
||||
cell longlong c-type (>>align)
|
||||
cell ulonglong c-type (>>align)
|
||||
4 double c-type (>>align)
|
||||
] unless
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: bootstrap.x86
|
|||
: stack-reg ( -- reg ) ESP ;
|
||||
: ds-reg ( -- reg ) ESI ;
|
||||
: rs-reg ( -- reg ) EDI ;
|
||||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: fixnum>slot@ ( -- ) temp0 2 SAR ;
|
||||
: rex-length ( -- n ) 0 ;
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: bootstrap.x86
|
|||
: stack-reg ( -- reg ) RSP ;
|
||||
: ds-reg ( -- reg ) R14 ;
|
||||
: rs-reg ( -- reg ) R15 ;
|
||||
: fixnum>slot@ ( -- ) ;
|
||||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -24,9 +24,3 @@ M: x86.64 dummy-fp-params? t ;
|
|||
|
||||
M: x86.64 temp-reg RAX ;
|
||||
|
||||
<<
|
||||
longlong ptrdiff_t typedef
|
||||
longlong intptr_t typedef
|
||||
int c-type long define-primitive-type
|
||||
uint c-type ulong define-primitive-type
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ big-endian off
|
|||
! pop boolean
|
||||
ds-reg bootstrap-cell SUB
|
||||
! compare boolean with f
|
||||
temp0 \ f tag-number CMP
|
||||
temp0 \ f type-number CMP
|
||||
! jump to true branch if not equal
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
! jump to false branch if equal
|
||||
|
|
@ -154,7 +154,7 @@ big-endian off
|
|||
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! The PIC and megamorphic code stubs are not permitted to touch temp3.
|
||||
! The PIC stubs are not permitted to touch temp3.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
|
|
@ -171,41 +171,15 @@ big-endian off
|
|||
! The 'make' trick lets us compute the jump distance for the
|
||||
! conditional branches there
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
temp1 object tag-number tag-fixnum CMP
|
||||
[ temp1 temp0 object tag-number neg [+] MOV ] { } make
|
||||
[ length JNE ] [ % ] bi
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
temp1 tuple tag-number tag-fixnum CMP
|
||||
[ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
|
||||
temp1 tuple type-number tag-fixnum CMP
|
||||
[ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
|
||||
[ length JNE ] [ % ] bi
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
temp1 BIN: 110 tag-fixnum CMP
|
||||
[
|
||||
! Untag temp0
|
||||
temp0 tag-mask get bitnot AND
|
||||
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
|
||||
temp1 1 tag-fixnum AND
|
||||
bootstrap-cell 4 = [ temp1 1 SHR ] when
|
||||
! Load header cell or tuple layout cell
|
||||
temp1 temp0 temp1 [+] MOV
|
||||
] [ ] make [ length JL ] [ % ] bi
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
|
@ -213,7 +187,7 @@ big-endian off
|
|||
[
|
||||
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
|
||||
temp1 temp2 CMP
|
||||
] pic-check jit-define
|
||||
] pic-check-tuple jit-define
|
||||
|
||||
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
|
|
@ -222,9 +196,9 @@ big-endian off
|
|||
[
|
||||
! cache = ...
|
||||
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! key = class
|
||||
! key = hashcode(class)
|
||||
temp2 temp1 MOV
|
||||
bootstrap-cell 8 = [ temp2 1 SHL ] when
|
||||
bootstrap-cell 4 = [ temp2 1 SHR ] when
|
||||
! key &= cache.length - 1
|
||||
temp2 mega-cache-size get 1 - bootstrap-cell * AND
|
||||
! cache += array-start-offset
|
||||
|
|
@ -410,7 +384,7 @@ big-endian off
|
|||
t jit-literal
|
||||
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! load f
|
||||
temp1 \ f tag-number MOV
|
||||
temp1 \ f type-number MOV
|
||||
! load first value
|
||||
temp0 ds-reg [] MOV
|
||||
! adjust stack pointer
|
||||
|
|
@ -540,7 +514,7 @@ big-endian off
|
|||
ds-reg bootstrap-cell SUB
|
||||
temp0 ds-reg [] OR
|
||||
temp0 tag-mask get AND
|
||||
temp0 \ f tag-number MOV
|
||||
temp0 \ f type-number MOV
|
||||
temp1 1 tag-fixnum MOV
|
||||
temp0 temp1 CMOVE
|
||||
ds-reg [] temp0 MOV
|
||||
|
|
|
|||
|
|
@ -45,8 +45,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
|
|||
: incr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
|
||||
|
||||
: align-stack ( n -- n' )
|
||||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
: align-stack ( n -- n' ) 16 align ;
|
||||
|
||||
M: x86 stack-frame-size ( stack-frame -- i )
|
||||
[ (stack-frame-size) ]
|
||||
|
|
@ -141,8 +140,10 @@ M: x86 %not int-rep one-operand NOT ;
|
|||
M: x86 %neg int-rep one-operand NEG ;
|
||||
M: x86 %log2 BSR ;
|
||||
|
||||
! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
|
||||
! since this induces partial register stalls
|
||||
GENERIC: copy-register* ( dst src rep -- )
|
||||
GENERIC: copy-unaligned* ( dst src rep -- )
|
||||
GENERIC: copy-memory* ( dst src rep -- )
|
||||
|
||||
M: int-rep copy-register* drop MOV ;
|
||||
M: tagged-rep copy-register* drop MOV ;
|
||||
|
|
@ -152,17 +153,14 @@ M: float-4-rep copy-register* drop MOVAPS ;
|
|||
M: double-2-rep copy-register* drop MOVAPS ;
|
||||
M: vector-rep copy-register* drop MOVDQA ;
|
||||
|
||||
M: object copy-unaligned* copy-register* ;
|
||||
M: float-rep copy-unaligned* drop MOVSS ;
|
||||
M: double-rep copy-unaligned* drop MOVSD ;
|
||||
M: float-4-rep copy-unaligned* drop MOVUPS ;
|
||||
M: double-2-rep copy-unaligned* drop MOVUPS ;
|
||||
M: vector-rep copy-unaligned* drop MOVDQU ;
|
||||
M: object copy-memory* copy-register* ;
|
||||
M: float-rep copy-memory* drop MOVSS ;
|
||||
M: double-rep copy-memory* drop MOVSD ;
|
||||
|
||||
M: x86 %copy ( dst src rep -- )
|
||||
2over eq? [ 3drop ] [
|
||||
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
|
||||
2over [ register? ] both? [ copy-register* ] [ copy-unaligned* ] if
|
||||
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
|
||||
] if ;
|
||||
|
||||
M: x86 %fixnum-add ( label dst src1 src2 -- )
|
||||
|
|
@ -177,76 +175,109 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- )
|
|||
M: x86 %unbox-alien ( dst src -- )
|
||||
alien-offset [+] MOV ;
|
||||
|
||||
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
|
||||
M:: x86 %unbox-any-c-ptr ( dst src -- )
|
||||
[
|
||||
{ "is-byte-array" "end" "start" } [ define-label ] each
|
||||
dst 0 MOV
|
||||
temp src MOV
|
||||
! We come back here with displaced aliens
|
||||
"start" resolve-label
|
||||
"end" define-label
|
||||
dst dst XOR
|
||||
! Is the object f?
|
||||
temp \ f tag-number CMP
|
||||
src \ f type-number CMP
|
||||
"end" get JE
|
||||
! Compute tag in dst register
|
||||
dst src MOV
|
||||
dst tag-mask get AND
|
||||
! Is the object an alien?
|
||||
temp header-offset [+] alien type-number tag-fixnum CMP
|
||||
"is-byte-array" get JNE
|
||||
! If so, load the offset and add it to the address
|
||||
dst temp alien-offset [+] ADD
|
||||
! Now recurse on the underlying alien
|
||||
temp temp underlying-alien-offset [+] MOV
|
||||
"start" get JMP
|
||||
"is-byte-array" resolve-label
|
||||
! Add byte array address to address being computed
|
||||
dst temp ADD
|
||||
dst alien type-number CMP
|
||||
! Add an offset to start of byte array's data
|
||||
dst byte-array-offset ADD
|
||||
dst src byte-array-offset [+] LEA
|
||||
"end" get JNE
|
||||
! If so, load the offset and add it to the address
|
||||
dst src alien-offset [+] MOV
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
|
||||
|
||||
:: %allot-alien ( dst displacement base temp -- )
|
||||
dst 4 cells alien temp %allot
|
||||
dst 1 alien@ base MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement MOV ! displacement
|
||||
;
|
||||
: alien@ ( reg n -- op ) cells alien type-number - [+] ;
|
||||
|
||||
M:: x86 %box-alien ( dst src temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
dst \ f tag-number MOV
|
||||
src 0 CMP
|
||||
dst \ f type-number MOV
|
||||
src src TEST
|
||||
"end" get JE
|
||||
dst src \ f tag-number temp %allot-alien
|
||||
dst 5 cells alien temp %allot
|
||||
dst 1 alien@ \ f type-number MOV ! base
|
||||
dst 2 alien@ \ f type-number MOV ! expired
|
||||
dst 3 alien@ src MOV ! displacement
|
||||
dst 4 alien@ src MOV ! address
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
|
||||
M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
|
||||
! This is ridiculous
|
||||
[
|
||||
"end" define-label
|
||||
"ok" define-label
|
||||
"not-f" define-label
|
||||
"not-alien" define-label
|
||||
|
||||
! If displacement is zero, return the base
|
||||
dst base MOV
|
||||
displacement 0 CMP
|
||||
displacement displacement TEST
|
||||
"end" get JE
|
||||
! Quickly use displacement' before its needed for real, as allot temporary
|
||||
dst 4 cells alien displacement' %allot
|
||||
! If base is already a displaced alien, unpack it
|
||||
base' base MOV
|
||||
displacement' displacement MOV
|
||||
base \ f tag-number CMP
|
||||
"ok" get JE
|
||||
base header-offset [+] alien type-number tag-fixnum CMP
|
||||
"ok" get JNE
|
||||
! displacement += base.displacement
|
||||
displacement' base 3 alien@ ADD
|
||||
! base = base.base
|
||||
base' base 1 alien@ MOV
|
||||
"ok" resolve-label
|
||||
dst 1 alien@ base' MOV ! alien
|
||||
dst 2 alien@ \ f tag-number MOV ! expired
|
||||
dst 3 alien@ displacement' MOV ! displacement
|
||||
|
||||
! Displacement is non-zero, we're going to be allocating a new
|
||||
! object
|
||||
dst 5 cells alien temp %allot
|
||||
|
||||
! Set expired to f
|
||||
dst 2 alien@ \ f type-number MOV
|
||||
|
||||
! Is base f?
|
||||
base \ f type-number CMP
|
||||
"not-f" get JNE
|
||||
|
||||
! Yes, it is f. Fill in new object
|
||||
dst 1 alien@ base MOV
|
||||
dst 3 alien@ displacement MOV
|
||||
dst 4 alien@ displacement MOV
|
||||
|
||||
"end" get JMP
|
||||
|
||||
"not-f" resolve-label
|
||||
|
||||
! Check base type
|
||||
temp base MOV
|
||||
temp tag-mask get AND
|
||||
|
||||
! Is base an alien?
|
||||
temp alien type-number CMP
|
||||
"not-alien" get JNE
|
||||
|
||||
! Yes, it is an alien. Set new alien's base to base.base
|
||||
temp base 1 alien@ MOV
|
||||
dst 1 alien@ temp MOV
|
||||
|
||||
! Compute displacement
|
||||
temp base 3 alien@ MOV
|
||||
temp displacement ADD
|
||||
dst 3 alien@ temp MOV
|
||||
|
||||
! Compute address
|
||||
temp base 4 alien@ MOV
|
||||
temp displacement ADD
|
||||
dst 4 alien@ temp MOV
|
||||
|
||||
! We are done
|
||||
"end" get JMP
|
||||
|
||||
! Is base a byte array? It has to be, by now...
|
||||
"not-alien" resolve-label
|
||||
|
||||
dst 1 alien@ base MOV
|
||||
dst 3 alien@ displacement MOV
|
||||
temp base MOV
|
||||
temp byte-array-offset ADD
|
||||
temp displacement ADD
|
||||
dst 4 alien@ temp MOV
|
||||
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
|
|
@ -396,13 +427,13 @@ M: x86 %vm-field-ptr ( dst field -- )
|
|||
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
|
||||
|
||||
: inc-allot-ptr ( nursery-ptr n -- )
|
||||
[ [] ] dip 8 align ADD ;
|
||||
[ [] ] dip data-alignment get align ADD ;
|
||||
|
||||
: store-header ( temp class -- )
|
||||
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
|
||||
|
||||
: store-tagged ( dst tag -- )
|
||||
tag-number OR ;
|
||||
type-number OR ;
|
||||
|
||||
M:: x86 %allot ( dst size class nursery-ptr -- )
|
||||
nursery-ptr dst load-allot-ptr
|
||||
|
|
@ -444,7 +475,7 @@ M: x86 %alien-global ( dst symbol library -- )
|
|||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||
|
||||
:: %boolean ( dst temp word -- )
|
||||
dst \ f tag-number MOV
|
||||
dst \ f type-number MOV
|
||||
temp 0 MOV \ t rc-absolute-cell rel-immediate
|
||||
dst temp word execute ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: sequences sequences.private math
|
||||
accessors alien.data ;
|
||||
accessors alien.c-types ;
|
||||
IN: game.input.dinput.keys-array
|
||||
|
||||
TUPLE: keys-array
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: io.buffers
|
|||
|
||||
TUPLE: buffer
|
||||
{ size fixnum }
|
||||
{ ptr simple-alien }
|
||||
{ ptr alien }
|
||||
{ fill fixnum }
|
||||
{ pos fixnum }
|
||||
disposed ;
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ CONSTANT: mappings {
|
|||
{ "latin9" "ISO-8859-15" "8859-15" }
|
||||
{ "latin10" "ISO-8859-16" "8859-16" }
|
||||
{ "koi8-r" "KOI8-R" "KOI8-R" }
|
||||
{ "windows-1250" "windows-1250" "CP1250" }
|
||||
{ "windows-1252" "windows-1252" "CP1252" }
|
||||
{ "ebcdic" "IBM037" "CP037" }
|
||||
{ "mac-roman" "macintosh" "ROMAN" }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,274 @@
|
|||
#
|
||||
# Name: cp1250 to Unicode table
|
||||
# Unicode version: 2.0
|
||||
# Table version: 2.01
|
||||
# Table format: Format A
|
||||
# Date: 04/15/98
|
||||
#
|
||||
# Contact: Shawn.Steele@microsoft.com
|
||||
#
|
||||
# General notes: none
|
||||
#
|
||||
# Format: Three tab-separated columns
|
||||
# Column #1 is the cp1250 code (in hex)
|
||||
# Column #2 is the Unicode (in hex as 0xXXXX)
|
||||
# Column #3 is the Unicode name (follows a comment sign, '#')
|
||||
#
|
||||
# The entries are in cp1250 order
|
||||
#
|
||||
0x00 0x0000 #NULL
|
||||
0x01 0x0001 #START OF HEADING
|
||||
0x02 0x0002 #START OF TEXT
|
||||
0x03 0x0003 #END OF TEXT
|
||||
0x04 0x0004 #END OF TRANSMISSION
|
||||
0x05 0x0005 #ENQUIRY
|
||||
0x06 0x0006 #ACKNOWLEDGE
|
||||
0x07 0x0007 #BELL
|
||||
0x08 0x0008 #BACKSPACE
|
||||
0x09 0x0009 #HORIZONTAL TABULATION
|
||||
0x0A 0x000A #LINE FEED
|
||||
0x0B 0x000B #VERTICAL TABULATION
|
||||
0x0C 0x000C #FORM FEED
|
||||
0x0D 0x000D #CARRIAGE RETURN
|
||||
0x0E 0x000E #SHIFT OUT
|
||||
0x0F 0x000F #SHIFT IN
|
||||
0x10 0x0010 #DATA LINK ESCAPE
|
||||
0x11 0x0011 #DEVICE CONTROL ONE
|
||||
0x12 0x0012 #DEVICE CONTROL TWO
|
||||
0x13 0x0013 #DEVICE CONTROL THREE
|
||||
0x14 0x0014 #DEVICE CONTROL FOUR
|
||||
0x15 0x0015 #NEGATIVE ACKNOWLEDGE
|
||||
0x16 0x0016 #SYNCHRONOUS IDLE
|
||||
0x17 0x0017 #END OF TRANSMISSION BLOCK
|
||||
0x18 0x0018 #CANCEL
|
||||
0x19 0x0019 #END OF MEDIUM
|
||||
0x1A 0x001A #SUBSTITUTE
|
||||
0x1B 0x001B #ESCAPE
|
||||
0x1C 0x001C #FILE SEPARATOR
|
||||
0x1D 0x001D #GROUP SEPARATOR
|
||||
0x1E 0x001E #RECORD SEPARATOR
|
||||
0x1F 0x001F #UNIT SEPARATOR
|
||||
0x20 0x0020 #SPACE
|
||||
0x21 0x0021 #EXCLAMATION MARK
|
||||
0x22 0x0022 #QUOTATION MARK
|
||||
0x23 0x0023 #NUMBER SIGN
|
||||
0x24 0x0024 #DOLLAR SIGN
|
||||
0x25 0x0025 #PERCENT SIGN
|
||||
0x26 0x0026 #AMPERSAND
|
||||
0x27 0x0027 #APOSTROPHE
|
||||
0x28 0x0028 #LEFT PARENTHESIS
|
||||
0x29 0x0029 #RIGHT PARENTHESIS
|
||||
0x2A 0x002A #ASTERISK
|
||||
0x2B 0x002B #PLUS SIGN
|
||||
0x2C 0x002C #COMMA
|
||||
0x2D 0x002D #HYPHEN-MINUS
|
||||
0x2E 0x002E #FULL STOP
|
||||
0x2F 0x002F #SOLIDUS
|
||||
0x30 0x0030 #DIGIT ZERO
|
||||
0x31 0x0031 #DIGIT ONE
|
||||
0x32 0x0032 #DIGIT TWO
|
||||
0x33 0x0033 #DIGIT THREE
|
||||
0x34 0x0034 #DIGIT FOUR
|
||||
0x35 0x0035 #DIGIT FIVE
|
||||
0x36 0x0036 #DIGIT SIX
|
||||
0x37 0x0037 #DIGIT SEVEN
|
||||
0x38 0x0038 #DIGIT EIGHT
|
||||
0x39 0x0039 #DIGIT NINE
|
||||
0x3A 0x003A #COLON
|
||||
0x3B 0x003B #SEMICOLON
|
||||
0x3C 0x003C #LESS-THAN SIGN
|
||||
0x3D 0x003D #EQUALS SIGN
|
||||
0x3E 0x003E #GREATER-THAN SIGN
|
||||
0x3F 0x003F #QUESTION MARK
|
||||
0x40 0x0040 #COMMERCIAL AT
|
||||
0x41 0x0041 #LATIN CAPITAL LETTER A
|
||||
0x42 0x0042 #LATIN CAPITAL LETTER B
|
||||
0x43 0x0043 #LATIN CAPITAL LETTER C
|
||||
0x44 0x0044 #LATIN CAPITAL LETTER D
|
||||
0x45 0x0045 #LATIN CAPITAL LETTER E
|
||||
0x46 0x0046 #LATIN CAPITAL LETTER F
|
||||
0x47 0x0047 #LATIN CAPITAL LETTER G
|
||||
0x48 0x0048 #LATIN CAPITAL LETTER H
|
||||
0x49 0x0049 #LATIN CAPITAL LETTER I
|
||||
0x4A 0x004A #LATIN CAPITAL LETTER J
|
||||
0x4B 0x004B #LATIN CAPITAL LETTER K
|
||||
0x4C 0x004C #LATIN CAPITAL LETTER L
|
||||
0x4D 0x004D #LATIN CAPITAL LETTER M
|
||||
0x4E 0x004E #LATIN CAPITAL LETTER N
|
||||
0x4F 0x004F #LATIN CAPITAL LETTER O
|
||||
0x50 0x0050 #LATIN CAPITAL LETTER P
|
||||
0x51 0x0051 #LATIN CAPITAL LETTER Q
|
||||
0x52 0x0052 #LATIN CAPITAL LETTER R
|
||||
0x53 0x0053 #LATIN CAPITAL LETTER S
|
||||
0x54 0x0054 #LATIN CAPITAL LETTER T
|
||||
0x55 0x0055 #LATIN CAPITAL LETTER U
|
||||
0x56 0x0056 #LATIN CAPITAL LETTER V
|
||||
0x57 0x0057 #LATIN CAPITAL LETTER W
|
||||
0x58 0x0058 #LATIN CAPITAL LETTER X
|
||||
0x59 0x0059 #LATIN CAPITAL LETTER Y
|
||||
0x5A 0x005A #LATIN CAPITAL LETTER Z
|
||||
0x5B 0x005B #LEFT SQUARE BRACKET
|
||||
0x5C 0x005C #REVERSE SOLIDUS
|
||||
0x5D 0x005D #RIGHT SQUARE BRACKET
|
||||
0x5E 0x005E #CIRCUMFLEX ACCENT
|
||||
0x5F 0x005F #LOW LINE
|
||||
0x60 0x0060 #GRAVE ACCENT
|
||||
0x61 0x0061 #LATIN SMALL LETTER A
|
||||
0x62 0x0062 #LATIN SMALL LETTER B
|
||||
0x63 0x0063 #LATIN SMALL LETTER C
|
||||
0x64 0x0064 #LATIN SMALL LETTER D
|
||||
0x65 0x0065 #LATIN SMALL LETTER E
|
||||
0x66 0x0066 #LATIN SMALL LETTER F
|
||||
0x67 0x0067 #LATIN SMALL LETTER G
|
||||
0x68 0x0068 #LATIN SMALL LETTER H
|
||||
0x69 0x0069 #LATIN SMALL LETTER I
|
||||
0x6A 0x006A #LATIN SMALL LETTER J
|
||||
0x6B 0x006B #LATIN SMALL LETTER K
|
||||
0x6C 0x006C #LATIN SMALL LETTER L
|
||||
0x6D 0x006D #LATIN SMALL LETTER M
|
||||
0x6E 0x006E #LATIN SMALL LETTER N
|
||||
0x6F 0x006F #LATIN SMALL LETTER O
|
||||
0x70 0x0070 #LATIN SMALL LETTER P
|
||||
0x71 0x0071 #LATIN SMALL LETTER Q
|
||||
0x72 0x0072 #LATIN SMALL LETTER R
|
||||
0x73 0x0073 #LATIN SMALL LETTER S
|
||||
0x74 0x0074 #LATIN SMALL LETTER T
|
||||
0x75 0x0075 #LATIN SMALL LETTER U
|
||||
0x76 0x0076 #LATIN SMALL LETTER V
|
||||
0x77 0x0077 #LATIN SMALL LETTER W
|
||||
0x78 0x0078 #LATIN SMALL LETTER X
|
||||
0x79 0x0079 #LATIN SMALL LETTER Y
|
||||
0x7A 0x007A #LATIN SMALL LETTER Z
|
||||
0x7B 0x007B #LEFT CURLY BRACKET
|
||||
0x7C 0x007C #VERTICAL LINE
|
||||
0x7D 0x007D #RIGHT CURLY BRACKET
|
||||
0x7E 0x007E #TILDE
|
||||
0x7F 0x007F #DELETE
|
||||
0x80 0x20AC #EURO SIGN
|
||||
0x81 #UNDEFINED
|
||||
0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
|
||||
0x83 #UNDEFINED
|
||||
0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
|
||||
0x85 0x2026 #HORIZONTAL ELLIPSIS
|
||||
0x86 0x2020 #DAGGER
|
||||
0x87 0x2021 #DOUBLE DAGGER
|
||||
0x88 #UNDEFINED
|
||||
0x89 0x2030 #PER MILLE SIGN
|
||||
0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON
|
||||
0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
|
||||
0x8C 0x015A #LATIN CAPITAL LETTER S WITH ACUTE
|
||||
0x8D 0x0164 #LATIN CAPITAL LETTER T WITH CARON
|
||||
0x8E 0x017D #LATIN CAPITAL LETTER Z WITH CARON
|
||||
0x8F 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE
|
||||
0x90 #UNDEFINED
|
||||
0x91 0x2018 #LEFT SINGLE QUOTATION MARK
|
||||
0x92 0x2019 #RIGHT SINGLE QUOTATION MARK
|
||||
0x93 0x201C #LEFT DOUBLE QUOTATION MARK
|
||||
0x94 0x201D #RIGHT DOUBLE QUOTATION MARK
|
||||
0x95 0x2022 #BULLET
|
||||
0x96 0x2013 #EN DASH
|
||||
0x97 0x2014 #EM DASH
|
||||
0x98 #UNDEFINED
|
||||
0x99 0x2122 #TRADE MARK SIGN
|
||||
0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON
|
||||
0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
|
||||
0x9C 0x015B #LATIN SMALL LETTER S WITH ACUTE
|
||||
0x9D 0x0165 #LATIN SMALL LETTER T WITH CARON
|
||||
0x9E 0x017E #LATIN SMALL LETTER Z WITH CARON
|
||||
0x9F 0x017A #LATIN SMALL LETTER Z WITH ACUTE
|
||||
0xA0 0x00A0 #NO-BREAK SPACE
|
||||
0xA1 0x02C7 #CARON
|
||||
0xA2 0x02D8 #BREVE
|
||||
0xA3 0x0141 #LATIN CAPITAL LETTER L WITH STROKE
|
||||
0xA4 0x00A4 #CURRENCY SIGN
|
||||
0xA5 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK
|
||||
0xA6 0x00A6 #BROKEN BAR
|
||||
0xA7 0x00A7 #SECTION SIGN
|
||||
0xA8 0x00A8 #DIAERESIS
|
||||
0xA9 0x00A9 #COPYRIGHT SIGN
|
||||
0xAA 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA
|
||||
0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
0xAC 0x00AC #NOT SIGN
|
||||
0xAD 0x00AD #SOFT HYPHEN
|
||||
0xAE 0x00AE #REGISTERED SIGN
|
||||
0xAF 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE
|
||||
0xB0 0x00B0 #DEGREE SIGN
|
||||
0xB1 0x00B1 #PLUS-MINUS SIGN
|
||||
0xB2 0x02DB #OGONEK
|
||||
0xB3 0x0142 #LATIN SMALL LETTER L WITH STROKE
|
||||
0xB4 0x00B4 #ACUTE ACCENT
|
||||
0xB5 0x00B5 #MICRO SIGN
|
||||
0xB6 0x00B6 #PILCROW SIGN
|
||||
0xB7 0x00B7 #MIDDLE DOT
|
||||
0xB8 0x00B8 #CEDILLA
|
||||
0xB9 0x0105 #LATIN SMALL LETTER A WITH OGONEK
|
||||
0xBA 0x015F #LATIN SMALL LETTER S WITH CEDILLA
|
||||
0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
0xBC 0x013D #LATIN CAPITAL LETTER L WITH CARON
|
||||
0xBD 0x02DD #DOUBLE ACUTE ACCENT
|
||||
0xBE 0x013E #LATIN SMALL LETTER L WITH CARON
|
||||
0xBF 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE
|
||||
0xC0 0x0154 #LATIN CAPITAL LETTER R WITH ACUTE
|
||||
0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
|
||||
0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
|
||||
0xC3 0x0102 #LATIN CAPITAL LETTER A WITH BREVE
|
||||
0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
|
||||
0xC5 0x0139 #LATIN CAPITAL LETTER L WITH ACUTE
|
||||
0xC6 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE
|
||||
0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
|
||||
0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON
|
||||
0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
|
||||
0xCA 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK
|
||||
0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
|
||||
0xCC 0x011A #LATIN CAPITAL LETTER E WITH CARON
|
||||
0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
|
||||
0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
|
||||
0xCF 0x010E #LATIN CAPITAL LETTER D WITH CARON
|
||||
0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE
|
||||
0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE
|
||||
0xD2 0x0147 #LATIN CAPITAL LETTER N WITH CARON
|
||||
0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
|
||||
0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
|
||||
0xD5 0x0150 #LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
|
||||
0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
|
||||
0xD7 0x00D7 #MULTIPLICATION SIGN
|
||||
0xD8 0x0158 #LATIN CAPITAL LETTER R WITH CARON
|
||||
0xD9 0x016E #LATIN CAPITAL LETTER U WITH RING ABOVE
|
||||
0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
|
||||
0xDB 0x0170 #LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
|
||||
0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
|
||||
0xDD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE
|
||||
0xDE 0x0162 #LATIN CAPITAL LETTER T WITH CEDILLA
|
||||
0xDF 0x00DF #LATIN SMALL LETTER SHARP S
|
||||
0xE0 0x0155 #LATIN SMALL LETTER R WITH ACUTE
|
||||
0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
|
||||
0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
|
||||
0xE3 0x0103 #LATIN SMALL LETTER A WITH BREVE
|
||||
0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
|
||||
0xE5 0x013A #LATIN SMALL LETTER L WITH ACUTE
|
||||
0xE6 0x0107 #LATIN SMALL LETTER C WITH ACUTE
|
||||
0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
|
||||
0xE8 0x010D #LATIN SMALL LETTER C WITH CARON
|
||||
0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
|
||||
0xEA 0x0119 #LATIN SMALL LETTER E WITH OGONEK
|
||||
0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
|
||||
0xEC 0x011B #LATIN SMALL LETTER E WITH CARON
|
||||
0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
|
||||
0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
|
||||
0xEF 0x010F #LATIN SMALL LETTER D WITH CARON
|
||||
0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE
|
||||
0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE
|
||||
0xF2 0x0148 #LATIN SMALL LETTER N WITH CARON
|
||||
0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
|
||||
0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
|
||||
0xF5 0x0151 #LATIN SMALL LETTER O WITH DOUBLE ACUTE
|
||||
0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
|
||||
0xF7 0x00F7 #DIVISION SIGN
|
||||
0xF8 0x0159 #LATIN SMALL LETTER R WITH CARON
|
||||
0xF9 0x016F #LATIN SMALL LETTER U WITH RING ABOVE
|
||||
0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
|
||||
0xFB 0x0171 #LATIN SMALL LETTER U WITH DOUBLE ACUTE
|
||||
0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
|
||||
0xFD 0x00FD #LATIN SMALL LETTER Y WITH ACUTE
|
||||
0xFE 0x0163 #LATIN SMALL LETTER T WITH CEDILLA
|
||||
0xFF 0x02D9 #DOT ABOVE
|
||||
|
|
@ -163,8 +163,10 @@ SYMBOL: interactive-vocabs
|
|||
"syntax"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.deprecation"
|
||||
"tools.destructors"
|
||||
"tools.disassembler"
|
||||
"tools.dispatch"
|
||||
"tools.errors"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
|
|
|
|||
|
|
@ -582,3 +582,20 @@ STRUCT: simd-struct
|
|||
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
|
||||
[ compile-call ] [ call ] 3bi =
|
||||
] unit-test
|
||||
|
||||
! Spilling SIMD values -- this basically just tests that the
|
||||
! stack was aligned properly by the runtime
|
||||
|
||||
: simd-spill-test-1 ( a b c -- v )
|
||||
{ float-4 float-4 float } declare
|
||||
[ v+ ] dip sin v*n ;
|
||||
|
||||
[ float-4{ 0 0 0 0 } ]
|
||||
[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
|
||||
|
||||
: simd-spill-test-2 ( a b d c -- v )
|
||||
{ float float-4 float-4 float } declare
|
||||
[ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
|
||||
|
||||
[ float-4{ 0 0 0 0 } ]
|
||||
[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -110,3 +110,7 @@ SYMBOL: pprint-string-cells?
|
|||
] with-row
|
||||
] each
|
||||
] tabular-output nl ;
|
||||
|
||||
: object-table. ( obj alist -- )
|
||||
[ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
|
||||
simple-table. ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ words.private definitions assocs summary compiler.units
|
|||
system.private combinators combinators.short-circuit locals
|
||||
locals.backend locals.types combinators.private
|
||||
stack-checker.values generic.single generic.single.private
|
||||
alien.libraries
|
||||
alien.libraries tools.dispatch.private tools.profiler.private
|
||||
stack-checker.alien
|
||||
stack-checker.state
|
||||
stack-checker.errors
|
||||
|
|
@ -501,16 +501,14 @@ M: bad-executable summary
|
|||
|
||||
\ compact-gc { } { } define-primitive
|
||||
|
||||
\ gc-stats { } { array } define-primitive
|
||||
|
||||
\ (save-image) { byte-array } { } define-primitive
|
||||
|
||||
\ (save-image-and-exit) { byte-array } { } define-primitive
|
||||
|
||||
\ data-room { } { integer integer array } define-primitive
|
||||
\ data-room { } { byte-array } define-primitive
|
||||
\ data-room make-flushable
|
||||
|
||||
\ code-room { } { integer integer integer integer } define-primitive
|
||||
\ code-room { } { byte-array } define-primitive
|
||||
\ code-room make-flushable
|
||||
|
||||
\ micros { } { integer } define-primitive
|
||||
|
|
@ -594,7 +592,7 @@ M: bad-executable summary
|
|||
|
||||
\ set-alien-double { float c-ptr integer } { } define-primitive
|
||||
|
||||
\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
|
||||
\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
|
||||
\ alien-cell make-flushable
|
||||
|
||||
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
|
||||
|
|
@ -701,21 +699,20 @@ M: bad-executable summary
|
|||
|
||||
\ unimplemented { } { } define-primitive
|
||||
|
||||
\ gc-reset { } { } define-primitive
|
||||
|
||||
\ gc-stats { } { array } define-primitive
|
||||
|
||||
\ jit-compile { quotation } { } define-primitive
|
||||
|
||||
\ lookup-method { object array } { word } define-primitive
|
||||
|
||||
\ reset-dispatch-stats { } { } define-primitive
|
||||
\ dispatch-stats { } { array } define-primitive
|
||||
\ reset-inline-cache-stats { } { } define-primitive
|
||||
\ inline-cache-stats { } { array } define-primitive
|
||||
|
||||
\ optimized? { word } { object } define-primitive
|
||||
|
||||
\ strip-stack-traces { } { } define-primitive
|
||||
|
||||
\ <callback> { word } { alien } define-primitive
|
||||
|
||||
\ enable-gc-events { } { } define-primitive
|
||||
\ disable-gc-events { } { object } define-primitive
|
||||
|
||||
\ profiling { object } { } define-primitive
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
IN: tools.dispatch
|
||||
USING: help.markup help.syntax vm quotations ;
|
||||
|
||||
HELP: last-dispatch-stats
|
||||
{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ;
|
||||
|
||||
HELP: dispatch-stats.
|
||||
{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ;
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces prettyprint classes.struct
|
||||
vm tools.dispatch.private ;
|
||||
IN: tools.dispatch
|
||||
|
||||
SYMBOL: last-dispatch-stats
|
||||
|
||||
: dispatch-stats. ( -- )
|
||||
last-dispatch-stats get {
|
||||
{ "Megamorphic hits" [ megamorphic-cache-hits>> ] }
|
||||
{ "Megamorphic misses" [ megamorphic-cache-misses>> ] }
|
||||
{ "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] }
|
||||
{ "Mono to polymorphic" [ ic-to-pic-transitions>> ] }
|
||||
{ "Poly to megamorphic" [ pic-to-mega-transitions>> ] }
|
||||
{ "Tag check count" [ pic-tag-count>> ] }
|
||||
{ "Tuple check count" [ pic-tuple-count>> ] }
|
||||
} object-table. ;
|
||||
|
||||
: collect-dispatch-stats ( quot -- )
|
||||
reset-dispatch-stats
|
||||
call
|
||||
dispatch-stats dispatch-statistics memory>struct
|
||||
last-dispatch-stats set ; inline
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax memory sequences ;
|
||||
USING: help.markup help.syntax memory sequences vm ;
|
||||
IN: tools.memory
|
||||
|
||||
ARTICLE: "tools.memory" "Object memory tools"
|
||||
|
|
@ -39,3 +39,15 @@ HELP: heap-stats.
|
|||
{ $description "For each class, prints the number of instances and total memory consumed by those instances." } ;
|
||||
|
||||
{ heap-stats heap-stats. } related-words
|
||||
|
||||
HELP: gc-events.
|
||||
{ $description "Prints all garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
|
||||
|
||||
HELP: gc-stats.
|
||||
{ $description "Prints a breakdown of different garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
|
||||
|
||||
HELP: gc-summary.
|
||||
{ $description "Prints aggregate garbage collection statistics from the last call to " { $link collect-gc-events } "." } ;
|
||||
|
||||
HELP: gc-events
|
||||
{ $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
USING: tools.test tools.memory ;
|
||||
USING: tools.test tools.memory memory ;
|
||||
IN: tools.memory.tests
|
||||
|
||||
[ ] [ room. ] unit-test
|
||||
[ ] [ heap-stats. ] unit-test
|
||||
[ ] [ [ gc gc ] collect-gc-events ] unit-test
|
||||
[ ] [ gc-events. ] unit-test
|
||||
[ ] [ gc-stats. ] unit-test
|
||||
[ ] [ gc-summary. ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,55 +1,78 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays generic assocs io math
|
||||
namespaces parser prettyprint strings io.styles words
|
||||
system sorting splitting grouping math.parser classes memory
|
||||
combinators fry ;
|
||||
USING: accessors arrays assocs classes classes.struct
|
||||
combinators combinators.smart continuations fry generalizations
|
||||
generic grouping io io.styles kernel make math math.parser
|
||||
math.statistics memory namespaces parser prettyprint sequences
|
||||
sorting specialized-arrays splitting strings system vm words ;
|
||||
SPECIALIZED-ARRAY: gc-event
|
||||
IN: tools.memory
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: write-size ( n -- )
|
||||
: commas ( n -- str )
|
||||
dup 0 < [ neg commas "-" prepend ] [
|
||||
number>string
|
||||
dup length 4 > [ 3 cut* "," glue ] when
|
||||
" KB" append write-cell ;
|
||||
reverse 3 group "," join reverse
|
||||
] if ;
|
||||
|
||||
: write-total/used/free ( free total str -- )
|
||||
[
|
||||
write-cell
|
||||
dup write-size
|
||||
over - write-size
|
||||
write-size
|
||||
] with-row ;
|
||||
: kilobytes ( n -- str )
|
||||
1024 /i commas " KB" append ;
|
||||
|
||||
: write-total ( n str -- )
|
||||
[
|
||||
write-cell
|
||||
write-size
|
||||
[ ] with-cell
|
||||
[ ] with-cell
|
||||
] with-row ;
|
||||
: micros>string ( n -- str )
|
||||
commas " µs" append ;
|
||||
|
||||
: write-headings ( seq -- )
|
||||
[ [ write-cell ] each ] with-row ;
|
||||
: copying-room. ( copying-sizes -- )
|
||||
{
|
||||
{ "Size:" [ size>> kilobytes ] }
|
||||
{ "Occupied:" [ occupied>> kilobytes ] }
|
||||
{ "Free:" [ free>> kilobytes ] }
|
||||
} object-table. ;
|
||||
|
||||
: (data-room.) ( -- )
|
||||
data-room 2 <groups> [
|
||||
[ first2 ] [ number>string "Generation " prepend ] bi*
|
||||
write-total/used/free
|
||||
] each-index
|
||||
"Decks" write-total
|
||||
"Cards" write-total ;
|
||||
: nursery-room. ( data-room -- )
|
||||
"- Nursery space" print nursery>> copying-room. ;
|
||||
|
||||
: write-labeled-size ( n string -- )
|
||||
[ write-cell write-size ] with-row ;
|
||||
: aging-room. ( data-room -- )
|
||||
"- Aging space" print aging>> copying-room. ;
|
||||
|
||||
: (code-room.) ( -- )
|
||||
code-room {
|
||||
[ "Size:" write-labeled-size ]
|
||||
[ "Used:" write-labeled-size ]
|
||||
[ "Total free space:" write-labeled-size ]
|
||||
[ "Largest free block:" write-labeled-size ]
|
||||
} spread ;
|
||||
: mark-sweep-table. ( mark-sweep-sizes -- )
|
||||
{
|
||||
{ "Size:" [ size>> kilobytes ] }
|
||||
{ "Occupied:" [ occupied>> kilobytes ] }
|
||||
{ "Total free:" [ total-free>> kilobytes ] }
|
||||
{ "Contiguous free:" [ contiguous-free>> kilobytes ] }
|
||||
{ "Free block count:" [ free-block-count>> number>string ] }
|
||||
} object-table. ;
|
||||
|
||||
: tenured-room. ( data-room -- )
|
||||
"- Tenured space" print tenured>> mark-sweep-table. ;
|
||||
|
||||
: misc-room. ( data-room -- )
|
||||
"- Miscellaneous buffers" print
|
||||
{
|
||||
{ "Card array:" [ cards>> kilobytes ] }
|
||||
{ "Deck array:" [ decks>> kilobytes ] }
|
||||
{ "Mark stack:" [ mark-stack>> kilobytes ] }
|
||||
} object-table. ;
|
||||
|
||||
: data-room. ( -- )
|
||||
"== Data heap ==" print nl
|
||||
data-room data-heap-room memory>struct {
|
||||
[ nursery-room. nl ]
|
||||
[ aging-room. nl ]
|
||||
[ tenured-room. nl ]
|
||||
[ misc-room. ]
|
||||
} cleave ;
|
||||
|
||||
: code-room. ( -- )
|
||||
"== Code heap ==" print nl
|
||||
code-room mark-sweep-sizes memory>struct mark-sweep-table. ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: room. ( -- ) data-room. nl code-room. ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: heap-stat-step ( obj counts sizes -- )
|
||||
[ [ class ] dip inc-at ]
|
||||
|
|
@ -57,26 +80,13 @@ IN: tools.memory
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: room. ( -- )
|
||||
"==== DATA HEAP" print
|
||||
standard-table-style [
|
||||
{ "" "Total" "Used" "Free" } write-headings
|
||||
(data-room.)
|
||||
] tabular-output
|
||||
nl nl
|
||||
"==== CODE HEAP" print
|
||||
standard-table-style [
|
||||
(code-room.)
|
||||
] tabular-output
|
||||
nl ;
|
||||
|
||||
: heap-stats ( -- counts sizes )
|
||||
[ ] instances H{ } clone H{ } clone
|
||||
[ '[ _ _ heap-stat-step ] each ] 2keep ;
|
||||
|
||||
: heap-stats. ( -- )
|
||||
heap-stats dup keys natural-sort standard-table-style [
|
||||
{ "Class" "Bytes" "Instances" } write-headings
|
||||
[ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
|
||||
[
|
||||
[
|
||||
dup pprint-cell
|
||||
|
|
@ -85,3 +95,104 @@ PRIVATE>
|
|||
] with-row
|
||||
] each 2drop
|
||||
] tabular-output nl ;
|
||||
|
||||
SYMBOL: gc-events
|
||||
|
||||
: collect-gc-events ( quot -- )
|
||||
enable-gc-events
|
||||
[ ] [ disable-gc-events drop ] cleanup
|
||||
disable-gc-events byte-array>gc-event-array gc-events set ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: gc-op-string ( op -- string )
|
||||
{
|
||||
{ collect-nursery-op [ "Copying from nursery" ] }
|
||||
{ collect-aging-op [ "Copying from aging" ] }
|
||||
{ collect-to-tenured-op [ "Copying to tenured" ] }
|
||||
{ collect-full-op [ "Mark and sweep" ] }
|
||||
{ collect-compact-op [ "Mark and compact" ] }
|
||||
{ collect-growing-heap-op [ "Grow heap" ] }
|
||||
} case ;
|
||||
|
||||
: (space-occupied) ( data-heap-room code-heap-room -- n )
|
||||
[
|
||||
[ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
|
||||
[ occupied>> ]
|
||||
bi*
|
||||
] sum-outputs ;
|
||||
|
||||
: space-occupied-before ( event -- bytes )
|
||||
[ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
|
||||
|
||||
: space-occupied-after ( event -- bytes )
|
||||
[ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
|
||||
|
||||
: space-reclaimed ( event -- bytes )
|
||||
[ space-occupied-before ] [ space-occupied-after ] bi - ;
|
||||
|
||||
TUPLE: gc-stats collections times ;
|
||||
|
||||
: <gc-stats> ( -- stats )
|
||||
gc-stats new
|
||||
0 >>collections
|
||||
V{ } clone >>times ; inline
|
||||
|
||||
: compute-gc-stats ( events -- stats )
|
||||
V{ } clone [
|
||||
'[
|
||||
dup op>> _ [ drop <gc-stats> ] cache
|
||||
[ 1 + ] change-collections
|
||||
[ total-time>> ] dip times>> push
|
||||
] each
|
||||
] keep sort-keys ;
|
||||
|
||||
: gc-stats-table-row ( pair -- row )
|
||||
[
|
||||
[ first gc-op-string ] [
|
||||
second
|
||||
[ collections>> ]
|
||||
[
|
||||
times>> {
|
||||
[ sum micros>string ]
|
||||
[ mean >integer micros>string ]
|
||||
[ median >integer micros>string ]
|
||||
[ infimum micros>string ]
|
||||
[ supremum micros>string ]
|
||||
} cleave
|
||||
] bi
|
||||
] bi
|
||||
] output>array ;
|
||||
|
||||
: gc-stats-table ( stats -- table )
|
||||
[ gc-stats-table-row ] map
|
||||
{ "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: gc-event. ( event -- )
|
||||
{
|
||||
{ "Event type:" [ op>> gc-op-string ] }
|
||||
{ "Total time:" [ total-time>> micros>string ] }
|
||||
{ "Space reclaimed:" [ space-reclaimed kilobytes ] }
|
||||
} object-table. ;
|
||||
|
||||
: gc-events. ( -- )
|
||||
gc-events get [ gc-event. nl ] each ;
|
||||
|
||||
: gc-stats. ( -- )
|
||||
gc-events get compute-gc-stats gc-stats-table simple-table. ;
|
||||
|
||||
: gc-summary. ( -- )
|
||||
gc-events get {
|
||||
{ "Collections:" [ length commas ] }
|
||||
{ "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
|
||||
{ "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
|
||||
{ "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
|
||||
{ "Total time:" [ [ total-time>> ] map-sum micros>string ] }
|
||||
{ "Card scan time:" [ [ card-scan-time>> ] map-sum micros>string ] }
|
||||
{ "Code block scan time:" [ [ code-scan-time>> ] map-sum micros>string ] }
|
||||
{ "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum micros>string ] }
|
||||
{ "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum micros>string ] }
|
||||
{ "Compaction time:" [ [ compaction-time>> ] map-sum micros>string ] }
|
||||
} object-table. ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ $nl
|
|||
method-profile.
|
||||
"profiler-limitations"
|
||||
}
|
||||
{ $see-also "ui.tools.profiler" } ;
|
||||
{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ;
|
||||
|
||||
ABOUT: "profiling"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,28 +1,38 @@
|
|||
USING: help.markup help.syntax memory system ;
|
||||
USING: help.markup help.syntax memory system tools.dispatch
|
||||
tools.memory quotations vm ;
|
||||
IN: tools.time
|
||||
|
||||
ARTICLE: "timing" "Timing code"
|
||||
ARTICLE: "timing" "Timing code and collecting statistics"
|
||||
"You can time the execution of a quotation in the listener:"
|
||||
{ $subsections time }
|
||||
"This word also collects statistics about method dispatch and garbage collection:"
|
||||
{ $subsections dispatch-stats. gc-events. gc-stats. gc-summary. }
|
||||
"A lower-level word puts timings on the stack, intead of printing:"
|
||||
{ $subsections benchmark }
|
||||
"You can also read the system clock and garbage collection statistics directly:"
|
||||
{ $subsections
|
||||
micros
|
||||
gc-stats
|
||||
}
|
||||
{ $see-also "profiling" } ;
|
||||
"You can also read the system clock directly:"
|
||||
{ $subsections micros }
|
||||
{ $see-also "profiling" "calendar" } ;
|
||||
|
||||
ABOUT: "timing"
|
||||
|
||||
HELP: benchmark
|
||||
{ $values { "quot" "a quotation" }
|
||||
{ $values { "quot" quotation }
|
||||
{ "runtime" "the runtime in microseconds" } }
|
||||
{ $description "Runs a quotation, measuring the total wall clock time." }
|
||||
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
|
||||
|
||||
HELP: time
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
|
||||
|
||||
{ benchmark micros time } related-words
|
||||
|
||||
HELP: collect-gc-events
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
|
||||
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
|
||||
|
||||
HELP: collect-dispatch-stats
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
|
||||
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
|
||||
|
|
|
|||
|
|
@ -1,74 +1,22 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math memory io io.styles prettyprint
|
||||
namespaces system sequences splitting grouping assocs strings
|
||||
generic.single combinators ;
|
||||
USING: system kernel math io prettyprint tools.memory
|
||||
tools.dispatch ;
|
||||
IN: tools.time
|
||||
|
||||
: benchmark ( quot -- runtime )
|
||||
micros [ call micros ] dip - ; inline
|
||||
|
||||
: time. ( time -- )
|
||||
"== Running time ==" print nl 1000000 /f pprint " seconds" print ;
|
||||
"Running time: " write 1000000 /f pprint " seconds" print ;
|
||||
|
||||
: gc-stats. ( stats -- )
|
||||
5 cut*
|
||||
"== Garbage collection ==" print nl
|
||||
"Times are in microseconds." print nl
|
||||
[
|
||||
6 group
|
||||
{
|
||||
"GC count:"
|
||||
"Total GC time:"
|
||||
"Longest GC pause:"
|
||||
"Average GC pause:"
|
||||
"Objects copied:"
|
||||
"Bytes copied:"
|
||||
} prefix
|
||||
flip
|
||||
{ "" "Nursery" "Aging" "Tenured" } prefix
|
||||
simple-table.
|
||||
]
|
||||
[
|
||||
nl
|
||||
{
|
||||
"Total GC time:"
|
||||
"Cards scanned:"
|
||||
"Decks scanned:"
|
||||
"Card scan time:"
|
||||
"Code heap literal scans:"
|
||||
} swap zip simple-table.
|
||||
] bi* ;
|
||||
|
||||
: dispatch-stats. ( stats -- )
|
||||
"== Megamorphic caches ==" print nl
|
||||
{ "Hits" "Misses" } swap zip simple-table. ;
|
||||
|
||||
: inline-cache-stats. ( stats -- )
|
||||
nl "== Polymorphic inline caches ==" print nl
|
||||
3 cut
|
||||
[
|
||||
"Transitions:" print
|
||||
{ "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
|
||||
simple-table. nl
|
||||
] [
|
||||
"Type check stubs:" print
|
||||
{ "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
|
||||
simple-table.
|
||||
] bi* ;
|
||||
: time-banner. ( -- )
|
||||
"Additional information was collected." print
|
||||
"dispatch-stats. - Print method dispatch statistics" print
|
||||
"gc-events. - Print all garbage collection events" print
|
||||
"gc-stats. - Print breakdown of different garbage collection events" print
|
||||
"gc-summary. - Print aggregate garbage collection statistics" print ;
|
||||
|
||||
: time ( quot -- )
|
||||
gc-reset
|
||||
reset-dispatch-stats
|
||||
reset-inline-cache-stats
|
||||
benchmark gc-stats dispatch-stats inline-cache-stats
|
||||
H{ { table-gap { 20 20 } } } [
|
||||
[
|
||||
[ [ time. ] 3dip ] with-cell
|
||||
[ ] with-cell
|
||||
] with-row
|
||||
[
|
||||
[ [ gc-stats. ] 2dip ] with-cell
|
||||
[ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
|
||||
] with-row
|
||||
] tabular-output nl ; inline
|
||||
[ [ benchmark ] collect-dispatch-stats ] collect-gc-events
|
||||
time. nl time-banner. ; inline
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: classes.struct alien.c-types alien.syntax ;
|
||||
IN: vm
|
||||
|
||||
TYPEDEF: void* cell
|
||||
TYPEDEF: intptr_t cell
|
||||
C-TYPE: context
|
||||
|
||||
STRUCT: zone
|
||||
|
|
@ -20,3 +20,60 @@ STRUCT: vm
|
|||
{ 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 } ;
|
||||
|
|
|
|||
|
|
@ -4,19 +4,9 @@ USING: accessors assocs kernel math namespaces sequences system
|
|||
kernel.private byte-arrays arrays init ;
|
||||
IN: alien
|
||||
|
||||
! Some predicate classes used by the compiler for optimization
|
||||
! purposes
|
||||
PREDICATE: simple-alien < alien underlying>> not ;
|
||||
PREDICATE: pinned-alien < alien underlying>> not ;
|
||||
|
||||
UNION: simple-c-ptr
|
||||
simple-alien POSTPONE: f byte-array ;
|
||||
|
||||
DEFER: pinned-c-ptr?
|
||||
|
||||
PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
|
||||
|
||||
UNION: pinned-c-ptr
|
||||
pinned-alien POSTPONE: f ;
|
||||
UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
|
||||
|
||||
GENERIC: >c-ptr ( obj -- c-ptr )
|
||||
|
||||
|
|
@ -33,7 +23,7 @@ M: alien expired? expired>> ;
|
|||
M: f expired? drop t ;
|
||||
|
||||
: <alien> ( address -- alien )
|
||||
f <displaced-alien> { simple-c-ptr } declare ; inline
|
||||
f <displaced-alien> { pinned-c-ptr } declare ; inline
|
||||
|
||||
: <bad-alien> ( -- alien )
|
||||
-1 <alien> t >>expired ; inline
|
||||
|
|
@ -49,7 +39,8 @@ M: alien equal?
|
|||
2drop f
|
||||
] if ;
|
||||
|
||||
M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
|
||||
M: pinned-alien hashcode*
|
||||
nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
|
||||
|
||||
ERROR: alien-callback-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,32 +5,28 @@ hashtables vectors strings sbufs arrays
|
|||
quotations assocs layouts classes.tuple.private
|
||||
kernel.private ;
|
||||
|
||||
BIN: 111 tag-mask set
|
||||
8 num-tags set
|
||||
3 tag-bits set
|
||||
16 data-alignment set
|
||||
|
||||
15 num-types set
|
||||
BIN: 1111 tag-mask set
|
||||
4 tag-bits set
|
||||
|
||||
14 num-types set
|
||||
|
||||
32 mega-cache-size set
|
||||
|
||||
H{
|
||||
{ fixnum BIN: 000 }
|
||||
{ bignum BIN: 001 }
|
||||
{ array BIN: 010 }
|
||||
{ float BIN: 011 }
|
||||
{ quotation BIN: 100 }
|
||||
{ POSTPONE: f BIN: 101 }
|
||||
{ object BIN: 110 }
|
||||
{ hi-tag BIN: 110 }
|
||||
{ tuple BIN: 111 }
|
||||
} tag-numbers set
|
||||
|
||||
tag-numbers get H{
|
||||
{ fixnum 0 }
|
||||
{ POSTPONE: f 1 }
|
||||
{ array 2 }
|
||||
{ float 3 }
|
||||
{ quotation 4 }
|
||||
{ bignum 5 }
|
||||
{ alien 6 }
|
||||
{ tuple 7 }
|
||||
{ wrapper 8 }
|
||||
{ byte-array 9 }
|
||||
{ callstack 10 }
|
||||
{ string 11 }
|
||||
{ word 12 }
|
||||
{ dll 13 }
|
||||
{ alien 14 }
|
||||
} assoc-union type-numbers set
|
||||
} type-numbers set
|
||||
|
|
|
|||
|
|
@ -99,6 +99,7 @@ bootstrapping? on
|
|||
"system"
|
||||
"system.private"
|
||||
"threads.private"
|
||||
"tools.dispatch.private"
|
||||
"tools.profiler.private"
|
||||
"words"
|
||||
"words.private"
|
||||
|
|
@ -177,10 +178,6 @@ bi
|
|||
|
||||
"object?" "kernel" vocab-words delete-at
|
||||
|
||||
! Class of objects with object tag
|
||||
"hi-tag" "kernel.private" create
|
||||
builtins get num-tags get tail define-union-class
|
||||
|
||||
! Empty class with no instances
|
||||
"null" "kernel" create
|
||||
[ f { } f union-class define-class ]
|
||||
|
|
@ -423,7 +420,6 @@ tuple
|
|||
{ "minor-gc" "memory" (( -- )) }
|
||||
{ "gc" "memory" (( -- )) }
|
||||
{ "compact-gc" "memory" (( -- )) }
|
||||
{ "gc-stats" "memory" f }
|
||||
{ "(save-image)" "memory.private" (( path -- )) }
|
||||
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
|
||||
{ "datastack" "kernel" (( -- ds )) }
|
||||
|
|
@ -433,8 +429,8 @@ tuple
|
|||
{ "set-retainstack" "kernel" (( rs -- )) }
|
||||
{ "set-callstack" "kernel" (( cs -- )) }
|
||||
{ "exit" "system" (( n -- )) }
|
||||
{ "data-room" "memory" (( -- cards decks generations )) }
|
||||
{ "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
|
||||
{ "data-room" "memory" (( -- data-room )) }
|
||||
{ "code-room" "memory" (( -- code-room )) }
|
||||
{ "micros" "system" (( -- us )) }
|
||||
{ "modify-code-heap" "compiler.units" (( alist -- )) }
|
||||
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
|
||||
|
|
@ -509,7 +505,6 @@ tuple
|
|||
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
|
||||
{ "dll-valid?" "alien.libraries" (( dll -- ? )) }
|
||||
{ "unimplemented" "kernel.private" (( -- * )) }
|
||||
{ "gc-reset" "memory" (( -- )) }
|
||||
{ "jit-compile" "quotations" (( quot -- )) }
|
||||
{ "load-locals" "locals.backend" (( ... n -- )) }
|
||||
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
|
||||
|
|
@ -517,15 +512,15 @@ tuple
|
|||
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
|
||||
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
|
||||
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
|
||||
{ "reset-dispatch-stats" "generic.single" (( -- )) }
|
||||
{ "dispatch-stats" "generic.single" (( -- stats )) }
|
||||
{ "reset-inline-cache-stats" "generic.single" (( -- )) }
|
||||
{ "inline-cache-stats" "generic.single" (( -- stats )) }
|
||||
{ "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }
|
||||
{ "dispatch-stats" "tools.dispatch.private" (( -- stats )) }
|
||||
{ "optimized?" "words" (( word -- ? )) }
|
||||
{ "quot-compiled?" "quotations" (( quot -- ? )) }
|
||||
{ "vm-ptr" "vm" (( -- ptr )) }
|
||||
{ "strip-stack-traces" "kernel.private" (( -- )) }
|
||||
{ "<callback>" "alien" (( word -- alien )) }
|
||||
{ "enable-gc-events" "memory" (( -- )) }
|
||||
{ "disable-gc-events" "memory" (( -- events )) }
|
||||
} [ [ first3 ] dip swap make-primitive ] each-index
|
||||
|
||||
! Bump build number
|
||||
|
|
|
|||
|
|
@ -17,7 +17,6 @@ ARTICLE: "class-operations" "Class operations"
|
|||
flatten-class
|
||||
flatten-builtin-class
|
||||
class-types
|
||||
class-tags
|
||||
} ;
|
||||
|
||||
ARTICLE: "class-linearization" "Class linearization"
|
||||
|
|
|
|||
|
|
@ -95,8 +95,6 @@ UNION: z1 b1 c1 ;
|
|||
|
||||
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
|
||||
|
||||
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
growable tuple sequence class-and class<=
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -237,11 +237,5 @@ M: anonymous-union (flatten-class)
|
|||
flatten-builtin-class keys
|
||||
[ "type" word-prop ] map natural-sort ;
|
||||
|
||||
: class-tags ( class -- seq )
|
||||
class-types [
|
||||
dup num-tags get >=
|
||||
[ drop \ hi-tag tag-number ] when
|
||||
] map prune ;
|
||||
|
||||
: class-tag ( class -- tag/f )
|
||||
class-tags dup length 1 = [ first ] [ drop f ] if ;
|
||||
: class-type ( class -- tag/f )
|
||||
class-types dup length 1 = [ first ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -12,34 +12,20 @@ PREDICATE: builtin-class < class
|
|||
|
||||
: class>type ( class -- n ) "type" word-prop ; foldable
|
||||
|
||||
PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
|
||||
|
||||
PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
|
||||
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
M: hi-tag class hi-tag type>class ; inline
|
||||
|
||||
M: object class tag type>class ; inline
|
||||
|
||||
M: builtin-class rank-class drop 0 ;
|
||||
|
||||
GENERIC: define-builtin-predicate ( class -- )
|
||||
|
||||
M: lo-tag-class define-builtin-predicate
|
||||
M: builtin-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
|
||||
|
||||
M: hi-tag-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
|
||||
[ dup tag 6 eq? ] [ [ drop f ] if ] surround
|
||||
define-predicate ;
|
||||
|
||||
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
|
||||
|
||||
M: hi-tag-class instance?
|
||||
over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
|
||||
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
|
||||
|
||||
M: builtin-class (flatten-class) dup set ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@ IN: classes.tests
|
|||
[ f ] [ 3 float instance? ] unit-test
|
||||
[ t ] [ 3 number instance? ] unit-test
|
||||
[ f ] [ 3 null instance? ] unit-test
|
||||
[ t ] [ "hi" \ hi-tag instance? ] unit-test
|
||||
|
||||
! Regression
|
||||
GENERIC: method-forget-test ( obj -- obj )
|
||||
|
|
|
|||
|
|
@ -112,15 +112,6 @@ TUPLE: tuple-dispatch-engine echelons ;
|
|||
tuple bootstrap-word
|
||||
\ <tuple-dispatch-engine> convert-methods ;
|
||||
|
||||
! 2.2 Convert hi-tag methods
|
||||
TUPLE: hi-tag-dispatch-engine methods ;
|
||||
|
||||
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
||||
|
||||
: convert-hi-tag-methods ( assoc -- assoc' )
|
||||
\ hi-tag bootstrap-word
|
||||
\ <hi-tag-dispatch-engine> convert-methods ;
|
||||
|
||||
! 3 Tag methods
|
||||
TUPLE: tag-dispatch-engine methods ;
|
||||
|
||||
|
|
@ -129,7 +120,6 @@ C: <tag-dispatch-engine> tag-dispatch-engine
|
|||
: <engine> ( assoc -- engine )
|
||||
flatten-methods
|
||||
convert-tuple-methods
|
||||
convert-hi-tag-methods
|
||||
<tag-dispatch-engine> ;
|
||||
|
||||
! ! ! Compile engine ! ! !
|
||||
|
|
@ -144,23 +134,12 @@ GENERIC: compile-engine ( engine -- obj )
|
|||
: direct-dispatch-table ( assoc n -- table )
|
||||
default get <array> [ <enum> swap update ] keep ;
|
||||
|
||||
: lo-tag-number ( class -- n )
|
||||
"type" word-prop dup num-tags get iota member?
|
||||
[ drop object tag-number ] unless ;
|
||||
: tag-number ( class -- n ) "type" word-prop ;
|
||||
|
||||
M: tag-dispatch-engine compile-engine
|
||||
methods>> compile-engines*
|
||||
[ [ lo-tag-number ] dip ] assoc-map
|
||||
num-tags get direct-dispatch-table ;
|
||||
|
||||
: num-hi-tags ( -- n ) num-types get num-tags get - ;
|
||||
|
||||
: hi-tag-number ( class -- n ) "type" word-prop ;
|
||||
|
||||
M: hi-tag-dispatch-engine compile-engine
|
||||
methods>> compile-engines*
|
||||
[ [ hi-tag-number num-tags get - ] dip ] assoc-map
|
||||
num-hi-tags direct-dispatch-table ;
|
||||
[ [ tag-number ] dip ] assoc-map
|
||||
num-types get direct-dispatch-table ;
|
||||
|
||||
: build-fast-hash ( methods -- buckets )
|
||||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||
|
|
|
|||
|
|
@ -651,7 +651,7 @@ HELP: declare
|
|||
|
||||
HELP: tag ( object -- n )
|
||||
{ $values { "object" object } { "n" "a tag number" } }
|
||||
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ;
|
||||
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
|
||||
|
||||
HELP: getenv ( n -- obj )
|
||||
{ $values { "n" "a non-negative integer" } { "obj" object } }
|
||||
|
|
|
|||
|
|
@ -230,8 +230,6 @@ ERROR: assert got expect ;
|
|||
|
||||
: declare ( spec -- ) drop ;
|
||||
|
||||
: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
|
||||
|
||||
: do-primitive ( number -- ) "Improper primitive call" throw ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -7,18 +7,11 @@ HELP: tag-bits
|
|||
{ $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
|
||||
{ $see-also tag } ;
|
||||
|
||||
HELP: num-tags
|
||||
{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ;
|
||||
|
||||
HELP: tag-mask
|
||||
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
|
||||
|
||||
HELP: num-types
|
||||
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
|
||||
|
||||
HELP: tag-number
|
||||
{ $values { "class" class } { "n" "an integer or " { $link f } } }
|
||||
{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ;
|
||||
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ;
|
||||
|
||||
HELP: type-number
|
||||
{ $values { "class" class } { "n" "an integer or " { $link f } } }
|
||||
|
|
@ -76,7 +69,7 @@ HELP: bootstrap-cell-bits
|
|||
|
||||
ARTICLE: "layouts-types" "Type numbers"
|
||||
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
|
||||
{ $subsections hi-tag }
|
||||
{ $subsections tag }
|
||||
"Built-in type numbers can be converted to classes, and vice versa:"
|
||||
{ $subsections
|
||||
type>class
|
||||
|
|
@ -88,14 +81,10 @@ ARTICLE: "layouts-types" "Type numbers"
|
|||
ARTICLE: "layouts-tags" "Tagged pointers"
|
||||
"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
|
||||
$nl
|
||||
"Getting the tag of an object:"
|
||||
{ $link tag }
|
||||
"Words for working with tagged pointers:"
|
||||
{ $subsections
|
||||
tag-bits
|
||||
num-tags
|
||||
tag-mask
|
||||
tag-number
|
||||
}
|
||||
"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,16 +4,14 @@ USING: namespaces math words kernel assocs classes
|
|||
math.order kernel.private ;
|
||||
IN: layouts
|
||||
|
||||
SYMBOL: tag-mask
|
||||
SYMBOL: data-alignment
|
||||
|
||||
SYMBOL: num-tags
|
||||
SYMBOL: tag-mask
|
||||
|
||||
SYMBOL: tag-bits
|
||||
|
||||
SYMBOL: num-types
|
||||
|
||||
SYMBOL: tag-numbers
|
||||
|
||||
SYMBOL: type-numbers
|
||||
|
||||
SYMBOL: mega-cache-size
|
||||
|
|
@ -21,9 +19,6 @@ SYMBOL: mega-cache-size
|
|||
: type-number ( class -- n )
|
||||
type-numbers get at ;
|
||||
|
||||
: tag-number ( class -- n )
|
||||
type-number dup num-tags get >= [ drop object tag-number ] when ;
|
||||
|
||||
: tag-fixnum ( n -- tagged )
|
||||
tag-bits get shift ;
|
||||
|
||||
|
|
@ -58,7 +53,7 @@ SYMBOL: mega-cache-size
|
|||
first-bignum neg >fixnum ; inline
|
||||
|
||||
: (max-array-capacity) ( b -- n )
|
||||
5 - 2^ 1 - ; inline
|
||||
6 - 2^ 1 - ; inline
|
||||
|
||||
: max-array-capacity ( -- n )
|
||||
cell-bits (max-array-capacity) ; inline
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ $nl
|
|||
{ { { $link float } } { $snippet "0.0" } }
|
||||
{ { { $link string } } { $snippet "\"\"" } }
|
||||
{ { { $link byte-array } } { $snippet "B{ }" } }
|
||||
{ { { $link simple-alien } } { $snippet "BAD-ALIEN" } }
|
||||
{ { { $link pinned-alien } } { $snippet "BAD-ALIEN" } }
|
||||
}
|
||||
"All other classes are handled with one of two cases:"
|
||||
{ $list
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@ M: class initial-value* no-initial-value ;
|
|||
{ [ string bootstrap-word over class<= ] [ "" ] }
|
||||
{ [ array bootstrap-word over class<= ] [ { } ] }
|
||||
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
|
||||
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
|
||||
{ [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
|
||||
{ [ quotation bootstrap-word over class<= ] [ [ ] ] }
|
||||
[ dup initial-value* ]
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
|
Before Width: | Height: | Size: 5.1 KiB After Width: | Height: | Size: 5.1 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 44 B After Width: | Height: | Size: 44 B |
|
Before Width: | Height: | Size: 10 KiB After Width: | Height: | Size: 10 KiB |
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue