diff options
Diffstat (limited to 'compiler/GHC/CmmToC.hs')
| -rw-r--r-- | compiler/GHC/CmmToC.hs | 516 |
1 files changed, 265 insertions, 251 deletions
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 7944f6a0fc..71b0793057 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- @@ -68,7 +69,7 @@ import Data.Array.ST -- Top level writeC :: DynFlags -> Handle -> RawCmmGroup -> IO () -writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine) +writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine) -- -------------------------------------------------------------------------- -- Now do some real work @@ -76,57 +77,59 @@ writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine) -- for fun, we could call cmmToCmm over the tops... -- -pprC :: RawCmmGroup -> SDoc -pprC tops = vcat $ intersperse blankLine $ map pprTop tops +pprC :: DynFlags -> RawCmmGroup -> SDoc +pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops -- -- top level procs -- -pprTop :: RawCmmDecl -> SDoc -pprTop (CmmProc infos clbl _in_live_regs graph) = - +pprTop :: DynFlags -> RawCmmDecl -> SDoc +pprTop dflags = \case + (CmmProc infos clbl _in_live_regs graph) -> (case mapLookup (g_entry graph) infos of Nothing -> empty Just (RawCmmStatics info_clbl info_dat) -> - pprDataExterns info_dat $$ - pprWordArray info_is_in_rodata info_clbl info_dat) $$ + pprDataExterns platform info_dat $$ + pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$ (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, nest 8 temp_decls, - vcat (map pprBBlock blocks), + vcat (map (pprBBlock dflags) blocks), rbrace ] ) - where + where -- info tables are always in .rodata info_is_in_rodata = True blocks = toBlockListEntryFirst graph - (temp_decls, extern_decls) = pprTempAndExternDecls blocks + (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks --- Chunks of static data. + -- Chunks of static data. --- We only handle (a) arrays of word-sized things and (b) strings. + -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) = - pprExternDecl lbl $$ - hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, - text "[] = ", pprStringInCStyle str, semi - ] + (CmmData section (RawCmmStatics lbl [CmmString str])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, + text "[] = ", pprStringInCStyle str, semi + ] -pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) = - pprExternDecl lbl $$ - hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, - brackets (int size), semi - ] + (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) -> + pprExternDecl platform lbl $$ + hcat [ + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, + brackets (int size), semi + ] -pprTop (CmmData section (RawCmmStatics lbl lits)) = - pprDataExterns lits $$ - pprWordArray (isSecConstant section) lbl lits + (CmmData section (RawCmmStatics lbl lits)) -> + pprDataExterns platform lits $$ + pprWordArray dflags (isSecConstant section) lbl lits + where + platform = targetPlatform dflags -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -135,10 +138,10 @@ pprTop (CmmData section (RawCmmStatics lbl lits)) = -- as many jumps as possible into fall throughs. -- -pprBBlock :: CmmBlock -> SDoc -pprBBlock block = +pprBBlock :: DynFlags -> CmmBlock -> SDoc +pprBBlock dflags block = nest 4 (pprBlockId (entryLabel block) <> colon) $$ - nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last) + nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last) where (_, nodes, last) = blockSplit block @@ -146,18 +149,19 @@ pprBBlock block = -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc -pprWordArray is_ro lbl ds - = sdocWithDynFlags $ \dflags -> - -- TODO: align closures only - pprExternDecl lbl $$ +pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc +pprWordArray dflags is_ro lbl ds + = -- TODO: align closures only + pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" , space, ppr lbl, text "[]" -- See Note [StgWord alignment] - , pprAlignment (wordWidth dflags) + , pprAlignment (wordWidth platform) , text "= {" ] $$ nest 8 (commafy (pprStatics dflags ds)) $$ text "};" + where + platform = targetPlatform dflags pprAlignment :: Width -> SDoc pprAlignment words = @@ -195,10 +199,9 @@ pprConstness is_ro | is_ro = text "const " -- Statements. -- -pprStmt :: CmmNode e x -> SDoc +pprStmt :: DynFlags -> CmmNode e x -> SDoc -pprStmt stmt = - sdocWithDynFlags $ \dflags -> +pprStmt dflags stmt = case stmt of CmmEntry{} -> empty CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") @@ -213,15 +216,16 @@ pprStmt stmt = CmmAssign dest src -> pprAssign dflags dest src CmmStore dest src - | typeWidth rep == W64 && wordWidth dflags /= W64 + | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" else ptext (sLit ("ASSIGN_Word64"))) <> - parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi + parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi | otherwise - -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] + -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ] where - rep = cmmExprType dflags src + rep = cmmExprType platform src + platform = targetPlatform dflags CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> fnCall @@ -229,28 +233,29 @@ pprStmt stmt = (res_hints, arg_hints) = foreignTargetHints target hresults = zip results res_hints hargs = zip args arg_hints + platform = targetPlatform dflags ForeignConvention cconv _ _ ret = conv - cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) + cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn) -- See wiki:commentary/compiler/backends/ppr-c#prototypes fnCall = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - pprCall (ppr lbl) cconv hresults hargs + pprCall dflags (ppr lbl) cconv hresults hargs -- 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 -> - pprCall cast_fn cconv hresults hargs <> semi + pprCall dflags cast_fn cconv hresults hargs <> semi | not (isMathFun lbl) -> - pprForeignCall (ppr lbl) cconv hresults hargs + pprForeignCall dflags (ppr lbl) cconv hresults hargs _ -> - pprCall cast_fn cconv hresults hargs <> semi + pprCall dflags cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty @@ -273,39 +278,38 @@ pprStmt stmt = -- builtins (see bug #5967). | Just _align <- machOpMemcpyishAlign op = (text ";EFF_(" <> fn <> char ')' <> semi) $$ - pprForeignCall fn cconv hresults hargs + pprForeignCall dflags fn cconv hresults hargs | otherwise - = pprCall fn cconv hresults hargs + = pprCall dflags fn cconv hresults hargs - CmmBranch ident -> pprBranch ident - CmmCondBranch expr yes no _ -> pprCondBranch expr yes no - CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi - CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> - pprSwitch dflags arg ids + CmmBranch ident -> pprBranch ident + CmmCondBranch expr yes no _ -> pprCondBranch dflags expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi + CmmSwitch arg ids -> pprSwitch dflags arg ids _other -> pprPanic "PprC.pprStmt" (ppr stmt) type Hinted a = (a, ForeignHint) -pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] +pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprForeignCall fn cconv results args = fn_call +pprForeignCall dflags fn cconv results args = fn_call where + platform = targetPlatform dflags fn_call = braces ( - pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi + pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall (text "ghcFunPtr") cconv results args <> semi + $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi ) - cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) + cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) -pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCFunType ppr_fn cconv ress args - = sdocWithDynFlags $ \dflags -> - let res_type [] = text "void" - res_type [(one, hint)] = machRepHintCType (localRegType one) hint +pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCFunType platform ppr_fn cconv ress args + = let res_type [] = text "void" + res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" - arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint + arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint in res_type ress <+> parens (ccallConvAttribute cconv <> ppr_fn) <> parens (commafy (map arg_type args)) @@ -318,9 +322,9 @@ pprBranch ident = text "goto" <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels -pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc -pprCondBranch expr yes no - = hsep [ text "if" , parens(pprExpr expr) , +pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch dflags expr yes no + = hsep [ text "if" , parens(pprExpr dflags expr) , text "goto", pprBlockId yes <> semi, text "else goto", pprBlockId no <> semi ] @@ -331,20 +335,21 @@ pprCondBranch expr yes no -- pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc pprSwitch dflags e ids - = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace) + = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace) 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace where (pairs, mbdef) = switchTargetsFallThrough ids + platform = targetPlatform dflags -- fall through case caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , + hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , text "/* fall through */" ] final_branch ix = - hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon , + hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , text "goto" , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" @@ -366,72 +371,73 @@ pprSwitch dflags e ids -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: CmmExpr -> SDoc -pprExpr e = case e of - CmmLit lit -> pprLit lit - - - CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty +pprExpr :: DynFlags -> CmmExpr -> SDoc +pprExpr dflags e = case e of + CmmLit lit -> pprLit dflags lit + CmmLoad e ty -> pprLoad dflags e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add - CmmRegOff reg i -> sdocWithDynFlags $ \dflags -> - pprCastReg reg <> char '+' <> - pprHexVal (fromIntegral i) (wordWidth dflags) + CmmRegOff reg i -> pprCastReg reg <> char '+' <> + pprHexVal dflags (fromIntegral i) (wordWidth platform) - CmmMachOp mop args -> pprMachOpApp mop args + CmmMachOp mop args -> pprMachOpApp dflags mop args CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + where + platform = targetPlatform dflags pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc pprLoad dflags e ty - | width == W64, wordWidth dflags /= W64 + | width == W64, wordWidth platform /= W64 = (if isFloatType ty then text "PK_DBL" else text "PK_Word64") - <> parens (mkP_ <> pprExpr1 e) + <> parens (mkP_ <> pprExpr1 dflags e) | otherwise = case e of - CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) + CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) + CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r off | isPtrReg r && width == wordWidth dflags - , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty) + CmmRegOff r off | isPtrReg r && width == wordWidth platform + , off `rem` platformWordSizeInBytes platform == 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 dflags)) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) - _other -> cLoad (targetPlatform dflags) e ty + _other -> cLoad dflags e ty where width = typeWidth ty + platform = targetPlatform dflags -pprExpr1 :: CmmExpr -> SDoc -pprExpr1 (CmmLit lit) = pprLit1 lit -pprExpr1 e@(CmmReg _reg) = pprExpr e -pprExpr1 other = parens (pprExpr other) +pprExpr1 :: DynFlags -> CmmExpr -> SDoc +pprExpr1 dflags e = case e of + CmmLit lit -> pprLit1 dflags lit + CmmReg _reg -> pprExpr dflags e + _ -> parens (pprExpr dflags e) -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc +pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp op args +pprMachOpApp dflags op args | isMulMayOfloOp op - = text "mulIntMayOflo" <> parens (commafy (map pprExpr args)) + = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False -pprMachOpApp mop args +pprMachOpApp dflags mop args | Just ty <- machOpNeedsCast mop - = ty <> parens (pprMachOpApp' mop args) + = ty <> parens (pprMachOpApp' dflags mop args) | otherwise - = pprMachOpApp' mop args + = pprMachOpApp' dflags mop args -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says). The other C operations inherit their type @@ -441,24 +447,23 @@ machOpNeedsCast mop | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing -pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc -pprMachOpApp' mop args +pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' dflags mop args = case args of -- dyadic - [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y + [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y -- unary - [x] -> pprMachOp_for_C mop <> parens (pprArg x) + [x] -> pprMachOp_for_C platform mop <> parens (pprArg x) _ -> panic "PprC.pprMachOp : machop with wrong number of args" where + platform = targetPlatform dflags -- Cast needed for signed integer ops - pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e - | needsFCasts mop = sdocWithDynFlags $ \dflags -> - cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e - | otherwise = pprExpr1 e + pprArg e | signedOp mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e + | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e + | otherwise = pprExpr1 dflags e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False needsFCasts (MO_F_Neg _) = True @@ -468,9 +473,9 @@ pprMachOpApp' mop args -- -------------------------------------------------------------------------- -- Literals -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of - CmmInt i rep -> pprHexVal i rep +pprLit :: DynFlags -> CmmLit -> SDoc +pprLit dflags lit = case lit of + CmmInt i rep -> pprHexVal dflags i rep CmmFloat f w -> parens (machRep_F_CType w) <> str where d = fromRational f :: Double @@ -496,71 +501,75 @@ pprLit lit = case lit of where pprCLabelAddr lbl = char '&' <> ppr 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 +pprLit1 :: DynFlags -> CmmLit -> SDoc +pprLit1 dflags lit = case lit of + (CmmLabelOff _ _) -> parens (pprLit dflags lit) + (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit) + (CmmFloat _ _) -> parens (pprLit dflags lit) + _ -> pprLit dflags lit -- --------------------------------------------------------------------------- -- Static data pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] -pprStatics _ [] = [] -pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) - -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding - | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' - -- adjacent floats aren't padded but combined into a single word - | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest - = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest' - | wORD_SIZE dflags == 4 - = pprLit1 (floatToWord dflags f) : pprStatics dflags rest - | otherwise - = pprPanic "pprStatics: float" (vcat (map ppr' rest)) - where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> - ppr (cmmLitType dflags l) - ppr' _other = text "bad static!" -pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) - = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest - -pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) - | wordWidth dflags == W32 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) - else pprStatics dflags (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) - where r = i .&. 0xffffffff - q = i `shiftR` 32 -pprStatics dflags (CmmStaticLit (CmmInt a W32) : - CmmStaticLit (CmmInt b W32) : rest) - | wordWidth dflags == W64 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : - rest) - else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : - rest) -pprStatics dflags (CmmStaticLit (CmmInt a W16) : - CmmStaticLit (CmmInt b W16) : rest) - | wordWidth dflags == W32 - = if wORDS_BIGENDIAN dflags - then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : - rest) - else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : - rest) -pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) - | w /= wordWidth dflags - = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) -pprStatics dflags (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics dflags rest -pprStatics _ (other : _) - = pprPanic "pprStatics: other" (pprStatic other) - -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - - CmmStaticLit lit -> nest 4 (pprLit lit) +pprStatics dflags = pprStatics' + where + platform = targetPlatform dflags + pprStatics' = \case + [] -> [] + (CmmStaticLit (CmmFloat f W32) : rest) + -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding + | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest + -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest' + -- adjacent floats aren't padded but combined into a single word + | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest + -> pprLit1 dflags (floatPairToWord dflags f g) : pprStatics' rest' + | wordWidth platform == W32 + -> pprLit1 dflags (floatToWord dflags f) : pprStatics' rest + | otherwise + -> pprPanic "pprStatics: float" (vcat (map ppr' rest)) + where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l) + ppr' _other = text "bad static!" + + (CmmStaticLit (CmmFloat f W64) : rest) + -> map (pprLit1 dflags) (doubleToWords dflags f) ++ pprStatics' rest + + (CmmStaticLit (CmmInt i W64) : rest) + | wordWidth platform == W32 + -> if wORDS_BIGENDIAN dflags + then pprStatics' (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) + else pprStatics' (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) + where r = i .&. 0xffffffff + q = i `shiftR` 32 + + (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest) + | wordWidth platform == W64 + -> if wORDS_BIGENDIAN dflags + then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest) + else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest) + + (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest) + | wordWidth platform == W32 + -> if wORDS_BIGENDIAN dflags + then pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest) + else pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest) + + (CmmStaticLit (CmmInt _ w) : _) + | w /= wordWidth platform + -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) + + (CmmStaticLit lit : rest) + -> pprLit1 dflags lit : pprStatics' rest + + (other : _) + -> pprPanic "pprStatics: other" (pprStatic dflags other) + +pprStatic :: DynFlags -> CmmStatic -> SDoc +pprStatic dflags s = case s of + + CmmStaticLit lit -> nest 4 (pprLit dflags lit) CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc @@ -577,9 +586,9 @@ pprBlockId b = char '_' <> ppr (getUnique b) -- Print a MachOp in a way suitable for emitting via C. -- -pprMachOp_for_C :: MachOp -> SDoc +pprMachOp_for_C :: Platform -> MachOp -> SDoc -pprMachOp_for_C mop = case mop of +pprMachOp_for_C platform mop = case mop of -- Integer operations MO_Add _ -> char '+' @@ -640,19 +649,19 @@ pprMachOp_for_C mop = case mop of -- noop casts MO_UU_Conv from to | from == to -> empty - MO_UU_Conv _from to -> parens (machRep_U_CType to) + MO_UU_Conv _from to -> parens (machRep_U_CType platform to) MO_SS_Conv from to | from == to -> empty - MO_SS_Conv _from to -> parens (machRep_S_CType to) + MO_SS_Conv _from to -> parens (machRep_S_CType platform to) MO_XX_Conv from to | from == to -> empty - MO_XX_Conv _from to -> parens (machRep_U_CType to) + MO_XX_Conv _from to -> parens (machRep_U_CType platform to) 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) + MO_FS_Conv _from to -> parens (machRep_S_CType platform to) MO_S_MulMayOflo _ -> pprTrace "offending mop:" (text "MO_S_MulMayOflo") @@ -875,10 +884,11 @@ pprAssign _ r1 (CmmReg r2) -- dest is a reg, rhs is a CmmRegOff pprAssign dflags r1 (CmmRegOff r2 off) - | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) + | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where - off1 = off `shiftR` wordShift dflags + platform = targetPlatform dflags + off1 = off `shiftR` wordShift platform (op,off') | off >= 0 = (char '+', off1) | otherwise = (char '-', -off1) @@ -886,10 +896,10 @@ pprAssign dflags r1 (CmmRegOff r2 off) -- dest is a reg, rhs is anything. -- 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 = mkAssign (mkP_ <> pprExpr1 r2) - | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) - | otherwise = mkAssign (pprExpr r2) +pprAssign dflags r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 dflags r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2) + | otherwise = mkAssign (pprExpr dflags r2) where mkAssign x = if r1 == CmmGlobal BaseReg then text "ASSIGN_BaseReg" <> parens x <> semi else pprReg r1 <> text " = " <> x <> semi @@ -988,8 +998,8 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCall ppr_fn cconv results args +pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCall dflags ppr_fn cconv results args | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -997,6 +1007,8 @@ pprCall ppr_fn cconv results args = ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where + platform = targetPlatform dflags + ppr_assign [] rhs = rhs ppr_assign [(one,hint)] rhs = pprLocalReg one <> text " = " @@ -1004,16 +1016,15 @@ pprCall ppr_fn cconv results args ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (expr, AddrHint) - = cCast (text "void *") expr + = cCast dflags (text "void *") expr -- see comment by machRepHintCType below pprArg (expr, SignedHint) - = sdocWithDynFlags $ \dflags -> - cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr + = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr pprArg (expr, _other) - = pprExpr expr + = pprExpr dflags expr - pprUnHint AddrHint rep = parens (machRepCType rep) - pprUnHint SignedHint rep = parens (machRepCType rep) + pprUnHint AddrHint rep = parens (machRepCType platform rep) + pprUnHint SignedHint rep = parens (machRepCType platform rep) pprUnHint _ _ = empty -- Currently we only have these two calling conventions, but this might @@ -1029,23 +1040,23 @@ is_cishCC JavaScriptCallConv = False -- Find and print local and external declarations for a list of -- Cmm statements. -- -pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) -pprTempAndExternDecls stmts - = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl), - vcat (map pprExternDecl (Map.keys lbls))) +pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-}) +pprTempAndExternDecls platform stmts + = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)), + vcat (map (pprExternDecl platform) (Map.keys lbls))) where (temps, lbls) = runTE (mapM_ te_BB stmts) -pprDataExterns :: [CmmStatic] -> SDoc -pprDataExterns statics - = vcat (map pprExternDecl (Map.keys lbls)) +pprDataExterns :: Platform -> [CmmStatic] -> SDoc +pprDataExterns platform statics + = vcat (map (pprExternDecl platform) (Map.keys lbls)) where (_, lbls) = runTE (mapM_ te_Static statics) -pprTempDecl :: LocalReg -> SDoc -pprTempDecl l@(LocalReg _ rep) - = hcat [ machRepCType rep, space, pprLocalReg l, semi ] +pprTempDecl :: Platform -> LocalReg -> SDoc +pprTempDecl platform l@(LocalReg _ rep) + = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ] -pprExternDecl :: CLabel -> SDoc -pprExternDecl lbl +pprExternDecl :: Platform -> CLabel -> SDoc +pprExternDecl platform lbl -- do not print anything for "known external" things | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz @@ -1072,9 +1083,9 @@ pprExternDecl lbl -- If the label we want to refer to is a stdcall function (on Windows) then -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) - stdcall_decl sz = sdocWithDynFlags $ \dflags -> + stdcall_decl sz = text "extern __attribute__((stdcall)) void " <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) + <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform)))) <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) @@ -1142,18 +1153,18 @@ te_Reg _ = return () -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: SDoc -> CmmExpr -> SDoc -cCast ty expr = parens ty <> pprExpr1 expr +cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc +cCast dflags ty expr = parens ty <> pprExpr1 dflags expr -cLoad :: Platform -> CmmExpr -> CmmType -> SDoc -cLoad platform expr rep +cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +cLoad dflags expr rep = if bewareLoadStoreAlignment (platformArch platform) - then let decl = machRepCType rep <+> text "x" <> semi + then let decl = machRepCType platform rep <+> text "x" <> semi struct = text "struct" <+> braces (decl) packed_attr = text "__attribute__((packed))" cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 expr) <> text "->x" - else char '*' <> parens (cCast (machRepPtrCType rep) expr) + in parens (cast <+> pprExpr1 dflags expr) <> text "->x" + else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr) where -- On these platforms, unaligned loads are known to cause problems bewareLoadStoreAlignment ArchAlpha = True bewareLoadStoreAlignment ArchMipseb = True @@ -1166,53 +1177,54 @@ cLoad platform expr rep -- on unknown arches bewareLoadStoreAlignment ArchUnknown = True bewareLoadStoreAlignment _ = False + platform = targetPlatform dflags -isCmmWordType :: DynFlags -> CmmType -> Bool +isCmmWordType :: Platform -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size -isCmmWordType dflags ty = not (isFloatType ty) - && typeWidth ty == wordWidth dflags +isCmmWordType platform ty = not (isFloatType ty) + && typeWidth ty == wordWidth platform -- 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 :: CmmType -> ForeignHint -> SDoc -machRepHintCType _ AddrHint = text "void *" -machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) -machRepHintCType rep _other = machRepCType rep - -machRepPtrCType :: CmmType -> SDoc -machRepPtrCType r - = sdocWithDynFlags $ \dflags -> - if isCmmWordType dflags r then text "P_" - else machRepCType r <> char '*' - -machRepCType :: CmmType -> SDoc -machRepCType ty | isFloatType ty = machRep_F_CType w - | otherwise = machRep_U_CType w - where - w = typeWidth ty +machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc +machRepHintCType platform rep = \case + AddrHint -> text "void *" + SignedHint -> machRep_S_CType platform (typeWidth rep) + _other -> machRepCType platform rep + +machRepPtrCType :: Platform -> CmmType -> SDoc +machRepPtrCType platform r + = if isCmmWordType platform r + then text "P_" + else machRepCType platform r <> char '*' + +machRepCType :: Platform -> CmmType -> SDoc +machRepCType platform ty + | isFloatType ty = machRep_F_CType w + | otherwise = machRep_U_CType platform w + where + w = typeWidth ty machRep_F_CType :: Width -> SDoc machRep_F_CType W32 = text "StgFloat" -- ToDo: correct? machRep_F_CType W64 = text "StgDouble" machRep_F_CType _ = panic "machRep_F_CType" -machRep_U_CType :: Width -> SDoc -machRep_U_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "W_" +machRep_U_CType :: Platform -> Width -> SDoc +machRep_U_CType platform w + = case w of + _ | w == wordWidth platform -> text "W_" W8 -> text "StgWord8" W16 -> text "StgWord16" W32 -> text "StgWord32" W64 -> text "StgWord64" _ -> panic "machRep_U_CType" -machRep_S_CType :: Width -> SDoc -machRep_S_CType w - = sdocWithDynFlags $ \dflags -> - case w of - _ | w == wordWidth dflags -> text "I_" +machRep_S_CType :: Platform -> Width -> SDoc +machRep_S_CType platform w + = case w of + _ | w == wordWidth platform -> text "I_" W8 -> text "StgInt8" W16 -> text "StgInt16" W32 -> text "StgInt32" @@ -1266,11 +1278,12 @@ floatToWord dflags r writeArray arr 0 (fromRational r) arr' <- castFloatToWord32Array arr w32 <- readArray arr' 0 - return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags)) + return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform)) ) - where wo | wordWidth dflags == W64 + where wo | wordWidth platform == W64 , wORDS_BIGENDIAN dflags = 32 | otherwise = 0 + platform = targetPlatform dflags floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit floatPairToWord dflags r1 r2 @@ -1300,7 +1313,8 @@ doubleToWords dflags r w64 <- readArray arr' 0 return (pprWord64 w64) ) - where targetWidth = wordWidth dflags + where targetWidth = wordWidth platform + platform = targetPlatform dflags targetBE = wORDS_BIGENDIAN dflags pprWord64 w64 | targetWidth == W64 = @@ -1319,15 +1333,15 @@ doubleToWords dflags r -- --------------------------------------------------------------------------- -- Utils -wordShift :: DynFlags -> Int -wordShift dflags = widthInLog (wordWidth dflags) +wordShift :: Platform -> Int +wordShift platform = widthInLog (wordWidth platform) commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs -- Print in C hex format: 0x13fa -pprHexVal :: Integer -> Width -> SDoc -pprHexVal w rep +pprHexVal :: DynFlags -> Integer -> Width -> SDoc +pprHexVal dflags w rep | w < 0 = parens (char '-' <> text "0x" <> intToDoc (-w) <> repsuffix rep) | otherwise = text "0x" <> intToDoc w <> repsuffix rep @@ -1338,7 +1352,7 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - repsuffix W64 = sdocWithDynFlags $ \dflags -> + repsuffix W64 = if cINT_SIZE dflags == 8 then char 'U' else if cLONG_SIZE dflags == 8 then text "UL" else if cLONG_LONG_SIZE dflags == 8 then text "ULL" |