+-- --------------------------------------------------------------------------
+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 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 (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 ) ]
+