+ --ZTail (CopyIn c' fs' _) _ ->
+ -- if c == c' && fs == fs' then b
+ -- else panic ("mismatched protocols for block " ++ show id)
+ _ -> Block id -- (ZTail (CopyIn c fs NoC_SRT) t)
+ $ foldr ZTail t (copyIn c area fs)
+ maybe_insert_CopyIns b = b
+
+-- | Add a CopyOut node before each procpoint.
+-- If the predecessor is a call, then the CopyOut should already exist (in the callee).
+
+add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
+ FuelMonad (BlockEnv CmmBlock)
+add_CopyOuts protos procPoints g = fold_blocks maybe_insert_CopyOut (return emptyBlockEnv) g
+ where maybe_insert_CopyOut :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
+ FuelMonad (BlockEnv CmmBlock)
+ maybe_insert_CopyOut b@(Block bid _) blocks | bid == lg_entry g = skip b blocks
+ maybe_insert_CopyOut b blocks =
+ case last $ unzip b of
+ LastOther (LastCall _ _) -> skip b blocks -- copy out done by callee
+ _ -> maybe_insert_CopyOut' b blocks
+ maybe_insert_CopyOut' b blocks = fold_succs trySucc b init >>= finish
+ where init = blocks >>= (\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 $ copyOut c area $ map fetch fs
+ -- CopyOut c $ map fetch fs
+ else z
+ fetch k = k {kindlessCmm = CmmReg $ CmmLocal $ kindlessCmm k}
+ insert z succId m =
+ do (b, bmap) <- z
+ (b, bs) <- insertBetween b m succId
+ 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)
+
+
+
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- If you want to duplicate blocks, do it before this gets called.
+splitAtProcPoints :: CmmFormalsWithoutKinds -> CLabel -> ProcPointSet ->
+ CmmGraph -> FuelMonad [CmmGraph]
+splitAtProcPoints formals entry_label procPoints g@(LGraph entry _) =
+ do let layout = layout_stack formals g
+ pprTrace "stack layout" (ppr layout) $ return ()
+ res <- procPointAnalysis procPoints g
+ procMap <- liftM zdfFpFacts res
+ let addBlock b@(Block bid _) graphEnv =
+ case lookupBlockEnv procMap bid of
+ Just ProcPoint -> add graphEnv bid bid b
+ Just (ReachedBy set) ->
+ case uniqSetToList set of
+ [] -> graphEnv
+ [id] -> add graphEnv id bid b
+ _ -> panic "Each block should be reachable from only one ProcPoint"
+ Nothing -> panic "block not reached by a proc point?"
+ 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
+ let add_label map pp = clabel pp >>= (\l -> return $ (pp, l) : map)
+ clabel procPoint = if procPoint == entry then return entry_label
+ else getUniqueM >>= return . to_label
+ to_label u = mkEntryLabel (mkFCallName u "procpoint")
+ procLabels <- foldM add_label [] (uniqSetToList procPoints)
+ -- 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 (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