Merge branch 'master' of git://factorcode.org/git/factor
						commit
						43bcfd2944
					
				| 
						 | 
				
			
			@ -0,0 +1,74 @@
 | 
			
		|||
! Copyright (C) 2008 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: namespaces accessors math.order assocs kernel sequences
 | 
			
		||||
combinators make classes words cpu.architecture
 | 
			
		||||
compiler.cfg.instructions compiler.cfg.registers
 | 
			
		||||
compiler.cfg.stack-frame ;
 | 
			
		||||
IN: compiler.cfg.build-stack-frame
 | 
			
		||||
 | 
			
		||||
SYMBOL: frame-required?
 | 
			
		||||
 | 
			
		||||
SYMBOL: spill-counts
 | 
			
		||||
 | 
			
		||||
GENERIC: compute-stack-frame* ( insn -- )
 | 
			
		||||
 | 
			
		||||
: request-stack-frame ( stack-frame -- )
 | 
			
		||||
    stack-frame [ max-stack-frame ] change ;
 | 
			
		||||
 | 
			
		||||
M: ##stack-frame compute-stack-frame*
 | 
			
		||||
    frame-required? on
 | 
			
		||||
    stack-frame>> request-stack-frame ;
 | 
			
		||||
 | 
			
		||||
M: ##call compute-stack-frame*
 | 
			
		||||
    word>> sub-primitive>> [ frame-required? on ] unless ;
 | 
			
		||||
 | 
			
		||||
M: _gc compute-stack-frame*
 | 
			
		||||
    frame-required? on
 | 
			
		||||
    stack-frame new swap gc-root-size>> >>gc-root-size
 | 
			
		||||
    request-stack-frame ;
 | 
			
		||||
 | 
			
		||||
M: _spill-counts compute-stack-frame*
 | 
			
		||||
    counts>> stack-frame get (>>spill-counts) ;
 | 
			
		||||
 | 
			
		||||
M: insn compute-stack-frame*
 | 
			
		||||
    class frame-required? word-prop [
 | 
			
		||||
        frame-required? on
 | 
			
		||||
    ] when ;
 | 
			
		||||
 | 
			
		||||
\ _spill t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-add t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-sub t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-mul t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-add-tail f frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-sub-tail f frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-mul-tail f frame-required? set-word-prop
 | 
			
		||||
 | 
			
		||||
: compute-stack-frame ( insns -- )
 | 
			
		||||
    frame-required? off
 | 
			
		||||
    T{ stack-frame } clone stack-frame set
 | 
			
		||||
    [ compute-stack-frame* ] each
 | 
			
		||||
    stack-frame get dup stack-frame-size >>total-size drop ;
 | 
			
		||||
 | 
			
		||||
GENERIC: insert-pro/epilogues* ( insn -- )
 | 
			
		||||
 | 
			
		||||
M: ##stack-frame insert-pro/epilogues* drop ;
 | 
			
		||||
 | 
			
		||||
M: ##prologue insert-pro/epilogues*
 | 
			
		||||
    drop frame-required? get [ stack-frame get _prologue ] when ;
 | 
			
		||||
 | 
			
		||||
M: ##epilogue insert-pro/epilogues*
 | 
			
		||||
    drop frame-required? get [ stack-frame get _epilogue ] when ;
 | 
			
		||||
 | 
			
		||||
M: insn insert-pro/epilogues* , ;
 | 
			
		||||
 | 
			
		||||
: insert-pro/epilogues ( insns -- insns )
 | 
			
		||||
    [ [ insert-pro/epilogues* ] each ] { } make ;
 | 
			
		||||
 | 
			
		||||
: build-stack-frame ( mr -- mr )
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
            [ compute-stack-frame ]
 | 
			
		||||
            [ insert-pro/epilogues ]
 | 
			
		||||
            bi
 | 
			
		||||
        ] change-instructions
 | 
			
		||||
    ] with-scope ;
 | 
			
		||||
| 
						 | 
				
			
			@ -15,6 +15,7 @@ compiler.cfg.iterator
 | 
			
		|||
compiler.cfg.utilities
 | 
			
		||||
compiler.cfg.registers
 | 
			
		||||
compiler.cfg.intrinsics
 | 
			
		||||
compiler.cfg.stack-frame
 | 
			
		||||
compiler.cfg.instructions
 | 
			
		||||
compiler.alien ;
 | 
			
		||||
IN: compiler.cfg.builder
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -31,6 +31,7 @@ M: ##compare-imm temp-vregs temp>> 1array ;
 | 
			
		|||
