X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=9f11ade302005b8fe54f4e16980b8f5b2c6bcf0f;hb=b9117bfdfc1c22ed594f33cdae5bdda5813b78a3;hp=638f692ac3458e2f9030739401753f569139f8a4;hpb=b10d7d079ec9c3fc22d4700fe484dd297bddb805;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 638f692..9f11ade 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -542,8 +542,9 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl)
   --          for the selector Id, but the poly_id is something like $cop
   = addErrCtxt (spec_ctxt prag) $
     do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
-        ; checkTc (isOverloadedTy poly_ty)
-                  (ptext (sLit "Discarding pragma for non-overloaded function") <+> quotes (ppr poly_id))
+        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
+                 (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
+		  -- Note [SPECIALISE pragmas]
         ; wrap <- tcSubType origin skol_info (idType poly_id) spec_ty
         ; return (SpecPrag poly_id wrap inl) }
   where
@@ -574,7 +575,7 @@ tcImpPrags prags
 tcImpSpec :: Sig Name -> TcM TcSpecPrag
 tcImpSpec prag@(SpecSig (L _ name) _ _)
  = do { id <- tcLookupId name
-      ; checkTc (isInlinePragma (idInlinePragma id))
+      ; checkTc (isAnyInlinePragma (idInlinePragma id))
                 (impSpecErr name)
       ; tcSpec id prag }
 tcImpSpec p = pprPanic "tcImpSpec" (ppr p)
@@ -582,8 +583,8 @@ tcImpSpec p = pprPanic "tcImpSpec" (ppr p)
 impSpecErr :: Name -> SDoc
 impSpecErr name
   = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
-       2 (ptext (sLit "because its definition has no INLINE/INLINABLE pragma"))
-
+       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
+               , ptext (sLit "(or you compiled its definining module without -O)")])
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 
@@ -602,6 +603,26 @@ forall_a_a :: TcType
 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
 \end{code}
 
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+   reverse :: [a] -> [a]
+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+   data Arr e where
+     ArrInt :: !Int -> ByteArray# -> Arr Int
+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+   (!:) :: Arr e -> Int -> e
+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
 
 %************************************************************************
 %*                                                                      *
@@ -1055,6 +1076,7 @@ instance Outputable GeneralisationPlan where
 decideGeneralisationPlan 
    :: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
 decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
+  | bang_pat_binds                         = NoGen
   | mono_pat_binds                         = NoGen
   | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
                                              then NoGen	      -- Optimise common case
@@ -1064,7 +1086,12 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
   | otherwise                              = InferGen mono_restriction
 
   where
-    mono_pat_binds = xopt Opt_MonoPatBinds dflags 
+    bang_pat_binds = any (isBangHsBind . unLoc) binds
+       -- Bang patterns must not be polymorphic,
+       -- because we are going to force them
+       -- See Trac #4498
+
+    mono_pat_binds = xopt Opt_MonoPatBinds dflags
                   && any (is_pat_bind . unLoc) binds
 
     mono_restriction = xopt Opt_MonomorphismRestriction dflags 
@@ -1108,24 +1135,30 @@ checkStrictBinds top_lvl rec_group binds poly_ids
         ; checkTc (isNonRec rec_group)
                   (strictBindErr "Recursive" unlifted binds)
         ; checkTc (isSingleton binds)
-                  (strictBindErr "Multiple" unlifted binds) 
+                  (strictBindErr "Multiple" unlifted binds)
         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
         -- the versions of alex and happy available have non-conforming
         -- templates, so the GHC build fails if it's an error:
         ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
-        ; warnTc (warnUnlifted && not bang_pat)
+        ; warnTc (warnUnlifted && not bang_pat && lifted_pat)
+                 -- No outer bang, but it's a compound pattern
+                 -- E.g   (I# x#) = blah
+                 -- Warn about this, but not about
+                 --      x# = 4# +# 1#
+                 --      (# a, b #) = ...
                  (unliftedMustBeBang binds) }
   | otherwise
   = return ()
   where
-    unlifted = any is_unlifted poly_ids
-    bang_pat = any (isBangHsBind . unLoc) binds
+    unlifted    = any is_unlifted poly_ids
+    bang_pat    = any (isBangHsBind . unLoc) binds
+    lifted_pat  = any (isLiftedPatBind . unLoc) binds
     is_unlifted id = case tcSplitForAllTys (idType id) of
                        (_, rho) -> isUnLiftedType rho
 
 unliftedMustBeBang :: [LHsBind Name] -> SDoc
 unliftedMustBeBang binds
-  = hang (text "Bindings containing unlifted types should use an outermost bang pattern:")
+  = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
        2 (pprBindList binds)
 
 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc