import Cmm
import PprCmm () -- Instances only
import CLabel
-import MachOp
import ForeignCall
import ClosureInfo
import FastString
import Outputable
import Constants
+import BasicTypes
+import CLabel
-- The rest
import Data.List
--
pprC :: RawCmm -> SDoc
-pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
--
-- top level procs
[] -> empty
-- the first block doesn't get a label:
(BasicBlock _ stmts : rest) -> vcat [
- text "",
+ blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
pprDataExterns lits $$
pprWordArray lbl lits
+-- Floating info table for safe a foreign call.
+pprTop top@(CmmData _section d@(_ : _))
+ | CmmDataLabel lbl : lits <- reverse d =
+ let lits' = reverse lits
+ in pprDataExterns lits' $$
+ pprWordArray lbl lits'
+
-- these shouldn't appear?
pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
pprStmt stmt = case stmt of
CmmNop -> empty
- CmmComment s -> (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
+ CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
+ -- XXX if the string contains "*/", we need to fix it
+ -- XXX we probably want to emit these comments when
+ -- some debugging option is on. They can get quite
+ -- large.
CmmAssign dest src -> pprAssign dest src
CmmStore dest src
- | 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
+ | typeWidth rep == W64 && wordWidth /= W64
+ -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
+ else ptext (sLit ("ASSIGN_Word64"))) <>
+ parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
| otherwise
-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
where
- rep = cmmExprRep src
+ rep = cmmExprType src
CmmCall (CmmCallee fn cconv) results args safety ret ->
maybe_proto $$
- pprCall ppr_fn cconv results args safety
+ fnCall
where
cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
pprCFunType (pprCLabel lbl) cconv results args <>
noreturn_attr <> semi
- data_proto lbl = ptext (sLit ";EI_(") <>
+ fun_proto lbl = ptext (sLit ";EF_(") <>
pprCLabel lbl <> char ')' <> semi
noreturn_attr = case ret of
CmmMayReturn -> empty
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
- (maybe_proto, ppr_fn) =
+ (maybe_proto, fnCall) =
case fn of
CmmLit (CmmLabel lbl)
- | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl)
+ | StdCallConv <- cconv ->
+ let myCall = pprCall (pprCLabel lbl) cconv results args safety
+ in (real_fun_proto lbl, myCall)
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
- | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl)
- | not (isMathFun lbl) -> (data_proto lbl, cast_fn)
- -- we declare all other 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.
+ | CmmNeverReturns <- ret ->
+ let myCall = pprCall (pprCLabel lbl) cconv results args safety
+ in (real_fun_proto lbl, myCall)
+ | not (isMathFun lbl) ->
+ let myCall = braces (
+ pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+ $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+ $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
+ )
+ in (fun_proto lbl, myCall)
_ ->
- (empty {- no proto -}, cast_fn)
+ (empty {- no proto -},
+ pprCall cast_fn cconv results args safety <> semi)
-- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim op) results args safety _ret ->
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> SDoc
+pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> 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 [CmmKinded one hint] = machRepHintCType (localRegRep one) hint
+ res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
- arg_type (CmmKinded expr hint) = machRepHintCType (cmmExprRep expr) hint
+ arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
-- ---------------------------------------------------------------------
-- unconditional branches
caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
where
do_fallthrough ix =
- hsep [ ptext (sLit "case") , pprHexVal ix wordRep <> colon ,
+ hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
ptext (sLit "/* fall through */") ]
final_branch ix =
- hsep [ ptext (sLit "case") , pprHexVal ix wordRep <> colon ,
+ hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
ptext (sLit "goto") , (pprBlockId ident) <> semi ]
-- ---------------------------------------------------------------------
--
-- has a type in C which is also given by
--
--- machRepCType (cmmExprRep e)
+-- machRepCType (cmmExprType e)
--
-- (similar invariants apply to the rest of the pretty printer).
pprExpr e = case e of
CmmLit lit -> pprLit lit
- 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
-
- CmmLoad (CmmRegOff r 0) rep
- | isPtrReg r && rep == wordRep
- -> char '*' <> pprAsPtrReg r
-
- CmmLoad (CmmRegOff r off) rep
- | 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 ->
- -- the general case:
- cLoad expr rep
+ CmmLoad e ty -> pprLoad e ty
CmmReg reg -> pprCastReg reg
CmmRegOff reg 0 -> pprCastReg reg
CmmMachOp mop args -> pprMachOpApp mop args
+
+pprLoad :: CmmExpr -> CmmType -> SDoc
+pprLoad e ty
+ | width == W64, wordWidth /= W64
+ = (if isFloatType ty then ptext (sLit "PK_DBL")
+ else ptext (sLit "PK_Word64"))
+ <> parens (mkP_ <> pprExpr1 e)
+
+ | otherwise
+ = case e of
+ CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
+ -> char '*' <> pprAsPtrReg r
+
+ CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
+ -> char '*' <> pprAsPtrReg r
+
+ CmmRegOff r off | isPtrReg r && width == wordWidth
+ , off `rem` wORD_SIZE == 0 && not (isFloatType ty)
+ -- 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))
+
+ _other -> cLoad e ty
+ where
+ width = typeWidth ty
+
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmLit lit) = pprLit1 lit
pprExpr1 e@(CmmReg _reg) = pprExpr e
_ -> panic "PprC.pprMachOp : machop with wrong number of args"
where
- pprArg e | signedOp mop = cCast (machRepSignedCType (cmmExprRep e)) e
+ -- Cast needed for signed integer ops
+ pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e
+ | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e
| otherwise = pprExpr1 e
+ needsFCasts (MO_F_Eq _) = False
+ needsFCasts (MO_F_Ne _) = False
+ needsFCasts (MO_F_Neg _) = True
+ needsFCasts (MO_F_Quot _) = True
+ needsFCasts mop = floatComparison mop
-- --------------------------------------------------------------------------
-- Literals
pprLit lit = case lit of
CmmInt i rep -> pprHexVal i rep
- CmmFloat f rep -> parens (machRepCType rep) <> str
+ CmmFloat f w -> parens (machRep_F_CType w) <> str
where d = fromRational f :: Double
str | isInfinite d && d < 0 = ptext (sLit "-INFINITY")
| isInfinite d = ptext (sLit "INFINITY")
-- these constants come from <math.h>
-- see #1861
+ CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+ CmmHighStackMark -> panic "PprC printing high stack mark"
CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
CmmLabelDiffOff clbl1 clbl2 i
pprStatics :: [CmmStatic] -> [SDoc]
pprStatics [] = []
-pprStatics (CmmStaticLit (CmmFloat f F32) : rest)
+pprStatics (CmmStaticLit (CmmFloat f W32) : rest)
-- floats are padded to a word, see #1852
- | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 I32) : rest' <- rest
+ | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : 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)
+ = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitType l)) rest))
+pprStatics (CmmStaticLit (CmmFloat f W64) : rest)
= map pprLit1 (doubleToWords f) ++ pprStatics rest
-pprStatics (CmmStaticLit (CmmInt i I64) : rest)
- | machRepByteWidth I32 == wORD_SIZE
+pprStatics (CmmStaticLit (CmmInt i W64) : rest)
+ | wordWidth == W32
#ifdef WORDS_BIGENDIAN
- = pprStatics (CmmStaticLit (CmmInt q I32) :
- CmmStaticLit (CmmInt r I32) : rest)
+ = pprStatics (CmmStaticLit (CmmInt q W32) :
+ CmmStaticLit (CmmInt r W32) : rest)
#else
- = pprStatics (CmmStaticLit (CmmInt r I32) :
- CmmStaticLit (CmmInt q I32) : rest)
+ = pprStatics (CmmStaticLit (CmmInt r W32) :
+ CmmStaticLit (CmmInt q W32) : rest)
#endif
where r = i .&. 0xffffffff
q = i `shiftR` 32
-pprStatics (CmmStaticLit (CmmInt i rep) : rest)
- | machRepByteWidth rep /= wORD_SIZE
+pprStatics (CmmStaticLit (CmmInt i w) : rest)
+ | w /= wordWidth
= panic "pprStatics: cannot emit a non-word-sized static literal"
pprStatics (CmmStaticLit lit : rest)
= pprLit1 lit : pprStatics rest
MO_U_Quot _ -> char '/'
MO_U_Rem _ -> char '%'
- -- Signed comparisons (floating-point comparisons also use these)
- -- & Unsigned comparisons
+ -- & Floating-point operations
+ MO_F_Add _ -> char '+'
+ MO_F_Sub _ -> char '-'
+ MO_F_Neg _ -> char '-'
+ MO_F_Mul _ -> char '*'
+ MO_F_Quot _ -> char '/'
+
+ -- Signed comparisons
MO_S_Ge _ -> ptext (sLit ">=")
MO_S_Le _ -> ptext (sLit "<=")
MO_S_Gt _ -> char '>'
MO_S_Lt _ -> char '<'
+ -- & Unsigned comparisons
MO_U_Ge _ -> ptext (sLit ">=")
MO_U_Le _ -> ptext (sLit "<=")
MO_U_Gt _ -> char '>'
MO_U_Lt _ -> char '<'
+ -- & Floating-point comparisons
+ MO_F_Eq _ -> ptext (sLit "==")
+ MO_F_Ne _ -> ptext (sLit "!=")
+ MO_F_Ge _ -> ptext (sLit ">=")
+ MO_F_Le _ -> ptext (sLit "<=")
+ MO_F_Gt _ -> char '>'
+ MO_F_Lt _ -> char '<'
+
-- Bitwise operations. Not all of these may be supported at all
-- sizes, and only integral MachReps are valid.
MO_And _ -> char '&'
MO_U_Shr _ -> ptext (sLit ">>") -- unsigned shift right
MO_S_Shr _ -> ptext (sLit ">>") -- signed shift right
--- Conversions. Some of these will be NOPs.
+-- Conversions. Some of these will be NOPs, but never those that convert
+-- between ints and floats.
-- Floating-point conversions use the signed variant.
-- We won't know to generate (void*) casts here, but maybe from
-- context elsewhere
-- noop casts
- MO_U_Conv I8 I8 -> empty
- MO_U_Conv I16 I16 -> empty
- MO_U_Conv I32 I32 -> empty
- MO_U_Conv I64 I64 -> empty
- MO_U_Conv I128 I128 -> empty
- MO_S_Conv I8 I8 -> empty
- MO_S_Conv I16 I16 -> empty
- MO_S_Conv I32 I32 -> empty
- MO_S_Conv I64 I64 -> empty
- MO_S_Conv I128 I128 -> empty
-
- MO_U_Conv _from to -> parens (machRepCType to)
- MO_S_Conv _from to -> parens (machRepSignedCType to)
-
- _ -> panic "PprC.pprMachOp_for_C: unknown machop"
-
-signedOp :: MachOp -> Bool
+ MO_UU_Conv from to | from == to -> empty
+ MO_UU_Conv _from to -> parens (machRep_U_CType to)
+
+ MO_SS_Conv from to | from == to -> empty
+ MO_SS_Conv _from to -> parens (machRep_S_CType to)
+
+ -- TEMPORARY: the old code didn't check this case, so let's leave it out
+ -- to facilitate comparisons against the old output code.
+ --MO_FF_Conv from to | from == to -> empty
+ MO_FF_Conv _from to -> parens (machRep_F_CType to)
+
+ MO_SF_Conv _from to -> parens (machRep_F_CType to)
+ MO_FS_Conv _from to -> parens (machRep_S_CType to)
+
+ _ -> pprTrace "offending mop" (ptext $ sLit $ show mop) $
+ panic "PprC.pprMachOp_for_C: unknown machop"
+
+signedOp :: MachOp -> Bool -- Argument type(s) are signed ints
signedOp (MO_S_Quot _) = True
signedOp (MO_S_Rem _) = True
signedOp (MO_S_Neg _) = True
signedOp (MO_S_Gt _) = True
signedOp (MO_S_Lt _) = True
signedOp (MO_S_Shr _) = True
-signedOp (MO_S_Conv _ _) = True
+signedOp (MO_SS_Conv _ _) = True
+signedOp (MO_SF_Conv _ _) = True
signedOp _ = False
+floatComparison :: MachOp -> Bool -- comparison between float args
+floatComparison (MO_F_Eq _) = True
+floatComparison (MO_F_Ne _) = True
+floatComparison (MO_F_Ge _) = True
+floatComparison (MO_F_Le _) = True
+floatComparison (MO_F_Gt _) = True
+floatComparison (MO_F_Lt _) = True
+floatComparison _ = False
+
-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls
-- from includes/Stg.h
--
-mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
+mkC_,mkW_,mkP_ :: SDoc
mkC_ = ptext (sLit "(C_)") -- StgChar
mkW_ = ptext (sLit "(W_)") -- StgWord
mkP_ = ptext (sLit "(P_)") -- StgWord*
-mkPP_ = ptext (sLit "(PP_)") -- P_*
-mkI_ = ptext (sLit "(I_)") -- StgInt
-mkA_ = ptext (sLit "(A_)") -- StgAddr
-mkD_ = ptext (sLit "(D_)") -- const StgWord*
-mkF_ = ptext (sLit "(F_)") -- StgFunPtr
-mkB_ = ptext (sLit "(B_)") -- StgByteArray
-mkL_ = ptext (sLit "(L_)") -- StgClosurePtr
-
-mkLI_ = ptext (sLit "(LI_)") -- StgInt64
-mkLW_ = ptext (sLit "(LW_)") -- StgWord64
-
-- ---------------------------------------------------------------------
--
isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
isPtrReg :: CmmReg -> Bool
isPtrReg (CmmLocal _) = False
-isPtrReg (CmmGlobal (VanillaReg n)) = True -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg
isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg
-- True if this global reg has type StgPtr
isFixedPtrGlobalReg _ = False
-- True if in C this register doesn't have the type given by
--- (machRepCType (cmmRegRep reg)), so it has to be cast.
+-- (machRepCType (cmmRegType reg)), so it has to be cast.
isStrangeTypeReg :: CmmReg -> Bool
isStrangeTypeReg (CmmLocal _) = False
isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
CmmGlobal global -> pprGlobalReg global
pprAsPtrReg :: CmmReg -> SDoc
-pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext (sLit ".p")
+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
+ = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
pprAsPtrReg other_reg = pprReg other_reg
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
- VanillaReg n -> char 'R' <> int n <> ptext (sLit ".w")
+ VanillaReg n _ -> char 'R' <> int n <> ptext (sLit ".w")
+ -- pprGlobalReg prints a VanillaReg as a .w regardless
+ -- Example: R1.w = R1.w & (-0x8UL);
+ -- JMP_(*R1.p);
FloatReg n -> char 'F' <> int n
DoubleReg n -> char 'D' <> int n
LongReg n -> char 'L' <> int n
CurrentNursery -> ptext (sLit "CurrentNursery")
HpAlloc -> ptext (sLit "HpAlloc")
BaseReg -> ptext (sLit "BaseReg")
+ EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
GCEnter1 -> ptext (sLit "stg_gc_enter_1")
GCFun -> ptext (sLit "stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> CmmSafety
+pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> 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 [CmmKinded one hint] rhs
+ ppr_assign [CmmHinted one hint] rhs
= pprLocalReg one <> ptext (sLit " = ")
- <> pprUnHint hint (localRegRep one) <> rhs
+ <> pprUnHint hint (localRegType one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
- pprArg (CmmKinded expr hint)
- | hint `elem` [PtrHint,SignedHint]
- = cCast (machRepHintCType (cmmExprRep expr) hint) expr
+ pprArg (CmmHinted expr AddrHint)
+ = cCast (ptext (sLit "void *")) expr
-- see comment by machRepHintCType below
- pprArg (CmmKinded expr _other)
- = pprExpr expr
+ pprArg (CmmHinted expr SignedHint)
+ = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
+ pprArg (CmmHinted expr _other)
+ = pprExpr expr
- pprUnHint PtrHint rep = parens (machRepCType rep)
+ pprUnHint AddrHint rep = parens (machRepCType rep)
pprUnHint SignedHint rep = parens (machRepCType rep)
pprUnHint _ _ = empty
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
- VanillaReg n -> char 'R' <> int n -- without the .w suffix
- _ -> pprGlobalReg gr
+ 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...
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _ rep _)
+pprTempDecl l@(LocalReg _ rep)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
| not (needsCDecl lbl) = empty
| Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
| otherwise =
- hcat [ visibility, label_type (labelType lbl),
+ hcat [ visibility, label_type lbl,
lparen, pprCLabel lbl, text ");" ]
where
- label_type CodeLabel = ptext (sLit "F_")
- label_type DataLabel = ptext (sLit "I_")
+ label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
+ | otherwise = ptext (sLit "I_")
visibility
| externallyVisibleCLabel lbl = char 'E'
-- add the @n suffix to the label (#2276)
stdcall_decl sz =
ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel lbl
- <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRepCType wordRep)))
+ <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
<> semi
type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
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.kindlessCmm) rs >>
- mapM_ (te_Expr.kindlessCmm) 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
cCast :: SDoc -> CmmExpr -> SDoc
cCast ty expr = parens ty <> pprExpr1 expr
-cLoad :: CmmExpr -> MachRep -> SDoc
+cLoad :: CmmExpr -> CmmType -> SDoc
#ifdef BEWARE_LOAD_STORE_ALIGNMENT
cLoad expr rep =
let decl = machRepCType rep <+> ptext (sLit "x") <> semi
cLoad expr rep = char '*' <> parens (cCast (machRepPtrCType rep) expr)
#endif
+isCmmWordType :: CmmType -> Bool
+-- True of GcPtrReg/NonGcReg of native word size
+isCmmWordType ty = not (isFloatType ty)
+ && typeWidth ty == wordWidth
+
-- This is for finding the types of foreign call arguments. For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
-machRepHintCType :: MachRep -> MachHint -> SDoc
-machRepHintCType rep PtrHint = ptext (sLit "void *")
-machRepHintCType rep SignedHint = machRepSignedCType rep
+machRepHintCType :: CmmType -> ForeignHint -> SDoc
+machRepHintCType rep AddrHint = ptext (sLit "void *")
+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
machRepHintCType rep _other = machRepCType rep
-machRepPtrCType :: MachRep -> SDoc
-machRepPtrCType r | r == wordRep = ptext (sLit "P_")
- | otherwise = machRepCType r <> char '*'
-
-machRepCType :: MachRep -> SDoc
-machRepCType r | r == wordRep = ptext (sLit "W_")
- | otherwise = sized_type
- where sized_type = case r of
- I8 -> ptext (sLit "StgWord8")
- I16 -> ptext (sLit "StgWord16")
- I32 -> ptext (sLit "StgWord32")
- I64 -> ptext (sLit "StgWord64")
- F32 -> ptext (sLit "StgFloat") -- ToDo: correct?
- F64 -> ptext (sLit "StgDouble")
- _ -> panic "machRepCType"
-
-machRepSignedCType :: MachRep -> SDoc
-machRepSignedCType r | r == wordRep = ptext (sLit "I_")
- | otherwise = sized_type
- where sized_type = case r of
- I8 -> ptext (sLit "StgInt8")
- I16 -> ptext (sLit "StgInt16")
- I32 -> ptext (sLit "StgInt32")
- I64 -> ptext (sLit "StgInt64")
- F32 -> ptext (sLit "StgFloat") -- ToDo: correct?
- F64 -> ptext (sLit "StgDouble")
- _ -> panic "machRepCType"
+machRepPtrCType :: CmmType -> SDoc
+machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
+ | otherwise = machRepCType r <> char '*'
+
+machRepCType :: CmmType -> SDoc
+machRepCType ty | isFloatType ty = machRep_F_CType w
+ | otherwise = machRep_U_CType w
+ where
+ w = typeWidth ty
+
+machRep_F_CType :: Width -> SDoc
+machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
+machRep_F_CType W64 = ptext (sLit "StgDouble")
+machRep_F_CType _ = panic "machRep_F_CType"
+
+machRep_U_CType :: Width -> SDoc
+machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
+machRep_U_CType W8 = ptext (sLit "StgWord8")
+machRep_U_CType W16 = ptext (sLit "StgWord16")
+machRep_U_CType W32 = ptext (sLit "StgWord32")
+machRep_U_CType W64 = ptext (sLit "StgWord64")
+machRep_U_CType _ = panic "machRep_U_CType"
+
+machRep_S_CType :: Width -> SDoc
+machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
+machRep_S_CType W8 = ptext (sLit "StgInt8")
+machRep_S_CType W16 = ptext (sLit "StgInt16")
+machRep_S_CType W32 = ptext (sLit "StgInt32")
+machRep_S_CType W64 = ptext (sLit "StgInt64")
+machRep_S_CType _ = panic "machRep_S_CType"
+
-- ---------------------------------------------------------------------
-- print strings as valid C strings
-- can safely initialise to static locations.
big_doubles
- | machRepByteWidth F64 == 2 * wORD_SIZE = True
- | machRepByteWidth F64 == wORD_SIZE = False
+ | widthInBytes W64 == 2 * wORD_SIZE = True
+ | widthInBytes W64 == wORD_SIZE = False
| otherwise = panic "big_doubles"
castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
writeArray arr 0 (fromRational r)
arr' <- castFloatToIntArray arr
i <- readArray arr' 0
- return (CmmInt (toInteger i) wordRep)
+ return (CmmInt (toInteger i) wordWidth)
)
doubleToWords :: Rational -> [CmmLit]
arr' <- castDoubleToIntArray arr
i1 <- readArray arr' 0
i2 <- readArray arr' 1
- return [ CmmInt (toInteger i1) wordRep
- , CmmInt (toInteger i2) wordRep
+ return [ CmmInt (toInteger i1) wordWidth
+ , CmmInt (toInteger i2) wordWidth
]
)
| otherwise -- doubles are 1 word
writeArray arr 0 (fromRational r)
arr' <- castDoubleToIntArray arr
i <- readArray arr' 0
- return [ CmmInt (toInteger i) wordRep ]
+ return [ CmmInt (toInteger i) wordWidth ]
)
-- ---------------------------------------------------------------------------
-- Utils
wordShift :: Int
-wordShift = machRepLogWidth wordRep
+wordShift = widthInLog wordWidth
commafy :: [SDoc] -> SDoc
commafy xs = hsep $ punctuate comma xs
-- Print in C hex format: 0x13fa
-pprHexVal :: Integer -> MachRep -> SDoc
+pprHexVal :: Integer -> Width -> SDoc
pprHexVal 0 _ = ptext (sLit "0x0")
pprHexVal w rep
| w < 0 = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
-- warnings about integer overflow from gcc.
-- on 32-bit platforms, add "ULL" to 64-bit literals
- repsuffix I64 | wORD_SIZE == 4 = ptext (sLit "ULL")
+ repsuffix W64 | 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 W64 | cINT_SIZE == 4 = ptext (sLit "UL")
repsuffix _ = char 'U'
go 0 = empty
projects / ghc-hetmet.git / blobdiff