import ForeignCall
-- Utils
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import Unique ( getUnique )
import UniqSet
import FiniteMap
import FastString
import Outputable
import Constants
-import CmdLineOpts ( opt_EnsureSplittableC )
-- The rest
-import Data.List ( intersperse, group )
+import Data.List ( intersperse, groupBy )
import Data.Bits ( shiftR )
import Char ( ord, chr )
import IO ( Handle )
import DATA_BITS
+import Data.Word ( Word8 )
#ifdef DEBUG
import PprCmm () -- instances only
-- --------------------------------------------------------------------------
-- Top level
-pprCs :: [Cmm] -> SDoc
-pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
-
-writeCs :: Handle -> [Cmm] -> IO ()
-writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms)
- -- ToDo: should be printForC
+pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs dflags cmms
+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
+ where
+ split_marker
+ | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
+ | otherwise = empty
-split_marker
- | opt_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER")
- | otherwise = empty
+writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs dflags handle cmms
+ = printForC handle (pprCs dflags cmms)
-- --------------------------------------------------------------------------
-- Now do some real work
pprTop :: CmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
- then pprWordArray (entryLblToInfoLbl clbl) info
+ then pprDataExterns info $$
+ pprWordArray (entryLblToInfoLbl clbl) info
else empty) $$
(case blocks of
[] -> empty
CmmAssign dest src -> pprAssign dest src
CmmStore dest src
- | rep == I64
+ | rep == I64 && wordRep /= I64
-> ptext SLIT("ASSIGN_Word64") <>
parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+ | rep == F64 && wordRep /= I64
+ -> ptext SLIT("ASSIGN_DBL") <>
+ parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
| otherwise
-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
where
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
- _other -> parens (cCast (pprCFunType results args) fn)
+ _other -> parens (cCast (pprCFunType cconv results args) fn)
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
-pprCFunType ress args =
- res_type ress <> parens (char '*') <> parens (commafy (map arg_type args))
+pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType cconv ress args
+ = hcat [
+ res_type ress,
+ parens (text (ccallConvAttribute cconv) <> char '*'),
+ parens (commafy (map arg_type args))
+ ]
where
res_type [] = ptext SLIT("void")
res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
--
pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
pprSwitch e maybe_ids
- = let ids = [ i | Just i <- maybe_ids ]
- pairs = zip [ 0 .. ] (concatMap markfalls (group ids))
+ = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
+ pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
in
(hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
- 4 (vcat ( map caseify pairs )))
+ 4 (vcat ( map caseify pairs2 )))
$$ rbrace
where
- -- fall through case
- caseify (i,Left ident) =
- hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
- ptext SLIT("/* fall through for"),
- pprBlockId ident,
- ptext SLIT("*/") ]
-
- caseify (i,Right ident) =
- hsep [ ptext SLIT("case") , pprHexVal i <> colon ,
- ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+ sndEq (_,x) (_,y) = x == y
- -- mark the bottom of a fallthough sequence of cases as `Right'
- markfalls [a] = [Right a]
- markfalls as = map (\a -> Left a) (init as) ++ [Right (last as)]
+ -- fall through case
+ caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+ where
+ do_fallthrough ix =
+ hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
+ ptext SLIT("/* fall through */") ]
+ final_branch ix =
+ hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
+ ptext SLIT("goto") , (pprBlockId ident) <> semi ]
-- ---------------------------------------------------------------------
-- Expressions.
pprExpr e = case e of
CmmLit lit -> pprLit lit
- CmmLoad e I64
+ CmmLoad e I64 | wordRep /= I64
-> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)
+ CmmLoad e F64 | wordRep /= I64
+ -> ptext SLIT("PK_DBL") <> parens (mkP_ <> pprExpr1 e)
+
CmmLoad (CmmReg r) rep
| isPtrReg r && rep == wordRep
-> char '*' <> pprAsPtrReg r
pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
- CmmInt i _rep -> pprHexVal i
+ CmmInt i rep -> pprHexVal i rep
CmmFloat f rep -> parens (machRepCType rep) <> (rational f)
- CmmLabel clbl -> mkW_ <> pprCLabel clbl
- CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
+ CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
+ CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
+ CmmLabelDiffOff clbl1 clbl2 i
+ -- WARNING:
+ -- * the lit must occur in the info table clbl2
+ -- * clbl1 must be an SRT, a slow entry point or a large bitmap
+ -- The Mangler is expected to convert any reference to an SRT,
+ -- a slow entry point or a large bitmap
+ -- from an info table to an offset.
+ -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+pprCLabelAddr lbl = char '&' <> pprCLabel lbl
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
pprLit1 other = pprLit other
MO_F64_Cosh -> ptext SLIT("cosh")
MO_F64_Tanh -> ptext SLIT("tanh")
MO_F64_Asin -> ptext SLIT("asin")
- MO_F64_Acos -> ptext SLIT("asin")
+ MO_F64_Acos -> ptext SLIT("acos")
MO_F64_Atan -> ptext SLIT("atan")
MO_F64_Log -> ptext SLIT("log")
MO_F64_Exp -> ptext SLIT("exp")
MO_F64_Sqrt -> ptext SLIT("sqrt")
- MO_F32_Pwr -> ptext SLIT("pow")
- MO_F32_Sin -> ptext SLIT("sin")
- MO_F32_Cos -> ptext SLIT("cos")
- MO_F32_Tan -> ptext SLIT("tan")
- MO_F32_Sinh -> ptext SLIT("sinh")
- MO_F32_Cosh -> ptext SLIT("cosh")
- MO_F32_Tanh -> ptext SLIT("tanh")
- MO_F32_Asin -> ptext SLIT("asin")
- MO_F32_Acos -> ptext SLIT("acos")
- MO_F32_Atan -> ptext SLIT("atan")
- MO_F32_Log -> ptext SLIT("log")
- MO_F32_Exp -> ptext SLIT("exp")
- MO_F32_Sqrt -> ptext SLIT("sqrt")
+ MO_F32_Pwr -> ptext SLIT("powf")
+ MO_F32_Sin -> ptext SLIT("sinf")
+ MO_F32_Cos -> ptext SLIT("cosf")
+ MO_F32_Tan -> ptext SLIT("tanf")
+ MO_F32_Sinh -> ptext SLIT("sinhf")
+ MO_F32_Cosh -> ptext SLIT("coshf")
+ MO_F32_Tanh -> ptext SLIT("tanhf")
+ MO_F32_Asin -> ptext SLIT("asinf")
+ MO_F32_Acos -> ptext SLIT("acosf")
+ MO_F32_Atan -> ptext SLIT("atanf")
+ MO_F32_Log -> ptext SLIT("logf")
+ MO_F32_Exp -> ptext SLIT("expf")
+ MO_F32_Sqrt -> ptext SLIT("sqrtf")
-- ---------------------------------------------------------------------
-- Useful #defines
isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal CurrentTSO = True
isStrangeTypeGlobal CurrentNursery = True
+isStrangeTypeGlobal BaseReg = True
isStrangeTypeGlobal r = isPtrGlobalReg r
strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
+strangeRegType (CmmGlobal BaseReg) = Just (ptext SLIT("struct StgRegTable_ *"))
strangeRegType _ = Nothing
-- pprReg just prints the register name.
pprCall ppr_fn cconv results args vols
| not (is_cish cconv)
- = panic "pprForeignCall: unknown calling convention"
+ = panic "pprCall: unknown calling convention"
| otherwise
= save vols $$
ptext SLIT("CALLER_SAVE_SYSTEM") $$
- hcat [ ppr_results results, ppr_fn,
- parens (commafy (map pprArg args)), semi ] $$
+ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
ptext SLIT("CALLER_RESTORE_SYSTEM") $$
restore vols
where
- ppr_results [] = empty
- ppr_results [(one,hint)]
- = pprExpr (CmmReg one) <> ptext SLIT(" = ") <> pprUnHint hint
- ppr_results _other = panic "pprCall: multiple results"
+ 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
+ ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
= cCast (ptext SLIT("void *")) expr
pprArg (expr, _other)
= pprExpr expr
- pprUnHint PtrHint = mkW_
- pprUnHint SignedHint = mkW_
- pprUnHint _ = empty
-
+ pprUnHint PtrHint rep = parens (machRepCType rep)
+ pprUnHint SignedHint rep = parens (machRepCType rep)
+ pprUnHint _ _ = empty
+
save = save_restore SLIT("CALLER_SAVE")
restore = save_restore SLIT("CALLER_RESTORE")
VanillaReg n -> char 'R' <> int n -- without the .w suffix
_ -> pprGlobalReg gr
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
is_cish CCallConv = True
is_cish StdCallConv = True
-is_cish _ = False
-- ---------------------------------------------------------------------
-- Find and print local and external declarations for a list of
te_Lit :: CmmLit -> TE ()
te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE ()
te_Expr :: CmmExpr -> TE ()
te_Expr (CmmLit lit) = te_Lit lit
-te_Expr (CmmReg r) = te_Reg r
te_Expr (CmmLoad e _) = te_Expr e
+te_Expr (CmmReg r) = te_Reg r
te_Expr (CmmMachOp _ es) = mapM_ te_Expr es
te_Expr (CmmRegOff r _) = te_Reg r
-te_Expr _ = return ()
te_Reg :: CmmReg -> TE ()
te_Reg (CmmLocal l) = te_temp l
-- ---------------------------------------------------------------------
-- print strings as valid C strings
--- Assumes it contains only characters '\0'..'\xFF'!
-pprFSInCStyle :: FastString -> SDoc
-pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)
-
-pprStringInCStyle :: String -> SDoc
+pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
-charToC :: Char -> String
-charToC '\"' = "\\\""
-charToC '\'' = "\\\'"
-charToC '\\' = "\\\\"
-charToC c | c >= ' ' && c <= '~' = [c]
- | c > '\xFF' = panic ("charToC "++show c)
- | otherwise = ['\\',
+charToC :: Word8 -> String
+charToC w =
+ case chr (fromIntegral w) of
+ '\"' -> "\\\""
+ '\'' -> "\\\'"
+ '\\' -> "\\\\"
+ c | c >= ' ' && c <= '~' -> [c]
+ | otherwise -> ['\\',
chr (ord '0' + ord c `div` 64),
chr (ord '0' + ord c `div` 8 `mod` 8),
chr (ord '0' + ord c `mod` 8)]
-
-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers. We can't
-- just emit the floating point number, because C will cast it to an int
commafy xs = hsep $ punctuate comma xs
-- Print in C hex format: 0x13fa
-pprHexVal :: Integer -> SDoc
-pprHexVal 0 = ptext SLIT("0x0")
-pprHexVal w
- | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w))
- | otherwise = ptext SLIT("0x") <> go w
+pprHexVal :: Integer -> MachRep -> SDoc
+pprHexVal 0 _ = ptext SLIT("0x0")
+pprHexVal w rep
+ | w < 0 = parens (char '-' <> ptext SLIT("0x") <> go (-w) <> repsuffix rep)
+ | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
where
+ -- type suffix for literals:
+ -- Integer literals are unsigned in Cmm/C. We explicitly cast to
+ -- signed values for doing signed operations, but at all other
+ -- times values are unsigned. This also helps eliminate occasional
+ -- warnings about integer overflow from gcc.
+
+ -- on 32-bit platforms, add "ULL" to 64-bit literals
+ repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("ULL")
+ -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
+ repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("UL")
+ repsuffix _ = char 'U'
+
go 0 = empty
go w' = go q <> dig
where
projects / ghc-hetmet.git / blobdiff