diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-06-30 14:49:14 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-06-30 14:49:14 +0100 |
| commit | bfbf3858110b1e16b2efd89f691e426b03e52343 (patch) | |
| tree | 7f8b2aa422c9a372b0c8034670a058025b5dcbdc /compiler | |
| parent | a347cd7c384eb255b5507a40840205d052f137c6 (diff) | |
| parent | e49dae36a00b2af8f6ad583dd24f9bacf5711242 (diff) | |
| download | haskell-bfbf3858110b1e16b2efd89f691e426b03e52343.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
42 files changed, 567 insertions, 250 deletions
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index fca625692f..a28136bd8a 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -35,8 +35,10 @@ module VarEnv ( RnEnv2, -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + mkRnEnv2, rnBndr2, rnBndrs2, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + delBndrL, delBndrR, delBndrsL, delBndrsR, addRnInScopeSet, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, @@ -283,11 +285,24 @@ rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR where new_b = uniqAway in_scope bR +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool -- ^ Tells whether a variable is locally bound inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index 38eda2d1ac..542e390128 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -63,13 +63,6 @@ data GenCmmTop d h g [d] --- A basic block containing a single label, at the beginning. --- The list of basic blocks in a top-level code block may be re-ordered. --- Fall-through is not allowed: there must be an explicit jump at the --- end of each basic block, but the code generator might rearrange basic --- blocks in order to turn some jumps into fallthroughs. - - ----------------------------------------------------------------------------- -- Info Tables ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 6e890355a5..aa166847eb 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -30,31 +30,13 @@ import Outputable -- MachOp ----------------------------------------------------------------------------- -{- -Implementation notes: - -It might suffice to keep just a width, without distinguishing between -floating and integer types. However, keeping the distinction will -help the native code generator to assign registers more easily. --} - - {- | Machine-level primops; ones which we can reasonably delegate to the -native code generators to handle. Basically contains C's primops -and no others. - -Nomenclature: all ops indicate width and signedness, where -appropriate. Widths: 8\/16\/32\/64 means the given size, obviously. -Nat means the operation works on STG word sized objects. -Signedness: S means signed, U means unsigned. For operations where -signedness is irrelevant or makes no difference (for example -integer add), the signedness component is omitted. - -An exception: NatP is a ptr-typed native word. From the point of -view of the native code generators this distinction is irrelevant, -but the C code generator sometimes needs this info to emit the -right casts. +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. -} data MachOp diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index f7950423fe..cf09b5b134 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -35,12 +35,15 @@ data CmmNode e x where CmmComment :: FastString -> CmmNode O O - CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register + CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O + -- Assign to register - CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. + CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. - CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls] + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] -- Like a "fat machine instruction"; can occur -- in the middle of a block ForeignTarget -> -- call target diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 6988ae6905..27277540fe 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -49,10 +49,6 @@ instance Outputable CmmType where instance Outputable CmmCat where ppr FloatCat = ptext $ sLit("F") ppr _ = ptext $ sLit("I") --- Temp Jan 08 --- ppr FloatCat = ptext $ sLit("float") --- ppr BitsCat = ptext $ sLit("bits") --- ppr GcPtrCat = ptext $ sLit("gcptr") -- Why is CmmType stratified? For native code generation, -- most of the time you just want to know what sort of register @@ -244,7 +240,7 @@ definition of a function is not visible at all of its call sites, so the compiler cannot infer the hints. Here in Cmm, we're taking a slightly different approach. We include -the int vs. float hint in the MachRep, because (a) the majority of +the int vs. float hint in the CmmType, because (a) the majority of platforms have a strong distinction between float and int registers, and (b) we don't want to do any heavyweight hint-inference in the native code backend in order to get good code. We're treating the @@ -272,7 +268,7 @@ of analysis that propagates hints around. In Cmm we don't want to have to do this, so we plump for having richer types and keeping the type information consistent. -If signed/unsigned hints are missing from MachRep, then the only +If signed/unsigned hints are missing from CmmType, then the only choice we have is (a), because we don't know whether the result of an operation should be sign- or zero-extended. @@ -287,7 +283,7 @@ convention can specify that signed 8-bit quantities are passed as sign-extended 32 bit quantities, for example (this is the case on the PowerPC). So we *do* need sign information on foreign call arguments. -Pros for adding signed vs. unsigned to MachRep: +Pros for adding signed vs. unsigned to CmmType: - It would let us use convention (b) above, and get easier code generation for extending loads. @@ -300,10 +296,10 @@ Cons: - More complexity - - What is the MachRep for a VanillaReg? Currently it is + - What is the CmmType for a VanillaReg? Currently it is always wordRep, but now we have to decide whether it is signed or unsigned. The same VanillaReg can thus have - different MachReps in different parts of the program. + different CmmType in different parts of the program. - Extra coercions cluttering up expressions. diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 1eea96c1b0..649bda87ef 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -157,6 +157,25 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr reps_compatible = idCgRep v == idCgRep bndr \end{code} +Special case #2.5; seq# + + case seq# a s of v + (# s', a' #) -> e + + ==> + + case a of v + (# s', a' #) -> e + + (taking advantage of the fact that the return convention for (# State#, a #) + is the same as the return convention for just 'a') + +\begin{code} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) + live_in_whole_case live_in_alts bndr alt_type alts + = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts +\end{code} + Special case #3: inline PrimOps and foreign calls. \begin{code} diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 1f11495b60..fe08f50b42 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -151,6 +151,13 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) tycon = tyConAppTyCon res_ty +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) + = cgTailCall a [] + -- seq# :: a -> State# -> (# State# , a #) + -- but the return convention for (# State#, a #) is exactly the same as + -- for just a, so we can implment seq# by + -- seq# a s ==> a + cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | primOpOutOfLine primop = tailCallPrimOp primop args diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 87ed25c041..c2a57a40d2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -127,8 +127,28 @@ emitPrimOp [res] ParOp [arg] live NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn where + newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + +emitPrimOp [res] SparkOp [arg] live = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- newTemp bWord + stmtC (CmmAssign (CmmLocal tmp) arg) + + vols <- getVolatileRegs live + emitForeignCall' PlayRisky [] + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + , (CmmHinted arg AddrHint) ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + emitPrimOp [res] ReadMutVarOp [mutv] _ = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index c5ee147c24..f730fdb7ae 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -8,7 +8,8 @@ Utility functions on @Core@ syntax \begin{code} module CoreSubst ( -- * Main data types - Subst, TvSubstEnv, IdSubstEnv, InScopeSet, + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index fbe1ab9a45..6f2e08afff 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -364,20 +364,6 @@ addTickHsExpr (HsWrap w e) = (return w) (addTickHsExpr e) -- explicitly no tick on inside -addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) = - liftM5 HsArrApp - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return arr_ty) - (return lr) - -addTickHsExpr (HsArrForm e fix cmdtop) = - liftM3 HsArrForm - (addTickLHsExpr e) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. @@ -544,8 +530,8 @@ addTickLHsCmd (L pos c0) = do addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) addTickHsCmd (HsLam matchgroup) = liftM HsLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsApp e1 e2) = - liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) +addTickHsCmd (HsApp c e) = + liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp (addTickLHsExpr e1) @@ -854,7 +840,12 @@ mkHpcPos pos@(RealSrcSpan s) | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndLine s, - srcSpanEndCol s) + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index af2db3697b..15d547eab0 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -169,7 +169,8 @@ deSugar hsc_env mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, - mg_vect_info = noVectInfo + mg_vect_info = noVectInfo, + mg_trust_pkg = imp_trust_own_pkg imports } ; return (msgs, Just mod_guts) }}} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 48a94c74e2..42507d9901 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -389,8 +389,9 @@ instance Binary ModIface where mi_rules = rules, mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust }) = do + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do put_ bh mod put_ bh is_boot put_ bh iface_hash @@ -412,6 +413,7 @@ instance Binary ModIface where put_ bh vect_info put_ bh hpc_info put_ bh trust + put_ bh trust_pkg get bh = do mod_name <- get bh @@ -435,6 +437,7 @@ instance Binary ModIface where vect_info <- get bh hpc_info <- get bh trust <- get bh + trust_pkg <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, @@ -458,6 +461,7 @@ instance Binary ModIface where mi_vect_info = vect_info, mi_hpc = hpc_info, mi_trust = trust, + mi_trust_pkg = trust_pkg, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index daa0bb0284..af94ce0b21 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -669,6 +669,7 @@ pprModIface iface , pprVectInfo (mi_vect_info iface) , ppr (mi_warns iface) , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") @@ -756,6 +757,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars pprTrustInfo :: IfaceTrustInfo -> SDoc pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg + instance Outputable Warnings where ppr = pprWarns diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3612372f8a..95cf35e427 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -123,18 +123,19 @@ mkIface :: HscEnv -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info } + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_trust_pkg = self_trust } = mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env - fix_env warns hpc_info dir_imp_mods mod_details + this_mod is_boot used_names deps rdr_env fix_env + warns hpc_info dir_imp_mods self_trust mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -159,12 +160,15 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details let hpc_info = emptyHpcInfo other_hpc_info mkIface_ hsc_env maybe_old_fingerprint this_mod (isHsBoot hsc_src) used_names deps rdr_env - fix_env warns hpc_info (imp_mods imports) mod_details + fix_env warns hpc_info (imp_mods imports) + (imp_trust_own_pkg imports) mod_details mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies TcGblEnv{ tcg_mod = mod, @@ -172,9 +176,9 @@ mkDependencies tcg_th_used = th_var } = do - th_used <- readIORef th_var -- Whether TH is used - let - dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- Template Haskell used? + th_used <- readIORef th_var + let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -182,30 +186,31 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports - -- add in safe haskell 'package needs to be safe' bool - sorted_pkgs = sortBy stablePackageIdCmp pkgs - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + sorted_pkgs = sortBy stablePackageIdCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, dep_pkgs = dep_pkgs', dep_orphs = sortBy stableModuleCmp (imp_orphs imports), dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } - -- sort to get into canonical order - -- NB. remember to use lexicographic ordering + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameSet -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings -> HpcInfo - -> ImportedMods + -> ImportedMods -> Bool -> ModDetails - -> IO (Messages, Maybe (ModIface, Bool)) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info - dir_imp_mods + dir_imp_mods pkg_trust_req ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -232,7 +237,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - ; warns = src_warns + ; warns = src_warns ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -271,6 +276,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_hash_fn = deliberatelyOmitted "hash_fn", mi_hpc = isHpcUsed hpc_info, mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, @@ -527,9 +533,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- dep_pkgs: see "Package Version Changes" on -- wiki/Commentary/Compiler/RecompilationAvoidance mi_trust iface0) - -- TODO: Can probably make more fine grained. Only - -- really need to have recompilation for overlapping - -- instances. + -- Make sure change of Safe Haskell mode causes recomp. -- put the declarations in a canonical order, sorted by OccName let sorted_decls = Map.elems $ Map.fromList $ @@ -918,7 +922,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names Just _ -> pprPanic "mkUsage: empty direct import" empty Nothing -> (False, safeImplicitImpsReq dflags) -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' - -- is used in the source code. We require them to be safe in SafeHaskell + -- is used in the source code. We require them to be safe in Safe Haskell used_occs = lookupModuleEnv ent_map mod `orElse` [] diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 221106aec5..59cdad4918 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -29,6 +29,7 @@ import LlvmCodeGen.Regs import CLabel import CgUtils ( activeStgRegs ) +import Config import Constants import FastString import OldCmm @@ -80,7 +81,8 @@ widthToLlvmInt w = LMInt $ widthInBits w -- | GHC Call Convention for LLVM llvmGhcCC :: LlvmCallConvention -llvmGhcCC = CC_Ncc 10 +llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10 + | otherwise = CC_Ccc -- | Llvm Function type for Cmm function llvmFunTy :: LlvmType diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 3ff75e1043..02b6042148 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -34,11 +34,11 @@ import Data.List data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" - flagSafety :: FlagSafety, -- Flag safety level (SafeHaskell) + flagSafety :: FlagSafety, -- Flag safety level (Safe Haskell) flagOptKind :: OptKind m -- What to do if we see it } --- | This determines how a flag should behave when SafeHaskell +-- | This determines how a flag should behave when Safe Haskell -- mode is on. data FlagSafety = EnablesSafe -- ^ This flag is a little bit of a hack. We give @@ -107,7 +107,7 @@ setArg l s (EwM f) = EwM (\_ _ c es ws -> | otherwise = err l es ws err (L loc ('-' : arg)) es ws = let msg = "Warning: " ++ arg ++ " is not allowed in " - ++ "SafeHaskell; ignoring " ++ arg + ++ "Safe Haskell; ignoring " ++ arg in return (es, ws `snocBag` L loc msg, ()) err _ _ _ = error "Bad pattern match in setArg" in check) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c7bc823823..aa987d7327 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -934,8 +934,8 @@ runPhase (Hsc src_flavour) input_fn dflags0 ms_location = location4, ms_hs_date = src_timestamp, ms_obj_date = Nothing, - ms_imps = imps, - ms_srcimps = src_imps } + ms_textual_imps = imps, + ms_srcimps = src_imps } -- run the compiler! result <- io $ hscCompileOneShot hsc_env' @@ -1440,7 +1440,10 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do | isWindowsTarget = empty | otherwise = hcat [ text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",@note\\n", + text ",\\\"\\\",", + text elfSectionNote, + text "\\n", + text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] where -- we need to escape twice: once because we're inside a C string, @@ -1450,6 +1453,16 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) + elfSectionNote :: String + elfSectionNote = case platformArch defaultTargetPlatform of + ArchX86 -> "@note" + ArchX86_64 -> "@note" + ArchPPC -> "@note" + ArchPPC_64 -> "@note" + ArchSPARC -> "@note" + ArchARM -> "%note" + ArchUnknown -> panic "elfSectionNote ArchUnknown" + -- The "link info" is a string representing the parameters of the -- link. We save this information in the binary, and the next time we -- link, if nothing else has changed, we use the link info stored in diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 62d3c2ab47..144d6d1fbe 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -30,13 +30,14 @@ module DynFlags ( DynLibLoader(..), fFlags, fLangFlags, xFlags, DPHBackend(..), dphPackageMaybe, - wayNames, + wayNames, dynFlagDependencies, - -- ** SafeHaskell + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeLanguageOn, safeDirectImpsReq, safeImplicitImpsReq, + -- ** System tool settings and locations Settings(..), ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, extraGccViaCFlags, systemPackageConfig, @@ -325,7 +326,7 @@ data DynFlag data Language = Haskell98 | Haskell2010 --- | The various SafeHaskell modes +-- | The various Safe Haskell modes data SafeHaskellMode = Sf_None | Sf_SafeImports @@ -979,17 +980,22 @@ setLanguage l = upd f extensionFlags = flattenExtensionFlags mLang oneoffs } +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool safeLanguageOn dflags = s == Sf_SafeLanguage || s == Sf_TrustworthyWithSafeLanguage || s == Sf_Safe where s = safeHaskell dflags --- | Test if SafeHaskell is on in some form +-- | Test if Safe Haskell is on in some form safeHaskellOn :: DynFlags -> Bool safeHaskellOn dflags = safeHaskell dflags /= Sf_None --- | Set a 'SafeHaskell' flag +-- | Set a 'Safe Haskell' flag setSafeHaskell :: SafeHaskellMode -> DynP () setSafeHaskell s = updM f where f dfs = do @@ -997,18 +1003,18 @@ setSafeHaskell s = updM f safeM <- combineSafeFlags sf s return $ dfs { safeHaskell = safeM } --- | Are all direct imports required to be safe for this SafeHaskell mode? +-- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module safeDirectImpsReq :: DynFlags -> Bool safeDirectImpsReq = safeLanguageOn --- | Are all implicit imports required to be safe for this SafeHaskell mode? +-- | Are all implicit imports required to be safe for this Safe Haskell mode? -- Implicit imports are things in the prelude. e.g System.IO when print is used. safeImplicitImpsReq :: DynFlags -> Bool safeImplicitImpsReq = safeLanguageOn --- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags. --- This makes SafeHaskell very much a monoid but for now I prefer this as I don't +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode @@ -1038,7 +1044,7 @@ combineSafeFlags a b = | otherwise -> err where err = do - let s = "Incompatible SafeHaskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" + let s = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" addErr s return $ panic s -- Just for saftey instead of returning say, a @@ -1271,7 +1277,7 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags flip xopt_unset Opt_TemplateHaskell)] safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" - ++ " SafeHaskell; ignoring " ++ str] + ++ " Safe Haskell; ignoring " ++ str] {- ********************************************************************** @@ -1365,7 +1371,7 @@ dynamic_flags = [ ------- Output Redirection ------------------------------------------ , flagA "odir" (hasArg setObjectDir) - , flagA "o" (SepArg (upd . setOutputFile . Just)) + , flagA "o" (sepArg (setOutputFile . Just)) , flagA "ohi" (hasArg (setOutputHi . Just )) , flagA "osuf" (hasArg setObjectSuf) , flagA "hcsuf" (hasArg setHcSuf) @@ -1522,8 +1528,8 @@ dynamic_flags = [ , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Plugin flags ------------------------------------------------ - , flagA "fplugin" (hasArg addPluginModuleName) - , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) + , flagA "fplugin" (sepArg addPluginModuleName) + , flagA "fplugin-opt" (sepArg addPluginModuleNameOption) ------ Optimisation flags ------------------------------------------ , flagA "O" (noArgM (setOptLevel 1)) @@ -1541,7 +1547,7 @@ dynamic_flags = [ , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , flagA "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) + , flagA "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s })) , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) @@ -2137,6 +2143,9 @@ hasArgDF :: (String -> DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynF hasArgDF fn deprec = HasArg (\s -> do { upd (fn s) ; deprecate deprec }) +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c8ca482784..8f5c894ac2 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -816,7 +816,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ms_obj_date = Nothing, -- Only handling the single-module case for now, so no imports. ms_srcimps = [], - ms_imps = [], + ms_textual_imps = [], -- No source file ms_hspp_file = "", ms_hspp_opts = dflags, diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 8ccf0a5a81..5dcea1b139 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1254,7 +1254,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_imps = the_imps, + ms_srcimps = srcimps, ms_textual_imps = the_imps, ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp }) @@ -1379,8 +1379,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp })) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index a8bb18d510..17bd230421 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -778,7 +778,7 @@ hscFileFrontEnd mod_summary = do ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module dflags <- getDynFlags - -- XXX: See Note [SafeHaskell API] + -- XXX: See Note [Safe Haskell API] if safeHaskellOn dflags then do tcg_env1 <- checkSafeImports dflags hsc_env tcg_env @@ -805,24 +805,53 @@ hscFileFrontEnd mod_summary = do warnRules (L loc (HsRule n _ _ _ _ _ _)) = mkPlainWarnMsg loc $ text "Rule \"" <> ftext n <> text "\" ignored" $+$ - text "User defined rules are disabled under SafeHaskell" + text "User defined rules are disabled under Safe Haskell" -------------------------------------------------------------- --- SafeHaskell +-- Safe Haskell -------------------------------------------------------------- +-- Note [Safe Haskell API] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- XXX: We only call this in hscFileFrontend and don't expose +-- it to the GHC API. External users of GHC can't properly use +-- the GHC API and Safe Haskell. + + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + -- | Validate that safe imported modules are actually safe. -- For modules in the HomePackage (the package the module we -- are compiling in resides) this just involves checking its -- trust type is 'Safe' or 'Trustworthy'. For modules that -- reside in another package we also must check that the --- external pacakge is trusted. +-- external pacakge is trusted. See the Note [Safe Haskell +-- Trust Check] above for more information. -- --- Note [SafeHaskell API] --- ~~~~~~~~~~~~~~~~~~~~~~ --- XXX: We only call this in hscFileFrontend and don't expose --- it to the GHC API. External users of GHC can't properly use --- the GHC API and SafeHaskell. +-- The code for this is quite tricky as the whole algorithm +-- is done in a few distinct phases in different parts of the +-- code base. See RnNames.rnImportDecl for where package trust +-- dependencies for a module are collected and unioned. +-- Specifically see the Note [RnNames . Tracking Trust Transitively] +-- and the Note [RnNames . Trust Own Package]. checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv checkSafeImports dflags hsc_env tcg_env = do @@ -873,9 +902,9 @@ checkSafeImports dflags hsc_env tcg_env -- that their package is trusted. For trustworthy modules, -- modules in the home package are trusted but otherwise -- we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Module -> Bool - packageTrusted Sf_Safe _ = True - packageTrusted _ m + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted Sf_Safe False _ = True + packageTrusted _ _ m | isHomePkg m = True | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId m) @@ -894,11 +923,12 @@ checkSafeImports dflags hsc_env tcg_env -- got iface, check trust Just iface' -> do let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' -- check module is trusted safeM = trust `elem` [Sf_Safe, Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage] -- check package is trusted - safeP = packageTrusted trust m + safeP = packageTrusted trust trust_own_pkg m if safeM && safeP then return Nothing else return $ Just $ if safeM @@ -1393,7 +1423,8 @@ mkModGuts mod binds = ModGuts { mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, - mg_fam_inst_env = emptyFamInstEnv + mg_fam_inst_env = emptyFamInstEnv, + mg_trust_pkg = False } \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1edce70d08..7f43414111 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -17,7 +17,7 @@ module HscTypes ( ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ImportedModsVal, - ModSummary(..), ms_mod_name, showModMsg, isBootSummary, + ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, -- * Information about the module being compiled @@ -131,7 +131,7 @@ import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..), SafeHaskellMode(..) ) + DynFlag(..), SafeHaskellMode(..), dynFlagDependencies ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -687,8 +687,15 @@ data ModIface -- The 'OccName' is the parent of the name, if it has one. mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. - mi_trust :: !IfaceTrustInfo + mi_trust :: !IfaceTrustInfo, -- ^ Safe Haskell Trust information for this module. + mi_trust_pkg :: !Bool + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [RnNames . Trust Own Package] } -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' @@ -767,9 +774,12 @@ data ModGuts mg_inst_env :: InstEnv, -- ^ Class instance environment from /home-package/ modules (including -- this one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_trust_pkg :: Bool + -- ^ Do we need to trust our own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] } -- The ModGuts takes on several slightly different forms: @@ -862,7 +872,8 @@ emptyModIface mod mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, mi_hpc = False, - mi_trust = noIfaceTrustInfo + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False } \end{code} @@ -1435,19 +1446,21 @@ type IsBootInterface = Bool data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ Home-package module dependencies - , dep_pkgs :: [(PackageId, Bool)] - -- ^ External package dependencies - , dep_orphs :: [Module] - -- ^ Orphan modules (whether home or external pkg), - -- *not* including family instance orphans as they - -- are anyway included in 'dep_finsts' - , dep_finsts :: [Module] + , dep_pkgs :: [(PackageId, Bool)] + -- ^ External package dependencies. The bool indicates + -- if the package is required to be trusted when the + -- module is imported as a safe import (Safe Haskell). + -- See Note [RnNames . Tracking Trust Transitively] + , dep_orphs :: [Module] + -- ^ Orphan modules (whether home or external pkg), + -- *not* including family instance orphans as they + -- are anyway included in 'dep_finsts' + , dep_finsts :: [Module] -- ^ Modules that contain family instances (whether the -- instances are from the home or an external package) } deriving( Eq ) - -- Equality used only for old/new comparison in MkIface.addVersionInfo - + -- Equality used only for old/new comparison in MkIface.addVersionInfo -- See 'TcRnTypes.ImportAvails' for details on dependencies. noDependencies :: Dependencies @@ -1643,22 +1656,38 @@ emptyMG = [] -- * An external-core source module data ModSummary = ModSummary { - ms_mod :: Module, -- ^ Identity of the module - ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core - ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: ClockTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one - ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module - ms_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module - ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ + ms_mod :: Module, -- ^ Identity of the module + ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core + ms_location :: ModLocation, -- ^ Location of the various files belonging to the module + ms_hs_date :: ClockTime, -- ^ Timestamp of source file + ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one + ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module + ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* + ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ -- and @LANGUAGE@ pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it + ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it } ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod +ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] +ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + -- This is a not-entirely-satisfactory means of creating an import that corresponds to an + -- import that did not occur in the program text, such as those induced by the use of + -- plugins (the -plgFoo flag) + mk_additional_import mod_nm = noLoc $ ImportDecl { + ideclName = noLoc mod_nm, + ideclPkgQual = Nothing, + ideclSource = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing, + ideclSafe = False + } + -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been -- done. The point is that the summariser will have to cpp/unlit/whatever @@ -1684,7 +1713,7 @@ instance Outputable ModSummary where nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' ] diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index f6d0af2665..d8e63aba8c 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -72,6 +72,7 @@ module StaticFlags ( -- misc opts opt_IgnoreDotGhci, + opt_GhciScripts, opt_ErrorSpans, opt_GranMacros, opt_HiVersion, @@ -92,7 +93,7 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJusts ) +import Maybes ( firstJusts, catMaybes ) import Panic import Data.Maybe ( listToMaybe ) @@ -121,6 +122,7 @@ lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String +lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -151,6 +153,10 @@ lookup_str sw Just str -> Just str Nothing -> Nothing +lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where + f ('=' : str) = str + f str = str + lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -189,6 +195,9 @@ unpacked_opts = opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") + +opt_GhciScripts :: [String] +opt_GhciScripts = lookup_all_str "-ghci-script" -- debugging options -- | Suppress all that is suppressable in core dumps. diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 7768b4ffa7..cf91fb9ecd 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -455,7 +455,9 @@ figureLlvmVersion dflags = do return $ Just v ) (\err -> do - putMsg dflags $ text $ "Warning: " ++ show err + putMsg dflags $ text $ "Error (" ++ show err ++ ")" + putMsg dflags $ text "Warning: Couldn't figure out LLVM version!" + putMsg dflags $ text "Make sure you have installed LLVM" return Nothing) return ver diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 1ea83e8e88..ff18615b1a 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -197,6 +197,8 @@ nativeCodeGen dflags h us cmms ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgMakeFarBranches = id } + ArchARM -> + panic "nativeCodeGen: No NCG for ARM" ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" ArchUnknown -> diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 848b266116..802f847f11 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -115,6 +115,7 @@ trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions ArchPPC -> 16 ArchSPARC -> 14 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER (virtualRegSqueeze RcInteger) @@ -134,6 +135,7 @@ trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions ArchPPC -> 0 ArchSPARC -> 22 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT (virtualRegSqueeze RcFloat) @@ -153,6 +155,7 @@ trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions ArchPPC -> 26 ArchSPARC -> 11 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE (virtualRegSqueeze RcDouble) @@ -172,6 +175,7 @@ trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions ArchPPC -> 0 ArchSPARC -> 0 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE (virtualRegSqueeze RcDoubleSSE) diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index b442d069a4..07cfc0f825 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -68,6 +68,7 @@ maxSpillSlots = case platformArch defaultTargetPlatform of ArchX86_64 -> X86.Instr.maxSpillSlots ArchPPC -> PPC.Instr.maxSpillSlots ArchSPARC -> SPARC.Instr.maxSpillSlots + ArchARM -> panic "maxSpillSlots ArchARM" ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index b91c2d0269..3682ffbe1d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -183,6 +183,7 @@ linearRegAlloc dflags first_id block_live sccs ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" ArchUnknown -> panic "linearRegAlloc ArchUnknown" diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index b357675eeb..e6427ed499 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -52,6 +52,7 @@ targetVirtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze ArchSPARC -> SPARC.virtualRegSqueeze ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" + ArchARM -> panic "targetVirtualRegSqueeze ArchARM" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" targetRealRegSqueeze :: RegClass -> RealReg -> FastInt @@ -62,6 +63,7 @@ targetRealRegSqueeze ArchPPC -> PPC.realRegSqueeze ArchSPARC -> SPARC.realRegSqueeze ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" + ArchARM -> panic "targetRealRegSqueeze ArchARM" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" targetClassOfRealReg :: RealReg -> RegClass @@ -72,6 +74,7 @@ targetClassOfRealReg ArchPPC -> PPC.classOfRealReg ArchSPARC -> SPARC.classOfRealReg ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" + ArchARM -> panic "targetClassOfRealReg ArchARM" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" -- TODO: This should look at targetPlatform too @@ -86,6 +89,7 @@ targetMkVirtualReg ArchPPC -> PPC.mkVirtualReg ArchSPARC -> SPARC.mkVirtualReg ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" + ArchARM -> panic "targetMkVirtualReg ArchARM" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" targetRegDotColor :: RealReg -> SDoc @@ -96,6 +100,7 @@ targetRegDotColor ArchPPC -> PPC.regDotColor ArchSPARC -> SPARC.regDotColor ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" + ArchARM -> panic "targetRegDotColor ArchARM" ArchUnknown -> panic "targetRegDotColor ArchUnknown" diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index a667c51532..d191733af1 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1620,10 +1620,10 @@ genCCall target dest_regs args = let sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) raw_arg_size = sum sizes - tot_arg_size = if isDarwin then roundTo 16 raw_arg_size else raw_arg_size + tot_arg_size = roundTo 16 raw_arg_size arg_pad_size = tot_arg_size - raw_arg_size delta0 <- getDeltaNat - when isDarwin $ setDeltaNat (delta0 - arg_pad_size) + setDeltaNat (delta0 - arg_pad_size) use_sse2 <- sse2Enabled push_codes <- mapM (push_arg use_sse2) (reverse args) @@ -1646,7 +1646,7 @@ genCCall target dest_regs args = ++ "probably because too many return values." let push_code - | isDarwin && (arg_pad_size /= 0) + | arg_pad_size /= 0 = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), DELTA (delta0 - arg_pad_size)] `appOL` concatOL push_codes @@ -1657,10 +1657,9 @@ genCCall target dest_regs args = -- but not for stdcall (callee does it) -- -- We have to pop any stack padding we added - -- on Darwin even if we are doing stdcall, though (#5052) + -- even if we are doing stdcall, though (#5052) pop_size | cconv /= StdCallConv = tot_arg_size - | isDarwin = arg_pad_size - | otherwise = 0 + | otherwise = arg_pad_size call = callinsns `appOL` toOL ( @@ -1703,10 +1702,6 @@ genCCall target dest_regs args = assign_code dest_regs) where - isDarwin = case platformOS (targetPlatform dflags) of - OSDarwin -> True - _ -> False - arg_size :: CmmType -> Int -- Width in bytes arg_size ty = widthInBytes (typeWidth ty) diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 140ff57ae9..0f6613d00d 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -61,6 +61,7 @@ normalRegColors = case platformArch defaultTargetPlatform of ArchPPC -> panic "X86 normalRegColors ArchPPC" ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64" ArchSPARC -> panic "X86 normalRegColors ArchSPARC" + ArchARM -> panic "X86 normalRegColors ArchARM" ArchUnknown -> panic "X86 normalRegColors ArchUnknown" fpRegColors :: [(Reg,String)] diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4fd23ee712..95bc2d6014 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -701,6 +701,10 @@ stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey +-- The 'undefined' function. Used by supercompilation. +undefinedName :: Name +undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey + -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey @@ -1440,6 +1444,9 @@ marshalStringIdKey = mkPreludeMiscIdUnique 96 unmarshalStringIdKey = mkPreludeMiscIdUnique 97 checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98 +undefinedKey :: Unique +undefinedKey = mkPreludeMiscIdUnique 99 + \end{code} Certain class operations from Prelude classes. They get their own diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 93cc576a81..e9401d4c9e 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -24,9 +24,10 @@ import Id import Literal import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn +import TysPrim import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr ) +import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) import Type import OccName ( occNameFS ) @@ -37,6 +38,7 @@ import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) import Constants +import BasicTypes import Data.Bits as Bits import Data.Int ( Int64 ) @@ -174,9 +176,10 @@ primOpRules op op_name = primop_rule op primop_rule WordEqOp = relop (==) primop_rule WordNeOp = relop (/=) - primop_rule _ = [] - + primop_rule SeqOp = mkBasicRule op_name 4 seqRule + primop_rule SparkOp = mkBasicRule op_name 4 sparkRule + primop_rule _ = [] \end{code} %************************************************************************ @@ -540,6 +543,27 @@ dataToTagRule _ _ = Nothing %************************************************************************ %* * +\subsection{Rules for seq# and spark#} +%* * +%************************************************************************ + +\begin{code} +-- seq# :: forall a s . a -> State# s -> (# State# s, a #) +seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a + = Just (mkConApp (tupleCon Unboxed 2) + [Type (mkStatePrimTy ty_s), ty_a, s, a]) +seqRule _ _ = Nothing + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? +\end{code} + +%************************************************************************ +%* * \subsection{Built in rules} %* * %************************************************************************ diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index ce2462c99f..49498466e3 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1650,6 +1650,21 @@ primop ParOp "par#" GenPrimOp has_side_effects = True code_size = { primOpCodeSizeForeignCall } +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SeqOp "seq#" GenPrimOp + a -> State# s -> (# State# s, a #) + + -- why return the value? So that we can control sharing of seq'd + -- values: in + -- let x = e in x `seq` ... x ... + -- we don't want to inline x, so better to represent it as + -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + -- also it matches the type of rseq in the Eval monad. + primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d841ad8b1f..afec7f59b5 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,7 +18,7 @@ import HsSyn import TcEnv ( isBrackStage ) import RnEnv import RnHsDoc ( rnHsDoc ) -import IfaceEnv ( ifaceExportNames ) +import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad @@ -53,6 +53,55 @@ import qualified Data.Map as Map %* * %************************************************************************ +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. There is one trust +property that can change for a package though without recompliation being +triggered, package trust. So we must check that all packages a module +tranitively depends on to be trusted are still trusted when we are compiling +this module (as due to recompilation avoidance some modules below may not be +considered trusted any more without recompilation being triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +HscMain.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + Note [Trust Transitive Property] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ So there is an interesting design question in regards to transitive trust @@ -64,7 +113,7 @@ requirements from B? Should A now also require that a package p is trusted since B required it? We currently say no but I saying yes also makes sense. The difference is, if a -module M that doesn't use SafeHaskell imports a module N that does, should all +module M that doesn't use Safe Haskell imports a module N that does, should all the trusted package requirements be dropped since M didn't declare that it cares about Safe Haskell (so -XSafe is more strongly associated with the module doing the importing) or should it be done still since the author of the module N that @@ -72,8 +121,8 @@ uses Safe Haskell said they cared (so -XSafe is more strongly associated with the module that was compiled that used it). Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that SafeHaskell will affect users who don't care about -SafeHaskell as they might grab a package from Cabal which uses safe haskell (say +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say network) and that packages imports -XTrustworthy modules from another package (say bytestring), so requires that package is trusted. The user may now get compilation errors in code that doesn't do anything with Safe Haskell simply @@ -81,9 +130,10 @@ because they are using the network package. They will have to call 'ghc-pkg trust network' to get everything working. Due to this invasive nature of going with yes we have gone with no for now. + \begin{code} rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports -- PROCESS IMPORT DECLS @@ -91,34 +141,37 @@ rnImports imports -- warning for {- SOURCE -} ones that are unnecessary = do this_mod <- getModule implicit_prelude <- xoptM Opt_ImplicitPrelude - let prel_imports = mkPrelImports (moduleName this_mod) implicit_prelude imports + let prel_imports = mkPrelImports (moduleName this_mod) + implicit_prelude imports (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot - ifDOptM Opt_WarnImplicitPrelude ( - when (notNull prel_imports) $ addWarn (implicitPreludeWarn) - ) + ifDOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ addWarn (implicitPreludeWarn) stuff1 <- mapM (rnImportDecl this_mod True) prel_imports stuff2 <- mapM (rnImportDecl this_mod False) ordinary stuff3 <- mapM (rnImportDecl this_mod False) source - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2 ++ stuff3) + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = + combine (stuff1 ++ stuff2 ++ stuff3) return (decls, rdr_env, imp_avails, hpc_usage) where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails,False) - where plus (decl, gbl_env1, imp_avails1,hpc_usage1) - (decls, gbl_env2, imp_avails2,hpc_usage2) - = (decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1 `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2) + combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) + where + plus (decl, gbl_env1, imp_avails1,hpc_usage1) + (decls, gbl_env2, imp_avails2,hpc_usage2) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2 ) rnImportDecl :: Module -> Bool -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage) + -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod implicit_prelude (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg @@ -137,13 +190,13 @@ rnImportDecl this_mod implicit_prelude imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") - -- Check for a missing import list - -- (Opt_WarnMissingImportList also checks for T(..) items - -- but that is done in checkDodgyImport below) + -- Check for a missing import list + -- (Opt_WarnMissingImportList also checks for T(..) items + -- but that is done in checkDodgyImport below) case imp_details of - Just (False, _) -> return () -- Explicit import list + Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () - | qual_only -> return () + | qual_only -> return () | otherwise -> ifDOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) @@ -171,6 +224,8 @@ rnImportDecl this_mod implicit_prelude orph_iface = mi_orphan iface has_finsts = mi_finsts iface deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface filtered_exports = filter not_this_mod (mi_exports iface) not_this_mod (mod,_) = mod /= this_mod @@ -220,7 +275,13 @@ rnImportDecl this_mod implicit_prelude pkg = modulePackageId (mi_module iface) - (dependent_mods, dependent_pkgs) + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy + || trust == Sf_TrustworthyWithSafeLanguage + || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) | pkg == thisPackage dflags = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself @@ -233,14 +294,15 @@ rnImportDecl this_mod implicit_prelude -- know if any of them depended on CM.hi-boot, in -- which case we should do the hi-boot consistency -- check. See LoadIface.loadHiBootInterface - ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) + ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps, ptrust) | otherwise = -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) ) - ([], (pkg, False) : dep_pkgs deps) + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) + , ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps, False) -- True <=> import M () import_all = case imp_details of @@ -253,7 +315,8 @@ rnImportDecl this_mod implicit_prelude || (implicit_prelude && safeImplicitImpsReq dflags) imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')], + imp_mods = unitModuleEnv imp_mod + [(qual_mod_name, import_all, loc, mod_safe')], imp_orphs = orphans, imp_finsts = finsts, imp_dep_mods = mkModDeps dependent_mods, @@ -261,10 +324,14 @@ rnImportDecl this_mod implicit_prelude -- Add in the imported modules trusted package -- requirements. ONLY do this though if we import the -- module as a safe import. - -- see Note [Trust Transitive Property] + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] imp_trust_pkgs = if mod_safe' then map fst $ filter snd dependent_pkgs - else [] + else [], + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req } -- Complain if we import a deprecated module @@ -626,9 +693,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails checkDodgyImport stuff | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) - -- NB. use the RdrName for reporting the warning - | IEThingAll {} <- ieRdr - , not (is_qual decl_spec) + -- NB. use the RdrName for reporting the warning + | IEThingAll {} <- ieRdr + , not (is_qual decl_spec) = ifDOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 31bd7214fd..d298a10f19 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -621,7 +621,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) any ev_var_matches (immSuperClasses clas' tys') ev_var_matches _ = False - -- Overlap error because of SafeHaskell (first match should be the most + -- Overlap error because of Safe Haskell (first match should be the most -- specific match) mk_overlap_msg (matches, _unifiers, True) = ASSERT( length matches > 1 ) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 6850846950..1c289f1574 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -204,7 +204,15 @@ tcRnImports hsc_env this_mod import_decls = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except @@ -338,7 +346,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_foreign = NoStubs, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo + mg_vect_info = noVectInfo, + mg_trust_pkg = False } } ; tcCoreDump mod_guts ; diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 46a322a93f..0e2f6617ac 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -599,17 +599,17 @@ data ImportAvails -- different packages. (currently not the case, but might be in the -- future). - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. - - imp_dep_pkgs :: [PackageId], + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: [PackageId], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. @@ -623,12 +623,19 @@ data ImportAvails -- where True for the bool indicates the package is required to be -- trusted is the more logical design, doing so complicates a lot -- of code not concerned with Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [RnNames . Trust Own Package] - imp_orphs :: [Module], + imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including -- us for imported modules) - imp_finsts :: [Module] + imp_finsts :: [Module] -- ^ Family instance modules below us in the import tree (and maybe -- including us for imported modules) } @@ -640,34 +647,41 @@ mkModDeps deps = foldl add emptyUFM deps add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = [], - imp_trust_pkgs = [], - imp_orphs = [], - imp_finsts = [] } - +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = [], + imp_trust_pkgs = [], + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a seperate ImportAvails structure +-- and then union them all together with this function. plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_trust_pkgs = tpkgs1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_trust_pkgs = tpkgs2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, - imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } where plus_mod_dep (m1, boot1) (m2, boot2) - = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match - (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index db310f3c7f..2789a331cc 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -432,7 +432,7 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> ([InstMatch], -- Successful matches [Instance], -- These don't match but do unify Bool) -- True if error condition caused by - -- SafeHaskell condition. + -- Safe Haskell condition. -- The second component of the result pair happens when we look up -- Foo [a] @@ -462,7 +462,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- misleading (complaining of multiple matches when some should be -- overlapped away) - -- SafeHaskell: We restrict code compiled in 'Safe' mode from + -- Safe Haskell: We restrict code compiled in 'Safe' mode from -- overriding code compiled in any other mode. The rational is -- that code compiled in 'Safe' mode is code that is untrusted -- by the ghc user. So we shouldn't let that code change the diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index fc4d919473..8a0c62a2ed 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -596,6 +596,10 @@ keyword = bold -- | Class designating that some type has an 'SDoc' representation class Outputable a where ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + + ppr = pprPrec 0 + pprPrec _ = ppr \end{code} \begin{code} @@ -656,6 +660,27 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) ppr d <> comma, ppr e]) +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index f3749ca09c..40e4a015df 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -39,6 +39,7 @@ data Arch | ArchPPC | ArchPPC_64 | ArchSPARC + | ArchARM deriving (Show, Eq) @@ -63,6 +64,7 @@ target32Bit p = case platformArch p of ArchPPC -> True ArchPPC_64 -> False ArchSPARC -> True + ArchARM -> True -- | This predicates tells us whether the OS supports ELF-like shared libraries. @@ -95,6 +97,8 @@ defaultTargetArch = ArchPPC defaultTargetArch = ArchPPC_64 #elif sparc_TARGET_ARCH defaultTargetArch = ArchSPARC +#elif arm_TARGET_ARCH +defaultTargetArch = ArchARM #else defaultTargetArch = ArchUnknown #endif diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 7302b0295e..9c9fdc9bc4 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -64,7 +64,9 @@ import Outputable import Compiler.Hoopl hiding (Unique) +import Data.Function (on) import qualified Data.IntMap as M +import qualified Data.Foldable as Foldable \end{code} %************************************************************************ @@ -161,7 +163,13 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] %************************************************************************ \begin{code} -newtype UniqFM ele = UFM (M.IntMap ele) +newtype UniqFM ele = UFM { unUFM :: M.IntMap ele } + +instance Eq ele => Eq (UniqFM ele) where + (==) = (==) `on` unUFM + +instance Foldable.Foldable UniqFM where + foldMap f = Foldable.foldMap f . unUFM emptyUFM = UFM M.empty isNullUFM (UFM m) = M.null m |