{-# LANGUAGE PatternGuards #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest
tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest
tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out 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)")
+ mid m@(MidAddToContext {}) = pcomment (ppr m)
+ 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')
last id prev' out l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
- LastBranch _ (_:_) -> panic "unrepresentable branch"
- LastBranch tgt [] ->
+ LastBranch tgt ->
case n of
G.Block id' t : bs
| tgt == id', unique_pred id'
tail id (CmmCondBranch e' fid : prev') Nothing 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
+ LastJump expr -> endblock $ with_out out $ CmmJump expr
+ LastReturn -> endblock $ with_out out $ CmmReturn
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e cont
| Just (conv, args) <- out
in tail id (delayed : call : prev') Nothing t bs
| otherwise -> panic "unrepairable call"
| otherwise -> panic "call with no CopyOut"
+ with_out (Just (_conv, actuals)) f = f actuals
+ with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f [])
findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
findCopyIn (G.ZTail _ t) = findCopyIn t
findCopyIn (G.ZLast _) = panic "missing CopyIn after call"