ghc-lib 0.20190516 → 0.20190523
raw patch · 18 files changed
+374/−349 lines, 18 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/deSugar/DsMeta.hs +7/−31
- compiler/ghci/Debugger.hs +5/−2
- compiler/ghci/Linker.hs +64/−93
- compiler/hieFile/HieAst.hs +6/−15
- compiler/hsSyn/Convert.hs +15/−22
- compiler/main/DriverMkDepend.hs +14/−1
- compiler/main/GhcMake.hs +55/−10
- compiler/main/HscMain.hs +3/−1
- compiler/main/InteractiveEval.hs +9/−5
- compiler/nativeGen/AsmCodeGen.hs +30/−12
- compiler/nativeGen/RegAlloc/Linear/State.hs +39/−25
- compiler/rename/RnSource.hs +47/−51
- compiler/typecheck/TcSplice.hs +4/−3
- compiler/typecheck/TcTyClsDecls.hs +67/−72
- ghc-lib.cabal +3/−2
- ghc-lib/generated/ghcversion.h +1/−1
- ghc/GHCi/UI.hs +4/−2
- includes/rts/storage/InfoTables.h +1/−1
compiler/deSugar/DsMeta.hs view
@@ -328,7 +328,7 @@ ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds ; fds1 <- repLFunDeps fds ; ats1 <- repFamilyDecls ats- ; atds1 <- repAssocTyFamDefaults atds+ ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds) ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 ; wrapGenSyms ss decls2 }@@ -454,35 +454,8 @@ repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) -repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]-repAssocTyFamDefaults = mapM rep_deflt- where- -- very like repTyFamEqn, but different in the details- rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)- rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc- , feqn_bndrs = bndrs- , feqn_pats = tys- , feqn_fixity = fixity- , feqn_rhs = rhs }))- = addTyClTyVarBinds tys $ \ _ ->- do { tc1 <- lookupLOcc tc- ; no_bndrs <- ASSERT( isNothing bndrs )- coreNothingList tyVarBndrQTyConName- ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)- ; lhs <- case fixity of- Prefix -> do { head_ty <- repNamedTyCon tc1- ; repTapps head_ty tys1 }- Infix -> do { (t1:t2:args) <- checkTys tys1- ; head_ty <- repTInfix t1 tc1 t2- ; repTapps head_ty args }- ; rhs1 <- repLTy rhs- ; eqn1 <- repTySynEqn no_bndrs lhs rhs1- ; repTySynInst eqn1 }- rep_deflt _ = panic "repAssocTyFamDefaults"-- checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]- checkTys tys@(_:_:_) = return tys- checkTys _ = panic "repAssocTyFamDefaults:checkTys"+repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)+repAssocTyFamDefaultD = repTyFamInstD ------------------------- -- represent fundeps@@ -1947,7 +1920,7 @@ ; rep2 mk_varg [pkg,mod,occ] } | otherwise = do { MkC occ <- nameLit name- ; MkC uni <- coreIntLit (getKey (getUnique name))+ ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where mod = ASSERT( isExternalName name) nameModule name@@ -2743,6 +2716,9 @@ coreIntLit :: Int -> DsM (Core Int) coreIntLit i = do dflags <- getDynFlags return (MkC (mkIntExprInt dflags i))++coreIntegerLit :: Integer -> DsM (Core Integer)+coreIntegerLit i = fmap MkC (mkIntegerExpr i) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id)
compiler/ghci/Debugger.hs view
@@ -123,7 +123,8 @@ let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids- liftIO $ extendLinkEnv (zip names fhvs)+ dl = hsc_dynLinker hsc_env+ liftIO $ extendLinkEnv dl (zip names fhvs) setSession hsc_env {hsc_IC = new_ic } return t' where@@ -177,8 +178,10 @@ expr = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String"+ dl = hsc_dynLinker hsc_env _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}- txt_ <- withExtendedLinkEnv [(bname, fhv)]+ txt_ <- withExtendedLinkEnv dl+ [(bname, fhv)] (GHC.compileExprRemote expr) let myprec = 10 -- application precedence. TODO Infix constructors txt <- liftIO $ evalString hsc_env txt_
compiler/ghci/Linker.hs view
@@ -15,8 +15,9 @@ linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs,- linkPackages,initDynLinker,linkModule,- linkCmdLineLibs+ linkPackages, initDynLinker, linkModule,+ linkCmdLineLibs,+ uninitializedLinker ) where #include "HsVersions.h"@@ -38,6 +39,7 @@ import NameEnv import Module import ListSetOps+import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) import DynFlags import BasicTypes import Outputable@@ -72,11 +74,6 @@ import Exception --- needed for 2nd stage-#if STAGE >= 2-import Foreign (Ptr)-#endif- {- ********************************************************************** The Linker's state@@ -85,76 +82,40 @@ {- The persistent linker state *must* match the actual state of the-C dynamic linker at all times, so we keep it in a private global variable.+C dynamic linker at all times. -The global IORef used for PersistentLinkerState actually contains another MVar,-which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure-mutual exclusion between multiple loaded copies of the GHC library. The Maybe-may be Nothing to indicate that the linker has not yet been initialised.+The MVar used to hold the PersistentLinkerState contains a Maybe+PersistentLinkerState. The MVar serves to ensure mutual exclusion between+multiple loaded copies of the GHC library. The Maybe may be Nothing to+indicate that the linker has not yet been initialised. The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. -}-#if STAGE < 2-GLOBAL_VAR_M( v_PersistentLinkerState- , newMVar Nothing- , MVar (Maybe PersistentLinkerState))-#else-SHARED_GLOBAL_VAR_M( v_PersistentLinkerState- , getOrSetLibHSghcPersistentLinkerState- , "getOrSetLibHSghcPersistentLinkerState"- , newMVar Nothing- , MVar (Maybe PersistentLinkerState))-#endif +uninitializedLinker :: IO DynLinker+uninitializedLinker =+ newMVar Nothing >>= (pure . DynLinker)+ uninitialised :: a uninitialised = panic "Dynamic linker not initialised" -modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()-modifyPLS_ f = readIORef v_PersistentLinkerState- >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)+modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()+modifyPLS_ dl f =+ modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised) -modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a-modifyPLS f = readIORef v_PersistentLinkerState- >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)+modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a+modifyPLS dl f =+ modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised) where fmapFst f = fmap (\(x, y) -> (f x, y)) -readPLS :: IO PersistentLinkerState-readPLS = readIORef v_PersistentLinkerState- >>= fmap (fromMaybe uninitialised) . readMVar+readPLS :: DynLinker -> IO PersistentLinkerState+readPLS dl =+ (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl) modifyMbPLS_- :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()-modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f--data PersistentLinkerState- = PersistentLinkerState {-- -- Current global mapping from Names to their true values- closure_env :: ClosureEnv,-- -- The current global mapping from RdrNames of DataCons to- -- info table addresses.- -- When a new Unlinked is linked into the running image, or an existing- -- module in the image is replaced, the itbl_env must be updated- -- appropriately.- itbl_env :: !ItblEnv,-- -- The currently loaded interpreted modules (home package)- bcos_loaded :: ![Linkable],-- -- And the currently-loaded compiled modules (home package)- objs_loaded :: ![Linkable],-- -- The currently-loaded packages; always object code- -- Held, as usual, in dependency order; though I am not sure if- -- that is really important- pkgs_loaded :: ![LinkerUnitId],-- -- we need to remember the name of previous temporary DLL/.so- -- libraries so we can link them (see #10322)- temp_sos :: ![(FilePath, String)] }-+ :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f emptyPLS :: DynFlags -> PersistentLinkerState emptyPLS _ = PersistentLinkerState {@@ -172,22 +133,21 @@ -- explicit list. See rts/Linker.c for details. where init_pkgs = map toInstalledUnitId [rtsUnitId] --extendLoadedPkgs :: [InstalledUnitId] -> IO ()-extendLoadedPkgs pkgs =- modifyPLS_ $ \s ->+extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO ()+extendLoadedPkgs dl pkgs =+ modifyPLS_ dl $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } -extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()-extendLinkEnv new_bindings =- modifyPLS_ $ \pls@PersistentLinkerState{..} -> do+extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()+extendLinkEnv dl new_bindings =+ modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do let new_ce = extendClosureEnv closure_env new_bindings return $! pls{ closure_env = new_ce } -- strictness is important for not retaining old copies of the pls -deleteFromLinkEnv :: [Name] -> IO ()-deleteFromLinkEnv to_remove =- modifyPLS_ $ \pls -> do+deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()+deleteFromLinkEnv dl to_remove =+ modifyPLS_ dl $ \pls -> do let ce = closure_env pls let new_ce = delListFromNameEnv ce to_remove return pls{ closure_env = new_ce }@@ -199,8 +159,9 @@ -- Throws a 'ProgramError' if loading fails or the name cannot be found. getHValue :: HscEnv -> Name -> IO ForeignHValue getHValue hsc_env name = do+ let dl = hsc_dynLinker hsc_env initDynLinker hsc_env- pls <- modifyPLS $ \pls -> do+ pls <- modifyPLS dl $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]@@ -223,7 +184,7 @@ -> SrcSpan -> [Module] -> IO (PersistentLinkerState, SuccessFlag) linkDependencies hsc_env pls span needed_mods = do--- initDynLinker (hsc_dflags hsc_env)+-- initDynLinker (hsc_dflags hsc_env) dl let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built@@ -244,9 +205,9 @@ -- | Temporarily extend the linker state. withExtendedLinkEnv :: (ExceptionMonad m) =>- [(Name,ForeignHValue)] -> m a -> m a-withExtendedLinkEnv new_env action- = gbracket (liftIO $ extendLinkEnv new_env)+ DynLinker -> [(Name,ForeignHValue)] -> m a -> m a+withExtendedLinkEnv dl new_env action+ = gbracket (liftIO $ extendLinkEnv dl new_env) (\_ -> reset_old_env) (\_ -> action) where@@ -256,16 +217,16 @@ -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ do- modifyPLS_ $ \pls ->+ modifyPLS_ dl $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } -- | Display the persistent linker state.-showLinkerState :: DynFlags -> IO ()-showLinkerState dflags- = do pls <- readPLS+showLinkerState :: DynLinker -> DynFlags -> IO ()+showLinkerState dl dflags+ = do pls <- readPLS dl putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags) (vcat [text "----- Linker state -----",@@ -299,8 +260,9 @@ -- trying to link. -- initDynLinker :: HscEnv -> IO ()-initDynLinker hsc_env =- modifyMbPLS_ $ \pls -> do+initDynLinker hsc_env = do+ let dl = hsc_dynLinker hsc_env+ modifyMbPLS_ dl $ \pls -> do case pls of Just _ -> return pls Nothing -> Just <$> reallyInitDynLinker hsc_env@@ -323,8 +285,9 @@ linkCmdLineLibs :: HscEnv -> IO () linkCmdLineLibs hsc_env = do+ let dl = hsc_dynLinker hsc_env initDynLinker hsc_env- modifyPLS_ $ \pls -> do+ modifyPLS_ dl $ \pls -> do linkCmdLineLibs' hsc_env pls linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState@@ -548,8 +511,11 @@ -- Initialise the linker (if it's not been done already) ; initDynLinker hsc_env + -- Extract the DynLinker value for passing into required places+ ; let dl = hsc_dynLinker hsc_env+ -- Take lock for the actual work.- ; modifyPLS $ \pls0 -> do {+ ; modifyPLS dl $ \pls0 -> do { -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods@@ -778,8 +744,11 @@ -- Initialise the linker (if it's not been done already) initDynLinker hsc_env + -- Extract the DynLinker for passing into required places+ let dl = hsc_dynLinker hsc_env+ -- Take lock for the actual work.- modifyPLS $ \pls0 -> do+ modifyPLS dl $ \pls0 -> do -- Link the packages and modules required (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods@@ -820,7 +789,8 @@ linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do initDynLinker hsc_env- modifyPLS_ $ \pls -> do+ let dl = hsc_dynLinker hsc_env+ modifyPLS_ dl $ \pls -> do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") else return pls'@@ -1084,8 +1054,11 @@ -- Initialise the linker (if it's not been done already) initDynLinker hsc_env + -- Extract DynLinker for passing into required places+ let dl = hsc_dynLinker hsc_env+ new_pls- <- modifyPLS $ \pls -> do+ <- modifyPLS dl $ \pls -> do pls1 <- unload_wkr hsc_env linkables pls return (pls1, pls1) @@ -1206,9 +1179,6 @@ showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm --- TODO: Make this type more precise-type LinkerUnitId = InstalledUnitId- -- | Link exactly the specified packages, and their dependents (unless of -- course they are already linked). The dependents are linked -- automatically, and it doesn't matter what order you specify the input@@ -1227,7 +1197,8 @@ -- It's probably not safe to try to load packages concurrently, so we take -- a lock. initDynLinker hsc_env- modifyPLS_ $ \pls -> do+ let dl = hsc_dynLinker hsc_env+ modifyPLS_ dl $ \pls -> do linkPackages' hsc_env new_pkgs pls linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
compiler/hieFile/HieAst.hs view
@@ -333,7 +333,7 @@ loc [] = noSrcSpan loc xs = foldl1' combineSrcSpans $ map loc xs -instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where+instance HasLoc a => HasLoc (FamEqn s a) where loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]@@ -1149,18 +1149,12 @@ , toHie $ fmap (BC InstanceBind ModuleScope) meths , toHie typs , concatMapM (pure . locOnly . getLoc) deftyps- , toHie $ map (go . unLoc) deftyps+ , toHie deftyps ] where context_scope = mkLScope context rhs_scope = foldl1' combineScopes $ map mkScope [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]-- go :: TyFamDefltEqn GhcRn- -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)- go (FamEqn a var bndrs pat b rhs) =- FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs- go (XFamEqn NoExt) = XFamEqn NoExt XTyClDecl _ -> [] instance ToHie (LFamilyDecl GhcRn) where@@ -1206,15 +1200,12 @@ , toHie $ map (C Use) rhs ] -instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)- => ToHie (TScoped (FamEqn GhcRn pats rhs)) where+instance (ToHie rhs, HasLoc rhs)+ => ToHie (TScoped (FamEqn GhcRn rhs)) where toHie (TS _ f) = toHie f -instance ( ToHie pats- , ToHie rhs- , HasLoc pats- , HasLoc rhs- ) => ToHie (FamEqn GhcRn pats rhs) where+instance (ToHie rhs, HasLoc rhs)+ => ToHie (FamEqn GhcRn rhs) where toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
compiler/hsSyn/Convert.hs view
@@ -243,33 +243,26 @@ cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds- ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs+ ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs ; unless (null adts') (failWith $ (text "Default data instance declarations" <+> text "are not allowed:") $$ (Outputable.ppr adts'))- ; at_defs <- mapM cvt_at_def ats' ; returnJustL $ TyClD noExt $ ClassDecl { tcdCExt = noExt , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdMeths = binds'- , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }+ , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] } -- no docs in TH ^^ }- where- cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)- -- Very similar to what happens in RdrHsSyn.mkClassDecl- cvt_at_def decl = case RdrHsSyn.mkATDefault decl of- Right (def, _) -> return def- Left (_, msg) -> failWith msg cvtDec (InstanceD o ctxt ty decs) = do { let doc = text "an instance declaration" ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams'))- ; ctxt' <- cvtContext ctxt+ ; ctxt' <- cvtContext funPrec ctxt ; (dL->L loc ty') <- cvtType ty ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' ; returnJustL $ InstD noExt $ ClsInstD noExt $@@ -365,7 +358,7 @@ ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') } cvtDec (TH.StandaloneDerivD ds cxt ty)- = do { cxt' <- cvtContext cxt+ = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds ; (dL->L loc ty') <- cvtType ty ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'@@ -471,7 +464,7 @@ , Located RdrName , LHsQTyVars GhcPs) cvt_tycl_hdr cxt tc tvs- = do { cxt' <- cvtContext cxt+ = do { cxt' <- cvtContext funPrec cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs ; return (cxt', tc', tvs')@@ -483,7 +476,7 @@ , Maybe [LHsTyVarBndr GhcPs] , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys- = do { cxt' <- cvtContext cxt+ = do { cxt' <- cvtContext funPrec cxt ; bndrs' <- traverse (mapM cvt_tv) bndrs ; (head_ty, args) <- split_ty_app tys ; case head_ty of@@ -573,7 +566,7 @@ cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs- ; ctxt' <- cvtContext ctxt+ ; ctxt' <- cvtContext funPrec ctxt ; (dL->L _ con') <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where@@ -1304,8 +1297,9 @@ cvtRole TH.PhantomR = Just Coercion.Phantom cvtRole TH.InferR = Nothing -cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)-cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }+cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)+cvtContext p tys = do { preds' <- mapM cvtPred tys+ ; parenthesizeHsContext p <$> returnL preds' } cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType@@ -1313,7 +1307,7 @@ cvtDerivClause :: TH.DerivClause -> CvtM (LHsDerivingClause GhcPs) cvtDerivClause (TH.DerivClause ds ctxt)- = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt+ = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt ; ds' <- traverse cvtDerivStrategy ds ; returnL $ HsDerivingClause noExt ds' ctxt' } @@ -1409,12 +1403,11 @@ ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs- ; cxt' <- cvtContext cxt- ; let pcxt = parenthesizeHsContext funPrec cxt'+ ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty- rho_ty = mkHsQualTy cxt loc pcxt ty'+ rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } @@ -1831,8 +1824,8 @@ = case th_name of TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ- TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)- TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)+ TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)+ TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name | otherwise -> mkRdrUnqual $! occ -- We check for built-in syntax here, because the TH
compiler/main/DriverMkDepend.hs view
@@ -41,6 +41,7 @@ import System.IO.Error ( isEOFError ) import Control.Monad ( when ) import Data.Maybe ( isJust )+import Data.IORef ----------------------------------------------------------------- --@@ -85,7 +86,7 @@ -- Print out the dependencies if wanted liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) - -- Prcess them one by one, dumping results into makefile+ -- Process them one by one, dumping results into makefile -- and complaining about cycles hsc_env <- getSession root <- liftIO getCurrentDirectory@@ -223,6 +224,18 @@ -- Emit std dependency of the object(s) on the source file -- Something like A.o : A.hs ; writeDependency root hdl obj_files src_file++ -- Emit a dependency for each CPP import+ ; when (depIncludeCppDeps dflags) $ do+ -- CPP deps are descovered in the module parsing phase by parsing+ -- comment lines left by the preprocessor.+ -- Note that GHC.parseModule may throw an exception if the module+ -- fails to parse, which may not be desirable (see #16616).+ { session <- Session <$> newIORef hsc_env+ ; parsedMod <- reflectGhc (GHC.parseModule node) session+ ; mapM_ (writeDependency root hdl obj_files)+ (GHC.pm_extra_src_files parsedMod)+ } -- Emit a dependency for each import
compiler/main/GhcMake.hs view
@@ -1430,6 +1430,7 @@ && (not (isObjectTarget prevailing_target) || not (isObjectTarget local_target)) && not (prevailing_target == HscNothing)+ && not (prevailing_target == HscInterpreted) then prevailing_target else local_target @@ -1955,7 +1956,11 @@ then enableCodeGenForTH (defaultObjectTarget (settings dflags)) map0- else return map0+ else if hscTarget dflags == HscInterpreted+ then enableCodeGenForUnboxedTuples+ (defaultObjectTarget (settings dflags))+ map0+ else return map0 return $ concat $ nodeMapElts map1 where calcDeps = msDeps@@ -2034,7 +2039,50 @@ enableCodeGenForTH :: HscTarget -> NodeMap [Either ErrMsg ModSummary] -> IO (NodeMap [Either ErrMsg ModSummary])-enableCodeGenForTH target nodemap =+enableCodeGenForTH =+ enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession+ where+ condition = isTemplateHaskellOrQQNonBoot+ should_modify (ModSummary { ms_hspp_opts = dflags }) =+ hscTarget dflags == HscNothing &&+ -- Don't enable codegen for TH on indefinite packages; we+ -- can't compile anything anyway! See #16219.+ not (isIndefinite dflags)++-- | Update the every ModSummary that is depended on+-- by a module that needs unboxed tuples. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+--+-- This is used used in order to load code that uses unboxed tuples+-- into GHCi while still allowing some code to be interpreted.+enableCodeGenForUnboxedTuples :: HscTarget+ -> NodeMap [Either ErrMsg ModSummary]+ -> IO (NodeMap [Either ErrMsg ModSummary])+enableCodeGenForUnboxedTuples =+ enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule+ where+ condition ms =+ xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&+ not (isBootSummary ms)+ should_modify (ModSummary { ms_hspp_opts = dflags }) =+ hscTarget dflags == HscInterpreted++-- | Helper used to implement 'enableCodeGenForTH' and+-- 'enableCodeGenForUnboxedTuples'. In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+ :: (ModSummary -> Bool)+ -> (ModSummary -> Bool)+ -> TempFileLifetime+ -> TempFileLifetime+ -> HscTarget+ -> NodeMap [Either ErrMsg ModSummary]+ -> IO (NodeMap [Either ErrMsg ModSummary])+enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where enable_code_gen ms@@ -2042,18 +2090,15 @@ { ms_mod = ms_mod , ms_location = ms_location , ms_hsc_src = HsSrcFile- , ms_hspp_opts = dflags@DynFlags- {hscTarget = HscNothing}+ , ms_hspp_opts = dflags } <- ms- -- Don't enable codegen for TH on indefinite packages; we- -- can't compile anything anyway! See #16219.- , not (isIndefinite dflags)+ , should_modify ms , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do- tn <- newTempName dflags TFL_CurrentModule suf+ tn <- newTempName dflags staticLife suf let dyn_tn = tn -<.> dynsuf- addFilesToClean dflags TFL_GhcSession [dyn_tn]+ addFilesToClean dflags dynLife [dyn_tn] return tn -- We don't want to create .o or .hi files unless we have been asked -- to by the user. But we need them, so we patch their locations in@@ -2076,7 +2121,7 @@ [ ms | mss <- Map.elems nodemap , Right ms <- mss- , isTemplateHaskellOrQQNonBoot ms+ , condition ms ] -- find the set of all transitive dependencies of a list of modules.
compiler/main/HscMain.hs view
@@ -193,6 +193,7 @@ nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv iserv_mvar <- newMVar Nothing+ emptyDynLinker <- uninitializedLinker return HscEnv { hsc_dflags = dflags , hsc_targets = [] , hsc_mod_graph = emptyMG@@ -202,7 +203,8 @@ , hsc_NC = nc_var , hsc_FC = fc_var , hsc_type_env_var = Nothing- , hsc_iserv = iserv_mvar+ , hsc_iserv = iserv_mvar+ , hsc_dynLinker = emptyDynLinker } -- -----------------------------------------------------------------------------
compiler/main/InteractiveEval.hs view
@@ -357,7 +357,8 @@ = do hsc_env <- getSession let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids final_names = map getName final_ids- liftIO $ Linker.extendLinkEnv (zip final_names hvals)+ dl = hsc_dynLinker hsc_env+ liftIO $ Linker.extendLinkEnv dl (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' return (ExecComplete (Right final_names) allocs)@@ -396,7 +397,8 @@ new_names = [ n | thing <- ic_tythings ic , let n = getName thing , not (n `elem` old_names) ]- liftIO $ Linker.deleteFromLinkEnv new_names+ dl = hsc_dynLinker hsc_env+ liftIO $ Linker.deleteFromLinkEnv dl new_names case r of Resume { resumeStmt = expr, resumeContext = fhv@@ -490,8 +492,9 @@ ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]+ dl = hsc_dynLinker hsc_env --- Linker.extendLinkEnv [(exn_name, apStack)]+ Linker.extendLinkEnv dl [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") -- Just case: we stopped at a breakpoint, we have information about the location@@ -548,10 +551,11 @@ ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids names = map idName new_ids+ dl = hsc_dynLinker hsc_env let fhvs = catMaybes mb_hValues- Linker.extendLinkEnv (zip names fhvs)- when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]+ Linker.extendLinkEnv dl (zip names fhvs)+ when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names, span, decl) where
compiler/nativeGen/AsmCodeGen.hs view
@@ -6,8 +6,12 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-} +#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE UnboxedTuples #-}+#endif+ module AsmCodeGen ( -- * Module entry point nativeCodeGen@@ -1024,36 +1028,50 @@ do blocks' <- mapM cmmBlockConFold (toBlockList graph) return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') -newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))+-- Avoids using unboxed tuples when loading into GHCi+#if !defined(GHC_LOADED_INTO_GHCI) +type OptMResult a = (# a, [CLabel] #)++pattern OptMResult :: a -> b -> (# a, b #)+pattern OptMResult x y = (# x, y #)+{-# COMPLETE OptMResult #-}+#else++data OptMResult a = OptMResult !a ![CLabel]+#endif++newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)+ instance Functor CmmOptM where fmap = liftM instance Applicative CmmOptM where- pure x = CmmOptM $ \_ _ imports -> (# x, imports #)+ pure x = CmmOptM $ \_ _ imports -> OptMResult x imports (<*>) = ap instance Monad CmmOptM where (CmmOptM f) >>= g =- CmmOptM $ \dflags this_mod imports ->- case f dflags this_mod imports of- (# x, imports' #) ->+ CmmOptM $ \dflags this_mod imports0 ->+ case f dflags this_mod imports0 of+ OptMResult x imports1 -> case g x of- CmmOptM g' -> g' dflags this_mod imports'+ CmmOptM g' -> g' dflags this_mod imports1 instance CmmMakeDynamicReferenceM CmmOptM where addImport = addImportCmmOpt- getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)+ getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports addImportCmmOpt :: CLabel -> CmmOptM ()-addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports) instance HasDynFlags CmmOptM where- getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)+ getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])-runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of- (# result, imports #) -> (result, imports)+runCmmOpt dflags this_mod (CmmOptM f) =+ case f dflags this_mod [] of+ OptMResult result imports -> (result, imports) cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock cmmBlockConFold block = do
compiler/nativeGen/RegAlloc/Linear/State.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE CPP, PatternSynonyms #-}++#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}+#endif -- | State monad for the linear register allocator. @@ -48,22 +52,36 @@ import Control.Monad (liftM, ap) +-- Avoids using unboxed tuples when loading into GHCi+#if !defined(GHC_LOADED_INTO_GHCI)++type RA_Result freeRegs a = (# RA_State freeRegs, a #)++pattern RA_Result :: a -> b -> (# a, b #)+pattern RA_Result a b = (# a, b #)+{-# COMPLETE RA_Result #-}+#else++data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a++#endif+ -- | The register allocator monad type. newtype RegM freeRegs a- = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }+ = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a } instance Functor (RegM freeRegs) where fmap = liftM instance Applicative (RegM freeRegs) where- pure a = RegM $ \s -> (# s, a #)+ pure a = RegM $ \s -> RA_Result s a (<*>) = ap instance Monad (RegM freeRegs) where- m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }+ m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } instance HasDynFlags (RegM a) where- getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)+ getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s) -- | Run a computation in the RegM register allocator monad.@@ -89,12 +107,8 @@ , ra_DynFlags = dflags , ra_fixups = [] }) of- (# state'@RA_State- { ra_blockassig = block_assig- , ra_stack = stack' }- , returned_thing #)-- -> (block_assig, stack', makeRAStats state', returned_thing)+ RA_Result state returned_thing+ -> (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing) -- | Make register allocator stats from its final state.@@ -108,12 +122,12 @@ spillR :: Instruction instr => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} -> let dflags = ra_DynFlags s- (stack',slot) = getStackSlotFor stack temp+ (stack1,slot) = getStackSlotFor stack0 temp instr = mkSpillInstr dflags reg delta slot in- (# s{ra_stack=stack'}, (instr,slot) #)+ RA_Result s{ra_stack=stack1} (instr,slot) loadR :: Instruction instr@@ -121,51 +135,51 @@ loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> let dflags = ra_DynFlags s- in (# s, mkLoadInstr dflags reg delta slot #)+ in RA_Result s (mkLoadInstr dflags reg delta slot) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->- (# s, freeregs #)+ RA_Result s freeregs setFreeRegsR :: freeRegs -> RegM freeRegs () setFreeRegsR regs = RegM $ \ s ->- (# s{ra_freeregs = regs}, () #)+ RA_Result s{ra_freeregs = regs} () getAssigR :: RegM freeRegs (RegMap Loc) getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->- (# s, assig #)+ RA_Result s assig setAssigR :: RegMap Loc -> RegM freeRegs () setAssigR assig = RegM $ \ s ->- (# s{ra_assig=assig}, () #)+ RA_Result s{ra_assig=assig} () getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->- (# s, assig #)+ RA_Result s assig setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () setBlockAssigR assig = RegM $ \ s ->- (# s{ra_blockassig = assig}, () #)+ RA_Result s{ra_blockassig = assig} () setDeltaR :: Int -> RegM freeRegs () setDeltaR n = RegM $ \ s ->- (# s{ra_delta = n}, () #)+ RA_Result s{ra_delta = n} () getDeltaR :: RegM freeRegs Int-getDeltaR = RegM $ \s -> (# s, ra_delta s #)+getDeltaR = RegM $ \s -> RA_Result s (ra_delta s) getUniqueR :: RegM freeRegs Unique getUniqueR = RegM $ \s -> case takeUniqFromSupply (ra_us s) of- (uniq, us) -> (# s{ra_us = us}, uniq #)+ (uniq, us) -> RA_Result s{ra_us = us} uniq -- | Record that a spill instruction was inserted, for profiling. recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill- = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)+ = RegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) () -- | Record a created fixup block recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs () recordFixupBlock from between to- = RegM $ \s -> (# s { ra_fixups = (from,between,to) : ra_fixups s}, () #)+ = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
compiler/rename/RnSource.hs view
@@ -424,11 +424,11 @@ rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })- = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi+ = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) } rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })- = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi+ = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) } rnSrcInstDecl (ClsInstD { cid_inst = cid })@@ -666,21 +666,22 @@ rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl" rnFamInstEqn :: HsDocContext- -> Maybe (Name, [Name]) -- Nothing => not associated- -- Just (cls,tvs) => associated,- -- and gives class and tyvars of the- -- parent instance decl+ -> AssocTyFamInfo -> [Located RdrName] -- Kind variables from the equation's RHS -> FamInstEqn GhcPs rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) -> RnM (FamInstEqn GhcRn rhs', FreeVars)-rnFamInstEqn doc mb_cls rhs_kvars+rnFamInstEqn doc atfi rhs_kvars (HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_bndrs = mb_bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = payload }}) rn_payload- = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon+ = do { let mb_cls = case atfi of+ NonAssocTyFamEqn -> Nothing+ AssocTyFamDeflt cls -> Just cls+ AssocTyFamInst cls _ -> Just cls+ ; tycon' <- lookupFamInstName mb_cls tycon ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats -- Use the "...Dups" form because it's needed -- below to report unsed binder on the LHS@@ -730,9 +731,10 @@ -- Note [Unused type variables in family instances] ; let nms_used = extendNameSetList rhs_fvs $ inst_tvs ++ nms_dups- inst_tvs = case mb_cls of- Nothing -> []- Just (_, inst_tvs) -> inst_tvs+ inst_tvs = case atfi of+ NonAssocTyFamEqn -> []+ AssocTyFamDeflt _ -> []+ AssocTyFamInst _ inst_tvs -> inst_tvs all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' ; warnUnusedTypePatterns all_nms nms_used @@ -753,15 +755,27 @@ rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn" rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn" -rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated,- -- and gives class and tyvars of- -- the parent instance decl+rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars)-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })- = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })+ = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } +-- | Tracks whether we are renaming:+--+-- 1. A type family equation that is not associated+-- with a parent type class ('NonAssocTyFamEqn')+--+-- 2. An associated type family default delcaration ('AssocTyFamDeflt')+--+-- 3. An associated type family instance declaration ('AssocTyFamInst')+data AssocTyFamInfo+ = NonAssocTyFamEqn+ | AssocTyFamDeflt Name -- Name of the parent class+ | AssocTyFamInst Name -- Name of the parent class+ [Name] -- Names of the tyvars of the parent instance decl+ -- | Tracks whether we are renaming an equation in a closed type family -- equation ('ClosedTyFam') or not ('NotClosedTyFam'). data ClosedTyFamInfo@@ -769,17 +783,17 @@ | ClosedTyFam (Located RdrName) Name -- The names (RdrName and Name) of the closed type family -rnTyFamInstEqn :: Maybe (Name, [Name])+rnTyFamInstEqn :: AssocTyFamInfo -> ClosedTyFamInfo -> TyFamInstEqn GhcPs -> RnM (TyFamInstEqn GhcRn, FreeVars)-rnTyFamInstEqn mb_cls ctf_info+rnTyFamInstEqn atfi ctf_info eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_rhs = rhs }}) = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs ; (eqn'@(HsIB { hsib_body = FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)- <- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn+ <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn ; case ctf_info of NotClosedTyFam -> pure () ClosedTyFam fam_rdr_name fam_name ->@@ -790,38 +804,20 @@ rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn" rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn" -rnTyFamDefltEqn :: Name- -> TyFamDefltEqn GhcPs- -> RnM (TyFamDefltEqn GhcRn, FreeVars)-rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon- , feqn_bndrs = bndrs- , feqn_pats = tyvars- , feqn_fixity = fixity- , feqn_rhs = rhs })- = do { let kvs = extractHsTyRdrTyVarsKindVars rhs- ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->- do { tycon' <- lookupFamInstName (Just cls) tycon- ; (rhs', fvs) <- rnLHsType ctx rhs- ; return (FamEqn { feqn_ext = noExt- , feqn_tycon = tycon'- , feqn_bndrs = ASSERT( isNothing bndrs )- Nothing- , feqn_pats = tyvars'- , feqn_fixity = fixity- , feqn_rhs = rhs' }, fvs) } }- where- ctx = TyFamilyCtx tycon-rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"+rnTyFamDefltDecl :: Name+ -> TyFamDefltDecl GhcPs+ -> RnM (TyFamDefltDecl GhcRn, FreeVars)+rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) -rnDataFamInstDecl :: Maybe (Name, [Name])+rnDataFamInstDecl :: AssocTyFamInfo -> DataFamInstDecl GhcPs -> RnM (DataFamInstDecl GhcRn, FreeVars)-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =- FamEqn { feqn_tycon = tycon- , feqn_rhs = rhs }})})+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =+ FamEqn { feqn_tycon = tycon+ , feqn_rhs = rhs }})}) = do { let rhs_kvs = extractDataDefnKindVars rhs ; (eqn', fvs) <-- rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn+ rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "rnDataFamInstDecl"@@ -837,8 +833,8 @@ rnATDecls cls at_decls = rnList (rnFamDecl (Just cls)) at_decls -rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames- decl GhcPs -> -- an instance. rnTyFamInstDecl+rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames+ decl GhcPs -> -- an instance. rnTyFamInstDecl RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl -> Name -- Class -> [Name]@@ -850,7 +846,7 @@ -- NB: We allow duplicate associated-type decls; -- See Note [Associated type instances] in TcInstDcls rnATInstDecls rnFun cls tv_ns at_insts- = rnList (rnFun (Just (cls, tv_ns))) at_insts+ = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts -- See Note [Renaming associated types] {- Note [Wildcards in family instances]@@ -1585,7 +1581,7 @@ fv_ats ; return ((tyvars', context', fds', ats'), fvs) } - ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs+ ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn@@ -1884,7 +1880,7 @@ -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs)- <- rnList (rnTyFamInstEqn Nothing (ClosedTyFam tycon fam_name))+ <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) -- no class context eqns ; return (ClosedTypeFamily (Just eqns'), fvs) }
compiler/typecheck/TcSplice.hs view
@@ -922,7 +922,7 @@ instance TH.Quasi TcM where qNewName s = do { u <- newUnique- ; let i = getKey u+ ; let i = toInteger (getKey u) ; return (TH.mkNameU s i) } -- 'msg' is forced to ensure exceptions don't escape,@@ -1947,8 +1947,9 @@ ------------------------------ reifyName :: NamedThing n => n -> TH.Name reifyName thing- | isExternalName name = mk_varg pkg_str mod_str occ_str- | otherwise = TH.mkNameU occ_str (getKey (getUnique name))+ | isExternalName name+ = mk_varg pkg_str mod_str occ_str+ | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) -- Many of the things we reify have local bindings, and -- NameL's aren't supposed to appear in binding positions, so -- we use NameU. When/if we start to reify nested things, that
compiler/typecheck/TcTyClsDecls.hs view
@@ -74,6 +74,7 @@ import Control.Monad import Data.Foldable+import Data.Function ( on ) import Data.List import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) )@@ -1412,7 +1413,7 @@ tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]- -> [LFamilyDecl GhcRn] -> [LTyFamDefltEqn GhcRn]+ -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs = fixM $ \ clas ->@@ -1478,10 +1479,10 @@ families. -} -tcClassATs :: Name -- The class name (not knot-tied)- -> Class -- The class parent of this associated type- -> [LFamilyDecl GhcRn] -- Associated types.- -> [LTyFamDefltEqn GhcRn] -- Associated type defaults.+tcClassATs :: Name -- The class name (not knot-tied)+ -> Class -- The class parent of this associated type+ -> [LFamilyDecl GhcRn] -- Associated types.+ -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs = do { -- Complain about associated type defaults for non associated-types@@ -1490,15 +1491,15 @@ , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where- at_def_tycon :: LTyFamDefltEqn GhcRn -> Name- at_def_tycon (dL->L _ eqn) = unLoc (feqn_tycon eqn)+ at_def_tycon :: LTyFamDefltDecl GhcRn -> Name+ at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn at_fam_name :: LFamilyDecl GhcRn -> Name at_fam_name (dL->L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) - at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]+ at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (at_def_tycon at_def) [at_def])@@ -1511,61 +1512,61 @@ ; return (ATI fam_tc atd) } --------------------------tcDefaultAssocDecl :: TyCon -- ^ Family TyCon (not knot-tied)- -> [LTyFamDefltEqn GhcRn] -- ^ Defaults- -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS+tcDefaultAssocDecl ::+ TyCon -- ^ Family TyCon (not knot-tied)+ -> [LTyFamDefltDecl GhcRn] -- ^ Defaults+ -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS tcDefaultAssocDecl _ [] = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) = failWithTc (text "More than one default declaration for"- <+> ppr (feqn_tycon (unLoc d1)))+ <+> ppr (tyFamInstDeclName (unLoc d1))) -tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name- , feqn_pats = hs_tvs- , feqn_rhs = hs_rhs_ty })]- | HsQTvs { hsq_ext = imp_vars- , hsq_explicit = exp_vars } <- hs_tvs+tcDefaultAssocDecl fam_tc+ [dL->L loc (TyFamInstDecl { tfid_eqn =+ HsIB { hsib_ext = imp_vars+ , hsib_body = FamEqn { feqn_tycon = L _ tc_name+ , feqn_bndrs = mb_expl_bndrs+ , feqn_pats = hs_pats+ , feqn_rhs = hs_rhs_ty }}})] = -- See Note [Type-checking default assoc decls] setSrcSpan loc $ tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) ; let fam_tc_name = tyConName fam_tc- fam_arity = length (tyConVisibleTyVars fam_tc)+ vis_arity = length (tyConVisibleTyVars fam_tc)+ vis_pats = numVisibleArgs hs_pats -- Kind of family check ; ASSERT( fam_tc_name == tc_name ) checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Arity check- ; checkTc (exp_vars `lengthIs` fam_arity)- (wrongNumberOfParmsErr fam_arity)+ ; checkTc (vis_pats == vis_arity)+ (wrongNumberOfParmsErr vis_arity) -- Typecheck RHS- ; let hs_pats = map (HsValArg . hsLTyVarBndrToType) exp_vars-- -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get- -- the LHsQTyVars used for declaring a tycon, but the names here- -- are different.-- -- You might think we should pass in some AssocInstInfo, as we're looking- -- at an associated type. But this would be wrong, because an associated- -- type default LHS can mention *different* type variables than the- -- enclosing class. So it's treated more as a freestanding beast.+ --+ -- You might think we should pass in some AssocInstInfo, as we're looking+ -- at an associated type. But this would be wrong, because an associated+ -- type default LHS can mention *different* type variables than the+ -- enclosing class. So it's treated more as a freestanding beast. ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated- imp_vars exp_vars+ imp_vars (mb_expl_bndrs `orElse` []) hs_pats hs_rhs_ty - ; let fam_tvs = tyConTyVars fam_tc- ppr_eqn = ppr_default_eqn pats rhs_ty+ ; let fam_tvs = tyConTyVars fam_tc+ ppr_eqn = ppr_default_eqn pats rhs_ty+ pats_vis = tyConArgFlags fam_tc pats ; traceTc "tcDefaultAssocDecl 2" (vcat [ text "fam_tvs" <+> ppr fam_tvs , text "qtvs" <+> ppr qtvs , text "pats" <+> ppr pats , text "rhs_ty" <+> ppr rhs_ty ])- ; pat_tvs <- traverse (extract_tv ppr_eqn) pats- ; check_all_distinct_tvs ppr_eqn pat_tvs+ ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis+ ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs) ; pure $ Just (substTyUnchecked subst rhs_ty, loc) -- We also perform other checks for well-formedness and validity@@ -1576,21 +1577,18 @@ -- variable. If so, return the underlying type variable, and if -- not, throw an error. -- See Note [Type-checking default assoc decls]- extract_tv :: SDoc -- The pretty-printed default equation- -- (only used for error message purposes)- -> Type -- The particular type pattern from which to extract- -- its underlying type variable+ extract_tv :: SDoc -- The pretty-printed default equation+ -- (only used for error message purposes)+ -> Type -- The particular type pattern from which to extract+ -- its underlying type variable+ -> ArgFlag -- The visibility of the type pattern+ -- (only used for error message purposes) -> TcM TyVar- extract_tv ppr_eqn pat =+ extract_tv ppr_eqn pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv- Nothing ->- -- Per Note [Type-checking default assoc decls], we already- -- know by this point that if any arguments in the default- -- instance aren't type variables, then they must be- -- invisible kind arguments. Therefore, always display the- -- error message with -fprint-explicit-kinds enabled.- failWithTc $ pprWithExplicitKindsWhen True $+ Nothing -> failWithTc $+ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -1598,22 +1596,21 @@ -- Checks that no type variables in an associated default declaration are -- duplicated. If that is the case, throw an error. -- See Note [Type-checking default assoc decls]- check_all_distinct_tvs :: SDoc -- The pretty-printed default equation- -- (only used for error message purposes)- -> [TyVar] -- The type variable arguments in the- -- associated default declaration- -> TcM ()- check_all_distinct_tvs ppr_eqn tvs =- let dups = findDupsEq (==) tvs in+ check_all_distinct_tvs ::+ SDoc -- The pretty-printed default equation (only used+ -- for error message purposes)+ -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated+ -- default declaration, along with their respective+ -- visibilities (the latter are only used for error+ -- message purposes)+ -> TcM ()+ check_all_distinct_tvs ppr_eqn pat_tvs_vis =+ let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in traverse_- (\d -> -- Per Note [Type-checking default assoc decls], we already- -- know by this point that if any arguments in the default- -- instance are duplicates, then they must be- -- invisible kind arguments. Therefore, always display the- -- error message with -fprint-explicit-kinds enabled.- failWithTc $ pprWithExplicitKindsWhen True $+ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal duplicate variable"- <+> quotes (ppr (NE.head d)) <+> text "in:")+ <+> quotes (ppr pat_tv) <+> text "in:") 2 (vcat [ppr_eqn, suggestion])) dups @@ -1625,9 +1622,6 @@ suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables"-tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"-tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)]- = panic "tcDefaultAssocDecl" tcDefaultAssocDecl _ [_] = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 @@ -1653,11 +1647,10 @@ In order to create this substitution, we must first ensure that all of the arguments in the default instance consist of distinct type variables.-This property has already been checked to some degree earlier in the compiler:-RdrHsSyn.checkTyVars ensures that all visible type arguments are type-variables, and RnTypes.bindLHsTyVarBndrs ensures that no visible type arguments-are duplicated. But these only check /visible/ arguments, however, so we still-must check the invisible kind arguments to see if these invariants are upheld.+One might think that this is a simple task that could be implemented earlier+in the compiler, perhaps in the parser or the renamer. However, there are some+tricky corner cases that really do require the full power of typechecking to+weed out, as the examples below should illustrate. First, we must check that all arguments are type variables. As a motivating example, consider this erroneous program (inspired by #11361):@@ -1674,13 +1667,15 @@ class C2 (a :: j) where type F2 (a :: j) (b :: k)- type F2 (x :: z) (y :: z) = z+ type F2 (x :: z) y = SameKind x y+ data SameKind :: k -> k -> Type All of the arguments in the default equation for `F2` are type variables, so that passes the first check. However, if we were to build this substitution, then both `j` and `k` map to `z`! In terms of visible kind application, it's as-if we had written `type F2 @z @z x y = z`, which makes it clear that we have-duplicated a use of `z`. Therefore, `F2`'s default is also rejected.+if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear+that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is+also rejected. Since the LHS of an associated type family default is always just variables, it won't contain any tycons. Accordingly, the patterns used in the substitution
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20190516+version: 0.20190523 license: BSD3 license-file: LICENSE category: Development@@ -84,7 +84,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*,- ghc-lib-parser == 0.20190516+ ghc-lib-parser == 0.20190523.1 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -261,6 +261,7 @@ Language.Haskell.TH.Syntax, Lexeme, Lexer,+ LinkerTypes, ListSetOps, Literal, Maybes,
ghc-lib/generated/ghcversion.h view
@@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190514+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190522 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc/GHCi/UI.hs view
@@ -55,7 +55,8 @@ import HsImpExp import HsSyn import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,- setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc )+ setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,+ hsc_dynLinker ) import Module import Name import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,@@ -2998,6 +2999,7 @@ showCmd str = do st <- getGHCiState dflags <- getDynFlags+ hsc_env <- GHC.getSession let lookupCmd :: String -> Maybe (m ()) lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds@@ -3017,7 +3019,7 @@ , action "imports" $ showImports , action "modules" $ showModules , action "bindings" $ showBindings- , action "linker" $ getDynFlags >>= liftIO . showLinkerState+ , action "linker" $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env)) , action "breaks" $ showBkptTable , action "context" $ showContext , action "packages" $ showPackages
includes/rts/storage/InfoTables.h view
@@ -189,7 +189,7 @@ StgHalfWord type; /* closure type */ StgSRTField srt; /* In a CONSTR:- - the constructor tag+ - the zero-based constructor tag In a FUN/THUNK - if USE_INLINE_SRT_FIELD - offset to the SRT (or zero if no SRT)