diff options
| author | dias@eecs.harvard.edu <unknown> | 2008-10-14 16:03:54 +0000 |
|---|---|---|
| committer | dias@eecs.harvard.edu <unknown> | 2008-10-14 16:03:54 +0000 |
| commit | e13a12b7b217ecea358f4dd853d27ffa44d161c8 (patch) | |
| tree | 9cfee4901c875030623cec974f986899beeb5426 | |
| parent | e367ebeb97b97bc2732202bcfabbbde63f1ec5cd (diff) | |
| download | haskell-e13a12b7b217ecea358f4dd853d27ffa44d161c8.tar.gz | |
Removed space and time inefficiency in procpoint splitting
I was adding extra jumps to every procpoint, even when the split-off graph
referred to only some of the procpoints. No effect on correctness,
but a big effect on space/time efficiency when there are lots of procpoints...
| -rw-r--r-- | compiler/cmm/CmmCPSZ.hs | 6 | ||||
| -rw-r--r-- | compiler/cmm/CmmProcPointZ.hs | 20 |
2 files changed, 21 insertions, 5 deletions
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 7db4eed073..03051f7575 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -43,7 +43,7 @@ import StaticFlags -- The SRT needs to be threaded because it is grown lazily. protoCmmCPSZ :: HscEnv -- Compilation env including -- dynamic flags: -dcmm-lint -ddump-cps-cmm - -> (TopSRT, [CmmZ]) -- SRT table and + -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs -> CmmZ -- Input C-- with Procedures -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) @@ -110,8 +110,8 @@ cpsTop hsc_env (CmmProc h l args g) = -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... procPointMap <- run $ procPointAnalysis procPoints g - gs <- pprTrace "procPointMap" (ppr procPointMap) $ - run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap + dump Opt_D_dump_cmmz "procpoint map" procPointMap + gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap (CmmProc h l args g) mapM (dump Opt_D_dump_cmmz "after splitting") gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 7cf477ab0d..58c63cb7e5 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -423,8 +423,22 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l return (extendBlockEnv env pp bid, b : bs) add_jumps (newGraphEnv) (ppId, blockEnv) = - do (jumpEnv, jumpBlocks) <- - foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels) + do let needed_jumps = -- find which procpoints we currently branch to + foldBlockEnv' add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp block rst = + case last (unzip block) of + LastOther (LastBranch id) -> add_if_pp id rst + LastOther (LastCondBranch _ ti fi) -> + add_if_pp ti (add_if_pp fi rst) + LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl) + _ -> rst + add_if_pp id rst = case lookupFM procLabels id of + Just x -> (id, x) : rst + Nothing -> rst + -- fmToList procLabels + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (emptyBlockEnv, []) needed_jumps + -- update the entry block let (b_off, b) = -- get the stack offset on entry into the block and -- remove the offset from the block (it goes in new graph) case lookupBlockEnv blockEnv ppId of -- get the procpoint block @@ -434,8 +448,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap Nothing -> panic "couldn't find entry block while splitting" blockEnv' = extendBlockEnv blockEnv ppId b off = if ppId == entry then e_off else b_off + -- replace branches to procpoints with branches to jumps LGraph _ _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId off blockEnv' + -- add the jump blocks to the graph blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks let g' = LGraph ppId off blockEnv''' pprTrace "g' pre jumps" (ppr g') $ |