X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprCmm.hs;h=2d3fd6a7465bd3a9e96f6e8f85330de9d8826f5b;hb=1c5499d4d5d506ce0cc971e98c09bfbf7bc290a1;hp=55a8014b46331433b51b0ad05f9406d44a2ab6c2;hpb=f96e9aa0444de0e673b3c4055c6e43299639bc5b;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 55a8014..2d3fd6a 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -117,7 +117,10 @@ pprTop (CmmData section ds) =
     (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
     $$ rbrace
 
-
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+  ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
+  ppr (CmmSafe srt) = ppr srt
 
 -- --------------------------------------------------------------------------
 -- Info tables. The current pretty printer needs refinement
@@ -126,13 +129,19 @@ pprTop (CmmData section ds) =
 -- 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 CmmNonInfo = empty
-pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
-                 gc_target tag info) =
-    vcat [ptext SLIT("type: ") <> pprLit closure_type,
+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("gc_target: ") <>
-                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
           ptext SLIT("tag: ") <> integer (toInteger tag),
           pprTypeInfo info]
 
@@ -140,24 +149,40 @@ 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),
-          ppr descr]
+          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)
-          --ppr args, -- TODO: needs to be printed
-          --ppr slow_entry -- TODO: needs to be printed
+          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 ) ]
+
+
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 
@@ -187,7 +212,7 @@ pprStmt stmt = case stmt of
 
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
-    CmmCall (CmmForeignCall fn cconv) results args srt ->
+    CmmCall (CmmCallee fn cconv) results args safety ->
         hcat [ if null results
                   then empty
                   else parens (commafy $ map ppr results) <>
@@ -195,14 +220,14 @@ pprStmt stmt = case stmt of
                ptext SLIT("call"), space, 
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
-               brackets (ppr srt), semi ]
+               brackets (ppr safety), semi ]
         where
             target (CmmLit lit) = pprLit lit
             target fn'          = parens (ppr fn')
 
-    CmmCall (CmmPrim op) results args srt ->
-        pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
-                        results args srt)
+    CmmCall (CmmPrim op) results args safety ->
+        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+                        results args safety)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)