diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index bfd9f671a8..86f1bfa026 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -184,6 +184,8 @@ sequences words ; \ fixnum* intrinsic +: slow-fixnum* \ %fixnum* 0 binary-op-reg ; + \ fixnum* [ ! Turn multiplication by a power of two into a left shift. node-peek dup literal? [ @@ -193,10 +195,10 @@ sequences words ; log2 0 %fixnum<< , 0 0 %replace-d , ] [ - drop binary-op-reg + drop slow-fixnum* ] ifte ] [ - drop binary-op-reg + drop slow-fixnum* ] ifte ] "linearizer" set-word-prop diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor deleted file mode 100644 index 17623e785c..0000000000 --- a/library/compiler/simplifier.factor +++ /dev/null @@ -1,230 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: compiler-backend -USING: generic inference kernel lists math namespaces -prettyprint strings words ; - -! A peephole optimizer operating on the linear IR. - -! The linear IR being simplified is stored in this variable. -SYMBOL: simplifying - -GENERIC: simplify-node ( linear vop -- linear ? ) - -! The next node following this node in terms of control flow, or -! f if this is a conditional. -GENERIC: next-logical ( linear vop -- linear ) - -! No delegation. -M: tuple simplify-node drop f ; - -: simplify-1 ( list -- list ? ) - #! Return a new linear IR. - dup [ - dup car simplify-node - [ uncons simplify-1 drop cons t ] - [ uncons simplify-1 >r cons r> ] ifte - ] [ - f - ] ifte ; - -: simplify ( linear -- linear ) - #! Keep simplifying until simplify-1 returns f. - [ - dup simplifying set simplify-1 - ] with-scope [ simplify ] when ; - -: label-called? ( label -- ? ) - simplifying get [ calls-label? ] some-with? ; - -M: %label simplify-node ( linear vop -- linear ? ) - vop-label label-called? [ f ] [ cdr t ] ifte ; - -: next-physical? ( linear class -- vop ? ) - #! If the following op has given class, remove it and - #! return it. - over cdr dup [ - car class = [ cdr car t ] [ f ] ifte - ] [ - 3drop f f - ] ifte ; - -M: %inc-d simplify-node ( linear vop -- linear ? ) - #! %inc-d cancels a following %inc-d. - >r dup \ %inc-d next-physical? [ - vop-literal r> vop-literal + dup 0 = [ - drop cdr cdr f - ] [ - %inc-d >r cdr cdr r> swons t - ] ifte - ] [ - r> 2drop f - ] ifte ; - -: dead-load? ( linear vop -- ? ) - #! Is the %replace-d followed by a %peek-d of the same - #! stack slot and vreg? - swap cdr car dup %peek-d? [ - over vop-source over vop-dest = >r - swap vop-literal swap vop-literal = r> and - ] [ - 2drop f - ] ifte ; - -: dead-store? ( linear n -- ? ) - #! Is the %replace-d followed by a %dec-d, so the stored - #! value is lost? - swap \ %inc-d next-physical? [ - vop-literal + 0 < - ] [ - 2drop f - ] ifte ; - -M: %replace-d simplify-node ( linear vop -- linear ? ) - 2dup dead-load? [ - drop uncons cdr cons t - ] [ - 2dup vop-literal dead-store? [ - drop cdr t - ] [ - drop f - ] ifte - ] ifte ; - -M: %immediate-d simplify-node ( linear vop -- linear ? ) - over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ; - -: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ; - -: can-fast-branch? ( linear -- ? ) - unswons class fast-branch [ - unswons pop? [ car %jump-t? ] [ drop f ] ifte - ] [ - drop f - ] ifte ; - -: fast-branch-params ( linear -- src dest label linear ) - uncons >r dup vop-source swap vop-dest r> cdr - uncons >r vop-label r> ; - -M: %fixnum<= simplify-node ( linear vop -- linear ? ) - drop dup can-fast-branch? [ - fast-branch-params >r - %jump-fixnum<= >r -1 %inc-d r> - r> cons cons t - ] [ - f - ] ifte ; - -M: %eq? simplify-node ( linear vop -- linear ? ) - drop dup can-fast-branch? [ - fast-branch-params >r - %jump-eq? >r -1 %inc-d r> - r> cons cons t - ] [ - f - ] ifte ; - -: find-label ( label -- rest ) - simplifying get [ - dup %label? [ vop-label = ] [ 2drop f ] ifte - ] some-with? ; - -M: %label next-logical ( linear vop -- linear ) - drop cdr dup car next-logical ; - -M: %jump-label next-logical ( linear vop -- linear ) - nip vop-label find-label cdr ; - -M: %target-label next-logical ( linear vop -- linear ) - nip vop-label find-label cdr ; - -M: object next-logical ( linear vop -- linear ) - drop ; - -: next-logical? ( op linear -- ? ) - dup car next-logical dup [ car class = ] [ 2drop f ] ifte ; - -: reduce ( linear op new -- linear ? ) - >r over cdr next-logical? [ - dup car vop-label - r> execute swap cdr cons t - ] [ - r> drop f - ] ifte ; inline - -M: %call simplify-node ( linear vop -- ? ) - #! Tail call optimization. - drop \ %return \ %jump reduce ; - -M: %call-label simplify-node ( linear vop -- ? ) - #! Tail call optimization. - drop \ %return \ %jump-label reduce ; - -: double-jump ( linear op2 op1 -- linear ? ) - #! A jump to a jump is just a jump. If the next logical node - #! is a jump of type op1, replace the jump at the car of the - #! list with a jump of type op2. - pick next-logical? [ - >r dup dup car next-logical car vop-label - r> execute swap cdr cons t - ] [ - drop f - ] ifte ; inline - -: useless-jump ( linear -- linear ? ) - #! A jump to a label immediately following is not needed. - dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ; - -: (dead-code) ( linear -- linear ? ) - #! Remove all nodes until the next #label. - dup [ - dup car %label? [ - f - ] [ - cdr (dead-code) t or - ] ifte - ] [ - f - ] ifte ; - -: dead-code ( linear -- linear ? ) - uncons (dead-code) >r cons r> ; - -M: %jump-label simplify-node ( linear vop -- linear ? ) - drop - \ %return dup double-jump [ - t - ] [ - \ %jump-label dup double-jump [ - t - ] [ - \ %jump dup double-jump - ! [ - ! t - ! ] [ - ! useless-jump [ - ! t - ! ] [ - ! dead-code - ! ] ifte - ! ] ifte - ] ifte - ] ifte ; -! -! #jump-label [ -! [ #return #return double-jump ] -! [ #jump-label #jump-label double-jump ] -! [ #jump #jump double-jump ] -! [ useless-jump ] -! [ dead-code ] -! ] "simplifiers" set-word-prop -! -! #target-label [ -! [ #target-label #jump-label double-jump ] -! ! [ #target #jump double-jump ] -! ] "simplifiers" set-word-prop -! -! #jump [ [ dead-code ] ] "simplifiers" set-word-prop -! #return [ [ dead-code ] ] "simplifiers" set-word-prop -! #end-dispatch [ [ dead-code ] ] "simplifiers" set-word-prop