CmmProcPoint.hs 4.89 KB
 Ian Lynagh committed Sep 03, 2007 1 ``````{-# OPTIONS -w #-} `````` Ian Lynagh committed Sep 01, 2007 2 3 4 ``````-- 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 `````` Ian Lynagh committed Sep 04, 2007 5 ``````-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings `````` Ian Lynagh committed Sep 01, 2007 6 7 ``````-- for details `````` Michael D. Adams committed May 23, 2007 8 9 10 11 12 13 ``````module CmmProcPoint ( calculateProcPoints ) where #include "HsVersions.h" `````` dias@eecs.harvard.edu committed May 29, 2008 14 ``````import BlockId `````` Michael D. Adams committed May 23, 2007 15 ``````import Cmm `````` Michael D. Adams committed May 24, 2007 16 ``````import CmmBrokenBlock `````` Michael D. Adams committed May 23, 2007 17 18 19 20 21 22 ``````import Dataflow import UniqSet import UniqFM import Panic `````` Michael D. Adams committed Jun 28, 2007 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 ``````-- Determine the proc points for a set of basic blocks. -- -- A proc point is any basic block that must start a new function. -- The entry block of the original function is a proc point. -- The continuation of a function call is also a proc point. -- The third kind of proc point arises when there is a joint point -- in the control flow. Suppose we have code like the following: -- -- if (...) { ...; call foo(); ...} -- else { ...; call bar(); ...} -- x = y; -- -- That last statement "x = y" must be a proc point because -- it can be reached by blocks owned by different proc points -- (the two branches of the conditional). -- -- We calculate these proc points by starting with the minimal set -- and finding blocks that are reachable from more proc points than -- one of their parents. (This ensures we don't choose a block -- simply beause it is reachable from another block that is reachable -- from multiple proc points.) These new blocks are added to the -- set of proc points and the process is repeated until there -- are no more proc points to be found. `````` Michael D. Adams committed May 23, 2007 46 47 `````` calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId `````` Michael D. Adams committed Jun 27, 2007 48 49 ``````calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks `````` Michael D. Adams committed May 23, 2007 50 51 52 53 54 `````` where init_proc_points = mkUniqSet \$ map brokenBlockId \$ filter always_proc_point blocks always_proc_point BrokenBlock { `````` Michael D. Adams committed Jun 27, 2007 55 `````` brokenBlockEntry = FunctionEntry _ _ _ } = True `````` Michael D. Adams committed May 23, 2007 56 `````` always_proc_point BrokenBlock { `````` Michael D. Adams committed Jul 02, 2007 57 `````` brokenBlockEntry = ContinuationEntry _ _ _ } = True `````` Michael D. Adams committed May 23, 2007 58 59 60 61 62 63 64 65 66 67 68 69 `````` always_proc_point _ = False calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId calculateProcPoints' old_proc_points blocks = if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points then old_proc_points else calculateProcPoints' new_proc_points blocks where blocks_ufm :: BlockEnv BrokenBlock blocks_ufm = blocksToBlockEnv blocks owners = calculateOwnership blocks_ufm old_proc_points blocks `````` Michael D. Adams committed Jun 28, 2007 70 71 72 73 `````` new_proc_points = unionManyUniqSets (old_proc_points: map (calculateNewProcPoints owners) blocks) `````` Michael D. Adams committed May 23, 2007 74 `````` `````` Michael D. Adams committed Jun 28, 2007 75 76 77 78 79 ``````calculateNewProcPoints :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId calculateNewProcPoints owners block = unionManyUniqSets (map (maybe_proc_point parent_id) child_ids) `````` Michael D. Adams committed May 23, 2007 80 81 82 `````` where parent_id = brokenBlockId block child_ids = brokenBlockTargets block `````` Michael D. Adams committed Jun 28, 2007 83 `````` maybe_proc_point parent_id child_id = `````` Michael D. Adams committed May 23, 2007 84 85 86 87 `````` if needs_proc_point then unitUniqSet child_id else emptyUniqSet where `````` dias@eecs.harvard.edu committed Oct 13, 2008 88 89 `````` parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id `````` Michael D. Adams committed Jul 15, 2007 90 91 92 93 94 95 `````` needs_proc_point = -- only if parent isn't dead (not \$ isEmptyUniqSet parent_owners) && -- and only if child has more owners than parent (not \$ isEmptyUniqSet \$ child_owners `minusUniqSet` parent_owners) `````` Michael D. Adams committed Jun 28, 2007 96 97 98 99 100 101 `````` calculateOwnership :: BlockEnv BrokenBlock -> UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId) calculateOwnership blocks_ufm proc_points blocks = `````` dias@eecs.harvard.edu committed Oct 13, 2008 102 `````` fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv `````` Michael D. Adams committed Jun 28, 2007 103 104 105 `````` where dependants :: BlockId -> [BlockId] dependants ident = `````` dias@eecs.harvard.edu committed Oct 13, 2008 106 `````` brokenBlockTargets \$ lookupWithDefaultBEnv `````` Michael D. Adams committed Jun 28, 2007 107 108 109 110 111 112 113 114 115 `````` blocks_ufm unknown_block ident update :: BlockId -> Maybe BlockId -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId)) update ident cause owners = case (cause, ident `elementOfUniqSet` proc_points) of (Nothing, True) -> `````` dias@eecs.harvard.edu committed Oct 13, 2008 116 `````` Just \$ extendBlockEnv owners ident (unitUniqSet ident) `````` Michael D. Adams committed Jun 28, 2007 117 118 119 120 121 `````` (Nothing, False) -> Nothing (Just cause', True) -> Nothing (Just cause', False) -> if (sizeUniqSet old) == (sizeUniqSet new) then Nothing `````` dias@eecs.harvard.edu committed Oct 13, 2008 122 `````` else Just \$ extendBlockEnv owners ident new `````` Michael D. Adams committed Jun 28, 2007 123 `````` where `````` dias@eecs.harvard.edu committed Oct 13, 2008 124 `````` old = lookupWithDefaultBEnv owners emptyUniqSet ident `````` Michael D. Adams committed Jun 28, 2007 125 `````` new = old `unionUniqSets` `````` dias@eecs.harvard.edu committed Oct 13, 2008 126 `````` lookupWithDefaultBEnv owners emptyUniqSet cause' `````` Michael D. Adams committed Jun 28, 2007 127 `````` `````` Michael D. Adams committed Jul 03, 2007 128 `` unknown_block = panic "unknown BlockId in calculateOwnership"``