Commit dd313897 authored by simonpj's avatar simonpj

[project @ 2005-04-28 10:09:41 by simonpj]

This big commit does several things at once (aeroplane hacking)
which change the format of interface files.  

	So you'll need to recompile your libraries!

1. The "stupid theta" of a newtype declaration
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Retain the "stupid theta" in a newtype declaration.
For some reason this was being discarded, and putting it
back in meant changing TyCon and IfaceSyn slightly.
   

2. Overlap flags travel with the instance
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Arrange that the ability to support overlap and incoherence
is a property of the *instance declaration* rather than the
module that imports the instance decl.  This allows a library
writer to define overlapping instance decls without the
library client having to know.  

The implementation is that in an Instance we store the
overlap flag, and preseve that across interface files


3. Nuke the "instnce pool" and "rule pool"
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A major tidy-up and simplification of the way that instances
and rules are sucked in from interface files.  Up till now
an instance decl has been held in a "pool" until its "gates" 
(a set of Names) are in play, when the instance is typechecked
and added to the InstEnv in the ExternalPackageState.  
This is complicated and error-prone; it's easy to suck in 
too few (and miss an instance) or too many (and thereby be
forced to suck in its type constructors, etc).

Now, as we load an instance from an interface files, we 
put it straight in the InstEnv... but the Instance we put in
the InstEnv has some Names (the "rough-match" names) that 
can be used on lookup to say "this Instance can't match".
The detailed dfun is only read lazily, and the rough-match
thing meansn it is'nt poked on until it has a chance of
being needed.

This simply continues the successful idea for Ids, whereby
they are loaded straightaway into the TypeEnv, but their
TyThing is a lazy thunk, not poked on until the thing is looked
up.

Just the same idea applies to Rules.

On the way, I made CoreRule and Instance into full-blown records
with lots of info, with the same kind of key status as TyCon or 
DataCon or Class.  And got rid of IdCoreRule altogether.   
It's all much more solid and uniform, but it meant touching
a *lot* of modules.


4. Allow instance decls in hs-boot files
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Allowing instance decls in hs-boot files is jolly useful, becuase
in a big mutually-recursive bunch of data types, you want to give
the instances with the data type declarations.  To achieve this

* The hs-boot file makes a provisional name for the dict-fun, something
  like $fx9.

* When checking the "mother module", we check that the instance
  declarations line up (by type) and generate bindings for the 
  boot dfuns, such as
	$fx9 = $f2
  where $f2 is the dfun generated by the mother module

* In doing this I decided that it's cleaner to have DFunIds get their
  final External Name at birth.  To do that they need a stable OccName,
  so I have an integer-valued dfun-name-supply in the TcM monad.
  That keeps it simple.

This feature is hardly tested yet.


5. Tidy up tidying, and Iface file generation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
main/TidyPgm now has two entry points:

  simpleTidyPgm is for hi-boot files, when typechecking only
  (not yet implemented), and potentially when compiling without -O.
  It ignores the bindings, and generates a nice small TypeEnv.

  optTidyPgm is the normal case: compiling with -O.  It generates a
  TypeEnv rich in IdInfo

