Make {-# UNPACK #-} work for type/data family invocations
authorSimon Peyton Jones <simonpj@microsoft.com>
Sun, 23 Dec 2012 15:38:48 +0000 (15:38 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Sun, 23 Dec 2012 15:38:48 +0000 (15:38 +0000)
This fixes most of Trac #3990.  Consider
  data family D a
  data instance D Double = CD Int Int
  data T = T {-# UNPACK #-} !(D Double)
Then we want the (D Double unpacked).

To do this we need to construct a suitable coercion, and it's much
safer to record that coercion in the interface file, lest the in-scope
instances differ somehow.  That in turn means elaborating the HsBang
type to include a coercion.

To do that I moved HsBang from BasicTypes to DataCon, which caused
quite a few minor knock-on changes.

Interface-file format has changed!

Still to do: need to do knot-tying to allow instances to take effect
within the same module.

18 files changed:
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/MkId.lhs
compiler/hsSyn/HsTypes.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/PprTyThing.hs
compiler/prelude/TysWiredIn.lhs
compiler/simplCore/Simplify.lhs
compiler/stranal/DmdAnal.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs

index b5fb018..be6a78f 100644 (file)
@@ -62,9 +62,6 @@ module BasicTypes(
 
         EP(..),
 
-       HsBang(..), isBanged, 
-        StrictnessMark(..), isMarkedStrict,
-
        DefMethSpec(..),
         SwapFlag(..), flipSwap, unSwap,
 
@@ -574,54 +571,6 @@ instance Outputable OccInfo where
 
 %************************************************************************
 %*                                                                     *
-               Strictness indication
-%*                                                                     *
-%************************************************************************
-
-The strictness annotations on types in data type declarations
-e.g.   data T = MkT !Int !(Bool,Bool)
-
-\begin{code}
--------------------------
--- HsBang describes what the *programmer* wrote
--- This info is retained in the DataCon.dcStrictMarks field
-data HsBang = HsNoBang        -- Lazy field
-
-           | HsBang Bool      -- Source-language '!' bang
-                               --  True <=> also an {-# UNPACK #-} pragma
-
-           | HsUnpack         -- Definite commitment: this field is strict and unboxed
-            | HsStrict         -- Definite commitment: this field is strict but not unboxed
-  deriving (Eq, Data, Typeable)
-
-instance Outputable HsBang where
-    ppr HsNoBang       = empty
-    ppr (HsBang True)  = ptext (sLit "{-# UNPACK #-} !")
-    ppr (HsBang False) = char '!'
-    ppr HsUnpack       = ptext (sLit "Unpacked")
-    ppr HsStrict       = ptext (sLit "SrictNotUnpacked")
-
-isBanged :: HsBang -> Bool
-isBanged HsNoBang = False
-isBanged _        = True
-
--------------------------
--- StrictnessMark is internal only, used to indicate strictness 
--- of the DataCon *worker* fields
-data StrictnessMark = MarkedStrict | NotMarkedStrict   
-
-instance Outputable StrictnessMark where
-  ppr MarkedStrict     = ptext (sLit "!")
-  ppr NotMarkedStrict  = empty
-
-isMarkedStrict :: StrictnessMark -> Bool
-isMarkedStrict NotMarkedStrict = False
-isMarkedStrict _               = True   -- All others are strict
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
                Default method specfication
 %*                                                                     *
 %************************************************************************
index 7a58a7b..e55a6e4 100644 (file)
@@ -14,7 +14,7 @@
 
 module DataCon (
         -- * Main data types
-       DataCon, DataConRep(..),
+       DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
        ConTag,
        
        -- ** Type construction
@@ -39,6 +39,7 @@ module DataCon (
        -- ** Predicates on DataCons
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
        isVanillaDataCon, classDataCon, dataConCannotMatch,
+        isBanged, isMarkedStrict, eqHsBang,
 
         -- * Splitting product types
        splitProductType_maybe, splitProductType, 
@@ -54,6 +55,7 @@ import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
+import Coercion
 import Kind
 import Unify
 import TyCon
@@ -436,6 +438,25 @@ data DataConRep
 -- but that makes it less likely that rules will match
 -- when we bring bits of unfoldings together.)
 
+-------------------------
+-- HsBang describes what the *programmer* wrote
+-- This info is retained in the DataCon.dcStrictMarks field
+data HsBang 
+  = HsNoBang          -- Lazy field
+
+  | HsBang Bool      -- Source-language '!' bang
+                     --  True <=> also an {-# UNPACK #-} pragma
+
+  | HsUnpack              -- Definite commitment: this field is strict and unboxed
+       (Maybe Coercion)   --    co :: arg-ty ~ product-ty
+
+  | HsStrict            -- Definite commitment: this field is strict but not unboxed
+  deriving (Data.Data, Data.Typeable)
+
+-------------------------
+-- StrictnessMark is internal only, used to indicate strictness 
+-- of the DataCon *worker* fields
+data StrictnessMark = MarkedStrict | NotMarkedStrict   
 
 -- | Type of the tags associated with each constructor possibility
 type ConTag = Int
@@ -515,6 +536,35 @@ instance Data.Data DataCon where
     toConstr _   = abstractConstr "DataCon"
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "DataCon"
+
+instance Outputable HsBang where
+    ppr HsNoBang             = empty
+    ppr (HsBang True)        = ptext (sLit "{-# UNPACK #-} !")
+    ppr (HsBang False)       = char '!'
+    ppr (HsUnpack Nothing)   = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict             = ptext (sLit "SrictNotUnpacked")
+
+instance Outputable StrictnessMark where
+  ppr MarkedStrict     = ptext (sLit "!")
+  ppr NotMarkedStrict  = empty
+
+
+eqHsBang :: HsBang -> HsBang -> Bool
+eqHsBang HsNoBang             HsNoBang             = True
+eqHsBang HsStrict             HsStrict             = True
+eqHsBang (HsBang b1)          (HsBang b2)          = b1 == b2
+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
+eqHsBang _ _ = False
+
+isBanged :: HsBang -> Bool
+isBanged HsNoBang = False
+isBanged _        = True
+
+isMarkedStrict :: StrictnessMark -> Bool
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict _               = True   -- All others are strict
 \end{code}
 
 
index 516e25a..1037332 100644 (file)
@@ -47,7 +47,8 @@ import TysPrim
 import TysWiredIn
 import PrelRules
 import Type
-import Coercion                ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo )
+import FamInstEnv
+import Coercion
 import TcType
 import MkCore
 import CoreUtils       ( exprType, mkCast )
@@ -55,6 +56,7 @@ import CoreUnfold
 import Literal
 import TyCon
 import Class
+import NameSet
 import VarSet
 import Name
 import PrimOp
@@ -76,7 +78,6 @@ import Outputable
 import FastString
 import ListSetOps
 
-import Data.List        ( unzip4 )
 import Data.Maybe       ( maybeToList )
 \end{code}
 
@@ -366,18 +367,6 @@ dictSelRule val_index n_ty_args _ _ id_unf args
 
 
 \begin{code}
-type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
-  -- Unbox: bind rep vars by decomposing src var
-
-data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
-  -- Box:   build src arg using these rep vars
-
-newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
-                       -- Bind these src-level vars, returning the
-                       -- rep-level vars to bind in the pattern
-\end{code}
-
-\begin{code}
 mkDataConWorkId :: Name -> DataCon -> Id
 mkDataConWorkId wkr_name data_con
   | isNewTyCon tycon
@@ -458,9 +447,28 @@ dataConCPR con
     --         things worse.
 \end{code}
 
+-------------------------------------------------
+--         Data constructor representation
+-- 
+-- This is where we decide how to wrap/unwrap the 
+-- constructor fields
+--
+--------------------------------------------------
+
+
 \begin{code}
-mkDataConRep :: DynFlags -> Name -> DataCon -> UniqSM DataConRep
-mkDataConRep dflags wrap_name data_con
+type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
+  -- Unbox: bind rep vars by decomposing src var
+
+data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
+  -- Box:   build src arg using these rep vars
+
+newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
+                       -- Bind these src-level vars, returning the
+                       -- rep-level vars to bind in the pattern
+
+mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
+mkDataConRep dflags fam_envs wrap_name data_con
   | not wrapper_reqd
   = return NoDataConRep
 
@@ -522,8 +530,9 @@ mkDataConRep dflags wrap_name data_con
             -- Because we are going to apply the eq_spec args manually in the
             -- wrapper
 
-    (wrap_bangs, rep_tys_w_strs, unboxers, boxers)
-       = unzip4 (zipWith (dataConArgRep dflags) all_arg_tys orig_bangs)
+    (wrap_bangs, rep_tys_w_strs, wrappers)
+       = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
+    (unboxers, boxers) = unzip wrappers
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
     wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
@@ -573,50 +582,70 @@ newLocal ty = do { uniq <- getUniqueUs
 -------------------------
 dataConArgRep
    :: DynFlags 
+   -> FamInstEnvs
    -> Type -> HsBang
    -> ( HsBang   -- Like input but with HsUnpackFailed if necy
       , [(Type, StrictnessMark)]   -- Rep types
-      , Unboxer, Boxer)
-
-dataConArgRep _ arg_ty HsNoBang
-  = (HsNoBang, [(arg_ty, NotMarkedStrict)], unitUnboxer, unitBoxer)
-
-dataConArgRep dflags arg_ty (HsBang False)   -- No {-# UNPACK #-} pragma
-  | gopt Opt_OmitInterfacePragmas dflags
-  = strict_but_not_unpacked arg_ty   -- Don't unpack if we aren't optimising; 
-                                     -- rather arbitrarily, we use -fomit-iface-pragmas
-                                     -- as the indication
-
-  | (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
-  ,  gopt Opt_UnboxStrictFields dflags
-  || (gopt Opt_UnboxSmallStrictFields dflags 
-      && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
-  = (HsUnpack, rep_tys, unbox, box)
+      , (Unboxer, Boxer) )
+
+dataConArgRep _ _ arg_ty HsNoBang
+  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
+dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) 
+  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
+          -- Don't unpack if we aren't optimising; 
+          -- rather arbitrarily, we use -fomit-iface-pragmas
+          -- as the indication
+  , let mb_co   = topNormaliseType fam_envs arg_ty
+        arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
+  , isUnpackableType fam_envs arg_ty'
+  , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
+  , user_unpack_prag
+    || gopt Opt_UnboxStrictFields dflags
+    || (gopt Opt_UnboxSmallStrictFields dflags 
+        && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+  = case mb_co of
+      Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
+      Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
 
   | otherwise  -- Record the strict-but-no-unpack decision
   = strict_but_not_unpacked arg_ty
 
-dataConArgRep dflags arg_ty (HsBang True)   -- {-# UNPACK #-} pragma
-  | gopt Opt_OmitInterfacePragmas dflags
-  = strict_but_not_unpacked arg_ty   -- Don't unpack if -fomit-iface-pragmas
+dataConArgRep _ _ arg_ty HsStrict
+  = strict_but_not_unpacked arg_ty
 
-  | (something_happened, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
-  = (if something_happened then HsUnpack else HsStrict
-    , rep_tys, unbox, box)
+dataConArgRep _ _ arg_ty (HsUnpack Nothing)
+  | (rep_tys, wrappers) <- dataConArgUnpack arg_ty
+  = (HsUnpack Nothing, rep_tys, wrappers)
 
-dataConArgRep _ arg_ty HsStrict
-  = strict_but_not_unpacked arg_ty
+dataConArgRep _ _ _ (HsUnpack (Just co))
+  | let co_rep_ty = pSnd (coercionKind co)
+  , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
+  = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
 
-dataConArgRep _ arg_ty HsUnpack
-  | (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
-  = (HsUnpack, rep_tys, unbox, box)
-  | otherwise -- An interface file specified Unpacked, but we couldn't unpack it
-  = pprPanic "dataConArgRep" (ppr arg_ty) 
-strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], Unboxer, Boxer)
+strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
 strict_but_not_unpacked arg_ty
-  = (HsStrict, [(arg_ty, MarkedStrict)], seqUnboxer, unitBoxer)
+  = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
 -------------------------
+wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
+wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty
+  = (unboxer, boxer)
+  where
+    unboxer arg_id = do { rep_id <- newLocal rep_ty
+                        ; (rep_ids, rep_fn) <- unbox_rep rep_id
+                        ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
+                        ; return (rep_ids, Let co_bind . rep_fn) }
+    boxer = Boxer $ \ subst -> 
+            do { (rep_ids, rep_expr) 
+                    <- case box_rep of
+                         UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
+                                       ; return ([rep_id], Var rep_id) }
+                         Boxer boxer -> boxer subst
+               ; let sco = substCo (tvCvSubst subst) co
+               ; return (rep_ids, rep_expr `Cast` mkSymCo sco) }
+
+------------------------
 seqUnboxer :: Unboxer
 seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])
 
@@ -629,56 +658,63 @@ unitBoxer = UnitBox
 -------------------------
 dataConArgUnpack
    :: Type
-   -> (Bool   -- True <=> some unboxing actually happened
-      , [(Type, StrictnessMark)]   -- Rep types
-      , Unboxer, Boxer)
+   ->  ( [(Type, StrictnessMark)]   -- Rep types
+       , (Unboxer, Boxer) )
 
 dataConArgUnpack arg_ty
-  = case splitTyConApp_maybe arg_ty of
-      Just (tc, tc_args) 
-        | not (isRecursiveTyCon tc)    -- Note [Recusive unboxing]
-       , Just con <- tyConSingleDataCon_maybe tc
-        , isVanillaDataCon con
-        -> unbox_tc_app tc tc_args con
-
-      _otherwise -> ( False, [(arg_ty, MarkedStrict)]
-                    , unitUnboxer, unitBoxer )
+  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
+  , Just con <- tyConSingleDataCon_maybe tc
+  , let rep_tys = dataConInstArgTys con tc_args
+  = ASSERT( isVanillaDataCon con )
+    ( rep_tys `zip` dataConRepStrictness con
+    ,( \ arg_id ->
+       do { rep_ids <- mapM newLocal rep_tys
+          ; let unbox_fn body
+                  = Case (Var arg_id) arg_id (exprType body)
+                         [(DataAlt con, rep_ids, body)]
+          ; return (rep_ids, unbox_fn) }
+     , Boxer $ \ subst ->
+       do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys
+          ; return (rep_ids, Var (dataConWorkId con)
+                             `mkTyApps` (substTys subst tc_args)
+                             `mkVarApps` rep_ids ) } ) )
+  | otherwise
+  = pprPanic "dataConArgUnpack" (ppr arg_ty)
+    -- An interface file specified Unpacked, but we couldn't unpack it
+
+isUnpackableType :: FamInstEnvs -> Type -> Bool
+-- True if we can unpack the UNPACK fields of the constructor
+-- without involving the NameSet tycons
+isUnpackableType fam_envs ty
+  | Just (tc, _) <- splitTyConApp_maybe ty
+  , Just con <- tyConSingleDataCon_maybe tc
+  , isVanillaDataCon con
+  = ok_con_args (unitNameSet (getName tc)) con
+  | otherwise
+  = False
   where
-    unbox_tc_app tc tc_args con
-      | isNewTyCon tc
-      , let rep_ty = newTyConInstRhs tc tc_args
-            co     = mkAxInstCo (newTyConCo tc) tc_args  -- arg_ty ~ rep_ty
-      , (yes, rep_tys, unbox_rep, box_rep) <- dataConArgUnpack rep_ty
-      = ( yes, rep_tys
-        , \ arg_id ->
-          do { rep_id <- newLocal rep_ty
-             ; (rep_ids, rep_fn) <- unbox_rep rep_id
-             ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
-             ; return (rep_ids, Let co_bind . rep_fn) }
-        , Boxer $ \ subst -> 
-          do { (rep_ids, rep_expr) 
-                  <- case box_rep of
-                       UnitBox -> do { rep_id <- newLocal (substTy subst rep_ty)
-                                     ; return ([rep_id], Var rep_id) }
-                       Boxer boxer -> boxer subst
-             ; let sco = mkAxInstCo (newTyConCo tc) (substTys subst tc_args)
-             ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } )
-        
-      | otherwise
-      = ( True, rep_tys `zip` dataConRepStrictness con
-        , \ arg_id ->
-          do { rep_ids <- mapM newLocal rep_tys
-             ; let unbox_fn body
-                     = Case (Var arg_id) arg_id (exprType body)
-                            [(DataAlt con, rep_ids, body)]
-             ; return (rep_ids, unbox_fn) }
-        , Boxer $ \ subst ->
-          do { rep_ids <- mapM (newLocal . substTy subst) rep_tys
-             ; return (rep_ids, Var (dataConWorkId con)
-                                       `mkTyApps` (substTys subst tc_args)
-                                       `mkVarApps` rep_ids ) } )
-      where
-        rep_tys = dataConInstArgTys con tc_args
+    ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty
+        where
+          norm_ty = case topNormaliseType fam_envs ty of
+                      Just (_, ty) -> ty
+                      Nothing      -> ty
+    ok_ty tcs ty
+      | Just (tc, _) <- splitTyConApp_maybe ty
+      , let tc_name = getName tc
+      =  not (tc_name `elemNameSet` tcs)
+      && case tyConSingleDataCon_maybe tc of
+            Just con | isVanillaDataCon con
+                    -> ok_con_args (tcs `addOneToNameSet` getName tc) con
+            _ -> True
+      | otherwise 
+      = True
+
+    ok_con_args tcs con
+       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
+
+    no_unpack (HsBang True)   = False
+    no_unpack (HsUnpack {})   = False
+    no_unpack _               = True
 \end{code}
 
 Note [Unpack one-wide fields]
@@ -734,7 +770,7 @@ space for each equality predicate, so it's pretty important!
 \begin{code}
 mk_pred_strict_mark :: PredType -> HsBang
 mk_pred_strict_mark pred 
-  | isEqPred pred = HsUnpack   -- Note [Unpack equality predicates]
+  | isEqPred pred = HsUnpack Nothing   -- Note [Unpack equality predicates]
   | otherwise     = HsNoBang
 \end{code}
 
index ffcc3ba..93d91b1 100644 (file)
@@ -45,6 +45,7 @@ import HsLit
 import NameSet( FreeVars )
 import Name( Name )
 import RdrName( RdrName )
+import DataCon( HsBang(..) )
 import Type
 import HsDoc
 import BasicTypes
index 8226b42..7f612ec 100644 (file)
@@ -748,21 +748,19 @@ instance Binary InlineSpec where
                   2 -> return Inlinable
                   _ -> return NoInline
 
-instance Binary HsBang where
-    put_ bh HsNoBang       = putByte bh 0
-    put_ bh (HsBang False) = putByte bh 1
-    put_ bh (HsBang True)  = putByte bh 2
-    put_ bh HsUnpack       = putByte bh 3
-    put_ bh HsStrict       = putByte bh 4
+instance Binary IfaceBang where
+    put_ bh IfNoBang        = putByte bh 0
+    put_ bh IfStrict        = putByte bh 1
+    put_ bh IfUnpack        = putByte bh 2
+    put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co
 
     get bh = do
             h <- getByte bh
             case h of
-              0 -> do return HsNoBang
-              1 -> do return (HsBang False)
-              2 -> do return (HsBang True)
-              3 -> do return HsUnpack
-              _ -> do return HsStrict
+              0 -> do return IfNoBang
+              1 -> do return IfStrict
+              2 -> do return IfUnpack
+              _ -> do { a <- get bh; return (IfUnpackCo a) }
 
 instance Binary TupleSort where
     put_ bh BoxedTuple      = putByte bh 0
index f1361fa..495c6b9 100644 (file)
@@ -24,7 +24,7 @@ module BuildTyCl (
 #include "HsVersions.h"
 
 import IfaceEnv
-
+import FamInstEnv( FamInstEnvs )
 import DataCon
 import Var
 import VarSet
@@ -134,7 +134,8 @@ mkNewTyConRhs tycon_name tycon con
                                
 
 ------------------------------------------------------
-buildDataCon :: Name -> Bool
+buildDataCon :: FamInstEnvs 
+            -> Name -> Bool
            -> [HsBang] 
            -> [Name]                   -- Field labels
            -> [TyVar] -> [TyVar]       -- Univ and ext 
@@ -148,7 +149,7 @@ buildDataCon :: Name -> Bool
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --     allocating its unique (hence monadic)
-buildDataCon src_name declared_infix arg_stricts field_lbls
+buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
             univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
@@ -166,7 +167,7 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
                                     arg_tys res_ty rep_tycon
                                     stupid_ctxt dc_wrk dc_rep
                 dc_wrk = mkDataConWorkId work_name data_con
-                dc_rep = initUs_ us (mkDataConRep dflags wrap_name data_con)
+                dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
 
        ; return data_con }
 
@@ -252,7 +253,8 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
              arg_tys   = sc_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
                
-       ; dict_con <- buildDataCon datacon_name
+       ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+                                   datacon_name
                                   False        -- Not declared infix
                                   (map (const HsNoBang) args)
                                   [{- No fields -}]
index 2f827ca..b1eb388 100644 (file)
@@ -20,7 +20,7 @@ module IfaceSyn (
         IfaceBinding(..), IfaceConAlt(..),
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
-        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
+        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceBang(..),
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -149,9 +149,12 @@ data IfaceConDecl
         ifConCtxt    :: IfaceContext,           -- Non-stupid context
         ifConArgTys  :: [IfaceType],            -- Arg types
         ifConFields  :: [OccName],              -- ...ditto... (field labels)
-        ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
+        ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
                                                 -- or 1-1 corresp with arg tys
 
+data IfaceBang
+  = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
+
 data IfaceClsInst
   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
@@ -572,8 +575,10 @@ pprIfaceConDecl tc
          ppUnless (null fields) $
             nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
-    ppr_bang HsNoBang = char '_'        -- Want to see these
-    ppr_bang bang     = ppr bang
+    ppr_bang IfNoBang = char '_'        -- Want to see these
+    ppr_bang IfStrict = char '!'
+    ppr_bang IfUnpack = ptext (sLit "!!")
+    ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceType co
 
     main_payload = ppr name <+> dcolon <+>
                    pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
index 217dad3..50c775f 100644 (file)
@@ -1505,7 +1505,7 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
                     ifConFields  = map getOccName 
                                        (dataConFieldLabels data_con),
-                    ifConStricts = dataConRepBangs data_con }
+                    ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1516,6 +1516,12 @@ tyConToIfaceDecl env tycon
           to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty) 
                             | (tv,ty) <- spec]
 
+toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
+toIfaceBang _    HsNoBang            = IfNoBang
+toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
+toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
+toIfaceBang _   HsStrict             = IfStrict
+toIfaceBang _   (HsBang {})          = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
 classToIfaceDecl env clas
index 652eb0a..3da34c9 100644 (file)
@@ -566,7 +566,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons
                          ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                          ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                          ifConArgTys = args, ifConFields = field_lbls,
-                         ifConStricts = stricts})
+                         ifConStricts = if_stricts})
      = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
         { name  <- lookupIfaceTop occ
@@ -583,11 +583,14 @@ tcIfaceDataCons tycon_name tycon _ if_cons
                 ; return (eq_spec, theta, arg_tys) }
         ; lbl_names <- mapM lookupIfaceTop field_lbls
 
