[project @ 2001-08-28 10:06:29 by simonpj]

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

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 195c192..a925c1b 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -22,26 +22,26 @@ module DataCon (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
+import {-# SOURCE #-} Subst( substTyWith )
+import {-# SOURCE #-} PprType( pprType )
 
 import CmdLineOpts     ( opt_DictsStrict )
 import Type            ( Type, TauType, ThetaType, 
                          mkForAllTys, mkFunTys, mkTyConApp,
-                         mkTyVarTys, splitTyConApp_maybe, repType
+                         mkTyVarTys, splitTyConApp_maybe, repType, 
+                         mkPredTys, isStrictType
                        )
-import TcType          ( isStrictPred, mkPredTys )
 import TyCon           ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )
 import FieldLabel      ( FieldLabel )
-import BasicTypes      ( Arity )
-import Demand          ( Demand, StrictnessMark(..), wwStrict, wwLazy )
+import BasicTypes      ( Arity, StrictnessMark(..) )
+import NewDemand       ( Demand, lazyDmd, seqDmd )
 import Outputable
 import Unique          ( Unique, Uniquable(..) )
 import CmdLineOpts     ( opt_UnboxStrictFields )
-import PprType         ()      -- Instances
 import Maybe
 import ListSetOps      ( assoc )
 import Util            ( zipEqual, zipWithEqual )
@@ -236,7 +236,8 @@ mkDataCon name arg_stricts fields
        -- Strictness marks for source-args
        --      *after unboxing choices*, 
        -- but  *including existential dictionaries*
-    real_stricts = (map mk_dict_strict_mark ex_theta) ++
+    ex_dict_tys  = mkPredTys ex_theta
+    real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
                   zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) 
                                orig_arg_tys arg_stricts 
 
@@ -245,7 +246,7 @@ mkDataCon name arg_stricts fields
        = unzip $ concat $ 
          zipWithEqual "mkDataCon2" unbox_strict_arg_ty 
                       real_stricts 
-                      (mkPredTys ex_theta ++ orig_arg_tys)
+                      (ex_dict_tys ++ orig_arg_tys)
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys (tyvars ++ ex_tyvars)
@@ -254,8 +255,8 @@ mkDataCon name arg_stricts fields
 
     result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
 
-mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
-                        | otherwise         = NotMarkedStrict
+mk_dict_strict_mark ty | isStrictType ty = MarkedStrict
+                      | otherwise       = NotMarkedStrict
 \end{code}
 
 \begin{code}
@@ -324,7 +325,7 @@ dataConArgTys :: DataCon
 
 dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
                       dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
 
 dataConTheta :: DataCon -> ThetaType
 dataConTheta dc = dcTheta dc
@@ -334,7 +335,7 @@ dataConTheta dc = dcTheta dc
 dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
 dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
                       dcExTyVars = ex_tyvars}) inst_tys
- = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
+ = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
 \end{code}
 
 These two functions get the real argument types of the constructor,
@@ -409,7 +410,7 @@ splitProductType_maybe ty
 splitProductType str ty
   = case splitProductType_maybe ty of
        Just stuff -> stuff
-       Nothing    -> pprPanic (str ++ ": not a product") (ppr ty)
+       Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
 
 -- We attempt to unbox/unpack a strict field when either:
 --   (i)  The tycon is imported, and the field is marked '! !', or
@@ -443,15 +444,14 @@ chooseBoxingStrategy tycon arg_ty strict
                                Just (arg_tycon, _) -> isProductTyCon arg_tycon
 
 unbox_strict_arg_ty 
-       :: StrictnessMark       -- After strategy choice; can't be MkaredUserStrict
+       :: StrictnessMark       -- After strategy choice; can't be MarkedUserStrict
        -> Type                 -- Source argument type
        -> [(Demand,Type)]      -- Representation argument types and demamds
 
-unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy,   ty)]
-unbox_strict_arg_ty MarkedStrict    ty = [(wwStrict, ty)]
+unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)]
+unbox_strict_arg_ty MarkedStrict    ty = [(seqDmd,  ty)]
 unbox_strict_arg_ty MarkedUnboxed   ty 
   = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
   where
-    (_, _, arg_data_con, arg_tys)
-        = splitProductType "unbox_strict_arg_ty" (repType ty)
+    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
 \end{code}