-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) $ uniqSetToList 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 (MidNop) = CmmNop
- mid (MidComment s) = CmmComment s
- mid (MidAssign l r) = CmmAssign l r
- mid (MidStore l r) = CmmStore l r
- mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
- mid m@(CopyOut {}) = pcomment (ppr m)
- mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
- pcomment p = scomment $ showSDoc p
- 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 _ (_:_) -> panic "unrepresentable branch"
- LastBranch tgt [] ->
- case n of
- 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
- | 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
- LastJump expr params -> endblock $ CmmJump expr params
- LastReturn params -> endblock $ CmmReturn params
- LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall tgt args Nothing ->
- endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
- LastCall tgt args (Just k)
- | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
- id' == k, unique_pred k ->
- let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
- in tail id (call : prev') t bs
- | G.Block id' t : bs <- n, id' == k, unique_pred k ->
- let (ress, srt) = findCopyIn t
- call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
- delayed = scomment "delayed CopyIn follows previous call"
- in tail id (delayed : call : prev') t bs
- | otherwise -> panic "unrepairable call"
- findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
- findCopyIn (G.ZTail _ t) = findCopyIn t
- findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
- 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 G.lookupBlockEnv preds id of
- Nothing -> single
- Just s -> if sizeUniqSet s == 1 then
- G.extendBlockSet single id
- else single
- in G.fold_blocks add G.emptyBlockSet g
- unique_pred id = G.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
+strip_hints :: [Old.CmmHinted a] -> [a]
+strip_hints = map Old.hintlessCmm
+
+convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget
+convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
+convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
+
+data ValueDirection = Arguments | Results
+
+add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
+add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
+
+get_hints :: Convention -> ValueDirection -> [ForeignHint]
+get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
+get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
+get_hints _other_conv _vd = repeat NoHint
+
+get_conv :: ForeignTarget -> Convention
+get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
+get_conv (ForeignTarget _ fc) = Foreign fc
+
+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