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 | |
| parent | a347cd7c384eb255b5507a40840205d052f137c6 (diff) | |
| parent | e49dae36a00b2af8f6ad583dd24f9bacf5711242 (diff) | |
| download | haskell-bfbf3858110b1e16b2efd89f691e426b03e52343.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
54 files changed, 636 insertions, 337 deletions
diff --git a/.gitignore b/.gitignore index ac8c70e59d..2bfec1656b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,9 @@ # ----------------------------------------------------------------------------- # generic generated file patterns +Thumbs.db +.DS_Store + *~ #*# *.bak @@ -233,4 +236,4 @@ _darcs/ /utils/unlit/unlit -/extra-gcc-opts
\ No newline at end of file +/extra-gcc-opts diff --git a/aclocal.m4 b/aclocal.m4 index d6b97fe52b..f8dafaca5f 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -1523,6 +1523,9 @@ AC_DEFUN([GHC_CONVERT_VENDOR],[ pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 $2="unknown" ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + $2="unknown" + ;; *) #pass thru by default $2="$1" 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 diff --git a/distrib/MacOS/mkinstaller b/distrib/MacOS/mkinstaller index feb3db080b..feb3db080b 100644..100755 --- a/distrib/MacOS/mkinstaller +++ b/distrib/MacOS/mkinstaller diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 43c713e119..7ef9e80045 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -487,6 +487,12 @@ <entry>-</entry> </row> <row> + <entry><option>-ghci-script</option></entry> + <entry>Load the given additional <filename>.ghci</filename> file</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> <entry><option>-read-dot-ghci</option></entry> <entry>Enable reading of <filename>.ghci</filename> files</entry> <entry>static</entry> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index 72481eb24f..62522e855b 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -2872,6 +2872,10 @@ Prelude> :set -fno-glasgow-exts </varlistentry> </variablelist> + <para>Additional <filename>.ghci</filename> files can be added + through the <option>-ghci-script</option> option. These are + loaded after the normal <filename>.ghci</filename> files.</para> + </sect1> <sect1 id="ghci-obj"> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1869040a80..139c2b462e 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -426,7 +426,8 @@ runGHCi paths maybe_exprs = do getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do - mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] + ++ map (return . Just) opt_GhciScripts mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0) mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the @@ -1321,7 +1322,7 @@ runScript filename = do else return () ----------------------------------------------------------------------------- --- Displaying SafeHaskell properties of a module +-- Displaying Safe Haskell properties of a module isSafeCmd :: String -> InputT GHCi () isSafeCmd m = diff --git a/rts/Adjustor.c b/rts/Adjustor.c index 607c0b8abe..0d5829368f 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -47,7 +47,7 @@ Haskell side. #include <string.h> #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) extern void adjustorCode(void); #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) // from AdjustorAsm.s @@ -288,7 +288,7 @@ typedef struct AdjustorStub { #endif #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) /* !!! !!! WARNING: !!! !!! * This structure is accessed from AdjustorAsm.s @@ -304,7 +304,7 @@ typedef struct AdjustorStub { } AdjustorStub; #endif -#if (defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) +#if defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) static int totalArgumentSize(char *typeString) { int sz = 0; @@ -380,54 +380,14 @@ createAdjustor(int cconv, StgStablePtr hptr, break; case 1: /* _ccall */ -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) - /* Magic constant computed by inspecting the code length of - the following assembly language snippet - (offset and machine code prefixed): - - <00>: 68 ef be ad de pushl $0xdeadbeef # constant is large enough to - # hold a StgStablePtr - <05>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr - <0a>: 68 ef be ad de pushl $obscure_ccall_ret_code # push the return address - <0f>: ff e0 jmp *%eax # jump to wptr - - The ccall'ing version is a tad different, passing in the return - address of the caller to the auto-generated C stub (which enters - via the stable pointer.) (The auto-generated C stub is in on this - game, don't worry :-) - - See the comment next to obscure_ccall_ret_code why we need to - perform a tail jump instead of a call, followed by some C stack - fixup. - - Note: The adjustor makes the assumption that any return value - coming back from the C stub is not stored on the stack. - That's (thankfully) the case here with the restricted set of - return types that we support. - */ - adjustor = allocateExec(17,&code); - { - unsigned char *const adj_code = (unsigned char *)adjustor; - - adj_code[0x00] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ - *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr; - - adj_code[0x05] = (unsigned char)0xb8; /* movl $wptr, %eax */ - *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr; - - adj_code[0x0a] = (unsigned char)0x68; /* pushl obscure_ccall_ret_code */ - *((StgFunPtr*)(adj_code + 0x0b)) = - (StgFunPtr)obscure_ccall_ret_code; - - adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */ - adj_code[0x10] = (unsigned char)0xe0; - } -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) { /* - What's special about Darwin/Mac OS X on i386? - It wants the stack to stay 16-byte aligned. - + Most of the trickiness here is due to the need to keep the + stack pointer 16-byte aligned (see #5250). That means we + can't just push another argument on the stack and call the + wrapper, we may have to shuffle the whole argument block. + We offload most of the work to AdjustorAsm.S. */ AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code); diff --git a/rts/AdjustorAsm.S b/rts/AdjustorAsm.S index cfdef68349..75b83f6947 100644 --- a/rts/AdjustorAsm.S +++ b/rts/AdjustorAsm.S @@ -147,7 +147,7 @@ adjustorCode: /* ********************************* i386 ********************************** */ -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#elif defined(i386_HOST_ARCH) #define WS 4 #define RETVAL_OFF 5 @@ -158,8 +158,13 @@ adjustorCode: #define FRAMESIZE_OFF (HEADER_BYTES + 2*WS) #define ARGWORDS_OFF (HEADER_BYTES + 3*WS) +#ifdef LEADING_UNDERSCORE .globl _adjustorCode _adjustorCode: +#else + .globl adjustorCode +adjustorCode: +#endif popl %eax subl $RETVAL_OFF, %eax diff --git a/rts/StgCRun.c b/rts/StgCRun.c index e28353c353..54ac04151c 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -128,18 +128,29 @@ StgFunPtr StgReturn(void) #define STG_GLOBAL ".global " #endif -StgRegTable * -StgRun(StgFunPtr f, StgRegTable *basereg) { +static void GNUC3_ATTRIBUTE(used) +StgRunIsImplementedInAssembler(void) +{ + __asm__ volatile ( + STG_GLOBAL STG_RUN "\n" + STG_RUN ":\n\t" - unsigned char space[ RESERVED_C_STACK_BYTES + 4*sizeof(void *) ]; - StgRegTable * r; + /* + * move %esp down to reserve an area for temporary storage + * during the execution of STG code. + * + * The stack pointer has to be aligned to a multiple of 16 + * bytes from here - this is a requirement of the C ABI, so + * that C code can assign SSE2 registers directly to/from + * stack locations. + */ + "subl %0, %%esp\n\t" - __asm__ volatile ( /* * save callee-saves registers on behalf of the STG code. */ - "movl %%esp, %%eax\n\t" - "addl %4, %%eax\n\t" + "movl %%esp, %%eax\n\t" + "addl %0-16, %%eax\n\t" "movl %%ebx,0(%%eax)\n\t" "movl %%esi,4(%%eax)\n\t" "movl %%edi,8(%%eax)\n\t" @@ -147,25 +158,17 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { /* * Set BaseReg */ - "movl %3,%%ebx\n\t" + "movl 24(%%eax),%%ebx\n\t" /* * grab the function argument from the stack */ - "movl %2,%%eax\n\t" - - /* - * Darwin note: - * The stack pointer has to be aligned to a multiple of 16 bytes at - * this point. This works out correctly with gcc 4.0.1, but it might - * break at any time in the future. TODO: Make this future-proof. - */ - - /* + "movl 20(%%eax),%%eax\n\t" + /* * jump to it */ "jmp *%%eax\n\t" - STG_GLOBAL STG_RETURN "\n" + STG_GLOBAL STG_RETURN "\n" STG_RETURN ":\n\t" "movl %%esi, %%eax\n\t" /* Return value in R1 */ @@ -174,18 +177,19 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { * restore callee-saves registers. (Don't stomp on %%eax!) */ "movl %%esp, %%edx\n\t" - "addl %4, %%edx\n\t" + "addl %0-16, %%edx\n\t" "movl 0(%%edx),%%ebx\n\t" /* restore the registers saved above */ "movl 4(%%edx),%%esi\n\t" "movl 8(%%edx),%%edi\n\t" "movl 12(%%edx),%%ebp\n\t" - : "=&a" (r), "=m" (space) - : "m" (f), "m" (basereg), "i" (RESERVED_C_STACK_BYTES) - : "edx" /* stomps on %edx */ - ); + "addl %0, %%esp\n\t" + "ret" - return r; + : : "i" (RESERVED_C_STACK_BYTES + 16 + 12) + // + 16 to make room for the 4 registers we have to save + // + 12 because we need to align %esp to a 16-byte boundary (#5250) + ); } #endif diff --git a/rts/Trace.h b/rts/Trace.h index b63e8760f3..dd396904e7 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -243,8 +243,8 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); HASKELLEVENT_REQUEST_PAR_GC(cap) #define dtraceCreateSparkThread(cap, spark_tid) \ HASKELLEVENT_CREATE_SPARK_THREAD(cap, spark_tid) -INLINE_HEADER void dtraceStartup (int n_caps) { - HASKELLEVENT_STARTUP(num_caps) +INLINE_HEADER void dtraceStartup (int num_caps) { + HASKELLEVENT_STARTUP(num_caps); } #define dtraceUserMsg(cap, msg) \ HASKELLEVENT_USER_MSG(cap, msg) @@ -279,7 +279,7 @@ INLINE_HEADER void dtraceStartup (int n_caps) { #define dtraceRequestSeqGc(cap) /* nothing */ #define dtraceRequestParGc(cap) /* nothing */ #define dtraceCreateSparkThread(cap, spark_tid) /* nothing */ -INLINE_HEADER void dtraceStartup (int n_caps STG_UNUSED) {}; +INLINE_HEADER void dtraceStartup (int num_caps STG_UNUSED) {}; #define dtraceUserMsg(cap, msg) /* nothing */ #define dtraceGcIdle(cap) /* nothing */ #define dtraceGcWork(cap) /* nothing */ diff --git a/rts/ghc.mk b/rts/ghc.mk index 38ddbc0d46..5ae873a46a 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -45,12 +45,8 @@ rts_CMM_SRCS := $(wildcard rts/*.cmm) # Don't compile .S files when bootstrapping a new arch ifneq "$(PORTING_HOST)" "YES" -ifneq "$(findstring $(TargetArch_CPP), powerpc powerpc64)" "" +ifneq "$(findstring $(TargetArch_CPP), i386 powerpc powerpc64)" "" rts_S_SRCS += rts/AdjustorAsm.S -else -ifneq "$(findstring $(TargetOS_CPP), darwin)" "" -rts_S_SRCS += rts/AdjustorAsm.S -endif endif endif diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py index f04b98ecd4..5a753279e6 100755 --- a/utils/fingerprint/fingerprint.py +++ b/utils/fingerprint/fingerprint.py @@ -159,7 +159,7 @@ def validate(opts, args, parser): if opts.dir: fname = opts.output if fname is None: - fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp" + fname = datetime.today().strftime("%Y-%m-%d_%H-%M-%S") + ".fp" path = os.path.join(opts.dir, fname) opts.output_file = path opts.output = file(path, "w") |