X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=3ee3738e7b9bb8e5e4cc47b9eb4236ee5c7e1143;hb=e239aa2329416a2822fcc03c4ed486c7d28739e1;hp=3db1be51ebb5519524e9d5e3bda9e9d17e8e7d9d;hpb=93d047a1096571b75d9911536aecaca547a6f947;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 3db1be5..3ee3738 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
@@ -192,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
 
@@ -209,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)
 
@@ -217,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
@@ -225,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 ->