\section{Tidying up Core}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TidyPgm( mkBootModDetails, tidyProgram ) where
#include "HsVersions.h"
import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
import NewDemand ( isBottomingSig, topSig )
import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker )
-import Name ( Name, getOccName, nameOccName, mkInternalName,
- localiseName, isExternalName, nameSrcLoc,
- isWiredInName, getName
- )
-import NameSet ( NameSet, elemNameSet, filterNameSet )
+import Name
+import NameSet ( NameSet, elemNameSet )
import IfaceEnv ( allocateGlobalBinder )
import NameEnv ( filterNameEnv, mapNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
newTyConRep, tyConSelIds, isAlgTyCon,
isEnumerationTyCon, isOpenTyCon )
import Class ( classSelIds )
-import Module ( Module )
+import Module
import HscTypes
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
-import PackageConfig ( PackageId )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import Outputable
import FastTypes hiding ( fastOr )
, md_fam_insts = fam_insts
, md_rules = []
, md_exports = exports
- , md_modBreaks = modBreaks
, md_vect_info = noVectInfo
})
}
; implicit_binds = getImplicitBinds type_env
; all_tidy_binds = implicit_binds ++ tidy_binds
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
-
- ; tidy_vect_info = VectInfo
- (filterNameSet (isElemId type_env)
- (vectInfoCCVar vect_info))
- -- filter against `type_env', not `tidy_type_env', as we must
- -- keep all implicit names
}
; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
- cg_hpc_info = hpc_info },
+ cg_hpc_info = hpc_info,
+ cg_modBreaks = modBreaks },
ModDetails { md_types = tidy_type_env,
md_rules = tidy_rules,
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports,
- md_modBreaks = modBreaks,
- md_vect_info = tidy_vect_info
+ md_vect_info = vect_info -- is already tidy
})
}
Just (AnId dfun_id') -> dfun_id'
other -> pprPanic "lookup_dfun" (ppr dfun_id)
-isElemId type_env name
- = case lookupTypeEnv type_env name of
- Just (AnId _) -> True
- _ -> False
-
tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
-- The competed type environment is gotten from
global = isExternalName name
local = not global
internal = not external
- loc = nameSrcLoc name
+ loc = nameSrcSpan name
(occ_env', occ') = tidyOccName occ_env (nameOccName name)
bndr' = mkVanillaGlobal name' ty' idinfo'
ty' = tidyTopType (idType bndr)
rhs' = tidyExpr rhs_tidy_env rhs
+ idinfo = idInfo bndr
idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
- (idInfo bndr) unfold_info arity
- caf_info
+ idinfo unfold_info worker_info
+ arity caf_info
-- Expose an unfolding if ext_ids tells us to
-- Remember that ext_ids maps an Id to a Bool:
show_unfold = maybe_external `orElse` False
unfold_info | show_unfold = mkTopUnfolding rhs'
| otherwise = noUnfolding
+ worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
-- Usually the Id will have an accurate arity on it, because
-- the simplifier has just run, but not always.
-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
-- CoreToStg makes use of this when constructing SRTs.
-tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
+tidyTopIdInfo tidy_env is_external idinfo unfold_info worker_info arity caf_info
| not is_external -- For internal Ids (not externally visible)
= vanillaIdInfo -- we only need enough info for code generation
-- Arity and strictness info are enough;
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setInlinePragInfo` inlinePragInfo idinfo
`setUnfoldingInfo` unfold_info
- `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
+ `setWorkerInfo` worker_info
-- NB: we throw away the Rules
-- They have already been extracted by findExternalRules
------------ Worker --------------
-tidyWorker tidy_env (HasWorker work_id wrap_arity)
- = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
-tidyWorker tidy_env other
+tidyWorker tidy_env show_unfold NoWorker
= NoWorker
+tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
+ | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
+ | otherwise = WARN( True, ppr work_id ) NoWorker
+ -- NB: do *not* expose the worker if show_unfold is off,
+ -- because that means this thing is a loop breaker or
+ -- marked NOINLINE or something like that
+ -- This is important: if you expose the worker for a loop-breaker
+ -- then you can make the simplifier go into an infinite loop, because
+ -- in effect the unfolding is exposed. See Trac #1709
+ --
+ -- Mind you, it probably should not be w/w'd in the first place;
+ -- hence the WARN
\end{code}
%************************************************************************