64 lines
		
	
	
		
			1.6 KiB
		
	
	
	
		
			Factor
		
	
	
			
		
		
	
	
			64 lines
		
	
	
		
			1.6 KiB
		
	
	
	
		
			Factor
		
	
	
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 | 
						|
! See http://factorcode.org/license.txt for BSD license.
 | 
						|
USING: accessors assocs combinators.short-circuit
 | 
						|
compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
 | 
						|
sequences sets ;
 | 
						|
IN: compiler.cfg.write-barrier
 | 
						|
 | 
						|
! This pass must run after GC check insertion and scheduling.
 | 
						|
 | 
						|
SYMBOL: fresh-allocations
 | 
						|
 | 
						|
SYMBOL: mutated-objects
 | 
						|
 | 
						|
SYMBOL: copies
 | 
						|
 | 
						|
: resolve-copy ( src -- dst )
 | 
						|
    copies get ?at drop ;
 | 
						|
 | 
						|
GENERIC: eliminate-write-barrier ( insn -- ? )
 | 
						|
 | 
						|
: fresh-allocation ( vreg -- )
 | 
						|
    fresh-allocations get adjoin ;
 | 
						|
 | 
						|
M: ##allot eliminate-write-barrier
 | 
						|
    dst>> fresh-allocation t ;
 | 
						|
 | 
						|
: mutated-object ( vreg -- )
 | 
						|
    resolve-copy mutated-objects get adjoin ;
 | 
						|
 | 
						|
M: ##set-slot eliminate-write-barrier
 | 
						|
    obj>> mutated-object t ;
 | 
						|
 | 
						|
M: ##set-slot-imm eliminate-write-barrier
 | 
						|
    obj>> mutated-object t ;
 | 
						|
 | 
						|
: needs-write-barrier? ( insn -- ? )
 | 
						|
    resolve-copy {
 | 
						|
        [ fresh-allocations get in? not ]
 | 
						|
        [ mutated-objects get in? ]
 | 
						|
    } 1&& ;
 | 
						|
 | 
						|
M: ##write-barrier eliminate-write-barrier
 | 
						|
    src>> needs-write-barrier? ;
 | 
						|
 | 
						|
M: ##write-barrier-imm eliminate-write-barrier
 | 
						|
    src>> needs-write-barrier? ;
 | 
						|
 | 
						|
M: gc-map-insn eliminate-write-barrier
 | 
						|
    fresh-allocations get clear-set ;
 | 
						|
 | 
						|
M: ##copy eliminate-write-barrier
 | 
						|
    [ src>> resolve-copy ] [ dst>> ] bi copies get set-at t ;
 | 
						|
 | 
						|
M: insn eliminate-write-barrier drop t ;
 | 
						|
 | 
						|
: write-barriers-step ( insns -- insns' )
 | 
						|
    HS{ } clone fresh-allocations set
 | 
						|
    HS{ } clone mutated-objects set
 | 
						|
    H{ } clone copies set
 | 
						|
    [ eliminate-write-barrier ] filter! ;
 | 
						|
 | 
						|
: eliminate-write-barriers ( cfg -- )
 | 
						|
    [ write-barriers-step ] simple-optimization ;
 |