Commit a7ecdf96 authored by simonpj's avatar simonpj

[project @ 2005-07-19 16:44:50 by simonpj]

WARNING: this is a big commit.  You might want 
	to wait a few days before updating, in case I've 
	broken something.

	However, if any of the changes are what you wanted,
	please check it out and test!

This commit does three main things:

1. A re-organisation of the way that GHC handles bindings in HsSyn.
   This has been a bit of a mess for quite a while.  The key new
   types are

	-- Bindings for a let or where clause
	data HsLocalBinds id
	  = HsValBinds (HsValBinds id)
	  | HsIPBinds  (HsIPBinds id)
	  | EmptyLocalBinds

	-- Value bindings (not implicit parameters)
	data HsValBinds id
	  = ValBindsIn  -- Before typechecking
		(LHsBinds id) [LSig id]	-- Not dependency analysed
					-- Recursive by default

	  | ValBindsOut	-- After typechecking
		[(RecFlag, LHsBinds id)]-- Dependency analysed

2. Implement Mark Jones's idea of increasing polymoprhism
   by using type signatures to cut the strongly-connected components
   of a recursive group.  As a consequence, GHC no longer insists
   on the contexts of the type signatures of a recursive group
   being identical.

   This drove a significant change: the renamer no longer does dependency
   analysis.  Instead, it attaches a free-variable set to each binding,
   so that the type checker can do the dep anal.  Reason: the typechecker
   needs to do *two* analyses:
	one to find the true mutually-recursive groups
		(which we need so we can build the right CoreSyn)
	one to find the groups in which to typecheck, taking
		account of type signatures

