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

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

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2246

compiler/coreSyn/CoreSyn.hs

@@ -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

compiler/coreSyn/CoreUnfold.hs

@@ -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
 

compiler/coreSyn/CoreUtils.hs

@@ -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)

compiler/coreSyn/PprCore.hs

@@ -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 "\\")

compiler/deSugar/DsMonad.hs

@@ -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

compiler/iface/LoadIface.hs

@@ -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

compiler/iface/TcIface.hs

@@ -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)

compiler/main/TidyPgm.hs

@@ -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 ]
 

compiler/simplCore/Simplify.hs

@@ -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 }

compiler/specialise/Specialise.hs

@@ -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 }

compiler/typecheck/TcRnMonad.hs

@@ -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) }

compiler/typecheck/TcRnTypes.hs

@@ -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,

compiler/vectorise/Vectorise/Exp.hs

@@ -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