[project @ 2003-07-22 14:24:57 by simonmar]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsCore.lhs

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 1174278..27b6ae6 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -31,7 +31,7 @@ import HsTypes                ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
                        )
 
 -- others:
-import Id              ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
+import Id              ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
 import Var             ( varType, isId )
 import IdInfo          ( InlinePragInfo )
 import Name            ( Name, NamedThing(..), eqNameByOcc )
@@ -76,6 +76,7 @@ data UfNote name = UfSCC CostCentre
                 | UfCoerce (HsType name)
                 | UfInlineCall
                 | UfInlineMe
+                 | UfCoreNote String
 
 type UfAlt name = (UfConAlt name, [name], UfExpr name)
 
@@ -124,6 +125,7 @@ toUfNote (SCC cc)   = UfSCC cc
 toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
 toUfNote InlineCall    = UfInlineCall
 toUfNote InlineMe      = UfInlineMe
+toUfNote (CoreNote s)   = UfCoreNote s
 
 ---------------------
 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
@@ -153,7 +155,7 @@ toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
 ---------------------
 toUfApp (App f a) as = toUfApp f (a:as)
 toUfApp (Var v) as
-  = case isDataConId_maybe v of
+  = case isDataConWorkId_maybe v of
        -- We convert the *worker* for tuples into UfTuples
        Just dc |  isTupleTyCon tc && saturated 
                -> UfTuple (mk_hs_tup_con tc dc) tup_args
@@ -252,6 +254,7 @@ instance Outputable name => Outputable (UfNote name) where
     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
     ppr UfInlineCall  = ptext SLIT("__inline_call")
     ppr UfInlineMe    = ptext SLIT("__inline_me")
+    ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 
 instance Outputable name => Outputable (UfConAlt name) where
     ppr UfDefault         = text "__DEFAULT"
@@ -315,7 +318,7 @@ eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
 -- differences when comparing interface files
 eq_ufVar env n1 n2 = case lookupFM env n1 of
                       Just n1 -> check n1
-                      Nothing -> check n2
+                      Nothing -> check n1
    where
        check n1 = eqNameByOcc (getName n1) (getName n2)
 
@@ -353,6 +356,7 @@ eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
     eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
     eq_ufNote UfInlineCall  UfInlineCall  = True
     eq_ufNote UfInlineMe    UfInlineMe    = True
+    eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
     eq_ufNote _                    _             = False
 
 eq_ufExpr env _ _ = False