Replace ##gc with a gc flag in the basic block
							parent
							
								
									f09813f6fd
								
							
						
					
					
						commit
						73d01452cb
					
				| 
						 | 
					@ -12,6 +12,7 @@ compiler.cfg
 | 
				
			||||||
compiler.cfg.hats
 | 
					compiler.cfg.hats
 | 
				
			||||||
compiler.cfg.stacks
 | 
					compiler.cfg.stacks
 | 
				
			||||||
compiler.cfg.iterator
 | 
					compiler.cfg.iterator
 | 
				
			||||||
 | 
					compiler.cfg.utilities
 | 
				
			||||||
compiler.cfg.registers
 | 
					compiler.cfg.registers
 | 
				
			||||||
compiler.cfg.intrinsics
 | 
					compiler.cfg.intrinsics
 | 
				
			||||||
compiler.cfg.instructions
 | 
					compiler.cfg.instructions
 | 
				
			||||||
| 
						 | 
					@ -20,19 +21,6 @@ IN: compiler.cfg.builder
 | 
				
			||||||
 | 
					
 | 
				
			||||||
! Convert tree SSA IR to CFG SSA IR.
 | 
					! Convert tree SSA IR to CFG SSA IR.
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: set-basic-block ( basic-block -- )
 | 
					 | 
				
			||||||
    [ basic-block set ] [ instructions>> building set ] bi ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: begin-basic-block ( -- )
 | 
					 | 
				
			||||||
    <basic-block> basic-block get [
 | 
					 | 
				
			||||||
        dupd successors>> push
 | 
					 | 
				
			||||||
    ] when*
 | 
					 | 
				
			||||||
    set-basic-block ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: end-basic-block ( -- )
 | 
					 | 
				
			||||||
    building off
 | 
					 | 
				
			||||||
    basic-block off ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: stop-iterating ( -- next ) end-basic-block f ;
 | 
					: stop-iterating ( -- next ) end-basic-block f ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
SYMBOL: procedures
 | 
					SYMBOL: procedures
 | 
				
			||||||
| 
						 | 
					@ -98,7 +86,7 @@ GENERIC: emit-node ( node -- next )
 | 
				
			||||||
