Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Glasgow Haskell Compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
90fa6b84
Commit
90fa6b84
authored
Oct 25, 2000
by
simonpj
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2000-10-25 12:56:20 by simonpj]
Tons of stuff for the mornings work
parent
b125ffe2
Changes
36
Hide whitespace changes
Inline
Side-by-side
Showing
36 changed files
with
656 additions
and
707 deletions
+656
-707
ghc/compiler/Simon-log
ghc/compiler/Simon-log
+11
-0
ghc/compiler/basicTypes/Name.lhs
ghc/compiler/basicTypes/Name.lhs
+2
-2
ghc/compiler/coreSyn/CoreSyn.lhs
ghc/compiler/coreSyn/CoreSyn.lhs
+12
-5
ghc/compiler/coreSyn/CoreTidy.lhs
ghc/compiler/coreSyn/CoreTidy.lhs
+10
-17
ghc/compiler/coreSyn/CoreUnfold.lhs
ghc/compiler/coreSyn/CoreUnfold.lhs
+1
-1
ghc/compiler/coreSyn/PprCore.lhs
ghc/compiler/coreSyn/PprCore.lhs
+4
-1
ghc/compiler/deSugar/Desugar.lhs
ghc/compiler/deSugar/Desugar.lhs
+5
-6
ghc/compiler/hsSyn/HsDecls.lhs
ghc/compiler/hsSyn/HsDecls.lhs
+26
-28
ghc/compiler/hsSyn/HsSyn.lhs
ghc/compiler/hsSyn/HsSyn.lhs
+0
-1
ghc/compiler/main/HscTypes.lhs
ghc/compiler/main/HscTypes.lhs
+2
-3
ghc/compiler/main/MkIface.lhs
ghc/compiler/main/MkIface.lhs
+178
-145
ghc/compiler/prelude/TysWiredIn.lhs
ghc/compiler/prelude/TysWiredIn.lhs
+1
-0
ghc/compiler/rename/Rename.lhs
ghc/compiler/rename/Rename.lhs
+16
-20
ghc/compiler/rename/RnBinds.hi-boot
ghc/compiler/rename/RnBinds.hi-boot
+1
-1
ghc/compiler/rename/RnBinds.hi-boot-5
ghc/compiler/rename/RnBinds.hi-boot-5
+1
-1
ghc/compiler/rename/RnBinds.lhs
ghc/compiler/rename/RnBinds.lhs
+11
-9
ghc/compiler/rename/RnEnv.lhs
ghc/compiler/rename/RnEnv.lhs
+9
-11
ghc/compiler/rename/RnHiFiles.lhs
ghc/compiler/rename/RnHiFiles.lhs
+3
-3
ghc/compiler/rename/RnHsSyn.lhs
ghc/compiler/rename/RnHsSyn.lhs
+3
-1
ghc/compiler/rename/RnIfaces.lhs
ghc/compiler/rename/RnIfaces.lhs
+13
-6
ghc/compiler/rename/RnMonad.lhs
ghc/compiler/rename/RnMonad.lhs
+1
-1
ghc/compiler/rename/RnSource.hi-boot
ghc/compiler/rename/RnSource.hi-boot
+1
-1
ghc/compiler/rename/RnSource.hi-boot-5
ghc/compiler/rename/RnSource.hi-boot-5
+4
-7
ghc/compiler/rename/RnSource.lhs
ghc/compiler/rename/RnSource.lhs
+39
-44
ghc/compiler/simplCore/SimplCore.lhs
ghc/compiler/simplCore/SimplCore.lhs
+130
-76
ghc/compiler/specialise/Rules.lhs
ghc/compiler/specialise/Rules.lhs
+14
-97
ghc/compiler/typecheck/TcClassDcl.lhs
ghc/compiler/typecheck/TcClassDcl.lhs
+11
-14
ghc/compiler/typecheck/TcDeriv.lhs
ghc/compiler/typecheck/TcDeriv.lhs
+2
-3
ghc/compiler/typecheck/TcEnv.lhs
ghc/compiler/typecheck/TcEnv.lhs
+55
-8
ghc/compiler/typecheck/TcInstDcls.lhs
ghc/compiler/typecheck/TcInstDcls.lhs
+5
-4
ghc/compiler/typecheck/TcModule.lhs
ghc/compiler/typecheck/TcModule.lhs
+6
-7
ghc/compiler/typecheck/TcMonoType.lhs
ghc/compiler/typecheck/TcMonoType.lhs
+27
-26
ghc/compiler/typecheck/TcRules.lhs
ghc/compiler/typecheck/TcRules.lhs
+24
-17
ghc/compiler/typecheck/TcTyClsDecls.lhs
ghc/compiler/typecheck/TcTyClsDecls.lhs
+24
-84
ghc/compiler/types/InstEnv.lhs
ghc/compiler/types/InstEnv.lhs
+3
-55
ghc/compiler/usageSP/UsageSPInf.lhs
ghc/compiler/usageSP/UsageSPInf.lhs
+1
-2
No files found.
ghc/compiler/Simon-log
View file @
90fa6b84
------------------------------------
GHCI hacking
------------------------------------
* Don't forget to put deferred-type-decls back into RnIfaces
* Do we want to record a package name in a .hi file?
Does pi_mod have a ModuleName or a Module?
* Does teh finder
------------------------------------
Mainly PredTypes (28 Sept 00)
------------------------------------
...
...
ghc/compiler/basicTypes/Name.lhs
View file @
90fa6b84
...
...
@@ -41,7 +41,7 @@ module Name (
#include "HsVersions.h"
import OccName -- All of it
import Module ( Module, moduleName,
pprModule,
mkVanillaModule,
import Module ( Module, moduleName, mkVanillaModule,
isModuleInThisPackage )
import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc,
rdrNameModule )
...
...
@@ -480,7 +480,7 @@ toRdrName :: NamedThing a => a -> RdrName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
getOccString
x = occNameString (getOccName x)
getOccString
= occNameString . getOccName
toRdrName = ifaceNameRdrName . getName
\end{code}
...
...
ghc/compiler/coreSyn/CoreSyn.lhs
View file @
90fa6b84
...
...
@@ -28,7 +28,7 @@ module CoreSyn (
noUnfolding, mkOtherCon,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding,
hasUnfolding, hasSomeUnfolding,
neverUnfold,
-- Seq stuff
seqRules, seqExpr, seqExprs, seqUnfolding,
...
...
@@ -39,6 +39,7 @@ module CoreSyn (
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
IdCoreRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
isBuiltinRule
...
...
@@ -47,9 +48,9 @@ module CoreSyn (
#include "HsVersions.h"
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId
, idType
)
import Type ( Type, UsageAnn, mkTyVarTy,
isUnLiftedType,
seqType )
import Literal ( Literal
(MachStr)
, mkMachInt )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, UsageAnn, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
import VarSet
import Outputable
...
...
@@ -137,6 +138,7 @@ rulesRules (Rules rules _) = rules
\begin{code}
type RuleName = FAST_STRING
type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
data CoreRule
= Rule RuleName
...
...
@@ -257,6 +259,12 @@ hasUnfolding other = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding other = True
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
neverUnfold other = False
\end{code}
...
...
@@ -296,7 +304,6 @@ type CoreExpr = Expr CoreBndr
type CoreArg = Arg CoreBndr
type CoreBind = Bind CoreBndr
type CoreAlt = Alt CoreBndr
type CoreNote = Note
\end{code}
Binders are ``tagged'' with a \tr{t}:
...
...
ghc/compiler/coreSyn/CoreTidy.lhs
View file @
90fa6b84
...
...
@@ -15,7 +15,6 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
import Rules ( ProtoCoreRule(..), RuleBase )
import UsageSPInf ( doUsageSPInf )
import VarEnv
import VarSet
...
...
@@ -66,9 +65,10 @@ Several tasks are done by @tidyCorePgm@
from the uniques for local thunks etc.]
\begin{code}
tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
tidyCorePgm dflags module_name binds_in rulebase_in
tidyCorePgm :: DynFlags -> Module
-> [CoreBind] -> [IdCoreRule]
-> IO ([CoreBind], [IdCoreRule])
tidyCorePgm dflags module_name binds_in orphans_in
= do
us <- mkSplitUniqSupply 'u'
...
...
@@ -81,13 +81,13 @@ tidyCorePgm dflags module_name binds_in rulebase_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
init_tidy_env binds_in1
rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
orphans_out = tidyIdRules tidy_env1 orphans_in
endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
dopt Opt_D_verbose_core2core dflags)
binds_out
return (binds_out,
rule
s_out)
return (binds_out,
orphan
s_out)
where
-- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl
...
...
@@ -101,11 +101,6 @@ tidyCorePgm dflags module_name binds_in rulebase_in
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
exportWithOrigOccName bndr]
mk_local_protos :: RuleBase -> [ProtoCoreRule]
mk_local_protos (rule_ids, _)
= [ProtoCoreRule True id rule | id <- varSetElems rule_ids,
rule <- rulesRules (idSpecialisation id)]
tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> TidyEnv
-> CoreBind
...
...
@@ -245,17 +240,15 @@ tidyIdInfo env info
| otherwise = info `setSpecInfo` tidyRules env rules
info3 = info2 `setUnfoldingInfo` noUnfolding
info4 = info3 `setDemandInfo` wwLazy
-- I don't understand why...
info4 = info3 `setDemandInfo` wwLazy
info5 = case workerInfo info of
NoWorker -> info4
HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a
tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
tidyProtoRules env rules
= [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
| ProtoCoreRule is_local fn rule <- rules
]
tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
tidyIdRules env rules
= [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
tidyRules :: TidyEnv -> CoreRules -> CoreRules
tidyRules env (Rules rules fvs)
...
...
ghc/compiler/coreSyn/CoreUnfold.lhs
View file @
90fa6b84
...
...
@@ -20,7 +20,7 @@ module CoreUnfold (
mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding,
hasUnfolding, hasSomeUnfolding,
neverUnfold,
couldBeSmallEnoughToInline,
certainlyWillInline,
...
...
ghc/compiler/coreSyn/PprCore.lhs
View file @
90fa6b84
...
...
@@ -12,7 +12,7 @@ module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprIdBndr,
pprCoreBinding, pprCoreBindings,
pprCoreRules, pprCoreRule
pprCoreRules, pprCoreRule
, pprIdCoreRule
) where
#include "HsVersions.h"
...
...
@@ -361,6 +361,9 @@ ppIdInfo b info
pprCoreRules :: Id -> CoreRules -> SDoc
pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
pprIdCoreRule :: IdCoreRule -> SDoc
pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
...
...
ghc/compiler/deSugar/Desugar.lhs
View file @
90fa6b84
...
...
@@ -14,7 +14,7 @@ import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import CoreSyn
import
Rules ( ProtoCoreRule(..), pprProto
CoreRule )
import
PprCore ( pprId
CoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
...
...
@@ -48,7 +48,7 @@ deSugar :: DynFlags
-> UniqSupply
-> HomeSymbolTable
-> TcResults
-> IO ([CoreBind],
RuleEnv
, SDoc, SDoc, [CoreBndr])
-> IO ([CoreBind],
[(Id,CoreRule)]
, SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name us hst
(TcResults {tc_env = global_val_env,
...
...
@@ -98,7 +98,7 @@ dsProgram mod_name all_binds rules fo_decls
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
vcat (map ppr
Proto
CoreRule rules)
vcat (map ppr
Id
CoreRule rules)
\end{code}
...
...
@@ -109,13 +109,12 @@ ppr_ds_rules rules
%************************************************************************
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM
ProtoCoreRule
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM
(Id, CoreRule)
dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
returnDs (ProtoCoreRule True {- local -} fn
(Rule name tpl_vars args core_rhs))
returnDs (fn, Rule name tpl_vars args core_rhs)
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
...
...
ghc/compiler/hsSyn/HsDecls.lhs
View file @
90fa6b84
...
...
@@ -15,7 +15,7 @@ module HsDecls (
BangType(..), getBangType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl,
countTyClDecls, toHsRule
,
isClassDecl, isSynDecl, isDataDecl,
isIfaceSigDecl, countTyClDecls
,
mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames
) where
...
...
@@ -27,20 +27,19 @@ import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
import HsExpr ( HsExpr )
import HsTypes
import PprCore ( pprCoreRule )
import HsCore ( UfExpr
(UfVar)
, UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr
, toUfExpr, toUfBndr
import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
import Name ( getName )
-- others:
import FunDeps ( pprFundeps )
import Class ( FunDep )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc
, noSrcLoc
)
import SrcLoc ( SrcLoc )
\end{code}
...
...
@@ -200,7 +199,29 @@ data TyClDecl name pat
(MonoBinds name pat) -- default methods
(ClassDeclSysNames name)
SrcLoc
\end{code}
Simple classifiers
\begin{code}
isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isIfaceSigDecl (IfaceSig _ _ _ _) = True
isIfaceSigDecl other = False
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
Dealing with names
\begin{code}
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
...
...
@@ -237,19 +258,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
\begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
...
...
@@ -669,16 +677,6 @@ instance (Outputable name, Outputable pat)
instance Outputable name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
toHsRule id (BuiltinRule _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
toHsRule id (Rule name bndrs args rhs)
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
...
...
ghc/compiler/hsSyn/HsSyn.lhs
View file @
90fa6b84
...
...
@@ -38,7 +38,6 @@ import HsLit
import HsMatches
import HsPat
import HsTypes
import HsCore
import BasicTypes ( Fixity, Version, NewOrData )
-- others:
...
...
ghc/compiler/main/HscTypes.lhs
View file @
90fa6b84
...
...
@@ -54,7 +54,6 @@ import Module ( Module, ModuleName, ModuleEnv,
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
...
...
@@ -65,7 +64,7 @@ import HsSyn ( DeprecTxt )
import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( CoreRule )
import CoreSyn ( CoreRule
, IdCoreRule
)
import Type ( Type )
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
...
...
@@ -150,7 +149,7 @@ data ModDetails
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules :: [
(Id,CoreRule)
] -- Domain may include Ids from other modules
md_rules :: [
IdCoreRule
] -- Domain may include Ids from other modules
}
\end{code}
...
...
ghc/compiler/main/MkIface.lhs
View file @
90fa6b84
...
...
@@ -36,7 +36,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile,
couldBeSmallEnoughToInline
)
import CoreUnfold ( okToUnfoldInHiFile,
mkTopUnfolding, neverUnfold
)
import Name ( isLocallyDefined, getName, nameModule,
Name, NamedThing(..),
plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
...
...
@@ -70,8 +70,24 @@ import List ( partition )
completeModDetails :: ModDetails
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
-> [
Proto
CoreRule] -- Tidy orphan rules
-> [
Id
CoreRule] -- Tidy orphan rules
-> ModDetails
completeModDetails mds tidy_binds stg_ids orphan_rules
= ModDetails {
where
dfun_ids = md_insts mds
final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
(mkVarSet stg_ids)
tidy_binds
rule_dcls | opt_OmitInterfacePragmas = []
| otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| (_, rule) <- tidy_orphan_rules]
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
...
...
@@ -87,33 +103,18 @@ completeIface :: Maybe ModIface -- The old interface, if we have it
-- The IO in the type is solely for debug output
-- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details
tidy_binds final_ids tidy_orphan_rules
= let
new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
in
addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
declsFromDetails details tidy_binds final_ids tidy_orphan_rules
= IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls,
dcl_insts = inst_dcls,
dcl_rules = rule_dcls }
where
dfun_ids = md_insts details
inst_dcls = map ifaceInstance dfun_ids
ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
(val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
final_ids tidy_binds
rule_dcls | opt_OmitInterfacePragmas = []
| otherwise = ifaceRules tidy_orphan_rules emitted_ids
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| ProtoCoreRule _ _ rule <- tidy_orphan_rules]
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
where
new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls,
dcl_insts = inst_dcls,
dcl_rules = rule_dcls }
inst_dcls = map ifaceInstance (mk_insts mds)
ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types details))
rule_dcls = map ifaceRule (md_rules details)
\end{code}
%************************************************************************
%* *
\subsection{Types and classes}
...
...
@@ -121,13 +122,6 @@ declsFromDetails details tidy_binds final_ids tidy_orphan_rules
%************************************************************************
\begin{code}
emitTyCls :: TyThing -> Bool
emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not
-- strictly necessary, and it costs extra time
emitTyCls (AClass cl) = True
emitTyCls (AnId _) = False
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
= ClassDecl (toHsContext sc_theta)
...
...
@@ -193,6 +187,49 @@ ifaceTyCls (ATyCon tycon)
= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
ifaceTyCls (AnId id)
= IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
where
id_type = idType id
id_info = idInfo id
hs_idinfo | opt_OmitInterfacePragmas = []
| otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
arity_hsinfo = case arityInfo id_info of
a@(ArityExactly n) -> [HsArity a]
other -> []
------------ Caf Info --------------
caf_hsinfo = case cafInfo id_info of
NoCafRefs -> [HsNoCafRefs]
otherwise -> []
------------ CPR Info --------------
cpr_hsinfo = case cprInfo id_info of
ReturnsCPR -> [HsCprInfo]
NoCPRInfo -> []
------------ Strictness --------------
strict_hsinfo = case strictnessInfo id_info of
NoStrictnessInfo -> []
info -> [HsStrictness info]
------------ Worker --------------
wkr_hsinfo = case workerInfo id_info of
HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
NoWorker -> []
------------ Unfolding --------------
unfold_info = unfoldInfo id_info
inine_prag = inlinePragInfo id_info
rhs = unfoldingTempate unfold_info
unfold_hsinfo | neverUnfold unfold_info = []
| otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
\end{code}
...
...
@@ -217,55 +254,40 @@ ifaceInstance dfun_id
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
\end{code}
\begin{code}
ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
ifaceRules rules emitted
= orphan_rules ++ local_rules
where
orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
local_rules = [ toHsRule fn rule
| fn <- varSetElems emitted,
rule <- rulesRules (idSpecialisation fn),
not (isBuiltinRule rule),
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
ifaceRule (id, BuiltinRule _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
-- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
-- from coming out, and to make it work properly we need to add ????
-- (put it back in for now)
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- Spit out a rule only if all its lhs free vars are emitted
-- This is a good reason not to do it when we emit the Id itself
]
ifaceRule (id, Rule name bndrs args rhs)
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
%************************************************************************
%* *
\subsection{
Value binding
s}
\subsection{
Compute final Id
s}
%* *
%************************************************************************
A "final Id" has exactly the IdInfo for going into an interface file, or
exporting to another module.
\begin{code}
ifaceBin
ds :: IdSet -- These Ids are needed already
->
[Id]
-- Ids used at code-gen time; they have better pragma info!
bindsToI
ds :: IdSet -- These Ids are needed already
->
IdSet
-- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
-> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out
-> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
-- they need for exporting to another module
ifaceBinds needed_ids final
_ids binds
= go needed_ids (reverse binds)
emptyBag emptyVarSet
bindsToIds needed_ids codegen
_ids binds
= go needed_ids (reverse binds)
[]
-- Reverse so that later things will
-- provoke earlier ones to be emitted
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
get_idinfo id = case lookupUFM final_id_map id of
Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
...
...
@@ -274,22 +296,21 @@ ifaceBinds needed_ids final_ids binds
go needed [] decls emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
(decls, emitted)
| otherwise =
(decls, emitted)
emitted
| otherwise =
emitted
go needed (NonRec id rhs : binds)
decls
emitted
go needed (NonRec id rhs : binds) emitted
| need_id needed id
= if omitIfaceSigForId id then
go (needed `delVarSet` id) binds
decls (emitted `extendVarSet` i
d)
go (needed `delVarSet` id) binds
(id:emitte
d)
else
go ((needed `unionVarSet` extras) `delVarSet` id)
binds
(decl `consBag` decls)
(emitted `extendVarSet` id)
(new_id:emitted)
| otherwise
= go needed binds decls emitted
where
(
decl, extras) = ifaceId get_idinfo
False id rhs
(
new_id, extras) = mkFinalId codegen_ids
False id rhs
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
...
...
@@ -297,72 +318,60 @@ ifaceBinds needed_ids final_ids binds
-- because without -O we may only need the first one (if we don't emit
-- its unfolding)
go needed (Rec pairs : binds) decls emitted
= go needed' binds
decls'
emitted'
= go needed' binds emitted'
where
(new_decls, new_emitted, extras) = go_rec needed pairs
decls' = new_decls `unionBags` decls
(new_emitted, extras) = go_rec needed pairs
needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
emitted' =
emitted `unionVarSet` new_emitted
emitted' =
new_emitted ++ emitted
go_rec :: IdSet -> [(Id,CoreExpr)] -> (
Bag RenamedIfaceSig, IdSet
, IdSet)
go_rec :: IdSet -> [(Id,CoreExpr)] -> (
[Id]
, IdSet)
go_rec needed pairs
| null decls = (emptyBag, emptyVarSet, emptyVarSet)
| otherwise = (more_decls `unionBags` listToBag decls,
more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
more_extras `unionVarSet` extras)
| null needed_prs = ([], emptyVarSet)
| otherwise = (emitted ++ more_emitted,
extras `unionVarSet` more_extras)
where
(needed_prs,leftover_prs) = partition is_needed pairs
(decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
| (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
extras = unionVarSets extras_s
(more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
(needed_prs,leftover_prs) = partition is_needed pairs
(emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs
| (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
extras = unionVarSets extras_s
(more_emitted, more_extras) = go_rec extras leftover_prs
is_needed (id,_) = need_id needed id
\end{code}
\begin{code}
ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
-- by the STG passes. Sigh
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo is_rec id rhs
= (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
mkFinalId :: IdSet -- The Ids with arity info from the code generator
-> Bool -- True <=> recursive, so don't include unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
mkFinalId codegen_ids is_rec id rhs
= (id `setIdInfo` new_idinfo, new_needed_ids)