[project @ 2001-10-25 09:57:52 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 1fe3575..8afbc4b 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -21,6 +21,7 @@ import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable,
 import Name            ( Name, mkSysLocalName )
 import CoreSyn          ( mkLams, Expr(..), CoreExpr, AltCon(..), 
                          mkConApp, Alt, mkTyApps, mkVarApps )
+import CoreUtils       ( exprArity )
 import BasicTypes       ( EP(..), Boxity(..) )
 import Var              ( TyVar )
 import VarSet          ( varSetElems )
@@ -31,11 +32,12 @@ import TysWiredIn       ( genericTyCons,
                          genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
                          inlDataCon, crossTyCon, crossDataCon
                        )
-import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo )
+import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
-import Unique          ( mkBuiltinUnique )
 import SrcLoc          ( builtinSrcLoc )
+import Unique          ( mkBuiltinUnique )
+import Util             ( takeList )
 import Outputable 
 
 #include "HsVersions.h"
@@ -258,7 +260,12 @@ mkTyConGenInfo tycon [from_name, to_name]
     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)
@@ -517,7 +524,7 @@ bimapTuple eps
   = EP { fromEP = mk_hs_lam [tuple_pat] from_body,
         toEP   = mk_hs_lam [tuple_pat] to_body }
   where
-    names      = take (length eps) genericNames
+    names      = takeList eps genericNames
     tuple_pat  = TuplePatIn (map VarPatIn names) Boxed
     eps_w_names = eps `zip` names
     to_body     = ExplicitTuple [toEP   ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed