Remove dead code in the CPS pass

[ghc-hetmet.git] / compiler / basicTypes / DataCon.lhs

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index a3504a6..9ce966e 100644 (file)
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -43,6 +43,11 @@ import ListSetOps
 import Util
 import Maybes
 import FastString
+import PackageConfig
+import Module
+
+import Data.Char
+import Data.Word
 \end{code}
 
 
@@ -492,18 +497,7 @@ mkDataCon name declared_infix
        -- The representation tycon looks like this:
        --   data :R7T b c where 
        --      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
-
-    orig_res_ty 
-       | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tycon
-       , let fam_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
-       = mkTyConApp fam_tc (substTys fam_subst fam_tys)
-       | otherwise
-       = mkTyConApp tycon res_tys
-       where
-         res_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs
-               -- In the example above, 
-               --      univ_tvs = [ b1, c1 ]
-               --      res_tys  = [ b1, b1 ]
+    orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tvs)
 
        -- Representation arguments and demands
        -- To do: eliminate duplication with MkId
@@ -529,19 +523,6 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
 dataConName :: DataCon -> Name
 dataConName = dcName
 
--- generate a name in the format: package:Module.OccName
--- and the unique identity of the name
-dataConIdentity :: DataCon -> String
-dataConIdentity dataCon
-   = prettyName
-   where
-   prettyName = pretty packageModule ++ "." ++ pretty occ
-   nm = getName dataCon
-   packageModule = nameModule nm
-   occ = getOccName dataCon
-   pretty :: Outputable a => a -> String 
-   pretty = showSDoc . ppr
-
 dataConTag :: DataCon -> ConTag
 dataConTag  = dcTag
 
@@ -645,9 +626,9 @@ dataConStupidTheta dc = dcStupidTheta dc
 dataConUserType :: DataCon -> Type
 -- The user-declared type of the data constructor
 -- in the nice-to-read form 
---     T :: forall a. a -> T [a]
+--     T :: forall a b. a -> b -> T [a]
 -- rather than
---     T :: forall b. forall a. (a=[b]) => a -> T b
+--     T :: forall a c. forall b. (c=[a]) => a -> b -> T c
 -- NB: If the constructor is part of a data instance, the result type
 -- mentions the family tycon, not the internal one.
 dataConUserType  (MkData { dcUnivTyVars = univ_tvs, 
@@ -659,34 +640,37 @@ dataConUserType  (MkData { dcUnivTyVars = univ_tvs,
     mkFunTys arg_tys $
     res_ty
 
-dataConInstArgTys :: DataCon
+dataConInstArgTys :: DataCon   -- A datacon with no existentials or equality constraints
+                               -- However, it can have a dcTheta (notably it can be a 
+                               -- class dictionary, with superclasses)
                  -> [Type]     -- Instantiated at these types
-                               -- NB: these INCLUDE the existentially quantified arg types
                  -> [Type]     -- Needs arguments of these types
-                               -- NB: these INCLUDE the existentially quantified dict args
+                               -- NB: these INCLUDE any dict args
                                --     but EXCLUDE the data-decl context which is discarded
                                -- It's all post-flattening etc; this is a representation type
-dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys, 
-                             dcUnivTyVars = univ_tvs, 
+dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, 
+                             dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
                              dcExTyVars = ex_tvs}) inst_tys
- = ASSERT2 ( length tyvars == length inst_tys 
-           , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys)
-           
-   map (substTyWith tyvars inst_tys) arg_tys
- where
-   tyvars = univ_tvs ++ ex_tvs
-
-
--- And the same deal for the original arg tys
-dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
+ = ASSERT2 ( length univ_tvs == length inst_tys 
+           , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
+   ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )        
+   map (substTyWith univ_tvs inst_tys) rep_arg_tys
+
+dataConInstOrigArgTys 
+       :: DataCon      -- Works for any DataCon
+       -> [Type]       -- Includes existential tyvar args, but NOT
+                       -- equality constraints or dicts
+       -> [Type]       -- Returns just the instsantiated *value* arguments
+-- For vanilla datacons, it's all quite straightforward
+-- But for the call in MatchCon, we really do want just the value args
 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
                                  dcUnivTyVars = univ_tvs, 
                                  dcExTyVars = ex_tvs}) inst_tys
- = ASSERT2( length tyvars == length inst_tys
+  = ASSERT2( length tyvars == length inst_tys
           , ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
-   map (substTyWith tyvars inst_tys) arg_tys
- where
-   tyvars = univ_tvs ++ ex_tvs
+    map (substTyWith tyvars inst_tys) arg_tys
+  where
+    tyvars = univ_tvs ++ ex_tvs
 \end{code}
 
 These two functions get the real argument types of the constructor,
@@ -705,6 +689,19 @@ dataConRepArgTys :: DataCon -> [Type]
 dataConRepArgTys dc = dcRepArgTys dc
 \end{code}
 
+The string <package>:<module>.<name> identifying a constructor, which is attached
+to its info table and used by the GHCi debugger and the heap profiler.  We want
+this string to be UTF-8, so we get the bytes directly from the FastStrings.
+
+\begin{code}
+dataConIdentity :: DataCon -> [Word8]
+dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ 
+                  fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
+                  fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
+  where name = dataConName dc
+        mod  = nameModule name
+\end{code}
+
 
 \begin{code}
 isTupleCon :: DataCon -> Bool
@@ -756,7 +753,8 @@ splitProductType_maybe ty
                                        -- and for constructors visible
           -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
           where
-             data_con = head (tyConDataCons tycon)
+             data_con = ASSERT( not (null (tyConDataCons tycon)) ) 
+                        head (tyConDataCons tycon)
        other -> Nothing
 
 splitProductType str ty