[project @ 2002-03-14 15:27:15 by simonpj]

[ghc-hetmet.git] / ghc / compiler / types / Generics.lhs

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index e8d26d5..ca05c39 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -15,12 +15,13 @@ import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
 import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
 
-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
+import TyCon            ( TyCon, tyConTyVars, tyConDataCons_maybe, 
                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
-import Name            ( Name, mkSysLocalName )
+import Name            ( Name, mkSystemName )
 import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 
                          mkConApp, Alt, mkTyApps, mkVarApps )
+import CoreUtils       ( exprArity )
 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
@@ -31,9 +32,10 @@ import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
-import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo )
+import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
+import Maybe           ( isNothing )
 import SrcLoc          ( builtinSrcLoc )
 import Unique          ( mkBuiltinUnique )
 import Util             ( takeList )
@@ -237,8 +239,8 @@ mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
 -- for the fromT and toT conversion functions.
 
 mkTyConGenInfo tycon [from_name, to_name]
-  | null datacons      -- Abstractly imported types don't have
-  = Nothing            -- to/from operations, (and should not need them)
+  | isNothing maybe_datacons   -- Abstractly imported types don't have
+  = Nothing                    -- to/from operations, (and should not need them)
 
        -- If any of the constructor has an unboxed type as argument,
        -- then we can't build the embedding-projection pair, because
@@ -253,13 +255,20 @@ mkTyConGenInfo tycon [from_name, to_name]
   = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
               toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
   where
-    tyvars      = tyConTyVars tycon                    -- [a, b, c]
-    datacons    = tyConDataConsIfAvailable tycon       -- [C, D]
-    tycon_ty    = mkTyConApp tycon tyvar_tys           -- T a b c
-    tyvar_tys    = mkTyVarTys tyvars
+    maybe_datacons = tyConDataCons_maybe tycon
+    Just datacons  = maybe_datacons            -- [C, D]
+
+    tyvars        = tyConTyVars tycon          -- [a, b, c]
+    tycon_ty      = mkTyConApp tycon tyvar_tys -- T a b c
+    tyvar_tys      = mkTyVarTys tyvars
 
     from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+                                     `setArityInfo`     exprArity from_fn
     to_id_info   = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+                                     `setArityInfo`     exprArity to_fn
+       -- It's important to set the arity info, so that
+       -- the calling convention (gotten from arity) 
+       -- matches reality.
 
     from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
     to_ty   = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
@@ -526,7 +535,7 @@ bimapTuple eps
 
 -------------------
 genericNames :: [Name]
-genericNames = [mkSysLocalName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
+genericNames = [mkSystemName (mkBuiltinUnique i) (_PK_ ('g' : show i)) | i <- [1..]]
 (g1:g2:g3:_) = genericNames
 
 mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))