+        ; stricts <- mapM tc_strict if_stricts
+
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon 
                                 (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
 
-        ; buildDataCon name is_infix
+        ; buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
+                       name is_infix
                        stricts lbl_names
                        univ_tyvars ex_tyvars 
                        eq_spec theta 
@@ -595,6 +598,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons
         }
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
+    tc_strict IfNoBang = return HsNoBang
+    tc_strict IfStrict = return HsStrict
+    tc_strict IfUnpack = return (HsUnpack Nothing)
+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
+                                      ; return (HsUnpack (Just co)) }
+
 tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
 tcIfaceEqSpec spec
   = mapM do_item spec
index 81d8e50..4447ad5 100644 (file)
@@ -29,7 +29,6 @@ import GHC ( TyThing(..) )
 import DataCon
 import Id
 import TyCon
-import BasicTypes
 import Coercion( pprCoAxiom )
 import HscTypes( tyThingParent_maybe )
 import TcType
@@ -219,7 +218,7 @@ pprDataConDecl pefas ss gadt_style dataCon
     user_ify :: HsBang -> HsBang
     user_ify bang | opt_PprStyle_Debug = bang
     user_ify HsStrict                  = HsBang False
-    user_ify HsUnpack                  = HsBang True
+    user_ify (HsUnpack {})             = HsBang True
     user_ify bang                      = bang
 
     maybe_show_label (lbl,bty)
