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

compiler: tweak ##write-barrier-imm

db4
Slava Pestov 2009-10-15 02:40:23 -05:00
parent 93ed6e6892
commit 7d97c19227
3 changed files with 44 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences classes.algebra USING: layouts namespaces kernel accessors sequences
fry compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats classes.algebra locals compiler.tree.propagation.info
compiler.cfg.registers compiler.cfg.instructions compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
compiler.cfg.utilities compiler.cfg.builder.blocks ; compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ; inline : value-tag ( info -- n ) class>> class-tag ; inline
@ -30,18 +31,31 @@ IN: compiler.cfg.intrinsics.slots
ds-push ds-push
] [ drop emit-primitive ] if ; ] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- ) : emit-write-barrier? ( infos -- ? )
[ first class>> immediate class<= ] first class>> immediate class<= not ;
[ [ 3inputs ] [ second value-tag ] bi* ^^tag-offset>slot ] bi
[ ##set-slot ]
[ '[ _ drop _ _ next-vreg next-vreg ##write-barrier ] unless ] 3bi ;
: (emit-set-slot-imm) ( infos -- ) :: (emit-set-slot) ( infos -- )
3inputs :> slot :> obj :> src
slot infos second value-tag ^^tag-offset>slot :> slot
src obj slot ##set-slot
infos emit-write-barrier?
[ obj slot next-vreg next-vreg ##write-barrier ] when ;
:: (emit-set-slot-imm) ( infos -- )
ds-drop ds-drop
[ first class>> immediate class<= ]
[ [ 2inputs ] [ [ third literal>> ] [ second value-tag ] bi ] bi* ] bi 2inputs :> obj :> src
'[ _ ##set-slot-imm ]
[ '[ _ drop _ _ cells next-vreg next-vreg ##write-barrier-imm ] unless ] 3bi ; infos third literal>> :> slot
infos second value-tag :> tag
src obj slot tag ##set-slot-imm
infos emit-write-barrier?
[ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
: emit-set-slot ( node -- ) : emit-set-slot ( node -- )
dup node-input-infos dup node-input-infos

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

@ -10,19 +10,21 @@ CONSTANT: deck-bits 18
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline : card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h ! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; inline : 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 : float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-offset ( -- n ) 4 string tag-number slot-offset ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline : profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline : byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline : quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline : word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes ! Relocation classes

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

@ -93,7 +93,7 @@ M: x86 %return ( -- ) 0 RET ;
0 <repetition> % ; 0 <repetition> % ;
:: (%slot-imm) ( obj slot tag -- op ) :: (%slot-imm) ( obj slot tag -- op )
obj slot cells tag - [+] ; inline obj slot tag slot-offset [+] ; inline
M: x86 %slot ( dst obj slot -- ) [+] MOV ; M: x86 %slot ( dst obj slot -- ) [+] MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
@ -395,8 +395,7 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
:: (%write-barrier) ( src slot temp1 temp2 -- ) :: (%write-barrier) ( src slot temp1 temp2 -- )
! Compute slot address. ! Compute slot address.
temp1 src MOV temp1 src slot [+] LEA
temp1 slot ADD
! Mark the card ! Mark the card
temp1 card-bits SHR temp1 card-bits SHR