TickBox representation change

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

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index b0de6f2..b847df0 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -69,6 +69,7 @@ import Outputable
 import DynFlags
 import TysPrim
 import FastString
+import Maybes
 import Util
 
 import GHC.Exts                -- For `xori` 
@@ -516,7 +517,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
@@ -800,6 +803,16 @@ 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.
+exprIsConApp_maybe (Note (TickBox {}) expr)
+  = Nothing
+exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
+  = Nothing
+-}
+
 exprIsConApp_maybe (Note _ expr)
   = exprIsConApp_maybe expr
     -- We ignore InlineMe notes in case we have
@@ -1120,7 +1133,8 @@ eta_expand n us expr ty
 
               Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
                   where 
-                    lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv)
+                    lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
+                       -- Using tv as a base retains its tyvar/covar-ness
                     (uniq:us2) = us 
        ; Nothing ->
   
@@ -1300,7 +1314,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
-
+ 
 varSize :: Var -> Int
 varSize b  | isTyVar b = 1
           | otherwise = seqType (idType b)             `seq`
@@ -1333,32 +1347,48 @@ hashExpr :: CoreExpr -> Int
 -- expressions may hash to the different Ints
 --
 -- The emphasis is on a crude, fast hash, rather than on high precision
+--
+-- 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 e)   -- Negative numbers kill UniqFM
-
-hash_expr (Note _ e)                     = hash_expr e
-hash_expr (Cast e co)             = hash_expr e
-hash_expr (Let (NonRec b r) e)    = hashId b
-hash_expr (Let (Rec ((b,r):_)) e) = hashId b
-hash_expr (Case _ b _ _)         = hashId b
-hash_expr (App f e)              = hash_expr f * fast_hash_expr e
-hash_expr (Var v)                = hashId v
-hash_expr (Lit lit)              = hashLiteral lit
-hash_expr (Lam b _)              = hashId b
-hash_expr (Type t)               = trace "hash_expr: type" 1           -- Shouldn't happen
-
-fast_hash_expr (Var v)         = hashId v
-fast_hash_expr (Lit lit)       = hashLiteral lit
-fast_hash_expr (App f (Type _)) = fast_hash_expr f
-fast_hash_expr (App f a)        = fast_hash_expr a
-fast_hash_expr (Lam b _)        = hashId b
-fast_hash_expr other           = 1
-
-hashId :: Id -> Int
-hashId id = hashName (idName id)
+            hash = abs (hash_expr (1,emptyVarEnv) e)   -- Negative numbers kill UniqFM
+
+type HashEnv = (Int, VarEnv Int)       -- Hash code for bound variables
+
+hash_expr :: HashEnv -> CoreExpr -> Int
+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 (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
+
+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 (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 env ty 
+  | Just tv <- getTyVar_maybe ty          = hashVar env tv
+  | Just (tc,_) <- splitTyConApp_maybe ty = 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)
 \end{code}
 
 %************************************************************************