Commit 92267aa2 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Implement auto-specialisation of imported Ids

This big-ish patch arranges that if an Id 'f' is 
  * Type-class overloaded 
       f :: Ord a => [a] -> [a]
  * Defined with an INLINABLE pragma
       {-# INLINABLE f #-}
  * Exported from its defining module 'D'

then in any module 'U' that imports D

1. Any call of 'f' at a fixed type will generate 
   (a) a specialised version of f in U
   (b) a RULE that rewrites unspecialised calls to the
       specialised on

  e.g. if the call is (f Int dOrdInt xs) then the 
  specialiser will generate
     $sfInt :: [Int] -> [Int]
     $sfInt = <code for f, imported from D, specialised>
     {-# RULE forall d.  f Int d = $sfInt #-}

2. In addition, you can give an explicit {-# SPECIALISE -#}
   pragma for the imported Id
     {-# SPECIALISE f :: [Bool] -> [Bool] #-}
   This too generates a local specialised definition, 
   and the corresponding RULE 

The new RULES are exported from module 'U', so that any module
importing U will see the specialised versions of 'f', and will
not re-specialise them.

There's a flag -fwarn-auto-orphan that warns you if the auto-generated
RULES are orphan rules. It's not in -Wall, mainly to avoid lots of
error messages with existing packages.

Main implementation changes

 - A new flag on a CoreRule to say if it was auto-generated.
   This is persisted across interface files, so there's a small
   change in interface file format.

 - Quite a bit of fiddling with plumbing, to get the 
   {-# SPECIALISE #-} pragmas for imported Ids.  In particular, a
   new field tgc_imp_specs in TcGblEnv, to keep the specialise
   pragmas for imported Ids between the typechecker and the desugarer.

 - Some new code (although surprisingly little) in Specialise,
   to deal with calls of imported Ids
parent 861e1d55
......@@ -65,7 +65,8 @@ module BasicTypes(
InlineSpec(..),
InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
neverInlinePragma, dfunInlinePragma,
isDefaultInlinePragma, isInlinePragma, inlinePragmaSpec, inlinePragmaSat,
isDefaultInlinePragma, isInlinePragma, isInlinablePragma,
inlinePragmaSpec, inlinePragmaSat,
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
......@@ -773,6 +774,11 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation
isInlinePragma :: InlinePragma -> Bool
isInlinePragma prag = isInlineSpec (inl_inline prag)
isInlinablePragma :: InlinePragma -> Bool
isInlinablePragma prag = case inl_inline prag of
Inlinable -> True
_ -> False
inlinePragmaSat :: InlinePragma -> Maybe Arity
inlinePragmaSat = inl_sat
......
......@@ -319,7 +319,7 @@ data CoreRule
= Rule {
ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
ru_act :: Activation, -- ^ When the rule is active
-- Rough-matching stuff
-- see comments with InstEnv.Instance( is_cls, is_rough )
ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
......@@ -336,6 +336,10 @@ data CoreRule
-- See Note [OccInfo in unfoldings and rules]
-- Locality
ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated
-- @False@ <=> generated at the users behest
-- Main effect: reporting of orphan-hood
ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
-- defined in the same module as the rule
-- and is not an implicit 'Id' (like a record selector,
......
......@@ -34,11 +34,11 @@ import CoreMonad ( endPass, CoreToDo(..) )
import ErrUtils
import Outputable
import SrcLoc
import Maybes
import FastString
import Coverage
import Util
import MonadUtils
import OrdList
import Data.List
import Data.IORef
\end{code}
......@@ -69,6 +69,7 @@ deSugar hsc_env
tcg_warns = warns,
tcg_anns = anns,
tcg_binds = binds,
tcg_imp_specs = imp_specs,
tcg_ev_binds = ev_binds,
tcg_fords = fords,
tcg_rules = rules,
......@@ -88,7 +89,7 @@ deSugar hsc_env
<- case target of
HscNothing ->
return (emptyMessages,
Just ([], [], [], NoStubs, hpcInfo, emptyModBreaks))
Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do
(binds_cvr,ds_hpc_info, modBreaks)
<- if (opt_Hpc
......@@ -98,23 +99,26 @@ deSugar hsc_env
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
ds_ev_binds <- dsEvBinds ev_binds
core_prs <- dsTopLHsBinds auto_scc binds_cvr
(ds_fords, foreign_prs) <- dsForeigns fords
let all_prs = foreign_prs ++ core_prs
mb_rules <- mapM dsRule rules
return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks)
do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
; rules <- mapMaybeM dsRule rules
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ rules
, ds_fords, ds_hpc_info, modBreaks) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do
Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
; let (rules_for_locals, rules_for_imps)
= partition isLocalRule (catMaybes mb_rules)
= partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target
export_set keep_alive rules_for_locals all_prs
export_set keep_alive rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
......@@ -163,6 +167,11 @@ deSugar hsc_env
; return (msgs, Just mod_guts)
}}}
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
= do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
; let (spec_binds, spec_rules) = unzip spec_prs
; return (concatOL spec_binds, spec_rules) }
combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
-- Top-level bindings can include coercion bindings, but not via superclasses
......@@ -340,13 +349,14 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
Nothing -> do { warnDs msg; return Nothing } ;
Just (fn_id, args) -> do
{ let local_rule = isLocalId fn_id
{ let is_local = isLocalId fn_id
-- NB: isLocalId is False of implicit Ids. This is good becuase
-- we don't want to attach rules to the bindings of implicit Ids,
-- because they don't show up in the bindings until just before code gen
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs' -- De-crap it
rule = mkRule local_rule name act fn_name bndrs' args final_rhs
rule = mkRule False {- Not auto -} is_local
name act fn_name bndrs' args final_rhs
; return (Just rule)
} } }
where
......
......@@ -10,7 +10,7 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
DsEvBind(..), AutoScc(..)
) where
......@@ -69,9 +69,8 @@ import MonadUtils
%************************************************************************
\begin{code}
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
; return (fromOL binds') }
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
......@@ -135,7 +134,7 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
Let core_bind $
Var local
; (spec_binds, rules) <- dsSpecs global rhs prags
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair global' (isDefaultMethod prags)
......@@ -178,9 +177,9 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
mkTupleSelector locals' (locals' !! n) tup_id $
mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
dicts
; (spec_binds, rules) <- dsSpecs global
(Let (NonRec poly_tup_id poly_tup_rhs) rhs)
spec_prags
full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
; let global' = addIdSpecialisations global rules
; return ((global', rhs) `consOL` spec_binds) }
where
......@@ -475,66 +474,69 @@ Note that
\begin{code}
------------------------
dsSpecs :: Id -- The polymorphic Id
-> CoreExpr -- Its rhs
dsSpecs :: CoreExpr -- Its rhs
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
, [CoreRule] ) -- Rules for the Global Ids
-- See Note [Implementing SPECIALISE pragmas]
dsSpecs poly_id poly_rhs prags
= case prags of
IsDefaultMethod -> return (nilOL, [])
SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
where
spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
spec_one (L loc (SpecPrag spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; wrap_fn <- dsHsWrapper spec_co
; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs ds_lhs of {
Nothing -> do { warnDs (decomp_msg spec_co)
; return Nothing } ;
Just (_fn, args) ->
-- Check for dead binders: Note [Unused spec binders]
let arg_fvs = exprsFreeVars args
bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
in if not (null bad_bndrs)
then do { warnDs (dead_msg bad_bndrs); return Nothing }
else do
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
| otherwise = spec_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
-- See Note [Constant rule dicts]
| d <- varSetElems (arg_fvs `delVarSetList` bndrs)
, isDictId d]
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
(extra_dict_bndrs ++ bndrs) args
(mkVarApps (Var spec_id) bndrs)
spec_rhs = wrap_fn poly_rhs
spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; return (Just (spec_pair `consOL` unf_pairs, rule))
} } }
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
= do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
; let (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, rules) }
dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-- Nothing => RULE is for an imported Id
-- rhs is in the Id's unfolding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
; wrap_fn <- dsHsWrapper spec_co
; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs ds_lhs of {
Nothing -> do { warnDs (decomp_msg spec_co)
; return Nothing } ;
Just (_fn, args) ->
-- Check for dead binders: Note [Unused spec binders]
let arg_fvs = exprsFreeVars args
bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
in if not (null bad_bndrs)
then do { warnDs (dead_msg bad_bndrs); return Nothing }
else do
{ (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
| otherwise = spec_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
-- See Note [Constant rule dicts]
| d <- varSetElems (arg_fvs `delVarSetList` bndrs)
, isDictId d]
rule = mkRule False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
(extra_dict_bndrs ++ bndrs) args
(mkVarApps (Var spec_id) bndrs)
spec_rhs = wrap_fn poly_rhs
spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; return (Just (spec_pair `consOL` unf_pairs, rule))
} } }
where
dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
<+> ptext (sLit "in specialied type:"),
nest 2 (pprTheta (map get_pred bs))]
......@@ -545,6 +547,15 @@ dsSpecs poly_id poly_rhs prags
= hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
2 (pprHsWrapper (ppr poly_id) spec_co)
is_local_id = isJust mb_poly_rhs
poly_rhs | Just rhs <- mb_poly_rhs
= rhs
| Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id)
= unfolding
| otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-- In the Nothing case the specialisation is for an imported Id
-- whose unfolding gives the RHS to be specialised
-- The type checker has checked that it has an unfolding
specUnfolding :: (CoreExpr -> CoreExpr) -> Type
-> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
......
......@@ -43,7 +43,7 @@ import Outputable
import FastString
import Config
import Constants
import OrdList
import Data.Maybe
import Data.List
\end{code}
......@@ -66,9 +66,9 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
dsForeigns :: [LForeignDecl Id]
-> DsM (ForeignStubs, [Binding])
-> DsM (ForeignStubs, OrdList Binding)
dsForeigns []
= return (NoStubs, [])
= return (NoStubs, nilOL)
dsForeigns fos = do
fives <- mapM do_ldecl fos
let
......@@ -79,7 +79,7 @@ dsForeigns fos = do
return (ForeignStubs
(vcat hs)
(vcat cs $$ vcat fe_init_code),
(concat bindss))
foldr (appOL . toOL) nilOL bindss)
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
......
......@@ -315,7 +315,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
where
ppr_exp (tvs, gbl, lcl, prags)
= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
nest 2 (pprTcSpecPrags gbl prags)]
nest 2 (pprTcSpecPrags prags)]
\end{code}
......@@ -636,11 +636,14 @@ data FixitySig name = FixitySig (Located name) Fixity
data TcSpecPrags
= IsDefaultMethod -- Super-specialised: a default method should
-- be macro-expanded at every call site
| SpecPrags [Located TcSpecPrag]
| SpecPrags [LTcSpecPrag]
deriving (Data, Typeable)
type LTcSpecPrag = Located TcSpecPrag
data TcSpecPrag
= SpecPrag
Id -- The Id to be specialised
HsWrapper -- An wrapper, that specialises the polymorphic function
InlinePragma -- Inlining spec for the specialised function
deriving (Data, Typeable)
......@@ -776,14 +779,11 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p
pp_inl | isDefaultInlinePragma inl = empty
| otherwise = ppr inl
pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
pprTcSpecPrags _ IsDefaultMethod = ptext (sLit "<default method>")
pprTcSpecPrags gbl (SpecPrags ps) = vcat (map (pprSpecPrag gbl) ps)
pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
pprTcSpecPrags :: TcSpecPrags -> SDoc
pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
\end{code}
......@@ -1430,7 +1430,7 @@ instance Binary IfaceClassOp where
return (IfaceClassOp occ def ty)
instance Binary IfaceRule where
put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
put_ bh a1
put_ bh a2
put_ bh a3
......@@ -1438,6 +1438,7 @@ instance Binary IfaceRule where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh a8
get bh = do
a1 <- get bh
a2 <- get bh
......@@ -1446,7 +1447,8 @@ instance Binary IfaceRule where
a5 <- get bh
a6 <- get bh
a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
a8 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
instance Binary IfaceAnnotation where
put_ bh (IfaceAnnotation a1 a2) = do
......
......@@ -163,6 +163,7 @@ data IfaceRule
ifRuleHead :: Name, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
ifRuleAuto :: Bool,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
......@@ -860,7 +861,8 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
freeNamesIfTc _ = emptyNameSet
freeNamesIfRule :: IfaceRule -> NameSet
freeNamesIfRule (IfaceRule _n _a bs f es rhs _o)
freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
, ifRuleArgs = es, ifRuleRhs = rhs })
= unitNameSet f &&&
fnList freeNamesIfBndr bs &&&
fnList freeNamesIfExpr es &&&
......
......@@ -280,9 +280,11 @@ mkIface_ hsc_env maybe_old_fingerprint
intermediate_iface decls
-- Warn about orphans
; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
| dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
; let warn_orphs = dopt Opt_WarnOrphans dflags
warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
orph_warnings --- Laziness means no work done unless -fwarn-orphans
| warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
......@@ -290,7 +292,9 @@ mkIface_ hsc_env maybe_old_fingerprint
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
, isNothing (ifRuleOrph r) ]
, isNothing (ifRuleOrph r)
, if ifRuleAuto r then warn_auto_orphs
else warn_orphs ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
......@@ -1569,12 +1573,14 @@ coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs })
ru_args = args, ru_rhs = rhs,
ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
ifRuleAuto = auto,
ifRuleOrph = orph }
where
-- For type args we must remove synonyms from the outermost
......@@ -1599,7 +1605,7 @@ bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr
......
......@@ -627,7 +627,8 @@ tcIfaceRules ignore_prags if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleAuto = auto })
= do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
forkM (ptext (sLit "Rule") <+> ftext name) $
......@@ -640,6 +641,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
ru_bndrs = bndrs', ru_args = args',
ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_auto = auto,
ru_local = False }) } -- An imported RULE is never for a local Id
-- or, even if it is (module loop, perhaps)
-- we'll just leave it in the non-local set
......
......@@ -202,6 +202,7 @@ data DynFlag
| Opt_WarnDodgyExports
| Opt_WarnDodgyImports
| Opt_WarnOrphans
| Opt_WarnAutoOrphans
| Opt_WarnTabs
| Opt_WarnUnrecognisedPragmas
| Opt_WarnDodgyForeignImports
......@@ -1441,6 +1442,7 @@ fFlags = [
( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ),
( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ),
( "warn-orphans", Opt_WarnOrphans, nop ),
( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ),
( "warn-tabs", Opt_WarnTabs, nop ),
( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ),
( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop),
......@@ -1759,6 +1761,7 @@ minuswRemovesOpts
Opt_WarnIncompletePatternsRecUpd,
Opt_WarnMonomorphism,
Opt_WarnUnrecognisedPragmas,
Opt_WarnAutoOrphans,
Opt_WarnTabs
]
......
This diff is collapsed.
......@@ -505,6 +505,8 @@ lookupQualifiedName rdr_name
doc = ptext (sLit "Need to find") <+> ppr rdr_name
\end{code}
Note [Looking up signature names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lookupSigOccRn is used for type signatures and pragmas
Is this valid?
module A
......@@ -525,10 +527,13 @@ return the imported 'f', so that later on the reanamer will
correctly report "misplaced type sig".
\begin{code}
lookupSigOccRn :: Maybe NameSet -- Just ns => source file; these are the binders
lookupSigOccRn :: Maybe NameSet -- Just ns => these are the binders
-- in the same group
-- Nothing => hs-boot file; signatures without
-- Nothing => signatures without
-- binders are expected
-- (a) top-level (SPECIALISE prags)
-- (b) class decls
-- (c) hs-boot files
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
lookupSigOccRn mb_bound_names sig
......@@ -538,14 +543,13 @@ lookupSigOccRn mb_bound_names sig
Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name }
lookupBindGroupOcc :: Maybe NameSet -- Just ns => source file; these are the binders
-- in the same group
-- Nothing => hs-boot file; signatures without
-- binders are expected
-> SDoc
lookupBindGroupOcc :: Maybe NameSet -- See notes on the (Maybe NameSet)
-> SDoc -- in lookupSigOccRn
-> RdrName -> RnM (Either Message Name)
-- Looks up the RdrName, expecting it to resolve to one of the
-- bound names passed in. If not, return an appropriate error message
--
-- See Note [Looking up signature names]
lookupBindGroupOcc mb_bound_names what rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of
......@@ -557,7 +561,8 @@ lookupBindGroupOcc mb_bound_names what rdr_name
; case (filter isLocalGRE gres) of
(gre:_) -> check_local_name (gre_name gre)
-- If there is more than one local GRE for the
-- same OccName, that will be reported separately
-- same OccName 'f', that will be reported separately
-- as a duplicate top-level binding for 'f'
[] | null gres -> bale_out_with empty
| otherwise -> bale_out_with import_msg
}}
......@@ -1100,7 +1105,7 @@ addNameClashErrRn rdr_name names
(np1:nps) = names
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn occ shadowed_locs
......
......@@ -21,7 +21,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
#endif /* GHCI */
import RnSource ( rnSrcDecls, findSplice )
import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
......@@ -931,7 +931,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
= failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
= do (_bound_names, binds') <- rnValBindsLHS fix_env binds
= do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
return [(L loc (LetStmt (HsValBinds binds')),
-- Warning: this is bogus; see function invariant
emptyFVs
......@@ -995,7 +995,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
(binds', du_binds) <-
-- fixities and unused are handled above in rn_rec_stmts_and_then
rnValBindsRHS (mkNameSet all_bndrs) binds'
rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
return [(duDefs du_binds, allUses du_binds,
emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
......
......@@ -150,7 +150,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
(rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- (G) Rename Fixity and deprecations
......
......@@ -24,7 +24,7 @@ module Rules (
-- * Misc. CoreRule helpers
rulesOfBinds, getRules, pprRulesForUser,
lookupRule, mkRule, mkLocalRule, roughTopNames
lookupRule, mkRule, roughTopNames
) where
#include "HsVersions.h"
......@@ -105,7 +105,7 @@ Note [Overall plumbing for rules]
The HomePackageTable doesn't have a single RuleBase because technically
we should only be able to "see" rules "below" this module; so we
generate a RuleBase for (c) by combing rules from all the modules
"below" us. That's whye we can't just select the home-package RuleBase
"below" us. That's why we can't just select the home-package RuleBase
from HscEnv.
[NB: we are inconsistent here. We should do the same for external
......@@ -156,22 +156,16 @@ might have a specialisation
where pi' :: Lift Int# is the specialised version of pi.
\begin{code}
mkLocalRule :: RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'CoreSyn.CoreRule'
mkLocalRule = mkRule True
mkRule :: Bool -> RuleName -> Activation
mkRule :: Bool -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'CoreSyn.CoreRule'
mkRule is_local name act fn bndrs args rhs
mkRule is_auto is_local name act fn bndrs args rhs
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = occurAnalyseExpr rhs,
ru_rough = roughTopNames args,
ru_local = is_local }
ru_auto = is_auto, ru_local = is_local }
--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
......@@ -759,21 +753,19 @@ match_alts idu menv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)
match_alts _ _ _ _ _
= Nothing
\end{code}
Matching Core types: use the matcher in TcType.
Notice that we treat newtypes as opaque. For example, suppose
we have a specialised version of a function at a newtype, say
newtype T = MkT Int
We only want to replace (f T) with f', not (f Int).
\begin{code}
------------------------------------------
match_ty :: MatchEnv
-> SubstEnv
-> Type -- Template
-> Type -- Target
-> Maybe SubstEnv
-- Matching Core types: use the matcher in TcType.
-- Notice that we treat newtypes as opaque. For example, suppose
-- we have a specialised version of a function at a newtype, say
-- newtype T = MkT Int
-- We only want to replace (f T) with f', not (f Int).
match_ty menv (tv_subst, id_subst, binds) ty1 ty2
= do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
; return (tv_subst', id_subst, binds) }
......
......@@ -1279,7 +1279,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
body_ty = exprType spec_body
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
rule = mkRule True {- Auto -} True {- Local -}
rule_name inline_act fn_name qvars pats rule_rhs
-- See Note [Transfer activation]
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
......
This diff is collapsed.
......@@ -25,6 +25,7 @@ import TcHsType
import TcPat
import TcMType
import TcType
import RnBinds( misplacedSigErr )
import Coercion
import TysPrim
import Id
......@@ -43,7 +44,10 @@ import BasicTypes
import Outputable
import FastString
import Data.List( partition )
import Control.Monad
#include "HsVersions.h"
\end{code}
......@@ -79,13 +83,19 @@ At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.
\begin{code}
tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
tcTopBinds :: HsValBinds Name
-> TcM ( LHsBinds TcId -- Typechecked bindings
, [LTcSpecPrag] -- SPECIALISE prags for imported Ids
, TcLclEnv) -- Augmented environment
-- Note: returning the TcLclEnv is more than we really
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
= do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
; return (foldr (unionBags . snd) emptyBag prs, env) }
= do { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv
; let binds = foldr (unionBags . snd) emptyBag prs
; specs <- tcImpPrags sigs
; return (binds, specs, env) }
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive LHsBinds
......@@ -360,7 +370,7 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
= do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
-- Zonk, mainly to expose unboxed types to checkStrictBinds
; let mono_id' = setIdType mono_id mono_ty'
; _specs <- tcSpecPrags False mono_id' (prag_fn name)
; _specs <- tcSpecPrags mono_id' (prag_fn name)
; return mono_id' }
-- NB: tcPrags generates error messages for
-- specialisation pragmas for non-overloaded sigs
......@@ -456,7 +466,7 @@ mkExport prag_fn inferred_tvs theta
; poly_id' <- addInlinePrags poly_id prag_sigs
; spec_prags <- tcSpecPrags (notNull theta) poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs