-cmm_target :: MidCallTarget -> CmmCallTarget
-cmm_target (PrimTarget op) = CmmPrim op
-cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
-
-ofZgraph :: CmmGraph -> ListGraph CmmStmt
-ofZgraph g = ListGraph $ swallow blocks
- where blocks = G.postorder_dfs g
- -- | the next two functions are hooks on which to hang debugging info
- extend_entry stmts = stmts
- extend_block _id stmts = stmts
- _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
- showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
- concat (map (\(G.Block id _) -> " " ++ show id) blocks)
- cscomm = "Call successors are" ++
- (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
- swallow [] = []
- swallow (G.Block id t : rest) = tail id [] t rest
- tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
- tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
- tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
- mid (MidComment s) = CmmComment s
- mid (MidAssign l r) = CmmAssign l r
- mid (MidStore l r) = CmmStore l r
- mid (MidForeignCall _ target ress args)
- = CmmCall (cmm_target target)
- (add_hints conv Results ress)
- (add_hints conv Arguments args)
- CmmUnsafe CmmMayReturn
- where
- conv = get_conv target
- block' id prev'
- | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
- | otherwise = BasicBlock id $ extend_block id (reverse prev')
- last id prev' l n =
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case l of
- LastBranch tgt ->
- case n of
- -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
- --G.Block id' _ t : bs
- -- | tgt == id', unique_pred id'
- -- -> tail id prev' t bs -- optimize out redundant labels
- _ -> endblock (CmmBranch tgt)
- LastCondBranch expr tid fid ->
- case n of
- G.Block id' t : bs
- -- It would be better to handle earlier, but we still must
- -- generate correct code here.
- | id' == fid, tid == fid, unique_pred id' ->
- tail id prev' t bs
- | id' == fid, unique_pred id' ->
- tail id (CmmCondBranch expr tid : prev') t bs
- | id' == tid, unique_pred id',
- Just e' <- maybeInvertCmmExpr expr ->
- tail id (CmmCondBranch e' fid : prev') t bs
- _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
- in block' id instrs' : swallow n
- LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall e _ _ _ _ -> endblock $ CmmJump e []
- exit id prev' n = -- highly irregular (assertion violation?)
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case n of [] -> endblock (scomment "procedure falls off end")
- G.Block id' t : bs ->
- if unique_pred id' then
- tail id (scomment "went thru exit" : prev') t bs
- else
- endblock (CmmBranch id')
- preds = zipPreds g
- single_preds =
- let add b single =
- let id = G.blockId b
- in case lookupBlockEnv preds id of
- Nothing -> single
- Just s -> if sizeBlockSet s == 1 then
- extendBlockSet single id
- else single
- in G.fold_blocks add emptyBlockSet g
- unique_pred id = elemBlockSet id single_preds
- call_succs =
- let add b succs =
- case G.last (G.unzip b) of
- G.LastOther (LastCall _ (Just id) _ _ _) ->
- extendBlockSet succs id
- _ -> succs
- in G.fold_blocks add emptyBlockSet g
- _is_call_succ id = elemBlockSet id call_succs
-
-scomment :: String -> CmmStmt
-scomment s = CmmComment $ mkFastString s
+cmm_target :: ForeignTarget -> Old.CmmCallTarget
+cmm_target (PrimTarget op) = Old.CmmPrim op
+cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
+
+ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
+ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
+ -- We catenated some blocks in the conversion process,
+ -- because of the CmmCondBranch -- the machine code does not have
+ -- 'jump here or there' instruction, but has 'jump if true' instruction.
+ -- As OldCmm has the same instruction, so we use it.
+ -- When we are doing this, we also catenate normal goto-s (it is for free).
+
+ -- Exactly, we catenate blocks with nonentry labes, that are
+ -- a) mentioned exactly once as a successor
+ -- b) any of 1) are a target of a goto
+ -- 2) are false branch target of a conditional jump
+ -- 3) are true branch target of a conditional jump, and
+ -- the false branch target is a successor of at least 2 blocks
+ -- and the condition can be inverted
+ -- The complicated rule 3) is here because we need to assign at most one
+ -- catenable block to a CmmCondBranch.
+ where preds :: BlockEnv [CmmNode O C]
+ preds = mapFold add mapEmpty $ toBlockMap g
+ where add block env = foldr (add' $ lastNode block) env (successors block)
+ add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
+ add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
+
+ to_be_catenated :: BlockId -> Bool
+ to_be_catenated id | id == g_entry g = False
+ | Just [CmmBranch _] <- mapLookup id preds = True
+ | Just [CmmCondBranch _ _ f] <- mapLookup id preds
+ , f == id = True
+ | Just [CmmCondBranch e t f] <- mapLookup id preds
+ , t == id
+ , Just (_:_:_) <- mapLookup f preds
+ , Just _ <- maybeInvertCmmExpr e = True
+ to_be_catenated _ = False
+
+ convert_block block | to_be_catenated (entryLabel block) = Nothing
+ convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
+ where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
+ first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
+
+ middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
+ middle node stmts = stmt : stmts
+ where stmt :: Old.CmmStmt
+ stmt = case node of
+ CmmComment s -> Old.CmmComment s
+ CmmAssign l r -> Old.CmmAssign l r
+ CmmStore l r -> Old.CmmStore l r
+ CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
+ CmmUnsafeForeignCall target ress args ->
+ Old.CmmCall (cmm_target target)
+ (add_hints (get_conv target) Results ress)
+ (add_hints (get_conv target) Arguments args)
+ Old.CmmUnsafe Old.CmmMayReturn
+
+ last :: CmmNode O C -> () -> [Old.CmmStmt]
+ last node _ = stmts
+ where stmts :: [Old.CmmStmt]
+ stmts = case node of
+ CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
+ | otherwise -> [Old.CmmBranch tgt]
+ CmmCondBranch expr tid fid
+ | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
+ | to_be_catenated tid
+ , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
+ | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
+ CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
+ CmmCall e _ _ _ _ -> [Old.CmmJump e []]
+ CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
+ tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
+ Old.BasicBlock _ stmts -> stmts
+ where Just block = mapLookup bid $ toBlockMap g