: emit-call ( word -- next )
 | 
					: emit-call ( word -- next )
 | 
				
			||||||
    {
 | 
					    {
 | 
				
			||||||
        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
 | 
					        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
 | 
				
			||||||
        { [ tail-call? not ] [ ##call iterate-next ] }
 | 
					        { [ tail-call? not ] [ ##call begin-basic-block iterate-next ] }
 | 
				
			||||||
        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
 | 
					        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
 | 
				
			||||||
        [ ##epilogue ##jump stop-iterating ]
 | 
					        [ ##epilogue ##jump stop-iterating ]
 | 
				
			||||||
    } cond ;
 | 
					    } cond ;
 | 
				
			||||||
| 
						 | 
					@ -241,7 +229,7 @@ M: #terminate emit-node drop stop-iterating ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-alien-node ( node quot -- next )
 | 
					: emit-alien-node ( node quot -- next )
 | 
				
			||||||
    [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
 | 
					    [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
 | 
				
			||||||
    iterate-next ; inline
 | 
					    begin-basic-block iterate-next ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke emit-node
 | 
					M: #alien-invoke emit-node
 | 
				
			||||||
    [ ##alien-invoke ] emit-alien-node ;
 | 
					    [ ##alien-invoke ] emit-alien-node ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -7,17 +7,18 @@ TUPLE: cfg entry word label ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
C: <cfg> cfg
 | 
					C: <cfg> cfg
 | 
				
			||||||
 | 
					
 | 
				
			||||||
! - "number" and "visited" is used by linearization.
 | 
					 | 
				
			||||||
TUPLE: basic-block < identity-tuple
 | 
					TUPLE: basic-block < identity-tuple
 | 
				
			||||||
visited
 | 
					id
 | 
				
			||||||
number
 | 
					number
 | 
				
			||||||
instructions
 | 
					instructions
 | 
				
			||||||
successors ;
 | 
					successors
 | 
				
			||||||
 | 
					gc ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: <basic-block> ( -- basic-block )
 | 
					: <basic-block> ( -- basic-block )
 | 
				
			||||||
    basic-block new
 | 
					    basic-block new
 | 
				
			||||||
        V{ } clone >>instructions
 | 
					        V{ } clone >>instructions
 | 
				
			||||||
        V{ } clone >>successors ;
 | 
					        V{ } clone >>successors
 | 
				
			||||||
 | 
					        \ basic-block counter >>id ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: mr { instructions array } word label spill-counts ;
 | 
					TUPLE: mr { instructions array } word label spill-counts ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -29,7 +29,7 @@ TUPLE: ##effect < insn { src vreg } ;
 | 
				
			||||||
TUPLE: ##read < ##flushable ;
 | 
					TUPLE: ##read < ##flushable ;
 | 
				
			||||||
TUPLE: ##write < ##effect ;
 | 
					TUPLE: ##write < ##effect ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: ##alien-getter < ##read { src vreg } ;
 | 
					TUPLE: ##alien-getter < ##flushable { src vreg } ;
 | 
				
			||||||
TUPLE: ##alien-setter < ##effect { value vreg } ;
 | 
					TUPLE: ##alien-setter < ##effect { value vreg } ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
! Stack operations
 | 
					! Stack operations
 | 
				
			||||||
| 
						 | 
					@ -145,7 +145,6 @@ INSN: ##set-alien-double < ##alien-setter ;
 | 
				
			||||||
! Memory allocation
 | 
					! Memory allocation
 | 
				
			||||||
INSN: ##allot < ##flushable size class { temp vreg } ;
 | 
					INSN: ##allot < ##flushable size class { temp vreg } ;
 | 
				
			||||||
INSN: ##write-barrier < ##effect card# table ;
 | 
					INSN: ##write-barrier < ##effect card# table ;
 | 
				
			||||||
INSN: ##gc ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
! FFI
 | 
					! FFI
 | 
				
			||||||
INSN: ##alien-invoke params ;
 | 
					INSN: ##alien-invoke params ;
 | 
				
			||||||
| 
						 | 
					@ -194,6 +193,8 @@ INSN: _epilogue stack-frame ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
INSN: _label id ;
 | 
					INSN: _label id ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					INSN: _gc ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
INSN: _branch label ;
 | 
					INSN: _branch label ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 | 
					TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -4,7 +4,7 @@ USING: accessors kernel sequences alien math classes.algebra
 | 
				
			||||||
fry locals combinators cpu.architecture
 | 
					fry locals combinators cpu.architecture
 | 
				
			||||||
compiler.tree.propagation.info
 | 
					compiler.tree.propagation.info
 | 
				
			||||||
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
 | 
					compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
 | 
				
			||||||
compiler.cfg.intrinsics.utilities ;
 | 
					compiler.cfg.utilities ;
 | 
				
			||||||
IN: compiler.cfg.intrinsics.alien
 | 
					IN: compiler.cfg.intrinsics.alien
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
 | 
					: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -4,7 +4,7 @@ USING: kernel math math.order sequences accessors arrays
 | 
				
			||||||
byte-arrays layouts classes.tuple.private fry locals
 | 
					byte-arrays layouts classes.tuple.private fry locals
 | 
				
			||||||
compiler.tree.propagation.info compiler.cfg.hats
 | 
					compiler.tree.propagation.info compiler.cfg.hats
 | 
				
			||||||
compiler.cfg.instructions compiler.cfg.stacks
 | 
					compiler.cfg.instructions compiler.cfg.stacks
 | 
				
			||||||
compiler.cfg.intrinsics.utilities ;
 | 
					compiler.cfg.utilities ;
 | 
				
			||||||
IN: compiler.cfg.intrinsics.allot
 | 
					IN: compiler.cfg.intrinsics.allot
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: ##set-slots ( regs obj class -- )
 | 
					: ##set-slots ( regs obj class -- )
 | 
				
			||||||
| 
						 | 
					@ -14,7 +14,7 @@ IN: compiler.cfg.intrinsics.allot
 | 
				
			||||||
    [ in-d>> length ] [ node-output-infos first class>> ] bi
 | 
					    [ in-d>> length ] [ node-output-infos first class>> ] bi
 | 
				
			||||||
    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
 | 
					    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
 | 
				
			||||||
    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
 | 
					    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
 | 
				
			||||||
    ##gc ;
 | 
					    need-gc ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: tuple-slot-regs ( layout -- vregs )
 | 
					: tuple-slot-regs ( layout -- vregs )
 | 
				
			||||||
    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
 | 
					    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
 | 
				
			||||||
| 
						 | 
					@ -26,7 +26,7 @@ IN: compiler.cfg.intrinsics.allot
 | 
				
			||||||
        ds-drop
 | 
					        ds-drop
 | 
				
			||||||
        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
 | 
					        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
 | 
				
			||||||
        [ tuple ##set-slots ] [ ds-push drop ] 2bi
 | 
					        [ tuple ##set-slots ] [ ds-push drop ] 2bi
 | 
				
			||||||
        ##gc
 | 
					        need-gc
 | 
				
			||||||
    ] [ drop emit-primitive ] if ;
 | 
					    ] [ drop emit-primitive ] if ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: store-length ( len reg -- )
 | 
					: store-length ( len reg -- )
 | 
				
			||||||
| 
						 | 
					@ -47,7 +47,7 @@ IN: compiler.cfg.intrinsics.allot
 | 
				
			||||||
                len reg store-length
 | 
					                len reg store-length
 | 
				
			||||||
                elt reg len store-initial-element
 | 
					                elt reg len store-initial-element
 | 
				
			||||||
                reg ds-push
 | 
					                reg ds-push
 | 
				
			||||||
                ##gc
 | 
					                need-gc
 | 
				
			||||||
            ]
 | 
					            ]
 | 
				
			||||||
        ] [ node emit-primitive ] if
 | 
					        ] [ node emit-primitive ] if
 | 
				
			||||||
    ] ;
 | 
					    ] ;
 | 
				
			||||||
| 
						 | 
					@ -66,7 +66,7 @@ IN: compiler.cfg.intrinsics.allot
 | 
				
			||||||
                len reg store-length
 | 
					                len reg store-length
 | 
				
			||||||
                elt reg len bytes>cells store-initial-element
 | 
					                elt reg len bytes>cells store-initial-element
 | 
				
			||||||
                reg ds-push
 | 
					                reg ds-push
 | 
				
			||||||
                ##gc
 | 
					                need-gc
 | 
				
			||||||
            ]
 | 
					            ]
 | 
				
			||||||
        ] [ node emit-primitive ] if
 | 
					        ] [ node emit-primitive ] if
 | 
				
			||||||
    ] ;
 | 
					    ] ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -4,7 +4,7 @@ USING: sequences accessors layouts kernel math namespaces
 | 
				
			||||||