index 942f102..d94de11 100644 (file)
@@ -96,7 +96,7 @@ import TypeRep
 import RdrName
 import Name
 import BasicTypes       ( TupleSort(..), tupleSortBoxity,
-                          Arity, RecFlag(..), Boxity(..), HsBang(..) )
+                          Arity, RecFlag(..), Boxity(..) )
 import ForeignCall
 import Unique           ( incrUnique, mkTupleTyConUnique,
                          mkTupleDataConUnique, mkPArrDataConUnique )
index 1c50c6b..c8e8956 100644 (file)
@@ -23,7 +23,7 @@ import Name             ( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType )
-import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness, isMarkedStrict )
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, StrictSig(..), dmdTypeDepth )
@@ -33,7 +33,7 @@ import CoreUtils
 import qualified CoreSubst
 import CoreArity
 import Rules            ( lookupRule, getRules )
-import BasicTypes       ( isMarkedStrict, Arity )
+import BasicTypes       ( Arity )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils       ( foldlM, mapAccumLM, liftIO )
index a8ee825..0ecefa7 100644 (file)
@@ -27,7 +27,7 @@ import PprCore
 import Coercion                ( isCoVarType )
 import CoreUtils       ( exprIsHNF, exprIsTrivial )
 import CoreArity       ( exprArity )
