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, 20 months ago)

Fixed patch.

  • compiler/ghc.cabal.in

    From a1425ed18c0feb07583068e0439750cee1446a23 Mon Sep 17 00:00:00 2001
    From: Michal Terepeta <michal.terepeta@gmail.com>
    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