-- ToDo: save/restore volatile registers around calls.
+{-# OPTIONS_GHC -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/WorkingConventions#Warnings
+-- for details
+
module PprC (
writeCs,
pprStringInCStyle
import CLabel
import MachOp
import ForeignCall
+import ClosureInfo
-- Utils
import DynFlags
-- import Debug.Trace
#endif
-#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
-#endif
import Control.Monad.ST
#if x86_64_TARGET_ARCH
-- --------------------------------------------------------------------------
-- 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 :: RawCmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
then pprDataExterns info $$
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args volatile ->
+ CmmCall (CmmCallee fn cconv) results args safety _ret ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args volatile
+ pprCall ppr_fn cconv results args safety
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
- _other -> parens (cCast (pprCFunType cconv results args) fn)
+ _ -> parens (cCast (pprCFunType cconv results args) fn)
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args volatile ->
- pprCall ppr_fn CCallConv results args volatile
+ 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 -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
pprCFunType cconv ress args
= hcat [
res_type ress,
]
where
res_type [] = ptext SLIT("void")
- res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+ res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
-> 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 ->
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
+pprStatics (CmmStaticLit (CmmInt i rep) : rest)
+ | machRepByteWidth rep /= wORD_SIZE
+ = panic "pprStatics: cannot emit a non-word-sized static literal"
pprStatics (CmmStaticLit lit : rest)
= pprLit1 lit : pprStatics rest
pprStatics (other : 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
GCFun -> ptext SLIT("stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> SDoc
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
+ -> SDoc
-pprCall ppr_fn cconv results args vols
+pprCall ppr_fn cconv results args _
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
| otherwise
- = save vols $$
- ptext SLIT("CALLER_SAVE_SYSTEM") $$
+ =
#if x86_64_TARGET_ARCH
-- HACK around gcc optimisations.
-- x86_64 needs a __DISCARD__() here, to create a barrier between
then ptext SLIT("__DISCARD__();")
else empty) $$
#endif
- ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
- ptext SLIT("CALLER_RESTORE_SYSTEM") $$
- restore vols
+ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
- ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
- | Just ty <- strangeRegType reg
- = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
- -- BaseReg is special, sometimes it isn't an lvalue and we
- -- can't assign to it.
ppr_assign [(one,hint)] rhs
- | Just ty <- strangeRegType one
- = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
- | otherwise
- = pprReg one <> ptext SLIT(" = ")
- <> pprUnHint hint (cmmRegRep one) <> rhs
+ = pprLocalReg one <> ptext SLIT(" = ")
+ <> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
pprUnHint SignedHint rep = parens (machRepCType rep)
pprUnHint _ _ = empty
- save = save_restore SLIT("CALLER_SAVE")
- restore = save_restore SLIT("CALLER_RESTORE")
-
- -- Nothing says "I don't know what's live; save everything"
- -- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
- save_restore txt Nothing = ptext txt <> ptext SLIT("_USER")
- save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
- where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r
-
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
VanillaReg n -> char 'R' <> int n -- without the .w suffix
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _uniq rep)
+pprTempDecl l@(LocalReg _ rep _)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
| 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_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
| machRepByteWidth F64 == wORD_SIZE = False
| otherwise = panic "big_doubles"
-#if __GLASGOW_HASKELL__ >= 504
-newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
-newFloatArray = newArray_
-
-newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
-newDoubleArray = newArray_
-
castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
castFloatToIntArray = castSTUArray
castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
castDoubleToIntArray = castSTUArray
-writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
-writeFloatArray = writeArray
-
-writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
-writeDoubleArray = writeArray
-
-readIntArray :: STUArray s Int Int -> Int -> ST s Int
-readIntArray = readArray
-
-#else
-
-castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castFloatToIntArray = return
-
-castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
-castDoubleToIntArray = return
-
-#endif
-
-- floats are always 1 word
floatToWord :: Rational -> CmmLit
floatToWord r
= runST (do
- arr <- newFloatArray ((0::Int),0)
- writeFloatArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 (fromRational r)
arr' <- castFloatToIntArray arr
- i <- readIntArray arr' 0
+ i <- readArray arr' 0
return (CmmInt (toInteger i) wordRep)
)
doubleToWords r
| big_doubles -- doubles are 2 words
= runST (do
- arr <- newDoubleArray ((0::Int),1)
- writeDoubleArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
- i1 <- readIntArray arr' 0
- i2 <- readIntArray arr' 1
+ i1 <- readArray arr' 0
+ i2 <- readArray arr' 1
return [ CmmInt (toInteger i1) wordRep
, CmmInt (toInteger i2) wordRep
]
)
| otherwise -- doubles are 1 word
= runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 (fromRational r)
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
- i <- readIntArray arr' 0
+ i <- readArray arr' 0
return [ CmmInt (toInteger i) wordRep ]
)
projects / ghc-hetmet.git / blobdiff