-import DataCon         ( dataConTyCon, dataConRepStrictness )
+import DataCon         ( dataConTyCon, dataConRepStrictness, isMarkedStrict )
 import TyCon           ( isProductTyCon, isRecursiveTyCon )
 import Id              ( Id, idType, idInlineActivation,
                          isDataConWorkId, isGlobalId, idArity,
@@ -45,7 +45,7 @@ import Type           ( isUnLiftedType, eqType, tyConAppTyCon_maybe )
 import Coercion         ( coercionKind )
 import Util
 import BasicTypes      ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
-                         RecFlag(..), isRec, isMarkedStrict )
+                         RecFlag(..), isRec )
 import Maybes          ( orElse, expectJust )
 import Outputable
 import Pair
index 22faed6..3489669 100644 (file)
@@ -801,7 +801,7 @@ checkBootTyCon tc1 tc2
     eqCon c1 c2
       =  dataConName c1 == dataConName c2
       && dataConIsInfix c1 == dataConIsInfix c2
-      && dataConStrictMarks c1 == dataConStrictMarks c2
+      && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
       && dataConFieldLabels c1 == dataConFieldLabels c2
       && eqType (dataConUserType c1) (dataConUserType c2)
 
index d5acf6c..e0c35d1 100644 (file)
@@ -1479,10 +1479,12 @@ reifyFixity name
       conv_dir BasicTypes.InfixL = TH.InfixL
       conv_dir BasicTypes.InfixN = TH.InfixN
 