combinators fry locals
 | 
					combinators fry locals
 | 
				
			||||||
compiler.tree.propagation.info
 | 
					compiler.tree.propagation.info
 | 
				
			||||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 | 
					compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 | 
				
			||||||
compiler.cfg.intrinsics.utilities ;
 | 
					compiler.cfg.utilities ;
 | 
				
			||||||
IN: compiler.cfg.intrinsics.fixnum
 | 
					IN: compiler.cfg.intrinsics.fixnum
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
 | 
					: (emit-fixnum-imm-op) ( infos insn -- dst )
 | 
				
			||||||
| 
						 | 
					@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.fixnum
 | 
				
			||||||
    ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 | 
					    ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-fixnum>bignum ( -- )
 | 
					: emit-fixnum>bignum ( -- )
 | 
				
			||||||
    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ##gc ;
 | 
					    ds-pop ^^untag-fixnum ^^integer>bignum ds-push need-gc ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -1,13 +1,13 @@
 | 
				
			||||||
! Copyright (C) 2008 Slava Pestov.
 | 
					! Copyright (C) 2008 Slava Pestov.
 | 
				
			||||||
! See http://factorcode.org/license.txt for BSD license.
 | 
					! See http://factorcode.org/license.txt for BSD license.
 | 
				
			||||||
