[project @ 2001-05-16 12:49:59 by simonmar]

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

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 443d75f..dae32df 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -31,6 +31,7 @@ module MkId (
 #include "HsVersions.h"
 
 
+import BasicTypes      ( Arity )
 import TysPrim         ( openAlphaTyVars, alphaTyVar, alphaTy, 
                          intPrimTy, realWorldStatePrimTy
                        )
@@ -38,7 +39,7 @@ import TysWiredIn     ( charTy, mkListTy )
 import PrelNames       ( pREL_ERR, pREL_GHC )
 import PrelRules       ( primOpRule )
 import Rules           ( addRule )
-import Type            ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
+import Type            ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys,
                          mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, 
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
                          splitFunTys, splitForAllTys, mkPredTy
@@ -118,7 +119,7 @@ wiredInIds
     , rEC_CON_ERROR_ID
     , rEC_UPD_ERROR_ID
 
-       -- These two can't be defined in Haskell
+       -- These three can't be defined in Haskell
     , realWorldPrimId
     , unsafeCoerceId
     , getTagId
@@ -151,10 +152,22 @@ mkDataConId work_name data_con
     tycon = dataConTyCon data_con
     cpr_info | isProductTyCon tycon && 
               isDataTyCon tycon    &&
-              arity > 0                = ReturnsCPR
+              arity > 0            &&
+              arity <= mAX_CPR_SIZE    = ReturnsCPR
             | otherwise                = NoCPRInfo
        -- ReturnsCPR is only true for products that are real data types;
        -- that is, not unboxed tuples or newtypes
+
+mAX_CPR_SIZE :: Arity
+mAX_CPR_SIZE = 10
+-- We do not treat very big tuples as CPR-ish:
+--     a) for a start we get into trouble because there aren't 
+--        "enough" unboxed tuple types (a tiresome restriction, 
+--        but hard to fix), 
+--     b) more importantly, big unboxed tuples get returned mainly
+--        on the stack, and are often then allocated in the heap
+--        by the caller.  So doing CPR for them may in fact make
+--        things worse.
 \end{code}
 
 The wrapper for a constructor is an ordinary top-level binding that evaluates
@@ -207,6 +220,7 @@ mkDataConWrapId data_con
                -- The Cpr info can be important inside INLINE rhss, where the
                -- wrapper constructor isn't inlined
           `setCgArity`         arity
+               -- The NoCaf-ness is set by noCafNoTyGenIdInfo
           `setArityInfo`       exactArity arity
                -- It's important to specify the arity, so that partial
                -- applications are treated as values
@@ -256,8 +270,8 @@ mkDataConWrapId data_con
     (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
     all_tyvars   = tyvars ++ ex_tyvars
 
-    dict_tys     = mkDictTys theta
-    ex_dict_tys  = mkDictTys ex_theta
+    dict_tys     = mkPredTys theta
+    ex_dict_tys  = mkPredTys ex_theta
     all_arg_tys  = dict_tys ++ ex_dict_tys ++ orig_arg_tys
     result_ty    = mkTyConApp tycon (mkTyVarTys tyvars)
 
@@ -360,8 +374,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
 
     tycon_theta        = tyConTheta tycon      -- The context on the data decl
                                        --   eg data (Eq a, Ord b) => T a b = ...
-    dict_tys  = [mkDictTy cls tys | (cls, tys) <- tycon_theta, 
-                                   needed_dict (cls, tys)]
+    dict_tys  = [mkPredTy pred | pred <- tycon_theta, 
+                                needed_dict pred]
     needed_dict pred = or [ pred `elem` (dataConTheta dc) 
                          | (DataAlt dc, _, _) <- the_alts]
     n_dict_tys = length dict_tys
@@ -442,9 +456,12 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
                    body              = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
                    strict_marks      = dataConStrictMarks data_con
                    (expr, real_args) = rebuildConArgs data_con arg_ids strict_marks body
-                                                      (length arg_ids + 1)
+                                                      unpack_base
        where
             arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
+
+           unpack_base = field_base + length arg_ids
+
                                -- arity+1 avoids all shadowing
            maybe_the_arg_id  = assocMaybe (field_lbls `zip` arg_ids) field_label
            field_lbls        = dataConFieldLabels data_con
@@ -573,7 +590,8 @@ mkPrimOpId prim_op
           `setArityInfo`       exactArity arity
           `setStrictnessInfo`  strict_info
 
-    rules = addRule emptyCoreRules id (primOpRule prim_op)
+    rules = maybe emptyCoreRules (addRule emptyCoreRules id)
+               (primOpRule prim_op)
 
 
 -- For each ccall we manufacture a separate CCallOpId, giving it
@@ -632,9 +650,6 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
   = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
   where
     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
-    info     = noCafNoTyGenIdInfo
-             -- Type is wired-in (see comment at TcClassDcl.tcClassSig),
-             -- so do not generalise it
 
 {-  1 dec 99: disable the Mark Jones optimisation for the sake
     of compatibility with Hugs.