X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=9f284c8926cdc3c9a57766c97e67b25cfb60bb8d;hp=374058f4be869c49435e481bc7b0f1813e421196;hb=f96194794bf099020706c3816d1a5678b40addbb;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 374058f..9f284c8 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -49,6 +49,8 @@ import UniqFM
 import FastString
 import Outputable
 import Constants
+import BasicTypes
+import CLabel
 
 -- The rest
 import Data.List
@@ -90,7 +92,7 @@ writeCs dflags handle cmms
 --
 
 pprC :: RawCmm -> SDoc
-pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
 
 --
 -- top level procs
@@ -105,7 +107,7 @@ pprTop (CmmProc info clbl _params (ListGraph blocks)) =
         [] -> empty
          -- the first block doesn't get a label:
         (BasicBlock _ stmts : rest) -> vcat [
-	   text "",
+	   blankLine,
 	   extern_decls,
            (if (externallyVisibleCLabel clbl)
                     then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
@@ -143,8 +145,9 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) =
 -- Floating info table for safe a foreign call.
 pprTop top@(CmmData _section d@(_ : _))
   | CmmDataLabel lbl : lits <- reverse d = 
-  pprDataExterns lits $$
-  pprWordArray lbl lits  
+  let lits' = reverse lits
+  in pprDataExterns lits' $$
+     pprWordArray lbl lits'
 
 -- these shouldn't appear?
 pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
@@ -191,7 +194,11 @@ pprStmt :: CmmStmt -> SDoc
 
 pprStmt stmt = case stmt of
     CmmNop       -> empty
-    CmmComment s -> (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
+    CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
+                          -- XXX if the string contains "*/", we need to fix it
+                          -- XXX we probably want to emit these comments when
+                          -- some debugging option is on.  They can get quite
+                          -- large.
 
     CmmAssign dest src -> pprAssign dest src
 
@@ -208,7 +215,7 @@ pprStmt stmt = case stmt of
 
     CmmCall (CmmCallee fn cconv) results args safety ret ->
         maybe_proto $$
-	pprCall ppr_fn cconv results args safety
+	fnCall
 	where
         cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
 
@@ -216,7 +223,7 @@ pprStmt stmt = case stmt of
                         pprCFunType (pprCLabel lbl) cconv results args <> 
                         noreturn_attr <> semi
 
-        data_proto lbl = ptext (sLit ";EI_(") <> 
+        fun_proto lbl = ptext (sLit ";EF_(") <>
                          pprCLabel lbl <> char ')' <> semi
 
         noreturn_attr = case ret of
@@ -224,26 +231,30 @@ pprStmt stmt = case stmt of
                           CmmMayReturn    -> empty
 
         -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
-    	(maybe_proto, ppr_fn) = 
+    	(maybe_proto, fnCall) = 
             case fn of
 	      CmmLit (CmmLabel lbl) 
-                | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl)
+                | StdCallConv <- cconv ->
+                    let myCall = pprCall (pprCLabel lbl) cconv results args safety
+                    in (real_fun_proto lbl, myCall)
                         -- stdcall functions must be declared with
                         -- a function type, otherwise the C compiler
                         -- doesn't add the @n suffix to the label.  We
                         -- can't add the @n suffix ourselves, because
                         -- it isn't valid C.
-                | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl)
-                | not (isMathFun lbl) -> (data_proto lbl, cast_fn)
-                        -- we declare all other called functions as
-                        -- data labels, and then cast them to the
-                        -- right type when calling.  This is because
-                        -- the label might already have a declaration
-                        -- as a data label in the same file,
-                        -- e.g. Foreign.Marshal.Alloc declares 'free'
-                        -- as both a data label and a function label.
+                | CmmNeverReturns <- ret ->
+                    let myCall = pprCall (pprCLabel lbl) cconv results args safety
+                    in (real_fun_proto lbl, myCall)
+                | not (isMathFun lbl) ->
+                    let myCall = braces (
+                                     pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+                                  $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+                                  $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
+                                 )
+                    in (fun_proto lbl, myCall)
 	      _ -> 
-                   (empty {- no proto -}, cast_fn)
+                   (empty {- no proto -},
+                    pprCall cast_fn cconv results args safety <> semi)
 			-- for a dynamic call, no declaration is necessary.
 
     CmmCall (CmmPrim op) results args safety _ret ->
@@ -668,22 +679,11 @@ mkFE_ = ptext (sLit "FE_") -- function code end
 
 -- from includes/Stg.h
 --
-mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
+mkC_,mkW_,mkP_ :: SDoc
 
 mkC_  = ptext (sLit "(C_)")        -- StgChar
 mkW_  = ptext (sLit "(W_)")        -- StgWord
 mkP_  = ptext (sLit "(P_)")        -- StgWord*
-mkPP_ = ptext (sLit "(PP_)")       -- P_*
-mkI_  = ptext (sLit "(I_)")        -- StgInt
-mkA_  = ptext (sLit "(A_)")        -- StgAddr
-mkD_  = ptext (sLit "(D_)")        -- const StgWord*
-mkF_  = ptext (sLit "(F_)")        -- StgFunPtr
-mkB_  = ptext (sLit "(B_)")        -- StgByteArray
-mkL_  = ptext (sLit "(L_)")        -- StgClosurePtr
-
-mkLI_ = ptext (sLit "(LI_)")       -- StgInt64
-mkLW_ = ptext (sLit "(LW_)")       -- StgWord64
-
 
 -- ---------------------------------------------------------------------
 --