-reifyStrict :: BasicTypes.HsBang -> TH.Strict
-reifyStrict bang | bang == HsUnpack = TH.Unpacked
-                 | isBanged bang    = TH.IsStrict
-                 | otherwise        = TH.NotStrict
+reifyStrict :: DataCon.HsBang -> TH.Strict
+reifyStrict HsNoBang        = TH.NotStrict
+reifyStrict (HsBang False)  = TH.Unpacked
+reifyStrict (HsBang True)   = TH.Unpacked
+reifyStrict HsStrict        = TH.IsStrict
+reifyStrict (HsUnpack {})   = TH.Unpacked
 
 ------------------------------
 noTH :: LitString -> SDoc -> TcM a
index 46a9445..f3b8ba3 100644 (file)
@@ -38,6 +38,7 @@ import TcHsType
 import TcMType
 import TcType
 import TysWiredIn( unitTy )
+import FamInst
 import Type
 import Kind
 import Class
@@ -1022,7 +1023,8 @@ tcConDecl new_or_data rep_tycon res_tmpl  -- Data types
                 = rejigConRes res_tmpl qtkvs res_ty
 
        ; traceTc "tcConDecl 3" (ppr name)
-       ; buildDataCon (unLoc name) is_infix
+       ; fam_envs <- tcGetFamInstEnvs 
+       ; buildDataCon fam_envs (unLoc name) is_infix
                      stricts field_lbls
                      univ_tvs ex_tvs eq_preds ctxt arg_tys
                      res_ty' rep_tycon
