Ticket #2132: 0001-Optimize-nested-comparisons-ticket-2132.patch

File 0001-Optimize-nested-comparisons-ticket-2132.patch, 33.1 KB (added by michalt, 4 years ago)

Initial implementation.

  • compiler/ghc.cabal.in

    From fbacab904611590966b4e8771aa39fa147e2c22a Mon Sep 17 00:00:00 2001
    From: Michal Terepeta <[email protected]>
    Date: Sun, 9 Oct 2011 22:09:07 +0200
    Subject: [PATCH] Optimize nested comparisons (ticket #2132).
    
    This implements a new optimization simplCore/SimplCmps, which
    records what comparisons have been done and uses that to remove
    ones that are not necessary. For example:
      case x ># y of
        True -> .. x ==# y ..
        ..
    the second comparison will always be false. It also tracks
    possible values of variables using intervals, so in:
      case x ># 5 of
        True -> .. x ==# 0 ..
        ..
    it will also detect that the second comparison is always false.
    ---
     compiler/ghc.cabal.in            |    1 +
     compiler/main/DynFlags.hs        |    3 +
     compiler/simplCore/CoreMonad.lhs |    3 +
     compiler/simplCore/SimplCmps.hs  |  783 ++++++++++++++++++++++++++++++++++++++
     compiler/simplCore/SimplCore.lhs |    7 +
     5 files changed, 797 insertions(+), 0 deletions(-)
     create mode 100644 compiler/simplCore/SimplCmps.hs
    
    diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
    index 09b0fb9..560bbc4 100755
    a b Library 
    363363        FloatOut
    364364        LiberateCase
    365365        OccurAnal
     366        SimplCmps
    366367        SAT
    367368        SetLevels
    368369        SimplCore
  • compiler/main/DynFlags.hs

    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index 3385c36..2fb78c9 100644
    a b data DynFlag 
    240240   | Opt_Vectorise
    241241   | Opt_RegsGraph                      -- do graph coloring register allocation
    242242   | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation
     243   | Opt_Comparisons
    243244
    244245   -- Interface files
    245246   | Opt_IgnoreInterfacePragmas
    fFlags = [ 
    17181719  ( "liberate-case",                    AlwaysAllowed, Opt_LiberateCase, nop ),
    17191720  ( "spec-constr",                      AlwaysAllowed, Opt_SpecConstr, nop ),
    17201721  ( "cse",                              AlwaysAllowed, Opt_CSE, nop ),
     1722  ( "comparisons",                      AlwaysAllowed, Opt_Comparisons, nop ),
    17211723  ( "ignore-interface-pragmas",         AlwaysAllowed, Opt_IgnoreInterfacePragmas, nop ),
    17221724  ( "omit-interface-pragmas",           AlwaysAllowed, Opt_OmitInterfacePragmas, nop ),
    17231725  ( "expose-all-unfoldings",            AlwaysAllowed, Opt_ExposeAllUnfoldings, nop ),
    optLevelFlags 
    19841986    , ([2],     Opt_LiberateCase)
    19851987    , ([2],     Opt_SpecConstr)
    19861988    , ([2],     Opt_RegsGraph)
     1989    , ([2],     Opt_Comparisons)
    19871990
    19881991--     , ([2],     Opt_StaticArgumentTransformation)
    19891992-- Max writes: I think it's probably best not to enable SAT with -O2 for the
  • compiler/simplCore/CoreMonad.lhs

    diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
    index 6ad402c..5ff5f3f 100644
    a b data CoreToDo -- These are diff core-to-core passes, 
    238238  | CoreDoSpecialising
    239239  | CoreDoSpecConstr
    240240  | CoreCSE
     241  | CoreDoSimplCmps
    241242  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
    242243                                           -- matching this string
    243244  | CoreDoVectorisation
    coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core 
    260261coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
    261262coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
    262263coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
     264coreDumpFlag CoreDoSimplCmps          = Just Opt_D_verbose_core2core
    263265coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
    264266coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
    265267coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
    instance Outputable CoreToDo where 
    295297  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
    296298  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
    297299  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
     300  ppr CoreDoSimplCmps          = ptext (sLit "Numeric analysis")
    298301
    299302pprPassDetails :: CoreToDo -> SDoc
    300303pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n
  • new file compiler/simplCore/SimplCmps.hs

    diff --git a/compiler/simplCore/SimplCmps.hs b/compiler/simplCore/SimplCmps.hs
    new file mode 100644
    index 0000000..2195530
    - +  
     1-- | This optimization tries to remove unnecessary comparisons, e.g.
     2--
     3--   case x <# y of
     4--     True -> .. case x <# y of ..
     5-- or
     6--   case 3 <=# x of
     7--     True -> .. case 1 <# x of ..
     8--
     9-- To do that we record the relations between variables as we go through
     10-- the case expressions and intervals of variables.
     11--
     12module SimplCmps ( simplCmps ) where
     13
     14#include "HsVersions.h"
     15
     16import CoreSyn
     17import Id
     18import Literal
     19import Outputable
     20import PrimOp
     21import TysPrim
     22import TysWiredIn
     23import UniqFM
     24import Unique
     25import Util ( debugIsOn )
     26import Var
     27import VarEnv
     28import Type
     29
     30import Control.Applicative ( (<$>), (<|>) )
     31import Data.List ( foldl' )
     32import Data.Maybe ( fromJust, isJust )
     33
     34simplCmps :: [CoreBind] -> [CoreBind]
     35simplCmps = map optimizeBind
     36
     37optimizeBind :: CoreBind -> CoreBind
     38optimizeBind (NonRec var expr) = NonRec var (optimizeExpr emptyNumEnv expr)
     39optimizeBind (Rec list)        = Rec (map f list)
     40  where
     41    f (b, e) = (b, optimizeExpr emptyNumEnv e)
     42
     43optimizeExpr :: NumEnv -> CoreExpr -> CoreExpr
     44optimizeExpr numenv (Case expr bndr ty alts)
     45  | Just result <- trueOrFalseId <$> tryEval numenv expr
     46  = let f alt@(DataAlt datacon, _, _)
     47          | datacon == idDataCon result
     48          = optimizeAlt numenv expr alt
     49        f alt = alt
     50    in Case (Var result) bndr ty (map f alts)
     51  | otherwise
     52  = Case (optimizeExpr numenv expr) bndr ty $ map (optimizeAlt numenv expr) alts
     53optimizeExpr numenv (App expr arg)
     54  | Just result <- trueOrFalseExpr <$> tryEval numenv arg
     55  = App expr result
     56  | otherwise
     57  = App (optimizeExpr numenv expr) (optimizeExpr numenv arg)
     58optimizeExpr numenv (Lam bndr expr)
     59  | Just result <- trueOrFalseExpr <$> tryEval numenv expr
     60  = Lam bndr result
     61  | otherwise
     62  = Lam bndr (optimizeExpr numenv expr)
     63optimizeExpr numenv (Let bndr expr)
     64  | Just result <- trueOrFalseExpr <$> tryEval numenv expr
     65  = Let bndr result
     66  | otherwise
     67  = Let bndr (optimizeExpr numenv expr)
     68-- FIXME: Not sure if we need to consider Cast --- can it contain expressions
     69-- that could be optimized?
     70optimizeExpr numenv (Cast expr coer)
     71  | Just result <- trueOrFalseExpr <$> tryEval numenv expr
     72  = Cast result coer
     73  | otherwise
     74  = Cast (optimizeExpr numenv expr) coer
     75optimizeExpr numenv (Note note expr)
     76  | Just result <- trueOrFalseExpr <$> tryEval numenv expr
     77  = Note note result
     78  | otherwise
     79  = Note note (optimizeExpr numenv expr)
     80optimizeExpr _      e                = e
     81
     82-- Optimize an alternative of case expression. This considers currently only
     83-- very simple case of comparisons. Maybe in the future it would be good to
     84-- extend that. Consider:
     85--   case x <# y + 1 of
     86--     ...
     87-- If we know that x is smaller than y then we are also able to determine the
     88-- result of the test. Apart from that we could use the interval arithmetic.
     89optimizeAlt :: NumEnv -> CoreExpr -> CoreAlt -> (AltCon, [CoreBndr], CoreExpr)
     90optimizeAlt env (App (App (Var opid) expr1) expr2) alt@(DataAlt datacon, args, expr)
     91  | Just relop <- idToRelOp opid
     92  = let negIf b op = if b then op else negRelOp op
     93    in case (expr1, expr2, datacon == trueDataCon) of
     94      (Var id1, Var id2, branch) ->
     95        let env' = addRelation env id1 (negIf branch relop) id2
     96        in (DataAlt datacon, args, optimizeExpr env' expr)
     97      (Var var, Lit lit, branch) ->
     98        let env' = updateIntrVarLit env var (negIf branch relop) lit
     99        in (DataAlt datacon, args, optimizeExpr env' expr)
     100      (Lit lit, Var var, branch) ->
     101        let env' = updateIntrLitVar env lit (negIf branch relop) var
     102        in (DataAlt datacon, args, optimizeExpr env' expr)
     103      _ -> alt
     104optimizeAlt env _ (altcon, args, expr) =
     105  (altcon, args, optimizeExpr env expr)
     106
     107trueOrFalseId :: Bool -> Id
     108trueOrFalseId True  = trueDataConId
     109trueOrFalseId False = falseDataConId
     110
     111trueOrFalseExpr :: Bool -> CoreExpr
     112trueOrFalseExpr = Var . trueOrFalseId
     113
     114tryEval :: NumEnv -> CoreExpr -> Maybe Bool
     115tryEval numenv expr = case expr of
     116  App (App (Var opid) e1) e2 -> do
     117    rel <- idToRelOp opid
     118    tryEval' numenv rel e1 e2
     119  _ -> Nothing
     120  where
     121    tryEval' env op (Var var1) (Var var2) =
     122      let r = evalVarVar env var1 op var2
     123      in ifDebugTrace (ppr var1 <+> ppr op <+> ppr var2) r
     124    tryEval' env op (Var var) (Lit lit) =
     125      let r = evalVarLit env var op lit
     126      in ifDebugTrace (ppr var <+> ppr op <+> ppr lit) r
     127    tryEval' env op (Lit lit) (Var var) =
     128      let r = evalLitVar env lit op var
     129      in ifDebugTrace (ppr lit <+> ppr op <+> ppr var) r
     130    -- Note that case with two literals should be handled by simplifier and
     131    -- the builtin rules.
     132    tryEval' _ _ _ _ = Nothing
     133
     134--
     135-- Evaluating comparisons.
     136--
     137
     138evalVarLit :: NumEnv -> Var -> RelOp -> Literal -> Maybe Bool
     139evalVarLit env var relop lit
     140  | Just i <- litToInteger lit
     141  = do intr <- lookupIntr env var
     142       cmpIntrWith relop intr (BetweenEq i i)
     143  | Just r <- litToRational lit
     144  = do intr <- lookupIntr env var
     145       cmpIntrWith relop intr (BetweenEq r r)
     146  | otherwise = Nothing
     147
     148-- The same as above but with arguments swapped ("mirrored" 'RelO').
     149evalLitVar :: NumEnv -> Literal -> RelOp -> Var -> Maybe Bool
     150evalLitVar env lit relop var = evalVarLit env var (mirrorRelOp relop) lit
     151
     152evalVarVar :: NumEnv -> Var -> RelOp -> Var -> Maybe Bool
     153evalVarVar numenv var1 relop var2 = m1 <|> m2 <|> mintr
     154  where
     155    -- First try with finding a relation between var1 and var2..
     156    m1 = checkRelation relations var1 var2 >>= flip evalRelOp relop
     157    -- .. then between var2 and var1..
     158    m2 = checkRelation relations var2 var1 >>= flip evalRelOp (mirrorRelOp relop)
     159    -- .. and finally check compare the intervals.
     160    mintr = evalIntr numenv var1 relop var2
     161
     162    relations = neRelations numenv
     163
     164-- | Return 'Just True' ('Just False') iff what we know implies that the given
     165-- 'RelOp' would evaluate to 'True' ('False'). Otherwise return 'Nothing'.
     166evalRelOp :: NumRelation  -- ^ This is what we know.
     167          -> RelOp        -- ^ And this what is asked.
     168          -> Maybe Bool
     169evalRelOp Greater relop = case relop of
     170  Gt  -> Just True
     171  Ge  -> Just True
     172  Neq -> Just True
     173  _   -> Just False
     174evalRelOp GreatEq relop = case relop of
     175  Ge -> Just True
     176  Lt -> Just False
     177  _  -> Nothing
     178evalRelOp Equal relop = case relop of
     179  Eq -> Just True
     180  Ge -> Just True
     181  Lt -> Just True
     182  _  -> Just False
     183
     184evalIntr :: NumEnv -> Var -> RelOp -> Var -> Maybe Bool
     185evalIntr numenv var1 relop var2
     186  | isIntegerLike ty
     187  = do i1 <- lookupIntr numenv var1 :: Maybe (Interval Integer)
     188       i2 <- lookupIntr numenv var2
     189       cmpIntrWith relop i1 i2
     190  | isRationalLike ty
     191  = do i1 <- lookupIntr numenv var1 :: Maybe (Interval Rational)
     192       i2 <- lookupIntr numenv var2
     193       cmpIntrWith relop i1 i2
     194  | otherwise = Nothing
     195  where
     196    ty = varType var1
     197
     198litToInteger :: Literal -> Maybe Integer
     199litToInteger (MachInt i)    = Just i
     200litToInteger (MachInt64 i)  = Just i
     201litToInteger (MachWord i)   = Just i
     202litToInteger (MachWord64 i) = Just i
     203litToInteger _              = Nothing
     204
     205litToRational :: Literal -> Maybe Rational
     206litToRational (MachFloat r)  = Just r
     207litToRational (MachDouble r) = Just r
     208litToRational _              = Nothing
     209
     210-- | Take two arguments and rearrange them, so that we can convert 'RelOp' to
     211-- 'NumRelation'. The order of arguments obviously matters.
     212toNumRelation :: a -> RelOp -> a -> Maybe (a, NumRelation, a)
     213toNumRelation a relop b = case relop of
     214  Gt  -> Just (a, Greater, b)
     215  Ge  -> Just (a, GreatEq, b)
     216  Eq  -> Just (a, Equal, b)
     217  Neq -> Nothing
     218  Le  -> Just (b, GreatEq, a)
     219  Lt  -> Just (b, Greater, a)
     220
     221-- | Check if the given type is one of the integer-like primitive types that is
     222-- handled by our optimization.
     223isIntegerLike :: Type -> Bool
     224isIntegerLike ty = case tyConAppTyCon_maybe ty of
     225  Just con -> con == intPrimTyCon
     226           || con == int32PrimTyCon
     227           || con == int64PrimTyCon
     228           || con == wordPrimTyCon
     229           || con == word32PrimTyCon
     230           || con == word64PrimTyCon
     231  Nothing  -> False
     232
     233-- | The same as 'isIntegerLike' but for rational types, i.e. 'Float' and
     234-- 'Double'.
     235isRationalLike :: Type -> Bool
     236isRationalLike ty = case tyConAppTyCon_maybe ty of
     237  Just con -> con == floatPrimTyCon
     238           || con == doublePrimTyCon
     239  Nothing  -> False
     240
     241--
     242-- Numerical environment.
     243--
     244
     245data NumEnv = NumEnv
     246  { neIntegers  :: VarEnv (Interval Integer)
     247  , neRationals :: VarEnv (Interval Rational)
     248  , neRelations :: NumRelations
     249  }
     250
     251instance Outputable NumEnv where
     252  ppr (NumEnv ienv renv rels) = ppr ienv $$ ppr renv $$ ppr rels
     253
     254emptyNumEnv :: NumEnv
     255emptyNumEnv = NumEnv emptyVarEnv emptyVarEnv emptyNumRels
     256
     257addRelation :: NumEnv -> Var -> RelOp -> Var -> NumEnv
     258addRelation numenv var1 relop var2 =
     259  updateIntrVarVar numenv' var1 relop var2
     260    where
     261      numenv' = addRelationU numenv var1 relop var2
     262
     263addRelationU :: (Uniquable a) => NumEnv -> a -> RelOp -> a -> NumEnv
     264-- With current representation there's nothing we can
     265-- do with not equal.
     266addRelationU numenv _    Neq   _    = numenv
     267addRelationU numenv var1 relop var2 = numenv { neRelations = rels }
     268    where
     269      -- Returns Nothing only in case of 'Neq'.
     270      Just (x, r, y) = toNumRelation var1 relop var2
     271      rels = insertRel (neRelations numenv) x r y
     272
     273--
     274-- Relations.
     275--
     276
     277-- | We store only three basic relations --- there is simply no need to store
     278-- also less than, etc. (x < y means that y is greater than x).
     279data NumRelation
     280  = Greater
     281  | GreatEq
     282  | Equal
     283
     284instance Outputable NumRelation where
     285  ppr Greater = text "Greater"
     286  ppr GreatEq = text "GreatEq"
     287  ppr Equal = text "Equal"
     288
     289-- | The 'NumRelations' basically holds a graph of variable relations.
     290data NumRelations = NumRels (UniqFM (UniqFM NumRelation))
     291
     292instance Outputable NumRelations where
     293  ppr (NumRels graph) = ppr graph
     294
     295emptyNumRels :: NumRelations
     296emptyNumRels = NumRels emptyUFM
     297
     298-- | Worklist for the algorithm searching for a path in the graph. Corresponds
     299-- to the list of edges with 'Equal', 'Greater' and 'GreatEq' labels
     300-- respectively.
     301data Worklist = Wl [(Unique, Unique)] [(Unique, Unique)] [(Unique, Unique)]
     302
     303emptyWorkList :: Worklist
     304emptyWorkList = Wl [] [] []
     305
     306-- | Get a next labeled edge and the remaining worklist or 'Nothing' if the
     307-- worklist is empty.
     308getNext :: Worklist -> Maybe (Unique, NumRelation, Unique, Worklist)
     309getNext (Wl (x:xs) ys zs) = Just (fst x, Equal,   snd x, Wl xs ys zs)
     310getNext (Wl [] (y:ys) zs) = Just (fst y, Greater, snd y, Wl [] ys zs)
     311getNext (Wl [] [] (z:zs)) = Just (fst z, GreatEq, snd z, Wl [] [] zs)
     312getNext _                 = Nothing
     313
     314-- | Create a worklist from the outgoing edges of the given vertex (i.e.
     315-- variable).
     316getWorklist :: UniqFM (UniqFM NumRelation) -> Unique -> Worklist
     317getWorklist umap1 source
     318  | Just umap2 <- lookupUFM umap1 source
     319  = let f p (Wl xs ys zs) = case p of
     320          (u, Equal)   -> Wl ((source, u) : xs) ys zs
     321          (u, Greater) -> Wl xs ((source, u) : ys) zs
     322          (u, GreatEq) -> Wl xs ys ((source, u) : zs)
     323    in foldr f emptyWorkList (ufmToList umap2)
     324  | otherwise = emptyWorkList
     325
     326concatWorklist :: Worklist -> Worklist -> Worklist
     327concatWorklist (Wl as bs cs) (Wl xs ys zs) = Wl (as ++ xs) (bs ++ ys) (cs ++ zs)
     328
     329insertRel :: (Uniquable u) => NumRelations -> u -> NumRelation -> u -> NumRelations
     330insertRel (NumRels graph1) source_ relation target_ =
     331  NumRels $! case relation of
     332    -- It is important to insert two edges in case of 'Equal'. Otherwise some of
     333    -- the paths (i.e. relations) will be much harder to find. Consider
     334    --   x > y and y == z
     335    -- if we store only one equal edge say '(y, Equal, z)', then we don't have
     336    -- an easy way of finding a path between 'x' and 'z' (without iterating over
     337    -- all other edges)!
     338    Equal -> insertRel_ graph2 target Equal source
     339    _     -> graph2
     340  where
     341    graph2 = insertRel_ graph1 source relation target
     342
     343    source = getUnique source_
     344    target = getUnique target_
     345
     346    insertRel_ umap src rel tar =
     347      let modIns (Just umap') = Just (addToUFM umap' tar rel)
     348          modIns Nothing      = Just (unitUFM tar rel)
     349      in alterUFM modIns umap src
     350
     351
     352checkRelation :: NumRelations -> Var -> Var -> Maybe NumRelation
     353checkRelation numrels var1 var2 =
     354  case (searchPath numrels var1 var2, searchPath numrels var2 var1) of
     355    -- Note that we can have that
     356    --   x >= y  and  y >= x
     357    -- This is only important in case of >= because then x == y. It is not
     358    -- possible for > and doesn't matter for ==.
     359    (Just GreatEq, Just GreatEq) -> Just Equal
     360    (something,    _           ) -> something
     361
     362-- | Searhing a path in the graph is inspired by Dijkstra shortest path
     363-- algorithm. We basically go and greedily explore the 'Equal', 'Greater'
     364-- and 'GreatEq' edges in this order and record the label of edges along
     365-- the way. E.g. if we have only 'Equal' edges then the two variables are equal.
     366searchPath :: (Uniquable u) => NumRelations -> u -> u -> Maybe NumRelation
     367-- searchPath :: NumRelations -> Var -> Var -> Maybe NumRelation
     368searchPath (NumRels umap) source_ target_ = go initialWl (unitUFM source Equal)
     369  where
     370    source = getUnique source_
     371    target = getUnique target_
     372
     373    initialWl = getWorklist umap source
     374
     375    go :: Worklist -> UniqFM NumRelation -> Maybe NumRelation
     376    go worklist visited = getNext worklist >>= go_
     377      where
     378        go_ (parent, rel, child, wl)
     379          | child == target         = combineRel rel <$> lookupUFM visited parent
     380          | child `elemUFM` visited = go wl visited
     381          | otherwise               = go wl' visited'
     382              where
     383                wl' = getWorklist umap child `concatWorklist` wl
     384                visited' = case lookupUFM visited parent of
     385                  Just prel -> addToUFM visited child (combineRel prel rel)
     386                  -- The following should never happen. Whenever we add
     387                  -- something to the worklist, the parent is inserted into
     388                  -- the visited map.
     389                  Nothing -> ASSERT2
     390                             (False, text "NumRelations: child without parent!")
     391                             visited
     392
     393    combineRel :: NumRelation -> NumRelation -> NumRelation
     394    combineRel Equal   Equal   = Equal
     395    combineRel Greater _       = Greater
     396    combineRel _       Greater = Greater
     397    combineRel _       _       = GreatEq
     398
     399--
     400-- Relational operators.
     401--
     402
     403data RelOp
     404  = Gt
     405  | Ge
     406  | Eq
     407  | Neq
     408  | Le
     409  | Lt
     410
     411instance Outputable RelOp where
     412  ppr Gt  = text ">"
     413  ppr Ge  = text ">="
     414  ppr Eq  = text "=="
     415  ppr Neq = text "/="
     416  ppr Le  = text "<="
     417  ppr Lt  = text "<"
     418
     419relOfIntrs :: (Ord a) => Interval a -> Interval a -> Maybe RelOp
     420relOfIntrs intr1 intr2
     421  | isJust (gtIntr  intr1 intr2) = Just Gt
     422  | isJust (geIntr  intr1 intr2) = Just Ge
     423  | isJust (eqIntr  intr1 intr2) = Just Eq
     424  | isJust (neqIntr intr1 intr2) = Just Neq
     425  | isJust (leIntr  intr1 intr2) = Just Le
     426  | isJust (ltIntr  intr1 intr2) = Just Lt
     427  | otherwise                    = Nothing
     428
     429cmpIntrWith :: (Ord a) => RelOp -> Interval a -> Interval a -> Maybe Bool
     430cmpIntrWith Gt  = gtIntr
     431cmpIntrWith Ge  = geIntr
     432cmpIntrWith Eq  = eqIntr
     433cmpIntrWith Neq = neqIntr
     434cmpIntrWith Le  = leIntr
     435cmpIntrWith Lt  = ltIntr
     436
     437-- | Check if for all possible values of the two intervals, the one from the
     438-- first one is always greater than/greater or equal/equal/less or equal/less
     439-- than the one from the second interval.
     440gtIntr, geIntr, eqIntr, neqIntr, leIntr, ltIntr
     441  :: (Ord a) => Interval a -> Interval a -> Maybe Bool
     442gtIntr i1 i2
     443  | Just l1 <- getLower i1 , Just u2 <- getUpper i2 , l1 > u2
     444  = Just True
     445  | Just l2 <- getLower i2 , Just u1 <- getUpper i1 , l2 >= u1
     446  = Just False
     447gtIntr _ _ = Nothing
     448
     449geIntr i1 i2
     450  | Just l1 <- getLower i1 , Just u2 <- getUpper i2 , l1 >= u2
     451  = Just True
     452  | Just l2 <- getLower i2 , Just u1 <- getUpper i1 , l2 > u1
     453  = Just False
     454geIntr _ _ = Nothing
     455
     456-- For these three we can simply reuse the above definitions.
     457leIntr i1 i2 = geIntr i2 i1
     458ltIntr i1 i2 = gtIntr i2 i1
     459neqIntr i1 i2 = not <$> eqIntr i1 i2
     460
     461eqIntr i1 i2
     462  -- If we can prove one variable greater than another,
     463  -- then they clearly can't be equal. Note that if we
     464  -- have 'Just False' it might be possible that the
     465  -- variables are in fact equal!
     466  | Just True <- gtIntr i1 i2 = Just False
     467  | Just True <- gtIntr i2 i1 = Just False
     468  -- If we know the exact values of the variables, then
     469  -- we can easily tell if they are equal or not.
     470  | Just l1 <- getLower i1, Just u1 <- getUpper i1
     471  , Just l2 <- getLower i2, Just u2 <- getUpper i2
     472  = if l1 == u1 && l2 == u2
     473      then Just $! l1 == l2  -- With above implies that u1 == u2.
     474      else Nothing
     475  | otherwise = Nothing
     476
     477-- | Return 'Just relop' if 'relop' is an operator that we can handle in this
     478-- optimization.
     479idToRelOp :: Id -> Maybe RelOp
     480idToRelOp i = isPrimOpId_maybe i >>= primOpToRelOp
     481
     482-- | Convert from a 'PrimOp' to 'RelOp' if the given 'PrimOp' can be handled by
     483-- the optimization. Otherwise return 'Nothing'.
     484primOpToRelOp :: PrimOp -> Maybe RelOp
     485primOpToRelOp IntGtOp = Just Gt
     486primOpToRelOp IntGeOp = Just Ge
     487primOpToRelOp IntLtOp = Just Lt
     488primOpToRelOp IntLeOp = Just Le
     489primOpToRelOp IntEqOp = Just Eq
     490
     491primOpToRelOp WordGtOp = Just Gt
     492primOpToRelOp WordGeOp = Just Ge
     493primOpToRelOp WordLtOp = Just Lt
     494primOpToRelOp WordLeOp = Just Le
     495primOpToRelOp WordEqOp = Just Eq
     496
     497primOpToRelOp FloatGtOp = Just Gt
     498primOpToRelOp FloatGeOp = Just Ge
     499primOpToRelOp FloatLtOp = Just Lt
     500primOpToRelOp FloatLeOp = Just Le
     501primOpToRelOp FloatEqOp = Just Eq
     502
     503primOpToRelOp DoubleGtOp = Just Gt
     504primOpToRelOp DoubleGeOp = Just Ge
     505primOpToRelOp DoubleLtOp = Just Lt
     506primOpToRelOp DoubleLeOp = Just Le
     507primOpToRelOp DoubleEqOp = Just Eq
     508
     509primOpToRelOp _ = Nothing
     510
     511-- | Negate the given 'RelOp', e.g.
     512--   negRelOp <  should give  >=
     513-- in other words
     514--   not (x < y)  should give  x >= y
     515negRelOp :: RelOp -> RelOp
     516negRelOp Gt  = Le
     517negRelOp Ge  = Le
     518negRelOp Eq  = Neq
     519negRelOp Neq = Eq
     520negRelOp Le  = Gt
     521negRelOp Lt  = Ge
     522
     523-- | Expresses that
     524--   x < y  iff  y > x
     525--   etc.
     526mirrorRelOp :: RelOp -> RelOp
     527mirrorRelOp Gt  = Lt
     528mirrorRelOp Ge  = Le
     529mirrorRelOp Eq  = Eq
     530mirrorRelOp Neq = Neq
     531mirrorRelOp Le  = Ge
     532mirrorRelOp Lt  = Gt
     533
     534--
     535-- Interval type.
     536--
     537
     538-- | Note that the intervals are always _closed_! Also for integers this means
     539-- that if we have 'x < 1' we can express that as 'BelowEq 0'.
     540data Interval a
     541  = BetweenEq !a !a
     542  | BelowEq !a
     543  | AboveEq !a
     544  | Top
     545
     546-- FIXME: any reason why Integer and Rational are not Outputable?
     547instance (Show a) => Outputable (Interval a) where
     548  ppr (BetweenEq a b) = char '[' <> text (show a) <> comma <+> text (show b) <> char ']'
     549  ppr (AboveEq a) = char '[' <> text (show a) <> comma <+> text "inf" <> char ']'
     550  ppr (BelowEq a) = char '[' <> text "inf" <> comma <+> text (show a) <> char ']'
     551  ppr Top      = char '[' <> text "inf" <> comma <+> text "inf" <> char ']'
     552
     553-- Generic function to update intervals that works both with Integer and
     554-- Rational ones.
     555updateIntrVarLit :: NumEnv -> Var -> RelOp -> Literal -> NumEnv
     556updateIntrVarLit numenv var relop lit
     557  | Just i <- litToInteger lit  = updateIntr numenv var relop i
     558  | Just r <- litToRational lit = updateIntr numenv var relop r
     559  | otherwise                   = numenv
     560
     561updateIntrLitVar :: NumEnv -> Literal -> RelOp -> Var -> NumEnv
     562updateIntrLitVar numenv lit relop var =
     563  updateIntrVarLit numenv var (mirrorRelOp relop) lit
     564
     565-- Update/refine intervals based on a new relation between some variables. That
     566-- is, if we know that 'x' is [0, 10] and 'y' is [8, inf] and then we learn that
     567-- that 'x' is larger than 'y' we can conclude that 'x' must be [9, 10] and 'y'
     568-- must be [8, 9].
     569updateIntrVarVar :: NumEnv -> Var -> RelOp -> Var -> NumEnv
     570updateIntrVarVar numenv _    Neq   _    = numenv
     571updateIntrVarVar numenv var1 relop var2
     572  | isIntegerLike ty
     573  -- = numenv
     574  = let mintr1 = lookupIntr numenv x :: Maybe (Interval Integer)
     575        mintr2 = lookupIntr numenv y
     576    in refineBoth mintr1 rel mintr2
     577  | isRationalLike ty
     578  = let mintr1 = lookupIntr numenv x :: Maybe (Interval Rational)
     579        mintr2 = lookupIntr numenv y
     580    in refineBoth mintr1 rel mintr2
     581  | otherwise
     582  = numenv
     583  where
     584    ty = varType var1
     585    -- Returns 'Nothing' only for 'Neq'.
     586    Just (x, rel, y) = toNumRelation var1 relop var2
     587
     588    -- Try to refine the intervals based on the new relation and insert them
     589    -- into the 'NumEnv'.
     590    refineBoth :: (Eq a, Intervalable a)
     591               => Maybe (Interval a) -> NumRelation -> Maybe (Interval a)
     592               -> NumEnv
     593    refineBoth (Just intr1) Greater (Just intr2) =
     594      case (getUpper intr1, getLower intr2) of
     595        (Just ux, Just ly) -> updateIntr (updateIntr numenv x Gt ly) y Lt ux
     596        (Just ux, Nothing) -> updateIntr numenv y Lt ux
     597        (Nothing, Just ly) -> updateIntr numenv x Gt ly
     598        _                  -> numenv
     599    refineBoth (Just intr1) GreatEq (Just intr2) =
     600      case (getUpper intr1, getLower intr2) of
     601        (Just ux, Just ly) -> updateIntr (updateIntr numenv x Ge ly) y Le ux
     602        (Just ux, Nothing) -> updateIntr numenv y Le ux
     603        (Nothing, Just ly) -> updateIntr numenv x Ge ly
     604        _                  -> numenv
     605    refineBoth (Just intr1) Greater Nothing
     606      | Just ux <- getUpper intr1
     607      = updateIntr numenv y Lt ux
     608    refineBoth (Just intr1) GreatEq Nothing
     609      | Just ux <- getUpper intr1
     610      = updateIntr numenv y Le ux
     611    refineBoth Nothing Greater (Just intr2)
     612      | Just ly <- getLower intr2
     613      = updateIntr numenv x Gt ly
     614    refineBoth Nothing GreatEq (Just intr2)
     615      | Just ly <- getLower intr2
     616      = updateIntr numenv x Ge ly
     617    refineBoth (Just intr1) Equal Nothing
     618      = insertIntr numenv y intr1
     619    refineBoth Nothing Equal (Just intr2)
     620      = insertIntr numenv x intr2
     621    refineBoth _ _ _ = numenv
     622
     623
     624-- | A class to cover numerical information about both Integers and
     625-- Rationals in some sane way.
     626class Intervalable a where
     627  lookupIntr :: NumEnv -> Var -> Maybe (Interval a)
     628  insertIntr :: NumEnv -> Var -> Interval a -> NumEnv
     629  updateIntr :: NumEnv -> Var -> RelOp -> a -> NumEnv
     630  toIntr     :: Literal -> Maybe (Interval a)
     631  mkIntr     :: RelOp -> a -> Interval a
     632  refineIntr :: RelOp -> a -> Interval a -> Interval a
     633
     634instance Intervalable Integer where
     635  lookupIntr env var = lookupVarEnv (neIntegers env) var
     636
     637  insertIntr env var intr =
     638    env { neIntegers = extendVarEnv (neIntegers env) var intr }
     639
     640  updateIntr numenv var relop lit = numenv' { neIntegers = newienv }
     641    where
     642      newienv = extendVarEnv intrs var newintr
     643
     644      numenv' = foldl' g numenv (ufmToList intrs)
     645
     646      g acc (u, intr)
     647        | Just op <- relOfIntrs newintr intr
     648        = addRelationU acc uvar op u
     649        | otherwise
     650        = acc
     651
     652      newintr = case lookupVarEnv intrs var of
     653        Just intr -> refineIntr relop lit intr
     654        Nothing   -> mkIntr relop lit
     655
     656      intrs = neIntegers numenv
     657      uvar = getUnique var
     658
     659  toIntr (MachInt i)    = Just $ BetweenEq i i
     660  toIntr (MachInt64 i)  = Just $ BetweenEq i i
     661  toIntr (MachWord i)   = Just $ BetweenEq i i
     662  toIntr (MachWord64 i) = Just $ BetweenEq i i
     663  toIntr _              = Nothing
     664
     665  mkIntr Gt a  = AboveEq (a + 1)
     666  mkIntr Ge a  = AboveEq a
     667  mkIntr Eq a  = BetweenEq a a
     668  mkIntr Neq _ = Top
     669  mkIntr Le a  = BelowEq a
     670  mkIntr Lt a  = BelowEq (a - 1)
     671
     672  refineIntr Gt a intr = case getLower intr of
     673    Just l | l <= a    -> setLower (a + 1) intr
     674           | otherwise -> intr
     675    Nothing            -> setLower (a + 1) intr
     676  refineIntr Ge a intr = case getLower intr of
     677    Just l | l < a     -> setLower a intr
     678           | otherwise -> intr
     679    Nothing            -> setLower a intr
     680  refineIntr Eq a _ = BetweenEq a a
     681  refineIntr Neq a intr = case (getLower intr, getUpper intr) of
     682    (Just l, _) | l == a -> setLower (a + 1) intr
     683    (_, Just u) | u == a -> setUpper (a - 1) intr
     684    _                    -> intr
     685  refineIntr Le a intr = case getUpper intr of
     686    Just u | a < u     -> setUpper a intr
     687           | otherwise -> intr
     688    Nothing            -> setUpper a intr
     689  refineIntr Lt a intr = case getUpper intr of
     690    Just u | a <= u    -> setUpper (a - 1) intr
     691           | otherwise -> intr
     692    Nothing            -> setUpper (a - 1) intr
     693
     694
     695instance Intervalable Rational where
     696  lookupIntr env var = lookupVarEnv (neRationals env) var
     697
     698  insertIntr env var intr =
     699    env { neRationals = extendVarEnv (neRationals env) var intr }
     700
     701  updateIntr numenv var relop lit = numenv' { neRationals = newrenv }
     702    where
     703      newrenv = extendVarEnv intrs var newintr
     704
     705      numenv' = foldl' g numenv (ufmToList intrs)
     706
     707      g acc (u, intr)
     708        | Just op <- relOfIntrs newintr intr
     709        = addRelationU acc uvar op u
     710        | otherwise
     711        = acc
     712
     713      newintr = case lookupVarEnv intrs var of
     714        Just intr -> refineIntr relop lit intr
     715        Nothing   -> mkIntr relop lit
     716
     717      intrs = neRationals numenv
     718      uvar = getUnique var
     719
     720  toIntr (MachFloat r)  = Just $ BetweenEq r r
     721  toIntr (MachDouble r) = Just $ BetweenEq r r
     722  toIntr _              = Nothing
     723
     724  mkIntr Gt a  = AboveEq a
     725  mkIntr Ge a  = AboveEq a
     726  mkIntr Eq a  = BetweenEq a a
     727  mkIntr Neq _ = Top
     728  mkIntr Le a  = BelowEq a
     729  mkIntr Lt a  = BelowEq a
     730
     731  refineIntr Gt a intr = case getLower intr of
     732    Just l | l < a     -> setLower a intr
     733           | otherwise -> intr
     734    Nothing            -> setLower a intr
     735  refineIntr Ge a intr = case getLower intr of
     736    Just l | l < a     -> setLower a intr
     737           | otherwise -> intr
     738    Nothing            -> setLower a intr
     739  refineIntr Eq a _ = BetweenEq a a
     740  refineIntr Neq _ intr = intr
     741  refineIntr Le a intr = case getUpper intr of
     742    Just u | a < u     -> setUpper a intr
     743           | otherwise -> intr
     744    Nothing            -> setUpper a intr
     745  refineIntr Lt a intr = case getUpper intr of
     746    Just u | a <= u    -> setUpper a intr
     747           | otherwise -> intr
     748    Nothing            -> setUpper a intr
     749
     750
     751getLower :: Interval a -> Maybe a
     752getLower (BetweenEq l _) = Just l
     753getLower (AboveEq l)     = Just l
     754getLower _               = Nothing
     755
     756getUpper :: Interval a -> Maybe a
     757getUpper (BetweenEq _ u) = Just u
     758getUpper (BelowEq u)     = Just u
     759getUpper _               = Nothing
     760
     761setLower :: a -> Interval a -> Interval a
     762setLower a (AboveEq _)     = AboveEq a
     763setLower a (BelowEq u)     = BetweenEq a u
     764setLower a (BetweenEq _ u) = BetweenEq a u
     765setLower a Top             = AboveEq a
     766
     767setUpper :: a -> Interval a -> Interval a
     768setUpper a (AboveEq l)     = BetweenEq l a
     769setUpper a (BelowEq _)     = BelowEq a
     770setUpper a (BetweenEq l _) = BetweenEq l a
     771setUpper a Top             = BelowEq a
     772
     773--
     774-- Some helper functions
     775--
     776
     777ifDebugTrace :: (Outputable a) => SDoc -> Maybe a -> Maybe a
     778ifDebugTrace cmp r
     779  | debugIsOn && isJust r
     780  = pprTrace "SimplCmps: known comparison:"
     781             (cmp <+> text "is" <+> ppr (fromJust r))
     782             r
     783  | otherwise = r
  • compiler/simplCore/SimplCore.lhs

    diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
    index d5915dd..9f66e16 100644
    a b import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, 
    1717                          extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
    1818import PprCore          ( pprCoreBindings, pprCoreExpr )
    1919import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
     20import SimplCmps        ( simplCmps )
    2021import IdInfo
    2122import CoreUtils        ( coreBindsSize, exprSize )
    2223import Simplify         ( simplTopBinds, simplExpr )
    getCoreToDo dflags 
    122123    static_args   = dopt Opt_StaticArgumentTransformation dflags
    123124    rules_on      = dopt Opt_EnableRewriteRules           dflags
    124125    eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
     126    comparisons   = dopt Opt_Comparisons                  dflags
    125127
    126128    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
    127129
    getCoreToDo dflags 
    282284
    283285        runWhen spec_constr CoreDoSpecConstr,
    284286
     287        runWhen comparisons CoreDoSimplCmps,
     288
    285289        maybe_rule_check (Phase 0),
    286290
    287291        -- Final clean-up simplification:
    doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} 
    390394doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
    391395                                       vectorise
    392396
     397doCorePass CoreDoSimplCmps           = {-# SCC "Comparisons" #-}
     398                                       doPass simplCmps
     399
    393400doCorePass CoreDoPrintCore              = observe   printCore
    394401doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
    395402doCorePass CoreDoNothing                = return