+ Just _ -> protos
+ Nothing -> let live = emptyRegSet
+ --lookupBlockEnv _liveness id `orElse`
+ --panic ("no liveness at block " ++ show id)
+ formals = uniqSetToList live
+ prot = Protocol Private formals $ CallArea $ Young id
+ in extendBlockEnv protos id prot
+
+
+-- | Add copy-in instructions to each proc point that did not arise from a call
+-- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
+
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock ->
+ FuelMonad [[CmmBlock]]
+add_CopyIns callPPs protos blocks =
+ liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
+ where maybe_insert_CopyIns (_, b@(Block id t))
+ | not $ elemBlockSet id callPPs
+ = case lookupBlockEnv protos id of
+ Just (Protocol c fs _area) ->
+ do LGraph _ blocks <-
+ lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
+ return (map snd $ blockEnvToList blocks)
+ Nothing -> return [b]
+ | otherwise = return [b]
+
+-- | Add a CopyOut node before each procpoint.
+-- If the predecessor is a call, then the copy outs should already be done by the callee.
+-- Note: If we need to add copy-out instructions, they may require stack space,
+-- so we accumulate a map from the successors to the necessary stack space,
+-- then update the successors after we have finished inserting the copy-outs.
+
+add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
+ FuelMonad (BlockEnv CmmBlock)
+add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g
+ where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
+ FuelMonad (BlockEnv CmmBlock)
+ mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z
+ mb_copy_out b z =
+ case last $ unzip b of
+ LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee
+ _ -> copy_out b z
+ copy_out b z = fold_succs trySucc b init >>= finish
+ where init = z >>= (\bmap -> return (b, bmap))
+ trySucc succId z =
+ if elemBlockSet succId procPoints then
+ case lookupBlockEnv protos succId of
+ Nothing -> z
+ Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
+ else z
+ insert z succId m =
+ do (b, bmap) <- z
+ (b, bs) <- insertBetween b m succId
+ -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
+ return $ (b, foldl (flip insertBlock) bmap bs)
+ finish (b@(Block bid _), bmap) =
+ return $ (extendBlockEnv bmap bid b)
+ skip b@(Block bid _) bs =
+ bs >>= (\bmap -> return (extendBlockEnv bmap bid b))
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+-- the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
+ CmmTopZ -> FuelMonad [CmmTopZ]
+splitAtProcPoints entry_label callPPs procPoints procMap
+ (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
+ (stackInfo, g@(LGraph entry blocks))) =
+ do -- Build a map from procpoints to the blocks they reach
+ let addBlock b@(Block bid _) graphEnv =
+ case lookupBlockEnv procMap bid of
+ Just ProcPoint -> add graphEnv bid bid b
+ Just (ReachedBy set) ->
+ case blockSetToList set of
+ [] -> graphEnv
+ [id] -> add graphEnv id bid b
+ _ -> panic "Each block should be reachable from only one ProcPoint"
+ Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
+ add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
+ where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
+ graph' = extendBlockEnv graph bid b
+ graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
+ -- Build a map from proc point BlockId to labels for their new procedures
+ -- Due to common blockification, we may overestimate the set of procpoints.
+ let add_label map pp = return $ addToFM map pp lbl
+ where lbl = if pp == entry then entry_label else blockLbl pp
+ procLabels <- foldM add_label emptyFM
+ (filter (elemBlockEnv blocks) (blockSetToList procPoints))
+ -- For each procpoint, we need to know the SP offset on entry.
+ -- If the procpoint is:
+ -- - continuation of a call, the SP offset is in the call
+ -- - otherwise, 0 -- no overflow for passing those variables
+ let add_sp_off b env =
+ case last (unzip b) of
+ LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off,
+ cml_ret_off = updfr_off}) ->
+ extendBlockEnv env succ (off, updfr_off)
+ _ -> env
+ spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g
+ getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing)
+ -- In each new graph, add blocks jumping off to the new procedures,
+ -- and replace branches to procpoints with branches to the jump-off blocks
+ let add_jump_block (env, bs) (pp, l) =
+ do bid <- liftM mkBlockId getUniqueM
+ let b = Block bid (ZLast (LastOther jump))
+ (argSpace, _) = getStackInfo pp
+ jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing
+ l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
+ return (extendBlockEnv env pp bid, b : bs)
+ add_jumps (newGraphEnv) (ppId, blockEnv) =
+ 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
+ (jumpEnv, jumpBlocks) <-
+ foldM add_jump_block (emptyBlockEnv, []) needed_jumps
+ -- update the entry block
+ let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
+ off = getStackInfo ppId
+ blockEnv' = extendBlockEnv blockEnv ppId b
+ -- replace branches to procpoints with branches to jumps
+ LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
+ -- add the jump blocks to the graph
+ blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+ let g' = (off, LGraph ppId blockEnv''')
+ -- pprTrace "g' pre jumps" (ppr g') $ do
+ return (extendBlockEnv newGraphEnv ppId g')
+ graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
+ let to_proc (bid, g) | elemBlockSet bid callPPs =
+ if bid == entry then
+ CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
+ else
+ CmmProc emptyContInfoTable lbl [] (replacePPIds g)
+ where lbl = expectJust "pp label" $ lookupFM procLabels bid
+ to_proc (bid, g) =
+ CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
+ where lbl = expectJust "pp label" $ lookupFM procLabels bid
+ -- References to procpoint IDs can now be replaced with the infotable's label
+ replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
+ where repl e@(CmmLit (CmmBlock bid)) =
+ case lookupFM procLabels bid of
+ Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+ Nothing -> e
+ repl e = e
+ -- The C back end expects to see return continuations before the call sites.
+ -- Here, we sort them in reverse order -- it gets reversed later.
+ let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
+ add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i)
+ sort_fn (bid, _) (bid', _) =
+ compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
+ (expectJust "block_order" $ lookupBlockEnv block_order bid')
+ procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
+ return -- pprTrace "procLabels" (ppr procLabels)
+ -- pprTrace "splitting graphs" (ppr procs)
+ procs
+splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]