[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Document how -O3 is handled by GHC
Marge Bot
gitlab at gitlab.haskell.org
Tue Apr 16 14:40:19 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b024e289 by Giles Anderson at 2019-04-15T10:20:29Z
Document how -O3 is handled by GHC
-O2 is the highest value of optimization.
-O3 will be reverted to -O2.
- - - - -
4b1ef06d by Giles Anderson at 2019-04-15T10:20:29Z
Apply suggestion to docs/users_guide/using-optimisation.rst
- - - - -
71cf94db by Fraser Tweedale at 2019-04-15T10:26:37Z
GHCi: fix load order of .ghci files
Directives in .ghci files in the current directory ("local .ghci")
can be overridden by global files. Change the order in which the
configs are loaded: global and $HOME/.ghci first, then local.
Also introduce a new field to GHCiState to control whether local
.ghci gets sourced or ignored. This commit does not add a way to
set this value (a subsequent commit will add this), but the .ghci
sourcing routine respects its value.
Fixes: https://gitlab.haskell.org/ghc/ghc/issues/14689
Related: https://gitlab.haskell.org/ghc/ghc/issues/6017
Related: https://gitlab.haskell.org/ghc/ghc/issues/14250
- - - - -
5c06b60d by Fraser Tweedale at 2019-04-15T10:26:38Z
users-guide: update startup script order
Update users guide to match the new startup script order. Also
clarify that -ignore-dot-ghci does not apply to scripts specified
via the -ghci-script option.
Part of: https://gitlab.haskell.org/ghc/ghc/issues/14689
- - - - -
aa490b35 by Fraser Tweedale at 2019-04-15T10:26:38Z
GHCi: add 'local-config' setting
Add the ':set local-config { source | ignore }' setting to control
whether .ghci file in current directory will be sourced or not. The
directive can be set in global config or $HOME/.ghci, which are
processed before local .ghci files.
The default is "source", preserving current behaviour.
Related: https://gitlab.haskell.org/ghc/ghc/issues/6017
Related: https://gitlab.haskell.org/ghc/ghc/issues/14250
- - - - -
ed94d345 by Fraser Tweedale at 2019-04-15T10:26:38Z
users-guide: document :set local-config
Document the ':set local-config' command and add a warning about
sourcing untrusted local .ghci scripts.
Related: https://gitlab.haskell.org/ghc/ghc/issues/6017
Related: https://gitlab.haskell.org/ghc/ghc/issues/14250
- - - - -
be05bd81 by Gabor Greif at 2019-04-15T21:19:03Z
asm-emit-time IND_STATIC elimination
When a new closure identifier is being established to a
local or exported closure already emitted into the same
module, refrain from adding an IND_STATIC closure, and
instead emit an assembly-language alias.
Inter-module IND_STATIC objects still remain, and need to be
addressed by other measures.
Binary-size savings on nofib are around 0.1%.
- - - - -
322fddd8 by erthalion at 2019-04-16T14:40:10Z
Show dynamic object files (#16062)
Closes #16062. When -dynamic-too is specified, reflect that in the
progress message, like:
$ ghc Main.hs -dynamic-too
[1 of 1] Compiling Lib ( Main.hs, Main.o, Main.dyn_o )
instead of:
$ ghc Main.hs -dynamic-too
[1 of 1] Compiling Lib ( Main.hs, Main.o )
- - - - -
82668e8e by Andrey Mokhov at 2019-04-16T14:40:11Z
Hadrian: Generate GHC wrapper scripts
This is a temporary workaround for #16534. We generate wrapper scripts
<build-root>/ghc-stage1 and <build-root>/ghc-stage2 that can be used to
run Stage1 and Stage2 GHCs with the right arguments.
See https://gitlab.haskell.org/ghc/ghc/issues/16534.
- - - - -
27 changed files:
- compiler/cmm/CLabel.hs
- compiler/codeGen/StgCmmBind.hs
- compiler/llvmGen/Llvm/Types.hs
- compiler/llvmGen/LlvmCodeGen/Base.hs
- compiler/llvmGen/LlvmCodeGen/Data.hs
- compiler/llvmGen/LlvmCodeGen/Ppr.hs
- compiler/main/DynFlags.hs
- compiler/main/HscTypes.hs
- compiler/nativeGen/PPC/Ppr.hs
- compiler/nativeGen/SPARC/Ppr.hs
- compiler/nativeGen/X86/Ppr.hs
- docs/users_guide/ghci.rst
- docs/users_guide/using-optimisation.rst
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/Generate.hs
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/T15155.stdout
- + testsuite/tests/codeGen/should_compile/T15155l.hs
- + testsuite/tests/codeGen/should_compile/T15155l.stdout
- testsuite/tests/codeGen/should_compile/all.T
- + testsuite/tests/driver/dynamicToo/dynamicToo006/Main.hs
- + testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile
- + testsuite/tests/driver/dynamicToo/dynamicToo006/all.T
- + testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout
- testsuite/tests/safeHaskell/safeInfered/UnsafeInfered02.stderr
Changes:
=====================================
compiler/cmm/CLabel.hs
=====================================
@@ -98,7 +98,7 @@ module CLabel (
needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
- isLocalCLabel,
+ isLocalCLabel, mayRedirectTo,
-- * Conversions
toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
@@ -1432,3 +1432,139 @@ pprDynamicLinkerAsmLabel platform dllInfo lbl =
SymbolPtr -> text ".LC_" <> ppr lbl
GotSymbolPtr -> ppr lbl <> text "@got"
GotSymbolOffset -> ppr lbl <> text "@gotoff"
+
+-- Figure out whether `symbol` may serve as an alias
+-- to `target` within one compilation unit.
+--
+-- This is true if any of these holds:
+-- * `target` is a module-internal haskell name.
+-- * `target` is an exported name, but comes from the same
+-- module as `symbol`
+--
+-- These are sufficient conditions for establishing e.g. a
+-- GNU assembly alias ('.equiv' directive). Sadly, there is
+-- no such thing as an alias to an imported symbol (conf.
+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)
+-- See note [emit-time elimination of static indirections].
+--
+-- Precondition is that both labels represent the
+-- same semantic value.
+
+mayRedirectTo :: CLabel -> CLabel -> Bool
+mayRedirectTo symbol target
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isExternalName nam
+ , Just mod <- nameModule_maybe nam
+ , Just anam <- hasHaskellName symbol
+ , Just amod <- nameModule_maybe anam
+ = amod == mod
+
+ | Just nam <- haskellName
+ , staticClosureLabel
+ , isInternalName nam
+ = True
+
+ | otherwise = False
+ where staticClosureLabel = isStaticClosureLabel target
+ haskellName = hasHaskellName target
+
+
+{-
+Note [emit-time elimination of static indirections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in #15155, certain static values are repesentationally
+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).
+
+ newtype A = A Int
+ {-# NOINLINE a #-}
+ a = A 42
+
+a1_rYB :: Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []]
+a1_rYB = GHC.Types.I# 42#
+
+a [InlPrag=NOINLINE] :: A
+[GblId, Unf=OtherCon []]
+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)
+
+Formerly we created static indirections for these (IND_STATIC), which
+consist of a statically allocated forwarding closure that contains
+the (possibly tagged) indirectee. (See CMM/assembly below.)
+This approach is suboptimal for two reasons:
+ (a) they occupy extra space,
+ (b) they need to be entered in order to obtain the indirectee,
+ thus they cannot be tagged.
+
+Fortunately there is a common case where static indirections can be
+eliminated while emitting assembly (native or LLVM), viz. when the
+indirectee is in the same module (object file) as the symbol that
+points to it. In this case an assembly-level identification can
+be created ('.equiv' directive), and as such the same object will
+be assigned two names in the symbol table. Any of the identified
+symbols can be referenced by a tagged pointer.
+
+Currently the 'mayRedirectTo' predicate will
+give a clue whether a label can be equated with another, already
+emitted, label (which can in turn be an alias). The general mechanics
+is that we identify data (IND_STATIC closures) that are amenable
+to aliasing while pretty-printing of assembly output, and emit the
+'.equiv' directive instead of static data in such a case.
+
+Here is a sketch how the output is massaged:
+
+ Consider
+newtype A = A Int
+{-# NOINLINE a #-}
+a = A 42 -- I# 42# is the indirectee
+ -- 'a' is exported
+
+ results in STG
+
+a1_rXq :: GHC.Types.Int
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+ CCS_DONT_CARE GHC.Types.I#! [42#];
+
+T15155.a [InlPrag=NOINLINE] :: T15155.A
+[GblId, Unf=OtherCon []] =
+ CAF_ccs \ u [] a1_rXq;
+
+ and CMM
+
+[section ""data" . a1_rXq_closure" {
+ a1_rXq_closure:
+ const GHC.Types.I#_con_info;
+ const 42;
+ }]
+
+[section ""data" . T15155.a_closure" {
+ T15155.a_closure:
+ const stg_IND_STATIC_info;
+ const a1_rXq_closure+1;
+ const 0;
+ const 0;
+ }]
+
+The emitted assembly is
+
+#### INDIRECTEE
+a1_rXq_closure: -- module local haskell value
+ .quad GHC.Types.I#_con_info -- an Int
+ .quad 42
+
+#### BEFORE
+.globl T15155.a_closure -- exported newtype wrapped value
+T15155.a_closure:
+ .quad stg_IND_STATIC_info -- the closure info
+ .quad a1_rXq_closure+1 -- indirectee ('+1' being the tag)
+ .quad 0
+ .quad 0
+
+#### AFTER
+.globl T15155.a_closure -- exported newtype wrapped value
+.equiv a1_rXq_closure,T15155.a_closure -- both are shared
+
+The transformation is performed because
+ T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
+returns True.
+-}
=====================================
compiler/codeGen/StgCmmBind.hs
=====================================
@@ -78,7 +78,9 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
-- closure pointing directly to the indirectee. This is exactly
-- what the CAF will eventually evaluate to anyway, we're just
-- shortcutting the whole process, and generating a lot less code
- -- (#7308)
+ -- (#7308). Eventually the IND_STATIC closure will be eliminated
+ -- by assembly '.equiv' directives, where possible (#15155).
+ -- See note [emit-time elimination of static indirections] in CLabel.
--
-- Note: we omit the optimisation when this binding is part of a
-- recursive group, because the optimisation would inhibit the black
=====================================
compiler/llvmGen/Llvm/Types.hs
=====================================
@@ -185,6 +185,7 @@ pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic (LMBitc v t) =
ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
<> char ')'
+pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v
pprSpecialStatic stat = ppr stat
=====================================
compiler/llvmGen/LlvmCodeGen/Base.hs
=====================================
@@ -31,7 +31,7 @@ module LlvmCodeGen.Base (
strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
getGlobalPtr, generateExternDecls,
- aliasify,
+ aliasify, llvmDefLabel
) where
#include "HsVersions.h"
@@ -57,6 +57,7 @@ import UniqSupply
import ErrUtils
import qualified Stream
+import Data.Maybe (fromJust)
import Control.Monad (ap)
-- ----------------------------------------------------------------------------
@@ -376,7 +377,7 @@ ghcInternalFunctions = do
mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
where
mk n ret args = do
- let n' = fsLit n `appendFS` fsLit "$def"
+ let n' = llvmDefLabel $ fsLit n
decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing
renderLlvm $ ppLlvmFunctionDecl decl
@@ -436,12 +437,17 @@ getGlobalPtr llvmLbl = do
let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
case m_ty of
-- Directly reference if we have seen it already
- Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
+ Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
-- Otherwise use a forward alias of it
Nothing -> do
saveAlias llvmLbl
return $ mkGlbVar llvmLbl i8 Alias
+-- | Derive the definition label. It has an identified
+-- structure type.
+llvmDefLabel :: LMString -> LMString
+llvmDefLabel = (`appendFS` fsLit "$def")
+
-- | Generate definitions for aliases forward-referenced by @getGlobalPtr at .
--
-- Must be called at a point where we are sure that no new global definitions
@@ -472,10 +478,28 @@ generateExternDecls = do
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
+-- See note [emit-time elimination of static indirections] in CLabel.
+-- Here we obtain the indirectee's precise type and introduce
+-- fresh aliases to both the precise typed label (lbl$def) and the i8*
+-- typed (regular) label of it with the matching new names.
+aliasify (LMGlobal (LMGlobalVar lbl ty at LMAlias{} link sect align Alias)
+ (Just orig)) = do
+ let defLbl = llvmDefLabel lbl
+ LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
+ defOrigLbl = llvmDefLabel origLbl
+ orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
+ origType <- funLookup origLbl
+ let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
+ (pLift $ fromJust origType) oLnk
+ Nothing Nothing Alias))
+ (pLift ty)
+ pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
+ , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
+ ]
aliasify (LMGlobal var val) = do
let LMGlobalVar lbl ty link sect align const = var
- defLbl = lbl `appendFS` fsLit "$def"
+ defLbl = llvmDefLabel lbl
defVar = LMGlobalVar defLbl ty Internal sect align const
defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
=====================================
compiler/llvmGen/LlvmCodeGen/Data.hs
=====================================
@@ -32,12 +32,41 @@ import qualified Data.ByteString as BS
structStr :: LMString
structStr = fsLit "_struct"
+-- | The LLVM visibility of the label
+linkage :: CLabel -> LlvmLinkageType
+linkage lbl = if externallyVisibleCLabel lbl
+ then ExternallyVisible else Internal
+
-- ----------------------------------------------------------------------------
-- * Top level
--
-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
+-- See note [emit-time elimination of static indirections] in CLabel.
+genLlvmData (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+ | lbl == mkIndStaticInfoLabel
+ , let labelInd (CmmLabelOff l _) = Just l
+ labelInd (CmmLabel l) = Just l
+ labelInd _ = Nothing
+ , Just ind' <- labelInd ind
+ , alias `mayRedirectTo` ind' = do
+ label <- strCLabel_llvm alias
+ label' <- strCLabel_llvm ind'
+ let link = linkage alias
+ link' = linkage ind'
+ -- the LLVM type we give the alias is an empty struct type
+ -- but it doesn't really matter, as the pointer is only
+ -- used for (bit/int)casting.
+ tyAlias = LMAlias (label `appendFS` structStr, LMStructU [])
+
+ aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
+ -- we don't know the type of the indirectee here
+ indType = panic "will be filled by 'aliasify', later"
+ orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
+
+ pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
+
genLlvmData (sec, Statics lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
@@ -45,11 +74,10 @@ genLlvmData (sec, Statics lbl xs) = do
let types = map getStatType static
strucTy = LMStruct types
- tyAlias = LMAlias ((label `appendFS` structStr), strucTy)
+ tyAlias = LMAlias (label `appendFS` structStr, strucTy)
struct = Just $ LMStaticStruc static tyAlias
- link = if (externallyVisibleCLabel lbl)
- then ExternallyVisible else Internal
+ link = linkage lbl
align = case sec of
Section CString _ -> Just 1
_ -> Nothing
=====================================
compiler/llvmGen/LlvmCodeGen/Ppr.hs
=====================================
@@ -71,7 +71,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
prefix lmblocks
name = decName $ funcDecl fun
- defName = name `appendFS` fsLit "$def"
+ defName = llvmDefLabel name
funcDecl' = (funcDecl fun) { decName = defName }
fun' = fun { funcDecl = funcDecl' }
funTy = LMFunction funcDecl'
=====================================
compiler/main/DynFlags.hs
=====================================
@@ -41,6 +41,7 @@ module DynFlags (
whenGeneratingDynamicToo, ifGeneratingDynamicToo,
whenCannotGenerateDynamicToo,
dynamicTooMkDynamicDynFlags,
+ dynamicOutputFile,
DynFlags(..),
FlagSpec(..),
HasDynFlags(..), ContainsDynFlags(..),
@@ -1823,6 +1824,12 @@ dynamicTooMkDynamicDynFlags dflags0
dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo
in dflags4
+-- | Compute the path of the dynamic object corresponding to an object file.
+dynamicOutputFile :: DynFlags -> FilePath -> FilePath
+dynamicOutputFile dflags outputFile = dynOut outputFile
+ where
+ dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension
+
-----------------------------------------------------------------------------
-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value
@@ -2772,11 +2779,11 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let chooseOutput
| isJust (outputFile dflags3) -- Only iff user specified -o ...
, not (isJust (dynOutputFile dflags3)) -- but not -dyno
- = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) }
+ = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile }
| otherwise
= return dflags3
where
- dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension
+ outFile = fromJust $ outputFile dflags3
dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3)
let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
=====================================
compiler/main/HscTypes.hs
=====================================
@@ -2805,6 +2805,9 @@ msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))
msHiFilePath ms = ml_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
+msDynObjFilePath :: ModSummary -> DynFlags -> FilePath
+msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)
+
-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> Bool
isBootSummary ms = ms_hsc_src ms == HsBootFile
@@ -2824,20 +2827,26 @@ showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg dflags target recomp mod_summary = showSDoc dflags $
if gopt Opt_HideSourcePaths dflags
then text mod_str
- else hsep
+ else hsep $
[ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')
, char '('
, text (op $ msHsFilePath mod_summary) <> char ','
- , case target of
- HscInterpreted | recomp -> text "interpreted"
- HscNothing -> text "nothing"
- _ -> text (op $ msObjFilePath mod_summary)
- , char ')'
- ]
+ ] ++
+ if gopt Opt_BuildDynamicToo dflags
+ then [ text obj_file <> char ','
+ , text dyn_file
+ , char ')'
+ ]
+ else [ text obj_file, char ')' ]
where
- op = normalise
- mod = moduleName (ms_mod mod_summary)
- mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
+ op = normalise
+ mod = moduleName (ms_mod mod_summary)
+ mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
+ dyn_file = op $ msDynObjFilePath mod_summary dflags
+ obj_file = case target of
+ HscInterpreted | recomp -> "interpreted"
+ HscNothing -> "nothing"
+ _ -> (op $ msObjFilePath mod_summary)
{-
************************************************************************
=====================================
compiler/nativeGen/PPC/Ppr.hs
=====================================
@@ -27,6 +27,7 @@ import Hoopl.Label
import BlockId
import CLabel
+import PprCmmExpr ()
import Unique ( pprUniqueAlways, getUnique )
import Platform
@@ -119,6 +120,16 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
pprDatas :: CmmStatics -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+ | lbl == mkIndStaticInfoLabel
+ , let labelInd (CmmLabelOff l _) = Just l
+ labelInd (CmmLabel l) = Just l
+ labelInd _ = Nothing
+ , Just ind' <- labelInd ind
+ , alias `mayRedirectTo` ind'
+ = pprGloblDecl alias
+ $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
pprData :: CmmStatic -> SDoc
=====================================
compiler/nativeGen/SPARC/Ppr.hs
=====================================
@@ -102,6 +102,16 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
pprDatas :: CmmStatics -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+ | lbl == mkIndStaticInfoLabel
+ , let labelInd (CmmLabelOff l _) = Just l
+ labelInd (CmmLabel l) = Just l
+ labelInd _ = Nothing
+ , Just ind' <- labelInd ind
+ , alias `mayRedirectTo` ind'
+ = pprGloblDecl alias
+ $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
pprData :: CmmStatic -> SDoc
@@ -634,4 +644,3 @@ pp_comma_lbracket = text ",["
pp_comma_a :: SDoc
pp_comma_a = text ",a"
-
=====================================
compiler/nativeGen/X86/Ppr.hs
=====================================
@@ -145,7 +145,19 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
(l at LOCATION{} : _) -> pprInstr l
_other -> empty
+
pprDatas :: (Alignment, CmmStatics) -> SDoc
+-- See note [emit-time elimination of static indirections] in CLabel.
+pprDatas (_, Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+ | lbl == mkIndStaticInfoLabel
+ , let labelInd (CmmLabelOff l _) = Just l
+ labelInd (CmmLabel l) = Just l
+ labelInd _ = Nothing
+ , Just ind' <- labelInd ind
+ , alias `mayRedirectTo` ind'
+ = pprGloblDecl alias
+ $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')
+
pprDatas (align, (Statics lbl dats))
= vcat (pprAlign align : pprLabel lbl : map pprData dats)
=====================================
docs/users_guide/ghci.rst
=====================================
@@ -2649,6 +2649,17 @@ commonly used commands.
Sets the command used by :ghci-cmd:`:edit` to ⟨cmd⟩.
+.. ghci-cmd:: :set local-config; ⟨source|ignore⟩
+
+ If ``ignore``, :file:`./.ghci` files will be ignored (sourcing
+ untrusted local scripts is a security risk). The default is
+ ``source``. Set this directive in your user :file:`.ghci`
+ script, i.e. before the local script would be sourced.
+
+ Even when set to ``ignore``, a local script will still be
+ processed if given by :ghc-flag:`-ghci-script` on the command
+ line, or sourced via :ghci-cmd:`:script`.
+
.. ghci-cmd:: :set prog; ⟨prog⟩
.. index::
@@ -3101,15 +3112,14 @@ When it starts, unless the :ghc-flag:`-ignore-dot-ghci` flag is given, GHCi
reads and executes commands from the following files, in this order, if
they exist:
-1. :file:`./.ghci`
+1. :file:`{ghcappdata}/ghci.conf`, where ⟨ghcappdata⟩ depends on
+ your system, but is usually something like :file:`$HOME/.ghc` on
+ Unix or :file:`C:/Documents and Settings/user/Application
+ Data/ghc` on Windows.
-2. :file:`{appdata}/ghc/ghci.conf`, where ⟨appdata⟩ depends on your system,
- but is usually something like
- :file:`C:/Documents and Settings/user/Application Data`
+2. :file:`$HOME/.ghci`
-3. On Unix: :file:`$HOME/.ghc/ghci.conf`
-
-4. :file:`$HOME/.ghci`
+3. :file:`./.ghci`
The :file:`ghci.conf` file is most useful for turning on favourite options
(e.g. ``:set +s``), and defining useful macros.
@@ -3134,6 +3144,12 @@ three subdirectories A, B and C, you might put the following lines in
fact it works to set it using :ghci-cmd:`:set` like this. The changes won't take
effect until the next :ghci-cmd:`:load`, though.)
+.. warning::
+ Sourcing untrusted :file:`./.ghci` files is a security risk.
+ They can contain arbitrary commands that will be executed as the
+ user. Use :ghci-cmd:`:set local-config` to inhibit the
+ processing of :file:`./.ghci` files.
+
Once you have a library of GHCi macros, you may want to source them from
separate files, or you may want to source your ``.ghci`` file into your
running GHCi session while debugging it
@@ -3166,8 +3182,9 @@ read:
:type: dynamic
:category:
- Read a specific file after the usual startup files. Maybe be
+ Read a specific file after the usual startup files. May be
specified repeatedly for multiple inputs.
+ :ghc-flag:`-ignore-dot-ghci` does not apply to these files.
When defining GHCi macros, there is some important behavior you should
be aware of when names may conflict with built-in commands, especially
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -88,6 +88,17 @@ So, for example, ``ghc -c Foo.hs``
runtime or space *worse* if you're unlucky. They are normally turned
on or off individually.
+.. ghc-flag:: -O⟨n⟩
+ :shortdesc: Any -On where n > 2 is the same as -O2.
+ :type: dynamic
+ :reverse: -O0
+ :category: optimization-levels
+
+ .. index::
+ single: optimise; aggressively
+
+ Any -On where n > 2 is the same as -O2.
+
We don't use a ``-O*`` flag for day-to-day work. We use ``-O`` to get
respectable speed; e.g., when we want to measure something. When we want
to go for broke, we tend to use ``-O2`` (and we go for lots of coffee
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -102,7 +102,7 @@ import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
- partition, sort, sortBy )
+ partition, sort, sortBy, (\\) )
import qualified Data.Set as S
import Data.Maybe
import Data.Map (Map)
@@ -351,13 +351,16 @@ defFullHelpText =
"\n" ++
" :set <option> ... set options\n" ++
" :seti <option> ... set options for interactive evaluation only\n" ++
+ " :set local-config { source | ignore }\n" ++
+ " set whether to source .ghci in current dir\n" ++
+ " (loading untrusted config is a security issue)\n" ++
" :set args <arg> ... set the arguments returned by System.getArgs\n" ++
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
" :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" ++
" :set prompt-function <expr> set the function to handle the prompt\n" ++
- " :set prompt-cont-function <expr>" ++
- "set the function to handle the continuation prompt\n" ++
+ " :set prompt-cont-function <expr>\n" ++
+ " set the function to handle the continuation prompt\n" ++
" :set editor <cmd> set the command used for :edit\n" ++
" :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
" :unset <option> ... unset options\n" ++
@@ -482,6 +485,7 @@ interactiveUI config srcs maybe_exprs = do
stop = default_stop,
editor = default_editor,
options = [],
+ localConfig = SourceLocalConfig,
-- We initialize line number as 0, not 1, because we use
-- current line number while reporting errors which is
-- incremented after reading a line.
@@ -566,8 +570,6 @@ runGHCi paths maybe_exprs = do
let
ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
- current_dir = return (Just ".ghci")
-
app_user_dir = liftIO $ withGhcAppData
(\dir -> return (Just (dir </> "ghci.conf")))
(return Nothing)
@@ -606,17 +608,44 @@ runGHCi paths maybe_exprs = do
setGHCContextFromGHCiState
- dot_cfgs <- if ignore_dot_ghci then return [] else do
- dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
- liftIO $ filterM checkFileAndDirPerms dot_files
- mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs
+ processedCfgs <- if ignore_dot_ghci
+ then pure []
+ else do
+ userCfgs <- do
+ paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]
+ checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths
+ liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths
+
+ localCfg <- do
+ let path = ".ghci"
+ ok <- liftIO $ checkFileAndDirPerms path
+ if ok then liftIO $ canonicalizePath' path else pure Nothing
+
+ mapM_ sourceConfigFile userCfgs
+ -- Process the global and user .ghci
+ -- (but not $CWD/.ghci or CLI args, yet)
+
+ behaviour <- localConfig <$> getGHCiState
+
+ processedLocalCfg <- case localCfg of
+ Just path | path `notElem` userCfgs ->
+ -- don't read .ghci twice if CWD is $HOME
+ case behaviour of
+ SourceLocalConfig -> localCfg <$ sourceConfigFile path
+ IgnoreLocalConfig -> pure Nothing
+ _ -> pure Nothing
+
+ pure $ maybe id (:) processedLocalCfg userCfgs
let arg_cfgs = reverse $ ghciScripts dflags
-- -ghci-script are collected in reverse order
-- We don't require that a script explicitly added by -ghci-script
-- is owned by the current user. (#6017)
- mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
- -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
+
+ mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs
+ -- Dedup, and remove any configs we already processed.
+ -- Importantly, if $PWD/.ghci was ignored due to configuration,
+ -- explicitly specifying it does cause it to be processed.
-- Perform a :load for files given on the GHCi command line
-- When in -e mode, if the load fails then we want to stop
@@ -2663,6 +2692,8 @@ setCmd str
Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
Right ("stop", rest) -> setStop $ dropWhile isSpace rest
+ Right ("local-config", rest) ->
+ setLocalConfigBehaviour $ dropWhile isSpace rest
_ -> case toArgs str of
Left err -> liftIO (hPutStrLn stderr err)
Right wds -> setOptions wds
@@ -2728,6 +2759,7 @@ showDynFlags show_all dflags = do
setArgs, setOptions :: GhciMonad m => [String] -> m ()
setProg, setEditor, setStop :: GhciMonad m => String -> m ()
+setLocalConfigBehaviour :: GhciMonad m => String -> m ()
setArgs args = do
st <- getGHCiState
@@ -2741,6 +2773,14 @@ setProg prog = do
setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
+setLocalConfigBehaviour s
+ | s == "source" =
+ modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })
+ | s == "ignore" =
+ modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })
+ | otherwise = throwGhcException
+ (CmdLineError "syntax: :set local-config { source | ignore }")
+
setStop str@(c:_) | isDigit c
= do let (nm_str,rest) = break (not.isDigit) str
nm = read nm_str
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -15,6 +15,7 @@ module GHCi.UI.Monad (
GHCiState(..), GhciMonad(..),
GHCiOption(..), isOptionSet, setOption, unsetOption,
Command(..), CommandResult(..), cmdSuccess,
+ LocalConfigBehaviour(..),
PromptFunction,
BreakLocation(..),
TickArray,
@@ -79,6 +80,7 @@ data GHCiState = GHCiState
prompt_cont :: PromptFunction,
editor :: String,
stop :: String,
+ localConfig :: LocalConfigBehaviour,
options :: [GHCiOption],
line_number :: !Int, -- ^ input line
break_ctr :: !Int,
@@ -197,6 +199,15 @@ data GHCiOption
-- modules after load
deriving Eq
+-- | Treatment of ./.ghci files. For now we either load or
+-- ignore. But later we could implement a "safe mode" where
+-- only safe operations are performed.
+--
+data LocalConfigBehaviour
+ = SourceLocalConfig
+ | IgnoreLocalConfig
+ deriving (Eq)
+
data BreakLocation
= BreakLocation
{ breakModule :: !GHC.Module
=====================================
hadrian/src/Rules.hs
=====================================
@@ -83,7 +83,12 @@ topLevelTargets = action $ do
targets <- concatForM buildStages $ \stage -> do
packages <- stagePackages stage
mapM (path stage) packages
- need targets
+
+ -- Why we need wrappers: https://gitlab.haskell.org/ghc/ghc/issues/16534.
+ root <- buildRoot
+ let wrappers = [ root -/- ("ghc-" ++ stageString s) | s <- [Stage1 ..]
+ , s < finalStage ]
+ need (targets ++ wrappers)
where
-- either the package database config file for libraries or
-- the programPath for programs. However this still does
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -170,6 +170,10 @@ copyRules = do
generateRules :: Rules ()
generateRules = do
root <- buildRootRules
+
+ (root -/- "ghc-stage1") <~ ghcWrapper Stage1
+ (root -/- "ghc-stage2") <~ ghcWrapper Stage2
+
priority 2.0 $ (root -/- generatedDir -/- "ghcautoconf.h") <~ generateGhcAutoconfH
priority 2.0 $ (root -/- generatedDir -/- "ghcplatform.h") <~ generateGhcPlatformH
priority 2.0 $ (root -/- generatedDir -/- "ghcversion.h") <~ generateGhcVersionH
@@ -190,6 +194,17 @@ emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
-- Generators
+-- | GHC wrapper scripts used for passing the path to the right package database
+-- when invoking in-tree GHC executables.
+ghcWrapper :: Stage -> Expr String
+ghcWrapper Stage0 = error "Stage0 GHC does not require a wrapper script to run."
+ghcWrapper stage = do
+ dbPath <- expr $ packageDbPath stage
+ ghcPath <- expr $ programPath (vanillaContext (pred stage) ghc)
+ return $ unwords $ map show $ [ ghcPath ]
+ ++ [ "-package-db " ++ dbPath | stage == Stage1 ]
+ ++ [ "$@" ]
+
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' is a valid C preprocessor identifier.
cppify :: String -> String
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -43,3 +43,18 @@ T15723:
'$(TEST_HC)' $(TEST_HC_OPTS) -prof -fPIC -fexternal-dynamic-refs -fforce-recomp -O2 -c T15723A.hs -o T15723A.o
'$(TEST_HC)' $(TEST_HC_OPTS) -prof -fPIC -fexternal-dynamic-refs -fforce-recomp -O2 -c T15723B.hs -o T15723B.o
'$(TEST_HC)' $(TEST_HC_OPTS) -dynamic -shared T15723B.o -o T15723B.so
+
+## check that there are two assembly equates
+# mentioning T15155.a_closure (def and use)
+T15155:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O0 -ddump-asm T15155l.hs | grep -F ".equiv " \
+ | grep -F "T15155.a_closure" | wc -l | sed -e 's/ *//g' | grep "2" ; echo $$?
+
+## check that there are two "$def" aliases:
+# - one that bitcasts to %T15155_a_closure_struct*
+# - and the other which bitcasts from %T15155_a_closure_struct*
+##
+T15155l:
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O0 -ddump-llvm T15155l.hs 2>/dev/null \
+ | grep -F "= alias %T15155_" | grep -E "@T15155_[ab]_closure.def = " | grep -F "%T15155_a_closure_struct*" \
+ | wc -l | sed -e 's/ *//g' | grep "2"; echo $$?
=====================================
testsuite/tests/codeGen/should_compile/T15155.stdout
=====================================
@@ -0,0 +1,2 @@
+2
+0
=====================================
testsuite/tests/codeGen/should_compile/T15155l.hs
=====================================
@@ -0,0 +1,8 @@
+module T15155 (a, B(..), b) where
+
+newtype A = A Int
+newtype B = B A
+
+{-# NOINLINE a #-}
+a = A 42
+b = B a
=====================================
testsuite/tests/codeGen/should_compile/T15155l.stdout
=====================================
@@ -0,0 +1,2 @@
+2
+0
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -44,7 +44,7 @@ test('T14999',
# Verify that we optimize away redundant jumps for unordered comparisons.
test('T15196',
- [ unless(arch('x86_64'),skip),
+ [ unless(arch('x86_64'), skip),
only_ways('normal'),
], makefile_test, [])
@@ -52,3 +52,10 @@ test('T15723',
[ unless(have_profiling(), skip),
unless(have_dynamic(), skip),
], makefile_test, [])
+
+test('T15155',
+ [ unless(have_ncg(), skip)
+ ], makefile_test, [])
+
+test('T15155l', when(unregisterised(), skip),
+ makefile_test, [])
=====================================
testsuite/tests/driver/dynamicToo/dynamicToo006/Main.hs
=====================================
@@ -0,0 +1 @@
+main = print "a"
=====================================
testsuite/tests/driver/dynamicToo/dynamicToo006/Makefile
=====================================
@@ -0,0 +1,16 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+ rm -f *.o
+ rm -f *.hi
+ rm -f Main
+
+# check that the compilation progress message will contain
+# *.dyn_o file with -dynamic-too
+main:
+ rm -f *.o
+ rm -f *.hi
+ rm -f Main
+ '$(TEST_HC)' $(TEST_HC_OPTS) -dynamic-too Main.hs
=====================================
testsuite/tests/driver/dynamicToo/dynamicToo006/all.T
=====================================
@@ -0,0 +1,2 @@
+test('dynamicToo006', [normalise_slashes, extra_files(['Main.hs'])],
+ run_command, ['$MAKE -s main --no-print-director'])
=====================================
testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 1] Compiling Main ( Main.hs, Main.o, Main.dyn_o )
+Linking Main ...
=====================================
testsuite/tests/safeHaskell/safeInfered/UnsafeInfered02.stderr
=====================================
@@ -1,5 +1,5 @@
-[1 of 2] Compiling UnsafeInfered02_A ( UnsafeInfered02_A.hs, UnsafeInfered02_A.o )
-[2 of 2] Compiling UnsafeInfered02 ( UnsafeInfered02.hs, UnsafeInfered02.o )
+[1 of 2] Compiling UnsafeInfered02_A ( UnsafeInfered02_A.hs, UnsafeInfered02_A.o, UnsafeInfered02_A.dyn_o )
+[2 of 2] Compiling UnsafeInfered02 ( UnsafeInfered02.hs, UnsafeInfered02.o, UnsafeInfered02.dyn_o )
UnsafeInfered02.hs:4:1: error:
UnsafeInfered02_A: Can't be safely imported!
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/852107ad049d0d6fc250bbb86ad48b60b3b7255c...82668e8eeed294d4ffdd1599192e3574907dd0ed
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/852107ad049d0d6fc250bbb86ad48b60b3b7255c...82668e8eeed294d4ffdd1599192e3574907dd0ed
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190416/40adba5c/attachment-0001.html>
More information about the ghc-commits
mailing list