M: ##compare-float temp-vregs temp>> 1array ;
 | 
			
		||||
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 | 
			
		||||
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 | 
			
		||||
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 | 
			
		||||
M: _dispatch temp-vregs temp>> 1array ;
 | 
			
		||||
M: insn temp-vregs drop f ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -51,7 +52,6 @@ M: ##alien-getter uses-vregs src>> 1array ;
 | 
			
		|||
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 | 
			
		||||
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 | 
			
		||||
M: ##phi uses-vregs inputs>> ;
 | 
			
		||||
M: ##gc uses-vregs live-in>> ;
 | 
			
		||||
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 | 
			
		||||
M: _compare-imm-branch uses-vregs src1>> 1array ;
 | 
			
		||||
M: _dispatch uses-vregs src>> 1array ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,8 @@
 | 
			
		|||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors kernel sequences assocs
 | 
			
		||||
cpu.architecture compiler.cfg.rpo
 | 
			
		||||
compiler.cfg.liveness compiler.cfg.instructions ;
 | 
			
		||||
compiler.cfg.liveness compiler.cfg.instructions
 | 
			
		||||
compiler.cfg.hats ;
 | 
			
		||||
IN: compiler.cfg.gc-checks
 | 
			
		||||
 | 
			
		||||
: gc? ( bb -- ? )
 | 
			
		||||
| 
						 | 
				
			
			@ -13,9 +14,7 @@ IN: compiler.cfg.gc-checks
 | 
			
		|||
 | 
			
		||||
