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 (
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,15 +148,7 @@ 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'
return (ModDetails { md_types = type_env'
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
......@@ -165,15 +156,9 @@ mkBootModDetailsTc hsc_env
, 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
--
......@@ -185,29 +170,56 @@ 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)
`setIdUnfolding` BootUnfolding
| id <- ids
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)
trimId :: Id -> Id
trimId id
| not (isImplicitId id)
= AnId (id `setIdInfo` vanillaIdInfo)
= 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