@@ -1322,7 +1324,7 @@ checkValidDataCon dflags existential_ok tc con
     ctxt = ConArgCtxt (dataConName con) 
     check_bang (HsBang want_unpack, rep_bang, n) 
       | want_unpack
-      , case rep_bang of { HsUnpack -> False; _ -> True }
+      , case rep_bang of { HsUnpack {} -> False; _ -> True }
       , not (gopt Opt_OmitInterfacePragmas dflags)  
            -- If not optimising, se don't unpack, so don't complain!
            -- See MkId.dataConArgRep, the (HsBang True) case
index 49997f8..a733d35 100644 (file)
@@ -12,6 +12,7 @@ import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Generic.Description
 import Vectorise.Utils
+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
 
 import BasicTypes
 import BuildTyCl
@@ -69,8 +70,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
  = do let tvs   = tyConTyVars vect_tc
       dc_name   <- mkLocalisedName mkPDataDataConOcc orig_name
       comp_tys  <- mkSumTys repr_sel_ty mkPDataType repr
-
-      liftDs $ buildDataCon dc_name
+      fam_envs  <- readGEnv global_fam_inst_env
+      liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
                             (map (const HsNoBang) comp_tys)
                             []                     -- no field labels
@@ -108,8 +109,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
       dc_name        <- mkLocalisedName mkPDatasDataConOcc orig_name
 
       comp_tys  <- mkSumTys repr_sels_ty mkPDatasType repr
-
-      liftDs $ buildDataCon dc_name
+      fam_envs <- readGEnv global_fam_inst_env
+      liftDs $ buildDataCon fam_envs dc_name
                             False                  -- not infix
                             (map (const HsNoBang) comp_tys)
                             []                     -- no field labels
index 05b7824..d1c5ca5 100644 (file)
@@ -5,6 +5,7 @@ module Vectorise.Type.TyConDecl (
 
 import Vectorise.Type.Type
 import Vectorise.Monad
+import Vectorise.Env( GlobalEnv( global_fam_inst_env ) )
 import BuildTyCl
 import Class
 import Type
@@ -169,7 +170,8 @@ vectDataCon dc
        ; tycon'  <- vectTyCon tycon
        ; arg_tys <- mapM vectType rep_arg_tys
        ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
-       ; liftDs $ buildDataCon
+       ; fam_envs  <- readGEnv global_fam_inst_env
+       ; liftDs $ buildDataCon fam_envs
                     name'
                     (dataConIsInfix dc)            -- infix if the original is
                     (dataConStrictMarks dc)        -- strictness as original constructor