+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+ ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
+ ppr (CmmSafe srt) = ppr srt
+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- For ideas on how to refine it, they used to be printed in the
+-- style of C--'s 'stackdata' declaration, just inside the proc body,
+-- and were labelled with the procedure name ++ "_info".
+pprInfo :: CmmInfo -> SDoc
+pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
+ vcat [{-ptext (sLit "gc_target: ") <>
+ maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+ ptext (sLit "update_frame: ") <>
+ maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
+pprInfo (CmmInfo _gc_target update_frame
+ (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
+ vcat [{-ptext (sLit "gc_target: ") <>
+ maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+ ptext (sLit "update_frame: ") <>
+ maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
+ ptext (sLit "type: ") <> pprLit closure_type,
+ ptext (sLit "desc: ") <> pprLit closure_desc,
+ ptext (sLit "tag: ") <> integer (toInteger tag),
+ pprTypeInfo info]
+
+pprTypeInfo :: ClosureTypeInfo -> SDoc
+pprTypeInfo (ConstrInfo layout constr descr) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "constructor: ") <> integer (toInteger constr),
+ pprLit descr]
+pprTypeInfo (FunInfo layout srt fun_type arity _args slow_entry) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt,
+ ptext (sLit "fun_type: ") <> integer (toInteger fun_type),
+ ptext (sLit "arity: ") <> integer (toInteger arity),
+ --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
+ ptext (sLit "slow: ") <> pprLit slow_entry
+ ]
+pprTypeInfo (ThunkInfo layout srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ThunkSelectorInfo offset srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ContInfo stack srt) =
+ vcat [ptext (sLit "stack: ") <> ppr stack,
+ ptext (sLit "srt: ") <> ppr srt]
+
+pprUpdateFrame :: UpdateFrame -> SDoc
+pprUpdateFrame (UpdateFrame expr args) =
+ hcat [ ptext (sLit "jump")
+ , space
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else case expr of
+ CmmLoad (CmmReg _) _ -> pprExpr expr
+ _ -> parens (pprExpr expr)
+ , space
+ , parens ( commafy $ map ppr args ) ]
+