+{-# 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 CLabel
import MachOp
import ForeignCall
+import ClosureInfo
-- Utils
import DynFlags
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 ->
+ CmmCall (CmmCallee fn cconv) results args safety _ret ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args
+ pprCall ppr_fn cconv results args safety
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args ->
- pprCall ppr_fn CCallConv results args
+ 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 :: CCallConv -> CmmFormals -> CmmActuals -> SDoc
pprCFunType cconv ress args
= hcat [
res_type ress,
]
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
+pprCall :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> CmmSafety
-> SDoc
-pprCall ppr_fn cconv results args
+pprCall ppr_fn cconv results args _
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
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)
+ pprArg (CmmHinted expr PtrHint)
= cCast (ptext SLIT("void *")) expr
-- see comment by machRepHintCType below
- pprArg (expr, SignedHint)
+ pprArg (CmmHinted expr SignedHint)
= cCast (machRepSignedCType (cmmExprRep expr)) expr
- pprArg (expr, _other)
+ pprArg (CmmHinted expr _other)
= pprExpr expr
pprUnHint PtrHint 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
projects / ghc-hetmet.git / blobdiff