summaryrefslogtreecommitdiff
path: root/compiler/cmm/PprCmmZ.hs
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2011-01-24 12:16:50 +0000
committerSimon Marlow <marlowsd@gmail.com>2011-01-24 12:16:50 +0000
commit889c084e943779e76d19f2ef5e970ff655f511eb (patch)
tree56bba8db5c08c72dc1a85ecb2987e6c16c0fd635 /compiler/cmm/PprCmmZ.hs
parentf1a90f54590e5a7a32a9c3ef2950740922b1f425 (diff)
downloadhaskell-889c084e943779e76d19f2ef5e970ff655f511eb.tar.gz
Merge in new code generator branch.
This changes the new code generator to make use of the Hoopl package for dataflow analysis. Hoopl is a new boot package, and is maintained in a separate upstream git repository (as usual, GHC has its own lagging darcs mirror in http://darcs.haskell.org/packages/hoopl). During this merge I squashed recent history into one patch. I tried to rebase, but the history had some internal conflicts of its own which made rebase extremely confusing, so I gave up. The history I squashed was: - Update new codegen to work with latest Hoopl - Add some notes on new code gen to cmm-notes - Enable Hoopl lag package. - Add SPJ note to cmm-notes - Improve GC calls on new code generator. Work in this branch was done by: - Milan Straka <fox@ucw.cz> - John Dias <dias@cs.tufts.edu> - David Terei <davidterei@gmail.com> Edward Z. Yang <ezyang@mit.edu> merged in further changes from GHC HEAD and fixed a few bugs.
Diffstat (limited to 'compiler/cmm/PprCmmZ.hs')
-rw-r--r--compiler/cmm/PprCmmZ.hs88
1 files changed, 0 insertions, 88 deletions
diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
deleted file mode 100644
index 075f0e457b..0000000000
--- a/compiler/cmm/PprCmmZ.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-
-module PprCmmZ
- ( pprCmmGraphLikeCmm
- )
-where
-
-import BlockId
-import Cmm
-import PprCmm
-import Outputable
-import qualified ZipCfgCmmRep as G
-import qualified ZipCfg as Z
-import CmmZipUtil
-
-import Data.Maybe
-import FastString
-
-----------------------------------------------------------------
--- | The purpose of this function is to print a Cmm zipper graph "as if it were"
--- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
--- code are dodgy as well.
-
-pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc
-pprCmmGraphLikeCmm g = vcat (swallow blocks)
- where blocks = Z.postorder_dfs g
- swallow :: [G.CmmBlock] -> [SDoc]
- swallow [] = []
- swallow (Z.Block id t : rest) = tail id [] Nothing t rest
- tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
- tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
- tail id prev' _ (Z.ZLast Z.LastExit) rest = exit id prev' rest
- mid m = ppr m
- block' id prev'
- | id == Z.lg_entry g, entry_has_no_pred =
- vcat (text "<entry>" : reverse prev')
- | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
- last id prev' out l n =
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case l of
- G.LastBranch tgt ->
- case n of
- Z.Block id' t : bs
- | tgt == id', unique_pred id'
- -> tail id prev' out t bs -- optimize out redundant labels
- _ -> endblock (ppr $ CmmBranch tgt)
- l@(G.LastCondBranch expr tid fid) ->
- let ft id = text "// fall through to " <> ppr id in
- case n of
- Z.Block id' t : bs
- | id' == fid, isNothing out ->
- tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
- | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
- tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
- _ -> endblock $ with_out out l
- l@(G.LastSwitch {}) -> endblock $ with_out out l
- l@(G.LastCall _ _ _ _ _) -> endblock $ with_out out l
- exit id prev' n = -- highly irregular (assertion violation?)
- let endblock stmt = block' id (stmt : prev') : swallow n in
- endblock (text "// <exit>")
- preds = zipPreds g
- entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
- Nothing -> True
- Just s -> isEmptyBlockSet s
- single_preds =
- let add b single =
- let id = Z.blockId b
- in case lookupBlockEnv preds id of
- Nothing -> single
- Just s -> if sizeBlockSet s == 1 then
- extendBlockSet single id
- else single
- in Z.fold_blocks add emptyBlockSet g
- unique_pred id = elemBlockSet id single_preds
-
-with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
-with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
-with_out (Just (conv, args)) l = last l
- where last (G.LastCall e k _ _ _) =
- hcat [ptext (sLit "... = foreign "),
- doubleQuotes(ppr conv), space,
- ppr_target e, parens ( commafy $ map ppr args ),
- ptext (sLit " \"safe\""),
- text " returns to " <+> ppr k,
- semi ]
- last l = ppr l
- ppr_target (CmmLit lit) = pprLit lit
- ppr_target fn' = parens (ppr fn')
- commafy xs = hsep $ punctuate comma xs