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

compiler.cfg.builder: annotate calls with height changes, once again

db4
Slava Pestov 2009-07-18 23:08:53 -05:00
parent ec1407bdae
commit 605b37a949
5 changed files with 20 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
basis/compiler/cfg/builder/builder.factor
View File

@ -63,15 +63,18 @@ GENERIC: emit-node ( node -- )
basic-block get successors>> push basic-block get successors>> push
basic-block off ; basic-block off ;
: emit-call ( word -- ) : emit-call ( word height -- )
dup loops get key? over loops get key?
[ loops get at emit-loop-call ] [ drop loops get at emit-loop-call ]
[ ##call ##branch begin-basic-block ] [ ##call ##branch begin-basic-block ]
if ; if ;
! #recursive ! #recursive
: recursive-height ( #recursive -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( #recursive -- ) : emit-recursive ( #recursive -- )
[ label>> id>> emit-call ] [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- ) : remember-loop ( label -- )
@ -133,10 +136,10 @@ M: #dispatch emit-node
! #call ! #call
M: #call emit-node M: #call emit-node
dup word>> dup "intrinsic" word-prop dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ nip emit-call ] if ; [ emit-intrinsic ] [ swap call-height emit-call ] if ;
! #call-recursive ! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ; M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
! #push ! #push
M: #push emit-node M: #push emit-node

10
basis/compiler/cfg/dcn/height/height.factor
View File

@ -17,14 +17,14 @@ M: insn ds-height-change drop 0 ;
M: ##inc-d ds-height-change n>> ; M: ##inc-d ds-height-change n>> ;
! XXX M: ##call ds-height-change height>> ;
! M: ##call ds-height-change height>> ;
M: ##call ds-height-change drop 0 ; : alien-node-height ( node -- )
params>> [ out-d>> length ] [ in-d>> length ] bi - ;
M: ##alien-invoke ds-height-change height>> ; M: ##alien-invoke ds-height-change alien-node-height ;
M: ##alien-indirect ds-height-change height>> ; M: ##alien-indirect ds-height-change alien-node-height ;
GENERIC: rs-height-change ( insn -- n ) GENERIC: rs-height-change ( insn -- n )

2
basis/compiler/cfg/instructions/instructions.factor
View File

@ -53,7 +53,7 @@ INSN: ##inc-r { n integer } ;
! Subroutine calls ! Subroutine calls
INSN: ##stack-frame stack-frame ; INSN: ##stack-frame stack-frame ;
INSN: ##call word ; INSN: ##call word { height integer } ;
INSN: ##jump word ; INSN: ##jump word ;
INSN: ##return ; INSN: ##return ;

2
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -65,7 +65,7 @@ IN: compiler.cfg.intrinsics.fixnum
[ -2 ##inc-d ds-push ] with-branch ; [ -2 ##inc-d ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb ) : emit-overflow-case ( word -- final-bb )
[ ##call ] with-branch ; [ -1 ##call ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- ) : emit-fixnum-overflow-op ( quot word -- )
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip

5
basis/compiler/cfg/utilities/utilities.factor
View File

@ -33,8 +33,11 @@ IN: compiler.cfg.utilities
building off building off
basic-block off ; basic-block off ;
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-primitive ( node -- ) : emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ; [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
: with-branch ( quot -- final-bb ) : with-branch ( quot -- final-bb )
[ [