Commit c96022cb authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents a30c2df5 cea63079
......@@ -125,6 +125,8 @@ _darcs/
/docs/users_guide/ug-book.xml
/docs/users_guide/ug-ent.xml
/docs/users_guide/users_guide.xml
/docs/users_guide/users_guide.pdf
/docs/users_guide/users_guide.ps
/docs/users_guide/users_guide/
/docs/users_guide/what_glasgow_exts_does.gen.xml
/driver/ghc/dist/
......@@ -182,6 +184,7 @@ _darcs/
/libraries/time/
/libraries/*/dist-boot/
/libraries/*/dist-install/
/libraries/dist-haddock/
/mk/are-validating.mk
/mk/build.mk
/mk/config.h
......
......@@ -37,7 +37,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
llvmCodeGen dflags h us cmms
= let cmm = concat cmms
(cdata,env) = {-# SCC "llvm_split" #-}
foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
foldr split ([], initLlvmEnv dflags) cmm
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split (CmmProc i l _) (d,e) =
let lbl = strCLabel_llvm env $ case i of
......
......@@ -13,7 +13,7 @@ module LlvmCodeGen.Base (
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
ghcInternalFunctions,
getDflags, ghcInternalFunctions,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
......@@ -32,6 +32,7 @@ import CLabel
import CgUtils ( activeStgRegs )
import Config
import Constants
import DynFlags
import FastString
import OldCmm
import qualified Outputable as Outp
......@@ -150,12 +151,13 @@ defaultLlvmVersion = 28
--
-- two maps, one for functions and one for local vars.
newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, Platform)
newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment.
initLlvmEnv :: Platform -> LlvmEnv
initLlvmEnv platform = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, platform)
initLlvmEnv :: DynFlags -> LlvmEnv
initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ]
-- | Here we pre-initialise some functions that are used internally by GHC
......@@ -211,7 +213,11 @@ setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
-- | Get the platform we are generating code for
getLlvmPlatform :: LlvmEnv -> Platform
getLlvmPlatform (LlvmEnv (_, _, _, p)) = p
getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
-- | Get the DynFlags for this compilation pass
getDflags :: LlvmEnv -> DynFlags
getDflags (LlvmEnv (_, _, _, d)) = d
-- ----------------------------------------------------------------------------
-- * Label handling
......
......@@ -16,13 +16,14 @@ import CgUtils ( activeStgRegs, callerSaves )
import CLabel
import OldCmm
import qualified OldPprCmm as PprCmm
import OrdList
import DynFlags
import FastString
import ForeignCall
import Outputable hiding ( panic, pprPanic )
import qualified Outputable
import Platform
import OrdList
import UniqSupply
import Unique
import Util
......@@ -475,7 +476,7 @@ genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
-- Call to known function
genJump env (CmmLit (CmmLabel lbl)) live = do
(env', vf, stmts, top) <- getHsFunc env lbl
(stgRegs, stgStmts) <- funEpilogue live
(stgRegs, stgStmts) <- funEpilogue env live
let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
let s2 = Return Nothing
return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
......@@ -494,7 +495,7 @@ genJump env expr live = do
++ show (ty) ++ ")"
(v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
(stgRegs, stgStmts) <- funEpilogue live
(stgRegs, stgStmts) <- funEpilogue env live
let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
let s3 = Return Nothing
return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
......@@ -550,7 +551,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [
= genStore_fast env addr r (negate $ fromInteger n) val
-- generic case
genStore env addr val = genStore_slow env addr val [top]
genStore env addr val = genStore_slow env addr val [other]
-- | CmmStore operation
-- This is a special case for storing to a global register pointer
......@@ -1032,7 +1033,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [
= genLoad_fast env e r (negate $ fromInteger n) ty
-- generic case
genLoad env e ty = genLoad_slow env e ty [top]
genLoad env e ty = genLoad_slow env e ty [other]
-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
......@@ -1200,29 +1201,33 @@ funPrologue = concat $ map getReg activeStgRegs
-- | Function epilogue. Load STG variables to use as argument for call.
funEpilogue :: Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
funEpilogue Nothing = do
-- STG Liveness optimisation done here.
funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
-- Have information and liveness optimisation is enabled
funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do
loads <- mapM loadExpr activeStgRegs
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
loadExpr r = do
loadExpr r | r `elem` alwaysLive || r `elem` live = do
let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
loadExpr r = do
let ty = (pLower . getVarType $ lmGlobalRegVar r)
return (LMLitVar $ LMUndefLit ty, unitOL Nop)
funEpilogue (Just live) = do
-- don't do liveness optimisation
funEpilogue _ _ = do
loads <- mapM loadExpr activeStgRegs
let (vars, stmts) = unzip loads
return (vars, concatOL stmts)
where
loadExpr r | r `elem` alwaysLive || r `elem` live = do
loadExpr r = do
let reg = lmGlobalRegVar r
(v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
return (v, unitOL s)
loadExpr r = do
let ty = (pLower . getVarType $ lmGlobalRegVar r)
return (LMLitVar $ LMUndefLit ty, unitOL Nop)
-- | A serries of statements to trash all the STG registers.
......
......@@ -4,7 +4,7 @@
module LlvmCodeGen.Regs (
lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA
stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA
) where
#include "HsVersions.h"
......@@ -70,23 +70,30 @@ stgTBAA
, MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN]
, MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN]
, MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN]
-- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'.
-- OR I think the big thing is Sp is never aliased, so might want
-- to change the hieracy to have Sp on its own branch that is never
-- aliased (e.g never use top as a TBAA node).
, MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN]
]
-- | Id values
topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed
topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed
topN = LMMetaUnamed 0
stackN = LMMetaUnamed 1
heapN = LMMetaUnamed 2
rxN = LMMetaUnamed 3
baseN = LMMetaUnamed 4
otherN = LMMetaUnamed 5
-- | The various TBAA types
top, heap, stack, rx, base :: MetaData
top, heap, stack, rx, base, other :: MetaData
top = (tbaa, topN)
heap = (tbaa, heapN)
stack = (tbaa, stackN)
rx = (tbaa, rxN)
base = (tbaa, baseN)
other = (tbaa, otherN)
-- | The TBAA metadata identifier
tbaa :: LMString
......
......@@ -1306,15 +1306,18 @@ runPhase SplitAs _input_fn dflags
runPhase LlvmOpt input_fn dflags
= do
let lo_opts = getOpts dflags opt_lo
let opt_lvl = max 0 (min 2 $ optLevel dflags)
-- don't specify anything if user has specified commands. We do this for
-- opt but not llc since opt is very specifically for optimisation passes
-- only, so if the user is passing us extra options we assume they know
-- what they are doing and don't get in the way.
let optFlag = if null lo_opts
then [SysTools.Option (llvmOpts !! opt_lvl)]
else []
let lo_opts = getOpts dflags opt_lo
opt_lvl = max 0 (min 2 $ optLevel dflags)
-- don't specify anything if user has specified commands. We do this
-- for opt but not llc since opt is very specifically for optimisation
-- passes only, so if the user is passing us extra options we assume
-- they know what they are doing and don't get in the way.
optFlag = if null lo_opts
then [SysTools.Option (llvmOpts !! opt_lvl)]
else []
tbaa | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
| otherwise = "--enable-tbaa=false"
output_fn <- phaseOutputFilename LlvmLlc
......@@ -1323,6 +1326,7 @@ runPhase LlvmOpt input_fn dflags
SysTools.Option "-o",
SysTools.FileOption "" output_fn]
++ optFlag
++ [SysTools.Option tbaa]
++ map SysTools.Option lo_opts)
return (LlvmLlc, output_fn)
......@@ -1341,6 +1345,8 @@ runPhase LlvmLlc input_fn dflags
rmodel | opt_PIC = "pic"
| not opt_Static = "dynamic-no-pic"
| otherwise = "static"
tbaa | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
| otherwise = "--enable-tbaa=false"
-- hidden debugging flag '-dno-llvm-mangler' to skip mangling
let next_phase = case dopt Opt_NoLlvmMangler dflags of
......@@ -1356,6 +1362,7 @@ runPhase LlvmLlc input_fn dflags
SysTools.FileOption "" input_fn,
SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts
++ [SysTools.Option tbaa]
++ map SysTools.Option fpOpts)
return (next_phase, output_fn)
......@@ -1373,7 +1380,7 @@ runPhase LlvmLlc input_fn dflags
else if (elem VFPv3D16 ext)
then ["-mattr=+v7,+vfp3,+d16"]
else []
_ -> []
_ -> []
-----------------------------------------------------------------------------
-- LlvmMangle phase
......
......@@ -250,6 +250,8 @@ data DynFlag
| Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
| Opt_PedanticBottoms -- Be picky about how we treat bottom
| Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA
| Opt_RegLiveness -- Use the STG Reg liveness information
-- Interface files
| Opt_IgnoreInterfacePragmas
......@@ -1823,6 +1825,8 @@ fFlags = [
( "vectorise", Opt_Vectorise, nop ),
( "regs-graph", Opt_RegsGraph, nop ),
( "regs-iterative", Opt_RegsIterative, nop ),
( "llvm-tbaa", Opt_LlvmTBAA, nop),
( "reg-liveness", Opt_RegLiveness, nop),
( "gen-manifest", Opt_GenManifest, nop ),
( "embed-manifest", Opt_EmbedManifest, nop ),
( "ext-core", Opt_EmitExternalCore, nop ),
......@@ -2071,6 +2075,8 @@ optLevelFlags
, ([2], Opt_LiberateCase)
, ([2], Opt_SpecConstr)
, ([2], Opt_RegsGraph)
, ([0,1,2], Opt_LlvmTBAA)
, ([0,1,2], Opt_RegLiveness)
-- , ([2], Opt_StaticArgumentTransformation)
-- Max writes: I think it's probably best not to enable SAT with -O2 for the
......
This diff is collapsed.
......@@ -1037,20 +1037,29 @@ publish-docs:
#
# Directory in which we're going to build the src dist
#
SRC_DIST_NAME=ghc-$(ProjectVersion)
SRC_DIST_DIR=$(SRC_DIST_NAME)
SRC_DIST_ROOT = sdistprep
SRC_DIST_BASE_NAME = ghc-$(ProjectVersion)
SRC_DIST_GHC_NAME = ghc-$(ProjectVersion)
SRC_DIST_GHC_ROOT = $(SRC_DIST_ROOT)/ghc
SRC_DIST_GHC_DIR = $(SRC_DIST_GHC_ROOT)/$(SRC_DIST_BASE_NAME)
SRC_DIST_GHC_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_GHC_NAME)-src.tar.bz2
SRC_DIST_TESTSUITE_NAME = testsuite-ghc-$(ProjectVersion)
SRC_DIST_TESTSUITE_ROOT = $(SRC_DIST_ROOT)/testsuite-ghc
SRC_DIST_TESTSUITE_DIR = $(SRC_DIST_TESTSUITE_ROOT)/$(SRC_DIST_BASE_NAME)
SRC_DIST_TESTSUITE_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_TESTSUITE_NAME)-src.tar.bz2
#
# Files to include in source distributions
#
SRC_DIST_DIRS = mk rules docs distrib bindisttest libffi includes utils docs rts compiler ghc driver libraries ghc-tarballs
SRC_DIST_FILES += \
configure.ac config.guess config.sub configure \
aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \
ghc.spec.in ghc.spec settings.in VERSION \
boot boot-pkgs packages ghc.mk
SRC_DIST_TARBALL = $(SRC_DIST_NAME)-src.tar.bz2
SRC_DIST_GHC_DIRS = mk rules docs distrib bindisttest libffi includes \
utils docs rts compiler ghc driver libraries ghc-tarballs
SRC_DIST_GHC_FILES += \
configure.ac config.guess config.sub configure \
aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \
ghc.spec.in ghc.spec settings.in VERSION \
boot boot-pkgs packages ghc.mk
VERSION :
echo $(ProjectVersion) >VERSION
......@@ -1058,50 +1067,66 @@ VERSION :
sdist : VERSION
# Use:
# $(call sdist_file,compiler,stage2,cmm,Foo/Bar,CmmLex,x)
# $(call sdist_ghc_file,compiler,stage2,cmm,Foo/Bar,CmmLex,x)
# to copy the generated file that replaces compiler/cmm/Foo/Bar/CmmLex.x, where
# "stage2" is the dist dir.
define sdist_file
"$(CP)" $1/$2/build/$4/$5.hs $(SRC_DIST_DIR)/$1/$3/$4
mv $(SRC_DIST_DIR)/$1/$3/$4/$5.$6 $(SRC_DIST_DIR)/$1/$3/$4/$5.$6.source
define sdist_ghc_file
"$(CP)" $1/$2/build/$4/$5.hs $(SRC_DIST_GHC_DIR)/$1/$3/$4
mv $(SRC_DIST_GHC_DIR)/$1/$3/$4/$5.$6 $(SRC_DIST_GHC_DIR)/$1/$3/$4/$5.$6.source
endef
.PHONY: sdist-prep
sdist-prep :
$(call removeTrees,$(SRC_DIST_DIR))
$(call removeFiles,$(SRC_DIST_TARBALL))
mkdir $(SRC_DIST_DIR)
cd $(SRC_DIST_DIR) && for i in $(SRC_DIST_DIRS); do mkdir $$i; ( cd $$i && lndir $(TOP)/$$i ); done
cd $(SRC_DIST_DIR) && for i in $(SRC_DIST_FILES); do $(LN_S) $(TOP)/$$i .; done
cd $(SRC_DIST_DIR) && $(MAKE) distclean
$(call removeTrees,$(SRC_DIST_DIR)/libraries/tarballs/)
$(call removeTrees,$(SRC_DIST_DIR)/libraries/stamp/)
$(call sdist_file,compiler,stage2,cmm,,CmmLex,x)
$(call sdist_file,compiler,stage2,cmm,,CmmParse,y)
$(call sdist_file,compiler,stage2,parser,,Lexer,x)
$(call sdist_file,compiler,stage2,parser,,Parser,y.pp)
$(call sdist_file,compiler,stage2,parser,,ParserCore,y)
$(call sdist_file,utils/hpc,dist-install,,,HpcParser,y)
$(call sdist_file,utils/genprimopcode,dist,,,Lexer,x)
$(call sdist_file,utils/genprimopcode,dist,,,Parser,y)
$(call sdist_file,utils/haddock,dist,src,Haddock,Lex,x)
$(call sdist_file,utils/haddock,dist,src,Haddock,Parse,y)
cd $(SRC_DIST_DIR) && $(call removeTrees,compiler/stage[123] mk/build.mk)
cd $(SRC_DIST_DIR) && "$(FIND)" $(SRC_DIST_DIRS) \( -name .git -o -name "autom4te*" -o -name "*~" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC)
.PHONY: sdist-ghc-prep
sdist-ghc-prep :
$(call removeTrees,$(SRC_DIST_GHC_ROOT))
$(call removeFiles,$(SRC_DIST_GHC_TARBALL))
-mkdir $(SRC_DIST_ROOT)
mkdir $(SRC_DIST_GHC_ROOT)
mkdir $(SRC_DIST_GHC_DIR)
cd $(SRC_DIST_GHC_DIR) && for i in $(SRC_DIST_GHC_DIRS); do mkdir $$i; ( cd $$i && lndir $(TOP)/$$i ); done
cd $(SRC_DIST_GHC_DIR) && for i in $(SRC_DIST_GHC_FILES); do $(LN_S) $(TOP)/$$i .; done
cd $(SRC_DIST_GHC_DIR) && $(MAKE) distclean
$(call removeTrees,$(SRC_DIST_GHC_DIR)/libraries/tarballs/)
$(call removeTrees,$(SRC_DIST_GHC_DIR)/libraries/stamp/)
$(call removeTrees,$(SRC_DIST_GHC_DIR)/compiler/stage[123])
$(call removeFiles,$(SRC_DIST_GHC_DIR)/mk/build.mk)
$(call sdist_ghc_file,compiler,stage2,cmm,,CmmLex,x)
$(call sdist_ghc_file,compiler,stage2,cmm,,CmmParse,y)
$(call sdist_ghc_file,compiler,stage2,parser,,Lexer,x)
$(call sdist_ghc_file,compiler,stage2,parser,,Parser,y.pp)
$(call sdist_ghc_file,compiler,stage2,parser,,ParserCore,y)
$(call sdist_ghc_file,utils/hpc,dist-install,,,HpcParser,y)
$(call sdist_ghc_file,utils/genprimopcode,dist,,,Lexer,x)
$(call sdist_ghc_file,utils/genprimopcode,dist,,,Parser,y)
$(call sdist_ghc_file,utils/haddock,dist,src,Haddock,Lex,x)
$(call sdist_ghc_file,utils/haddock,dist,src,Haddock,Parse,y)
cd $(SRC_DIST_GHC_DIR) && "$(FIND)" $(SRC_DIST_GHC_DIRS) \( -name .git -o -name "autom4te*" -o -name "*~" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC)
.PHONY: sdist-testsuite-prep
sdist-testsuite-prep :
$(call removeTrees,$(SRC_DIST_TESTSUITE_ROOT))
$(call removeFiles,$(SRC_DIST_TESTSUITE_TARBALL))
-mkdir $(SRC_DIST_ROOT)
mkdir $(SRC_DIST_TESTSUITE_ROOT)
mkdir $(SRC_DIST_TESTSUITE_DIR)
mkdir $(SRC_DIST_TESTSUITE_DIR)/testsuite
cd $(SRC_DIST_TESTSUITE_DIR)/testsuite && lndir $(TOP)/testsuite
$(call removeTrees,$(SRC_DIST_TESTSUITE_DIR)/testsuite/.git)
.PHONY: sdist
sdist : sdist-prep
"$(TAR_CMD)" chf - $(SRC_DIST_NAME) 2>src_log | bzip2 >$(TOP)/$(SRC_DIST_TARBALL)
sdist : sdist-ghc-prep sdist-testsuite-prep
cd $(SRC_DIST_GHC_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_GHC_TARBALL)
cd $(SRC_DIST_TESTSUITE_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_TESTSUITE_TARBALL)
sdist-manifest : $(SRC_DIST_TARBALL)
tar tjf $(SRC_DIST_TARBALL) | sed "s|^ghc-$(ProjectVersion)/||" | sort >sdist-manifest
sdist-manifest : $(SRC_DIST_GHC_TARBALL)
tar tjf $(SRC_DIST_GHC_TARBALL) | sed "s|^ghc-$(ProjectVersion)/||" | sort >sdist-manifest
# Upload the distribution(s)
# Retrying is to work around buggy firewalls that corrupt large file transfers
# over SSH.
ifneq "$(PublishLocation)" ""
publish-sdist :
$(call try10Times,$(PublishCp) $(SRC_DIST_TARBALL) $(PublishLocation)/dist)
$(call try10Times,$(PublishCp) $(SRC_DIST_GHC_TARBALL) $(PublishLocation)/dist)
$(call try10Times,$(PublishCp) $(SRC_DIST_TESTSUITE_TARBALL) $(PublishLocation)/dist)
endif
ifeq "$(BootingFromHc)" "YES"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment