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

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

Initial implementation.

  • compiler/ghc.cabal.in

    From fbacab904611590966b4e8771aa39fa147e2c22a 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 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