[Git][ghc/ghc][wip/andrey/ghc-wrapper-script] 3 commits: asm-emit-time IND_STATIC elimination
Marge Bot
gitlab at gitlab.haskell.org
Tue Apr 16 19:46:50 UTC 2019
Marge Bot pushed to branch wip/andrey/ghc-wrapper-script at Glasgow Haskell Compiler / GHC
Commits:
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%.
- - - - -
57eb5bc6 by erthalion at 2019-04-16T19:40:36Z
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 )
- - - - -
894ec447 by Andrey Mokhov at 2019-04-16T19:46:44Z
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.
- - - - -
23 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
- 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)
=====================================
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/062e97ed4238ee1d7b4f1ee6627332917fa7d032...894ec447955a5066faee1b87af9cc7785ae14cd8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/062e97ed4238ee1d7b4f1ee6627332917fa7d032...894ec447955a5066faee1b87af9cc7785ae14cd8
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/7cbceb3b/attachment-0001.html>
More information about the ghc-commits
mailing list