    module CmmProcPoint (
      calculateProcPoints
      ) where

    #include "HsVersions.h"

    import BlockId
    import CmmBrokenBlock
    import Dataflow

    import UniqSet
    import Panic

    -- 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.

    calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
    calculateProcPoints blocks =
        calculateProcPoints' init_proc_points blocks
        where
          init_proc_points = mkUniqSet $
                             map brokenBlockId $
                             filter always_proc_point blocks
          always_proc_point BrokenBlock {
                                  brokenBlockEntry = FunctionEntry _ _ _ } = True
          always_proc_point BrokenBlock {
                                  brokenBlockEntry = ContinuationEntry _ _ _ } = True
          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
          new_proc_points =
              unionManyUniqSets
                (old_proc_points:
                 map (calculateNewProcPoints owners) blocks)

    calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
                           -> BrokenBlock
                           -> UniqSet BlockId
    calculateNewProcPoints  owners block =
        unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
        where
          parent_id = brokenBlockId block
          child_ids = brokenBlockTargets block
          maybe_proc_point parent_id child_id =
              if needs_proc_point
                then unitUniqSet child_id
                else emptyUniqSet
              where
                parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
                child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
                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)

    calculateOwnership :: BlockEnv BrokenBlock
                       -> UniqSet BlockId
                       -> [BrokenBlock]
                       -> BlockEnv (UniqSet BlockId)
    calculateOwnership blocks_ufm proc_points blocks =
        fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
        where
          dependants :: BlockId -> [BlockId]
          dependants ident =
              brokenBlockTargets $ lookupWithDefaultBEnv
                                     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) ->
                    Just $ extendBlockEnv owners ident (unitUniqSet ident)
                (Nothing, False) -> Nothing
                (Just _,      True) -> Nothing
                (Just cause', False) ->
                    if (sizeUniqSet old) == (sizeUniqSet new)
                       then Nothing
                       else Just $ extendBlockEnv owners ident new
                    where
                      old = lookupWithDefaultBEnv owners emptyUniqSet ident
                      new = old `unionUniqSets`
                            lookupWithDefaultBEnv owners emptyUniqSet cause'

          unknown_block = panic "unknown BlockId in calculateOwnership"