PowerPC NCG: support conditional branches outside +-32KB

[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 78da0e3..362fb52 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -71,6 +71,8 @@ import TysPrim
 import FastString
 import Maybes
 import Util
+import Data.Word
+import Data.Bits
 
 import GHC.Exts                -- For `xori` 
 \end{code}
@@ -517,7 +519,9 @@ side effects, and can't diverge or raise an exception.
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)     = True
 exprOkForSpeculation (Type _)    = True
+    -- Tick boxes are *not* suitable for speculation
 exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
+                                && not (isTickBoxOp v)
 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
 exprOkForSpeculation other_expr
@@ -621,10 +625,6 @@ exprIsHNF (Lit l)     = True
 exprIsHNF (Type ty)       = True       -- Types are honorary Values; 
                                        -- we don't mind copying them
 exprIsHNF (Lam b e)       = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note (TickBox {}) _)
-                          = False
-exprIsHNF (Note (BinaryTickBox {}) _)
-                          = False
 exprIsHNF (Note _ e)      = exprIsHNF e
 exprIsHNF (Cast e co)      = exprIsHNF e
 exprIsHNF (App e (Type _)) = exprIsHNF e
@@ -805,6 +805,7 @@ exprIsConApp_maybe (Cast expr co)
     Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
     }}
 
+{-
 -- We do not want to tell the world that we have a
 -- Cons, to *stop* Case of Known Cons, which removes
 -- the TickBox.
@@ -812,6 +813,7 @@ exprIsConApp_maybe (Note (TickBox {}) expr)
   = Nothing
 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
   = Nothing
+-}
 
 exprIsConApp_maybe (Note _ expr)
   = exprIsConApp_maybe expr
@@ -1197,9 +1199,6 @@ exprArity e = go e
              go (Var v)                   = idArity v
              go (Lam x e) | isId x        = go e + 1
                           | otherwise     = go e
-              go (Note (TickBox {}) _)     = 0
-              go (Note (BinaryTickBox {}) _) 
-                                          = 0
              go (Note n e)                = go e
               go (Cast e _)                = go e
              go (App e (Type t))          = go e
@@ -1317,9 +1316,7 @@ exprSize (Type t)        = seqType t `seq` 1
 noteSize (SCC cc)       = cc `seq` 1
 noteSize InlineMe       = 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
-noteSize (TickBox m n)    = m `seq` n `seq` 1 
-noteSize (BinaryTickBox m t e)  = m `seq` t `seq` e `seq` 1 
-
+ 
 varSize :: Var -> Int
 varSize b  | isTyVar b = 1
           | otherwise = seqType (idType b)             `seq`
@@ -1356,44 +1353,48 @@ hashExpr :: CoreExpr -> Int
 -- We must be careful that \x.x and \y.y map to the same hash code,
 -- (at least if we want the above invariant to be true)
 
-hashExpr e | hash < 0  = 77    -- Just in case we hit -maxInt
-          | otherwise = hash
-          where
-            hash = abs (hash_expr (1,emptyVarEnv) e)   -- Negative numbers kill UniqFM
+hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
+             -- UniqFM doesn't like negative Ints
 
 type HashEnv = (Int, VarEnv Int)       -- Hash code for bound variables
 
-hash_expr :: HashEnv -> CoreExpr -> Int
+hash_expr :: HashEnv -> CoreExpr -> Word32
+-- Word32, because we're expecting overflows here, and overflowing
+-- signed types just isn't cool.  In C it's even undefined.
 hash_expr env (Note _ e)             = hash_expr env e
 hash_expr env (Cast e co)             = hash_expr env e
 hash_expr env (Var v)                = hashVar env v
-hash_expr env (Lit lit)                      = hashLiteral lit
+hash_expr env (Lit lit)                      = fromIntegral (hashLiteral lit)
 hash_expr env (App f e)              = hash_expr env f * fast_hash_expr env e
 hash_expr env (Let (NonRec b r) e)    = hash_expr (extend_env env b) e * fast_hash_expr env r
 hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
 hash_expr env (Case e _ _ _)         = hash_expr env e
 hash_expr env (Lam b e)                      = hash_expr (extend_env env b) e
-hash_expr env (Type t)               = fast_hash_type env t
+hash_expr env (Type t)               = WARN(True, text "hash_expr: type") 1
+-- Shouldn't happen.  Better to use WARN than trace, because trace
+-- prevents the CPR optimisation kicking in for hash_expr.
 
 fast_hash_expr env (Var v)             = hashVar env v
 fast_hash_expr env (Type t)    = fast_hash_type env t
-fast_hash_expr env (Lit lit)   = hashLiteral lit
+fast_hash_expr env (Lit lit)   = fromIntegral (hashLiteral lit)
 fast_hash_expr env (Cast e co)  = fast_hash_expr env e
 fast_hash_expr env (Note n e)   = fast_hash_expr env e
 fast_hash_expr env (App f a)    = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
 fast_hash_expr env other        = 1
 
-fast_hash_type :: HashEnv -> Type -> Int
+fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
   | Just tv <- getTyVar_maybe ty          = hashVar env tv
-  | Just (tc,_) <- splitTyConApp_maybe ty = hashName (tyConName tc)
+  | Just (tc,_) <- splitTyConApp_maybe ty
+                              = fromIntegral (hashName (tyConName tc))
   | otherwise                            = 1
 
 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
 extend_env (n,env) b = (n+1, extendVarEnv env b n)
 
-hashVar :: HashEnv -> Var -> Int
-hashVar (_,env) v = lookupVarEnv env v `orElse` hashName (idName v)
+hashVar :: HashEnv -> Var -> Word32
+hashVar (_,env) v
+ = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
 \end{code}
 
 %************************************************************************
@@ -1480,8 +1481,6 @@ rhsIsStatic this_pkg rhs = is_static False rhs
   is_static False (Lam b e) = isRuntimeVar b || is_static False e
   
   is_static in_arg (Note (SCC _) e) = False
-  is_static in_arg (Note (TickBox {}) e) = False
-  is_static in_arg (Note (BinaryTickBox {}) e) = False
   is_static in_arg (Note _ e)       = is_static in_arg e
   is_static in_arg (Cast e co)      = is_static in_arg e