X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=47b8c31f3c2900977f27614a7530793a7746cdb4;hp=126113168361bd1ab9de8ec9eebfaf2eef7c59d3;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=60789c09584c8a12fa27289605221942fb05764d

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 1261131..47b8c31 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -925,11 +925,11 @@ consUseH98Syntax _                                             = True
 -------------------
 tcConArg :: Bool		-- True <=> -funbox-strict_fields
 	   -> LHsType Name
-	   -> TcM (TcType, StrictnessMark)
+	   -> TcM (TcType, HsBang)
 tcConArg unbox_strict bty
   = do  { arg_ty <- tcHsBangType bty
 	; let bang = getBangStrictness bty
-        ; strict_mark <- chooseBoxingStrategy unbox_strict arg_ty bang
+        ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
 	; return (arg_ty, strict_mark) }
 
 -- We attempt to unbox/unpack a strict field when either:
@@ -938,31 +938,47 @@ tcConArg unbox_strict bty
 --
 -- We have turned off unboxing of newtypes because coercions make unboxing 
 -- and reboxing more complicated
-chooseBoxingStrategy :: Bool -> TcType -> HsBang -> TcM StrictnessMark
+chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
 chooseBoxingStrategy unbox_strict_fields arg_ty bang
   = case bang of
-	HsNoBang			-> return NotMarkedStrict
-	HsUnbox  | can_unbox arg_ty	-> return MarkedUnboxed
-                 | otherwise            -> do { addWarnTc cant_unbox_msg
-                                              ; return MarkedStrict }
-	HsStrict | unbox_strict_fields 
-                 , can_unbox arg_ty 	-> return MarkedUnboxed
-	_                               -> return MarkedStrict
+	HsNoBang			-> HsNoBang
+	HsUnpack                        -> can_unbox HsUnpackFailed arg_ty
+	HsStrict | unbox_strict_fields  -> can_unbox HsStrict       arg_ty
+		 | otherwise            -> HsStrict
+	HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
+		       	  -- Source code never has shtes
   where
-    -- we can unbox if the type is a chain of newtypes with a product tycon
-    -- at the end
-    can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
-		   Nothing 	       		-> False
-		   Just (arg_tycon, tycon_args) -> 
-                       not (isRecursiveTyCon arg_tycon) &&	-- Note [Recusive unboxing]
-		       isProductTyCon arg_tycon &&
-                       (if isNewTyCon arg_tycon then 
-                            can_unbox (newTyConInstRhs arg_tycon tycon_args)
-                        else True)
-
-    cant_unbox_msg = ptext (sLit "Ignoring unusable UNPACK pragma")
+    can_unbox :: HsBang -> TcType -> HsBang
+    -- Returns   HsUnpack  if we can unpack arg_ty
+    -- 		 fail_bang if we know what arg_ty is but we can't unpack it
+    -- 		 HsStrict  if it's abstract, so we don't know whether or not we can unbox it
+    can_unbox fail_bang arg_ty 
+       = case splitTyConApp_maybe arg_ty of
+	    Nothing -> fail_bang
+
+	    Just (arg_tycon, tycon_args) 
+              | isAbstractTyCon arg_tycon -> HsStrict	
+                      -- See Note [Don't complain about UNPACK on abstract TyCons]
+              | not (isRecursiveTyCon arg_tycon) 	-- Note [Recusive unboxing]
+	      , isProductTyCon arg_tycon 
+	      	    -- We can unbox if the type is a chain of newtypes 
+		    -- with a product tycon at the end
+              -> if isNewTyCon arg_tycon 
+                 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
+                 else HsUnpack
+
+              | otherwise -> fail_bang
 \end{code}
 
+Note [Don't complain about UNPACK on abstract TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are going to complain about UnpackFailed, but if we say
+   data T = MkT {-# UNPACK #-} !Wobble
+and Wobble is a newtype imported from a module that was compiled 
+without optimisation, we don't want to complain. Because it might
+be fine when optimsation is on.  I think this happens when Haddock
+is working over (say) GHC souce files.
+
 Note [Recursive unboxing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Be careful not to try to unbox this!
@@ -1110,9 +1126,15 @@ checkValidDataCon tc con
 		-- Reason: it's really the argument of an equality constraint
 	; checkValidType ctxt (dataConUserType con)
 	; when (isNewTyCon tc) (checkNewDataCon con)
+        ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
+    check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
+    check_bang _                   = return ()
+
+    cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
+                           , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
 
 -------------------------------
 checkNewDataCon :: DataCon -> TcM ()
@@ -1124,7 +1146,7 @@ checkNewDataCon con
 		-- Return type is (T a b c)
 	; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
 		-- No existentials
-	; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) 
+	; checkTc (not (any isBanged (dataConStrictMarks con))) 
 		  (newtypeStrictError con)
 		-- No strictness
     }