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
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
-- leave them to the tcSimplifyTop, and quite a bit faster too
| otherwise -- Nested case
- = do { ((binds, ids, thing), lie) <- getConstraints thing_inside
+ = do { ((binds, ids, thing), lie) <- captureConstraints thing_inside
; lie_binds <- bindLocalMethods lie ids
; return (binds, lie_binds, thing) }
-}
; 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
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
- <- getConstraints $
+ <- captureConstraints $
tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
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]
-- 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
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)
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.
%************************************************************************
%* *
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
| 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
; 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
projects / ghc-hetmet.git / blobdiff