Commit 16a2f6a8 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

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 <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * diagnostic assistance in case fromJust fails

    M ./compiler/nativeGen/MachCodeGen.hs -2 +5

Thu Aug 23 14:07:28 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * clean up the code in PprMach

    M ./compiler/nativeGen/PprMach.hs -16 +14

Fri Aug 24 19:35:03 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * 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 <nr@eecs.harvard.edu>
  * fix a warning about an import

    M ./compiler/nativeGen/RegAllocColor.hs -1 +1
parent 5fccc856
......@@ -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
......
This diff is collapsed.
......@@ -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 (
......
......@@ -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
......@@ -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
......
......@@ -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
......@@ -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"
......
......@@ -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"))
......
......@@ -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
......
......@@ -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 })
......
......@@ -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}
......@@ -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
......
......@@ -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:
......
......@@ -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)