X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=3aaa58a35fcc06b5c253e46c4b04003a4c8fcc5b;hb=c80364f8e4681b34e974f5df36ecdacec7cd9cd8;hp=a191b8225f423efa94717a3642678d83bd16a3b0;hpb=debb7b80e707c343a3a7d8993ffab19b83e5c52b;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index a191b82..3aaa58a 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -130,14 +130,12 @@ tcLocalBinds (HsValBinds binds) thing_inside
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
   = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
-        ; let ip_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet given_ips
 
         -- If the binding binds ?x = E, we  must now 
         -- discharge any ?x constraints in expr_lie
+        -- See Note [Implicit parameter untouchables]
         ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
-                                  ip_tvs  -- See Note [Implicit parameter untouchables]
-                                  [] given_ips $
-                                thing_inside
+                                  [] given_ips thing_inside
 
         ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
   where
@@ -164,6 +162,9 @@ doesn't float that solved constraint out (it's not an unsolved
 wanted.  Result disaster: the (Num alpha) is again solved, this
 time by defaulting.  No no no.
 
+However [Oct 10] this is all handled automatically by the 
+untouchable-range idea.
+
 \begin{code}
 tcValBinds :: TopLevelFlag 
            -> HsValBinds Name -> TcM thing
@@ -393,7 +394,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
 
        ; let skol_info = SigSkol (FunSigCtxt (idName id))
        ; (ev_binds, (binds', [mono_info])) 
-            <- checkConstraints skol_info emptyVarSet tvs ev_vars $
+            <- checkConstraints skol_info tvs ev_vars $
                tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs)    $
                tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
 
@@ -495,7 +496,9 @@ mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
     get_sig _                         = Nothing
 
     add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
-      | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+      | Just ar <- lookupNameEnv ar_env n,
+        Inline <- inl_inline inl_prag     = inl_prag { inl_sat = Just ar }
+        -- add arity only for real INLINE pragmas, not INLINABLE
       | otherwise                         = inl_prag
 
     prag_env :: NameEnv [LSig Name]
@@ -539,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
@@ -599,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.
 
 %************************************************************************
 %*                                                                      *