[Git][ghc/ghc][master] Properly trim IdInfos of DFunIds and PatSyns in TidyPgm
Marge Bot
gitlab at gitlab.haskell.org
Thu Jun 20 02:14:33 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
9d58554f by Ömer Sinan Ağacan at 2019-06-20T02:14:26Z
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
- - - - -
12 changed files:
- compiler/basicTypes/PatSyn.hs
- compiler/coreSyn/CoreTidy.hs
- compiler/main/TidyPgm.hs
- compiler/typecheck/TcRnDriver.hs
- compiler/types/InstEnv.hs
- + testsuite/tests/driver/T16608/Makefile
- + testsuite/tests/driver/T16608/MyInteger.hs
- + testsuite/tests/driver/T16608/T16608_1.hs
- + testsuite/tests/driver/T16608/T16608_1.stdout
- + testsuite/tests/driver/T16608/T16608_2.hs
- + testsuite/tests/driver/T16608/T16608_2.stdout
- + testsuite/tests/driver/T16608/all.T
Changes:
=====================================
compiler/basicTypes/PatSyn.hs
=====================================
@@ -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)
=====================================
compiler/coreSyn/CoreTidy.hs
=====================================
@@ -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"
=====================================
compiler/main/TidyPgm.hs
=====================================
@@ -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
=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -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) }
{-
=====================================
compiler/types/InstEnv.hs
=====================================
@@ -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]
=====================================
testsuite/tests/driver/T16608/Makefile
=====================================
@@ -0,0 +1,17 @@
+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
=====================================
testsuite/tests/driver/T16608/MyInteger.hs
=====================================
@@ -0,0 +1,12 @@
+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 -}
=====================================
testsuite/tests/driver/T16608/T16608_1.hs
=====================================
@@ -0,0 +1,11 @@
+module Main
+ ( main
+ ) where
+
+import MyInteger (MyInteger (MyInteger), toMyInteger)
+
+main :: IO ()
+main = do
+ let (MyInteger i) = toMyInteger (41 :: Integer)
+ print i
+
=====================================
testsuite/tests/driver/T16608/T16608_1.stdout
=====================================
@@ -0,0 +1,7 @@
+[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
=====================================
testsuite/tests/driver/T16608/T16608_2.hs
=====================================
@@ -0,0 +1,10 @@
+module Main
+ ( main
+ ) where
+
+import MyInteger (MyInteger (MyInteger), toMyInteger)
+
+main :: IO ()
+main = do
+ let (MyInteger i) = (id . toMyInteger) (41 :: Integer)
+ print i
=====================================
testsuite/tests/driver/T16608/T16608_2.stdout
=====================================
@@ -0,0 +1,7 @@
+[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
=====================================
testsuite/tests/driver/T16608/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T16608_1', [extra_files(['MyInteger.hs'])], makefile_test, [])
+test('T16608_2', [extra_files(['MyInteger.hs'])], makefile_test, [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/9d58554f7b19c52896796e8c3b6de20c154a67b2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/9d58554f7b19c52896796e8c3b6de20c154a67b2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190619/d48db6f4/attachment-0001.html>
More information about the ghc-commits
mailing list