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

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
Pipeline #7391 failed with stages
in 292 minutes and 25 seconds
......@@ -19,7 +19,7 @@ module PatSyn (
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
tidyPatSynIds, pprPatSynType
updatePatSynIds, pprPatSynType
) where
#include "HsVersions.h"
......@@ -417,8 +417,8 @@ patSynMatcher = psMatcher
patSynBuilder :: PatSyn -> Maybe (Id, Bool)
patSynBuilder = psBuilder
tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
= ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
where
tidy_pr (id, dummy) = (tidy_fn id, dummy)
......
......@@ -9,7 +9,7 @@ The code for *top-level* bindings is in TidyPgm.
{-# LANGUAGE CPP #-}
module CoreTidy (
tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
tidyExpr, tidyRule, tidyRules, tidyUnfolding
) where
#include "HsVersions.h"
......
......@@ -7,7 +7,7 @@
{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}
module TidyPgm (
mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
mkBootModDetailsTc, tidyProgram
) where
#include "HsVersions.h"
......@@ -39,13 +39,11 @@ import Id
import MkId ( mkDictSelRhs )
import IdInfo
import InstEnv
import FamInstEnv
import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig )
import BasicTypes
import Name hiding (varName)
import NameSet
import NameEnv
import NameCache
import Avail
import IfaceEnv
......@@ -60,6 +58,7 @@ import HscTypes
import Maybes
import UniqSupply
import Outputable
import Util( filterOut )
import qualified ErrUtils as Err
import Control.Monad
......@@ -149,65 +148,78 @@ mkBootModDetailsTc hsc_env
Err.withTiming (pure dflags)
(text "CoreTidy"<+>brackets (ppr this_mod))
(const ()) $
do { let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
; pat_syns' = map (tidyPatSynIds globaliseAndTidyId) pat_syns
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
(typeEnvIds type_env) tcs fam_insts
; type_env2 = extendTypeEnvWithPatSyns pat_syns' type_env1
; dfun_ids = map instanceDFunId insts'
; type_env' = extendTypeEnvWithIds type_env2 dfun_ids
}
; 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
})
}
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
dflags = hsc_dflags hsc_env
mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
mkBootTypeEnv exports ids tcs fam_insts
= tidyTypeEnv True $
typeEnvFromEntities final_ids tcs fam_insts
where
-- Find the LocalIds in the type env that are exported
-- Make them into GlobalIds, and tidy their types
--
-- It's very important to remove the non-exported ones
-- because we don't tidy the OccNames, and if we don't remove
-- the non-exported ones we'll get many things with the
-- same name in the interface file, giving chaos.
--
-- 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
-- Find the LocalIds in the type env that are exported
-- Make them into GlobalIds, and tidy their types
--
-- It's very important to remove the non-exported ones
-- because we don't tidy the OccNames, and if we don't remove
-- the non-exported ones we'll get many things with the
-- same name in the interface file, giving chaos.
--
-- 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 = [ globaliseAndTidyBootId id
| id <- typeEnvIds type_env
, keep_it id ]
-- default methods have their export flag set, but everything
-- else doesn't (yet), because this is pre-desugaring, so we
-- must test both.
keep_it id = isExportedId id || idName id `elemNameSet` exports
final_tcs = filterOut (isWiredInName . getName) tcs
-- See Note [Drop wired-in things]
type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts
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
-- Takes a LocalId with an External Name,
globaliseAndTidyBootId :: Id -> Id
-- For a LocalId with an External Name,
-- makes it into a GlobalId
-- * unchanged Name (might be Internal or External)
-- * unchanged details
-- * VanillaIdInfo (makes a conservative assumption about Caf-hood)
globaliseAndTidyId id
= Id.setIdType (globaliseId id) tidy_type
where
tidy_type = tidyTopType (idType id)
-- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)
-- * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)
globaliseAndTidyBootId id
= globaliseId id `setIdType` tidyTopType (idType id)
`setIdUnfolding` BootUnfolding
{-
************************************************************************
......@@ -335,13 +347,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
; expose_all = gopt Opt_ExposeAllUnfoldings dflags
; print_unqual = mkPrintUnqualified dflags rdr_env
}
; let { type_env = typeEnvFromEntities [] tcs fam_insts
; implicit_binds
= concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
; implicit_binds = concatMap getImplicitBinds tcs
}
; (unfold_env, tidy_occ_env)
......@@ -353,30 +359,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; (tidy_env, tidy_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.
; (spt_entries, tidy_binds') <-
sptCreateStaticBinds hsc_env mod tidy_binds
......@@ -388,20 +370,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
HscInterpreted -> id
-- otherwise add a C stub to do so
_ -> (`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'
-- 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
-- in this module
-- (b) wired-in TyCons, which are normally removed from the
-- TypeEnv we put in the ModDetails
-- (c) Constructors even if they are not exported (the
-- 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
......@@ -444,46 +450,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
where
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
-- Trim off inessentials, for boot files and no -O
trimThing (AnId id)
| not (isImplicitId id)
= AnId (id `setIdInfo` vanillaIdInfo)
trimId :: Id -> Id
trimId id
| not (isImplicitId id)
= id `setIdInfo` vanillaIdInfo
| otherwise
= id
trimThing other_thing
= other_thing
{- Note [Drop wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
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 tc
| isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId
......
......@@ -61,7 +61,6 @@ import RnExpr
import RnUtils ( HsDocContext(..) )
import RnFixity ( lookupFixityRn )
import MkId
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
import Plugins
import DynFlags
......@@ -2560,7 +2559,9 @@ tcRnDeclsi hsc_env local_decls
externaliseAndTidyId :: Module -> Id -> TcM Id
externaliseAndTidyId this_mod 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 (
OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
instanceDFunId, updateClsInstDFun, instanceRoughTcs,
fuzzyClsInstCmp, orphNamesOfClsInst,
InstEnvs(..), VisibleOrphanModules, InstEnv,
......@@ -199,8 +199,8 @@ being equal to
instanceDFunId :: ClsInst -> DFunId
instanceDFunId = is_dfun
tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
tidyClsInstDFun tidy_dfun ispec
updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst
updateClsInstDFun tidy_dfun ispec
= ispec { is_dfun = tidy_dfun (is_dfun ispec) }
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