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

File 0001-Optimize-nested-comparisons-ticket-2132.2.patch, 33.8 KB (added by michalt, 3 years ago)

Fixed patch.

  • compiler/ghc.cabal.in

    From a1425ed18c0feb07583068e0439750cee1446a23 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 patch implements a new optimization simplCore/Comparisons, which
    keeps track what comparisons have been done and uses that to remove
    ones that are guaranteed to be always true or false. 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 detect that the second comparison is always false. Finally it
    is also able to use transitivity so here:
      case x ># y of
        True -> .. case y ># z of
          True -> .. x ># z ..
        ..
    it will optimize away the last comparison.
    ---
     compiler/ghc.cabal.in             |    1 +
     compiler/main/DynFlags.hs         |    3 +
     compiler/simplCore/Comparisons.hs |  796 +++++++++++++++++++++++++++++++++++++
     compiler/simplCore/CoreMonad.lhs  |    3 +
     compiler/simplCore/SimplCore.lhs  |    7 +
     5 files changed, 810 insertions(+), 0 deletions(-)
     create mode 100644 compiler/simplCore/Comparisons.hs
    
    diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
    index 9eaa0ef..8b02c54 100644
    a b Library 
    350350        FloatOut
    351351        LiberateCase
    352352        OccurAnal
     353        Comparisons
    353354        SAT
    354355        SetLevels
    355356        SimplCore
  • compiler/main/DynFlags.hs

    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index 8abe664..07c91db 100644
    a b data DynFlag 
    282282   | Opt_IrrefutableTuples
    283283   | Opt_CmmSink
    284284   | Opt_CmmElimCommonBlocks
     285   | Opt_Comparisons
    285286
    286287   -- Interface files
    287288   | Opt_IgnoreInterfacePragmas
    fFlags = [ 
    20592060  ( "irrefutable-tuples",               Opt_IrrefutableTuples, nop ),
    20602061  ( "cmm-sink",                         Opt_CmmSink, nop ),
    20612062  ( "cmm-elim-common-blocks",           Opt_CmmElimCommonBlocks, nop ),
     2063  ( "comparisons",                      Opt_Comparisons, nop),
    20622064  ( "gen-manifest",                     Opt_GenManifest, nop ),
    20632065  ( "embed-manifest",                   Opt_EmbedManifest, nop ),
    20642066  ( "ext-core",                         Opt_EmitExternalCore, nop ),
    optLevelFlags 
    23292331    , ([2],     Opt_LiberateCase)
    23302332    , ([2],     Opt_SpecConstr)
    23312333    , ([2],     Opt_RegsGraph)
     2334    , ([2],     Opt_Comparisons)
    23322335    , ([0,1,2], Opt_LlvmTBAA)
    23332336    , ([0,1,2], Opt_RegLiveness)
    23342337    , ([1,2],   Opt_CmmSink)
  • new file compiler/simplCore/Comparisons.hs

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

    diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
    index b1429c5..0572e70 100644
    a b data CoreToDo -- These are diff core-to-core passes, 
    249249  | CoreDoSpecialising
    250250  | CoreDoSpecConstr
    251251  | CoreCSE
     252  | CoreDoComparisons
    252253  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
    253254                                           -- matching this string
    254255  | CoreDoVectorisation
    coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core 
    272273coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
    273274coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
    274275coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
     276coreDumpFlag CoreDoComparisons        = Just Opt_D_verbose_core2core
    275277coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
    276278coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
    277279coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
    instance Outputable CoreToDo where 
    309311  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
    310312  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
    311313  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
     314  ppr CoreDoComparisons        = ptext (sLit "Comparisons")
    312315
    313316pprPassDetails :: CoreToDo -> SDoc
    314317pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
  • compiler/simplCore/SimplCore.lhs

    diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
    index 731f551..cbaf910 100644
    a b import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, 
    2424                          extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
    2525import PprCore          ( pprCoreBindings, pprCoreExpr )
    2626import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
     27import Comparisons      ( comparisons )
    2728import IdInfo
    2829import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize )
    2930import Simplify         ( simplTopBinds, simplExpr )
    getCoreToDo dflags 
    130131    static_args   = dopt Opt_StaticArgumentTransformation dflags
    131132    rules_on      = dopt Opt_EnableRewriteRules           dflags
    132133    eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
     134    comparisons   = dopt Opt_Comparisons                  dflags
    133135
    134136    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
    135137
    getCoreToDo dflags 
    294296
    295297        runWhen spec_constr CoreDoSpecConstr,
    296298
     299        runWhen comparisons CoreDoComparisons,
     300
    297301        maybe_rule_check (Phase 0),
    298302
    299303        -- Final clean-up simplification:
    doCorePass _ CoreDoSpecConstr = {-# SCC "SpecConstr" #-} 
    402406doCorePass _      CoreDoVectorisation       = {-# SCC "Vectorise" #-}
    403407                                              vectorise
    404408
     409doCorePass _      CoreDoComparisons         = {-# SCC "Comparisons" #-}
     410                                              doPass comparisons
     411
    405412doCorePass _      CoreDoPrintCore              = observe   printCore
    406413doCorePass _      (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
    407414doCorePass _      CoreDoNothing                = return