3. Implement non-ground SPECIALISE pragmas, as promised, and as
   requested by Remi and Ross.  Certainly, this should fix the 
   current problem with GHC, namely that if you have
	g :: Eq a => a -> b -> b
   then you can now specialise thus
	SPECIALISE g :: Int -> b -> b
    (This didn't use to work.)

   However, it goes further than that.  For example:
	f :: (Eq a, Ix b) => a -> b -> b
   then you can make a partial specialisation
	SPECIALISE f :: (Eq a) => a -> Int -> Int

    In principle, you can specialise f to *any* type that is
    "less polymorphic" (in the sense of subsumption) than f's 
    actual type.  Such as
	SPECIALISE f :: Eq a => [a] -> Int -> Int
    But I haven't tested that.

    I implemented this by doing the specialisation in the typechecker
    and desugarer, rather than leaving around the strange SpecPragmaIds,
    for the specialiser to find.  Indeed, SpecPragmaIds have vanished 
    altogether (hooray).

    Pragmas in general are handled more tidily.  There's a new
    data type HsBinds.Prag, which lives in an AbsBinds, and carries
    pragma info from the typechecker to the desugarer.


Smaller things

- The loop in the renamer goes via RnExpr, instead of RnSource.
  (That makes it more like the type checker.)

- I fixed the thing that was causing 'check_tc' warnings to be 
  emitted.
parent 8a9aba1f
...@@ -22,7 +22,7 @@ module BasicTypes( ...@@ -22,7 +22,7 @@ module BasicTypes(
Fixity(..), FixityDirection(..), Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence, defaultFixity, maxPrecedence,
negateFixity, negateFixity, funTyFixity,
compareFixity, compareFixity,
IPName(..), ipNameName, mapIPName, IPName(..), ipNameName, mapIPName,
...@@ -155,11 +155,10 @@ instance Outputable FixityDirection where ...@@ -155,11 +155,10 @@ instance Outputable FixityDirection where
maxPrecedence = (9::Int) maxPrecedence = (9::Int)
defaultFixity = Fixity maxPrecedence InfixL defaultFixity = Fixity maxPrecedence InfixL
negateFixity :: Fixity negateFixity, funTyFixity :: Fixity
negateFixity = Fixity negatePrecedence InfixL -- Precedence of unary negate is wired in as infixl 6! -- Wired-in fixities
negateFixity = Fixity 6 InfixL -- Fixity of unary negate
negatePrecedence :: Int funTyFixity = Fixity 0 InfixR -- Fixity of '->'
negatePrecedence = 6
\end{code} \end{code}
Consider Consider
......
...@@ -8,7 +8,7 @@ module Id ( ...@@ -8,7 +8,7 @@ module Id (
Id, DictId, Id, DictId,
-- Simple construction -- Simple construction
mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, mkGlobalId, mkLocalId, mkLocalIdWithInfo,
mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
mkWorkerId, mkExportedLocalId, mkWorkerId, mkExportedLocalId,
...@@ -24,8 +24,8 @@ module Id ( ...@@ -24,8 +24,8 @@ module Id (
zapLamIdInfo, zapDemandIdInfo, zapLamIdInfo, zapDemandIdInfo,
-- Predicates -- Predicates
isImplicitId, isDeadBinder, isImplicitId, isDeadBinder, isDictId,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId, isExportedId, isLocalId, isGlobalId,
isRecordSelector, isRecordSelector,
isClassOpId_maybe, isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe, isPrimOpId, isPrimOpId_maybe,
...@@ -83,7 +83,7 @@ module Id ( ...@@ -83,7 +83,7 @@ module Id (
import CoreSyn ( Unfolding, CoreRule ) import CoreSyn ( Unfolding, CoreRule )
import BasicTypes ( Arity ) import BasicTypes ( Arity )
import Var ( Id, DictId, import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId, isId, isExportedId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId, idName, idType, idUnique, idInfo, isGlobalId,
setIdName, setIdType, setIdUnique, setIdName, setIdType, setIdUnique,
setIdExported, setIdNotExported, setIdExported, setIdNotExported,
...@@ -91,10 +91,11 @@ import Var ( Id, DictId, ...@@ -91,10 +91,11 @@ import Var ( Id, DictId,
maybeModifyIdInfo, maybeModifyIdInfo,
globalIdDetails globalIdDetails
) )
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId )
import TyCon ( FieldLabel, TyCon ) import TyCon ( FieldLabel, TyCon )
import Type ( Type, typePrimRep, addFreeTyVars, seqType, import Type ( Type, typePrimRep, addFreeTyVars, seqType,
splitTyConApp_maybe, PrimRep ) splitTyConApp_maybe, PrimRep )
import TcType ( isDictTy )
import TysPrim ( statePrimTyCon ) import TysPrim ( statePrimTyCon )
import IdInfo import IdInfo
...@@ -147,9 +148,6 @@ where it can easily be found. ...@@ -147,9 +148,6 @@ where it can easily be found.
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
mkSpecPragmaId :: Name -> Type -> Id
mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
mkExportedLocalId :: Name -> Type -> Id mkExportedLocalId :: Name -> Type -> Id
mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo
...@@ -229,17 +227,6 @@ idPrimRep id = typePrimRep (idType id) ...@@ -229,17 +227,6 @@ idPrimRep id = typePrimRep (idType id)
%* * %* *
%************************************************************************ %************************************************************************
The @SpecPragmaId@ exists only to make Ids that are
on the *LHS* of bindings created by SPECIALISE pragmas;
eg: s = f Int d
The SpecPragmaId is never itself mentioned; it
exists solely so that the specialiser will find
the call to f, and make specialised version of it.
The SpecPragmaId binding is discarded by the specialiser
when it gathers up overloaded calls.
Meanwhile, it is not discarded as dead code.
\begin{code} \begin{code}
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of recordSelectorFieldLabel id = case globalIdDetails id of
...@@ -278,6 +265,9 @@ isDataConWorkId_maybe id = case globalIdDetails id of ...@@ -278,6 +265,9 @@ isDataConWorkId_maybe id = case globalIdDetails id of
DataConWorkId con -> Just con DataConWorkId con -> Just con
other -> Nothing other -> Nothing
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
idDataCon :: Id -> DataCon idDataCon :: Id -> DataCon
-- Get from either the worker or the wrapper to the DataCon -- Get from either the worker or the wrapper to the DataCon
-- Currently used only in the desugarer -- Currently used only in the desugarer
......
...@@ -442,6 +442,9 @@ type InlinePragInfo = Activation ...@@ -442,6 +442,9 @@ type InlinePragInfo = Activation
-- --
-- If there was an INLINE pragma, then as a separate matter, the -- If there was an INLINE pragma, then as a separate matter, the
-- RHS will have been made to look small with a CoreSyn Inline Note -- RHS will have been made to look small with a CoreSyn Inline Note
-- The default InlinePragInfo is AlwaysActive, so the info serves
-- entirely as a way to inhibit inlining until we want it
\end{code} \end{code}
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
module NameEnv ( module NameEnv (
NameEnv, mkNameEnv, NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts, emptyNameEnv, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnvList_C, extendNameEnv, extendNameEnvList, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList,
foldNameEnv, filterNameEnv, foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C, plusNameEnv, plusNameEnv_C,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
...@@ -34,7 +34,7 @@ emptyNameEnv :: NameEnv a ...@@ -34,7 +34,7 @@ emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a] nameEnvElts :: NameEnv a -> [a]
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnvList_C:: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b
extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
...@@ -54,7 +54,7 @@ foldNameEnv = foldUFM ...@@ -54,7 +54,7 @@ foldNameEnv = foldUFM
mkNameEnv = listToUFM mkNameEnv = listToUFM
nameEnvElts = eltsUFM nameEnvElts = eltsUFM
extendNameEnv_C = addToUFM_C extendNameEnv_C = addToUFM_C
extendNameEnvList_C = addListToUFM_C extendNameEnv_Acc = addToUFM_Acc
extendNameEnv = addToUFM extendNameEnv = addToUFM
plusNameEnv = plusUFM plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C plusNameEnv_C = plusUFM_C
......
...@@ -19,15 +19,14 @@ module Var ( ...@@ -19,15 +19,14 @@ module Var (
Id, DictId, Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo, setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo,
setIdExported, setIdNotExported, zapSpecPragmaId, setIdExported, setIdNotExported,
globalIdDetails, globaliseId, globalIdDetails, globaliseId,
mkLocalId, mkExportedLocalId, mkSpecPragmaId, mkLocalId, mkExportedLocalId, mkGlobalId,
mkGlobalId,
isTyVar, isTcTyVar, isId, isLocalVar, isLocalId, isTyVar, isTcTyVar, isId, isLocalVar, isLocalId,
isGlobalId, isExportedId, isSpecPragmaId, isGlobalId, isExportedId,
mustHaveLocalBinding mustHaveLocalBinding
) where ) where
...@@ -91,9 +90,7 @@ data Var ...@@ -91,9 +90,7 @@ data Var
data LocalIdDetails data LocalIdDetails
= NotExported -- Not exported = NotExported -- Not exported
| Exported -- Exported | Exported -- Exported
| SpecPragma -- Not exported, but not to be discarded either -- Exported Ids are kept alive;
-- It's unclean that this is so deeply built in
-- Exported and SpecPragma Ids are kept alive;
-- NotExported things may be discarded as dead code. -- NotExported things may be discarded as dead code.
\end{code} \end{code}
...@@ -225,11 +222,6 @@ setIdNotExported :: Id -> Id ...@@ -225,11 +222,6 @@ setIdNotExported :: Id -> Id
-- We can only do this to LocalIds -- We can only do this to LocalIds
setIdNotExported id = ASSERT( isLocalId id ) id { lclDetails = NotExported } setIdNotExported id = ASSERT( isLocalId id ) id { lclDetails = NotExported }
zapSpecPragmaId :: Id -> Id
zapSpecPragmaId id
| isSpecPragmaId id = id {lclDetails = NotExported}
| otherwise = id
globaliseId :: GlobalIdDetails -> Id -> Id globaliseId :: GlobalIdDetails -> Id -> Id
-- If it's a local, make it global -- If it's a local, make it global
globaliseId details id = GlobalId { varName = varName id, globaliseId details id = GlobalId { varName = varName id,
...@@ -287,16 +279,13 @@ mkLocalId name ty info = mk_local_id name ty NotExported info ...@@ -287,16 +279,13 @@ mkLocalId name ty info = mk_local_id name ty NotExported info
mkExportedLocalId :: Name -> Type -> IdInfo -> Id mkExportedLocalId :: Name -> Type -> IdInfo -> Id
mkExportedLocalId name ty info = mk_local_id name ty Exported info mkExportedLocalId name ty info = mk_local_id name ty Exported info
mkSpecPragmaId :: Name -> Type -> IdInfo -> Id
mkSpecPragmaId name ty info = mk_local_id name ty SpecPragma info
\end{code} \end{code}
\begin{code} \begin{code}
isTyVar, isTcTyVar :: Var -> Bool isTyVar, isTcTyVar :: Var -> Bool
isId, isLocalVar, isLocalId :: Var -> Bool isId, isLocalVar, isLocalId :: Var -> Bool
isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool isGlobalId, isExportedId :: Var -> Bool
mustHaveLocalBinding :: Var -> Bool mustHaveLocalBinding :: Var -> Bool
isTyVar (TyVar {}) = True isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True isTyVar (TcTyVar {}) = True
...@@ -333,12 +322,8 @@ isExportedId (GlobalId {}) = True ...@@ -333,12 +322,8 @@ isExportedId (GlobalId {}) = True
isExportedId (LocalId {lclDetails = details}) isExportedId (LocalId {lclDetails = details})
= case details of = case details of
Exported -> True Exported -> True
SpecPragma -> True
other -> False other -> False
isExportedId other = False isExportedId other = False
isSpecPragmaId (LocalId {lclDetails = SpecPragma}) = True
isSpecPragmaId other = False
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -37,7 +37,7 @@ import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold, ...@@ -37,7 +37,7 @@ import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold,
import DynFlags ( DynFlags, DynFlag(..), dopt ) import DynFlags ( DynFlags, DynFlag(..), dopt )
import CoreSyn import CoreSyn
import PprCore ( pprCoreExpr ) import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr ) import OccurAnal ( occurAnalyseExpr )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId, import Id ( Id, idType, isId,
idUnfolding, globalIdDetails idUnfolding, globalIdDetails
...@@ -69,7 +69,7 @@ import GLAEXTS ( Int# ) ...@@ -69,7 +69,7 @@ import GLAEXTS ( Int# )
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
mkUnfolding top_lvl expr mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr) = CoreUnfolding (occurAnalyseExpr expr)
top_lvl top_lvl
(exprIsValue expr) (exprIsValue expr)
...@@ -89,7 +89,7 @@ mkUnfolding top_lvl expr ...@@ -89,7 +89,7 @@ mkUnfolding top_lvl expr
-- it gets fixed up next round -- it gets fixed up next round
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= CompulsoryUnfolding (occurAnalyseGlobalExpr expr) = CompulsoryUnfolding (occurAnalyseExpr expr)
\end{code} \end{code}
......
...@@ -22,7 +22,7 @@ import Var ( Var ) ...@@ -22,7 +22,7 @@ import Var ( Var )
import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity, import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo, idInfo, idInlinePragma, idOccInfo,
globalIdDetails, isGlobalId, isExportedId, globalIdDetails, isGlobalId, isExportedId,
isSpecPragmaId, idNewDemandInfo idNewDemandInfo
) )
import Var ( TyVar, isTyVar, tyVarKind ) import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo, import IdInfo ( IdInfo, megaSeqIdInfo,
...@@ -317,7 +317,6 @@ pprIdBndr id = ppr id <+> ...@@ -317,7 +317,6 @@ pprIdBndr id = ppr id <+>
pprIdDetails :: Id -> SDoc pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
| isExportedId id = ptext SLIT("[Exported]") | isExportedId id = ptext SLIT("[Exported]")
| isSpecPragmaId id = ptext SLIT("[SpecPrag]")
| otherwise = empty | otherwise = empty
ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo :: Id -> IdInfo -> SDoc
......
...@@ -13,27 +13,24 @@ import StaticFlags ( opt_SccProfilingOn ) ...@@ -13,27 +13,24 @@ import StaticFlags ( opt_SccProfilingOn )
import DriverPhases ( isHsBoot ) import DriverPhases ( isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), import HscTypes ( ModGuts(..), HscEnv(..),
Dependencies(..), TypeEnv, IsBootInterface ) Dependencies(..), TypeEnv, IsBootInterface )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo ) import MkIface ( mkUsageInfo )
import Id ( Id, setIdExported, idName ) import Id ( Id, setIdExported, idName )
import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName ) import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
import CoreSyn import CoreSyn
import PprCore ( pprRules, pprCoreExpr ) import PprCore ( pprRules, pprCoreExpr )
import CoreSubst ( substExpr, mkSubst )
import DsMonad import DsMonad
import DsExpr ( dsLExpr ) import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) ) import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
import DsForeign ( dsForeigns ) import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot. -- depends on DsExpr.hi-boot.
import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS ) import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS )
import RdrName ( GlobalRdrEnv ) import RdrName ( GlobalRdrEnv )
import NameSet import NameSet
import VarEnv
import VarSet import VarSet
import Bag ( Bag, isEmptyBag, emptyBag, bagToList ) import Bag ( Bag, isEmptyBag, emptyBag )
import Rules ( roughTopNames ) import Rules ( roughTopNames )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
...@@ -43,8 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, ...@@ -43,8 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
import ListSetOps ( insertList ) import ListSetOps ( insertList )
import Outputable import Outputable
import UniqSupply ( mkSplitUniqSupply ) import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), unLoc ) import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef ) import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
import FastString import FastString
import Util ( sortLe ) import Util ( sortLe )
\end{code} \end{code}
...@@ -82,14 +80,12 @@ deSugar hsc_env ...@@ -82,14 +80,12 @@ deSugar hsc_env
-- Desugar the program -- Desugar the program
; ((all_prs, ds_rules, ds_fords), warns) ; ((all_prs, ds_rules, ds_fords), warns)
<- initDs hsc_env mod rdr_env type_env $ do <- initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsHsBinds auto_scc binds [] { core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords ; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs ; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs) local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules ; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, ds_rules, ds_fords) } ; return (all_prs, catMaybes ds_rules, ds_fords) }
-- If warnings are considered errors, leave. -- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag) ; if errorsFound dflags (warns, emptyBag)
...@@ -263,49 +259,37 @@ ppr_ds_rules rules ...@@ -263,49 +259,37 @@ ppr_ds_rules rules
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM CoreRule dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule mod in_scope (L loc (HsRule name act vars lhs rhs)) dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
= putSrcSpanDs loc $ = putSrcSpanDs loc $
do { let (dict_binds, body) do { let bndrs = [var | RuleBndr (L _ var) <- vars]
= case unLoc lhs of ; lhs' <- dsLExpr lhs
(HsLet [HsBindGroup dbs _ _] body) -> (dbs, body) ; rhs' <- dsLExpr rhs
other -> (emptyBag, lhs)
ds_dict_bind (L _ (VarBind id rhs))
= do { rhs' <- dsLExpr rhs ; returnDs (id,rhs') }
; dict_binds' <- mappM ds_dict_bind (bagToList dict_binds)
; body' <- dsLExpr body
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
Nothing -> do { dsWarn msg; return Nothing } ;
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly, -- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form -- and take the body apart into a (f args) form
; let bndrs = [var | RuleBndr (L _ var) <- vars] { let local_rule = nameIsLocalOrFrom mod fn_name
in_scope' = mkInScopeSet (extendVarSetList in_scope bndrs)
subst = mkSubst in_scope' emptyVarEnv (mkVarEnv id_pairs)
id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
body'' = substExpr subst body'
(fn, args) = case collectArgs body'' of
(Var fn_id, args) -> (idName fn_id, args)
other -> pprPanic "dsRule" (ppr lhs)
local_rule = nameIsLocalOrFrom mod fn
-- NB we can't use isLocalId in the orphan test, -- NB we can't use isLocalId in the orphan test,
-- because isLocalId isn't true of class methods -- because isLocalId isn't true of class methods
lhs_names = fn : nameSetToList (exprsFreeNames args) fn_name = idName fn_id
lhs_names = fn_name : nameSetToList (exprsFreeNames args)
-- No need to delete bndrs, because -- No need to delete bndrs, because
-- exprsFreeNams finds only External names -- exprsFreeNames finds only External names
orph = case filter (nameIsLocalOrFrom mod) lhs_names of orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n:ns) -> Just (nameOccName n) (n:ns) -> Just (nameOccName n)
[] -> Nothing [] -> Nothing
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
ru_rough = roughTopNames args, ru_rough = roughTopNames args,
ru_local = local_rule, ru_orph = orph }) ru_local = local_rule, ru_orph = orph }
} ; return (Just rule)
} } }
where
msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
2 (ppr lhs)
\end{code} \end{code}
...@@ -24,7 +24,7 @@ import TcHsSyn ( hsPatType ) ...@@ -24,7 +24,7 @@ import TcHsSyn ( hsPatType )
-- So WATCH OUT; check each use of split*Ty functions. -- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain. -- Sigh. This is a pain.
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import TcType ( Type, tcSplitAppTy, mkFunTy ) import TcType ( Type, tcSplitAppTy, mkFunTy )
import Type ( mkTyConApp, funArgTy ) import Type ( mkTyConApp, funArgTy )
...@@ -555,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ ...@@ -555,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
= let = let
defined_vars = mkVarSet (map unLoc (collectGroupBinders binds)) defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
local_vars' = local_vars `unionVarSet` defined_vars local_vars' = local_vars `unionVarSet` defined_vars
in in
dsfixCmd ids local_vars' stack res_ty body dsfixCmd ids local_vars' stack res_ty body
`thenDs` \ (core_body, free_vars, env_ids') -> `thenDs` \ (core_body, free_vars, env_ids') ->
mappM newSysLocalDs stack `thenDs` \ stack_ids -> mappM newSysLocalDs stack `thenDs` \ stack_ids ->
-- build a new environment, plus the stack, using the let bindings -- build a new environment, plus the stack, using the let bindings
dsLet binds (buildEnvStack env_ids' stack_ids) dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
`thenDs` \ core_binds -> `thenDs` \ core_binds ->
-- match the old environment and stack against the input -- match the old environment and stack against the input
matchEnvStack env_ids stack_ids core_binds matchEnvStack env_ids stack_ids core_binds
...@@ -798,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) ...@@ -798,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- build a new environment using the let bindings -- build a new environment using the let bindings
= dsLet binds (mkTupleExpr out_ids) `thenDs` \ core_binds -> = dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
-- match the old environment against the input -- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map -> matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids returnDs (do_arr ids
...@@ -1009,7 +1009,7 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) ...@@ -1009,7 +1009,7 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let = let
defined_vars = mkVarSet (collectPatsBinders pats) defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet` `unionVarSet`
mkVarSet (map unLoc (collectGroupBinders binds)) mkVarSet (map unLoc (collectLocalBinders binds))
in in
[(expr, [(expr,
mkVarSet (map unLoc (collectLStmtsBinders stmts)) mkVarSet (map unLoc (collectLStmtsBinders stmts))
......
...@@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at ...@@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s). lower levels it is preserved with @let@/@letrec@s).
\begin{code} \begin{code}
module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsLExpr ) import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr )
import {-# SOURCE #-} Match( matchWrapper ) import {-# SOURCE #-} Match( matchWrapper )
import DsMonad import DsMonad
...@@ -26,17 +26,23 @@ import CoreUtils ( exprType, mkInlineMe, mkSCC ) ...@@ -26,17 +26,23 @@ import CoreUtils ( exprType, mkInlineMe, mkSCC )
import StaticFlags ( opt_AutoSccsOnAllToplevs, import StaticFlags ( opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs ) opt_AutoSccsOnExportedToplevs )
import OccurAnal ( occurAnalyseExpr )
import CostCentre ( mkAutoCC, IsCafCC(..) ) import CostCentre ( mkAutoCC, IsCafCC(..) )
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) import Id ( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma )