| 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 | -- |
| 12 | module Comparisons ( comparisons ) where |
| 13 | |
| 14 | #include "HsVersions.h" |
| 15 | |
| 16 | import CoreSubst |
| 17 | import CoreSyn |
| 18 | import Id |
| 19 | import Literal |
| 20 | import Outputable |
| 21 | import PrimOp |
| 22 | import Type hiding ( substTy ) |
| 23 | import TysPrim |
| 24 | import TysWiredIn |
| 25 | import UniqFM |
| 26 | import Unique |
| 27 | import Util ( debugIsOn ) |
| 28 | import Var |
| 29 | import VarEnv |
| 30 | |
| 31 | import Control.Applicative ( (<$>), (<|>) ) |
| 32 | import Data.List ( foldl', mapAccumL ) |
| 33 | import Data.Maybe ( fromJust, fromMaybe, isJust ) |
| 34 | |
| 35 | comparisons :: [CoreBind] -> [CoreBind] |
| 36 | comparisons = snd . mapAccumL optimizeBind emptySubst |
| 37 | |
| 38 | optimizeBind :: Subst -> CoreBind -> (Subst, CoreBind) |
| 39 | optimizeBind subst (NonRec var expr) = (subst', NonRec var' expr') |
| 40 | where |
| 41 | expr' = tryToSimplify emptyNumEnv subst' expr |
| 42 | (subst', var') = substBndr subst var |
| 43 | optimizeBind 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 | |
| 49 | tryToSimplify :: NumEnv -> Subst -> CoreExpr -> CoreExpr |
| 50 | tryToSimplify numenv subst expr = |
| 51 | fromMaybe expr' (trueOrFalseExpr <$> tryEval numenv subst expr') |
| 52 | where |
| 53 | expr' = optimizeExpr numenv subst expr |
| 54 | |
| 55 | optimizeExpr :: NumEnv -> Subst -> CoreExpr -> CoreExpr |
| 56 | optimizeExpr numenv subst (Case expr bndr ty alts) |
| 57 | = Case (tryToSimplify numenv subst expr) bndr ty |
| 58 | $ map (optimizeAlt numenv subst expr) alts |
| 59 | optimizeExpr numenv subst (App expr arg) |
| 60 | = App (tryToSimplify numenv subst expr) (tryToSimplify numenv subst arg) |
| 61 | optimizeExpr numenv subst (Lam bndr expr) |
| 62 | = Lam bndr' (tryToSimplify numenv subst' expr) |
| 63 | where |
| 64 | (subst', bndr') = substBndr subst bndr |
| 65 | optimizeExpr numenv subst (Let bndr expr) |
| 66 | = Let bndr' (tryToSimplify numenv subst' expr) |
| 67 | where |
| 68 | (subst', bndr') = optimizeBind subst bndr |
| 69 | optimizeExpr numenv subst (Cast expr coer) |
| 70 | = Cast (tryToSimplify numenv subst expr) (substCo subst coer) |
| 71 | optimizeExpr numenv subst (Tick tickid expr) = |
| 72 | Tick (substTickish subst tickid) (tryToSimplify numenv subst expr) |
| 73 | optimizeExpr _ subst (Type ty) = Type (substTy subst ty) |
| 74 | optimizeExpr _ subst (Coercion co) = Coercion (substCo subst co) |
| 75 | optimizeExpr _ subst (Var var) = lookupSubst subst var |
| 76 | optimizeExpr _ _ (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). |
| 85 | optimizeAlt :: NumEnv -> Subst -> CoreExpr -> CoreAlt -> (AltCon, [CoreBndr], CoreExpr) |
| 86 | optimizeAlt 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 |
| 102 | optimizeAlt numenv subst _ (altcon, args, expr) = |
| 103 | (altcon, args', tryToSimplify numenv subst' expr) |
| 104 | where |
| 105 | (subst', args') = substBndrs subst args |
| 106 | |
| 107 | lookupSubst :: Subst -> Var -> CoreExpr |
| 108 | lookupSubst = lookupIdSubst (text "Comparisons.lookupSubst") |
| 109 | |
| 110 | trueOrFalseId :: Bool -> Id |
| 111 | trueOrFalseId True = trueDataConId |
| 112 | trueOrFalseId False = falseDataConId |
| 113 | |
| 114 | trueOrFalseExpr :: Bool -> CoreExpr |
| 115 | trueOrFalseExpr = Var . trueOrFalseId |
| 116 | |
| 117 | tryEval :: NumEnv -> Subst -> CoreExpr -> Maybe Bool |
| 118 | tryEval 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. |
| 150 | evalVarLit :: NumEnv -> Var -> RelOp -> Literal -> Maybe Bool |
| 151 | evalVarLit 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'). |
| 161 | evalLitVar :: NumEnv -> Literal -> RelOp -> Var -> Maybe Bool |
| 162 | evalLitVar env lit relop var = evalVarLit env var (mirrorRelOp relop) lit |
| 163 | |
| 164 | -- | The last where we compare two variables. |
| 165 | evalVarVar :: NumEnv -> Var -> RelOp -> Var -> Maybe Bool |
| 166 | evalVarVar 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'. |
| 179 | evalRelOp :: NumRelation -- ^ This is what we know. |
| 180 | -> RelOp -- ^ And this what is asked. |
| 181 | -> Maybe Bool |
| 182 | evalRelOp Greater relop = case relop of |
| 183 | Gt -> Just True |
| 184 | Ge -> Just True |
| 185 | Neq -> Just True |
| 186 | _ -> Just False |
| 187 | evalRelOp GreatEq relop = case relop of |
| 188 | Ge -> Just True |
| 189 | Lt -> Just False |
| 190 | _ -> Nothing |
| 191 | evalRelOp 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. |
| 199 | evalIntr :: NumEnv -> Var -> RelOp -> Var -> Maybe Bool |
| 200 | evalIntr 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 | |
| 213 | litToInteger :: Literal -> Maybe Integer |
| 214 | litToInteger (MachInt i) = Just i |
| 215 | litToInteger (MachInt64 i) = Just i |
| 216 | litToInteger (MachWord i) = Just i |
| 217 | litToInteger (MachWord64 i) = Just i |
| 218 | litToInteger _ = Nothing |
| 219 | |
| 220 | litToRational :: Literal -> Maybe Rational |
| 221 | litToRational (MachFloat r) = Just r |
| 222 | litToRational (MachDouble r) = Just r |
| 223 | litToRational _ = Nothing |
| 224 | |
| 225 | -- | Take two arguments and rearrange them, so that we can convert 'RelOp' to |
| 226 | -- 'NumRelation'. The order of arguments obviously matters. |
| 227 | toNumRelation :: a -> RelOp -> a -> Maybe (a, NumRelation, a) |
| 228 | toNumRelation 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. |
| 238 | isIntegerLike :: Type -> Bool |
| 239 | isIntegerLike 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'. |
| 250 | isRationalLike :: Type -> Bool |
| 251 | isRationalLike ty = case tyConAppTyCon_maybe ty of |
| 252 | Just con -> con == floatPrimTyCon |
| 253 | || con == doublePrimTyCon |
| 254 | Nothing -> False |
| 255 | |
| 256 | -- |
| 257 | -- Numerical environment. |
| 258 | -- |
| 259 | |
| 260 | data NumEnv = NumEnv |
| 261 | { neIntegers :: VarEnv (Interval Integer) |
| 262 | , neRationals :: VarEnv (Interval Rational) |
| 263 | , neRelations :: NumRelations |
| 264 | } |
| 265 | |
| 266 | instance Outputable NumEnv where |
| 267 | ppr (NumEnv ienv renv rels) = ppr ienv $$ ppr renv $$ ppr rels |
| 268 | |
| 269 | emptyNumEnv :: NumEnv |
| 270 | emptyNumEnv = NumEnv emptyVarEnv emptyVarEnv emptyNumRels |
| 271 | |
| 272 | addRelation :: NumEnv -> Var -> RelOp -> Var -> NumEnv |
| 273 | addRelation numenv var1 relop var2 = |
| 274 | updateIntrVarVar numenv' var1 relop var2 |
| 275 | where |
| 276 | numenv' = addRelationU numenv var1 relop var2 |
| 277 | |
| 278 | addRelationU :: (Uniquable a) => NumEnv -> a -> RelOp -> a -> NumEnv |
| 279 | -- With current representation there's nothing we can |
| 280 | -- do with not equal. |
| 281 | addRelationU numenv _ Neq _ = numenv |
| 282 | addRelationU 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. |
| 293 | data NumRelation |
| 294 | = Greater |
| 295 | | GreatEq |
| 296 | | Equal |
| 297 | |
| 298 | instance 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. |
| 304 | data NumRelations = NumRels (UniqFM (UniqFM NumRelation)) |
| 305 | |
| 306 | instance Outputable NumRelations where |
| 307 | ppr (NumRels graph) = ppr graph |
| 308 | |
| 309 | emptyNumRels :: NumRelations |
| 310 | emptyNumRels = NumRels emptyUFM |
| 311 | |
| 312 | insertRel :: (Uniquable u) => NumRelations -> u -> NumRelation -> u -> NumRelations |
| 313 | insertRel (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 | |
| 335 | checkRelation :: NumRelations -> Var -> Var -> Maybe NumRelation |
| 336 | checkRelation 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. |
| 349 | searchPath :: NumRelations -> Var -> Var -> Maybe NumRelation |
| 350 | searchPath (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. |
| 384 | data Worklist = Wl [(Unique, Unique)] [(Unique, Unique)] [(Unique, Unique)] |
| 385 | |
| 386 | emptyWorkList :: Worklist |
| 387 | emptyWorkList = Wl [] [] [] |
| 388 | |
| 389 | -- | Get a next labeled edge and the remaining worklist or 'Nothing' if the |
| 390 | -- worklist is empty. |
| 391 | getNext :: Worklist -> Maybe (Unique, NumRelation, Unique, Worklist) |
| 392 | getNext (Wl (x:xs) ys zs) = Just (fst x, Equal, snd x, Wl xs ys zs) |
| 393 | getNext (Wl [] (y:ys) zs) = Just (fst y, Greater, snd y, Wl [] ys zs) |
| 394 | getNext (Wl [] [] (z:zs)) = Just (fst z, GreatEq, snd z, Wl [] [] zs) |
| 395 | getNext _ = Nothing |
| 396 | |
| 397 | -- | Create a worklist from the outgoing edges of the given vertex (i.e. |
| 398 | -- variable). |
| 399 | getWorklist :: UniqFM (UniqFM NumRelation) -> Unique -> Worklist |
| 400 | getWorklist 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 | |
| 409 | concatWorklist :: Worklist -> Worklist -> Worklist |
| 410 | concatWorklist (Wl as bs cs) (Wl xs ys zs) = Wl (as ++ xs) (bs ++ ys) (cs ++ zs) |
| 411 | |
| 412 | -- |
| 413 | -- Relational operators. |
| 414 | -- |
| 415 | |
| 416 | data RelOp |
| 417 | = Gt |
| 418 | | Ge |
| 419 | | Eq |
| 420 | | Neq |
| 421 | | Le |
| 422 | | Lt |
| 423 | |
| 424 | instance 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 | |
| 432 | relOfIntrs :: (Ord a) => Interval a -> Interval a -> Maybe RelOp |
| 433 | relOfIntrs 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 | |
| 442 | cmpIntrWith :: (Ord a) => RelOp -> Interval a -> Interval a -> Maybe Bool |
| 443 | cmpIntrWith Gt = gtIntr |
| 444 | cmpIntrWith Ge = geIntr |
| 445 | cmpIntrWith Eq = eqIntr |
| 446 | cmpIntrWith Neq = neqIntr |
| 447 | cmpIntrWith Le = leIntr |
| 448 | cmpIntrWith 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. |
| 453 | gtIntr, geIntr, eqIntr, neqIntr, leIntr, ltIntr |
| 454 | :: (Ord a) => Interval a -> Interval a -> Maybe Bool |
| 455 | gtIntr 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 |
| 460 | gtIntr _ _ = Nothing |
| 461 | |
| 462 | geIntr 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 |
| 467 | geIntr _ _ = Nothing |
| 468 | |
| 469 | -- For these three we can simply reuse the above definitions. |
| 470 | leIntr i1 i2 = geIntr i2 i1 |
| 471 | ltIntr i1 i2 = gtIntr i2 i1 |
| 472 | neqIntr i1 i2 = not <$> eqIntr i1 i2 |
| 473 | |
| 474 | eqIntr 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. |
| 492 | idToRelOp :: Id -> Maybe RelOp |
| 493 | idToRelOp 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'. |
| 497 | primOpToRelOp :: PrimOp -> Maybe RelOp |
| 498 | primOpToRelOp IntGtOp = Just Gt |
| 499 | primOpToRelOp IntGeOp = Just Ge |
| 500 | primOpToRelOp IntLtOp = Just Lt |
| 501 | primOpToRelOp IntLeOp = Just Le |
| 502 | primOpToRelOp IntEqOp = Just Eq |
| 503 | |
| 504 | primOpToRelOp WordGtOp = Just Gt |
| 505 | primOpToRelOp WordGeOp = Just Ge |
| 506 | primOpToRelOp WordLtOp = Just Lt |
| 507 | primOpToRelOp WordLeOp = Just Le |
| 508 | primOpToRelOp WordEqOp = Just Eq |
| 509 | |
| 510 | primOpToRelOp FloatGtOp = Just Gt |
| 511 | primOpToRelOp FloatGeOp = Just Ge |
| 512 | primOpToRelOp FloatLtOp = Just Lt |
| 513 | primOpToRelOp FloatLeOp = Just Le |
| 514 | primOpToRelOp FloatEqOp = Just Eq |
| 515 | |
| 516 | primOpToRelOp DoubleGtOp = Just Gt |
| 517 | primOpToRelOp DoubleGeOp = Just Ge |
| 518 | primOpToRelOp DoubleLtOp = Just Lt |
| 519 | primOpToRelOp DoubleLeOp = Just Le |
| 520 | primOpToRelOp DoubleEqOp = Just Eq |
| 521 | |
| 522 | primOpToRelOp _ = 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 |
| 528 | negRelOp :: RelOp -> RelOp |
| 529 | negRelOp Gt = Le |
| 530 | negRelOp Ge = Le |
| 531 | negRelOp Eq = Neq |
| 532 | negRelOp Neq = Eq |
| 533 | negRelOp Le = Gt |
| 534 | negRelOp Lt = Ge |
| 535 | |
| 536 | -- | Expresses that |
| 537 | -- x < y iff y > x |
| 538 | -- etc. |
| 539 | mirrorRelOp :: RelOp -> RelOp |
| 540 | mirrorRelOp Gt = Lt |
| 541 | mirrorRelOp Ge = Le |
| 542 | mirrorRelOp Eq = Eq |
| 543 | mirrorRelOp Neq = Neq |
| 544 | mirrorRelOp Le = Ge |
| 545 | mirrorRelOp 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'. |
| 553 | data 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? |
| 560 | instance (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. |
| 568 | updateIntrVarLit :: NumEnv -> Var -> RelOp -> Literal -> NumEnv |
| 569 | updateIntrVarLit 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 | |
| 574 | updateIntrLitVar :: NumEnv -> Literal -> RelOp -> Var -> NumEnv |
| 575 | updateIntrLitVar 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]. |
| 582 | updateIntrVarVar :: NumEnv -> Var -> RelOp -> Var -> NumEnv |
| 583 | updateIntrVarVar numenv _ Neq _ = numenv |
| 584 | updateIntrVarVar 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. |
| 639 | class 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 | |
| 647 | instance 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 | |
| 708 | instance 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 | |
| 764 | getLower :: Interval a -> Maybe a |
| 765 | getLower (BetweenEq l _) = Just l |
| 766 | getLower (AboveEq l) = Just l |
| 767 | getLower _ = Nothing |
| 768 | |
| 769 | getUpper :: Interval a -> Maybe a |
| 770 | getUpper (BetweenEq _ u) = Just u |
| 771 | getUpper (BelowEq u) = Just u |
| 772 | getUpper _ = Nothing |
| 773 | |
| 774 | setLower :: a -> Interval a -> Interval a |
| 775 | setLower a (AboveEq _) = AboveEq a |
| 776 | setLower a (BelowEq u) = BetweenEq a u |
| 777 | setLower a (BetweenEq _ u) = BetweenEq a u |
| 778 | setLower a Top = AboveEq a |
| 779 | |
| 780 | setUpper :: a -> Interval a -> Interval a |
| 781 | setUpper a (AboveEq l) = BetweenEq l a |
| 782 | setUpper a (BelowEq _) = BelowEq a |
| 783 | setUpper a (BetweenEq l _) = BetweenEq l a |
| 784 | setUpper a Top = BelowEq a |
| 785 | |
| 786 | -- |
| 787 | -- Some helper functions |
| 788 | -- |
| 789 | |
| 790 | ifDebugTrace :: (Outputable a) => SDoc -> Maybe a -> Maybe a |
| 791 | ifDebugTrace cmp r |
| 792 | | debugIsOn && isJust r |
| 793 | = pprTrace "Comparisons: known comparison:" |
| 794 | (cmp <+> text "is" <+> ppr (fromJust r)) |
| 795 | r |
| 796 | | otherwise = r |