From: Norman Ramsey Date: Thu, 6 Sep 2007 16:19:48 +0000 (+0000) Subject: massive changes to add a 'zipper' representation of C-- X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=16a2f6a8a381af31c23b6a41a851951da9bc1803 massive changes to add a 'zipper' representation of C-- Changes too numerous to comment on, but here is some old history that I saved: Wed Aug 15 11:07:13 BST 2007 Norman Ramsey * type synonyms made consistent with new Cmm types M ./compiler/nativeGen/MachInstrs.hs -2 +2 Mon Aug 20 19:22:14 BST 2007 Norman Ramsey * pushing return info beyond cmm into codegen M ./compiler/codeGen/Bitmap.hs r3 M ./compiler/codeGen/CgBindery.lhs r3 M ./compiler/codeGen/CgCallConv.hs r3 M ./compiler/codeGen/CgCase.lhs r3 M ./compiler/codeGen/CgClosure.lhs r3 M ./compiler/codeGen/CgCon.lhs r3 M ./compiler/codeGen/CgExpr.lhs r3 M ./compiler/codeGen/CgForeignCall.hs -6 +7 r3 M ./compiler/codeGen/CgHeapery.lhs r3 M ./compiler/codeGen/CgHpc.hs +1 r3 M ./compiler/codeGen/CgInfoTbls.hs r3 M ./compiler/codeGen/CgLetNoEscape.lhs r3 M ./compiler/codeGen/CgMonad.lhs r3 M ./compiler/codeGen/CgParallel.hs r3 M ./compiler/codeGen/CgPrimOp.hs +3 r3 M ./compiler/codeGen/CgProf.hs r3 M ./compiler/codeGen/CgStackery.lhs r3 M ./compiler/codeGen/CgTailCall.lhs r3 M ./compiler/codeGen/CgTicky.hs r3 M ./compiler/codeGen/CgUtils.hs -1 +1 r3 M ./compiler/codeGen/ClosureInfo.lhs r3 M ./compiler/codeGen/CodeGen.lhs r3 M ./compiler/codeGen/SMRep.lhs r3 M ./compiler/nativeGen/AsmCodeGen.lhs -2 +2 r1 M ./compiler/nativeGen/MachCodeGen.hs -3 +3 r1 M ./compiler/nativeGen/MachInstrs.hs r1 M ./compiler/nativeGen/MachRegs.lhs r1 M ./compiler/nativeGen/NCGMonad.hs r1 M ./compiler/nativeGen/PositionIndependentCode.hs r1 M ./compiler/nativeGen/PprMach.hs r1 M ./compiler/nativeGen/RegAllocInfo.hs r1 M ./compiler/nativeGen/RegisterAlloc.hs r1 Mon Aug 20 20:54:41 BST 2007 Norman Ramsey * put CmmReturnInfo into a CmmCall (and related types) M ./compiler/cmm/Cmm.hs -2 +1 r3 M ./compiler/cmm/CmmBrokenBlock.hs -13 +12 r1 M ./compiler/cmm/CmmCPS.hs -3 +3 M ./compiler/cmm/CmmCPSGen.hs -8 +6 r1 M ./compiler/cmm/CmmLint.hs -1 +1 M ./compiler/cmm/CmmLive.hs -1 +1 M ./compiler/cmm/CmmOpt.hs -3 +3 M ./compiler/cmm/CmmParse.y -6 +6 r3 M ./compiler/cmm/PprC.hs -3 +3 M ./compiler/cmm/PprCmm.hs -7 +4 r2 M ./compiler/codeGen/CgForeignCall.hs -7 +6 r2 M ./compiler/codeGen/CgHpc.hs -1 r1 M ./compiler/codeGen/CgPrimOp.hs -3 r1 M ./compiler/codeGen/CgUtils.hs -1 +1 r1 M ./compiler/nativeGen/AsmCodeGen.lhs -2 +2 M ./compiler/nativeGen/MachCodeGen.hs -3 +3 r1 Tue Aug 21 18:09:13 BST 2007 Norman Ramsey * add call info in nativeGen M ./compiler/nativeGen/AsmCodeGen.lhs r1 M ./compiler/nativeGen/MachInstrs.hs r1 M ./compiler/nativeGen/MachRegs.lhs r1 M ./compiler/nativeGen/NCGMonad.hs r1 M ./compiler/nativeGen/PositionIndependentCode.hs r1 M ./compiler/nativeGen/PprMach.hs r1 M ./compiler/nativeGen/RegAllocInfo.hs r1 Wed Aug 22 16:41:58 BST 2007 Norman Ramsey * ListGraph is now a newtype, not a synonym The resultant bookkeepping is unenviable, but the change greatly simplifies our ability to make Cmm things propertly Outputable for both list-graph and zipper-graph representations. M ./compiler/cmm/Cmm.hs -5 +3 M ./compiler/cmm/CmmCPS.hs -2 +2 M ./compiler/cmm/CmmCPSGen.hs -1 +1 M ./compiler/cmm/CmmContFlowOpt.hs -3 +3 M ./compiler/cmm/CmmCvt.hs -2 +2 M ./compiler/cmm/CmmInfo.hs -2 +3 M ./compiler/cmm/CmmLint.hs -1 +1 M ./compiler/cmm/CmmOpt.hs -2 +2 M ./compiler/cmm/PprC.hs -1 +1 M ./compiler/cmm/PprCmm.hs -5 +8 M ./compiler/cmm/PprCmmZ.hs -7 +1 M ./compiler/codeGen/CgMonad.lhs -1 +1 M ./compiler/nativeGen/AsmCodeGen.lhs -15 +15 M ./compiler/nativeGen/MachCodeGen.hs -2 +2 M ./compiler/nativeGen/PositionIndependentCode.hs -6 +6 M ./compiler/nativeGen/PprMach.hs -3 +2 M ./compiler/nativeGen/RegAllocColor.hs +1 M ./compiler/nativeGen/RegAllocLinear.hs -4 +5 M ./compiler/nativeGen/RegCoalesce.hs -6 +6 M ./compiler/nativeGen/RegLiveness.hs -12 +12 Thu Aug 23 13:44:49 BST 2007 Norman Ramsey * diagnostic assistance in case fromJust fails M ./compiler/nativeGen/MachCodeGen.hs -2 +5 Thu Aug 23 14:07:28 BST 2007 Norman Ramsey * give every block, even the first, a label With branch-chain elimination, the first block of a procedure might be the target of a branch. This actually happens to a dozen or more procedures in the run-time system. M ./compiler/nativeGen/PprMach.hs -8 +3 Fri Aug 24 17:27:04 BST 2007 Norman Ramsey * clean up the code in PprMach M ./compiler/nativeGen/PprMach.hs -16 +14 Fri Aug 24 19:35:03 BST 2007 Norman Ramsey * a bunch of impedance matching to get the compiler to build, plus * the plus is diagnostics for unreachable code, which required moving a lot of prettyprinting code M ./compiler/cmm/Cmm.hs -7 +5 M ./compiler/cmm/CmmCPSZ.hs -1 +1 M ./compiler/cmm/CmmCvt.hs -8 +8 M ./compiler/cmm/CmmParse.y -4 +3 M ./compiler/cmm/MkZipCfg.hs -19 +9 M ./compiler/cmm/PprCmmZ.hs -118 +4 M ./compiler/cmm/ZipCfg.hs -1 +13 M ./compiler/cmm/ZipCfgCmm.hs -10 +129 M ./compiler/main/HscMain.lhs -4 +4 M ./compiler/nativeGen/NCGMonad.hs -2 +2 M ./compiler/nativeGen/RegAllocInfo.hs -3 +3 Fri Aug 31 14:38:02 BST 2007 Norman Ramsey * fix a warning about an import M ./compiler/nativeGen/RegAllocColor.hs -1 +1 --- diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 28c43e1..ba89a06 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -325,7 +325,8 @@ mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) mkDefaultLabel uniq = CaseLabel uniq CaseDefault mkStringLitLabel = StringLitLabel -mkAsmTempLabel = AsmTempLabel +mkAsmTempLabel :: Uniquable a => a -> CLabel +mkAsmTempLabel a = AsmTempLabel (getUnique a) mkModuleInitLabel :: Module -> String -> CLabel mkModuleInitLabel mod way = ModuleInitLabel mod way diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 0ba437c..22479ca 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Cmm data types @@ -6,41 +7,66 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details + module Cmm ( GenCmm(..), Cmm, RawCmm, GenCmmTop(..), CmmTop, RawCmmTop, - ListGraph(..), + ListGraph(..), + cmmMapGraph, cmmTopMapGraph, + cmmMapGraphM, cmmTopMapGraphM, CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, - GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, + GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmReturnInfo(..), CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, CmmSafety(..), CmmCallTarget(..), CmmStatic(..), Section(..), - CmmExpr(..), cmmExprRep, + CmmExpr(..), cmmExprRep, maybeInvertCmmExpr, CmmReg(..), cmmRegRep, CmmLit(..), cmmLitRep, LocalReg(..), localRegRep, localRegGCFollow, Kind(..), - BlockId(..), BlockEnv, + BlockId(..), freshBlockId, + BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, + BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, GlobalReg(..), globalRegRep, node, nodeReg, spReg, hpReg, spLimReg ) where +-- ^ In order not to do violence to the import structure of the rest +-- of the compiler, module Cmm re-exports a number of identifiers +-- defined in 'CmmExpr' + #include "HsVersions.h" +import CmmExpr import MachOp import CLabel import ForeignCall import SMRep import ClosureInfo -import Unique -import UniqFM +import Outputable import FastString import Data.Word +import ZipCfg ( BlockId(..), freshBlockId + , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv + , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet + ) + +-- A [[BlockId]] is a local label. +-- Local labels must be unique within an entire compilation unit, not +-- just a single top-level item, because local labels map one-to-one +-- with assembly-language labels. + ----------------------------------------------------------------------------- -- Cmm, CmmTop, CmmBasicBlock ----------------------------------------------------------------------------- @@ -58,6 +84,8 @@ import Data.Word -- (Cmm and RawCmm below) -- (b) Native code, populated with data/instructions -- +-- A second family of instances based on ZipCfg is work in progress. +-- newtype GenCmm d h g = Cmm [GenCmmTop d h g] -- | A top-level chunk, abstracted over the type of the contents of @@ -101,6 +129,9 @@ type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (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 + blockId :: GenBasicBlock i -> BlockId -- The branch block id is that of the first block in -- the branch, which is that branch's entry point @@ -109,8 +140,26 @@ blockId (BasicBlock blk_id _ ) = blk_id blockStmts :: GenBasicBlock i -> [i] blockStmts (BasicBlock _ stmts) = stmts + mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) +---------------------------------------------------------------- +-- graph maps +---------------------------------------------------------------- + +cmmMapGraph :: (g -> g') -> GenCmm d h g -> GenCmm d h g' +cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g' + +cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmm d h g -> m (GenCmm d h g') +cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g') + +cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops +cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g) +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds + +cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm +cmmTopMapGraphM f (CmmProc h l args g) = f (showSDoc $ ppr l) g >>= return . CmmProc h l args +cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds ----------------------------------------------------------------------------- -- Info Tables @@ -212,6 +261,28 @@ type CmmHintFormals = [(CmmFormal,MachHint)] type CmmFormals = [CmmFormal] data CmmSafety = CmmUnsafe | CmmSafe C_SRT +-- | enable us to fold used registers over 'CmmActuals' and 'CmmHintFormals' +instance UserOfLocalRegs a => UserOfLocalRegs (a, MachHint) where + foldRegsUsed f set (a, _) = foldRegsUsed f set a + +instance UserOfLocalRegs CmmStmt where + foldRegsUsed f set s = stmt s set + where stmt (CmmNop) = id + stmt (CmmComment {}) = id + stmt (CmmAssign _ e) = gen e + stmt (CmmStore e1 e2) = gen e1 . gen e2 + stmt (CmmCall target _ es _ _) = gen target . gen es + stmt (CmmBranch _) = id + stmt (CmmCondBranch e _) = gen e + stmt (CmmSwitch e _) = gen e + stmt (CmmJump e es) = gen e . gen es + stmt (CmmReturn es) = gen es + gen a set = foldRegsUsed f set a + +instance UserOfLocalRegs CmmCallTarget where + foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e + foldRegsUsed _ set (CmmPrim {}) = set + {- Discussion ~~~~~~~~~~ @@ -220,6 +291,10 @@ One possible problem with the above type is that the only way to do a non-local conditional jump is to encode it as a branch to a block that contains a single jump. This leads to inefficient code in the back end. +[N.B. This problem will go away when we make the transition to the +'zipper' form of control-flow graph, in which both targets of a +conditional jump are explicit. ---NR] + One possible way to fix this would be: data CmmStat = @@ -265,104 +340,6 @@ data CmmCallTarget -- code by the backend. ----------------------------------------------------------------------------- --- CmmExpr --- An expression. Expressions have no side effects. ------------------------------------------------------------------------------ - -data CmmExpr - = CmmLit CmmLit -- Literal - | CmmLoad CmmExpr MachRep -- Read memory location - | CmmReg CmmReg -- Contents of register - | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) - | CmmRegOff CmmReg Int - -- CmmRegOff reg i - -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep))) - -- where rep = cmmRegRep reg - deriving Eq - -data CmmReg - = CmmLocal LocalReg - | CmmGlobal GlobalReg - deriving( Eq ) - --- | Whether a 'LocalReg' is a GC followable pointer -data Kind = KindPtr | KindNonPtr deriving (Eq) - -data LocalReg - = LocalReg - !Unique -- ^ Identifier - MachRep -- ^ Type - Kind -- ^ Should the GC follow as a pointer - -data CmmLit - = CmmInt Integer MachRep - -- Interpretation: the 2's complement representation of the value - -- is truncated to the specified size. This is easier than trying - -- to keep the value within range, because we don't know whether - -- it will be used as a signed or unsigned value (the MachRep doesn't - -- distinguish between signed & unsigned). - | CmmFloat Rational MachRep - | CmmLabel CLabel -- Address of label - | CmmLabelOff CLabel Int -- Address of label + byte offset - - -- Due to limitations in the C backend, the following - -- MUST ONLY be used inside the info table indicated by label2 - -- (label2 must be the info label), and label1 must be an - -- SRT, a slow entrypoint or a large bitmap (see the Mangler) - -- Don't use it at all unless tablesNextToCode. - -- It is also used inside the NCG during when generating - -- position-independent code. - | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset - deriving Eq - -instance Eq LocalReg where - (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2 - -instance Uniquable LocalReg where - getUnique (LocalReg uniq _ _) = uniq - ------------------------------------------------------------------------------ --- MachRep ------------------------------------------------------------------------------ -cmmExprRep :: CmmExpr -> MachRep -cmmExprRep (CmmLit lit) = cmmLitRep lit -cmmExprRep (CmmLoad _ rep) = rep -cmmExprRep (CmmReg reg) = cmmRegRep reg -cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op -cmmExprRep (CmmRegOff reg _) = cmmRegRep reg - -cmmRegRep :: CmmReg -> MachRep -cmmRegRep (CmmLocal reg) = localRegRep reg -cmmRegRep (CmmGlobal reg) = globalRegRep reg - -localRegRep :: LocalReg -> MachRep -localRegRep (LocalReg _ rep _) = rep - -localRegGCFollow :: LocalReg -> Kind -localRegGCFollow (LocalReg _ _ p) = p - -cmmLitRep :: CmmLit -> MachRep -cmmLitRep (CmmInt _ rep) = rep -cmmLitRep (CmmFloat _ rep) = rep -cmmLitRep (CmmLabel _) = wordRep -cmmLitRep (CmmLabelOff _ _) = wordRep -cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep - ------------------------------------------------------------------------------ --- A local label. - --- Local labels must be unique within a single compilation unit. - -newtype BlockId = BlockId Unique - deriving (Eq,Ord) - -instance Uniquable BlockId where - getUnique (BlockId u) = u - -type BlockEnv a = UniqFM {- BlockId -} a - ------------------------------------------------------------------------------ -- Static Data ----------------------------------------------------------------------------- @@ -387,69 +364,3 @@ data CmmStatic | CmmString [Word8] -- string of 8-bit values only, not zero terminated. ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number - - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure - - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun - - -- Base offset for the register table, used for accessing registers - -- which do not have real registers assigned to them. This register - -- will only appear after we have expanded GlobalReg into memory accesses - -- (where necessary) in the native code generator. - | BaseReg - - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg - - deriving( Eq -#ifdef DEBUG - , Show -#endif - ) - --- convenient aliases -spReg, hpReg, spLimReg, nodeReg :: CmmReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node - -node :: GlobalReg -node = VanillaReg 1 - -globalRegRep :: GlobalReg -> MachRep -globalRegRep (VanillaReg _) = wordRep -globalRegRep (FloatReg _) = F32 -globalRegRep (DoubleReg _) = F64 -globalRegRep (LongReg _) = I64 -globalRegRep _ = wordRep diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 9118ef3..d24d77a 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -2,7 +2,7 @@ -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings -- for details module CmmCallConv ( diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 770baec..3524377 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -14,7 +14,6 @@ module CmmInfo ( import Cmm import CmmUtils -import PprCmm import CLabel import MachOp @@ -28,7 +27,6 @@ import SMRep import Constants import StaticFlags -import DynFlags import Unique import UniqSupply import Panic @@ -78,10 +76,10 @@ cmmToRawCmm cmm = do mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] -mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments (ListGraph blocks)) = +mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = case info of -- | Code without an info table. Easy. - CmmNonInfoTable -> [CmmProc [] entry_label arguments (ListGraph blocks)] + CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info -> let info_label = entryLblToInfoLbl entry_label @@ -153,21 +151,21 @@ mkInfoTableAndCode :: CLabel -> [CmmLit] -> CLabel -> CmmFormals - -> [CmmBasicBlock] + -> ListGraph CmmStmt -> [RawCmmTop] mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) - entry_lbl args (ListGraph blocks)] + entry_lbl args blocks] - | null blocks -- No actual code; only the info table is significant + | ListGraph [] <- blocks -- No code; only the info table is significant = -- Use a zero place-holder in place of the -- entry-label in the info table [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)] | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [CmmProc [] entry_lbl args (ListGraph blocks), + [CmmProc [] entry_lbl args blocks, mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] mkSRTLit :: CLabel @@ -277,3 +275,7 @@ mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit | otherwise = [] type_lit = packHalfWordsCLit cl_type srt_len + + +_unused :: FS.FastString -- stops a warning +_unused = undefined diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 4b63346..b1922d0 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -22,6 +22,7 @@ module CmmLint ( import Cmm import CLabel import MachOp +import Maybe import Outputable import PprCmm import Unique @@ -44,15 +45,18 @@ runCmmLint l = Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err) Right _ -> Nothing +lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint () lintCmmTop (CmmProc _ lbl _ (ListGraph blocks)) = addLintInfo (text "in proc " <> pprCLabel lbl) $ - mapM_ lintCmmBlock blocks -lintCmmTop _other + let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks + in mapM_ (lintCmmBlock labels) blocks + +lintCmmTop (CmmData {}) = return () -lintCmmBlock (BasicBlock id stmts) +lintCmmBlock labels (BasicBlock id stmts) = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ - mapM_ lintCmmStmt stmts + mapM_ (lintCmmStmt labels) stmts -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -85,13 +89,13 @@ lintCmmExpr expr = cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset (CmmMachOp op args) -cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)] +cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] = cmmCheckMachOp op [reg, lit] cmmCheckMachOp op@(MO_U_Conv from to) args | isFloatingRep from || isFloatingRep to = cmmLintErr (text "unsigned conversion from/to floating rep: " <> ppr (CmmMachOp op args)) -cmmCheckMachOp op args +cmmCheckMachOp op _args = return (resultRepOfMachOp op) isWordOffsetReg (CmmGlobal Sp) = True @@ -119,25 +123,38 @@ cmmCheckWordAddress _ notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True -lintCmmStmt :: CmmStmt -> CmmLint () -lintCmmStmt stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr expr - if (erep == cmmRegRep reg) - then return () - else cmmLintAssignErr stmt -lintCmmStmt (CmmStore l r) = do - lintCmmExpr l - lintCmmExpr r - return () -lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args -lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return () -lintCmmStmt (CmmSwitch e _branches) = do - erep <- lintCmmExpr e - if (erep == wordRep) - then return () - else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e) -lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return () -lintCmmStmt _other = return () +lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint () +lintCmmStmt labels = lint + where lint (CmmNop) = return () + lint (CmmComment {}) = return () + lint stmt@(CmmAssign reg expr) = do + erep <- lintCmmExpr expr + if (erep == cmmRegRep reg) + then return () + else cmmLintAssignErr stmt + lint (CmmStore l r) = do + lintCmmExpr l + lintCmmExpr r + return () + lint (CmmCall target _res args _ _) = + lintTarget target >> mapM_ (lintCmmExpr.fst) args + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e + lint (CmmSwitch e branches) = do + mapM_ checkTarget $ catMaybes branches + erep <- lintCmmExpr e + if (erep == wordRep) + then return () + else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e) + lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr.fst) args + lint (CmmReturn ress) = mapM_ (lintCmmExpr.fst) ress + lint (CmmBranch id) = checkTarget id + checkTarget id = if elemBlockSet id labels then return () + else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) + +lintTarget :: CmmCallTarget -> CmmLint () +lintTarget (CmmCallee e _) = lintCmmExpr e >> return () +lintTarget (CmmPrim {}) = return () + checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2 diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 5f6654e..8a2dd75 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -22,6 +22,7 @@ module CmmOpt ( #include "HsVersions.h" import Cmm +import CmmExpr import CmmUtils import CLabel import MachOp @@ -52,6 +53,10 @@ once. It works as follows: - if we reach the statement that uses it, inline the rhs and delete the original assignment. +[N.B. In the Quick C-- compiler, this optimization is achieved by a + combination of two dataflow passes: forward substitution (peephole + optimization) and dead-assignment elimination. ---NR] + Possible generalisations: here is an example from factorial Fac_zdwfac_entry: @@ -85,17 +90,14 @@ To inline _smi: its occurrences. -} +countUses :: UserOfLocalRegs a => a -> UniqFM Int +countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a + where count m r = lookupWithDefaultUFM m (0::Int) r + cmmMiniInline :: [CmmBasicBlock] -> [CmmBasicBlock] cmmMiniInline blocks = map do_inline blocks - where - blockUses (BasicBlock _ stmts) - = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts) - - uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks) - - do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts uses stmts) - + where do_inline (BasicBlock id stmts) + = BasicBlock id (cmmMiniInlineStmts (countUses blocks) stmts) cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt] cmmMiniInlineStmts uses [] = [] @@ -117,7 +119,7 @@ cmmMiniInlineStmts uses (stmt:stmts) -- and temporaries are single-assignment. lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest) | u /= u' - = case lookupUFM (getExprUses rhs) u of + = case lookupUFM (countUses rhs) u of Just 1 -> Just (inlineStmt u expr stmt : rest) _other -> case lookForInline u expr rest of Nothing -> Nothing @@ -126,8 +128,10 @@ lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest) lookForInline u expr (CmmNop : rest) = lookForInline u expr rest +lookForInline _ _ [] = Nothing + lookForInline u expr (stmt:stmts) - = case lookupUFM (getStmtUses stmt) u of + = case lookupUFM (countUses stmt) u of Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts) _other -> Nothing where @@ -140,30 +144,6 @@ lookForInline u expr (stmt:stmts) CmmCall{} -> hasNoGlobalRegs expr _ -> True --- ----------------------------------------------------------------------------- --- Boring Cmm traversals for collecting usage info and substitutions. - -getStmtUses :: CmmStmt -> UniqFM Int -getStmtUses (CmmAssign _ e) = getExprUses e -getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2) -getStmtUses (CmmCall target _ es _ _) - = plusUFM_C (+) (uses target) (getExprsUses (map fst es)) - where uses (CmmCallee e _) = getExprUses e - uses _ = emptyUFM -getStmtUses (CmmCondBranch e _) = getExprUses e -getStmtUses (CmmSwitch e _) = getExprUses e -getStmtUses (CmmJump e _) = getExprUses e -getStmtUses _ = emptyUFM - -getExprUses :: CmmExpr -> UniqFM Int -getExprUses (CmmReg (CmmLocal (LocalReg u _ _))) = unitUFM u 1 -getExprUses (CmmRegOff (CmmLocal (LocalReg u _ _)) _) = unitUFM u 1 -getExprUses (CmmLoad e _) = getExprUses e -getExprUses (CmmMachOp _ es) = getExprsUses es -getExprUses _other = emptyUFM - -getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es) - inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) @@ -391,15 +371,15 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))] MO_S_Shr r -> x MO_U_Shr r -> x MO_Ne r | isComparisonExpr x -> x - MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_Eq r | Just x' <- maybeInvertCmmExpr x -> x' MO_U_Gt r | isComparisonExpr x -> x MO_S_Gt r | isComparisonExpr x -> x MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) - MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x' - MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> x' + MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> x' other -> CmmMachOp mop args cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))] @@ -409,10 +389,10 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))] MO_U_Quot r -> x MO_S_Rem r -> CmmLit (CmmInt 0 rep) MO_U_Rem r -> CmmLit (CmmInt 0 rep) - MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_Ne r | Just x' <- maybeInvertCmmExpr x -> x' MO_Eq r | isComparisonExpr x -> x - MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x' - MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x' + MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> x' + MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> x' MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep) MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep) @@ -565,10 +545,8 @@ isComparisonExpr :: CmmExpr -> Bool isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op isComparisonExpr _other = False -maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr -maybeInvertConditionalExpr (CmmMachOp op args) - | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args) -maybeInvertConditionalExpr _ = Nothing - isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True isPicReg _ = False + +_unused :: FS.FastString -- stops a warning +_unused = undefined diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 5a379c8..4c2fffa 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -909,29 +909,15 @@ foreignCall conv_string results_code expr_code args_code vols safety ret case convention of -- Temporary hack so at least some functions are CmmSafe CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret)) - _ -> - let expr' = adjCallTarget convention expr args in - case safety of + _ -> case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmCallee expr' convention) args vols NoC_SRT ret) + (CmmCallee expr convention) args vols NoC_SRT ret) CmmSafe srt -> code (emitForeignCall' (PlaySafe unused) results - (CmmCallee expr' convention) args vols NoC_SRT ret) where + (CmmCallee expr convention) args vols NoC_SRT ret) where unused = panic "not used by emitForeignCall'" -adjCallTarget :: CCallConv -> CmmExpr -> [(CmmExpr,MachHint)] -> CmmExpr -#ifdef mingw32_TARGET_OS --- On Windows, we have to add the '@N' suffix to the label when making --- a call with the stdcall calling convention. -adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args - = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (e,_) = max wORD_SIZE (machRepByteWidth (cmmExprRep e)) - -- c.f. CgForeignCall.emitForeignCall -#endif -adjCallTarget _ expr _ - = expr - primCall :: [ExtFCode (CmmFormal,MachHint)] -> FastString @@ -1102,7 +1088,7 @@ parseCmmFile dflags filename = do let ms = getMessages pst printErrorsAndWarnings dflags ms when (errorsFound dflags ms) $ exitWith (ExitFailure 1) - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm]) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) return (Just cmm) where no_module = panic "parseCmmFile: no module" diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 65e2f6f..c31c4de 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -39,13 +39,15 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -module PprCmm ( - writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic - ) where +module PprCmm + ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic + ) +where #include "HsVersions.h" import Cmm +import CmmExpr import CmmUtils import MachOp import CLabel @@ -59,7 +61,7 @@ import Data.List import System.IO import Data.Maybe -pprCmms :: (Outputable info) => [GenCmm CmmStatic info (ListGraph CmmStmt)] -> SDoc +pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext SLIT("-------------------") $$ space @@ -69,22 +71,20 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance (Outputable info) => Outputable (GenCmm CmmStatic info (ListGraph CmmStmt)) where +instance (Outputable info, Outputable g) + => Outputable (GenCmm CmmStatic info g) where ppr c = pprCmm c instance (Outputable d, Outputable info, Outputable i) => Outputable (GenCmmTop d info i) where ppr t = pprTop t -instance Outputable i => Outputable (ListGraph i) where +instance (Outputable instr) => Outputable (ListGraph instr) where ppr (ListGraph blocks) = vcat (map ppr blocks) instance (Outputable instr) => Outputable (GenBasicBlock instr) where ppr b = pprBBlock b -instance Outputable BlockId where - ppr id = pprBlockId id - instance Outputable CmmStmt where ppr s = pprStmt s @@ -110,16 +110,16 @@ instance Outputable CmmInfo where ----------------------------------------------------------------------------- -pprCmm :: (Outputable info) => GenCmm CmmStatic info (ListGraph CmmStmt) -> SDoc +pprCmm :: (Outputable info, Outputable g) => GenCmm CmmStatic info g -> SDoc pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable d, Outputable info, Outputable g) - => GenCmmTop d info g -> SDoc +pprTop :: (Outputable d, Outputable info, Outputable i) + => GenCmmTop d info i -> SDoc -pprTop (CmmProc info lbl params graph) +pprTop (CmmProc info lbl params graph ) = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace , nest 8 $ lbrace <+> ppr info $$ rbrace @@ -235,7 +235,7 @@ pprStmt stmt = case stmt of then empty else parens (commafy $ map ppr results) <> ptext SLIT(" = "), - ptext SLIT("call"), space, + ptext SLIT("foreign"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), brackets (ppr safety), @@ -548,6 +548,7 @@ pprSection s = case s of Text -> section <+> doubleQuotes (ptext SLIT("text")) Data -> section <+> doubleQuotes (ptext SLIT("data")) ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly")) + ReadOnlyData16 -> section <+> doubleQuotes (ptext SLIT("readonly16")) RelocatableReadOnlyData -> section <+> doubleQuotes (ptext SLIT("relreadonly")) UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised")) diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 5269e4e..bf4cf3d 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -397,6 +397,9 @@ cgTyCon tycon -- datatype closure table (for enumeration types) -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff -- Note that the closure pointers are tagged. + + -- XXX comment says to put table after constructor decls, but + -- code appears to put it before --- NR 16 Aug 2007 ; extra <- if isEnumerationTyCon tycon then do tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index faa84c2..7b2ee7d 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -80,9 +80,9 @@ import Id import VarEnv import OrdList import Unique -import Util +import Util() import UniqSupply -import FastString +import FastString() import Outputable import Control.Monad @@ -241,6 +241,7 @@ flattenCgStmts id stmts = where (block,blocks) = flatten stmts (CgFork fork_id stmts : ss) -> flatten (CgFork fork_id stmts : CgStmt stmt : ss) + (CgStmt {} : _) -> panic "CgStmt not seen as ordinary" flatten (s:ss) = case s of @@ -711,7 +712,8 @@ labelC :: BlockId -> Code labelC id = emitCgStmt (CgLabel id) newLabelC :: FCode BlockId -newLabelC = do { id <- newUnique; return (BlockId id) } +newLabelC = do { us <- newUniqSupply + ; return $ initUs_ us (freshBlockId "LabelC") } checkedAbsC :: CmmStmt -> Code -- Emit code, eliminating no-ops @@ -758,6 +760,8 @@ emitSimpleProc lbl code getCmm :: Code -> FCode Cmm -- Get all the CmmTops (there should be no stmts) +-- Return a single Cmm which may be split from other Cmms by +-- object splitting (at a later stage) getCmm code = do { state1 <- getState ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 16369ab..cd100e8 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -34,7 +34,6 @@ import CgUtils import CgTicky import ClosureInfo import SMRep -import MachOp import Cmm import CmmUtils import CLabel @@ -227,6 +226,7 @@ performTailCall fun_info arg_amodes pending_assts where --cond1 tag = cmmULtWord tag lowCons -- More efficient than the above? +{- tag_expr = cmmGetClosureType (CmmReg nodeReg) cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0)) cond2 tag = cmmUGtWord tag highCons @@ -234,11 +234,9 @@ performTailCall fun_info arg_amodes pending_assts -- CONSTR highCons = CmmLit (mkIntCLit 8) -- CONSTR_NOCAF_STATIC (from ClosureType.h) +-} -untagCmmAssign (CmmAssign r cmmExpr) = CmmAssign r (cmmUntag cmmExpr) -untagCmmAssign stmt = stmt - directCall sp lbl args extra_args assts = do let -- First chunk of args go in registers @@ -475,3 +473,9 @@ adjustSpAndHp newRealSp ; setRealHp vHp } \end{code} + +Some things are unused. +\begin{code} +_unused :: FS.FastString +_unused = undefined +\end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index ee25300..a53ff49 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -70,6 +70,10 @@ codeGen :: DynFlags -> HpcInfo -> IO [Cmm] -- Output + -- N.B. returning '[Cmm]' and not 'Cmm' here makes it + -- possible for object splitting to split up the + -- pieces later. + codeGen dflags this_mod data_tycons imported_mods cost_centre_info stg_binds hpc_info = do diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index de49e90..0438fb0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -91,7 +91,7 @@ import Data.List ( isPrefixOf ) import Util ( split ) #endif -import Data.Char ( isUpper, toLower ) +import Data.Char ( isUpper ) import System.IO ( hPutStrLn, stderr ) -- ----------------------------------------------------------------------------- @@ -101,10 +101,13 @@ data DynFlag -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_cmmz | Opt_D_dump_cps_cmm + | Opt_D_dump_cvt_cmm | Opt_D_dump_asm | Opt_D_dump_asm_native | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_coalesce | Opt_D_dump_asm_regalloc | Opt_D_dump_asm_regalloc_stages | Opt_D_dump_asm_conflicts @@ -263,6 +266,8 @@ data DynFlag | Opt_BreakOnException | Opt_GenManifest | Opt_EmbedManifest + | Opt_RunCPSZ + | Opt_ConvertToZipCfgAndBack -- keeping stuff | Opt_KeepHiDiffs @@ -1025,12 +1030,15 @@ dynamic_flags = [ , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats)) , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) + , ( "ddump-cmmz", setDumpFlag Opt_D_dump_cmmz) , ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm) + , ( "ddump-cvt-cmm", setDumpFlag Opt_D_dump_cvt_cmm) , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) , ( "ddump-asm-native", setDumpFlag Opt_D_dump_asm_native) , ( "ddump-asm-liveness", setDumpFlag Opt_D_dump_asm_liveness) - , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts) + , ( "ddump-asm-coalesce", setDumpFlag Opt_D_dump_asm_coalesce) , ( "ddump-asm-regalloc", setDumpFlag Opt_D_dump_asm_regalloc) + , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts) , ( "ddump-asm-regalloc-stages", setDumpFlag Opt_D_dump_asm_regalloc_stages) , ( "ddump-asm-stats", setDumpFlag Opt_D_dump_asm_stats) @@ -1181,6 +1189,8 @@ fFlags = [ ( "hpc-no-auto", Opt_Hpc_No_Auto ), ( "rewrite-rules", Opt_RewriteRules ), ( "break-on-exception", Opt_BreakOnException ), + ( "run-cps", Opt_RunCPSZ ), + ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack), ( "vectorise", Opt_Vectorise ), ( "regs-graph", Opt_RegsGraph), -- Deprecated in favour of -XTemplateHaskell: diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 72abafb..0152549 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -5,13 +5,6 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module HscMain ( newHscEnv, hscCmmFile , hscFileCheck @@ -36,7 +29,6 @@ import HsSyn ( Stmt(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) -import CoreSyn ( CoreExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) @@ -54,7 +46,7 @@ import VarEnv ( emptyTidyEnv ) #endif import Var ( Id ) -import Module ( emptyModuleEnv, ModLocation(..) ) +import Module ( emptyModuleEnv, ModLocation(..), Module ) import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, HaddockModInfo ) @@ -72,18 +64,24 @@ import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar ( deSugar ) -import Flattening ( flatten ) import SimplCore ( core2core ) import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) +import StgSyn +import CostCentre import TyCon ( isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) +import Cmm ( Cmm ) import CmmParse ( parseCmmFile ) import CmmCPS +import CmmCPSZ import CmmInfo +import CmmCvt +import CmmTx +import CmmContFlowOpt import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) @@ -99,6 +97,7 @@ import ParserCore import ParserCoreUtils import FastString import UniqFM ( emptyUFM ) +import UniqSupply ( initUs_ ) import Bag ( unitBag ) import Control.Monad @@ -348,7 +347,7 @@ hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary = -------------------------------------------------------------- norecompOneShot :: NoRecomp HscStatus -norecompOneShot old_iface +norecompOneShot _old_iface = do hsc_env <- gets compHscEnv liftIO $ do dumpIfaceStats hsc_env @@ -361,9 +360,9 @@ norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) norecompInteractive = norecompWorker InteractiveNoRecomp True norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) -norecompWorker a isInterp old_iface +norecompWorker a _isInterp old_iface = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary + _mod_summary <- gets compModSummary liftIO $ do new_details <- {-# SCC "tcRnIface" #-} initIfaceCheck hsc_env $ @@ -485,7 +484,7 @@ hscSimplify ds_result hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts) hscSimpleIface ds_result = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary + _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do details <- mkBootModDetails hsc_env ds_result @@ -499,7 +498,7 @@ hscSimpleIface ds_result hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) hscNormalIface simpl_result = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary + _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do ------------------- @@ -540,12 +539,12 @@ hscWriteIface (iface, no_change, details, a) return (iface, details, a) hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) -hscIgnoreIface (iface, no_change, details, a) +hscIgnoreIface (iface, _no_change, details, a) = return (iface, details, a) -- Don't output any code. hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails) -hscNothing (iface, details, a) +hscNothing (iface, details, _) = return (HscRecomp False, iface, details) -- Generate code and return both the new ModIface and the ModDetails. @@ -591,26 +590,32 @@ hscCompile cgguts <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ - abstractC <- {-# SCC "CodeGen" #-} + cmms <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons dir_imps cost_centre_info stg_binds hpc_info - ------------------ Convert to CPS -------------------- - --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm - continuationC <- cmmToRawCmm abstractC + -------- Optionally convert to and from zipper ------ + cmms <- + if dopt Opt_ConvertToZipCfgAndBack dflags + then mapM (testCmmConversion dflags) cmms + else return cmms + ------------ Optionally convert to CPS -------------- + cmms <- + if not (dopt Opt_ConvertToZipCfgAndBack dflags) && + dopt Opt_RunCPSZ dflags + then cmmCPS dflags cmms + else return cmms ------------------ Code output ----------------------- - (stub_h_exists,stub_c_exists) + rawcmms <- cmmToRawCmm cmms + (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs - dependencies continuationC + dependencies rawcmms return stub_c_exists -hscConst :: b -> a -> Comp b -hscConst b a = return b - hscInteractive :: (ModIface, ModDetails, CgGuts) -> Comp (InteractiveStatus, ModIface, ModDetails) -hscInteractive (iface, details, cgguts) #ifdef GHCI +hscInteractive (iface, details, cgguts) = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary liftIO $ do @@ -635,11 +640,11 @@ hscInteractive (iface, details, cgguts) ----------------- Generate byte code ------------------ comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- - (istub_h_exists, istub_c_exists) + (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details) #else - = panic "GHC not compiled with interpreter" +hscInteractive _ = panic "GHC not compiled with interpreter" #endif ------------------------------ @@ -712,7 +717,8 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm + cmm <- testCmmConversion dflags cmm + --continuationC <- cmmCPS dflags cmm >>= cmmToRawCmm continuationC <- cmmToRawCmm [cmm] codeOutput dflags no_mod no_loc NoStubs [] continuationC return True @@ -722,6 +728,24 @@ hscCmmFile dflags filename = do ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } +testCmmConversion :: DynFlags -> Cmm -> IO Cmm +testCmmConversion dflags cmm = + do showPass dflags "CmmToCmm" + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm + us <- mkSplitUniqSupply 'C' + let cfopts = runTx $ runCmmOpts cmmCfgOptsZ + let cvtm = do g <- cmmToZgraph cmm + return $ cfopts g + let zgraph = initUs_ us cvtm + cps_zgraph <- protoCmmCPSZ dflags zgraph + let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + showPass dflags "Convert from Z back to Cmm" + let cvt = cmmOfZgraph $ cfopts $ chosen_graph + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + return cvt + -- return cmm -- don't use the conversion myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer -> IO (Either ErrMsg (Located (HsModule RdrName))) @@ -759,6 +783,10 @@ myParseModule dflags src_filename maybe_src_buf }} +myCoreToStg :: DynFlags -> Module -> [CoreBind] + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + , CollectedCCs) -- cost centre info (declared and used) + myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} @@ -853,7 +881,7 @@ hscTcExpr hsc_env expr Nothing -> return Nothing ; -- Parse error Just (Just (L _ (ExprStmt expr _ _))) -> tcRnExpr hsc_env icontext expr ; - Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; + Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; return Nothing } ; } } @@ -991,6 +1019,7 @@ dumpIfaceStats hsc_env %************************************************************************ \begin{code} +showModuleIndex :: Maybe (Int, Int) -> String showModuleIndex Nothing = "" showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " where diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 8598e7e..0966404 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -35,7 +35,7 @@ import qualified GraphColor as Color import Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms, pprCmm ) +import PprCmm import MachOp import CLabel import State @@ -43,11 +43,11 @@ import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply -import FastTypes import List ( groupBy, sortBy ) -import ErrUtils ( dumpIfSet_dyn ) import DynFlags +#if powerpc_TARGET_ARCH import StaticFlags ( opt_Static, opt_PIC ) +#endif import Util import Config ( cProjectVersion ) import Module @@ -445,6 +445,9 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- output the block, then if it has an out edge, we move the -- destination of the out edge to the front of the list, and continue. +-- FYI, the classic layout for basic blocks uses postorder DFS; this +-- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007). + sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] sequenceBlocks [] = [] sequenceBlocks (entry:blocks) = diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index dd3d029..91f9cdf 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -72,23 +72,19 @@ pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) = pprSectionHeader Text $$ - (if not (null info) - then + (if null info then -- blocks guaranteed not null, so label needed + pprLabel lbl + else #if HAVE_SUBSECTIONS_VIA_SYMBOLS pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) - else empty) $$ - (case blocks of - [] -> empty - (BasicBlock _ instrs : rest) -> - (if null info then pprLabel lbl else empty) $$ - -- the first block doesn't get a label: - vcat (map pprInstr instrs) $$ - vcat (map pprBasicBlock rest) - ) + vcat (map pprData info) $$ + pprLabel (entryLblToInfoLbl lbl) + ) $$ + vcat (map pprBasicBlock blocks) + -- ^ Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- If we are using the .subsections_via_symbols directive -- (available on recent versions of Darwin),