Add some more generic (en|de)code(Double|Float) code

[ghc-hetmet.git] / compiler / cmm / PprC.hs

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index c7d0cf1..8a2da23 100644 (file)
--- 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