+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
import System.IO
import Data.Word
-#ifdef DEBUG
-import PprCmm () -- instances only
--- import Debug.Trace
-#endif
-
import Data.Array.ST
import Control.Monad.ST
-- top level procs
--
pprTop :: RawCmmTop -> SDoc
-pprTop (CmmProc info clbl _params blocks) =
+pprTop (CmmProc info clbl _params (ListGraph blocks)) =
(if not (null info)
then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info
-- these shouldn't appear?
pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
-
-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
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)
+
+ 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
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: CCallConv -> CmmHintFormals -> 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
pprStatics :: [CmmStatic] -> [SDoc]
pprStatics [] = []
pprStatics (CmmStaticLit (CmmFloat f F32) : rest)
+ -- floats are padded to a word, see #1852
+ | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 I32) : rest' <- rest
+ = pprLit1 (floatToWord f) : pprStatics rest'
+ | wORD_SIZE == 4
= pprLit1 (floatToWord f) : pprStatics rest
+ | otherwise
+ = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitRep l)) rest))
pprStatics (CmmStaticLit (CmmFloat f F64) : rest)
= map pprLit1 (doubleToWords f) ++ pprStatics rest
pprStatics (CmmStaticLit (CmmInt i I64) : rest)
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
+pprCall :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> CmmSafety
-> SDoc
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)
--
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)
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
projects / ghc-hetmet.git / blobdiff