: insert-gc-check ( basic-block -- )
 | 
			
		||||
    dup gc? [
 | 
			
		||||
        dup
 | 
			
		||||
        [ swap object-pointer-regs \ ##gc new-insn prefix ]
 | 
			
		||||
        change-instructions drop
 | 
			
		||||
        [ i i f f \ ##gc new-insn prefix ] change-instructions drop
 | 
			
		||||
    ] [ drop ] if ;
 | 
			
		||||
 | 
			
		||||
: insert-gc-checks ( cfg -- cfg' )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -52,12 +52,6 @@ INSN: ##inc-d { n integer } ;
 | 
			
		|||
INSN: ##inc-r { n integer } ;
 | 
			
		||||
 | 
			
		||||
! Subroutine calls
 | 
			
		||||
TUPLE: stack-frame
 | 
			
		||||
{ params integer }
 | 
			
		||||
{ return integer }
 | 
			
		||||
{ total-size integer }
 | 
			
		||||
spill-counts ;
 | 
			
		||||
 | 
			
		||||
INSN: ##stack-frame stack-frame ;
 | 
			
		||||
INSN: ##call word { height integer } ;
 | 
			
		||||
INSN: ##jump word ;
 | 
			
		||||
| 
						 | 
				
			
			@ -223,7 +217,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 | 
			
		|||
INSN: ##compare-float-branch < ##conditional-branch ;
 | 
			
		||||
INSN: ##compare-float < ##binary cc temp ;
 | 
			
		||||
 | 
			
		||||
INSN: ##gc live-in ;
 | 
			
		||||
INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
 | 
			
		||||
 | 
			
		||||
! Instructions used by machine IR only.
 | 
			
		||||
INSN: _prologue stack-frame ;
 | 
			
		||||
| 
						 | 
				
			
			@ -243,6 +237,10 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 | 
			
		|||
 | 
			
		||||
INSN: _compare-float-branch < _conditional-branch ;
 | 
			
		||||
 | 
			
		||||
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 | 
			
		||||
 | 
			
		||||
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
 | 
			
		||||
 | 
			
		||||
! These instructions operate on machine registers and not
 | 
			
		||||
! virtual registers
 | 
			
		||||
INSN: _spill src class n ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -58,17 +58,34 @@ SYMBOL: unhandled-intervals
 | 
			
		|||
        ] [ 2drop ] if
 | 
			
		||||
    ] if ;
 | 
			
		||||
 | 
			
		||||
GENERIC: assign-registers-in-insn ( insn -- )
 | 
			
		||||
GENERIC: assign-before ( insn -- )
 | 
			
		||||
 | 
			
		||||
GENERIC: assign-after ( insn -- )
 | 
			
		||||
 | 
			
		||||
: all-vregs ( insn -- vregs )
 | 
			
		||||
    [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 | 
			
		||||
 | 
			
		||||
M: vreg-insn assign-registers-in-insn
 | 
			
		||||
M: vreg-insn assign-before
 | 
			
		||||
    active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
 | 
			
		||||
    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
 | 
			
		||||
    >>regs drop ;
 | 
			
		||||
 | 
			
		||||
M: insn assign-registers-in-insn drop ;
 | 
			
		||||
M: insn assign-before drop ;
 | 
			
		||||
 | 
			
		||||
: compute-live-registers ( -- regs )
 | 
			
		||||
    active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
 | 
			
		||||
 | 
			
		||||
: compute-live-spill-slots ( -- spill-slots )
 | 
			
		||||
    unhandled-intervals get
 | 
			
		||||
    heap-values [ reload-from>> ] filter
 | 
			
		||||
    [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
 | 
			
		||||
 | 
			
		||||
M: ##gc assign-after
 | 
			
		||||
    compute-live-registers >>live-registers
 | 
			
		||||
    compute-live-spill-slots >>live-spill-slots
 | 
			
		||||
    drop ;
 | 
			
		||||
 | 
			
		||||
M: insn assign-after drop ;
 | 
			
		||||
 | 
			
		||||
: <active-intervals> ( -- obj )
 | 
			
		||||
    V{ } clone active-intervals boa ;
 | 
			
		||||
| 
						 | 
				
			
			@ -82,10 +99,13 @@ M: insn assign-registers-in-insn drop ;
 | 
			
		|||
    [
 | 
			
		||||
        [
 | 
			
		||||
            [
 | 
			
		||||
                [ insn#>> activate-new-intervals ]
 | 
			
		||||
                [ [ assign-registers-in-insn ] [ , ] bi ]
 | 
			
		||||
                [ insn#>> expire-old-intervals ]
 | 
			
		||||
                tri
 | 
			
		||||
                {
 | 
			
		||||
                    [ insn#>> activate-new-intervals ]
 | 
			
		||||
                    [ assign-before ]
 | 
			
		||||
                    [ , ]
 | 
			
		||||
                    [ insn#>> expire-old-intervals ]
 | 
			
		||||
                    [ assign-after ]
 | 
			
		||||
                } cleave
 | 
			
		||||
            ] each
 | 
			
		||||
        ] V{ } make
 | 
			
		||||
    ] change-instructions drop ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,11 +1,11 @@
 | 
			
		|||
! Copyright (C) 2008, 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: kernel math accessors sequences namespaces make
 | 
			
		||||
combinators assocs
 | 
			
		||||
cpu.architecture
 | 
			
		||||
combinators assocs arrays locals cpu.architecture
 | 
			
		||||
compiler.cfg
 | 
			
		||||
compiler.cfg.rpo
 | 
			
		||||
compiler.cfg.liveness
 | 
			
		||||
compiler.cfg.stack-frame
 | 
			
		||||
compiler.cfg.instructions ;
 | 
			
		||||
IN: compiler.cfg.linearization
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -68,6 +68,57 @@ M: ##dispatch linearize-insn
 | 
			
		|||
    [ successors>> [ number>> _dispatch-label ] each ]
 | 
			
		||||
    bi* ;
 | 
			
		||||
 | 
			
		||||
: gc-root-registers ( n live-registers -- n )
 | 
			
		||||
    [
 | 
			
		||||
        [ second 2array , ]
 | 
			
		||||
        [ first reg-class>> reg-size + ]
 | 
			
		||||
        2bi
 | 
			
		||||
    ] each ;
 | 
			
		||||
 | 
			
		||||
: gc-root-spill-slots ( n live-spill-slots -- n )
 | 
			
		||||
    [
 | 
			
		||||
        dup first reg-class>> int-regs eq? [
 | 
			
		||||
            [ second <spill-slot> 2array , ]
 | 
			
		||||
            [ first reg-class>> reg-size + ]
 | 
			
		||||
            2bi
 | 
			
		||||
        ] [ drop ] if
 | 
			
		||||
    ] each ;
 | 
			
		||||
 | 
			
		||||
: oop-registers ( regs -- regs' )
 | 
			
		||||
    [ first reg-class>> int-regs eq? ] filter ;
 | 
			
		||||
 | 
			
		||||
: data-registers ( regs -- regs' )
 | 
			
		||||
    [ first reg-class>> double-float-regs eq? ] filter ;
 | 
			
		||||
 | 
			
		||||
:: compute-gc-roots ( live-registers live-spill-slots -- alist )
 | 
			
		||||
    [
 | 
			
		||||
        0
 | 
			
		||||
        ! we put float registers last; the GC doesn't actually scan them
 | 
			
		||||
        live-registers oop-registers gc-root-registers
 | 
			
		||||
        live-spill-slots gc-root-spill-slots
 | 
			
		||||
        live-registers data-registers gc-root-registers
 | 
			
		||||
        drop
 | 
			
		||||
    ] { } make ;
 | 
			
		||||
 | 
			
		||||
: count-gc-roots ( live-registers live-spill-slots -- n )
 | 
			
		||||
    ! Size of GC root area, minus the float registers
 | 
			
		||||
    [ oop-registers length ] bi@ + ;
 | 
			
		||||
 | 
			
		||||
M: ##gc linearize-insn
 | 
			
		||||
    nip
 | 
			
		||||
    [
 | 
			
		||||
        [ temp1>> ]
 | 
			
		||||
        [ temp2>> ]
 | 
			
		||||
        [
 | 
			
		||||
            [ live-registers>> ] [ live-spill-slots>> ] bi
 | 
			
		||||
            [ compute-gc-roots ]
 | 
			
		||||
            [ count-gc-roots ]
 | 
			
		||||
            [ gc-roots-size ]
 | 
			
		||||
            2tri
 | 
			
		||||
        ] tri
 | 
			
		||||
        _gc
 | 
			
		||||
    ] with-regs ;
 | 
			
		||||
 | 
			
		||||
: linearize-basic-blocks ( cfg -- insns )
 | 
			
		||||
    [
 | 
			
		||||
        [ [ linearize-basic-block ] each-basic-block ]
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,7 @@
 | 
			
		|||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: compiler.cfg.linearization compiler.cfg.two-operand
 | 
			
		||||
compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
 | 
			
		||||
compiler.cfg.stack-frame compiler.cfg.rpo ;
 | 
			
		||||
compiler.cfg.build-stack-frame compiler.cfg.rpo ;
 | 
			
		||||
IN: compiler.cfg.mr
 | 
			
		||||
 | 
			
		||||
: build-mr ( cfg -- mr )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -0,0 +1 @@
 | 
			
		|||
Slava Pestov
 | 
			
		||||
| 
						 | 
				
			
			@ -1,72 +1,55 @@
 | 
			
		|||
! Copyright (C) 2008 Slava Pestov.
 | 
			
		||||
! Copyright (C) 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: namespaces accessors math.order assocs kernel sequences
 | 
			
		||||
combinators make classes words cpu.architecture
 | 
			
		||||
compiler.cfg.instructions compiler.cfg.registers ;
 | 
			
		||||
USING: math math.order namespaces accessors kernel layouts combinators
 | 
			
		||||
combinators.smart assocs sequences cpu.architecture ;
 | 
			
		||||
IN: compiler.cfg.stack-frame
 | 
			
		||||
 | 
			
		||||
SYMBOL: frame-required?
 | 
			
		||||
TUPLE: stack-frame
 | 
			
		||||
{ params integer }
 | 
			
		||||
{ return integer }
 | 
			
		||||
{ total-size integer }
 | 
			
		||||
{ gc-root-size integer }
 | 
			
		||||
spill-counts ;
 | 
			
		||||
 | 
			
		||||
SYMBOL: spill-counts
 | 
			
		||||
! Stack frame utilities
 | 
			
		||||
: param-base ( -- n )
 | 
			
		||||
    stack-frame get [ params>> ] [ return>> ] bi + ;
 | 
			
		||||
 | 
			
		||||
GENERIC: compute-stack-frame* ( insn -- )
 | 
			
		||||
: spill-float-offset ( n -- offset )
 | 
			
		||||
    double-float-regs reg-size * ;
 | 
			
		||||
 | 
			
		||||
: spill-integer-base ( -- n )
 | 
			
		||||
    stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
 | 
			
		||||
    param-base + ;
 | 
			
		||||
 | 
			
		||||
: spill-integer-offset ( n -- offset )
 | 
			
		||||
    cells spill-integer-base + ;
 | 
			
		||||
 | 
			
		||||
: spill-area-size ( stack-frame -- n )
 | 
			
		||||
    spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
 | 
			
		||||
 | 
			
		||||
: gc-root-base ( -- n )
 | 
			
		||||
    stack-frame get spill-area-size
 | 
			
		||||
    param-base + ;
 | 
			
		||||
 | 
			
		||||
: gc-root-offset ( n -- n' ) gc-root-base + ;
 | 
			
		||||
 | 
			
		||||
: gc-roots-size ( live-registers live-spill-slots -- n )
 | 
			
		||||
    [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
 | 
			
		||||
 | 
			
		||||
: (stack-frame-size) ( stack-frame -- n )
 | 
			
		||||
    [
 | 
			
		||||
        {
 | 
			
		||||
            [ spill-area-size ]
 | 
			
		||||
            [ gc-root-size>> ]
 | 
			
		||||
            [ params>> ]
 | 
			
		||||
            [ return>> ]
 | 
			
		||||
        } cleave
 | 
			
		||||
    ] sum-outputs ;
 | 
			
		||||
 | 
			
		||||
: max-stack-frame ( frame1 frame2 -- frame3 )
 | 
			
		||||
    [ stack-frame new ] 2dip
 | 
			
		||||
        [ [ params>> ] bi@ max >>params ]
 | 
			
		||||
        [ [ return>> ] bi@ max >>return ]
 | 
			
		||||
        2bi ;
 | 
			
		||||
 | 
			
		||||
M: ##stack-frame compute-stack-frame*
 | 
			
		||||
    frame-required? on
 | 
			
		||||
    stack-frame>> stack-frame [ max-stack-frame ] change ;
 | 
			
		||||
 | 
			
		||||
M: ##call compute-stack-frame*
 | 
			
		||||
    word>> sub-primitive>> [ frame-required? on ] unless ;
 | 
			
		||||
 | 
			
		||||
M: _spill-counts compute-stack-frame*
 | 
			
		||||
    counts>> stack-frame get (>>spill-counts) ;
 | 
			
		||||
 | 
			
		||||
M: insn compute-stack-frame*
 | 
			
		||||
    class frame-required? word-prop [
 | 
			
		||||
        frame-required? on
 | 
			
		||||
    ] when ;
 | 
			
		||||
 | 
			
		||||
\ _spill t frame-required? set-word-prop
 | 
			
		||||
\ ##gc t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-add t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-sub t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-mul t frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-add-tail f frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-sub-tail f frame-required? set-word-prop
 | 
			
		||||
\ ##fixnum-mul-tail f frame-required? set-word-prop
 | 
			
		||||
 | 
			
		||||
: compute-stack-frame ( insns -- )
 | 
			
		||||
    frame-required? off
 | 
			
		||||
    T{ stack-frame } clone stack-frame set
 | 
			
		||||
    [ compute-stack-frame* ] each
 | 
			
		||||
    stack-frame get dup stack-frame-size >>total-size drop ;
 | 
			
		||||
 | 
			
		||||
GENERIC: insert-pro/epilogues* ( insn -- )
 | 
			
		||||
 | 
			
		||||
M: ##stack-frame insert-pro/epilogues* drop ;
 | 
			
		||||
 | 
			
		||||
M: ##prologue insert-pro/epilogues*
 | 
			
		||||
    drop frame-required? get [ stack-frame get _prologue ] when ;
 | 
			
		||||
 | 
			
		||||
M: ##epilogue insert-pro/epilogues*
 | 
			
		||||
    drop frame-required? get [ stack-frame get _epilogue ] when ;
 | 
			
		||||
 | 
			
		||||
M: insn insert-pro/epilogues* , ;
 | 
			
		||||
 | 
			
		||||
: insert-pro/epilogues ( insns -- insns )
 | 
			
		||||
    [ [ insert-pro/epilogues* ] each ] { } make ;
 | 
			
		||||
 | 
			
		||||
: build-stack-frame ( mr -- mr )
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
            [ compute-stack-frame ]
 | 
			
		||||
            [ insert-pro/epilogues ]
 | 
			
		||||
            bi
 | 
			
		||||
        ] change-instructions
 | 
			
		||||
    ] with-scope ;
 | 
			
		||||
        [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
 | 
			
		||||
        2tri ;
 | 
			
		||||
| 
						 | 
				
			
			@ -10,6 +10,7 @@ compiler.errors
 | 
			
		|||
compiler.alien
 | 
			
		||||
compiler.cfg
 | 
			
		||||
compiler.cfg.instructions
 | 
			
		||||
compiler.cfg.stack-frame
 | 
			
		||||
compiler.cfg.registers
 | 
			
		||||
compiler.cfg.builder
 | 
			
		||||
compiler.codegen.fixup
 | 
			
		||||
| 
						 | 
				
			
			@ -234,7 +235,13 @@ M: ##write-barrier generate-insn
 | 
			
		|||
    [ table>> register ]
 | 
			
		||||
    tri %write-barrier ;
 | 
			
		||||
 | 
			
		||||
M: ##gc generate-insn drop %gc ;
 | 
			
		||||
M: _gc generate-insn
 | 
			
		||||
    {
 | 
			
		||||
        [ temp1>> register ]
 | 
			
		||||
        [ temp2>> register ]
 | 
			
		||||
        [ gc-roots>> ]
 | 
			
		||||
        [ gc-root-count>> ]
 | 
			
		||||
    } cleave %gc ;
 | 
			
		||||
 | 
			
		||||
M: ##loop-entry generate-insn drop %loop-entry ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -243,16 +250,6 @@ M: ##alien-global generate-insn
 | 
			
		|||
    %alien-global ;
 | 
			
		||||
 | 
			
		||||
! ##alien-invoke
 | 
			
		||||
GENERIC: reg-size ( register-class -- n )
 | 
			
		||||
 | 
			
		||||
M: int-regs reg-size drop cell ;
 | 
			
		||||
 | 
			
		||||
M: single-float-regs reg-size drop 4 ;
 | 
			
		||||
 | 
			
		||||
M: double-float-regs reg-size drop 8 ;
 | 
			
		||||
 | 
			
		||||
M: stack-params reg-size drop "void*" heap-size ;
 | 
			
		||||
 | 
			
		||||
GENERIC: reg-class-variable ( register-class -- symbol )
 | 
			
		||||
 | 
			
		||||
M: reg-class reg-class-variable ;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -12,12 +12,22 @@ SINGLETON: double-float-regs
 | 
			
		|||
UNION: float-regs single-float-regs double-float-regs ;
 | 
			
		||||
UNION: reg-class int-regs float-regs ;
 | 
			
		||||
 | 
			
		||||
! Mapping from register class to machine registers
 | 
			
		||||
HOOK: machine-registers cpu ( -- assoc )
 | 
			
		||||
 | 
			
		||||
! A pseudo-register class for parameters spilled on the stack
 | 
			
		||||
SINGLETON: stack-params
 | 
			
		||||
 | 
			
		||||
GENERIC: reg-size ( register-class -- n )
 | 
			
		||||
 | 
			
		||||
M: int-regs reg-size drop cell ;
 | 
			
		||||
 | 
			
		||||
M: single-float-regs reg-size drop 4 ;
 | 
			
		||||
 | 
			
		||||
M: double-float-regs reg-size drop 8 ;
 | 
			
		||||
 | 
			
		||||
M: stack-params reg-size drop cell ;
 | 
			
		||||
 | 
			
		||||
! Mapping from register class to machine registers
 | 
			
		||||
HOOK: machine-registers cpu ( -- assoc )
 | 
			
		||||
 | 
			
		||||
! Return values of this class go here
 | 
			
		||||
GENERIC: return-reg ( register-class -- reg )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -119,7 +129,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
 | 
			
		|||
 | 
			
		||||
HOOK: %allot cpu ( dst size class temp -- )
 | 
			
		||||
HOOK: %write-barrier cpu ( src card# table -- )
 | 
			
		||||
HOOK: %gc cpu ( -- )
 | 
			
		||||
HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
 | 
			
		||||
 | 
			
		||||
HOOK: %prologue cpu ( n -- )
 | 
			
		||||
HOOK: %epilogue cpu ( n -- )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1,4 +1,4 @@
 | 
			
		|||
! Copyright (C) 2005, 2008 Slava Pestov.
 | 
			
		||||
! Copyright (C) 2005, 2009 Slava Pestov.
 | 
			
		||||
! See http://factorcode.org/license.txt for BSD license.
 | 
			
		||||
USING: accessors arrays kernel math namespaces make sequences
 | 
			
		||||
system layouts alien alien.c-types alien.accessors alien.structs
 | 
			
		||||
| 
						 | 
				
			
			@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
 | 
			
		|||
cpu.x86 cpu.architecture compiler.constants
 | 
			
		||||
compiler.codegen compiler.codegen.fixup
 | 
			
		||||
compiler.cfg.instructions compiler.cfg.builder
 | 
			
		||||
compiler.cfg.intrinsics ;
 | 
			
		||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 | 
			
		||||
IN: cpu.x86.64
 | 
			
		||||
 | 
			
		||||
M: x86.64 machine-registers
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
 | 
			
		|||
words system layouts combinators math.order fry locals
 | 
			
		||||
compiler.constants compiler.cfg.registers
 | 
			
		||||
compiler.cfg.instructions compiler.cfg.intrinsics
 | 
			
		||||
compiler.codegen compiler.codegen.fixup ;
 | 
			
		||||
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
 | 
			
		||||
IN: cpu.x86
 | 
			
		||||
 | 
			
		||||
<< enable-fixnum-log2 >>
 | 
			
		||||
| 
						 | 
				
			
			@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
 | 
			
		|||
 | 
			
		||||
M: x86 two-operand? t ;
 | 
			
		||||
 | 
			
		||||
HOOK: stack-reg cpu ( -- reg )
 | 
			
		||||
 | 
			
		||||
HOOK: reserved-area-size cpu ( -- n )
 | 
			
		||||
 | 
			
		||||
: stack@ ( n -- op ) stack-reg swap [+] ;
 | 
			
		||||
 | 
			
		||||
: param@ ( n -- op ) reserved-area-size + stack@ ;
 | 
			
		||||
 | 
			
		||||
: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
 | 
			
		||||
 | 
			
		||||
: spill-float@ ( n -- op ) spill-float-offset param@ ;
 | 
			
		||||
 | 
			
		||||
: gc-root@ ( n -- op ) gc-root-offset param@ ;
 | 
			
		||||
 | 
			
		||||
: decr-stack-reg ( n -- )
 | 
			
		||||
    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 | 
			
		||||
 | 
			
		||||
: 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 ;
 | 
			
		||||
 | 
			
		||||
M: x86 stack-frame-size ( stack-frame -- i )
 | 
			
		||||
    (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
 | 
			
		||||
 | 
			
		||||
HOOK: temp-reg-1 cpu ( -- reg )
 | 
			
		||||
HOOK: temp-reg-2 cpu ( -- reg )
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
 | 
			
		|||
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 | 
			
		||||
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 | 
			
		||||
 | 
			
		||||
: align-stack ( n -- n' )
 | 
			
		||||
    os macosx? cpu x86.64? or [ 16 align ] when ;
 | 
			
		||||
 | 
			
		||||
HOOK: reserved-area-size cpu ( -- n )
 | 
			
		||||
 | 
			
		||||
M: x86 stack-frame-size ( stack-frame -- i )
 | 
			
		||||
    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
 | 
			
		||||
    [ params>> ]
 | 
			
		||||
    [ return>> ]
 | 
			
		||||
    tri + +
 | 
			
		||||
    3 cells +
 | 
			
		||||
    reserved-area-size +
 | 
			
		||||
    align-stack ;
 | 
			
		||||
 | 
			
		||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
 | 
			
		||||
 | 
			
		||||
: xt-tail-pic-offset ( -- n )
 | 
			
		||||
| 
						 | 
				
			
			@ -492,29 +504,58 @@ M:: x86 %write-barrier ( src card# table -- )
 | 
			
		|||
    table table [] MOV
 | 
			
		||||
    table card# [+] card-mark <byte> MOV ;
 | 
			
		||||
 | 
			
		||||
M: x86 %gc ( -- )
 | 
			
		||||
    "end" define-label
 | 
			
		||||
    temp-reg-1 load-zone-ptr
 | 
			
		||||
    temp-reg-2 temp-reg-1 cell [+] MOV
 | 
			
		||||
    temp-reg-2 1024 ADD
 | 
			
		||||
    temp-reg-1 temp-reg-1 3 cells [+] MOV
 | 
			
		||||
    temp-reg-2 temp-reg-1 CMP
 | 
			
		||||
    "end" get JLE
 | 
			
		||||
:: check-nursery ( temp1 temp2 -- )
 | 
			
		||||
    temp1 load-zone-ptr
 | 
			
		||||
    temp2 temp1 cell [+] MOV
 | 
			
		||||
    temp2 1024 ADD
 | 
			
		||||
    temp1 temp1 3 cells [+] MOV
 | 
			
		||||
    temp2 temp1 CMP ;
 | 
			
		||||
 | 
			
		||||
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
 | 
			
		||||
 | 
			
		||||
M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
 | 
			
		||||
    temp spill-slot n>> spill-integer@ MOV
 | 
			
		||||
    gc-root gc-root@ temp MOV ;
 | 
			
		||||
 | 
			
		||||
M:: word save-gc-root ( gc-root register temp -- )
 | 
			
		||||
    gc-root gc-root@ register MOV ;
 | 
			
		||||
 | 
			
		||||
: save-gc-roots ( gc-roots temp -- )
 | 
			
		||||
    '[ _ save-gc-root ] assoc-each ;
 | 
			
		||||
 | 
			
		||||
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
 | 
			
		||||
 | 
			
		||||
M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
 | 
			
		||||
    temp gc-root gc-root@ MOV
 | 
			
		||||
    spill-slot n>> spill-integer@ temp MOV ;
 | 
			
		||||
 | 
			
		||||
M:: word load-gc-root ( gc-root register temp -- )
 | 
			
		||||
    register gc-root gc-root@ MOV ;
 | 
			
		||||
 | 
			
		||||
: load-gc-roots ( gc-roots temp -- )
 | 
			
		||||
    '[ _ load-gc-root ] assoc-each ;
 | 
			
		||||
 | 
			
		||||
:: call-gc ( gc-root-count -- )
 | 
			
		||||
    ! Pass pointer to start of GC roots as first parameter
 | 
			
		||||
    param-reg-1 gc-root-base param@ LEA
 | 
			
		||||
    ! Pass number of roots as second parameter
 | 
			
		||||
    param-reg-2 gc-root-count MOV
 | 
			
		||||
    ! Call GC
 | 
			
		||||
    %prepare-alien-invoke
 | 
			
		||||
    "minor_gc" f %alien-invoke
 | 
			
		||||
    "inline_gc" f %alien-invoke ;
 | 
			
		||||
 | 
			
		||||
M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
 | 
			
		||||
    "end" define-label
 | 
			
		||||
    temp1 temp2 check-nursery
 | 
			
		||||
    "end" get JLE
 | 
			
		||||
    gc-roots temp1 save-gc-roots
 | 
			
		||||
    gc-root-count call-gc
 | 
			
		||||
    gc-roots temp1 load-gc-roots
 | 
			
		||||
    "end" resolve-label ;
 | 
			
		||||
 | 
			
		||||
M: x86 %alien-global
 | 
			
		||||
    [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
 | 
			
		||||
 | 
			
		||||
HOOK: stack-reg cpu ( -- reg )
 | 
			
		||||
 | 
			
		||||
: decr-stack-reg ( n -- )
 | 
			
		||||
    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 | 
			
		||||
 | 
			
		||||
: incr-stack-reg ( n -- )
 | 
			
		||||
    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
 | 
			
		||||
 | 
			
		||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 | 
			
		||||
 | 
			
		||||
:: %boolean ( dst temp word -- )
 | 
			
		||||
| 
						 | 
				
			
			@ -568,28 +609,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 | 
			
		|||
        { cc/= [ JNE ] }
 | 
			
		||||
    } case ;
 | 
			
		||||
 | 
			
		||||
: stack@ ( n -- op ) stack-reg swap [+] ;
 | 
			
		||||
 | 
			
		||||
: param@ ( n -- op ) reserved-area-size + stack@ ;
 | 
			
		||||
 | 
			
		||||
: spill-integer-base ( stack-frame -- n )
 | 
			
		||||
    [ params>> ] [ return>> ] bi + reserved-area-size + ;
 | 
			
		||||
 | 
			
		||||
: spill-integer@ ( n -- op )
 | 
			
		||||
    cells
 | 
			
		||||
    stack-frame get spill-integer-base
 | 
			
		||||
    + stack@ ;
 | 
			
		||||
 | 
			
		||||
: spill-float-base ( stack-frame -- n )
 | 
			
		||||
    [ spill-integer-base ]
 | 
			
		||||
    [ spill-counts>> int-regs swap at int-regs reg-size * ]
 | 
			
		||||
    bi + ;
 | 
			
		||||
 | 
			
		||||
: spill-float@ ( n -- op )
 | 
			
		||||
    double-float-regs reg-size *
 | 
			
		||||
    stack-frame get spill-float-base
 | 
			
		||||
    + stack@ ;
 | 
			
		||||
 | 
			
		||||
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
 | 
			
		||||
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
 | 
			
		|||
    [ dup heap-pop swap 2array ]
 | 
			
		||||
    produce nip ;
 | 
			
		||||
 | 
			
		||||
: heap-values ( heap -- alist )
 | 
			
		||||
    data>> [ value>> ] { } map-as ;
 | 
			
		||||
 | 
			
		||||
: slurp-heap ( heap quot: ( elt -- ) -- )
 | 
			
		||||
    over heap-empty? [ 2drop ] [
 | 
			
		||||
        [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -680,9 +680,15 @@ PRIMITIVE(become)
 | 
			
		|||
	compile_all_words();
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
VM_C_API void minor_gc()
 | 
			
		||||
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
 | 
			
		||||
{
 | 
			
		||||
	for(cell i = 0; i < gc_roots_size; i++)
 | 
			
		||||
		gc_local_push((cell)&gc_roots_base[i]);
 | 
			
		||||
 | 
			
		||||
	garbage_collection(data->nursery(),false,0);
 | 
			
		||||
 | 
			
		||||
	for(cell i = 0; i < gc_roots_size; i++)
 | 
			
		||||
		gc_local_pop();
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
 | 
			
		|||
#endif
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
VM_C_API void minor_gc();
 | 
			
		||||
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
 | 
			
		||||
 | 
			
		||||
}
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue