Commit 1f1bd920 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Introduce BootUnfolding, set when unfolding is absent due to hs-boot file.


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2246
parent 704913cf
......@@ -49,7 +49,7 @@ module CoreSyn (
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,
unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
-- ** Predicates and deconstruction on 'Unfolding'
......@@ -59,6 +59,7 @@ module CoreSyn (
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, hasStableCoreUnfolding_maybe,
isClosedUnfolding, hasSomeUnfolding,
isBootUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
-- * Annotated expression data types
......@@ -975,7 +976,10 @@ The @Unfolding@ type is declared here to avoid numerous loops
-- identifier would have if we substituted its definition in for the identifier.
-- This type should be treated as abstract everywhere except in "CoreUnfold"
data Unfolding
= NoUnfolding -- ^ We have no information about the unfolding
= NoUnfolding -- ^ We have no information about the unfolding.
| BootUnfolding -- ^ We have no information about the unfolding, because
-- this 'Id' came from an @hi-boot@ file.
| OtherCon [AltCon] -- ^ It ain't one of these constructors.
-- @OtherCon xs@ also indicates that something has been evaluated
......@@ -1160,6 +1164,11 @@ evaldUnfolding :: Unfolding
noUnfolding = NoUnfolding
evaldUnfolding = OtherCon []
-- | There is no known 'Unfolding', because this came from an
-- hi-boot file.
bootUnfolding :: Unfolding
bootUnfolding = BootUnfolding
mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
......@@ -1260,8 +1269,13 @@ isClosedUnfolding _ = True
-- | Only returns False if there is no unfolding information available at all
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding _ = True
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding BootUnfolding = False
hasSomeUnfolding _ = True
isBootUnfolding :: Unfolding -> Bool
isBootUnfolding BootUnfolding = True
isBootUnfolding _ = False
neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfNever = True
......
......@@ -1065,6 +1065,7 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
is_wf is_exp guidance
| otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing
NoUnfolding -> Nothing
BootUnfolding -> Nothing
OtherCon {} -> Nothing
DFunUnfolding {} -> Nothing -- Never unfold a DFun
......
......@@ -1836,6 +1836,7 @@ diffIdInfo env bndr1 bndr2
-- redundant, and can lead to an exponential blow-up in complexity.
diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold _ NoUnfolding NoUnfolding = []
diffUnfold _ BootUnfolding BootUnfolding = []
diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
diffUnfold env (DFunUnfolding bs1 c1 a1)
(DFunUnfolding bs2 c2 a2)
......
......@@ -484,6 +484,7 @@ instance Outputable UnfoldingSource where
instance Outputable Unfolding where
ppr NoUnfolding = text "No unfolding"
ppr BootUnfolding = text "No unfolding (from boot)"
ppr (OtherCon cs) = text "OtherCon" <+> ppr cs
ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
= hang (text "DFun:" <+> ptext (sLit "\\")
......
......@@ -263,6 +263,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
False -- not boot!
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
gbl_env = DsGblEnv { ds_mod = mod
, ds_fam_inst_env = fam_inst_env
......
......@@ -423,7 +423,7 @@ loadInterface doc_str mod from
let
loc_doc = text file_path
in
initIfaceLcl mod loc_doc $ do
initIfaceLcl mod loc_doc (mi_boot iface) $ do
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
......
......@@ -146,7 +146,7 @@ knots are tied through the EPS. No problem!
typecheckIface :: ModIface -- Get the decls from here
-> IfG ModDetails
typecheckIface iface
= initIfaceLcl (mi_module iface) (text "typecheckIface") $ do
= initIfaceLcl (mi_module iface) (text "typecheckIface") (mi_boot iface) $ do
{ -- Get the right set of decls and rules. If we are compiling without -O
-- we discard pragmas before typechecking, so that we don't "see"
-- information that we shouldn't. From a versioning point of view
......@@ -1241,16 +1241,18 @@ tcIdDetails _ (IfRecSelId tc naughty)
tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info
| ignore_prags = return vanillaIdInfo
| otherwise = case info of
NoInfo -> return vanillaIdInfo
HasInfo info -> foldlM tcPrag init_info info
where
tcIdInfo ignore_prags name ty info = do
lcl_env <- getLclEnv
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
init_info = vanillaIdInfo
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
if ignore_prags
then return init_info
else case info of
NoInfo -> return init_info
HasInfo info -> foldlM tcPrag init_info info
where
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
......
......@@ -183,8 +183,9 @@ mkBootTypeEnv exports ids tcs fam_insts
-- Do make sure that we keep Ids that are already Global.
-- When typechecking an .hs-boot file, the Ids come through as
-- GlobalIds.
final_ids = [ if isLocalId id then globaliseAndTidyId id
else id
final_ids = [ (if isLocalId id then globaliseAndTidyId id
else id)
`setIdUnfolding` BootUnfolding
| id <- ids
, keep_it id ]
......
......@@ -2911,6 +2911,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> InId -> Unfolding -> SimplM Unfoldi
simplUnfolding env top_lvl id unf
= case unf of
NoUnfolding -> return unf
BootUnfolding -> return unf
OtherCon {} -> return unf
DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
......
......@@ -748,6 +748,7 @@ wantSpecImport :: DynFlags -> Unfolding -> Bool
wantSpecImport dflags unf
= case unf of
NoUnfolding -> False
BootUnfolding -> False
OtherCon {} -> False
DFunUnfolding {} -> True
CoreUnfolding { uf_src = src, uf_guidance = _guidance }
......
......@@ -1600,9 +1600,11 @@ setLocalRdrEnv rdr_env thing_inside
************************************************************************
-}
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
mkIfLclEnv mod loc boot
= IfLclEnv { if_mod = mod,
if_loc = loc,
if_boot = boot,
if_tv_env = emptyFsEnv,
if_id_env = emptyFsEnv }
......@@ -1644,9 +1646,9 @@ initIfaceCheck doc hsc_env do_this
}
initTcRnIf 'i' hsc_env gbl_env () do_this
initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc hi_boot_file thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }
......
......@@ -276,6 +276,11 @@ data IfLclEnv
-- it means M.f = \x -> x, where M is the if_mod
if_mod :: Module,
-- Whether or not the IfaceDecl came from a boot
-- file or not; we'll use this to choose between
-- NoUnfolding and BootUnfolding
if_boot :: Bool,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
if_loc :: SDoc,
......
......@@ -323,6 +323,7 @@ liftSimple aexpr
isToplevel :: Var -> Bool
isToplevel v | isId v = case realIdUnfolding v of
NoUnfolding -> False
BootUnfolding -> False
OtherCon {} -> True
DFunUnfolding {} -> True
CoreUnfolding {uf_is_top = top} -> top
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment