diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-31 09:09:28 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-31 09:09:28 +0000 |
| commit | 7e255c5c67cbc60d2d85ee21f03c0e868eb510c1 (patch) | |
| tree | 68fb83f34c34ac40f1a2539edf35465e5ad4fa91 | |
| parent | 10f83429ba493699af95cb8c3b16d179d78b7749 (diff) | |
| parent | a44a5e335f18699e2b97e9c6ecb869900145cbec (diff) | |
| download | haskell-7e255c5c67cbc60d2d85ee21f03c0e868eb510c1.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
69 files changed, 1056 insertions, 539 deletions
diff --git a/.gitignore b/.gitignore index 2bbf8004be..baf85fa206 100644 --- a/.gitignore +++ b/.gitignore @@ -85,6 +85,27 @@ _darcs/ /utils/hsc2hs/ # ----------------------------------------------------------------------------- +# Cabal dist directories + +/driver/ghc/dist/ +/driver/haddock/dist/ +/driver/ghci/dist/ +/driver/split/dist/ +/includes/dist-*/ +/libffi/dist-install/ +/libraries/*/dist-boot/ +/libraries/*/dist-install/ +/libraries/dist-haddock/ +/rts/dist/ +/utils/*/dist*/ +/compiler/stage1/ +/compiler/stage2/ +/compiler/stage3/ +/ghc/stage1/ +/ghc/stage2/ +/ghc/stage3/ + +# ----------------------------------------------------------------------------- # specific generated files /bindist-list @@ -93,30 +114,8 @@ _darcs/ /bindisttest/ /ch01.html /ch02.html -/compiler/cmm/CmmLex.hs -/compiler/cmm/CmmParse.hs /compiler/ghc.cabal /compiler/ghc.cabal.old -/compiler/ghci/LibFFI.hs -/compiler/ghci/LibFFI_hsc.c -/compiler/main/Config.hs -/compiler/main/ParsePkgConf.hs -/compiler/parser/HaddockLex.hs -/compiler/parser/HaddockParse.hs -/compiler/parser/Lexer.hs -/compiler/parser/Parser.hs -/compiler/parser/Parser.y -/compiler/parser/ParserCore.hs -/compiler/prelude/primops.txt -/compiler/primop*incl -/compiler/stage1/ -/compiler/stage2/ -/compiler/stage3/ -/compiler/utils/Fingerprint.hs -/compiler/utils/Fingerprint_hsc.c -/distrib/MacOS/GHC-system.pmdoc/index.xml -/distrib/MacOS/installer-scripts/Uninstaller -/distrib/MacOS/installer-scripts/create-links /distrib/configure.ac /distrib/ghc.iss /docs/index.html @@ -130,36 +129,18 @@ _darcs/ /docs/users_guide/users_guide.ps /docs/users_guide/users_guide/ /docs/users_guide/what_glasgow_exts_does.gen.xml -/driver/ghc/dist/ -/driver/haddock/dist/ /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace -/driver/ghci/dist/ /driver/ghci/ghci.res -/driver/mangler/dist/ghc-asm -/driver/mangler/dist/ghc-asm.prl /driver/package.conf /driver/package.conf.inplace.old -/driver/split/dist/ghc-split -/driver/split/dist/ghc-split.prl -/driver/stamp-pkg-conf-rts /settings /ghc.spec /ghc/ghc-bin.cabal -/ghc/stage1/ -/ghc/stage2/ -/ghc/stage3/ -/includes/DerivedConstants.h -/includes/GHCConstants.h -/includes/dist-*/ /includes/ghcautoconf.h /includes/ghcplatform.h -/includes/mkDerivedConstantsHdr -/includes/mkGHCConstants -/inplace-datadir/ /index.html /inplace/ -/libffi/dist-install/ /libffi/build/ /libffi/ffi.h /libffi/package.conf.inplace @@ -183,9 +164,6 @@ _darcs/ /libraries/synopsis.png /libraries/stamp/ /libraries/time/ -/libraries/*/dist-boot/ -/libraries/*/dist-install/ -/libraries/dist-haddock/ /mk/are-validating.mk /mk/build.mk /mk/config.h @@ -197,48 +175,14 @@ _darcs/ /mk/project.mk.old /mk/stamp-h /mk/validate.mk -/rts/dist/ -/rts/AutoApply.*cmm /rts/package.conf.inplace /rts/package.conf.inplace.raw -/rts/sm/Evac_thr.c -/rts/sm/Scav_thr.c /rts/package.conf.install /rts/package.conf.install.raw /stage3.package.conf /testsuite_summary.txt /testlog -/utils/*/dist*/ -/utils/ext-core/Driver -/utils/ext-core/PrimEnv.hs -/utils/genapply/genapply -/utils/genprimopcode/Lexer.hs -/utils/genprimopcode/Parser.hs -/utils/genprimopcode/genprimopcode -/utils/ghc-pkg/Version.hs -/utils/ghc-pkg/ghc-pkg-inplace -/utils/ghc-pkg/ghc-pkg-inplace.bin -/utils/ghc-pkg/ghc-pkg-inplace.hs -/utils/ghc-pkg/ghc-pkg.bin -/utils/ghc-pwd/dist-boot/ghc-pwd -/utils/hasktags/hasktags -/utils/hasktags/hasktags-inplace -/utils/hp2ps/hp2ps -/utils/hpc/HpcParser.hs -/utils/lndir/lndir -/utils/mkdependC/mkdependC -/utils/mkdirhier/mkdirhier -/utils/prof/cgprof/cgprof -/utils/prof/ghcprof-inplace -/utils/pwd/pwd -/utils/pwd/pwd-inplace -/utils/runghc/runghc -/utils/runghc/runghc-inplace /utils/runghc/runghc.cabal -/utils/runghc/runhaskell -/utils/runstdtest/runstdtest -/utils/unlit/unlit - /extra-gcc-opts diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 8409f0dbeb..e1701bd4c5 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -71,6 +71,14 @@ data GenCmmDecl d h g = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Entry label + [GlobalReg] -- Registers live on entry. Note that the set of live + -- registers will be correct in generated C-- code, but + -- not in hand-written C-- code. However, + -- splitAtProcPoints calculates correct liveness + -- information for CmmProc's. Right now only the LLVM + -- back-end relies on correct liveness information and + -- for that back-end we always call splitAtProcPoints, so + -- all is good. g -- Control-flow graph for the procedure's code | CmmData -- Static data @@ -100,8 +108,8 @@ data CmmTopInfo = TopInfo { info_tbls :: BlockEnv CmmInfoTable , stack_info :: CmmStackInfo } topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable -topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos) -topInfoTable _ = Nothing +topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) +topInfoTable _ = Nothing data CmmStackInfo = StackInfo { diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 304f4c2170..af78b40e0f 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -250,7 +250,7 @@ to_SRT dflags top_srt off len bmp -- any CAF that is reachable from c. localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) -localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = +localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) = case topInfoTable proc of Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep) && not (isStackRep rep) @@ -295,7 +295,7 @@ bundle :: Map CLabel CAFSet -> (CAFEnv, CmmDecl) -> (CAFSet, Maybe CLabel) -> (BlockEnv CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl) +bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) = ( mapMapWithKey get_cafs (info_tbls infos), decl ) where entry = g_entry g @@ -371,8 +371,8 @@ buildSRTs dflags top_srt caf_map -} updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl -updInfoSRTs srt_env (CmmProc top_info top_l g) = - CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g +updInfoSRTs srt_env (CmmProc top_info top_l live g) = + CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g where updInfoTbl l info_tbl = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env } updInfoSRTs _ t = t diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 180b2d7eab..7fc89e2f54 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -9,7 +9,7 @@ module CmmCallConv ( ParamLocation(..), assignArgumentsPos, assignStack, - globalArgRegs, realArgRegs + globalArgRegs, realArgRegsCover ) where #include "HsVersions.h" @@ -69,22 +69,27 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) assign_regs assts [] _ = (assts, []) assign_regs assts (r:rs) regs = if isFloatType ty then float else int where float = case (w, regs) of - (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls)) - (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls)) + (W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) + (W32, (vs, f:fs, ds, ls, ss)) + | not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss)) + (W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) + (W64, (vs, fs, d:ds, ls, ss)) + | not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss)) (W80, _) -> panic "F80 unsupported register type" _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls)) - (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags) - -> k (RegisterParam l, (vs, fs, ds, ls)) + (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags) + -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) + (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags) + -> k (RegisterParam l, (vs, fs, ds, ls, ss)) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty gcp | isGcPtrType ty = VGcPtr | otherwise = VNonGcPtr + hasSseRegs = mAX_Real_SSE_REG dflags /= 0 assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] @@ -109,6 +114,7 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. , [GlobalReg] -- floats , [GlobalReg] -- doubles , [GlobalReg] -- longs (int64 and word64) + , [Int] -- SSE (floats and doubles) ) -- Vanilla registers can contain pointers, Ints, Chars. @@ -122,7 +128,8 @@ getRegsWithoutNode dflags = ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) , realFloatRegs dflags , realDoubleRegs dflags - , realLongRegs dflags) + , realLongRegs dflags + , sseRegNos dflags) -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode dflags = @@ -131,15 +138,18 @@ getRegsWithNode dflags = else realVanillaRegs dflags , realFloatRegs dflags , realDoubleRegs dflags - , realLongRegs dflags) + , realLongRegs dflags + , sseRegNos dflags) allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +allSseRegs :: DynFlags -> [Int] allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) +allSseRegs dflags = regList (mAX_SSE_REG dflags) realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] @@ -149,6 +159,9 @@ realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) +sseRegNos :: DynFlags -> [Int] +sseRegNos dflags =regList (mAX_SSE_REG dflags) + regList :: Int -> [Int] regList n = [1 .. n] @@ -156,10 +169,11 @@ allRegs :: DynFlags -> AvailRegs allRegs dflags = (allVanillaRegs dflags, allFloatRegs dflags, allDoubleRegs dflags, - allLongRegs dflags) + allLongRegs dflags, + allSseRegs dflags) noRegs :: AvailRegs -noRegs = ([], [], [], []) +noRegs = ([], [], [], [], []) globalArgRegs :: DynFlags -> [GlobalReg] globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ @@ -167,8 +181,19 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ allDoubleRegs dflags ++ allLongRegs dflags -realArgRegs :: DynFlags -> [GlobalReg] -realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ - realFloatRegs dflags ++ - realDoubleRegs dflags ++ - realLongRegs dflags +-- This returns the set of global registers that *cover* the machine registers +-- used for argument passing. On platforms where registers can overlap---right +-- now just x86-64, where Float and Double registers overlap---passing this set +-- of registers is guaranteed to preserve the contents of all live registers. We +-- only use this functionality in hand-written C-- code in the RTS. +realArgRegsCover :: DynFlags -> [GlobalReg] +realArgRegsCover dflags + | hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++ + realDoubleRegs dflags ++ + realLongRegs dflags + | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags + where + hasSseRegs = mAX_Real_SSE_REG dflags /= 0 diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 4028efddf6..82f7243e73 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -28,7 +28,7 @@ cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph cmmCfgOpts split g = fst (blockConcat split g) cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl -cmmCfgOptsProc split (CmmProc info lbl g) = CmmProc info' lbl g' +cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g' where (g', env) = blockConcat split g info' = info{ info_tbls = new_info_tbls } new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info))) diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 017d120d84..39f0b86ec8 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -19,7 +19,7 @@ import Outputable cmmOfZgraph :: CmmGroup -> Old.CmmGroup cmmOfZgraph tops = map mapTop tops - where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) + where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] @@ -109,7 +109,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] CmmSwitch arg ids -> [Old.CmmSwitch arg ids] -- ToDo: STG Live - CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)] + CmmCall e _ r _ _ _ -> [Old.CmmJump e r] CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of Old.BasicBlock _ stmts -> stmts diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 128eb1ca62..87713c6b0d 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,16 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} module CmmExpr ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType - , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg + , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg , VGcPtr(..), vgcFlag -- Temporary! - , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed - , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet - , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet - , regSetToList + + , DefinerOfRegs, UserOfRegs + , foldRegsDefd, foldRegsUsed, filterRegsUsed + , foldLocalRegsDefd, foldLocalRegsUsed + + , RegSet, LocalRegSet, GlobalRegSet + , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet + , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet + , regSetToList , regUsedIn + , Area(..) , module CmmMachOp , module CmmType @@ -177,7 +185,7 @@ localRegType (LocalReg _ rep) = rep -- Register-use information for expressions and other types ----------------------------------------------------------------------------- --- | Sets of local registers +-- | Sets of registers -- These are used for dataflow facts, and a common operation is taking -- the union of two RegSets and then asking whether the union is the @@ -185,16 +193,19 @@ localRegType (LocalReg _ rep) = rep -- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary -- Sets. -type RegSet = Set LocalReg -emptyRegSet :: RegSet -nullRegSet :: RegSet -> Bool -elemRegSet :: LocalReg -> RegSet -> Bool -extendRegSet :: RegSet -> LocalReg -> RegSet -deleteFromRegSet :: RegSet -> LocalReg -> RegSet -mkRegSet :: [LocalReg] -> RegSet -minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet -sizeRegSet :: RegSet -> Int -regSetToList :: RegSet -> [LocalReg] +type RegSet r = Set r +type LocalRegSet = RegSet LocalReg +type GlobalRegSet = RegSet GlobalReg + +emptyRegSet :: Ord r => RegSet r +nullRegSet :: Ord r => RegSet r -> Bool +elemRegSet :: Ord r => r -> RegSet r -> Bool +extendRegSet :: Ord r => RegSet r -> r -> RegSet r +deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r +mkRegSet :: Ord r => [r] -> RegSet r +minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r +sizeRegSet :: Ord r => RegSet r -> Int +regSetToList :: Ord r => RegSet r -> [r] emptyRegSet = Set.empty nullRegSet = Set.null @@ -208,58 +219,75 @@ timesRegSet = Set.intersection sizeRegSet = Set.size regSetToList = Set.toList -class UserOfLocalRegs a where - foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b +class Ord r => UserOfRegs r a where + foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b + +foldLocalRegsUsed :: UserOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsUsed = foldRegsUsed -class DefinerOfLocalRegs a where - foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b +class Ord r => DefinerOfRegs r a where + foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b -filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet -filterRegsUsed p e = - foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs) +foldLocalRegsDefd :: DefinerOfRegs LocalReg a + => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b +foldLocalRegsDefd = foldRegsDefd + +filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r +filterRegsUsed dflags p e = + foldRegsUsed dflags + (\regs r -> if p r then extendRegSet regs r else regs) emptyRegSet e -instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where - foldRegsUsed f z (Just x) = foldRegsUsed f z x - foldRegsUsed _ z Nothing = z +instance UserOfRegs LocalReg CmmReg where + foldRegsUsed _ f z (CmmLocal reg) = f z reg + foldRegsUsed _ _ z (CmmGlobal _) = z + +instance DefinerOfRegs LocalReg CmmReg where + foldRegsDefd _ f z (CmmLocal reg) = f z reg + foldRegsDefd _ _ z (CmmGlobal _) = z -instance UserOfLocalRegs CmmReg where - foldRegsUsed f z (CmmLocal reg) = f z reg - foldRegsUsed _ z (CmmGlobal _) = z +instance UserOfRegs GlobalReg CmmReg where + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg -instance DefinerOfLocalRegs CmmReg where - foldRegsDefd f z (CmmLocal reg) = f z reg - foldRegsDefd _ z (CmmGlobal _) = z +instance DefinerOfRegs GlobalReg CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal reg) = f z reg -instance UserOfLocalRegs LocalReg where - foldRegsUsed f z r = f z r +instance Ord r => UserOfRegs r r where + foldRegsUsed _ f z r = f z r -instance DefinerOfLocalRegs LocalReg where - foldRegsDefd f z r = f z r +instance Ord r => DefinerOfRegs r r where + foldRegsDefd _ f z r = f z r -instance UserOfLocalRegs RegSet where - foldRegsUsed f = Set.fold (flip f) +instance Ord r => UserOfRegs r (RegSet r) where + foldRegsUsed _ f = Set.fold (flip f) -instance UserOfLocalRegs CmmExpr where - foldRegsUsed f z e = expr z e +instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where + foldRegsUsed dflags f z e = expr z e where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed f z addr - expr z (CmmReg r) = foldRegsUsed f z r - expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs - expr z (CmmRegOff r _) = foldRegsUsed f z r + expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr + expr z (CmmReg r) = foldRegsUsed dflags f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs + expr z (CmmRegOff r _) = foldRegsUsed dflags f z r expr z (CmmStackSlot _ _) = z -instance UserOfLocalRegs a => UserOfLocalRegs [a] where - foldRegsUsed _ set [] = set - foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs +instance UserOfRegs r a => UserOfRegs r (Maybe a) where + foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x + foldRegsUsed _ _ z Nothing = z -instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where - foldRegsDefd _ set [] = set - foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs +instance UserOfRegs r a => UserOfRegs r [a] where + foldRegsUsed _ _ set [] = set + foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs -instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where - foldRegsDefd _ set Nothing = set - foldRegsDefd f set (Just x) = foldRegsDefd f set x +instance DefinerOfRegs r a => DefinerOfRegs r [a] where + foldRegsDefd _ _ set [] = set + foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs + +instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where + foldRegsDefd _ _ set Nothing = set + foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x ----------------------------------------------------------------------------- -- Another reg utility @@ -424,3 +452,10 @@ globalRegType dflags Hp = gcWord dflags -- The initialiser for all -- dynamically allocated closures globalRegType dflags _ = bWord dflags + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg _ = False diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index e952c831ff..699469c116 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -90,7 +90,7 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] -mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) +mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- -- in the non-tables-next-to-code case, procs can have at most a -- single info table associated with the entry label of the proc. @@ -99,7 +99,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = case topInfoTable proc of -- must be at most one -- no info table Nothing -> - return [CmmProc mapEmpty entry_lbl blocks] + return [CmmProc mapEmpty entry_lbl live blocks] Just info@CmmInfoTable { cit_lbl = info_lbl } -> do (top_decls, (std_info, extra_bits)) <- @@ -120,7 +120,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) -- Separately emit info table (with the function entry -- point as first entry) and the entry code return (top_decls ++ - [CmmProc mapEmpty entry_lbl blocks, + [CmmProc mapEmpty entry_lbl live blocks, mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]) @@ -134,7 +134,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) = do (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos) return (concat top_declss ++ - [CmmProc (mapFromList raw_infos) entry_lbl blocks]) + [CmmProc (mapFromList raw_infos) entry_lbl live blocks]) where do_one_info (lbl,itbl) = do diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index de9f35a798..78bef17a42 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -111,9 +111,9 @@ cmmLayoutStack dflags procpoints entry_args -- We need liveness info. We could do removeDeadAssignments at -- the same time, but it buys nothing over doing cmmSink later, - -- and costs a lot more than just cmmLiveness. + -- and costs a lot more than just cmmLocalLiveness. -- (graph, liveness) <- removeDeadAssignments graph0 - let (graph, liveness) = (graph0, cmmLiveness graph0) + let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0) -- pprTrace "liveness" (ppr liveness) $ return () let blocks = postorderDfs graph @@ -132,7 +132,7 @@ cmmLayoutStack dflags procpoints entry_args layout :: DynFlags -> BlockSet -- proc points - -> BlockEnv CmmLive -- liveness + -> BlockEnv CmmLocalLive -- liveness -> BlockId -- entry -> ByteOff -- stack args on entry @@ -319,7 +319,7 @@ getStackLoc (Young l) n stackmaps = -- extra code that goes *after* the Sp adjustment. handleLastNode - :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff + :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff -> BlockEnv StackMap -> StackMap -> Block CmmNode O O -> CmmNode O C @@ -499,7 +499,7 @@ fixupStack old_stack new_stack = concatMap move new_locs setupStackFrame :: DynFlags -> BlockId -- label of continuation - -> BlockEnv CmmLive -- liveness + -> BlockEnv CmmLocalLive -- liveness -> ByteOff -- updfr -> ByteOff -- bytes of return values on stack -> StackMap -- current StackMap @@ -602,7 +602,7 @@ futureContinuation middle = foldBlockNodesB f middle Nothing -- on the stack and return the new StackMap and the assignments to do -- the saving. -- -allocate :: DynFlags -> ByteOff -> RegSet -> StackMap +allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap -> (StackMap, [CmmNode O O]) allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 , sm_regs = regs0 } @@ -847,8 +847,8 @@ elimStackStores stackmap stackmaps area_off nodes setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) - = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g) + = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g where fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = info_tbl { cit_rep = StackRep (get_liveness lbl) } diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 87a3ebfb5e..da7b094643 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -32,10 +32,10 @@ import Data.Maybe cmmLint :: (Outputable d, Outputable h) => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc -cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g +cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint dflags l p = @@ -46,18 +46,19 @@ runCmmLint dflags l p = nest 2 (ppr p)]) Right _ -> Nothing -lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint () -lintCmmDecl (CmmProc _ lbl g) - = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g -lintCmmDecl (CmmData {}) +lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl _ g) + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g +lintCmmDecl _ (CmmData {}) = return () -lintCmmGraph :: CmmGraph -> CmmLint () -lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks - -- cmmLiveness throws an error if there are registers - -- live on entry to the graph (i.e. undefined - -- variables) +lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () +lintCmmGraph dflags g = + cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) where blocks = toBlockList g labels = setFromList (map entryLabel blocks) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index f0163fefc4..7d674b76a2 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmLive - ( CmmLive - , cmmLiveness + ( CmmLocalLive + , CmmGlobalLive + , cmmLocalLiveness + , cmmGlobalLiveness , liveLattice , noLiveOnEntry, xferLive, gen, kill, gen_kill , removeDeadAssignments @@ -12,6 +16,7 @@ module CmmLive where import UniqSupply +import DynFlags import BlockId import Cmm import CmmUtils @@ -26,10 +31,14 @@ import Outputable ----------------------------------------------------------------------------- -- | The variables live on entry to a block -type CmmLive = RegSet +type CmmLive r = RegSet r +type CmmLocalLive = CmmLive LocalReg +type CmmGlobalLive = CmmLive GlobalReg -- | The dataflow lattice -liveLattice :: DataflowLattice CmmLive +liveLattice :: Ord r => DataflowLattice (CmmLive r) +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-} +{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-} liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add where add _ (OldFact old) (NewFact new) = (changeIf $ sizeRegSet join > sizeRegSet old, join) @@ -37,58 +46,73 @@ liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add -- | A mapping from block labels to the variables live on entry -type BlockEntryLiveness = BlockEnv CmmLive +type BlockEntryLiveness r = BlockEnv (CmmLive r) ----------------------------------------------------------------------------- -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLiveness :: CmmGraph -> BlockEntryLiveness -cmmLiveness graph = - check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive +cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness dflags graph = + check $ dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) where entry = g_entry graph check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts +cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness dflags graph = + dataflowAnalBwd graph [] $ analBwd liveLattice (xferLive dflags) + -- | On entry to the procedure, there had better not be any LocalReg's live-in. -noLiveOnEntry :: BlockId -> CmmLive -> a -> a +noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a noLiveOnEntry bid in_fact x = if nullRegSet in_fact then x else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) -- | The transfer equations use the traditional 'gen' and 'kill' -- notations, which should be familiar from the Dragon Book. -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet -kill a live = foldRegsDefd deleteFromRegSet live a +gen :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE gen #-} +gen dflags a live = foldRegsUsed dflags extendRegSet live a + +kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r +{-# INLINE kill #-} +kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a -gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) - => a -> CmmLive -> CmmLive -gen_kill a = gen a . kill a +gen_kill :: (DefinerOfRegs r a, UserOfRegs r a) + => DynFlags -> a -> CmmLive r -> CmmLive r +{-# INLINE gen_kill #-} +gen_kill dflags a = gen dflags a . kill dflags a -- | The transfer function -xferLive :: BwdTransfer CmmNode CmmLive -xferLive = mkBTransfer3 fst mid lst +xferLive :: forall r . ( UserOfRegs r (CmmNode O O) + , DefinerOfRegs r (CmmNode O O) + , UserOfRegs r (CmmNode O C) + , DefinerOfRegs r (CmmNode O C)) + => DynFlags -> BwdTransfer CmmNode (CmmLive r) +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-} +xferLive dflags = mkBTransfer3 fst mid lst where fst _ f = f - mid :: CmmNode O O -> CmmLive -> CmmLive - mid n f = gen_kill n f - lst :: CmmNode O C -> FactBase CmmLive -> CmmLive - lst n f = gen_kill n $ joinOutFacts liveLattice n f + mid :: CmmNode O O -> CmmLive r -> CmmLive r + mid n f = gen_kill dflags n f + lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r + lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f ----------------------------------------------------------------------------- -- Removing assignments to dead variables ----------------------------------------------------------------------------- -removeDeadAssignments :: CmmGraph -> UniqSM (CmmGraph, BlockEnv CmmLive) -removeDeadAssignments g = - dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites +removeDeadAssignments :: DynFlags -> CmmGraph + -> UniqSM (CmmGraph, BlockEnv CmmLocalLive) +removeDeadAssignments dflags g = + dataflowPassBwd g [] $ analRewBwd liveLattice (xferLive dflags) rewrites where rewrites = mkBRewrite3 nothing middle nothing -- SDM: no need for deepBwdRw here, we only rewrite to empty -- Beware: deepBwdRw with one polymorphic function seems more -- reasonable here, but GHC panics while compiling, see bug -- #4045. - middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O + middle :: CmmNode O O -> Fact O CmmLocalLive -> CmmReplGraph O O middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` live) = return $ Just emptyGraph @@ -99,5 +123,5 @@ removeDeadAssignments g = = return $ Just emptyGraph middle _ _ = return Nothing - nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x + nothing :: CmmNode e x -> Fact x CmmLocalLive -> CmmReplGraph e x nothing _ _ = return Nothing diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index b7bb270bd6..6fa3007fbe 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -1,5 +1,7 @@ -- CmmNode type for representation using Hoopl graphs. +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. @@ -16,7 +18,9 @@ module CmmNode ( mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors ) where +import CodeGen.Platform import CmmExpr +import DynFlags import FastString import ForeignCall import SMRep @@ -280,8 +284,8 @@ data ForeignTarget -- The target of a foreign call -------------------------------------------------- -- Instances of register and slot users / definers -instance UserOfLocalRegs (CmmNode e x) where - foldRegsUsed f z n = case n of +instance UserOfRegs LocalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of CmmAssign _ expr -> fold f z expr CmmStore addr rval -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args @@ -291,24 +295,58 @@ instance UserOfLocalRegs (CmmNode e x) where CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args _ -> z where fold :: forall a b. - UserOfLocalRegs a => + UserOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed f z n + fold f z n = foldRegsUsed dflags f z n -instance UserOfLocalRegs ForeignTarget where - foldRegsUsed _f z (PrimTarget _) = z - foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e +instance UserOfRegs GlobalReg (CmmNode e x) where + foldRegsUsed dflags f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed dflags f z n -instance DefinerOfLocalRegs (CmmNode e x) where - foldRegsDefd f z n = case n of +instance UserOfRegs r CmmExpr => UserOfRegs r ForeignTarget where + foldRegsUsed _ _ z (PrimTarget _) = z + foldRegsUsed dflags f z (ForeignTarget e _) = foldRegsUsed dflags f z e + +instance DefinerOfRegs LocalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of CmmAssign lhs _ -> fold f z lhs CmmUnsafeForeignCall _ fs _ -> fold f z fs CmmForeignCall {res=res} -> fold f z res _ -> z where fold :: forall a b. - DefinerOfLocalRegs a => + DefinerOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd f z n + fold f z n = foldRegsDefd dflags f z n + +instance DefinerOfRegs GlobalReg (CmmNode e x) where + foldRegsDefd dflags f z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) + CmmCall {} -> fold f z activeRegs + CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt) + _ -> z + where fold :: forall a b. + DefinerOfRegs GlobalReg a => + (b -> GlobalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd dflags f z n + + platform = targetPlatform dflags + activeRegs = activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform) activeRegs + + foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] + foreignTargetRegs _ = activeCallerSavesRegs ----------------------------------- diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index dffd417e07..0d44f0ffd5 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -419,10 +419,10 @@ exactLog2 x_ cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl -- XXX: revisit if we actually want to do this -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts -cmmLoopifyForC dflags (CmmProc infos entry_lbl +cmmLoopifyForC dflags (CmmProc infos entry_lbl live (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc infos entry_lbl (ListGraph blocks') + CmmProc infos entry_lbl live (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index c483502cd9..1291f6466a 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -482,7 +482,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } do let prof = NoProfilingInfo rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep , cit_prof = prof, cit_srt = NoC_SRT }, []) } @@ -497,7 +497,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } bitmap = mkLiveness dflags (map Just (drop 1 live)) rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3 , cit_rep = rep , cit_prof = prof, cit_srt = NoC_SRT }, live) } @@ -609,8 +609,9 @@ safety :: { Safety } vols :: { [GlobalReg] } : '[' ']' { [] } | '[' '*' ']' {% do df <- getDynFlags - ; return (realArgRegs df) } - -- all of them + ; return (realArgRegsCover df) } + -- All of them. See comment attached + -- to realArgRegsCover | '[' globals ']' { $2 } globals :: { [GlobalReg] } diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index aa8fa2c1f5..70ff754166 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -61,7 +61,7 @@ cpsTop hsc_env proc = -- later passes by removing lots of empty blocks, so we do it -- even when optimisation isn't turned on. -- - CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-} + CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOptsProc splitting_proc_points proc dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g @@ -121,7 +121,7 @@ cpsTop hsc_env proc = dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints dflags l call_pps proc_points pp_map - (CmmProc h l g) + (CmmProc h l v g) dumps Opt_D_dump_cmmz_split "Post splitting" gs ------------- Populate info tables with stack info ----------------- @@ -140,7 +140,7 @@ cpsTop hsc_env proc = else do -- attach info tables to return points - g <- return $ attachContInfoTables call_pps (CmmProc h l g) + g <- return $ attachContInfoTables call_pps (CmmProc h l v g) ------------- Populate info tables with stack info ----------------- g <- {-# SCC "setInfoTableStackMap" #-} diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index ddccf7ba49..02b232d488 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -18,6 +18,7 @@ import Cmm import PprCmm () import CmmUtils import CmmInfo +import CmmLive (cmmGlobalLiveness) import Data.List (sortBy) import Maybes import Control.Monad @@ -210,7 +211,7 @@ splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> BlockE CmmDecl -> UniqSM [CmmDecl] splitAtProcPoints dflags entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) - top_l g@(CmmGraph {g_entry=entry})) = + top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach let addBlock b graphEnv = case mapLookup bid procMap of @@ -226,6 +227,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph + let liveness = cmmGlobalLiveness dflags g + let ppLiveness pp = filter isArgReg $ + regSetToList $ + expectJust "ppLiveness" $ mapLookup pp liveness + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g -- Build a map from proc point BlockId to pairs of: @@ -248,8 +254,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap let add_jump_block (env, bs) (pp, l) = do bid <- liftM mkBlockId getUniqueM let b = blockJoin (CmmEntry bid) emptyBlock jump - jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0 - -- XXX: No regs are live at the call + live = ppLiveness pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0 return (mapInsert pp bid env, b : bs) add_jumps newGraphEnv (ppId, blockEnv) = @@ -293,17 +299,19 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap | bid == entry = CmmProc (TopInfo {info_tbls = info_tbls, stack_info = stack_info}) - top_l (replacePPIds g) + top_l live g' | otherwise = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) , stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' (lbl, Nothing) -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) - lbl (replacePPIds g) + lbl live g' where + g' = replacePPIds g + live = ppLiveness (g_entry g') stack_info = StackInfo { arg_space = 0 , updfr_space = Nothing , do_layout = True } @@ -333,7 +341,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap procs splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t] - -- Only called from CmmProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below. replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph @@ -358,8 +365,8 @@ replaceBranches env cmmg -- Not splitting proc points: add info tables for continuations attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl -attachContInfoTables call_proc_points (CmmProc top_info top_l g) - = CmmProc top_info{info_tbls = info_tbls'} top_l g +attachContInfoTables call_proc_points (CmmProc top_info top_l live g) + = CmmProc top_info{info_tbls = info_tbls'} top_l live g where info_tbls' = mapUnion (info_tbls top_info) $ mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l)) diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index 0f2aeaa939..8381d12e7c 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -42,11 +42,11 @@ rewriteAssignments dflags g = do -- first perform usage analysis and bake this information into the -- graph (backwards transform), and then do a forwards transform -- to actually perform inlining and sinking. - g' <- annotateUsage g + g' <- annotateUsage dflags g g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ analRewFwd assignmentLattice (assignmentTransfer dflags) - (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags) + (assignmentRewrite dflags `thenFwdRw` machOpFoldRewrite dflags) return (modifyGraph eraseRegUsage g'') ---------------------------------------------------------------- @@ -159,13 +159,13 @@ data WithRegUsage n e x where Plain :: n e x -> WithRegUsage n e x AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O -instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where - foldRegsUsed f z (Plain n) = foldRegsUsed f z n - foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e +instance UserOfRegs LocalReg (n e x) => UserOfRegs LocalReg (WithRegUsage n e x) where + foldRegsUsed dflags f z (Plain n) = foldRegsUsed dflags f z n + foldRegsUsed dflags f z (AssignLocal _ e _) = foldRegsUsed dflags f z e -instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where - foldRegsDefd f z (Plain n) = foldRegsDefd f z n - foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r +instance DefinerOfRegs LocalReg (n e x) => DefinerOfRegs LocalReg (WithRegUsage n e x) where + foldRegsDefd dflags f z (Plain n) = foldRegsDefd dflags f z n + foldRegsDefd dflags f z (AssignLocal r _ _) = foldRegsDefd dflags f z r instance NonLocal n => NonLocal (WithRegUsage n) where entryLabel (Plain n) = entryLabel n @@ -190,8 +190,8 @@ usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f) -- We reuse the names 'gen' and 'kill', although we're doing something -- slightly different from the Dragon Book -usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap -usageTransfer = mkBTransfer3 first middle last +usageTransfer :: DynFlags -> BwdTransfer (WithRegUsage CmmNode) UsageMap +usageTransfer dflags = mkBTransfer3 first middle last where first _ f = f middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap middle n f = gen_kill n f @@ -209,9 +209,9 @@ usageTransfer = mkBTransfer3 first middle last gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap gen_kill a = gen a . kill a gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap - gen a f = foldRegsUsed increaseUsage f a + gen a f = foldLocalRegsUsed dflags increaseUsage f a kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap - kill a f = foldRegsDefd delFromUFM f a + kill a f = foldLocalRegsDefd dflags delFromUFM f a increaseUsage f r = addToUFM_C combine f r SingleUse where combine _ _ = ManyUse @@ -228,11 +228,11 @@ usageRewrite = mkBRewrite3 first middle last last _ _ = return Nothing type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) -annotateUsage :: CmmGraph -> UniqSM (CmmGraphWithRegUsage) -annotateUsage vanilla_g = +annotateUsage :: DynFlags -> CmmGraph -> UniqSM (CmmGraphWithRegUsage) +annotateUsage dflags vanilla_g = let g = modifyGraph liftRegUsage vanilla_g in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ - analRewBwd usageLattice usageTransfer usageRewrite + analRewBwd usageLattice (usageTransfer dflags) usageRewrite ---------------------------------------------------------------- --- Assignment tracking @@ -286,8 +286,8 @@ assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUF -- Deletes sinks from assignment map, because /this/ is the place -- where it will be sunk to. -deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap -deleteSinks n m = foldRegsUsed (adjustUFM f) m n +deleteSinks :: UserOfRegs LocalReg n => DynFlags -> n -> AssignmentMap -> AssignmentMap +deleteSinks dflags n m = foldLocalRegsUsed dflags (adjustUFM f) m n where f (AlwaysSink _) = NeverOptimize f old = old @@ -319,8 +319,8 @@ middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap -- the correct optimization policy. -- 3. Look for all assignments that reference that register and -- invalidate them. -middleAssignment _ n@(AssignLocal r e usage) assign - = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign +middleAssignment dflags n@(AssignLocal r e usage) assign + = invalidateUsersOf (CmmLocal r) . add . deleteSinks dflags n $ assign where add m = addToUFM m r $ case usage of SingleUse -> AlwaysInline e @@ -339,8 +339,8 @@ middleAssignment _ n@(AssignLocal r e usage) assign -- 1. Delete any sinking assignments that were used by this instruction -- 2. Look for all assignments that reference this register and -- invalidate them. -middleAssignment _ (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign - = invalidateUsersOf reg . deleteSinks n $ assign +middleAssignment dflags (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign + = invalidateUsersOf reg . deleteSinks dflags n $ assign -- Algorithm for unannotated assignments of *local* registers: do -- nothing (it's a reload, so no state should have changed) @@ -351,7 +351,7 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign -- 2. Look for all assignments that load from memory locations that -- were clobbered by this store and invalidate them. middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign - = let m = deleteSinks n assign + = let m = deleteSinks dflags n assign in foldUFM_Directly f m m -- [foldUFM performance] where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize f _ _ m = m @@ -373,7 +373,7 @@ middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign -- store extra information about expressions that allow this and other -- checks to be done cheaply.) middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign - = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) + = deleteCallerSaves (foldLocalRegsDefd dflags (\m r -> addToUFM m r NeverOptimize) (deleteSinks dflags n assign) n) where deleteCallerSaves m = foldUFM_Directly f m m f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize f _ _ m = m @@ -442,10 +442,10 @@ overlaps (_, o, w) (_, o', w') = s' = o' - w' in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK -lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] -lastAssignment (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)] -lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] -lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l +lastAssignment :: DynFlags -> WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] +lastAssignment _ (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)] +lastAssignment _ (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] +lastAssignment dflags l assign = map (\id -> (id, deleteSinks dflags l assign)) $ successors l -- Invalidates any expressions that have volatile contents: essentially, -- all terminals volatile except for literals and loads of stack slots @@ -471,7 +471,7 @@ assignmentTransfer :: DynFlags assignmentTransfer dflags = mkFTransfer3 (flip const) (middleAssignment dflags) - ((mkFactBase assignmentLattice .) . lastAssignment) + ((mkFactBase assignmentLattice .) . lastAssignment dflags) -- Note [Soundness of inlining] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -533,8 +533,8 @@ assignmentTransfer dflags -- values from the assignment map, due to reassignment of the local -- register.) This is probably not locally sound. -assignmentRewrite :: FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap -assignmentRewrite = mkFRewrite3 first middle last +assignmentRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) AssignmentMap +assignmentRewrite dflags = mkFRewrite3 first middle last where first _ _ = return Nothing middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O @@ -543,7 +543,7 @@ assignmentRewrite = mkFRewrite3 first middle last last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l -- Tuple is (inline?, reloads for sinks) precompute :: AssignmentMap -> CmmNode O x -> (Bool, [WithRegUsage CmmNode O O]) - precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless + precompute assign n = foldLocalRegsUsed dflags f (False, []) n -- duplicates are harmless where f (i, l) r = case lookupUFM assign r of Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l) Just (AlwaysInline _) -> (True, l) diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 7553e37325..2a080c2e58 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -125,7 +125,7 @@ type Assignment = (LocalReg, CmmExpr, AbsMem) cmmSink :: DynFlags -> CmmGraph -> CmmGraph cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where - liveness = cmmLiveness graph + liveness = cmmLocalLiveness dflags graph getLive l = mapFindWithDefault Set.empty l liveness blocks = postorderDfs graph @@ -147,8 +147,8 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. live = Set.unions (map getLive succs) - live_middle = gen_kill last live - ann_middles = annotate live_middle (blockToList middle) + live_middle = gen_kill dflags last live + ann_middles = annotate dflags live_middle (blockToList middle) -- Now sink and inline in this block (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) @@ -187,7 +187,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks upd set | r `Set.member` set = set `Set.union` live_rhs | otherwise = set - live_rhs = foldRegsUsed extendRegSet emptyRegSet rhs + live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs final_middle = foldl blockSnoc middle' dropped_last @@ -215,9 +215,9 @@ isTrivial _ = False -- -- annotate each node with the set of registers live *after* the node -- -annotate :: RegSet -> [CmmNode O O] -> [(RegSet, CmmNode O O)] -annotate live nodes = snd $ foldr ann (live,[]) nodes - where ann n (live,nodes) = (gen_kill n live, (live,n) : nodes) +annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] +annotate dflags live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) -- -- Find the blocks that have multiple successors (join points) @@ -234,7 +234,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts -- filter the list of assignments to remove any assignments that -- are not live in a continuation. -- -filterAssignments :: DynFlags -> RegSet -> [Assignment] -> [Assignment] +filterAssignments :: DynFlags -> LocalRegSet -> [Assignment] -> [Assignment] filterAssignments dflags live assigs = reverse (go assigs []) where go [] kept = kept go (a@(r,_,_):as) kept | needed = go as (a:kept) @@ -251,7 +251,7 @@ filterAssignments dflags live assigs = reverse (go assigs []) -- as we go. walk :: DynFlags - -> [(RegSet, CmmNode O O)] -- nodes of the block, annotated with + -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node. @@ -310,7 +310,7 @@ shouldSink _ _other = Nothing -- out of inlining, but the inliner will see that r is live -- after the instruction and choose not to inline r in the rhs. -- -shouldDiscard :: CmmNode e x -> RegSet -> Bool +shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool shouldDiscard node live = case node of CmmAssign r (CmmReg r') | r == r' -> True @@ -346,7 +346,7 @@ dropAssignments dflags should_drop state assigs tryToInline :: DynFlags - -> RegSet -- set of registers live after this + -> LocalRegSet -- set of registers live after this -- node. We cannot inline anything -- that is live after the node, unless -- it is small enough to duplicate. @@ -360,7 +360,7 @@ tryToInline tryToInline dflags live node assigs = go usages node [] assigs where usages :: UniqFM Int - usages = foldRegsUsed addUsage emptyUFM node + usages = foldRegsUsed dflags addUsage emptyUFM node go _usages node _skipped [] = (node, []) @@ -371,14 +371,14 @@ tryToInline dflags live node assigs = go usages node [] assigs | otherwise = dont_inline where inline_and_discard = go usages' inl_node skipped rest - where usages' = foldRegsUsed addUsage usages rhs + where usages' = foldRegsUsed dflags addUsage usages rhs dont_inline = keep node -- don't inline the assignment, keep it inline_and_keep = keep inl_node -- inline the assignment, keep it keep node' = (final_node, a : rest') where (final_node, rest') = go usages' node' (l:skipped) rest - usages' = foldRegsUsed (\m r -> addToUFM m r 2) usages rhs + usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) usages rhs -- we must not inline anything that is mentioned in the RHS -- of a binding that we have already skipped, so we set the -- usages of the regs on the RHS to 2. @@ -458,7 +458,7 @@ conflicts dflags (r, rhs, addr) node -- (1) an assignment to a register conflicts with a use of the register | CmmAssign reg _ <- node, reg `regUsedIn` rhs = True - | foldRegsUsed (\b r' -> r == r' || b) False node = True + | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True -- (2) a store to an address conflicts with a read of the same memory | CmmStore addr' e <- node diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 1e2ddfadd1..1536794a70 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -304,20 +304,20 @@ stackStubExpr w = CmmLit (CmmInt 0 w) copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) copyInOflow dflags conv area formals extra_stk - = (offset, catAGraphs $ map mkMiddle nodes) - where (offset, nodes) = copyIn dflags conv area formals extra_stk + = (offset, gregs, catAGraphs $ map mkMiddle nodes) + where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. copyIn :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] - -> (ByteOff, [CmmNode O O]) + -> (ByteOff, [GlobalReg], [CmmNode O O]) copyIn dflags conv area formals extra_stk - = (stk_size, map ci (stk_args ++ args)) + = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where ci (reg, RegisterParam r) = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) @@ -386,7 +386,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] - -> (Int, CmmAGraph) + -> (Int, [GlobalReg], CmmAGraph) mkCallEntry dflags conv formals extra_stk = copyInOflow dflags conv Old formals extra_stk diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index cf05db92b8..fccdd8137d 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + ----------------------------------------------------------------------------- -- -- Old-style Cmm data types @@ -86,8 +88,8 @@ type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt data GenBasicBlock i = BasicBlock BlockId [i] type CmmBasicBlock = GenBasicBlock CmmStmt -instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where - foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l +instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where + foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l -- | The branch block id is that of the first block in -- the branch, which is that branch's entry point @@ -103,7 +105,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) -- | Returns the info table associated with the CmmDecl's entry point, -- if any. topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i -topInfoTable (CmmProc infos _ (ListGraph (b:_))) +topInfoTable (CmmProc infos _ _ (ListGraph (b:_))) = mapLookup (blockId b) infos topInfoTable _ = Nothing @@ -116,8 +118,8 @@ cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' cmmMapGraph f tops = map (cmmTopMapGraph f) tops cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' -cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds +cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g) +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds ----------------------------------------------------------------------------- -- CmmStmt @@ -156,7 +158,7 @@ data CmmStmt | CmmJump -- Jump to another C-- function, CmmExpr -- Target - (Maybe [GlobalReg]) -- Live registers at call site; + [GlobalReg] -- Live registers at call site; -- Nothing -> no information, assume -- all live -- Just .. -> info on liveness, [] @@ -187,8 +189,8 @@ data CmmSafety | CmmInterruptible -- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' -instance UserOfLocalRegs CmmStmt where - foldRegsUsed f (set::b) s = stmt s set +instance UserOfRegs LocalReg CmmStmt where + foldRegsUsed dflags f (set::b) s = stmt s set where stmt :: CmmStmt -> b -> b stmt (CmmNop) = id @@ -202,18 +204,18 @@ instance UserOfLocalRegs CmmStmt where stmt (CmmJump e _) = gen e stmt (CmmReturn) = id - gen :: UserOfLocalRegs a => a -> b -> b - gen a set = foldRegsUsed f set a + gen :: UserOfRegs LocalReg a => a -> b -> b + gen a set = foldRegsUsed dflags f set a -instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts +instance UserOfRegs LocalReg CmmCallTarget where + foldRegsUsed dflags f set (CmmCallee e _) = foldRegsUsed dflags f set e + foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts -instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where - foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) +instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where + foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a) -instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where - foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) +instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where + foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a) {- Discussion diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index f158369b13..9a4fb42bc5 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -48,7 +48,7 @@ runCmmLint _ l p = Right _ -> Nothing lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) +lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks)) = addLintInfo (text "in proc " <> ppr lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock dflags labels) blocks diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index dcde86e37c..edfaef8098 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -161,7 +161,7 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> Maybe [GlobalReg] -> SDoc +genJump :: CmmExpr -> [GlobalReg] -> SDoc genJump expr live = hcat [ ptext (sLit "jump") , space @@ -171,7 +171,7 @@ genJump expr live = CmmLoad (CmmReg _) _ -> pprExpr expr _ -> parens (pprExpr expr) , semi <+> ptext (sLit "// ") - , maybe empty ppr live] + , ppr live] -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index e07bd6459d..e0ff99cb29 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -81,7 +81,7 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmDecl -> SDoc -pprTop proc@(CmmProc _ clbl (ListGraph blocks)) = +pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) = (case topInfoTable proc of Nothing -> empty Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 2cb90e9a22..354a3d4563 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -92,9 +92,9 @@ pprCmmGroup tops pprTop :: (Outputable d, Outputable info, Outputable i) => GenCmmDecl d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen + = vcat [ ppr lbl <> lparen <> rparen <+> ptext (sLit "// ") <+> ppr live , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 1f0b82532b..67d8fd8817 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -36,10 +36,16 @@ baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags -baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags +baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags -baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags +baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags +baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags +baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags @@ -90,9 +96,9 @@ get_Regtable_addr_from_offset dflags _ offset = fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = +fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) = let blocks' = map (fixStgRegBlock dflags) blocks - in CmmProc info lbl $ ListGraph blocks' + in CmmProc info lbl live $ ListGraph blocks' fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock fixStgRegBlock dflags (BasicBlock id stmts) = diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index a0859252ff..9176cb330c 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -717,7 +717,7 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newLabelC - ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] ; lcall <- newLabelC ; updfr_off <- getUpdFrameOff ; let area = Young lret diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index e7925667a8..7612cd1a49 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -213,7 +213,7 @@ emitForeignCall safety results target args updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target k <- newLabelC - let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] -- see Note [safe foreign call convention] emit $ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 7393faac9f..7805473915 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -416,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do Nothing -> genericGC checkYield code Just gc -> do lret <- newLabelC - let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] lcont <- newLabelC emitOutOfLine lret (copyin <*> mkBranch lcont) emitLabel lcont diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 39676635aa..bb0b8a78d0 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -126,7 +126,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack AssignTo res_regs _ -> do k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area res_regs [] + (off, _, copyin) = copyInOflow dflags retConv area res_regs [] copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off extra_stack emit (copyout <*> mkLabel k <*> copyin) @@ -521,7 +521,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ; let args' = if node_points then (node : arg_regs) else arg_regs conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall else NativeDirectCall - (offset, _) = mkCallEntry dflags conv args' [] + (offset, _, _) = mkCallEntry dflags conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index b7797bdae6..7a0816f041 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -713,12 +713,12 @@ emitProcWithStackFrame emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False = do { dflags <- getDynFlags - ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False + ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False } emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout = do { dflags <- getDynFlags - ; let (offset, entry) = mkCallEntry dflags conv args stk_args - ; emitProc_ mb_info lbl (entry <*> blocks) offset True + ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + ; emitProc_ mb_info lbl live (entry <*> blocks) offset True } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" @@ -729,13 +729,13 @@ emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel emitProcWithConvention conv mb_info lbl args blocks = emitProcWithStackFrame conv mb_info lbl [] args blocks True -emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode () -emitProc mb_info lbl blocks offset - = emitProc_ mb_info lbl blocks offset True +emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode () +emitProc mb_info lbl live blocks offset + = emitProc_ mb_info lbl live blocks offset True -emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool +emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool -> FCode () -emitProc_ mb_info lbl blocks offset do_layout +emitProc_ mb_info lbl live blocks offset do_layout = do { dflags <- getDynFlags ; l <- newLabelC ; let @@ -751,7 +751,7 @@ emitProc_ mb_info lbl blocks offset do_layout tinfo = TopInfo { info_tbls = infos , stack_info=sinfo} - proc_block = CmmProc tinfo lbl blks + proc_block = CmmProc tinfo lbl live blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -795,7 +795,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area results [] + (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack return (copyout <*> mkLabel k <*> copyin) diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 211620ac42..571348f577 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -41,11 +41,11 @@ llvmCodeGen dflags h us cmms (cdata,env) = {-# SCC "llvm_split" #-} foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split p@(CmmProc _ l _) (d,e) = + split p@(CmmProc _ l live _) (d,e) = let lbl = strCLabel_llvm env $ case topInfoTable p of Nothing -> l Just (Statics info_lbl _) -> info_lbl - env' = funInsert lbl (llvmFunTy dflags) e + env' = funInsert lbl (llvmFunTy dflags live) e in (d,env') in do showPass dflags "LlVM CodeGen" @@ -129,7 +129,7 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars -cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars +cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars = cmmProcLlvmGens dflags h us env cmms count ivars cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 86fab77ad9..849e40d203 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -7,6 +7,7 @@ module LlvmCodeGen.Base ( LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, @@ -46,6 +47,9 @@ import Unique type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] + -- | Unresolved code. -- Of the form: (data label, data type, unresolved data) type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) @@ -88,29 +92,29 @@ llvmGhcCC dflags | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function -llvmFunTy :: DynFlags -> LlvmType -llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible +llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType +llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig env lbl link - = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link +llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig env live lbl link + = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link -llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig' dflags lbl link +llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig' dflags live lbl link = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) | otherwise = (x, []) in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags)) + (map (toParams . getVarType) (llvmFunArgs dflags live)) (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. -mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks +mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction -mkLlvmFunc env lbl link sec blks +mkLlvmFunc env live lbl link sec blks = let dflags = getDflags env - funDec = llvmFunSig env lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags) + funDec = llvmFunSig env live lbl link + funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live) in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions @@ -122,9 +126,15 @@ llvmInfAlign :: DynFlags -> LMAlign llvmInfAlign dflags = Just (wORD_SIZE dflags) -- | A Function's arguments -llvmFunArgs :: DynFlags -> [LlvmVar] -llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform) +llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] +llvmFunArgs dflags live = + map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform)) where platform = targetPlatform dflags + isLive r = not (isFloat r) || r `elem` alwaysLive || r `elem` live + isPassed r = not (isFloat r) || isLive r + isFloat (FloatReg _) = True + isFloat (DoubleReg _) = True + isFloat _ = False -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 73cd98f63a..d62fbf4397 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -37,10 +37,10 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do - (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) +genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) let info = topInfoTable proc0 - proc = CmmProc info lbl (ListGraph lmblocks) + proc = CmmProc info lbl live (ListGraph lmblocks) return (env', proc:lmdata) genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" @@ -51,22 +51,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- | Generate code for a list of blocks that make up a complete procedure. basicBlocksCodeGen :: LlvmEnv + -> LiveGlobalRegs -> [CmmBasicBlock] -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env ([]) (blocks, tops) +basicBlocksCodeGen env live ([]) (blocks, tops) = do let dflags = getDflags env let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks + let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) -basicBlocksCodeGen env (block:blocks) (lblocks', ltops') +basicBlocksCodeGen env live (block:blocks) (lblocks', ltops') = do (env', lb, lt) <- basicBlockCodeGen env block let lblocks = lblocks' ++ lb let ltops = ltops' ++ lt - basicBlocksCodeGen env' blocks (lblocks, ltops) + basicBlocksCodeGen env' live blocks (lblocks, ltops) -- | Allocations need to be extracted so they can be moved to the entry @@ -510,11 +511,11 @@ cmmPrimOpFunctions env mop ++ " not supported here") -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData +genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData -- Call to known function genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env lbl + (env', vf, stmts, top) <- getHsFunc env live lbl (stgRegs, stgStmts) <- funEpilogue env live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing @@ -523,7 +524,7 @@ genJump env (CmmLit (CmmLabel lbl)) live = do -- Call to unknown function / address genJump env expr live = do - let fty = llvmFunTy (getDflags env) + let fty = llvmFunTy (getDflags env) live (env', vf, stmts, top) <- exprToVar env expr let cast = case getVarType vf of @@ -1246,29 +1247,40 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> [LlvmStatement] -funPrologue dflags = concat $ map getReg $ activeStgRegs platform +funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] +funPrologue dflags live = concat $ map getReg $ activeStgRegs platform where platform = targetPlatform dflags + isLive r = r `elem` alwaysLive || r `elem` live getReg rr = let reg = lmGlobalRegVar dflags rr arg = lmGlobalRegArg dflags rr + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in [alloc, Store arg reg] + in + if isLive rr + then [alloc, Store arg reg] + else [alloc, Store trash reg] -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) -- Have information and liveness optimisation is enabled -funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do - loads <- mapM loadExpr (activeStgRegs platform) +funEpilogue env live = do + loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads return (vars, concatOL stmts) where dflags = getDflags env platform = targetPlatform dflags - loadExpr r | r `elem` alwaysLive || r `elem` live = do + isLive r = r `elem` alwaysLive || r `elem` live + isPassed r = not (isFloat r) || isLive r + isFloat (FloatReg _) = True + isFloat (DoubleReg _) = True + isFloat _ = False + loadExpr r | isLive r = do let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1276,19 +1288,6 @@ funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (LMLitVar $ LMUndefLit ty, unitOL Nop) --- don't do liveness optimisation -funEpilogue env _ = do - loads <- mapM loadExpr (activeStgRegs platform) - let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - loadExpr r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - -- | A serries of statements to trash all the STG registers. -- @@ -1317,8 +1316,8 @@ trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData -getHsFunc env lbl +getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData +getHsFunc env live lbl = let dflags = getDflags env fn = strCLabel_llvm env lbl ty = funLookup fn env @@ -1332,13 +1331,13 @@ getHsFunc env lbl Just ty' -> do let fun = LMGlobalVar fn (pLift ty') ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr (pLift (llvmFunTy dflags)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags)) + (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ + Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) return (env, v1, unitOL s1, []) -- label not in module, create external reference Nothing -> do - let ty' = LMFunction $ llvmFunSig env lbl ExternallyVisible + let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let top = CmmData Data [([],[ty'])] let env' = funInsert fn ty' env diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index c791e85a52..73632f5fd4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) pprLlvmCmmDecl _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) +pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks)) = let (idoc, ivar) = case mb_info of Nothing -> (empty, []) Just (Statics info_lbl dat) @@ -98,7 +98,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) else Internal lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc env lbl' link sec' lmblocks + fun = mkLlvmFunc env live lbl' link sec' lmblocks in ppLlvmFunction fun ), ivar) diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 49c900d5e0..e6cfcb2e18 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -47,8 +47,14 @@ lmGlobalReg dflags suf reg FloatReg 2 -> floatGlobal $"F2" ++ suf FloatReg 3 -> floatGlobal $"F3" ++ suf FloatReg 4 -> floatGlobal $"F4" ++ suf + FloatReg 5 -> floatGlobal $"F5" ++ suf + FloatReg 6 -> floatGlobal $"F6" ++ suf DoubleReg 1 -> doubleGlobal $ "D1" ++ suf DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 7defbe6def..d745cd63af 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -277,7 +277,6 @@ data GeneralFlag | 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 (hidden flag) - | Opt_RegLiveness -- Use the STG Reg liveness information (hidden flag) | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks @@ -2349,7 +2348,6 @@ fFlags = [ ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), ( "llvm-tbaa", Opt_LlvmTBAA, nop), -- hidden flag - ( "regs-liveness", Opt_RegLiveness, nop), -- hidden flag ( "irrefutable-tuples", Opt_IrrefutableTuples, nop ), ( "cmm-sink", Opt_CmmSink, nop ), ( "cmm-elim-common-blocks", Opt_CmmElimCommonBlocks, nop ), @@ -2634,7 +2632,6 @@ optLevelFlags -- XXX disabled, see #7192 -- , ([2], Opt_RegsGraph) , ([0,1,2], Opt_LlvmTBAA) - , ([0,1,2], Opt_RegLiveness) , ([1,2], Opt_CmmSink) , ([1,2], Opt_CmmElimCommonBlocks) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ef61adfbec..23aca9293c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -290,7 +290,7 @@ nativeCodeGen' dflags ncgImpl h us cmms | gopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph []) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) @@ -550,8 +550,8 @@ cmmNativeGen dflags ncgImpl us cmm count x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. @@ -627,8 +627,8 @@ sequenceTop => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = - CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks) +sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) = + CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks) -- The algorithm is very simple (and stupid): we make a graph out of -- the blocks where there is an edge from one block to another iff the @@ -744,7 +744,7 @@ generateJumpTables :: NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] generateJumpTables ncgImpl xs = concatMap f xs - where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) @@ -768,10 +768,10 @@ build_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl d (BlockEnv t) (ListGraph instr) -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) -build_mapping _ (CmmProc info lbl (ListGraph [])) - = (CmmProc info lbl (ListGraph []), emptyUFM) -build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) - = (CmmProc info lbl (ListGraph (head:others)), mapping) +build_mapping _ (CmmProc info lbl live (ListGraph [])) + = (CmmProc info lbl live (ListGraph []), emptyUFM) +build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks))) + = (CmmProc info lbl live (ListGraph (head:others)), mapping) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where @@ -804,8 +804,8 @@ apply_mapping :: NcgImpl statics instr jumpDest -> GenCmmDecl statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) -apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map short_bb blocks) +apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map short_bb blocks) where short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i @@ -878,9 +878,9 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold blocks - return $ CmmProc info lbl (ListGraph blocks') + return $ CmmProc info lbl live (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 1ea62dad82..69f3e29add 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -693,7 +693,7 @@ initializePicBase_ppc -> NatM [NatCmmDecl CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os = do dflags <- getDynFlags @@ -719,11 +719,11 @@ initializePicBase_ppc ArchPPC os picReg : PPC.ADD picReg picReg (PPC.RIReg tmp) : insns) - return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics) + return (CmmProc info lab live (ListGraph (b' : tail blocks)) : gotOffset : statics) initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (PPC.FETCHPC picReg : insns) @@ -746,9 +746,9 @@ initializePicBase_x86 -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab (ListGraph blocks) : statics) + (CmmProc info lab live (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab (ListGraph blocks') : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] (b:bs) -> fetchGOT b : map maybeFetchGOT bs @@ -764,8 +764,8 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab (ListGraph blocks) : statics) - = return (CmmProc info lab (ListGraph blocks') : statics) + (CmmProc info lab live (ListGraph blocks) : statics) + = return (CmmProc info lab live (ListGraph blocks') : statics) where blocks' = case blocks of [] -> [] diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 026e8933d7..848c7f933c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -71,11 +71,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 576e19db1a..045ce8d48e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -51,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 0680beac00..c4fb7ac378 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -75,7 +75,7 @@ slurpJoinMovs live = slurpCmm emptyBag live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpLI rs (LiveInstr _ Nothing) = rs diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 6e110266d1..25bd313826 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -91,7 +91,7 @@ regSpill_top platform regSlotMap cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info -> do -- We should only passed Cmms with the liveness maps filled in, but we'll @@ -115,7 +115,7 @@ regSpill_top platform regSlotMap cmm -- Apply the spiller to all the basic blocks in the CmmProc. sccs' <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs - return $ CmmProc info' label sccs' + return $ CmmProc info' label live sccs' where -- | Given a BlockId and the set of registers live in it, -- if registers in this block are being spilled to stack slots, diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 9348dca936..7f86b9a884 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -301,10 +301,10 @@ cleanTopBackward cmm CmmData{} -> return cmm - CmmProc info label sccs + CmmProc info label live sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label sccs' + return $ CmmProc info label live sccs' cleanBlockBackward diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index abcc6a69b6..879597fd88 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -79,7 +79,7 @@ slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ sccs) + countCmm (CmmProc info _ _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3f1efe5824..fc5b992603 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -150,12 +150,12 @@ regAlloc _ (CmmData sec d) , Nothing , Nothing ) -regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl []) - = return ( CmmProc info lbl (ListGraph []) +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) + = return ( CmmProc info lbl live (ListGraph []) , Nothing , Nothing ) -regAlloc dflags (CmmProc static lbl sccs) +regAlloc dflags (CmmProc static lbl live sccs) | LiveInfo info (Just first_id) (Just block_live) _ <- static = do -- do register allocation on each component. @@ -174,12 +174,12 @@ regAlloc dflags (CmmProc static lbl sccs) | otherwise = Nothing - return ( CmmProc info lbl (ListGraph (first' : rest')) + return ( CmmProc info lbl live (ListGraph (first' : rest')) , extra_stack , Just stats) -- bogus. to make non-exhaustive match warning go away. -regAlloc _ (CmmProc _ _ _) +regAlloc _ (CmmProc _ _ _ _) = panic "RegAllocLinear.regAlloc: no match" diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 608f0a423b..12c138897c 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -246,9 +246,9 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label sccs) +mapBlockTopM f (CmmProc header label live sccs) = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + return $ CmmProc header label live sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) mapSCCM f (AcyclicSCC x) @@ -278,9 +278,9 @@ mapGenBlockTopM mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) +mapGenBlockTopM f (CmmProc header label live (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + return $ CmmProc header label live (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -296,7 +296,7 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ sccs) + slurpCmm rs (CmmProc info _ _ sccs) = foldl' (slurpSCC info) rs sccs slurpSCC info rs (AcyclicSCC b) @@ -375,7 +375,7 @@ slurpReloadCoalesce live -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ sccs) + slurpCmm cs (CmmProc _ _ _ sccs) = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) @@ -475,7 +475,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -484,12 +484,12 @@ stripLive dflags live ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - in CmmProc info label + in CmmProc info label live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc @@ -559,14 +559,14 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) + patchCmm (CmmProc info label live sccs) | LiveInfo static id (Just blockMap) mLiveSlots <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapMap patchRegSet blockMap info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + in CmmProc info' label live $ map patchSCC sccs | otherwise = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" @@ -635,17 +635,17 @@ natCmmTopToLive natCmmTopToLive (CmmData i d) = CmmData i d -natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] +natCmmTopToLive (CmmProc info lbl live (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] -natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) +natCmmTopToLive (CmmProc info lbl live (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive sccBlocks @@ -674,18 +674,18 @@ regLiveness regLiveness _ (CmmData i d) = return $ CmmData i d -regLiveness _ (CmmProc info lbl []) +regLiveness _ (CmmProc info lbl live []) | LiveInfo static mFirst _ _ <- info = return $ CmmProc (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] + lbl live [] -regLiveness platform (CmmProc info lbl sccs) +regLiveness platform (CmmProc info lbl live sccs) | LiveInfo static mFirst _ liveSlotsOnEntry <- info = let (ann_sccs, block_live) = computeLiveness platform sccs in return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + lbl live ann_sccs -- ----------------------------------------------------------------------------- @@ -734,7 +734,7 @@ reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr reverseBlocksInTops top = case top of CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmProc info lbl live sccs -> CmmProc info lbl live (reverse sccs) -- | Computing liveness diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index aeb6d10acc..c4efdf677e 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -59,10 +59,10 @@ import Control.Monad ( mapAndUnzipM ) cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) let tops = proc : concat statics return tops diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index c468fcc255..fa397771d7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -32,8 +32,8 @@ expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) = top -expandTop (CmmProc info lbl (ListGraph blocks)) - = CmmProc info lbl (ListGraph $ map expandBlock blocks) +expandTop (CmmProc info lbl live (ListGraph blocks)) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 55afac0ee2..9bfa3141cc 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 7ab30bf922..cfadd57869 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -93,11 +93,11 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr] -cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -173,9 +173,8 @@ stmtToInstrs stmt = do panic "stmtToInstrs: return statement should have been cps'd away" -jumpRegs :: DynFlags -> Maybe [GlobalReg] -> [Reg] -jumpRegs dflags Nothing = allHaskellArgRegs dflags -jumpRegs dflags (Just gregs) = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] +jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] +jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] where platform = targetPlatform dflags -------------------------------------------------------------------------------- diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 7bd9b0cc9e..d089fc3ec2 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -828,8 +828,8 @@ allocMoreStack -> NatCmmDecl statics X86.Instr.Instr allocMoreStack _ _ top@(CmmData _ _) = top -allocMoreStack platform amount (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph (map insert_stack_insns code)) +allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) = + CmmProc info lbl live (ListGraph (map insert_stack_insns code)) where alloc = mkStackAllocInstr platform amount dealloc = mkStackDeallocInstr platform amount diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 420da7cc3d..76715f1996 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -53,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc pprNatCmmDecl (CmmData section dats) = pprSectionHeader section $$ pprDatas dats -pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) = +pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = case topInfoTable proc of Nothing -> case blocks of @@ -129,8 +129,14 @@ include mk/ways.mk include mk/custom-settings.mk ifeq "$(findstring clean,$(MAKECMDGOALS))" "" -ifeq "$(GhcLibWays)" "" -$(error $$(GhcLibWays) is empty, it must contain at least one way) +ifeq "$(DYNAMIC_BY_DEFAULT)" "YES" +ifeq "$(findstring dyn,$(GhcLibWays))" "" +$(error dyn is not in $$(GhcLibWays), but $$(DYNAMIC_BY_DEFAULT) is YES) +endif +else +ifeq "$(findstring v,$(GhcLibWays))" "" +$(error v is not in $$(GhcLibWays), and $$(DYNAMIC_BY_DEFAULT) is not YES) +endif endif endif @@ -1223,12 +1229,16 @@ CLEAN_FILES += libraries/bootstrapping.conf CLEAN_FILES += libraries/integer-gmp/cbits/GmpDerivedConstants.h CLEAN_FILES += libraries/integer-gmp/cbits/mkGmpDerivedConstants -# These four are no longer generated, but we still clean them for a while +# These are no longer generated, but we still clean them for a while # as they may still be in old GHC trees: CLEAN_FILES += includes/GHCConstants.h CLEAN_FILES += includes/DerivedConstants.h CLEAN_FILES += includes/ghcautoconf.h CLEAN_FILES += includes/ghcplatform.h +CLEAN_FILES += utils/ghc-pkg/Version.hs +CLEAN_FILES += compiler/parser/Parser.y +CLEAN_FILES += compiler/prelude/primops.txt +CLEAN_FILES += $(wildcard compiler/primop*incl) clean : clean_files clean_libraries diff --git a/includes/Cmm.h b/includes/Cmm.h index 2b5d93b2d1..211d2a86fe 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -194,7 +194,7 @@ if (predicate) { \ /*null*/; \ } else { \ - foreign "C" _assertFail(NULL, __LINE__); \ + foreign "C" _assertFail(NULL, __LINE__) never returns; \ } #else #define ASSERT(p) /* nothing */ @@ -682,8 +682,8 @@ #define SAVE_STGREGS \ W_ r1, r2, r3, r4, r5, r6, r7, r8; \ - F_ f1, f2, f3, f4; \ - D_ d1, d2; \ + F_ f1, f2, f3, f4, f5, f6; \ + D_ d1, d2, d3, d4, d5, d6; \ L_ l1; \ \ r1 = R1; \ @@ -699,9 +699,15 @@ f2 = F2; \ f3 = F3; \ f4 = F4; \ + f5 = F5; \ + f6 = F6; \ \ d1 = D1; \ d2 = D2; \ + d3 = D3; \ + d4 = D4; \ + d5 = D5; \ + d6 = D6; \ \ l1 = L1; @@ -720,9 +726,15 @@ F2 = f2; \ F3 = f3; \ F4 = f4; \ + F5 = f5; \ + F6 = f6; \ \ D1 = d1; \ D2 = d2; \ + D3 = d3; \ + D4 = d4; \ + D5 = d5; \ + D6 = d6; \ \ L1 = l1; diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs index 0ba57a46d7..b038f822c2 100644 --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -286,12 +286,30 @@ callerSaves (FloatReg 3) = True #ifdef CALLER_SAVES_F4 callerSaves (FloatReg 4) = True #endif +#ifdef CALLER_SAVES_F5 +callerSaves (FloatReg 5) = True +#endif +#ifdef CALLER_SAVES_F6 +callerSaves (FloatReg 6) = True +#endif #ifdef CALLER_SAVES_D1 callerSaves (DoubleReg 1) = True #endif #ifdef CALLER_SAVES_D2 callerSaves (DoubleReg 2) = True #endif +#ifdef CALLER_SAVES_D3 +callerSaves (DoubleReg 3) = True +#endif +#ifdef CALLER_SAVES_D4 +callerSaves (DoubleReg 4) = True +#endif +#ifdef CALLER_SAVES_D5 +callerSaves (DoubleReg 5) = True +#endif +#ifdef CALLER_SAVES_D6 +callerSaves (DoubleReg 6) = True +#endif #ifdef CALLER_SAVES_L1 callerSaves (LongReg 1) = True #endif @@ -362,24 +380,81 @@ activeStgRegs = [ #ifdef REG_SpLim ,SpLim #endif +#if MAX_REAL_SSE_REG != 0 #ifdef REG_F1 ,FloatReg 1 #endif +#ifdef REG_D1 + ,DoubleReg 1 +#endif #ifdef REG_F2 ,FloatReg 2 #endif +#ifdef REG_D2 + ,DoubleReg 2 +#endif #ifdef REG_F3 ,FloatReg 3 #endif +#ifdef REG_D3 + ,DoubleReg 3 +#endif #ifdef REG_F4 ,FloatReg 4 #endif +#ifdef REG_D4 + ,DoubleReg 4 +#endif +#ifdef REG_F5 + ,FloatReg 5 +#endif +#ifdef REG_D5 + ,DoubleReg 5 +#endif +#ifdef REG_F6 + ,FloatReg 6 +#endif +#ifdef REG_D6 + ,DoubleReg 6 +#endif +#else /* MAX_REAL_SSE_REG == 0 */ +#ifdef REG_F1 + ,FloatReg 1 +#endif +#ifdef REG_F2 + ,FloatReg 2 +#endif +#ifdef REG_F3 + ,FloatReg 3 +#endif +#ifdef REG_F4 + ,FloatReg 4 +#endif +#ifdef REG_F5 + ,FloatReg 5 +#endif +#ifdef REG_F6 + ,FloatReg 6 +#endif #ifdef REG_D1 ,DoubleReg 1 #endif #ifdef REG_D2 ,DoubleReg 2 #endif +#ifdef REG_D3 + ,DoubleReg 3 +#endif +#ifdef REG_D4 + ,DoubleReg 4 +#endif +#ifdef REG_D5 + ,DoubleReg 5 +#endif +#ifdef REG_D6 + ,DoubleReg 6 +#endif +#endif /* MAX_REAL_SSE_REG == 0 */ ] haveRegBase :: Bool @@ -439,6 +514,12 @@ globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) # ifdef REG_F4 globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) # endif +# ifdef REG_F5 +globalRegMaybe (FloatReg 5) = Just (RealRegSingle REG_F5) +# endif +# ifdef REG_F6 +globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) +# endif # ifdef REG_D1 globalRegMaybe (DoubleReg 1) = # if MACHREGS_sparc @@ -455,6 +536,38 @@ globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) # endif # endif +# ifdef REG_D3 +globalRegMaybe (DoubleReg 3) = +# if MACHREGS_sparc + Just (RealRegPair REG_D3 (REG_D3 + 1)) +# else + Just (RealRegSingle REG_D3) +# endif +# endif +# ifdef REG_D4 +globalRegMaybe (DoubleReg 4) = +# if MACHREGS_sparc + Just (RealRegPair REG_D4 (REG_D4 + 1)) +# else + Just (RealRegSingle REG_D4) +# endif +# endif +# ifdef REG_D5 +globalRegMaybe (DoubleReg 5) = +# if MACHREGS_sparc + Just (RealRegPair REG_D5 (REG_D5 + 1)) +# else + Just (RealRegSingle REG_D5) +# endif +# endif +# ifdef REG_D6 +globalRegMaybe (DoubleReg 6) = +# if MACHREGS_sparc + Just (RealRegPair REG_D6 (REG_D6 + 1)) +# else + Just (RealRegSingle REG_D6) +# endif +# endif # ifdef REG_Sp globalRegMaybe Sp = Just (RealRegSingle REG_Sp) # endif @@ -588,12 +701,30 @@ freeReg REG_F3 = fastBool False # ifdef REG_F4 freeReg REG_F4 = fastBool False # endif +# ifdef REG_F5 +freeReg REG_F5 = fastBool False +# endif +# ifdef REG_F6 +freeReg REG_F6 = fastBool False +# endif # ifdef REG_D1 freeReg REG_D1 = fastBool False # endif # ifdef REG_D2 freeReg REG_D2 = fastBool False # endif +# ifdef REG_D3 +freeReg REG_D3 = fastBool False +# endif +# ifdef REG_D4 +freeReg REG_D4 = fastBool False +# endif +# ifdef REG_D5 +freeReg REG_D5 = fastBool False +# endif +# ifdef REG_D6 +freeReg REG_D6 = fastBool False +# endif # ifdef REG_Sp freeReg REG_Sp = fastBool False # endif @@ -698,6 +829,12 @@ freeReg REG_F3 = fastBool False # ifdef REG_F4 freeReg REG_F4 = fastBool False # endif +# ifdef REG_F5 +freeReg REG_F5 = fastBool False +# endif +# ifdef REG_F6 +freeReg REG_F6 = fastBool False +# endif # ifdef REG_D1 freeReg REG_D1 = fastBool False # endif @@ -710,6 +847,30 @@ freeReg REG_D2 = fastBool False # ifdef REG_D2_2 freeReg REG_D2_2 = fastBool False # endif +# ifdef REG_D3 +freeReg REG_D3 = fastBool False +# endif +# ifdef REG_D3_2 +freeReg REG_D3_2 = fastBool False +# endif +# ifdef REG_D4 +freeReg REG_D4 = fastBool False +# endif +# ifdef REG_D4_2 +freeReg REG_D4_2 = fastBool False +# endif +# ifdef REG_D5 +freeReg REG_D5 = fastBool False +# endif +# ifdef REG_D5_2 +freeReg REG_D5_2 = fastBool False +# endif +# ifdef REG_D6 +freeReg REG_D6 = fastBool False +# endif +# ifdef REG_D6_2 +freeReg REG_D6_2 = fastBool False +# endif # ifdef REG_Sp freeReg REG_Sp = fastBool False # endif diff --git a/includes/ghc.mk b/includes/ghc.mk index dd38a6d6c0..85df1da8b9 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -34,7 +34,7 @@ includes_H_FILES := $(subst /./,/,$(includes_H_FILES)) # Options # ifeq "$(GhcUnregisterised)" "YES" -includes_CC_OPTS += -DNO_REGS -DUSE_MINIINTERPRETER +includes_CC_OPTS += -DUSE_MINIINTERPRETER endif includes_CC_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) @@ -125,6 +125,9 @@ endif @echo "#define $(TargetOS_CPP)_TARGET_OS 1" >> $@ @echo "#define TARGET_OS \"$(TargetOS_CPP)\"" >> $@ @echo "#define $(TargetVendor_CPP)_TARGET_VENDOR 1" >> $@ +ifeq "$(GhcUnregisterised)" "YES" + @echo "#define UnregisterisedCompiler 1" >> $@ +endif @echo >> $@ @echo "#endif /* __GHCPLATFORM_H__ */" >> $@ @echo "Done." diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index a58c500928..79242d9b41 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -46,7 +46,7 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske printf(" , pc_OFFSET_" str " :: Int\n"); \ break; \ case Gen_Haskell_Value: \ - printf(" , pc_OFFSET_" str " = %" PRIdPTR "\n", (intptr_t)offset); \ + printf(" , pc_OFFSET_" str " = %" PRIdPTR "\n", (intptr_t)(offset)); \ break; \ case Gen_Haskell_Wrappers: \ printf("oFFSET_" str " :: DynFlags -> Int\n"); \ @@ -56,7 +56,7 @@ enum Mode { Gen_Haskell_Type, Gen_Haskell_Value, Gen_Haskell_Wrappers, Gen_Haske printf(" oFFSET_" str ",\n"); \ break; \ case Gen_Header: \ - printf("#define OFFSET_" str " %" PRIdPTR "\n", (intptr_t)offset); \ + printf("#define OFFSET_" str " %" PRIdPTR "\n", (intptr_t)(offset)); \ break; \ } @@ -458,8 +458,14 @@ main(int argc, char *argv[]) field_offset(StgRegTable, rF2); field_offset(StgRegTable, rF3); field_offset(StgRegTable, rF4); + field_offset(StgRegTable, rF5); + field_offset(StgRegTable, rF6); field_offset(StgRegTable, rD1); field_offset(StgRegTable, rD2); + field_offset(StgRegTable, rD3); + field_offset(StgRegTable, rD4); + field_offset(StgRegTable, rD5); + field_offset(StgRegTable, rD6); field_offset(StgRegTable, rL1); field_offset(StgRegTable, rSp); field_offset(StgRegTable, rSpLim); @@ -736,9 +742,11 @@ main(int argc, char *argv[]) constantInt("mAX_Float_REG", MAX_FLOAT_REG); constantInt("mAX_Double_REG", MAX_DOUBLE_REG); constantInt("mAX_Long_REG", MAX_LONG_REG); + constantInt("mAX_SSE_REG", MAX_SSE_REG); constantInt("mAX_Real_Vanilla_REG", MAX_REAL_VANILLA_REG); constantInt("mAX_Real_Float_REG", MAX_REAL_FLOAT_REG); constantInt("mAX_Real_Double_REG", MAX_REAL_DOUBLE_REG); + constantInt("mAX_Real_SSE_REG", MAX_REAL_SSE_REG); constantInt("mAX_Real_Long_REG", MAX_REAL_LONG_REG); // This tells the native code generator the size of the spill diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 2fab041c22..5ff4d4e51e 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -81,9 +81,10 @@ -------------------------------------------------------------------------- */ #define MAX_VANILLA_REG 10 -#define MAX_FLOAT_REG 4 -#define MAX_DOUBLE_REG 2 +#define MAX_FLOAT_REG 6 +#define MAX_DOUBLE_REG 6 #define MAX_LONG_REG 1 +#define MAX_SSE_REG 6 /* ----------------------------------------------------------------------------- Semi-Tagging constants diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h index 6a70d08d66..8cefe9bc64 100644 --- a/includes/stg/MachRegs.h +++ b/includes/stg/MachRegs.h @@ -92,6 +92,7 @@ #define MAX_REAL_FLOAT_REG 0 #define MAX_REAL_DOUBLE_REG 0 #define MAX_REAL_LONG_REG 0 +#define MAX_REAL_SSE_REG 0 /* ----------------------------------------------------------------------------- The x86-64 register mapping @@ -141,9 +142,22 @@ #define REG_F2 xmm2 #define REG_F3 xmm3 #define REG_F4 xmm4 - -#define REG_D1 xmm5 -#define REG_D2 xmm6 +#define REG_F5 xmm5 +#define REG_F6 xmm6 + +#define REG_D1 xmm1 +#define REG_D2 xmm2 +#define REG_D3 xmm3 +#define REG_D4 xmm4 +#define REG_D5 xmm5 +#define REG_D6 xmm6 + +#define REG_SSE1 xmm1 +#define REG_SSE2 xmm2 +#define REG_SSE3 xmm3 +#define REG_SSE4 xmm4 +#define REG_SSE5 xmm5 +#define REG_SSE6 xmm6 #if !defined(mingw32_HOST_OS) #define CALLER_SAVES_R3 @@ -156,16 +170,34 @@ #define CALLER_SAVES_F2 #define CALLER_SAVES_F3 #define CALLER_SAVES_F4 +#define CALLER_SAVES_F5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_F6 +#endif #define CALLER_SAVES_D1 -#if !defined(mingw32_HOST_OS) #define CALLER_SAVES_D2 +#define CALLER_SAVES_D3 +#define CALLER_SAVES_D4 +#define CALLER_SAVES_D5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_D6 +#endif + +#define CALLER_SAVES_SSE1 +#define CALLER_SAVES_SSE2 +#define CALLER_SAVES_SSE3 +#define CALLER_SAVES_SSE4 +#define CALLER_SAVES_SSE5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_SSE6 #endif #define MAX_REAL_VANILLA_REG 6 -#define MAX_REAL_FLOAT_REG 4 -#define MAX_REAL_DOUBLE_REG 2 +#define MAX_REAL_FLOAT_REG 6 +#define MAX_REAL_DOUBLE_REG 6 #define MAX_REAL_LONG_REG 0 +#define MAX_REAL_SSE_REG 6 /* ----------------------------------------------------------------------------- The PowerPC register mapping @@ -518,6 +550,24 @@ # endif #endif +#ifndef MAX_REAL_SSE_REG +# if defined(REG_SSE6) +# define MAX_REAL_SSE_REG 6 +# elif defined(REG_SSE5) +# define MAX_REAL_SSE_REG 5 +# elif defined(REG_SSE4) +# define MAX_REAL_SSE_REG 4 +# elif defined(REG_SSE3) +# define MAX_REAL_SSE_REG 3 +# elif defined(REG_SSE2) +# define MAX_REAL_SSE_REG 2 +# elif defined(REG_SSE1) +# define MAX_REAL_SSE_REG 1 +# else +# define MAX_REAL_SSE_REG 0 +# endif +#endif + /* define NO_ARG_REGS if we have no argument registers at all (we can * optimise certain code paths using this predicate). */ diff --git a/includes/stg/Regs.h b/includes/stg/Regs.h index 70e93d3234..fd1577e71a 100644 --- a/includes/stg/Regs.h +++ b/includes/stg/Regs.h @@ -73,8 +73,14 @@ typedef struct { StgFloat rF2; StgFloat rF3; StgFloat rF4; + StgFloat rF5; + StgFloat rF6; StgDouble rD1; StgDouble rD2; + StgDouble rD3; + StgDouble rD4; + StgDouble rD5; + StgDouble rD6; StgWord64 rL1; StgPtr rSp; StgPtr rSpLim; @@ -216,6 +222,18 @@ GLOBAL_REG_DECL(StgFloat,F4,REG_F4) #define F4 (BaseReg->rF4) #endif +#if defined(REG_F5) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgFloat,F5,REG_F5) +#else +#define F5 (BaseReg->rF5) +#endif + +#if defined(REG_F6) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgFloat,F6,REG_F6) +#else +#define F6 (BaseReg->rF6) +#endif + #if defined(REG_D1) && !defined(NO_GLOBAL_REG_DECLS) GLOBAL_REG_DECL(StgDouble,D1,REG_D1) #else @@ -228,6 +246,30 @@ GLOBAL_REG_DECL(StgDouble,D2,REG_D2) #define D2 (BaseReg->rD2) #endif +#if defined(REG_D3) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgDouble,D3,REG_D3) +#else +#define D3 (BaseReg->rD3) +#endif + +#if defined(REG_D4) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgDouble,D4,REG_D4) +#else +#define D4 (BaseReg->rD4) +#endif + +#if defined(REG_D5) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgDouble,D5,REG_D5) +#else +#define D5 (BaseReg->rD5) +#endif + +#if defined(REG_D6) && !defined(NO_GLOBAL_REG_DECLS) +GLOBAL_REG_DECL(StgDouble,D6,REG_D6) +#else +#define D6 (BaseReg->rD6) +#endif + #if defined(REG_L1) && !defined(NO_GLOBAL_REG_DECLS) GLOBAL_REG_DECL(StgWord64,L1,REG_L1) #else diff --git a/includes/stg/RtsMachRegs.h b/includes/stg/RtsMachRegs.h index f78cb1f6b7..1eae6a5883 100644 --- a/includes/stg/RtsMachRegs.h +++ b/includes/stg/RtsMachRegs.h @@ -15,6 +15,12 @@ #ifndef RTSMACHREGS_H #define RTSMACHREGS_H +#ifdef UnregisterisedCompiler +#ifndef NO_REGS +#define NO_REGS +#endif +#endif + /* * Defining NO_REGS causes no global registers to be used. NO_REGS is * typically defined by GHC, via a command-line option passed to gcc, diff --git a/mk/config.mk.in b/mk/config.mk.in index 366d511608..a906d25fdf 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -136,8 +136,17 @@ SharedLibsByDefaultPlatformList = \ x86_64-unknown-linux \ x86_64-apple-darwin -DYNAMIC_BY_DEFAULT = $(if $(filter $(TARGETPLATFORM),\ - $(SharedLibsByDefaultPlatformList)),YES,NO) +# DYANMIC_BY_DEFAULT says whether this compiler will default to +# building dynamic executables, i.e. -dynamic is on. We do this for +# certain platforms because it lets us use the system dynamic linker +# instead of our own linker for GHCi. +# +# We do not enable this for an unregisterised build. It is currently +# unknown whether shared libraries (should) work when unregisterised. +# +DYNAMIC_BY_DEFAULT = $(strip $(if $(filter YES,$(GhcUnregisterised)),NO,\ + $(if $(filter $(TARGETPLATFORM),\ + $(SharedLibsByDefaultPlatformList)),YES,NO))) # Build a compiler that will build *unregisterised* libraries and # binaries by default. Unregisterised code is supposed to compile and diff --git a/rts/AutoApply.h b/rts/AutoApply.h index ebb7308875..c5dbbcd344 100644 --- a/rts/AutoApply.h +++ b/rts/AutoApply.h @@ -82,9 +82,9 @@ Sp(-1) = CCCS; \ Sp(-2) = stg_restore_cccs_info; \ Sp_adj(-2); \ - jump (target) [*] + jump (target) [R1] #else -#define jump_SAVE_CCCS(target) jump (target) [*] +#define jump_SAVE_CCCS(target) jump (target) [R1] #endif #endif /* APPLY_H */ diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 4fd44302f5..b3ae2648d9 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -509,7 +509,12 @@ INFO_TABLE_RET ( stg_block_takemvar, RET_SMALL, W_ info_ptr, P_ mvar ) // code fragment executed just before we return to the scheduler stg_block_takemvar_finally { + W_ r1, r3; + r1 = R1; + r3 = R3; unlockClosure(R3, stg_MVAR_DIRTY_info); + R1 = r1; + R3 = r3; jump StgReturn [R1]; } @@ -532,7 +537,12 @@ INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr, // code fragment executed just before we return to the scheduler stg_block_putmvar_finally { + W_ r1, r3; + r1 = R1; + r3 = R3; unlockClosure(R3, stg_MVAR_DIRTY_info); + R1 = r1; + R3 = r3; jump StgReturn [R1]; } @@ -565,7 +575,10 @@ stg_block_throwto_finally // unlocked. It may have been unlocked if we revoked the message // due to an exception being raised during threadPaused(). if (StgHeader_info(StgTSO_block_info(CurrentTSO)) == stg_WHITEHOLE_info) { + W_ r1; + r1 = R1; unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info); + R1 = r1; } jump StgReturn [R1]; } diff --git a/rts/Linker.c b/rts/Linker.c index dca8a52813..0fd3be1052 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -5002,7 +5002,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, # endif // arm_HOST_ARCH default: - errorBelch("%s: unhandled ELF relocation(Rel) type %" FMT_SizeT "\n", + errorBelch("%s: unhandled ELF relocation(Rel) type %" FMT_Word "\n", oc->fileName, (W_)ELF_R_TYPE(info)); return 0; } @@ -5317,7 +5317,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, #endif default: - errorBelch("%s: unhandled ELF relocation(RelA) type %" FMT_SizeT "\n", + errorBelch("%s: unhandled ELF relocation(RelA) type %" FMT_Word "\n", oc->fileName, (W_)ELF_R_TYPE(info)); return 0; } diff --git a/rules/build-dependencies.mk b/rules/build-dependencies.mk index edde237784..8442801cbe 100644 --- a/rules/build-dependencies.mk +++ b/rules/build-dependencies.mk @@ -24,6 +24,16 @@ $1_$2_C_FILES_DEPS = $$(filter-out $$($1_$2_C_FILES_NODEPS),$$($1_$2_C_FILES)) $1_$2_MKDEPENDHS_FLAGS = -dep-makefile $$($1_$2_depfile_haskell).tmp $$(foreach way,$$(filter-out v,$$($1_$2_WAYS)),-dep-suffix $$(way)) $1_$2_MKDEPENDHS_FLAGS += -include-pkg-deps +# Setting hisuf/osuf is a kludge. If DYNAMIC_BY_DEFAULT is on, dyn is +# the first way, and p is another way, then without this kludge we run +# ghc -M -hisuf dyn_hi -osuf dyn_o -dep-suffix dyn -dep-suffix p +# which means we get dependencies for .dyn_hi/.dyn_o and .p_dyn_hi/.p_dyn_o +# rather than .dyn_hi/.dyn_o and .p_hi/.p_o. +# With the kludge we also get .hi/.o dependencies that we don't need, but +# they don't do any harm. +# We also specify -static, as otherwise we end up with some dependencies +# on .dyn_dyn_hi files +$1_$2_MKDEPENDHS_FLAGS += -static -hisuf hi -osuf o ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" @@ -34,8 +44,9 @@ $$($1_$2_depfile_haskell) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$($1_$2_depfile_haskell) : $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS) $$($1_$2_HC_MK_DEPEND_DEP) | $$$$(dir $$$$@)/. $$(call removeFiles,$$@.tmp) ifneq "$$($1_$2_HS_SRCS)" "" - "$$($1_$2_HC_MK_DEPEND)" -M $$($1_$2_MKDEPENDHS_FLAGS) \ + "$$($1_$2_HC_MK_DEPEND)" -M \ $$(filter-out -split-objs, $$($1_$2_$$(firstword $$($1_$2_WAYS))_ALL_HC_OPTS)) \ + $$($1_$2_MKDEPENDHS_FLAGS) \ $$($1_$2_HS_SRCS) endif echo "$1_$2_depfile_haskell_EXISTS = YES" >> $$@.tmp diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index e859184c59..1a097b7a1d 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -17,7 +17,7 @@ module Main(main) where import Text.PrettyPrint import Data.Word import Data.Bits -import Data.List ( intersperse ) +import Data.List ( intersperse, nub, sort ) import System.Exit import System.Environment import System.IO @@ -135,6 +135,18 @@ regRep _ = "W_" loadSpWordOff :: String -> Int -> Doc loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]" +-- Make a jump +mkJump :: RegStatus -- Registerised status + -> Doc -- Jump target + -> [Reg] -- Registers that are definitely live + -> [ArgRep] -- Jump arguments + -> Doc +mkJump regstatus jump live args = + text "jump " <> jump <+> brackets (hcat (punctuate comma (map text regs))) + where + (reg_locs, _, _) = assignRegs regstatus 0 args + regs = (nub . sort) (live ++ map fst reg_locs) + -- make a ptr/non-ptr bitmap from a list of argument types mkBitmap :: [ArgRep] -> Word32 mkBitmap args = foldr f 0 args @@ -178,7 +190,21 @@ mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi mkTagStmt tag = text ("R1 = R1 + "++ show tag) -genMkPAP regstatus macro jump ticker disamb +genMkPAP :: RegStatus -- Register status + -> String -- Macro + -> String -- Jump target + -> [Reg] -- Registers that are definitely live + -> String -- Ticker + -> String -- Disamb + -> Bool -- Don't load argument registers before jump if True + -> Bool -- Arguments already in registers if True + -> Bool -- Is a PAP if True + -> [ArgRep] -- Arguments + -> Int -- Size of all arguments + -> Doc -- info label + -> Bool -- Is a function + -> Doc +genMkPAP regstatus macro jump live ticker disamb no_load_regs -- don't load argument regs before jumping args_in_regs -- arguments are already in regs is_pap args all_args_size fun_info_label @@ -232,7 +258,7 @@ genMkPAP regstatus macro jump ticker disamb if is_fun_case then mb_tag_node arity else empty, if overflow_regs then text "jump_SAVE_CCCS" <> parens (text jump) <> semi - else text "jump " <> text jump <+> text "[*]" <> semi + else mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi ]) $$ text "}" @@ -334,7 +360,7 @@ genMkPAP regstatus macro jump ticker disamb then text "R2 = " <> fun_info_label <> semi else empty, if is_fun_case then mb_tag_node n_args else empty, - text "jump " <> text jump <+> text "[*]" <> semi + mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi ]) -- The LARGER ARITY cases: @@ -411,12 +437,18 @@ tagForArity :: Int -> Maybe Int tagForArity i | i < tAG_BITS_MAX = Just i | otherwise = Nothing +enterFastPathHelper :: Int + -> RegStatus + -> Bool + -> Bool + -> [ArgRep] + -> Doc enterFastPathHelper tag regstatus no_load_regs args_in_regs args = vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {", reg_doc, text " Sp_adj(" <> int sp' <> text ");", -- enter, but adjust offset with tag - text " jump " <> text "%GET_ENTRY(R1-" <> int tag <> text ") [*];", + text " " <> mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi, text "}" ] -- I don't totally understand this code, I copied it from @@ -552,7 +584,7 @@ genApply regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgBCO_arity(R1));", text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO" + genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO" True{-stack apply-} False{-args on stack-} False{-not a PAP-} args all_args_size fun_info_label {- tag stmt -}False ]), @@ -571,7 +603,7 @@ genApply regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));", text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" + genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN" False{-reg apply-} False{-args on stack-} False{-not a PAP-} args all_args_size fun_info_label {- tag stmt -}True ]), @@ -585,7 +617,7 @@ genApply regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgPAP_arity(R1));", text "ASSERT(arity > 0);", - genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP" + genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP" True{-stack apply-} False{-args on stack-} True{-is a PAP-} args all_args_size fun_info_label {- tag stmt -}False ]), @@ -686,7 +718,7 @@ genApplyFast regstatus args = nest 4 (vcat [ text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));", text "ASSERT(arity > 0);", - genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" "FUN" "FUN" + genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN" False{-reg apply-} True{-args in regs-} False{-not a PAP-} args all_args_size fun_info_label {- tag stmt -}True ]), @@ -701,7 +733,7 @@ genApplyFast regstatus args = nest 4 (vcat [ text "Sp_adj" <> parens (int (-sp_offset)) <> semi, saveRegOffs reg_locs, - text "jump" <+> fun_ret_label <+> text "[*]" <> semi + mkJump regstatus fun_ret_label [] [] <> semi ]), char '}' ]), @@ -739,7 +771,7 @@ genStackApply regstatus args = (assign_regs, sp') = loadRegArgs regstatus 0 args body = vcat [assign_regs, text "Sp_adj" <> parens (int sp') <> semi, - text "jump %GET_ENTRY(UNTAG(R1)) [*];" + mkJump regstatus (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi ] -- ----------------------------------------------------------------------------- diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index 68c63e2a1f..868f62c98f 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -51,7 +51,7 @@ endif # # ToDo: we might want to do this using ghc-cabal instead. # -utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) +utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/dist/build/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \ -no-user-$(GHC_PACKAGE_DB_FLAG) \ -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ @@ -60,8 +60,9 @@ utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/ -DBOOTSTRAPPING \ -odir bootstrapping \ -hidir bootstrapping \ - -iutils/ghc-pkg \ + -iutils/ghc-pkg \ -XCPP -XExistentialQuantification -XDeriveDataTypeable \ + -iutils/ghc-pkg/dist/build \ -ilibraries/Cabal/Cabal \ -ilibraries/filepath \ -ilibraries/hpc \ @@ -69,7 +70,8 @@ utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/ -ilibraries/bin-package-db -utils/ghc-pkg/Version.hs: mk/project.mk +utils/ghc-pkg/dist/build/Version.hs \ +utils/ghc-pkg/dist-install/build/Version.hs: mk/project.mk | $$(dir $$@)/. $(call removeFiles,$@) echo "module Version where" >> $@ echo "version, targetOS, targetARCH :: String" >> $@ @@ -77,9 +79,7 @@ utils/ghc-pkg/Version.hs: mk/project.mk echo "targetOS = \"$(TargetOS_CPP)\"" >> $@ echo "targetARCH = \"$(TargetArch_CPP)\"" >> $@ -$(eval $(call clean-target,utils/ghc-pkg,dist,\ - utils/ghc-pkg/dist \ - utils/ghc-pkg/Version.hs)) +$(eval $(call clean-target,utils/ghc-pkg,dist,utils/ghc-pkg/dist)) # ----------------------------------------------------------------------------- # Cross-compile case: Install our dist version @@ -110,6 +110,9 @@ else $(eval $(call build-prog,utils/ghc-pkg,dist-install,1)) endif +utils/ghc-pkg/dist-install/package-data.mk: \ + utils/ghc-pkg/dist-install/build/Version.hs + ifeq "$(Windows)" "NO" install: install_utils/ghc-pkg_link diff --git a/utils/touchy/touchy.c b/utils/touchy/touchy.c index dc4dc8d83f..7252012366 100644 --- a/utils/touchy/touchy.c +++ b/utils/touchy/touchy.c @@ -1,6 +1,5 @@ /* - * Simple _utime() wrapper for setting the mod. time on files - * to the current system time. + * Simple 'touch' program for Windows * */ #if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32) @@ -12,53 +11,108 @@ #include <fcntl.h> #include <errno.h> #include <utime.h> +#include <windows.h> + +/* +With Windows 7 in a virtual box VM on OS X, some very odd things happen +with dates and time stamps when SSHing into cygwin. e.g. here the +"Change" time is in the past: + +$ date; touch foo; stat foo +Fri Dec 2 16:58:07 GMTST 2011 + File: `foo' + Size: 0 Blocks: 0 IO Block: 65536 regular +empty file +Device: 540aba0bh/1409989131d Inode: 562949953592977 Links: 1 +Access: (0644/-rw-r--r--) Uid: ( 1000/ ian) Gid: ( 513/ None) +Access: 2011-12-02 16:58:07.414457900 +0000 +Modify: 2011-12-02 16:58:07.414457900 +0000 +Change: 2011-12-02 16:58:03.495141800 +0000 + Birth: 2011-12-02 16:57:57.731469900 +0000 + +And if we copy such a file, then the copy is older (as determined by the +"Modify" time) than the original: + +$ date; touch foo; stat foo; cp foo bar; stat bar +Fri Dec 2 16:59:10 GMTST 2011 + File: `foo' + Size: 0 Blocks: 0 IO Block: 65536 regular +empty file +Device: 540aba0bh/1409989131d Inode: 1407374883725128 Links: 1 +Access: (0644/-rw-r--r--) Uid: ( 1000/ ian) Gid: ( 513/ None) +Access: 2011-12-02 16:59:10.118457900 +0000 +Modify: 2011-12-02 16:59:10.118457900 +0000 +Change: 2011-12-02 16:59:06.189477700 +0000 + Birth: 2011-12-02 16:57:57.731469900 +0000 + File: `bar' + Size: 0 Blocks: 0 IO Block: 65536 regular +empty file +Device: 540aba0bh/1409989131d Inode: 281474976882512 Links: 1 +Access: (0644/-rw-r--r--) Uid: ( 1000/ ian) Gid: ( 513/ None) +Access: 2011-12-02 16:59:06.394555800 +0000 +Modify: 2011-12-02 16:59:06.394555800 +0000 +Change: 2011-12-02 16:59:06.395532400 +0000 + Birth: 2011-12-02 16:58:40.921899600 +0000 + +This means that make thinks that things are out of date when it +shouldn't, so reinvokes itself repeatedly until the MAKE_RESTARTS +infinite-recursion test triggers. + +The touchy program, like most other programs, creates files with both +Modify and Change in the past, which is still a little odd, but is +consistent, so doesn't break make. + +We used to use _utime(argv[i],NULL)) to set the file modification times, +but after a BST -> GMT change this started giving files a modification +time an hour in the future: + +$ date; utils/touchy/dist/build/tmp/touchy testfile; stat testfile +Tue, Oct 30, 2012 11:33:06 PM + File: `testfile' + Size: 0 Blocks: 0 IO Block: 65536 regular empty file +Device: 540aba0bh/1409989131d Inode: 9851624184986293 Links: 1 +Access: (0755/-rwxr-xr-x) Uid: ( 1000/ ian) Gid: ( 513/ None) +Access: 2012-10-31 00:33:06.000000000 +0000 +Modify: 2012-10-31 00:33:06.000000000 +0000 +Change: 2012-10-30 23:33:06.769118900 +0000 + Birth: 2012-10-30 23:33:06.769118900 +0000 + +so now we use the Win32 functions GetSystemTimeAsFileTime and SetFileTime. +*/ int main(int argc, char** argv) { - int rc; - int i=0; - int fd; - int wBitSet = 0; - struct _stat sb; + int i; + FILETIME ft; + BOOL b; + HANDLE hFile; - if (argc == 1) { - fprintf(stderr, "Usage: %s <files>\n", argv[0]); - return 1; - } - - - while (i++ < (argc-1)) { - if ( (_access(argv[i], 00) < 0) && (errno == ENOENT || errno == EACCES) ) { - /* File doesn't exist, try creating it. */ - if ( (fd = _open(argv[i], _O_CREAT | _O_EXCL | _O_TRUNC, _S_IREAD | _S_IWRITE)) < 0 ) { - fprintf(stderr, "Unable to create %s, skipping.\n", argv[i]); - } else { - _close(fd); - } - } - if ( (_access(argv[i], 02)) < 0 ) { - /* No write permission, try setting it first. */ - if (_stat(argv[i], &sb) < 0) { - fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno); - continue; - } - if (_chmod(argv[i], (sb.st_mode & _S_IREAD) | _S_IWRITE) < 0) { - fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno); - continue; - } - wBitSet = 1; + if (argc == 1) { + fprintf(stderr, "Usage: %s <files>\n", argv[0]); + return 1; } - if ( (rc = _utime(argv[i],NULL)) < 0) { - fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno); - } - if (wBitSet) { - /* Turn the file back into a read-only file */ - _chmod(argv[i], (sb.st_mode & _S_IREAD)); - wBitSet = 0; + + for (i = 1; i < argc; i++) { + hFile = CreateFile(argv[i], GENERIC_WRITE, 0, NULL, OPEN_ALWAYS, + FILE_ATTRIBUTE_NORMAL, NULL); + if (hFile == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Unable to open %s\n", argv[i]); + exit(1); + } + GetSystemTimeAsFileTime(&ft); + b = SetFileTime(hFile, (LPFILETIME) NULL, (LPFILETIME) NULL, &ft); + if (b == 0) { + fprintf(stderr, "Unable to change mod. time for %s\n", argv[i]); + exit(1); + } + b = CloseHandle(hFile); + if (b == 0) { + fprintf(stderr, "Closing failed for %s\n", argv[i]); + exit(1); + } } - } - - return 0; + + return 0; } #endif |