MkIface.mkIface now only generates a ModIface.  A separate
procedure, MkIface.writeIfaceFile, writes the file out to disk.
parent 89d6434a
-------------------------
*** unexpected failure for jtod_circint(opt)
......
......@@ -79,7 +79,7 @@ module Id (
#include "HsVersions.h"
import CoreSyn ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
import CoreSyn ( Unfolding, CoreRule )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
......@@ -403,13 +403,13 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
idSpecialisation :: Id -> SpecInfo
idSpecialisation id = specInfo (idInfo id)
idCoreRules :: Id -> [IdCoreRule]
idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)]
idCoreRules :: Id -> [CoreRule]
idCoreRules id = specInfoRules (idSpecialisation id)
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation :: Id -> SpecInfo -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
......
......@@ -63,7 +63,8 @@ module IdInfo (
occInfo, setOccInfo,
-- Specialisation
specInfo, setSpecInfo,
SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo,
specInfoFreeVars, specInfoRules, seqSpecInfo,
-- CAF info
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
......@@ -79,6 +80,7 @@ import CoreSyn
import Class ( Class )
import PrimOp ( PrimOp )
import Var ( Id )
import VarSet ( VarSet, emptyVarSet, seqVarSet )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch,
......@@ -282,7 +284,7 @@ case. KSW 1999-04).
data IdInfo
= IdInfo {
arityInfo :: !ArityInfo, -- Its arity
specInfo :: CoreRules, -- Specialisations of this function which exist
specInfo :: SpecInfo, -- Specialisations of this function which exist
#ifdef OLD_STRICTNESS
cprInfo :: CprInfo, -- Function always constructs a product result
demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
......@@ -317,7 +319,7 @@ seqIdInfo (IdInfo {}) = ()
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
= seqRules (specInfo info) `seq`
= seqSpecInfo (specInfo info) `seq`
seqWorker (workerInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
......@@ -385,7 +387,7 @@ vanillaIdInfo
demandInfo = wwLazy,
strictnessInfo = NoStrictnessInfo,
#endif
specInfo = emptyCoreRules,
specInfo = emptySpecInfo,
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
......@@ -443,6 +445,33 @@ type InlinePragInfo = Activation
\end{code}
%************************************************************************
%* *
SpecInfo
%* *
%************************************************************************
\begin{code}
-- CoreRules is used only in an idSpecialisation (move to IdInfo?)
data SpecInfo
= SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs
emptySpecInfo :: SpecInfo
emptySpecInfo = SpecInfo [] emptyVarSet
isEmptySpecInfo :: SpecInfo -> Bool
isEmptySpecInfo (SpecInfo rs _) = null rs
specInfoFreeVars :: SpecInfo -> VarSet
specInfoFreeVars (SpecInfo _ fvs) = fvs
specInfoRules :: SpecInfo -> [CoreRule]
specInfoRules (SpecInfo rules _) = rules
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
\end{code}
%************************************************************************
%* *
\subsection[worker-IdInfo]{Worker info about an @Id@}
......
......@@ -37,12 +37,12 @@ module MkId (
import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import Rules ( mkSpecInfo )
import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
realWorldStatePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
import Rules ( addRules )
import Type ( TyThing(..) )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
......@@ -665,13 +665,10 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
`setSpecInfo` rules
`setArityInfo` arity
`setSpecInfo` mkSpecInfo (primOpRules prim_op name)
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
rules = addRules id emptyCoreRules (primOpRules prim_op)
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
-- and a CCall structure that gives the correct details about calling
......@@ -717,11 +714,9 @@ Dict funs and default methods are *not* ImplicitIds. Their definition
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).
We build them as GlobalIds, but when in the module where they are
bound, we turn the Id at the *binding site* into an exported LocalId.
This ensures that they are taken to account by free-variable finding
and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
will propagate the LocalId to all occurrence sites.
We build them as LocalIds, but with External Names. This ensures that
they are taken to account by free-variable finding and dependency
analysis (e.g. CoreFVs.exprFreeVars).
Why shouldn't they be bound as GlobalIds? Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
......
......@@ -21,7 +21,7 @@ module Name (
setNameOcc,
hashName, localiseName,
nameSrcLoc, nameParent, nameParent_maybe,
nameSrcLoc, nameParent, nameParent_maybe, isImplicitName,
isSystemName, isInternalName, isExternalName,
isTyVarName, isWiredInName, isBuiltInSyntax,
......@@ -41,7 +41,7 @@ import OccName -- All of it
import Module ( Module )
import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), getKey, pprUnique )
import Maybes ( orElse )
import Maybes ( orElse, isJust )
import Outputable
\end{code}
......@@ -159,6 +159,11 @@ nameParent name = case nameParent_maybe name of
Just parent -> parent
Nothing -> name
isImplicitName :: Name -> Bool
-- An Implicit Name is one has a parent; that is, one whose definition
-- derives from tehe paren thing
isImplicitName name = isJust (nameParent_maybe name)
nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name)
nameModule_maybe (Name { n_sort = External mod _}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod
......
......@@ -62,6 +62,7 @@ import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt )
import Util ( thenCmp )
import Unique ( Unique, mkUnique, Uniquable(..) )
import BasicTypes ( Boxity(..), Arity )
import StaticFlags ( opt_PprStyle_Debug )
import UniqFM
import UniqSet
import FastString
......@@ -524,9 +525,22 @@ mkLocalOcc uniq occ
\begin{code}
mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe"
-> OccName -- "$fOrdMaybe"
-- Only used in debug mode, for extra clarity
-> Bool -- True <=> hs-boot instance dfun
-> Int -- Unique index
-> OccName -- "$f3OrdMaybe"
mkDFunOcc string = mk_deriv VarName "$f" string
-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real
-- thing when we compile the mother module. Reason: we don't know exactly
-- what the mother module will call it.
mkDFunOcc info_str is_boot index
= mk_deriv VarName prefix string
where
prefix | is_boot = "$fx"
| otherwise = "$f"
string | opt_PprStyle_Debug = show index ++ info_str
| otherwise = show index
\end{code}
We used to add a '$m' to indicate a method, but that gives rise to bad
......
......@@ -55,8 +55,6 @@ import Panic ( assertPanic )
#ifdef DEBUG
import Outputable
#endif
import DATA_IOREF ( readIORef )
\end{code}
\begin{code}
......
......@@ -9,9 +9,11 @@ module CoreFVs (
exprsFreeVars, -- [CoreExpr] -> VarSet
exprSomeFreeVars, exprsSomeFreeVars,
exprFreeNames, exprsFreeNames,
idRuleVars, idFreeVars, idFreeTyVars,
ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds,
idRuleVars, idFreeVars, idFreeTyVars,
ruleRhsFreeVars, rulesRhsFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet
......@@ -22,8 +24,11 @@ module CoreFVs (
#include "HsVersions.h"
import CoreSyn
import Id ( Id, idType, idSpecialisation )
import Id ( Id, idType, idSpecialisation, isLocalId )
import IdInfo ( specInfoFreeVars )
import NameSet
import UniqFM ( delFromUFM )
import Name ( isExternalName )
import VarSet
import Var ( Var, isId, isLocalVar, varName )
import Type ( tyVarsOfType )
......@@ -70,8 +75,8 @@ type InterestingVarFun = Var -> Bool -- True <=> interesting
\begin{code}
type FV = InterestingVarFun
-> VarSet -- In scope
-> VarSet -- Free vars
-> VarSet -- In scope
-> VarSet -- Free vars
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
......@@ -127,7 +132,6 @@ expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-- gaw 2004
expr_fvs (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
(foldr (union . alt_fvs) noVars alts)
......@@ -141,6 +145,9 @@ expr_fvs (Let (Rec pairs) body)
= addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
where
(bndrs,rhss) = unzip pairs
---------
exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
\end{code}
......@@ -150,7 +157,7 @@ expr_fvs (Let (Rec pairs) body)
%* *
%************************************************************************
exprFreeNames finds the free *names* of an expression, notably
exprFreeNames finds the free *external* *names* of an expression, notably
including the names of type constructors (which of course do not show
up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used
when deciding whether a rule is an orphan. In particular, suppose that
......@@ -159,40 +166,37 @@ T is defined in this module; we want to avoid declaring that a rule like
is an orphan. Of course it isn't, an declaring it an orphan would
make the whole module an orphan module, which is bad.
There's no need to delete local binders, because they will all
be *internal* names.
\begin{code}
ruleLhsFreeNames :: IdCoreRule -> NameSet
ruleLhsFreeNames (IdCoreRule fn _ (BuiltinRule _ _)) = unitNameSet (varName fn)
ruleLhsFreeNames (IdCoreRule fn _ (Rule _ _ tpl_vars tpl_args rhs))
= addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
ruleLhsFreeNames :: CoreRule -> NameSet
ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args })
= addOneToNameSet (exprsFreeNames tpl_args) fn
exprFreeNames :: CoreExpr -> NameSet
exprFreeNames (Var v) = unitNameSet (varName v)
exprFreeNames (Lit _) = emptyNameSet
exprFreeNames (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
exprFreeNames (Note n e) = exprFreeNames e
exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b)
`unionNameSets` exprFreeNames r
exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e)
`del_binders` bs
where
(bs, rs) = unzip prs
-- gaw 2004
exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty
`unionNameSets`
(unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b)
-- Helpers
altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs
-- Find the free *external* names of an expression
exprFreeNames e
= go e
where
go (Var v)
| isExternalName n = unitNameSet n
| otherwise = emptyNameSet
where n = varName v
go (Lit _) = emptyNameSet
go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
go (App e1 e2) = go e1 `unionNameSets` go e2
go (Lam v e) = go e `delFromNameSet` varName v
go (Note n e) = go e
go (Let (NonRec b r) e) = go e `unionNameSets` go r
go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e
go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty
`unionNameSets` unionManyNameSets (map go_alt as)
go_alt (_,_,r) = go r
exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es
del_binders :: NameSet -> [Var] -> NameSet
del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs
\end{code}
%************************************************************************
......@@ -204,17 +208,26 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd
\begin{code}
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule _ _) = noFVs
ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
= rule_fvs isLocalVar emptyVarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
= delFromUFM fvs fn
-- Hack alert!
-- Don't include the Id in its own rhs free-var set.
-- Otherwise the occurrence analyser makes bindings recursive
-- that shoudn't be. E.g.
-- RULE: f (f x y) z ==> f x (f y z)
where
rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
rulesRhsFreeVars :: [CoreRule] -> VarSet
rulesRhsFreeVars rules
= foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules
ruleLhsFreeIds :: CoreRule -> VarSet
-- This finds all locally-defined free Ids on the LHS of the rule
ruleLhsFreeIds (BuiltinRule _ _) = noFVs
ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsFreeVars tpl_args) tpl_vars
ruleLhsFreeIds (BuiltinRule {}) = noFVs
ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
......@@ -288,7 +301,7 @@ idFreeTyVars id = tyVarsOfType (idType id)
-- | otherwise = emptyVarSet
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
\end{code}
......
......@@ -8,7 +8,7 @@ module CoreSubst (
-- Substitution stuff
Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
substTy, substExpr, substRules, substWorker,
substTy, substExpr, substSpec, substWorker,
lookupIdSubst, lookupTvSubst,
emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst,
......@@ -24,8 +24,7 @@ module CoreSubst (
#include "HsVersions.h"
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
CoreRule(..), hasUnfolding, noUnfolding
)
import CoreFVs ( exprFreeVars )
import CoreUtils ( exprIsTrivial )
......@@ -36,8 +35,8 @@ import VarSet
import VarEnv
import Var ( setVarUnique, isId )
import Id ( idType, setIdType, maybeModifyIdInfo, isLocalId )
import IdInfo ( IdInfo, specInfo, setSpecInfo,
unfoldingInfo, setUnfoldingInfo,
import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo,
unfoldingInfo, setUnfoldingInfo, seqSpecInfo,
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import Unique ( Unique )
......@@ -339,13 +338,13 @@ substIdInfo :: Subst -> IdInfo -> Maybe IdInfo
-- Always zaps the unfolding, to save substitution work
substIdInfo subst info
| nothing_to_do = Nothing
| otherwise = Just (info `setSpecInfo` substRules subst old_rules
| otherwise = Just (info `setSpecInfo` substSpec subst old_rules
`setWorkerInfo` substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
where
old_rules = specInfo info
old_wrkr = workerInfo info
nothing_to_do = isEmptyCoreRules old_rules &&
nothing_to_do = isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
......@@ -366,22 +365,23 @@ substWorker subst (HasWorker w a)
-- via postInlineUnconditionally, hence warning)
------------------
substRules :: Subst -> CoreRules -> CoreRules
substSpec :: Subst -> SpecInfo -> SpecInfo
substRules subst rules
| isEmptySubst subst = rules
substRules subst (Rules rules rhs_fvs)
= seqRules new_rules `seq` new_rules
substSpec subst spec@(SpecInfo rules rhs_fvs)
| isEmptySubst subst
= spec
| otherwise
= seqSpecInfo new_rules `seq` new_rules
where
new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs)
do_subst rule@(BuiltinRule _ _) = rule
do_subst (Rule name act tpl_vars lhs_args rhs)
= Rule name act tpl_vars'
(map (substExpr subst') lhs_args)
(substExpr subst' rhs)
do_subst rule@(BuiltinRule {}) = rule
do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= rule { ru_bndrs = bndrs',
ru_args = map (substExpr subst') args,
ru_rhs = substExpr subst' rhs }
where
(subst', tpl_vars') = substBndrs subst tpl_vars
(subst', bndrs') = substBndrs subst bndrs
------------------
substVarSet subst fvs
......
......@@ -32,19 +32,16 @@ module CoreSyn (
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- Seq stuff
seqRules, seqExpr, seqExprs, seqUnfolding,
seqExpr, seqExprs, seqUnfolding,
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
IdCoreRule(..), isOrphanRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
isBuiltinRule, ruleName
RuleName, seqRules,
isBuiltinRule, ruleName, isLocalRule, ruleIdName
) where
#include "HsVersions.h"
......@@ -53,6 +50,8 @@ import StaticFlags ( opt_RuntimeTypes )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import Name ( Name )
import OccName ( OccName )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConWorkId, dataConTag )
import BasicTypes ( Activation )
......@@ -171,56 +170,65 @@ INVARIANTS:
The CoreRule type and its friends are dealt with mainly in CoreRules,
but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
\begin{code}
data CoreRules
= Rules [CoreRule]
VarSet -- Locally-defined free vars of RHSs
emptyCoreRules :: CoreRules
emptyCoreRules = Rules [] emptyVarSet
A Rule is
isEmptyCoreRules :: CoreRules -> Bool
isEmptyCoreRules (Rules rs _) = null rs
"local" if the function it is a rule for is defined in the
same module as the rule itself.
rulesRhsFreeVars :: CoreRules -> VarSet
rulesRhsFreeVars (Rules _ fvs) = fvs
rulesRules :: CoreRules -> [CoreRule]
rulesRules (Rules rules _) = rules
\end{code}
"orphan" if nothing on the LHS is defined in the same module
as the rule itself
\begin{code}
type RuleName = FastString
data IdCoreRule = IdCoreRule Id -- A rule for this Id
Bool -- True <=> orphan rule
CoreRule -- The rule itself
isOrphanRule :: IdCoreRule -> Bool
isOrphanRule (IdCoreRule _ is_orphan _) = is_orphan
data CoreRule
= Rule RuleName
Activation -- When the rule is active
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
= Rule {
ru_name :: RuleName,
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 at the head of this rule
ru_rough :: [Maybe Name], -- Name at the head of each argument
-- Proper-matching stuff
-- see comments with InstEnv.Instance( is_tvs, is_tys )
ru_bndrs :: [CoreBndr], -- Forall'd variables
ru_args :: [CoreExpr], -- LHS args
-- And the right-hand side
ru_rhs :: CoreExpr,
-- Locality
ru_local :: Bool, -- The fn at the head of the rule is
-- defined in the same module as the rule
-- Orphan-hood; see comments is InstEnv.Instance( is_orph )
ru_orph :: Maybe OccName }
| BuiltinRule { -- Built-in rules are used for constant folding
ru_name :: RuleName, -- and suchlike. It has no free variables.
ru_fn :: Name, -- Name of the Id at
-- the head of this rule
ru_try :: [CoreExpr] -> Maybe CoreExpr }
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
| BuiltinRule -- Built-in rules are used for constant folding
RuleName -- and suchlike. It has no free variables.
([CoreExpr] -> Maybe CoreExpr)
ruleName :: CoreRule -> RuleName
ruleName = ru_name
isBuiltinRule (BuiltinRule _ _) = True
isBuiltinRule _ = False
ruleIdName :: CoreRule -> Name
ruleIdName = ru_fn
ruleName :: CoreRule -> RuleName
ruleName (Rule n _ _ _ _) = n
ruleName (BuiltinRule n _) = n
isLocalRule :: CoreRule -> Bool
isLocalRule = ru_local
\end{code}
%************************************************************************
%* *
\subsection{@Unfolding@ type}
Unfoldings
%* *
%************************************************************************
......@@ -618,12 +626,10 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
seqAlts [] = ()
seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
seqRules :: CoreRules -> ()
seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
seq_rules [] = ()
seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
seq_rules (BuiltinRule _ _ : rules) = seq_rules rules
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
seqRules (BuiltinRule {} : rules) = seqRules rules
\end{code}
......
......@@ -4,8 +4,7 @@
\begin{code}
module CoreTidy (
tidyExpr, tidyVarOcc,
tidyIdRules, pprTidyIdRules
tidyExpr, tidyVarOcc, tidyRule, tidyRules
) where
#include "HsVersions.h"
......@@ -13,17 +12,17 @@ module CoreTidy (
import CoreSyn
import CoreUtils ( exprArity )
import Unify ( coreRefineTys )
import PprCore ( pprIdRules )
import DataCon ( DataCon, isVanillaDataCon )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, setIdType, idCoreRules )
idType, setIdType )
import IdInfo ( setArityInfo, vanillaIdInfo,
newStrictnessInfo, setAllStrictnessInfo,