- let b = Block bid (ZLast (LastOther (LastJump $ CmmLit $ CmmLabel l)))
- return $ (extendBlockEnv env pp bid, b : bs)
- add_jumps newGraphEnv (guniq, blockEnv) =
- do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) procLabels
- let ppId = mkBlockId guniq
- LGraph _ blockEnv' = replaceLabelsZ jumpEnv $ LGraph ppId blockEnv
- blockEnv'' = foldl (flip insertBlock) blockEnv' jumpBlocks
- return $ extendBlockEnv newGraphEnv ppId $
- runTx cmmCfgOptsZ $ LGraph ppId blockEnv''
- _ <- return $ replaceLabelsZ
- graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv
- return $ pprTrace "procLabels" (ppr procLabels) $
- pprTrace "splitting graphs" (ppr graphEnv) $ [g]
-
-------------------------------------------------------------------------
--- Stack Layout (completely bogus for now) --
-------------------------------------------------------------------------
-
--- At some point, we'll do stack layout properly.
--- But for now, we can move forward on generating code by just producing
--- a brain dead layout, giving a separate slot to every variable,
--- and (incorrectly) assuming that all parameters are passed on the stack.
-
--- For now, variables are placed at explicit offsets from a virtual
--- frame pointer.
--- We may want to use abstract stack slots at some point.
-data Placement = VFPMinus Int
-
-instance Outputable Placement where
- ppr (VFPMinus k) = text "VFP - " <> int k
-
--- Build a map from registers to stack locations.
--- Return that map along with the offset to the end of the block
--- containing local registers.
-layout_stack ::CmmFormalsWithoutKinds -> CmmGraph ->
- (Int, FiniteMap LocalReg Placement, FiniteMap LocalReg Placement)
-layout_stack formals g = (ix', incomingMap, localMap)
- where (ix, incomingMap) = foldl (flip place) (1, emptyFM) formals -- IGNORES CC'S
- -- 1 leaves space for the return infotable
- (ix', localMap) = foldUniqSet place (ix, emptyFM) regs
- place r (ix, map) = (ix', addToFM map r $ VFPMinus ix') where ix' = ix + 1
- regs = fold_blocks (fold_fwd_block (\_ y -> y) add addL) emptyRegSet g
- add x y = foldRegsDefd extendRegSet y x
- addL (LastOther l) z = add l z
- addL LastExit z = z
-
+ 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]