Store a SrcSpan instead of a SrcLoc inside a Name

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

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 92f8979..d08a6c9 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -13,7 +13,7 @@ module CoreUtils (
        mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart
-       findDefault, findAlt, isDefaultAlt, mergeAlts,
+       findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
 
        -- Properties of expressions
        exprType, coreAltType,
@@ -87,14 +87,13 @@ import GHC.Exts             -- For `xori`
 \begin{code}
 exprType :: CoreExpr -> Type
 
-exprType (Var var)             = idType var
-exprType (Lit lit)             = literalType lit
-exprType (Let _ body)          = exprType body
-exprType (Case _ _ ty alts)     = ty
-exprType (Cast e co) 
-  = let (_, ty) = coercionKind co in ty
-exprType (Note other_note e)    = exprType e
-exprType (Lam binder expr)      = mkPiType binder (exprType expr)
+exprType (Var var)          = idType var
+exprType (Lit lit)          = literalType lit
+exprType (Let _ body)       = exprType body
+exprType (Case _ _ ty alts)  = ty
+exprType (Cast e co)        = snd (coercionKind co)
+exprType (Note other_note e) = exprType e
+exprType (Lam binder expr)   = mkPiType binder (exprType expr)
 exprType e@(App _ _)
   = case collectArgs e of
        (fun, args) -> applyTypeToArgs e (exprType fun) args
@@ -260,6 +259,8 @@ mkAltExpr (DataAlt con) args inst_tys
   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 mkAltExpr (LitAlt lit) [] []
   = Lit lit
+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
@@ -314,6 +315,18 @@ mergeAlts (a1:as1) (a2:as2)
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
+
+
+---------------------------------
+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
+-- Given       case (C a b x y) of
+--                C b x y -> ...
+-- we want to drop the leading type argument of the scrutinee
+-- leaving the arguments to match agains the pattern
+
+trimConArgs DEFAULT      args = ASSERT( null args ) []
+trimConArgs (LitAlt lit) args = ASSERT( null args ) []
+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 \end{code}
 
 
@@ -721,7 +734,7 @@ dataConInstPat arg_fun fss uniqs con inst_tys
          co_kind  = substTy subst (mkPredTy eq_pred)
 
       -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
     id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
@@ -1374,10 +1387,10 @@ fast_hash_expr env other        = 1
 
 fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
-  | Just tv <- getTyVar_maybe ty          = hashVar env tv
-  | Just (tc,_) <- splitTyConApp_maybe ty
-                              = fromIntegral (hashName (tyConName tc))
-  | otherwise                            = 1
+  | Just tv <- getTyVar_maybe ty            = hashVar env tv
+  | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
+                                             in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
+  | otherwise                              = 1
 
 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
 extend_env (n,env) b = (n+1, extendVarEnv env b n)