[project @ 2001-11-26 09:20:25 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 b5a093e..efefb63 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -25,7 +25,7 @@ module DataCon (
 import {-# SOURCE #-} Subst( substTyWith )
 import {-# SOURCE #-} PprType( pprType )
 
-import Type            ( Type, TauType, ThetaType, 
+import Type            ( Type, ThetaType, 
                          mkForAllTys, mkFunTys, mkTyConApp,
                          mkTyVarTys, splitTyConApp_maybe, repType, 
                          mkPredTys, isStrictType
@@ -37,13 +37,12 @@ import Name         ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )
 import FieldLabel      ( FieldLabel )
 import BasicTypes      ( Arity, StrictnessMark(..) )
-import NewDemand       ( Demand, lazyDmd, seqDmd )
 import Outputable
 import Unique          ( Unique, Uniquable(..) )
 import CmdLineOpts     ( opt_UnboxStrictFields )
 import Maybe
 import ListSetOps      ( assoc )
-import Util            ( zipEqual, zipWithEqual )
+import Util            ( zipEqual, zipWithEqual, equalLength )
 \end{code}
 
 
@@ -114,7 +113,7 @@ data DataCon
        dcRepArgTys :: [Type],          -- Final, representation argument types, after unboxing and flattening,
                                        -- and including existential dictionaries
 
-       dcRepStrictness :: [Demand],    -- One for each representation argument 
+       dcRepStrictness :: [StrictnessMark],    -- One for each representation argument 
 
        dcTyCon  :: TyCon,              -- Result tycon
 
@@ -209,7 +208,7 @@ mkDataCon :: Name
          -> [StrictnessMark] -> [FieldLabel]
          -> [TyVar] -> ThetaType
          -> [TyVar] -> ThetaType
-         -> [TauType] -> TyCon
+         -> [Type] -> TyCon
          -> Id -> Id
          -> DataCon
   -- Can get the tag from the TyCon
@@ -217,7 +216,7 @@ mkDataCon :: Name
 mkDataCon name arg_stricts fields
          tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
          work_id wrap_id
-  = ASSERT(length arg_stricts == length orig_arg_tys)
+  = ASSERT(equalLength arg_stricts orig_arg_tys)
        -- The 'stricts' passed to mkDataCon are simply those for the
        -- source-language arguments.  We add extra ones for the
        -- dictionary arguments right here.
@@ -228,7 +227,7 @@ mkDataCon name arg_stricts fields
                  dcOrigArgTys = orig_arg_tys,
                  dcRepArgTys = rep_arg_tys,
                  dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
-                 dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands,
+                 dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts,
                  dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
                  dcId = work_id, dcWrapId = wrap_id}
 
@@ -239,13 +238,10 @@ mkDataCon name arg_stricts fields
     real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
                   zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) 
                                orig_arg_tys arg_stricts 
+    real_arg_tys = ex_dict_tys ++ orig_arg_tys
 
        -- Representation arguments and demands
-    (rep_arg_demands, rep_arg_tys) 
-       = unzip $ concat $ 
-         zipWithEqual "mkDataCon2" unbox_strict_arg_ty 
-                      real_stricts 
-                      (ex_dict_tys ++ orig_arg_tys)
+    (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys (tyvars ++ ex_tyvars)
@@ -300,14 +296,14 @@ dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
 
 isNullaryDataCon con  = dataConRepArity con == 0
 
-dataConRepStrictness :: DataCon -> [Demand]
+dataConRepStrictness :: DataCon -> [StrictnessMark]
        -- Give the demands on the arguments of a
        -- Core constructor application (Con dc args)
 dataConRepStrictness dc = dcRepStrictness dc
 
 dataConSig :: DataCon -> ([TyVar], ThetaType,
                          [TyVar], ThetaType,
-                         [TauType], TyCon)
+                         [Type], TyCon)
 
 dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
                     dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
@@ -349,7 +345,7 @@ after any flattening has been done.
 dataConOrigArgTys :: DataCon -> [Type]
 dataConOrigArgTys dc = dcOrigArgTys dc
 
-dataConRepArgTys :: DataCon -> [TauType]
+dataConRepArgTys :: DataCon -> [Type]
 dataConRepArgTys dc = dcRepArgTys dc
 \end{code}
 
@@ -442,15 +438,18 @@ chooseBoxingStrategy tycon arg_ty strict
                                Nothing -> False
                                Just (arg_tycon, _) -> isProductTyCon arg_tycon
 
-unbox_strict_arg_ty 
-       :: StrictnessMark       -- After strategy choice; can't be MarkedUserStrict
-       -> Type                 -- Source argument type
-       -> [(Demand,Type)]      -- Representation argument types and demamds
+computeRep :: [StrictnessMark]         -- Original arg strictness
+                                       --   [after strategy choice; can't be MarkedUserStrict]
+          -> [Type]                    -- and types
+          -> ([StrictnessMark],        -- Representation arg strictness
+              [Type])                  -- And type
 
-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
+computeRep stricts tys
+  = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
   where
-    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
+    unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
+    unbox MarkedStrict    ty = [(MarkedStrict,    ty)]
+    unbox MarkedUnboxed   ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
+                            where
+                              (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty)
 \end{code}