Commit 9d58554f authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Marge Bot
Browse files

Properly trim IdInfos of DFunIds and PatSyns in TidyPgm

Not doing this right caused #16608. We now properly trim IdInfos of
DFunIds and PatSyns.

Some further refactoring done by SPJ.

Two regression tests T16608_1 and T16608_2 added.

Fixes #16608
parent 8584430e
...@@ -19,7 +19,7 @@ module PatSyn ( ...@@ -19,7 +19,7 @@ module PatSyn (
patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType, patSynFieldType,
tidyPatSynIds, pprPatSynType updatePatSynIds, pprPatSynType
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -417,8 +417,8 @@ patSynMatcher = psMatcher ...@@ -417,8 +417,8 @@ patSynMatcher = psMatcher
patSynBuilder :: PatSyn -> Maybe (Id, Bool) patSynBuilder :: PatSyn -> Maybe (Id, Bool)
patSynBuilder = psBuilder patSynBuilder = psBuilder
tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
= ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
where where
tidy_pr (id, dummy) = (tidy_fn id, dummy) tidy_pr (id, dummy) = (tidy_fn id, dummy)
......
...@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm. ...@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module CoreTidy ( module CoreTidy (
tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding tidyExpr, tidyRule, tidyRules, tidyUnfolding
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} {-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}
module TidyPgm ( module TidyPgm (
mkBootModDetailsTc, tidyProgram, globaliseAndTidyId mkBootModDetailsTc, tidyProgram
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -39,13 +39,11 @@ import Id ...@@ -39,13 +39,11 @@ import Id
import MkId ( mkDictSelRhs ) import MkId ( mkDictSelRhs )
import IdInfo import IdInfo
import InstEnv import InstEnv
import FamInstEnv
import Type ( tidyTopType ) import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig ) import Demand ( appIsBottom, isTopSig, isBottomingSig )
import BasicTypes import BasicTypes
import Name hiding (varName) import Name hiding (varName)
import NameSet import NameSet
import NameEnv
import NameCache import NameCache
import Avail import Avail
import IfaceEnv import IfaceEnv
...@@ -60,6 +58,7 @@ import HscTypes ...@@ -60,6 +58,7 @@ import HscTypes
import Maybes import Maybes
import UniqSupply import UniqSupply
import Outputable import Outputable
import Util( filterOut )
import qualified ErrUtils as Err import qualified ErrUtils as Err
import Control.Monad import Control.Monad
...@@ -149,65 +148,78 @@ mkBootModDetailsTc hsc_env ...@@ -149,65 +148,78 @@ mkBootModDetailsTc hsc_env
Err.withTiming (pure dflags) Err.withTiming (pure dflags)
(text "CoreTidy"<+>brackets (ppr this_mod)) (text "CoreTidy"<+>brackets (ppr this_mod))
(const ()) $ (const ()) $
do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts return (ModDetails { md_types = type_env'
; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns , md_insts = insts'
; type_env1 = mkBootTypeEnv (availsToNameSet exports) , md_fam_insts = fam_insts
(typeEnvIds type_env) tcs fam_insts , md_rules = []
; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1 , md_anns = []
; dfun_ids = map instanceDFunId insts' , md_exports = exports
; type_env' = extendTypeEnvWithIds type_env2 dfun_ids , md_complete_sigs = complete_sigs
} })
; return (ModDetails { md_types = type_env'
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
, md_anns = []
, md_exports = exports
, md_complete_sigs = complete_sigs
})
}
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv -- Find the LocalIds in the type env that are exported
mkBootTypeEnv exports ids tcs fam_insts -- Make them into GlobalIds, and tidy their types
= tidyTypeEnv True $ --
typeEnvFromEntities final_ids tcs fam_insts -- It's very important to remove the non-exported ones
where -- because we don't tidy the OccNames, and if we don't remove
-- Find the LocalIds in the type env that are exported -- the non-exported ones we'll get many things with the
-- Make them into GlobalIds, and tidy their types -- same name in the interface file, giving chaos.
-- --
-- It's very important to remove the non-exported ones -- Do make sure that we keep Ids that are already Global.
-- because we don't tidy the OccNames, and if we don't remove -- When typechecking an .hs-boot file, the Ids come through as
-- the non-exported ones we'll get many things with the -- GlobalIds.
-- same name in the interface file, giving chaos. final_ids = [ globaliseAndTidyBootId id
-- | id <- typeEnvIds type_env
-- 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)
`setIdUnfolding` BootUnfolding
| id <- ids
, keep_it id ] , keep_it id ]
-- default methods have their export flag set, but everything final_tcs = filterOut (isWiredInName . getName) tcs
-- else doesn't (yet), because this is pre-desugaring, so we -- See Note [Drop wired-in things]
-- must test both. type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts
keep_it id = isExportedId id || idName id `elemNameSet` exports insts' = mkFinalClsInsts type_env1 insts
pat_syns' = mkFinalPatSyns type_env1 pat_syns
type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1
-- Default methods have their export flag set (isExportedId),
-- but everything else doesn't (yet), because this is
-- pre-desugaring, so we must test against the exports too.
keep_it id | isWiredInName id_name = False
-- See Note [Drop wired-in things]
| isExportedId id = True
| id_name `elemNameSet` exp_names = True
| otherwise = False
where
id_name = idName id
exp_names = availsToNameSet exports
lookupFinalId :: TypeEnv -> Id -> Id
lookupFinalId type_env id
= case lookupTypeEnv type_env (idName id) of
Just (AnId id') -> id'
_ -> pprPanic "lookup_final_id" (ppr id)
mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]
mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))
extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns tidy_patsyns type_env
= extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
globaliseAndTidyId :: Id -> Id globaliseAndTidyBootId :: Id -> Id
-- Takes a LocalId with an External Name, -- For a LocalId with an External Name,
-- makes it into a GlobalId -- makes it into a GlobalId
-- * unchanged Name (might be Internal or External) -- * unchanged Name (might be Internal or External)
-- * unchanged details -- * unchanged details
-- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
globaliseAndTidyId id -- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
= Id.setIdType (globaliseId id) tidy_type globaliseAndTidyBootId id
where = globaliseId id `setIdType` tidyTopType (idType id)
tidy_type = tidyTopType (idType id) `setIdUnfolding` BootUnfolding
{- {-
************************************************************************ ************************************************************************
...@@ -335,13 +347,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -335,13 +347,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags
; print_unqual = mkPrintUnqualified dflags rdr_env ; print_unqual = mkPrintUnqualified dflags rdr_env
} ; implicit_binds = concatMap getImplicitBinds tcs
; let { type_env = typeEnvFromEntities [] tcs fam_insts
; implicit_binds
= concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
} }
; (unfold_env, tidy_occ_env) ; (unfold_env, tidy_occ_env)
...@@ -353,30 +359,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -353,30 +359,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; (tidy_env, tidy_binds) ; (tidy_env, tidy_binds)
<- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds
; let { final_ids = [ id | id <- bindersOfBinds tidy_binds,
isExternalName (idName id)]
; type_env1 = extendTypeEnvWithIds type_env final_ids
; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
-- A DFunId will have a binding in tidy_binds, and so will now be in
-- tidy_type_env, replete with IdInfo. Its name will be unchanged since
-- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
-- tidy_cls_insts. Similarly the Ids inside a PatSyn.
; tidy_rules = tidyRules tidy_env trimmed_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
-- Tidy the Ids inside each PatSyn, very similarly to DFunIds
-- and then override the PatSyns in the type_env with the new tidy ones
-- This is really the only reason we keep mg_patsyns at all; otherwise
-- they could just stay in type_env
; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1
; tidy_type_env = tidyTypeEnv omit_prags type_env2
}
-- See Note [Grand plan for static forms] in StaticPtrTable. -- See Note [Grand plan for static forms] in StaticPtrTable.
; (spt_entries, tidy_binds') <- ; (spt_entries, tidy_binds') <-
sptCreateStaticBinds hsc_env mod tidy_binds sptCreateStaticBinds hsc_env mod tidy_binds
...@@ -388,20 +370,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -388,20 +370,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
HscInterpreted -> id HscInterpreted -> id
-- otherwise add a C stub to do so -- otherwise add a C stub to do so
_ -> (`appendStubC` spt_init_code) _ -> (`appendStubC` spt_init_code)
}
; let { -- See Note [Injecting implicit bindings] -- The completed type environment is gotten from
-- a) the types and classes defined here (plus implicit things)
-- b) adding Ids with correct IdInfo, including unfoldings,
-- gotten from the bindings
-- From (b) we keep only those Ids with External names;
-- the CoreTidy pass makes sure these are all and only
-- the externally-accessible ones
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
--
-- See Note [Don't attempt to trim data types]
; final_ids = [ if omit_prags then trimId id else id
| id <- bindersOfBinds tidy_binds
, isExternalName (idName id)
, not (isWiredInName (getName id))
] -- See Note [Drop wired-in things]
; final_tcs = filterOut (isWiredInName . getName) tcs
-- See Note [Drop wired-in things]
; type_env = typeEnvFromEntities final_ids final_tcs fam_insts
; tidy_cls_insts = mkFinalClsInsts type_env cls_insts
; tidy_patsyns = mkFinalPatSyns type_env patsyns
; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env
; tidy_rules = tidyRules tidy_env trimmed_rules
; -- See Note [Injecting implicit bindings]
all_tidy_binds = implicit_binds ++ tidy_binds' all_tidy_binds = implicit_binds ++ tidy_binds'
-- Get the TyCons to generate code for. Careful! We must use -- Get the TyCons to generate code for. Careful! We must use
-- the untidied TypeEnv here, because we need -- the untidied TyCons here, because we need
-- (a) implicit TyCons arising from types and classes defined -- (a) implicit TyCons arising from types and classes defined
-- in this module -- in this module
-- (b) wired-in TyCons, which are normally removed from the -- (b) wired-in TyCons, which are normally removed from the
-- TypeEnv we put in the ModDetails -- TypeEnv we put in the ModDetails
-- (c) Constructors even if they are not exported (the -- (c) Constructors even if they are not exported (the
-- tidied TypeEnv has trimmed these away) -- tidied TypeEnv has trimmed these away)
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) ; alg_tycons = filter isAlgTyCon tcs
} }
; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
...@@ -444,46 +450,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -444,46 +450,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
tidyTypeEnv :: Bool -- Compiling without -O, so omit prags
-> TypeEnv -> TypeEnv
-- The completed type environment is gotten from
-- a) the types and classes defined here (plus implicit things)
-- b) adding Ids with correct IdInfo, including unfoldings,
-- gotten from the bindings
-- From (b) we keep only those Ids with External names;
-- the CoreTidy pass makes sure these are all and only
-- the externally-accessible ones
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
--
-- See Note [Don't attempt to trim data types]
tidyTypeEnv omit_prags type_env
= let
type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
-- (1) remove wired-in things
type_env2 | omit_prags = mapNameEnv trimThing type_env1
| otherwise = type_env1
-- (2) trimmed if necessary
in
type_env2
-------------------------- --------------------------
trimThing :: TyThing -> TyThing trimId :: Id -> Id
-- Trim off inessentials, for boot files and no -O trimId id
trimThing (AnId id) | not (isImplicitId id)
| not (isImplicitId id) = id `setIdInfo` vanillaIdInfo
= AnId (id `setIdInfo` vanillaIdInfo) | otherwise
= id
trimThing other_thing {- Note [Drop wired-in things]
= other_thing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We never put wired-in TyCons or Ids in an interface file.
They are wired-in, so the compiler knows about them already.
extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns tidy_patsyns type_env
= extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
{-
Note [Don't attempt to trim data types] Note [Don't attempt to trim data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For some time GHC tried to avoid exporting the data constructors For some time GHC tried to avoid exporting the data constructors
...@@ -565,6 +544,11 @@ really just a code generation trick.... binding itself makes no sense. ...@@ -565,6 +544,11 @@ really just a code generation trick.... binding itself makes no sense.
See Note [Data constructor workers] in CorePrep. See Note [Data constructor workers] in CorePrep.
-} -}
getImplicitBinds :: TyCon -> [CoreBind]
getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
where
cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)
getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds tc getTyConImplicitBinds tc
| isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId
......
...@@ -61,7 +61,6 @@ import RnExpr ...@@ -61,7 +61,6 @@ import RnExpr
import RnUtils ( HsDocContext(..) ) import RnUtils ( HsDocContext(..) )
import RnFixity ( lookupFixityRn ) import RnFixity ( lookupFixityRn )
import MkId import MkId
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy ) import TysWiredIn ( unitTy, mkListTy )
import Plugins import Plugins
import DynFlags import DynFlags
...@@ -2560,7 +2559,9 @@ tcRnDeclsi hsc_env local_decls ...@@ -2560,7 +2559,9 @@ tcRnDeclsi hsc_env local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId this_mod id externaliseAndTidyId this_mod id
= do { name' <- externaliseName this_mod (idName id) = do { name' <- externaliseName this_mod (idName id)
; return (globaliseAndTidyId (setIdName id name')) } ; return $ globaliseId id
`setIdName` name'
`setIdType` tidyTopType (idType id) }
{- {-
......
...@@ -14,7 +14,7 @@ module InstEnv ( ...@@ -14,7 +14,7 @@ module InstEnv (
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
instanceDFunId, tidyClsInstDFun, instanceRoughTcs, instanceDFunId, updateClsInstDFun, instanceRoughTcs,
fuzzyClsInstCmp, orphNamesOfClsInst, fuzzyClsInstCmp, orphNamesOfClsInst,
InstEnvs(..), VisibleOrphanModules, InstEnv, InstEnvs(..), VisibleOrphanModules, InstEnv,
...@@ -199,8 +199,8 @@ being equal to ...@@ -199,8 +199,8 @@ being equal to
instanceDFunId :: ClsInst -> DFunId instanceDFunId :: ClsInst -> DFunId
instanceDFunId = is_dfun instanceDFunId = is_dfun
tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
tidyClsInstDFun tidy_dfun ispec updateClsInstDFun tidy_dfun ispec
= ispec { is_dfun = tidy_dfun (is_dfun ispec) } = ispec { is_dfun = tidy_dfun (is_dfun ispec) }
instanceRoughTcs :: ClsInst -> [Maybe Name] instanceRoughTcs :: ClsInst -> [Maybe Name]
......
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
T16608_1:
'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs
./T16608_1
sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs
'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_1.hs
./T16608_1
T16608_2:
'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs
./T16608_2
sed -i -e 's/{- . succ -}/. succ/' MyInteger.hs
'$(TEST_HC)' $(TEST_HC_OPTS) --make -O0 T16608_2.hs
./T16608_2
module MyInteger
( MyInteger (MyInteger)
, ToMyInteger (toMyInteger)
) where
newtype MyInteger = MyInteger Integer
class ToMyInteger a where
toMyInteger :: a -> MyInteger
instance ToMyInteger Integer where
toMyInteger = MyInteger {- . succ -}
module Main
( main
) where
import MyInteger (MyInteger (MyInteger), toMyInteger)
main :: IO ()
main = do
let (MyInteger i) = toMyInteger (41 :: Integer)
print i
[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o )
[2 of 2] Compiling Main ( T16608_1.hs, T16608_1.o )
Linking T16608_1 ...
41
[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o )
Linking T16608_1 ...
42
module Main
( main
) where
import MyInteger (MyInteger (MyInteger), toMyInteger)
main :: IO ()
main = do
let (MyInteger i) = (id . toMyInteger) (41 :: Integer)
print i
[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o )
[2 of 2] Compiling Main ( T16608_2.hs, T16608_2.o )
Linking T16608_2 ...
41
[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o )
Linking T16608_2 ...
42
test('T16608_1', [extra_files(['MyInteger.hs'])], makefile_test, [])
test('T16608_2', [extra_files(['MyInteger.hs'])], makefile_test, [])
Markdown is supported
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