X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=8a2da2343ba9cc6ac7ffe3adf66e22100a39732b;hb=4f92da533cd1c7b5f41ef8794ee6a284f1680413;hp=c7d0cf16c11977b784ee44eb5cdd908f9efc1ced;hpb=e5d9aaa2b7b717c862651f8eea5e2dc66f0a8028;p=ghc-hetmet.git

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index c7d0cf1..8a2da23 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -16,6 +16,8 @@
 --
 -- Print Cmm as real C, for -fvia-C
 --
+-- See wiki:Commentary/Compiler/Backends/PprC
+--
 -- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
 -- relative to the old AbstractC, and many oddities/decorations have
 -- disappeared from the data type.
@@ -54,11 +56,6 @@ import Data.Char
 import System.IO
 import Data.Word
 
-#ifdef DEBUG
-import PprCmm		() -- instances only
--- import Debug.Trace
-#endif
-
 import Data.Array.ST
 import Control.Monad.ST
 
@@ -206,25 +203,25 @@ pprStmt stmt = case stmt of
 	  rep = cmmExprRep src
 
     CmmCall (CmmCallee fn cconv) results args safety _ret ->
-	-- Controversial: leave this out for now.
-	-- pprUndef fn $$
-
+        maybe_proto $$
 	pprCall ppr_fn cconv results args safety
 	where
-    	ppr_fn = case fn of
-		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
-		   _ -> parens (cCast (pprCFunType cconv results args) fn)
-			-- for a dynamic call, cast the expression to
-			-- a function of the right type (we hope).
-
-	-- we #undef a function before calling it: the FFI is supposed to be
-	-- an interface specifically to C, not to C+CPP.  For one thing, this
-	-- makes the via-C route more compatible with the NCG.  If macros
-	-- are being used for optimisation, then inline functions are probably
-	-- better anyway.
-	pprUndef (CmmLit (CmmLabel lbl)) = 
-	   ptext SLIT("#undef") <+> pprCLabel lbl
-	pprUndef _ = empty
+        ppr_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+
+        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
+    	maybe_proto = 
+            case fn of
+	      CmmLit (CmmLabel lbl) | not (isMathFun lbl) -> 
+                  ptext SLIT(";EI_(") <+> pprCLabel lbl <> char ')' <> semi
+                        -- we declare all 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.
+	      _ -> 
+                   empty {- no proto -}
+			-- for a dynamic call, no declaration is necessary.
 
     CmmCall (CmmPrim op) results args safety _ret ->
 	pprCall ppr_fn CCallConv results args safety
@@ -236,18 +233,16 @@ pprStmt stmt = case stmt of
     CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
     CmmSwitch arg ids        -> pprSwitch arg ids
 
-pprCFunType :: CCallConv -> CmmFormals -> CmmActuals -> SDoc
-pprCFunType cconv ress args
-  = hcat [
-	res_type ress,
-	parens (text (ccallConvAttribute cconv) <>  char '*'),
-	parens (commafy (map arg_type args))
-   ]
+pprCFunType :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> SDoc
+pprCFunType ppr_fn cconv ress args
+  = res_type ress <+>
+    parens (text (ccallConvAttribute cconv) <>  ppr_fn) <>
+    parens (commafy (map arg_type args))
   where
 	res_type [] = ptext SLIT("void")
-	res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
+	res_type [CmmHinted one hint] = machRepHintCType (localRegRep one) hint
 
-	arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
+	arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprRep expr) hint
 
 -- ---------------------------------------------------------------------
 -- unconditional branches
@@ -755,18 +750,17 @@ pprCall ppr_fn cconv results args _
     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
   where 
      ppr_assign []           rhs = rhs
-     ppr_assign [(one,hint)] rhs
+     ppr_assign [CmmHinted one hint] rhs
 	 = pprLocalReg one <> ptext SLIT(" = ")
 		 <> pprUnHint hint (localRegRep one) <> rhs
      ppr_assign _other _rhs = panic "pprCall: multiple results"
 
-     pprArg (expr, PtrHint)
-   	= cCast (ptext SLIT("void *")) expr
+     pprArg (CmmHinted expr hint)
+         | hint `elem` [PtrHint,SignedHint]
+         = cCast (machRepHintCType (cmmExprRep expr) hint) expr
 	-- see comment by machRepHintCType below
-     pprArg (expr, SignedHint)
-	= cCast (machRepSignedCType (cmmExprRep expr)) expr
-     pprArg (expr, _other)
-	= pprExpr expr
+     pprArg (CmmHinted expr _other)
+         = pprExpr expr
 
      pprUnHint PtrHint    rep = parens (machRepCType rep)
      pprUnHint SignedHint rep = parens (machRepCType rep)
@@ -788,7 +782,7 @@ is_cish StdCallConv = True
 -- 
 pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts 
-  = (vcat (map pprTempDecl (eltsUFM temps)), 
+  = (vcat (map pprTempDecl (uniqSetToList temps)), 
      vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
   where (temps, lbls) = runTE (mapM_ te_BB stmts)
 
@@ -849,8 +843,8 @@ te_Lit _ = return ()
 te_Stmt :: CmmStmt -> TE ()
 te_Stmt (CmmAssign r e)		= te_Reg r >> te_Expr e
 te_Stmt (CmmStore l r)		= te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es _ _)	= mapM_ (te_temp.fst) rs >>
-				  mapM_ (te_Expr.fst) es
+te_Stmt (CmmCall _ rs es _ _)	= mapM_ (te_temp.hintlessCmm) rs >>
+				  mapM_ (te_Expr.hintlessCmm) es
 te_Stmt (CmmCondBranch e _)	= te_Expr e
 te_Stmt (CmmSwitch e _)		= te_Expr e
 te_Stmt (CmmJump e _)		= te_Expr e