+{-# 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
-pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs :: DynFlags -> [RawCmm] -> SDoc
pprCs dflags cmms
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
| dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
-writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
writeCs dflags handle cmms
= printForC handle (pprCs dflags cmms)
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: Cmm -> SDoc
+pprC :: RawCmm -> SDoc
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
--
-- top level procs
--
-pprTop :: CmmTop -> SDoc
-pprTop (CmmProc info clbl _params blocks) =
+pprTop :: RawCmmTop -> SDoc
+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.
--
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args srt ->
- -- Controversial: leave this out for now.
- -- pprUndef fn $$
-
- pprCall ppr_fn cconv results args srt
+ CmmCall (CmmCallee fn cconv) results args safety _ret ->
+ 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
-
- CmmCall (CmmPrim op) results args srt ->
- pprCall ppr_fn CCallConv results args srt
+ 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
where
ppr_fn = pprCallishMachOp_for_C op
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
-> char '*' <> pprAsPtrReg r
CmmLoad (CmmRegOff r off) rep
- | isPtrReg r && rep == wordRep
+ | isPtrReg r && rep == wordRep && (off `rem` wORD_SIZE == 0)
-- ToDo: check that the offset is a word multiple?
+ -- (For tagging to work, I had to avoid unaligned loads. --ARY)
-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
CmmLoad expr rep ->
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)
-- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
pprAssign r1 r2
- | isFixedPtrReg r1
- = pprReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
- | Just ty <- strangeRegType r1
- = pprReg r1 <> ptext SLIT(" = ") <> parens ty <> pprExpr1 r2 <> semi
- | otherwise
- = pprReg r1 <> ptext SLIT(" = ") <> pprExpr r2 <> semi
+ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
+ | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
+ | otherwise = mkAssign (pprExpr r2)
+ where mkAssign x = if r1 == CmmGlobal BaseReg
+ then ptext SLIT("ASSIGN_BaseReg") <> parens x <> semi
+ else pprReg r1 <> ptext SLIT(" = ") <> x <> semi
-- ---------------------------------------------------------------------
-- Registers
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
+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)
| not (needsCDecl lbl) = empty
| otherwise =
hcat [ visibility, label_type (labelType lbl),
- lparen, dyn_wrapper (pprCLabel lbl), text ");" ]
+ lparen, pprCLabel lbl, text ");" ]
where
- dyn_wrapper d
- | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d
- | otherwise = d
-
label_type CodeLabel = ptext SLIT("F_")
label_type DataLabel = ptext SLIT("I_")
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