{-# LANGUAGE CPP, GADTs #-}--------------------------------------------------------------------------------- Pretty-printing of Cmm as C, suitable for feeding gcc---- (c) The University of Glasgow 2004-2006---- Print Cmm as real C, for -fvia-C---- See wiki:commentary/compiler/backends/ppr-c---- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"-- relative to the old AbstractC, and many oddities/decorations have-- disappeared from the data type.---- This code generator is only supported in unregisterised mode.-------------------------------------------------------------------------------modulePprC(writeCs ,pprStringInCStyle )where#include "HsVersions.h"
-- Cmm stuffimportGhcPreludeimportBlockId importCLabel importForeignCallimportCmm hiding(pprBBlock )importPprCmm ()importHoopl.Block importHoopl.Collections importHoopl.Graph importCmmUtils importCmmSwitch -- UtilsimportCPrim importDynFlagsimportFastStringimportOutputableimportPlatformimportUniqSetimportUniqFMimportUniqueimportUtil-- The restimportData.ByteString(ByteString)importqualifiedData.ByteStringasBSimportControl.Monad.STimportData.BitsimportData.CharimportData.ListimportData.Map(Map)importData.WordimportSystem.IOimportqualifiedData.MapasMapimportControl.Monad(liftM,ap)importqualifiedData.Array.UnsafeasU(castSTUArray)importData.Array.ST-- ---------------------------------------------------------------------------- Top levelpprCs::[RawCmmGroup ]->SDocpprCs cmms =pprCodeCStyle(vcat$mappprC cmms )writeCs::DynFlags->Handle->[RawCmmGroup ]->IO()writeCs dflags handle cmms =printForCdflags handle (pprCs cmms )-- ---------------------------------------------------------------------------- Now do some real work---- for fun, we could call cmmToCmm over the tops...--pprC::RawCmmGroup ->SDocpprC tops =vcat$intersperseblankLine$mappprTop tops ---- top level procs--pprTop::RawCmmDecl ->SDocpprTop (CmmProc infos clbl _in_live_regs graph )=(casemapLookup (g_entrygraph )infos ofNothing->emptyJust(Statics info_clbl info_dat )->pprDataExterns info_dat $$pprWordArray info_is_in_rodata info_clbl info_dat )$$(vcat[blankLine,extern_decls ,(if(externallyVisibleCLabel clbl )thenmkFN_ elsemkIF_ )(pprclbl )<+>lbrace,nest8temp_decls ,vcat(mappprBBlock blocks ),rbrace])where-- info tables are always in .rodatainfo_is_in_rodata =Trueblocks =toBlockListEntryFirst graph (temp_decls ,extern_decls )=pprTempAndExternDecls blocks -- Chunks of static data.-- We only handle (a) arrays of word-sized things and (b) strings.pprTop(CmmData section (Statics lbl [CmmString str ]))=pprExternDecl lbl $$hcat[pprLocalness lbl ,pprConstness (isSecConstant section ),text"char ",pprlbl ,text"[] = ",pprStringInCStyle str ,semi]pprTop(CmmData section (Statics lbl [CmmUninitialised size ]))=pprExternDecl lbl $$hcat[pprLocalness lbl ,pprConstness (isSecConstant section ),text"char ",pprlbl ,brackets(intsize ),semi]pprTop(CmmData section (Statics lbl lits ))=pprDataExterns lits $$pprWordArray (isSecConstant section )lbl lits -- ---------------------------------------------------------------------------- BasicBlocks are self-contained entities: they always end in a jump.---- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn-- as many jumps as possible into fall throughs.--pprBBlock::CmmBlock ->SDocpprBBlock block =nest4(pprBlockId (entryLabel block )<>colon)$$nest8(vcat(mappprStmt (blockToList nodes ))$$pprStmt last )where(_,nodes ,last )=blockSplit block -- ---------------------------------------------------------------------------- Info tables. Just arrays of words.-- See codeGen/ClosureInfo, and nativeGen/PprMachpprWordArray::Bool->CLabel ->[CmmStatic ]->SDocpprWordArray is_ro lbl ds =sdocWithDynFlags$\dflags ->-- TODO: align closures onlypprExternDecl lbl $$hcat[pprLocalness lbl ,pprConstness is_ro ,text"StgWord",space,pprlbl ,text"[]"-- See Note [StgWord alignment],pprAlignment (wordWidthdflags ),text"= {"]$$nest8(commafy (pprStatics dflags ds ))$$text"};"pprAlignment::Width->SDocpprAlignment words =text"__attribute__((aligned("<>int(widthInByteswords )<>text")))"-- Note [StgWord alignment]-- C codegen builds static closures as StgWord C arrays (pprWordArray).-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume-- pointers to 'StgClosure' are aligned at pointer size boundary:-- 4 byte boundary on 32 systems-- and 8 bytes on 64-bit systems-- see TAG_MASK and TAG_BITS definition and usage.---- It's a reasonable assumption also known as natural alignment.-- Although some architectures have different alignment rules.-- One of known exceptions is m68k (#11395, comment:16) where:-- __alignof__(StgWord) == 2, sizeof(StgWord) == 4---- Thus we explicitly increase alignment by using-- __attribute__((aligned(4)))-- declaration.---- has to be static, if it isn't globally visible--pprLocalness::CLabel ->SDocpprLocalness lbl |not$externallyVisibleCLabel lbl =text"static "|otherwise=emptypprConstness::Bool->SDocpprConstness is_ro |is_ro =text"const "|otherwise=empty-- ---------------------------------------------------------------------------- Statements.--pprStmt::CmmNode e x ->SDocpprStmt stmt =sdocWithDynFlags$\dflags ->casestmt ofCmmEntry {}->emptyCmmComment _->empty-- (hang (text "/*") 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.CmmTick _->emptyCmmUnwind {}->emptyCmmAssign dest src ->pprAssign dflags dest src CmmStore dest src |typeWidthrep ==W64&&wordWidthdflags /=W64->(ifisFloatTyperep thentext"ASSIGN_DBL"elseptext(sLit("ASSIGN_Word64")))<>parens(mkP_ <>pprExpr1 dest <>comma<>pprExpr src )<>semi|otherwise->hsep[pprExpr (CmmLoad dest rep ),equals,pprExpr src <>semi]whererep =cmmExprType dflags src CmmUnsafeForeignCall target @(ForeignTarget fn conv )results args ->fnCall where(res_hints ,arg_hints )=foreignTargetHints target hresults =zipresults res_hints hargs =zipargs arg_hints ForeignConvention cconv __ret =conv cast_fn =parens(cCast (pprCFunType (char'*')cconv hresults hargs )fn )-- See wiki:commentary/compiler/backends/ppr-c#prototypesfnCall =casefn ofCmmLit (CmmLabel lbl )|StdCallConv<-cconv ->pprCall (pprlbl )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|not(isMathFun lbl )->pprForeignCall (pprlbl )cconv hresults hargs _->pprCall cast_fn cconv hresults hargs <>semi-- for a dynamic call, no declaration is necessary.CmmUnsafeForeignCall (PrimTarget MO_Touch )_results _args ->emptyCmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _))_results _args ->emptyCmmUnsafeForeignCall target @(PrimTarget op )results args ->fn_call wherecconv =CCallConvfn =pprCallishMachOp_for_C op (res_hints ,arg_hints )=foreignTargetHints target hresults =zipresults res_hints hargs =zipargs arg_hints fn_call -- The mem primops carry an extra alignment arg.-- We could maybe emit an alignment directive using this info.-- We also need to cast mem primops to prevent conflicts with GCC-- builtins (see bug #5967).|Just_align <-machOpMemcpyishAlign op =(text";EFF_("<>fn <>char')'<>semi)$$pprForeignCall fn cconv hresults hargs |otherwise=pprCall fn cconv hresults hargs CmmBranch ident ->pprBranch ident CmmCondBranch expr yes no _->pprCondBranch expr yes no CmmCall {cml_target=expr }->mkJMP_ (pprExpr expr )<>semiCmmSwitch arg ids ->sdocWithDynFlags$\dflags ->pprSwitch dflags arg ids _other ->pprPanic"PprC.pprStmt"(pprstmt )typeHinted a =(a ,ForeignHint)pprForeignCall::SDoc->CCallConv->[Hinted CmmFormal ]->[Hinted CmmActual ]->SDocpprForeignCall fn cconv results args =fn_call wherefn_call =braces(pprCFunType (char'*'<>text"ghcFunPtr")cconv results args <>semi$$text"ghcFunPtr"<+>equals<+>cast_fn <>semi$$pprCall (text"ghcFunPtr")cconv results args <>semi)cast_fn =parens(parens(pprCFunType (char'*')cconv results args )<>fn )pprCFunType::SDoc->CCallConv->[Hinted CmmFormal ]->[Hinted CmmActual ]->SDocpprCFunType ppr_fn cconv ress args =sdocWithDynFlags$\dflags ->letres_type []=text"void"res_type[(one ,hint )]=machRepHintCType (localRegType one )hint res_type_=panic"pprCFunType: only void or 1 return value supported"arg_type (expr ,hint )=machRepHintCType (cmmExprType dflags expr )hint inres_type ress <+>parens(ccallConvAttributecconv <>ppr_fn )<>parens(commafy (maparg_type args ))-- ----------------------------------------------------------------------- unconditional branchespprBranch::BlockId ->SDocpprBranch ident =text"goto"<+>pprBlockId ident <>semi-- ----------------------------------------------------------------------- conditional branches to local labelspprCondBranch::CmmExpr ->BlockId ->BlockId ->SDocpprCondBranch expr yes no =hsep[text"if",parens(pprExpr expr ),text"goto",pprBlockId yes <>semi,text"else goto",pprBlockId no <>semi]-- ----------------------------------------------------------------------- a local table branch---- we find the fall-through cases--pprSwitch::DynFlags->CmmExpr ->SwitchTargets ->SDocpprSwitch dflags e ids =(hang(text"switch"<+>parens(pprExpr e )<+>lbrace)4(vcat(mapcaseify pairs )$$def ))$$rbracewhere(pairs ,mbdef )=switchTargetsFallThrough ids -- fall through casecaseify (ix :ixs ,ident )=vcat(mapdo_fallthrough ixs )$$final_branch ix wheredo_fallthrough ix =hsep[text"case",pprHexVal ix (wordWidthdflags )<>colon,text"/* fall through */"]final_branch ix =hsep[text"case",pprHexVal ix (wordWidthdflags )<>colon,text"goto",(pprBlockId ident )<>semi]caseify(_,_)=panic"pprSwitch: switch with no cases!"def |Justl <-mbdef =text"default: goto"<+>pprBlockId l <>semi|otherwise=empty-- ----------------------------------------------------------------------- Expressions.---- C Types: the invariant is that the C expression generated by---- pprExpr e---- has a type in C which is also given by---- machRepCType (cmmExprType e)---- (similar invariants apply to the rest of the pretty printer).pprExpr::CmmExpr ->SDocpprExpr e =casee ofCmmLit lit ->pprLit lit CmmLoad e ty ->sdocWithDynFlags$\dflags ->pprLoad dflags e ty CmmReg reg ->pprCastReg reg CmmRegOff reg 0->pprCastReg reg -- CmmRegOff is an alias of MO_AddCmmRegOff reg i ->sdocWithDynFlags$\dflags ->pprCastReg reg <>char'+'<>pprHexVal (fromIntegrali )(wordWidthdflags )CmmMachOp mop args ->pprMachOpApp mop args CmmStackSlot __->panic"pprExpr: CmmStackSlot not supported!"pprLoad::DynFlags->CmmExpr ->CmmType->SDocpprLoad dflags e ty |width ==W64,wordWidthdflags /=W64=(ifisFloatTypety thentext"PK_DBL"elsetext"PK_Word64")<>parens(mkP_ <>pprExpr1 e )|otherwise=casee ofCmmReg r |isPtrReg r &&width ==wordWidthdflags &&not(isFloatTypety )->char'*'<>pprAsPtrReg r CmmRegOff r 0|isPtrReg r &&width ==wordWidthdflags &&not(isFloatTypety )->char'*'<>pprAsPtrReg r CmmRegOff r off |isPtrReg r &&width ==wordWidthdflags ,off `rem`wORD_SIZEdflags ==0&&not(isFloatTypety )-- 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 ))_other ->cLoad e ty wherewidth =typeWidthty pprExpr1::CmmExpr ->SDocpprExpr1 (CmmLit lit )=pprLit1 lit pprExpr1e @(CmmReg _reg )=pprExpr e pprExpr1other =parens(pprExpr other )-- ---------------------------------------------------------------------------- MachOp applicationspprMachOpApp::MachOp ->[CmmExpr ]->SDocpprMachOpApp op args |isMulMayOfloOp op =text"mulIntMayOflo"<>parens(commafy (mappprExpr args ))whereisMulMayOfloOp (MO_U_MulMayOflo _)=TrueisMulMayOfloOp(MO_S_MulMayOflo _)=TrueisMulMayOfloOp_=FalsepprMachOpAppmop args |Justty <-machOpNeedsCast mop =ty <>parens(pprMachOpApp' mop args )|otherwise=pprMachOpApp' 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-- from their operands, so no casting is required.machOpNeedsCast::MachOp ->MaybeSDocmachOpNeedsCast mop |isComparisonMachOp mop =JustmkW_ |otherwise=NothingpprMachOpApp'::MachOp ->[CmmExpr ]->SDocpprMachOpApp' mop args =caseargs of-- dyadic[x ,y ]->pprArg x <+>pprMachOp_for_C mop <+>pprArg y -- unary[x ]->pprMachOp_for_C mop <>parens(pprArg x )_->panic"PprC.pprMachOp : machop with wrong number of args"where-- Cast needed for signed integer opspprArg 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 needsFCasts (MO_F_Eq _)=FalseneedsFCasts(MO_F_Ne _)=FalseneedsFCasts(MO_F_Neg _)=TrueneedsFCasts(MO_F_Quot _)=TrueneedsFCastsmop =floatComparison mop -- ---------------------------------------------------------------------------- LiteralspprLit::CmmLit ->SDocpprLit lit =caselit ofCmmInt i rep ->pprHexVal i rep CmmFloat f w ->parens(machRep_F_CType w )<>str whered =fromRationalf ::Doublestr |isInfinited &&d <0=text"-INFINITY"|isInfinited =text"INFINITY"|isNaNd =text"NAN"|otherwise=text(showd )-- these constants come from <math.h>-- see #1861CmmVec {}->panic"PprC printing vector literal"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'+'<>inti CmmLabelDiffOff clbl1 _i _-- non-word widths not supported via C-- WARNING:-- * the lit must occur in the info table clbl2-- * clbl1 must be an SRT, a slow entry point or a large bitmap->mkW_ <>pprCLabelAddr clbl1 <>char'+'<>inti wherepprCLabelAddr lbl =char'&'<>pprlbl pprLit1::CmmLit ->SDocpprLit1 lit @(CmmLabelOff __)=parens(pprLit lit )pprLit1lit @(CmmLabelDiffOff ____)=parens(pprLit lit )pprLit1lit @(CmmFloat __)=parens(pprLit lit )pprLit1other =pprLit other -- ----------------------------------------------------------------------------- Static datapprStatics::DynFlags->[CmmStatic ]->[SDoc]pprStatics _[]=[]pprStaticsdflags (CmmStaticLit (CmmFloat f W32):rest )-- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding|wORD_SIZEdflags ==8,CmmStaticLit (CmmInt 0W32):rest' <-rest =pprLit1 (floatToWord dflags f ):pprStatics dflags rest' -- adjacent floats aren't padded but combined into a single word|wORD_SIZEdflags ==8,CmmStaticLit (CmmFloat g W32):rest' <-rest =pprLit1 (floatPairToWord dflags f g ):pprStatics dflags rest' |wORD_SIZEdflags ==4=pprLit1 (floatToWord dflags f ):pprStatics dflags rest |otherwise=pprPanic"pprStatics: float"(vcat(mapppr' rest ))whereppr' (CmmStaticLit l )=sdocWithDynFlags$\dflags ->ppr(cmmLitType dflags l )ppr'_other =text"bad static!"pprStaticsdflags (CmmStaticLit (CmmFloat f W64):rest )=mappprLit1 (doubleToWords dflags f )++pprStatics dflags rest pprStaticsdflags (CmmStaticLit (CmmInt i W64):rest )|wordWidthdflags ==W32=ifwORDS_BIGENDIANdflags thenpprStatics dflags (CmmStaticLit (CmmInt q W32):CmmStaticLit (CmmInt r W32):rest )elsepprStatics dflags (CmmStaticLit (CmmInt r W32):CmmStaticLit (CmmInt q W32):rest )wherer =i .&.0xffffffffq =i `shiftR`32pprStaticsdflags (CmmStaticLit (CmmInt a W32):CmmStaticLit (CmmInt b W32):rest )|wordWidthdflags ==W64=ifwORDS_BIGENDIANdflags thenpprStatics dflags (CmmStaticLit (CmmInt ((shiftLa 32).|.b )W64):rest )elsepprStatics dflags (CmmStaticLit (CmmInt ((shiftLb 32).|.a )W64):rest )pprStaticsdflags (CmmStaticLit (CmmInt a W16):CmmStaticLit (CmmInt b W16):rest )|wordWidthdflags ==W32=ifwORDS_BIGENDIANdflags thenpprStatics dflags (CmmStaticLit (CmmInt ((shiftLa 16).|.b )W32):rest )elsepprStatics dflags (CmmStaticLit (CmmInt ((shiftLb 16).|.a )W32):rest )pprStaticsdflags (CmmStaticLit (CmmInt _w ):_)|w /=wordWidthdflags =pprPanic"pprStatics: cannot emit a non-word-sized static literal"(pprw )pprStaticsdflags (CmmStaticLit lit :rest )=pprLit1 lit :pprStatics dflags rest pprStatics_(other :_)=pprPanic"pprStatics: other"(pprStatic other )pprStatic::CmmStatic ->SDocpprStatic s =cases ofCmmStaticLit lit ->nest4(pprLit lit )CmmUninitialised i ->nest4(mkC_ <>brackets(inti ))-- these should be inlined, like the old .hcCmmString s' ->nest4(mkW_ <>parens(pprStringInCStyle s' ))-- ----------------------------------------------------------------------------- Block IdspprBlockId::BlockId ->SDocpprBlockId b =char'_'<>ppr(getUniqueb )-- ---------------------------------------------------------------------------- Print a MachOp in a way suitable for emitting via C.--pprMachOp_for_C::MachOp ->SDocpprMachOp_for_C mop =casemop of-- Integer operationsMO_Add _->char'+'MO_Sub _->char'-'MO_Eq _->text"=="MO_Ne _->text"!="MO_Mul _->char'*'MO_S_Quot _->char'/'MO_S_Rem _->char'%'MO_S_Neg _->char'-'MO_U_Quot _->char'/'MO_U_Rem _->char'%'-- & Floating-point operationsMO_F_Add _->char'+'MO_F_Sub _->char'-'MO_F_Neg _->char'-'MO_F_Mul _->char'*'MO_F_Quot _->char'/'-- Signed comparisonsMO_S_Ge _->text">="MO_S_Le _->text"<="MO_S_Gt _->char'>'MO_S_Lt _->char'<'-- & Unsigned comparisonsMO_U_Ge _->text">="MO_U_Le _->text"<="MO_U_Gt _->char'>'MO_U_Lt _->char'<'-- & Floating-point comparisonsMO_F_Eq _->text"=="MO_F_Ne _->text"!="MO_F_Ge _->text">="MO_F_Le _->text"<="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_Or _->char'|'MO_Xor _->char'^'MO_Not _->char'~'MO_Shl _->text"<<"MO_U_Shr _->text">>"-- unsigned shift rightMO_S_Shr _->text">>"-- signed shift right-- 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 castsMO_UU_Conv from to |from ==to ->emptyMO_UU_Conv _from to ->parens(machRep_U_CType to )MO_SS_Conv from to |from ==to ->emptyMO_SS_Conv _from to ->parens(machRep_S_CType to )MO_XX_Conv from to |from ==to ->emptyMO_XX_Conv _from to ->parens(machRep_U_CType to )MO_FF_Conv from to |from ==to ->emptyMO_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_S_MulMayOflo _->pprTrace"offending mop:"(text"MO_S_MulMayOflo")(panic$"PprC.pprMachOp_for_C: MO_S_MulMayOflo"++" should have been handled earlier!")MO_U_MulMayOflo _->pprTrace"offending mop:"(text"MO_U_MulMayOflo")(panic$"PprC.pprMachOp_for_C: MO_U_MulMayOflo"++" should have been handled earlier!")MO_V_Insert {}->pprTrace"offending mop:"(text"MO_V_Insert")(panic$"PprC.pprMachOp_for_C: MO_V_Insert"++" should have been handled earlier!")MO_V_Extract {}->pprTrace"offending mop:"(text"MO_V_Extract")(panic$"PprC.pprMachOp_for_C: MO_V_Extract"++" should have been handled earlier!")MO_V_Add {}->pprTrace"offending mop:"(text"MO_V_Add")(panic$"PprC.pprMachOp_for_C: MO_V_Add"++" should have been handled earlier!")MO_V_Sub {}->pprTrace"offending mop:"(text"MO_V_Sub")(panic$"PprC.pprMachOp_for_C: MO_V_Sub"++" should have been handled earlier!")MO_V_Mul {}->pprTrace"offending mop:"(text"MO_V_Mul")(panic$"PprC.pprMachOp_for_C: MO_V_Mul"++" should have been handled earlier!")MO_VS_Quot {}->pprTrace"offending mop:"(text"MO_VS_Quot")(panic$"PprC.pprMachOp_for_C: MO_VS_Quot"++" should have been handled earlier!")MO_VS_Rem {}->pprTrace"offending mop:"(text"MO_VS_Rem")(panic$"PprC.pprMachOp_for_C: MO_VS_Rem"++" should have been handled earlier!")MO_VS_Neg {}->pprTrace"offending mop:"(text"MO_VS_Neg")(panic$"PprC.pprMachOp_for_C: MO_VS_Neg"++" should have been handled earlier!")MO_VU_Quot {}->pprTrace"offending mop:"(text"MO_VU_Quot")(panic$"PprC.pprMachOp_for_C: MO_VU_Quot"++" should have been handled earlier!")MO_VU_Rem {}->pprTrace"offending mop:"(text"MO_VU_Rem")(panic$"PprC.pprMachOp_for_C: MO_VU_Rem"++" should have been handled earlier!")MO_VF_Insert {}->pprTrace"offending mop:"(text"MO_VF_Insert")(panic$"PprC.pprMachOp_for_C: MO_VF_Insert"++" should have been handled earlier!")MO_VF_Extract {}->pprTrace"offending mop:"(text"MO_VF_Extract")(panic$"PprC.pprMachOp_for_C: MO_VF_Extract"++" should have been handled earlier!")MO_VF_Add {}->pprTrace"offending mop:"(text"MO_VF_Add")(panic$"PprC.pprMachOp_for_C: MO_VF_Add"++" should have been handled earlier!")MO_VF_Sub {}->pprTrace"offending mop:"(text"MO_VF_Sub")(panic$"PprC.pprMachOp_for_C: MO_VF_Sub"++" should have been handled earlier!")MO_VF_Neg {}->pprTrace"offending mop:"(text"MO_VF_Neg")(panic$"PprC.pprMachOp_for_C: MO_VF_Neg"++" should have been handled earlier!")MO_VF_Mul {}->pprTrace"offending mop:"(text"MO_VF_Mul")(panic$"PprC.pprMachOp_for_C: MO_VF_Mul"++" should have been handled earlier!")MO_VF_Quot {}->pprTrace"offending mop:"(text"MO_VF_Quot")(panic$"PprC.pprMachOp_for_C: MO_VF_Quot"++" should have been handled earlier!")MO_AlignmentCheck {}->panic"-falignment-santisation not supported by unregisterised backend"signedOp::MachOp ->Bool-- Argument type(s) are signed intssignedOp (MO_S_Quot _)=TruesignedOp(MO_S_Rem _)=TruesignedOp(MO_S_Neg _)=TruesignedOp(MO_S_Ge _)=TruesignedOp(MO_S_Le _)=TruesignedOp(MO_S_Gt _)=TruesignedOp(MO_S_Lt _)=TruesignedOp(MO_S_Shr _)=TruesignedOp(MO_SS_Conv __)=TruesignedOp(MO_SF_Conv __)=TruesignedOp_=FalsefloatComparison::MachOp ->Bool-- comparison between float argsfloatComparison (MO_F_Eq _)=TruefloatComparison(MO_F_Ne _)=TruefloatComparison(MO_F_Ge _)=TruefloatComparison(MO_F_Le _)=TruefloatComparison(MO_F_Gt _)=TruefloatComparison(MO_F_Lt _)=TruefloatComparison_=False-- ----------------------------------------------------------------------- tend to be implemented by foreign callspprCallishMachOp_for_C::CallishMachOp ->SDocpprCallishMachOp_for_C mop =casemop ofMO_F64_Pwr ->text"pow"MO_F64_Sin ->text"sin"MO_F64_Cos ->text"cos"MO_F64_Tan ->text"tan"MO_F64_Sinh ->text"sinh"MO_F64_Cosh ->text"cosh"MO_F64_Tanh ->text"tanh"MO_F64_Asin ->text"asin"MO_F64_Acos ->text"acos"MO_F64_Atanh ->text"atanh"MO_F64_Asinh ->text"asinh"MO_F64_Acosh ->text"acosh"MO_F64_Atan ->text"atan"MO_F64_Log ->text"log"MO_F64_Exp ->text"exp"MO_F64_Sqrt ->text"sqrt"MO_F64_Fabs ->text"fabs"MO_F32_Pwr ->text"powf"MO_F32_Sin ->text"sinf"MO_F32_Cos ->text"cosf"MO_F32_Tan ->text"tanf"MO_F32_Sinh ->text"sinhf"MO_F32_Cosh ->text"coshf"MO_F32_Tanh ->text"tanhf"MO_F32_Asin ->text"asinf"MO_F32_Acos ->text"acosf"MO_F32_Atan ->text"atanf"MO_F32_Asinh ->text"asinhf"MO_F32_Acosh ->text"acoshf"MO_F32_Atanh ->text"atanhf"MO_F32_Log ->text"logf"MO_F32_Exp ->text"expf"MO_F32_Sqrt ->text"sqrtf"MO_F32_Fabs ->text"fabsf"MO_WriteBarrier ->text"write_barrier"MO_Memcpy _->text"memcpy"MO_Memset _->text"memset"MO_Memmove _->text"memmove"MO_Memcmp _->text"memcmp"(MO_BSwap w )->ptext(sLit$bSwapLabel w )(MO_BRev w )->ptext(sLit$bRevLabel w )(MO_PopCnt w )->ptext(sLit$popCntLabel w )(MO_Pext w )->ptext(sLit$pextLabel w )(MO_Pdep w )->ptext(sLit$pdepLabel w )(MO_Clz w )->ptext(sLit$clzLabel w )(MO_Ctz w )->ptext(sLit$ctzLabel w )(MO_AtomicRMW w amop )->ptext(sLit$atomicRMWLabel w amop )(MO_Cmpxchg w )->ptext(sLit$cmpxchgLabel w )(MO_AtomicRead w )->ptext(sLit$atomicReadLabel w )(MO_AtomicWrite w )->ptext(sLit$atomicWriteLabel w )(MO_UF_Conv w )->ptext(sLit$word2FloatLabel w )MO_S_QuotRem {}->unsupported MO_U_QuotRem {}->unsupported MO_U_QuotRem2 {}->unsupported MO_Add2 {}->unsupported MO_AddWordC {}->unsupported MO_SubWordC {}->unsupported MO_AddIntC {}->unsupported MO_SubIntC {}->unsupported MO_U_Mul2 {}->unsupported MO_Touch ->unsupported (MO_Prefetch_Data _)->unsupported --- we could support prefetch via "__builtin_prefetch"--- Not adding it for nowwhereunsupported =panic("pprCallishMachOp_for_C: "++showmop ++" not supported!")-- ----------------------------------------------------------------------- Useful #defines--mkJMP_,mkFN_,mkIF_::SDoc->SDocmkJMP_ i =text"JMP_"<>parensi mkFN_ i =text"FN_"<>parensi -- externally visible functionmkIF_ i =text"IF_"<>parensi -- locally visible-- from includes/Stg.h--mkC_,mkW_,mkP_::SDocmkC_ =text"(C_)"-- StgCharmkW_ =text"(W_)"-- StgWordmkP_ =text"(P_)"-- StgWord*-- ------------------------------------------------------------------------- Assignments---- Generating assignments is what we're all about, here--pprAssign::DynFlags->CmmReg ->CmmExpr ->SDoc-- dest is a reg, rhs is a regpprAssign _r1 (CmmReg r2 )|isPtrReg r1 &&isPtrReg r2 =hcat[pprAsPtrReg r1 ,equals,pprAsPtrReg r2 ,semi]-- dest is a reg, rhs is a CmmRegOffpprAssigndflags r1 (CmmRegOff r2 off )|isPtrReg r1 &&isPtrReg r2 &&(off `rem`wORD_SIZEdflags ==0)=hcat[pprAsPtrReg r1 ,equals,pprAsPtrReg r2 ,op ,intoff' ,semi]whereoff1 =off `shiftR`wordShift dflags (op ,off' )|off >=0=(char'+',off1 )|otherwise=(char'-',-off1 )-- 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 )|Justty <-strangeRegType r1 =mkAssign (parensty <>pprExpr1 r2 )|otherwise=mkAssign (pprExpr r2 )wheremkAssign x =ifr1 ==CmmGlobal BaseReg thentext"ASSIGN_BaseReg"<>parensx <>semielsepprReg r1 <>text" = "<>x <>semi-- ----------------------------------------------------------------------- RegisterspprCastReg::CmmReg ->SDocpprCastReg reg |isStrangeTypeReg reg =mkW_ <>pprReg reg |otherwise=pprReg reg -- True if (pprReg reg) will give an expression with type StgPtr. We-- need to take care with pointer arithmetic on registers with type-- StgPtr.isFixedPtrReg::CmmReg ->BoolisFixedPtrReg (CmmLocal _)=FalseisFixedPtrReg(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 ->BoolisPtrReg (CmmLocal _)=FalseisPtrReg(CmmGlobal (VanillaReg _VGcPtr ))=True-- if we print via pprAsPtrRegisPtrReg(CmmGlobal (VanillaReg _VNonGcPtr ))=False-- if we print via pprAsPtrRegisPtrReg(CmmGlobal reg )=isFixedPtrGlobalReg reg -- True if this global reg has type StgPtrisFixedPtrGlobalReg::GlobalReg ->BoolisFixedPtrGlobalReg Sp =TrueisFixedPtrGlobalRegHp =TrueisFixedPtrGlobalRegHpLim =TrueisFixedPtrGlobalRegSpLim =TrueisFixedPtrGlobalReg_=False-- True if in C this register doesn't have the type given by-- (machRepCType (cmmRegType reg)), so it has to be cast.isStrangeTypeReg::CmmReg ->BoolisStrangeTypeReg (CmmLocal _)=FalseisStrangeTypeReg(CmmGlobal g )=isStrangeTypeGlobal g isStrangeTypeGlobal::GlobalReg ->BoolisStrangeTypeGlobal CCCS =TrueisStrangeTypeGlobalCurrentTSO =TrueisStrangeTypeGlobalCurrentNursery =TrueisStrangeTypeGlobalBaseReg =TrueisStrangeTypeGlobalr =isFixedPtrGlobalReg r strangeRegType::CmmReg ->MaybeSDocstrangeRegType (CmmGlobal CCCS )=Just(text"struct CostCentreStack_ *")strangeRegType(CmmGlobal CurrentTSO )=Just(text"struct StgTSO_ *")strangeRegType(CmmGlobal CurrentNursery )=Just(text"struct bdescr_ *")strangeRegType(CmmGlobal BaseReg )=Just(text"struct StgRegTable_ *")strangeRegType_=Nothing-- pprReg just prints the register name.--pprReg::CmmReg ->SDocpprReg r =caser ofCmmLocal local ->pprLocalReg local CmmGlobal global ->pprGlobalReg global pprAsPtrReg::CmmReg ->SDocpprAsPtrReg (CmmGlobal (VanillaReg n gcp ))=WARN(gcp/=VGcPtr,pprn )char'R'<>intn<>text".p"pprAsPtrRegother_reg =pprReg other_reg pprGlobalReg::GlobalReg ->SDocpprGlobalReg gr =casegr ofVanillaReg n _->char'R'<>intn <>text".w"-- pprGlobalReg prints a VanillaReg as a .w regardless-- Example: R1.w = R1.w & (-0x8UL);-- JMP_(*R1.p);FloatReg n ->char'F'<>intn DoubleReg n ->char'D'<>intn LongReg n ->char'L'<>intn Sp ->text"Sp"SpLim ->text"SpLim"Hp ->text"Hp"HpLim ->text"HpLim"CCCS ->text"CCCS"CurrentTSO ->text"CurrentTSO"CurrentNursery ->text"CurrentNursery"HpAlloc ->text"HpAlloc"BaseReg ->text"BaseReg"EagerBlackholeInfo ->text"stg_EAGER_BLACKHOLE_info"GCEnter1 ->text"stg_gc_enter_1"GCFun ->text"stg_gc_fun"other ->panic$"pprGlobalReg: Unsupported register: "++showother pprLocalReg::LocalReg ->SDocpprLocalReg (LocalReg uniq _)=char'_'<>ppruniq -- ------------------------------------------------------------------------------- Foreign CallspprCall::SDoc->CCallConv->[Hinted CmmFormal ]->[Hinted CmmActual ]->SDocpprCall ppr_fn cconv results args |not(is_cishCC cconv )=panic$"pprCall: unknown calling convention"|otherwise=ppr_assign results (ppr_fn <>parens(commafy (mappprArg args )))<>semiwhereppr_assign []rhs =rhs ppr_assign[(one ,hint )]rhs =pprLocalReg one <>text" = "<>pprUnHint hint (localRegType one )<>rhs ppr_assign_other _rhs =panic"pprCall: multiple results"pprArg (expr ,AddrHint)=cCast (text"void *")expr -- see comment by machRepHintCType belowpprArg(expr ,SignedHint)=sdocWithDynFlags$\dflags ->cCast (machRep_S_CType $typeWidth$cmmExprType dflags expr )expr pprArg(expr ,_other )=pprExpr expr pprUnHint AddrHintrep =parens(machRepCType rep )pprUnHintSignedHintrep =parens(machRepCType rep )pprUnHint__=empty-- Currently we only have these two calling conventions, but this might-- change in the future...is_cishCC::CCallConv->Boolis_cishCC CCallConv=Trueis_cishCCCApiConv=Trueis_cishCCStdCallConv=Trueis_cishCCPrimCallConv=Falseis_cishCCJavaScriptCallConv=False-- ----------------------------------------------------------------------- Find and print local and external declarations for a list of-- Cmm statements.--pprTempAndExternDecls::[CmmBlock ]->(SDoc{-temps-},SDoc{-externs-})pprTempAndExternDecls stmts =(pprUFM(getUniqSettemps )(vcat.mappprTempDecl ),vcat(mappprExternDecl (Map.keyslbls )))where(temps ,lbls )=runTE (mapM_te_BB stmts )pprDataExterns::[CmmStatic ]->SDocpprDataExterns statics =vcat(mappprExternDecl (Map.keyslbls ))where(_,lbls )=runTE (mapM_te_Static statics )pprTempDecl::LocalReg ->SDocpprTempDecl l @(LocalReg _rep )=hcat[machRepCType rep ,space,pprLocalReg l ,semi]pprExternDecl::CLabel ->SDocpprExternDecl lbl -- do not print anything for "known external" things|not(needsCDecl lbl )=empty|Justsz <-foreignLabelStdcallInfo lbl =stdcall_decl sz |otherwise=hcat[visibility ,label_type lbl ,lparen,pprlbl ,text");"-- occasionally useful to see label type-- , text "/* ", pprDebugCLabel lbl, text " */"]wherelabel_type lbl |isBytesLabel lbl =text"B_"|isForeignLabel lbl &&isCFunctionLabel lbl =text"FF_"|isCFunctionLabel lbl =text"F_"|isStaticClosureLabel lbl =text"C_"-- generic .rodata labels|isSomeRODataLabel lbl =text"RO_"-- generic .data labels (common case)|otherwise=text"RW_"visibility |externallyVisibleCLabel lbl =char'E'|otherwise=char'I'-- 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 ->text"extern __attribute__((stdcall)) void "<>pprlbl <>parens(commafy (replicate(sz `quot`wORD_SIZEdflags )(machRep_U_CType (wordWidthdflags ))))<>semitypeTEState =(UniqSetLocalReg ,MapCLabel ())newtypeTE a =TE {unTE ::TEState ->(a ,TEState )}instanceFunctorTE wherefmap =liftMinstanceApplicativeTE wherepure a =TE $\s ->(a ,s )(<*> )=apinstanceMonadTE whereTE m >>= k =TE $\s ->casem s of(a ,s' )->unTE(k a )s' te_lbl::CLabel ->TE ()te_lbl lbl =TE $\(temps ,lbls )->((),(temps ,Map.insertlbl ()lbls ))te_temp::LocalReg ->TE ()te_temp r =TE $\(temps ,lbls )->((),(addOneToUniqSettemps r ,lbls ))runTE::TE ()->TEState runTE (TE m )=snd(m (emptyUniqSet,Map.empty))te_Static::CmmStatic ->TE ()te_Static (CmmStaticLit lit )=te_Lit lit te_Static_=return()te_BB::CmmBlock ->TE ()te_BB block =mapM_te_Stmt (blockToList mid )>>te_Stmt last where(_,mid ,last )=blockSplit block te_Lit::CmmLit ->TE ()te_Lit (CmmLabel l )=te_lbl l te_Lit(CmmLabelOff l _)=te_lbl l te_Lit(CmmLabelDiffOff l1 ___)=te_lbl l1 te_Lit_=return()te_Stmt::CmmNode e x ->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(CmmUnsafeForeignCall target rs es )=dote_Target target mapM_te_temp rs mapM_te_Expr es te_Stmt(CmmCondBranch e ___)=te_Expr e te_Stmt(CmmSwitch e _)=te_Expr e te_Stmt(CmmCall {cml_target=e })=te_Expr e te_Stmt_=return()te_Target::ForeignTarget ->TE ()te_Target (ForeignTarget e _)=te_Expr e te_Target(PrimTarget {})=return()te_Expr::CmmExpr ->TE ()te_Expr (CmmLit lit )=te_Lit lit 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(CmmStackSlot __)=panic"te_Expr: CmmStackSlot not supported!"te_Reg::CmmReg ->TE ()te_Reg (CmmLocal l )=te_temp l te_Reg_=return()-- ----------------------------------------------------------------------- C types for MachRepscCast::SDoc->CmmExpr ->SDoccCast ty expr =parensty <>pprExpr1 expr cLoad::CmmExpr ->CmmType->SDoccLoad expr rep =sdocWithPlatform$\platform ->ifbewareLoadStoreAlignment (platformArchplatform )thenletdecl =machRepCType rep <+>text"x"<>semistruct =text"struct"<+>braces(decl )packed_attr =text"__attribute__((packed))"cast =parens(struct <+>packed_attr <>char'*')inparens(cast <+>pprExpr1 expr )<>text"->x"elsechar'*'<>parens(cCast (machRepPtrCType rep )expr )where-- On these platforms, unaligned loads are known to cause problemsbewareLoadStoreAlignment ArchAlpha=TruebewareLoadStoreAlignmentArchMipseb=TruebewareLoadStoreAlignmentArchMipsel=TruebewareLoadStoreAlignment(ArchARM{})=TruebewareLoadStoreAlignmentArchARM64=TruebewareLoadStoreAlignmentArchSPARC=TruebewareLoadStoreAlignmentArchSPARC64=True-- Pessimistically assume that they will also cause problems-- on unknown archesbewareLoadStoreAlignmentArchUnknown=TruebewareLoadStoreAlignment_=FalseisCmmWordType::DynFlags->CmmType->Bool-- True of GcPtrReg/NonGcReg of native word sizeisCmmWordType dflags ty =not(isFloatTypety )&&typeWidthty ==wordWidthdflags -- 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->SDocmachRepHintCType _AddrHint=text"void *"machRepHintCTyperep SignedHint=machRep_S_CType (typeWidthrep )machRepHintCTyperep _other =machRepCType rep machRepPtrCType::CmmType->SDocmachRepPtrCType r =sdocWithDynFlags$\dflags ->ifisCmmWordType dflags r thentext"P_"elsemachRepCType r <>char'*'machRepCType::CmmType->SDocmachRepCType ty |isFloatTypety =machRep_F_CType w |otherwise=machRep_U_CType w wherew =typeWidthty machRep_F_CType::Width->SDocmachRep_F_CType W32=text"StgFloat"-- ToDo: correct?machRep_F_CTypeW64=text"StgDouble"machRep_F_CType_=panic"machRep_F_CType"machRep_U_CType::Width->SDocmachRep_U_CType w =sdocWithDynFlags$\dflags ->casew of_|w ==wordWidthdflags ->text"W_"W8->text"StgWord8"W16->text"StgWord16"W32->text"StgWord32"W64->text"StgWord64"_->panic"machRep_U_CType"machRep_S_CType::Width->SDocmachRep_S_CType w =sdocWithDynFlags$\dflags ->casew of_|w ==wordWidthdflags ->text"I_"W8->text"StgInt8"W16->text"StgInt16"W32->text"StgInt32"W64->text"StgInt64"_->panic"machRep_S_CType"-- ----------------------------------------------------------------------- print strings as valid C stringspprStringInCStyle::ByteString->SDocpprStringInCStyle s =doubleQuotes(text(concatMapcharToC(BS.unpacks )))-- ----------------------------------------------------------------------------- Initialising static objects with floating-point numbers. We can't-- just emit the floating point number, because C will cast it to an int-- by rounding it. We want the actual bit-representation of the float.---- Consider a concrete C example:-- double d = 2.5e-10;-- float f = 2.5e-10f;---- int * i2 = &d; printf ("i2: %08X %08X\n", i2[0], i2[1]);-- long long * l = &d; printf (" l: %016llX\n", l[0]);-- int * i = &f; printf (" i: %08X\n", i[0]);-- Result on 64-bit LE (x86_64):-- i2: E826D695 3DF12E0B-- l: 3DF12E0BE826D695-- i: 2F89705F-- Result on 32-bit BE (m68k):-- i2: 3DF12E0B E826D695-- l: 3DF12E0BE826D695-- i: 2F89705F---- The trick here is to notice that binary representation does not-- change much: only Word32 values get swapped on LE hosts / targets.-- This is a hack to turn the floating point numbers into ints that we-- can safely initialise to static locations.castFloatToWord32Array::STUArrays IntFloat->STs (STUArrays IntWord32)castFloatToWord32Array =U.castSTUArraycastDoubleToWord64Array::STUArrays IntDouble->STs (STUArrays IntWord64)castDoubleToWord64Array =U.castSTUArrayfloatToWord::DynFlags->Rational->CmmLit floatToWord dflags r =runST(doarr <-newArray_((0::Int),0)writeArrayarr 0(fromRationalr )arr' <-castFloatToWord32Array arr w32 <-readArrayarr' 0return(CmmInt (toIntegerw32 `shiftL`wo )(wordWidthdflags )))wherewo |wordWidthdflags ==W64,wORDS_BIGENDIANdflags =32|otherwise=0floatPairToWord::DynFlags->Rational->Rational->CmmLit floatPairToWord dflags r1 r2 =runST(doarr <-newArray_((0::Int),1)writeArrayarr 0(fromRationalr1 )writeArrayarr 1(fromRationalr2 )arr' <-castFloatToWord32Array arr w32_1 <-readArrayarr' 0w32_2 <-readArrayarr' 1return(pprWord32Pair w32_1 w32_2 ))wherepprWord32Pair w32_1 w32_2 |wORDS_BIGENDIANdflags =CmmInt ((shiftLi1 32).|.i2 )W64|otherwise=CmmInt ((shiftLi2 32).|.i1 )W64wherei1 =toIntegerw32_1 i2 =toIntegerw32_2 doubleToWords::DynFlags->Rational->[CmmLit ]doubleToWords dflags r =runST(doarr <-newArray_((0::Int),1)writeArrayarr 0(fromRationalr )arr' <-castDoubleToWord64Array arr w64 <-readArrayarr' 0return(pprWord64 w64 ))wheretargetWidth =wordWidthdflags targetBE =wORDS_BIGENDIANdflags pprWord64 w64 |targetWidth ==W64=[CmmInt (toIntegerw64 )targetWidth ]|targetWidth ==W32=[CmmInt (toIntegertargetW1 )targetWidth ,CmmInt (toIntegertargetW2 )targetWidth ]|otherwise=panic"doubleToWords.pprWord64"where(targetW1 ,targetW2 )|targetBE =(wHi ,wLo )|otherwise=(wLo ,wHi )wHi =w64 `shiftR`32wLo =w64 .&.0xFFFFffff-- ----------------------------------------------------------------------------- UtilswordShift::DynFlags->IntwordShift dflags =widthInLog(wordWidthdflags )commafy::[SDoc]->SDoccommafy xs =hsep$punctuatecommaxs -- Print in C hex format: 0x13fapprHexVal::Integer->Width->SDocpprHexVal w rep |w <0=parens(char'-'<>text"0x"<>intToDoc (-w )<>repsuffix rep )|otherwise=text"0x"<>intToDoc 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.repsuffix W64=sdocWithDynFlags$\dflags ->ifcINT_SIZEdflags ==8thenchar'U'elseifcLONG_SIZEdflags ==8thentext"UL"elseifcLONG_LONG_SIZEdflags ==8thentext"ULL"elsepanic"pprHexVal: Can't find a 64-bit type"repsuffix_=char'U'intToDoc::Integer->SDocintToDoc i =casetruncInt i of0->char'0'v ->go v -- We need to truncate value as Cmm backend does not drop-- redundant bits to ease handling of negative values.-- Thus the following Cmm code on 64-bit arch, like amd64:-- CInt v;-- v = {something};-- if (v == %lobits32(-1)) { ...-- leads to the following C code:-- StgWord64 v = (StgWord32)({something});-- if (v == 0xFFFFffffFFFFffffU) { ...-- Such code is incorrect as it promotes both operands to StgWord64-- and the whole condition is always false.truncInt::Integer->IntegertruncInt i =caserep ofW8->i `rem`(2^(8::Int))W16->i `rem`(2^(16::Int))W32->i `rem`(2^(32::Int))W64->i `rem`(2^(64::Int))_->panic("pprHexVal/truncInt: C backend can't encode "++showrep ++" literals")go 0=emptygow' =go q <>dig where(q ,r )=w' `quotRem`16dig |r <10=char(chr(fromIntegerr +ord'0'))|otherwise=char(chr(fromIntegerr -10+ord'a'))