From 7f5e240e98f2375bffeef76c5df4d16fd58ea2fb Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 8 Apr 2006 07:13:01 +0000 Subject: [PATCH] More powerful templating --- library/compiler/basic-blocks.factor | 178 --------------------------- library/compiler/templates.factor | 44 +++++-- 2 files changed, 37 insertions(+), 185 deletions(-) delete mode 100644 library/compiler/basic-blocks.factor diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor deleted file mode 100644 index 2510c32880..0000000000 --- a/library/compiler/basic-blocks.factor +++ /dev/null @@ -1,178 +0,0 @@ -! Copyright (C) 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: compiler -USING: arrays hashtables kernel lists math namespaces sequences ; - -! Optimizations performed here: -! - combining %inc-d/%inc-r within a single basic block -! - if a literal is loaded into a vreg but the vreg is -! overwritten before being read, the literal load is deleted -! - if a %replace is writing a vreg to a stack location already -! holding that vreg, or a stack location that is not read -! before being popped, the %replace is deleted -! - if a %peek is reading a stack location into a vreg that -! already holds that vreg, or if the vreg is overwritten -! before being read, the %peek is deleted -! - removing dead loads of stack locations into vregs -! - removing dead stores of vregs into stack locations - -: vop-in ( vop n -- input ) swap vop-inputs nth ; -: set-vop-in ( input vop n -- ) swap vop-inputs set-nth ; -: vop-out ( vop n -- input ) swap vop-outputs nth ; -: set-vop-out ( output vop n -- ) swap vop-outputs set-nth ; - -: (split-blocks) ( n linear -- ) - 2dup length = [ - dup like , drop - ] [ - 2dup nth basic-block? [ - >r 1+ r> (split-blocks) - ] [ - (cut) >r , 1 r> (cut) >r , 0 r> (split-blocks) - ] if - ] if ; - -: split-blocks ( linear -- blocks ) - [ 0 swap (split-blocks) ] { } make ; - -SYMBOL: d-height -SYMBOL: r-height - -! combining %inc-d/%inc-r -GENERIC: simplify-stack* ( vop -- ) - -M: tuple simplify-stack* ( vop -- ) drop ; - -: accum-height ( vop var -- ) - >r dup 0 vop-in r> [ + ] change 0 swap 0 set-vop-in ; - -M: %inc-d simplify-stack* ( vop -- ) d-height accum-height ; - -M: %inc-r simplify-stack* ( vop -- ) r-height accum-height ; - -GENERIC: update-loc ( loc -- loc ) - -M: ds-loc update-loc ds-loc-n d-height get - ; - -M: cs-loc update-loc cs-loc-n r-height get - ; - -M: %peek simplify-stack* ( vop -- ) - 0 [ vop-in update-loc ] 2keep set-vop-in ; - -M: %replace simplify-stack* ( vop -- ) - 0 [ vop-out update-loc ] 2keep set-vop-out ; - -: simplify-stack ( block -- ) - #! Combine all %inc-d/%inc-r into two final ones. - #! Destructively modifies the VOPs in the block. - [ simplify-stack* ] each ; - -: each-tail ( seq quot -- | quot: tail -- ) - >r dup length [ swap tail-slice ] map-with r> each ; inline - -! removing dead loads/stores -: preserves-location? ( exitcc location vop -- ? ) - #! If the VOP writes the register, call the loop exit - #! continuation with 'f'. - { - { [ 2dup vop-inputs member? ] [ 3drop t ] } - { [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] } - { [ t ] [ 3drop f ] } - } cond ; - -GENERIC: live@end? ( location -- ? ) - -M: tuple live@end? drop t ; - -M: ds-loc live@end? ds-loc-n d-height get + 0 >= ; - -M: cs-loc live@end? cs-loc-n r-height get + 0 >= ; - -: location-live? ( location tail -- ? ) - #! A location is not live if and only if it is overwritten - #! before the end of the basic block. - [ - -rot [ >r 2dup r> preserves-location? ] contains? - [ dup live@end? ] unless* - ] callcc1 2nip ; - -! Used for elimination of dead loads from the stack: -! we keep a map of vregs to ds-loc/cs-loc/f. -SYMBOL: vreg-contents - -GENERIC: trim-dead* ( tail vop -- ) - -: forget-vregs ( vop -- ) - vop-outputs [ vreg-contents get remove-hash ] each ; - -M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ; - -: ?, [ , ] [ drop ] if ; - -: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ; - -M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ; - -M: %inc-r trim-dead* ( tail vop -- ) simplify-inc drop ; - -: live-load? ( tail vop -- ? ) - #! If the VOP's output location is overwritten before being - #! read again, kill the VOP. - 0 vop-out swap location-live? ; - -: remember-peek ( vop -- ) - dup 0 vop-in swap 0 vop-out vreg-contents get set-hash ; - -: redundant-peek? ( vop -- ? ) - dup 0 vop-in swap 0 vop-out vreg-contents get hash = ; - -M: %peek trim-dead* ( tail vop -- ) - dup redundant-peek? >r tuck live-load? not r> or - [ dup remember-peek dup , ] unless drop ; - -: redundant-replace? ( vop -- ? ) - dup 0 vop-out swap 0 vop-in vreg-contents get hash = ; - -: forget-stack-loc ( loc -- ) - #! Forget that any vregs hold this stack location. - vreg-contents [ [ nip swap = not ] hash-subset-with ] change ; - -: remember-replace ( vop -- ) - #! If a vreg claims to hold the stack location we are - #! writing to, we must forget this fact, since that stack - #! location no longer holds this value! - dup 0 vop-out forget-stack-loc - dup 0 vop-out swap 0 vop-in vreg-contents get set-hash ; - -M: %replace trim-dead* ( tail vop -- ) - dup redundant-replace? >r tuck live-load? not r> or - [ dup remember-replace dup , ] unless drop ; - -: ?dead-literal dup forget-vregs tuck live-load? ?, ; - -M: %immediate trim-dead* ( tail vop -- ) ?dead-literal ; - -M: %indirect trim-dead* ( tail vop -- ) ?dead-literal ; - -: trim-dead ( block -- ) - #! Remove dead loads and stores. - [ dup first >r 1 swap tail-slice r> trim-dead* ] each-tail ; - -: simplify-block ( block -- block ) - #! Destructively modifies the VOPs in the block. - [ - 0 d-height set - 0 r-height set - H{ } clone vreg-contents set - dup simplify-stack - d-height get %inc-d r-height get %inc-r 2array append - trim-dead - ] { } make ; - -: keep-simplifying ( block -- block ) - dup length >r simplify-block dup length r> = - [ keep-simplifying ] unless ; - -: simplify ( blocks -- blocks ) - #! Simplify basic block IR. - [ keep-simplifying ] map ; diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor index f4c064914e..1abc111a1f 100644 --- a/library/compiler/templates.factor +++ b/library/compiler/templates.factor @@ -61,6 +61,9 @@ M: object vreg>stack ( value loc -- ) [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ; inline +: reset-stack ( vector -- ) + 0 swap set-length ; + : end-basic-block ( -- ) \ %inc-d d-height finalize-height \ %inc-r r-height finalize-height @@ -68,8 +71,8 @@ M: object vreg>stack ( value loc -- ) phantom-r get [ ] f vregs>stack phantom-d get [ ] t vregs>stack phantom-r get [ ] t vregs>stack - 0 phantom-d get set-length - 0 phantom-r get set-length ; + phantom-d get reset-stack + phantom-r get reset-stack ; G: stack>vreg ( value vreg loc -- operand ) 2 standard-combination ; @@ -98,14 +101,41 @@ SYMBOL: any-reg 3array flip [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ; +: phantom-vregs ( phantom template -- ) + [ second ] map [ set ] 2each ; + : stack>vregs ( stack template quot -- ) - >r unpair -rot alloc-regs dup length reverse r> map - (stack>vregs) swap [ set ] 2each ; inline + >r dup [ first ] map swapd alloc-regs + dup length reverse r> map + (stack>vregs) swap phantom-vregs ; inline + +: compatible-vreg? + swap dup value? [ 2drop t ] [ vreg-n = ] if ; + +: compatible-values? ( value template -- ? ) + { + { [ dup any-reg eq? ] [ 2drop t ] } + { [ dup integer? ] [ compatible-vreg? ] } + { [ dup value eq? ] [ drop value? ] } + } cond ; + +: template-match? ( phantom template -- ? ) + 2dup [ length ] 2apply = [ + f [ first compatible-values? and ] 2reduce + ] [ + 2drop f + ] if ; + +: template-input ( values template phantom quot -- ) + >r swap [ template-match? ] 2keep rot [ + rot r> 2drop over >r phantom-vregs r> reset-stack + ] [ + nip end-basic-block r> stack>vregs + ] if ; inline : template-inputs ( stack template stack template -- ) - end-basic-block - over >r [ ] stack>vregs - over >r [ ] stack>vregs + over >r phantom-r get [ ] template-input + over >r phantom-d get [ ] template-input r> r> [ length neg ] 2apply adjust-stacks ; : >phantom ( seq stack -- )