factor/library/compiler/simplifier.factor

! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: inference kernel lists math namespaces prettyprint
strings words ;

: simplify ;

! The linear IR being simplified is stored in this variable.
! SYMBOL: simplifying
! 
! : simplifiers ( linear -- list )
!     #! A list of quotations with stack effect
!     #! ( linear -- linear ? ) that can simplify the first node
!     #! in the linear IR.
!     car car "simplifiers" word-prop ;
! 
! : simplify-node ( linear list -- linear ? )
!     dup [
!         uncons >r call [
!             r> drop t
!         ] [
!             r> simplify-node
!         ] ifte
!     ] when ;
! 
! : simplify-1 ( linear -- linear ? )
!     #! Return a new linear IR.
!     dup [
!         dup simplifiers 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 linear -- ? )
!     [ uncons pick = swap #label = not and ] some? nip ;
! 
! #label [
!     [
!         dup car cdr simplifying get label-called?
!         [ f ] [ cdr t ] ifte
!     ]
! ] "simplifiers" set-word-prop
! 
! : next-physical? ( op linear -- ? )
!     cdr dup [ car car = ] [ 2drop f ] ifte ;
! 
! : cancel ( linear op -- linear param ? )
!     #! If the following op is as given, remove it, and return
!     #! its param.
!     over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
! 
! \ drop [
!     [
!         #push-immediate cancel [
!             #replace-immediate swons swons t
!         ] when
!     ] [
!         #push-indirect cancel [
!             #replace-indirect swons swons t
!         ] when
!     ]
! ] "simplifiers" set-word-prop
! 
! : find-label ( label -- rest )
!     simplifying get [
!         uncons pick = swap #label = and
!     ] some? nip ;
! 
! : next-logical ( linear -- linear )
!     dup car car "next-logical" word-prop call ;
! 
! #label [
!     cdr next-logical
! ] "next-logical" set-word-prop
! 
! #jump-label [
!     car cdr find-label cdr
! ] "next-logical" set-word-prop
! 
! #target-label [
!     car cdr find-label cdr
! ] "next-logical" set-word-prop
! 
! : next-logical? ( op linear -- ? )
!     next-logical dup [ car car = ] [ 2drop f ] ifte ;
! 
! : reduce ( linear op new -- linear ? )
!     >r over cdr next-logical? [
!         unswons cdr r> swons swons t
!     ] [
!         r> drop f
!     ] ifte ;
! 
! #call [
!     [ #return #jump reduce ]
! ] "simplifiers" set-word-prop
! 
! #call-label [
!     [ #return #jump-label reduce ]
! ] "simplifiers" set-word-prop
! 
! : double-jump ( linear op1 op2 -- 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.
!     swap pick next-logical? [
!         over next-logical car cdr cons swap cdr cons t
!     ] [
!         drop f
!     ] ifte ;
! 
! : 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 car #label = [
!             f
!         ] [
!             cdr (dead-code) t or
!         ] ifte
!     ] [
!         f
!     ] ifte ;
! 
! : dead-code ( linear -- linear ? )
!     uncons (dead-code) >r cons r> ;
! 
! #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 [
!     [ #jump-label #target-label double-jump ]
! !   [ #jump #target 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