diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -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_ diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -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 diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -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 diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -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 diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -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. diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 } -- ----------------------------------------------------------------------------- diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -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, "") -- 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 diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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 diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -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 }) () diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -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) } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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, diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -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__ || \ diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -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 diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h --- a/includes/rts/storage/InfoTables.h +++ b/includes/rts/storage/InfoTables.h @@ -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)