USING: kernel compiler.cfg.stacks compiler.cfg.hats
 | 
					USING: kernel compiler.cfg.stacks compiler.cfg.hats
 | 
				
			||||||
compiler.cfg.instructions ;
 | 
					compiler.cfg.instructions compiler.cfg.utilities ;
 | 
				
			||||||
IN: compiler.cfg.intrinsics.float
 | 
					IN: compiler.cfg.intrinsics.float
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-float-op ( insn -- )
 | 
					: emit-float-op ( insn -- )
 | 
				
			||||||
    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
 | 
					    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
 | 
				
			||||||
    ds-push
 | 
					    ds-push
 | 
				
			||||||
    ##gc ; inline
 | 
					    need-gc ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-float-comparison ( cc -- )
 | 
					: emit-float-comparison ( cc -- )
 | 
				
			||||||
    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
 | 
					    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
 | 
				
			||||||
| 
						 | 
					@ -17,4 +17,5 @@ IN: compiler.cfg.intrinsics.float
 | 
				
			||||||
    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 | 
					    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-fixnum>float ( -- )
 | 
					: emit-fixnum>float ( -- )
 | 
				
			||||||
    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ##gc  ;
 | 
					    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push
 | 
				
			||||||
 | 
					    need-gc ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -3,7 +3,7 @@
 | 
				
			||||||
USING: layouts namespaces kernel accessors sequences
 | 
					USING: layouts namespaces kernel accessors sequences
 | 
				
			||||||
classes.algebra compiler.tree.propagation.info
 | 
					classes.algebra compiler.tree.propagation.info
 | 
				
			||||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 | 
					compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 | 
				
			||||||
compiler.cfg.intrinsics.utilities ;
 | 
					compiler.cfg.utilities ;
 | 
				
			||||||
IN: compiler.cfg.intrinsics.slots
 | 
					IN: compiler.cfg.intrinsics.slots
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: emit-tag ( -- )
 | 
					: emit-tag ( -- )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -21,10 +21,10 @@ M: ##stack-frame compute-stack-frame*
 | 
				
			||||||
    frame-required? on
 | 
					    frame-required? on
 | 
				
			||||||
    stack-frame>> stack-frame [ max-stack-frame ] change ;
 | 
					    stack-frame>> stack-frame [ max-stack-frame ] change ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: ##gc compute-stack-frame*
 | 
					M: ##call compute-stack-frame*
 | 
				
			||||||
    drop frame-required? on ;
 | 
					    drop frame-required? on ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: ##call compute-stack-frame*
 | 
					M: _gc compute-stack-frame*
 | 
				
			||||||
    drop frame-required? on ;
 | 
					    drop frame-required? on ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: _spill compute-stack-frame*
 | 
					M: _spill compute-stack-frame*
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -201,7 +201,7 @@ M: ##write-barrier generate-insn
 | 
				
			||||||
    [ table>> register ]
 | 
					    [ table>> register ]
 | 
				
			||||||
    tri %write-barrier ;
 | 
					    tri %write-barrier ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: ##gc generate-insn drop %gc ;
 | 
					M: _gc generate-insn drop %gc ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
! ##alien-invoke
 | 
					! ##alien-invoke
 | 
				
			||||||
GENERIC: reg-size ( register-class -- n )
 | 
					GENERIC: reg-size ( register-class -- n )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue