diff options
Diffstat (limited to 'compiler/GHC/CmmToAsm/PPC/Ppr.hs')
| -rw-r--r-- | compiler/GHC/CmmToAsm/PPC/Ppr.hs | 249 |
1 files changed, 118 insertions, 131 deletions
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 601714cf84..b4f9c98260 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language @@ -59,19 +61,19 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = -- special case for code without info table: pprSectionAlign config (Section Text lbl) $$ (case platformArch platform of - ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl - ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl + ArchPPC_64 ELF_V1 -> pprFunctionDescriptor platform lbl + ArchPPC_64 ELF_V2 -> pprFunctionPrologue platform lbl _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' + then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -80,9 +82,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = then -- See Note [Subsections Via Symbols] in X86/Ppr.hs text "\t.long " - <+> ppr info_lbl + <+> pdoc platform info_lbl <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) + <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl @@ -93,37 +95,37 @@ pprSizeDecl platform lbl then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl else empty where - prettyLbl = ppr lbl + prettyLbl = pdoc platform lbl codeLbl | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl | otherwise = prettyLbl -pprFunctionDescriptor :: CLabel -> SDoc -pprFunctionDescriptor lab = pprGloblDecl lab +pprFunctionDescriptor :: Platform -> CLabel -> SDoc +pprFunctionDescriptor platform lab = pprGloblDecl platform lab $$ text "\t.section \".opd\", \"aw\"" $$ text "\t.align 3" - $$ ppr lab <> char ':' + $$ pdoc platform lab <> char ':' $$ text "\t.quad ." - <> ppr lab + <> pdoc platform lab <> text ",.TOC.@tocbase,0" $$ text "\t.previous" $$ text "\t.type" - <+> ppr lab + <+> pdoc platform lab <> text ", @function" - $$ char '.' <> ppr lab <> char ':' + $$ char '.' <> pdoc platform lab <> char ':' -pprFunctionPrologue :: CLabel ->SDoc -pprFunctionPrologue lab = pprGloblDecl lab +pprFunctionPrologue :: Platform -> CLabel ->SDoc +pprFunctionPrologue platform lab = pprGloblDecl platform lab $$ text ".type " - <> ppr lab + <> pdoc platform lab <> text ", @function" - $$ ppr lab <> char ':' + $$ pdoc platform lab <> char ':' $$ text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha" $$ text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> ppr lab - <> text ",.-" <> ppr lab + $$ text "\t.localentry\t" <> pdoc platform lab + <> text ",.-" <> pdoc platform lab pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc @@ -132,7 +134,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' else empty ) where @@ -149,15 +151,15 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' - = pprGloblDecl alias - $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') + = pprGloblDecl platform alias + $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc @@ -167,23 +169,23 @@ pprData platform d = case d of CmmUninitialised bytes -> text ".space " <> int bytes CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: CLabel -> SDoc -pprGloblDecl lbl +pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> ppr lbl + | otherwise = text ".globl " <> pdoc platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> - ppr lbl <> text ", @object" + pdoc platform lbl <> text ", @object" else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = - pprGloblDecl lbl + pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl - $$ (ppr lbl <> char ':') + $$ (pdoc platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' @@ -230,57 +232,42 @@ pprCond c GU -> sLit "gt"; LEU -> sLit "le"; }) -pprImm :: Imm -> SDoc - -pprImm (ImmInt i) = int i -pprImm (ImmInteger i) = integer i -pprImm (ImmCLbl l) = ppr l -pprImm (ImmIndex l i) = ppr l <> char '+' <> int i -pprImm (ImmLit s) = s -pprImm (ImmFloat f) = float $ fromRational f -pprImm (ImmDouble d) = double $ fromRational d - -pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b -pprImm (ImmConstantDiff a b) = pprImm a <> char '-' - <> lparen <> pprImm b <> rparen - -pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i))) -pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16)) - where - lo16 = fromInteger (i .&. 0xffff) :: Int16 - -pprImm (LO i) - = pprImm i <> text "@l" - -pprImm (HI i) - = pprImm i <> text "@h" - -pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i))) -pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16) - where - ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 - hi16 = (i `shiftR` 16) - lo16 = i .&. 0xffff - -pprImm (HA i) - = pprImm i <> text "@ha" - -pprImm (HIGHERA i) - = pprImm i <> text "@highera" - -pprImm (HIGHESTA i) - = pprImm i <> text "@highesta" - - -pprAddr :: AddrMode -> SDoc -pprAddr (AddrRegReg r1 r2) - = pprReg r1 <> char ',' <+> pprReg r2 -pprAddr (AddrRegImm r1 (ImmInt i)) - = hcat [ int i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 (ImmInteger i)) - = hcat [ integer i, char '(', pprReg r1, char ')' ] -pprAddr (AddrRegImm r1 imm) - = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] +pprImm :: Platform -> Imm -> SDoc +pprImm platform = \case + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> pdoc platform l + ImmIndex l i -> pdoc platform l <> char '+' <> int i + ImmLit s -> s + ImmFloat f -> float $ fromRational f + ImmDouble d -> double $ fromRational d + ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b + ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen + LO (ImmInt i) -> pprImm platform (LO (ImmInteger (toInteger i))) + LO (ImmInteger i) -> pprImm platform (ImmInteger (toInteger lo16)) + where + lo16 = fromInteger (i .&. 0xffff) :: Int16 + + LO i -> pprImm platform i <> text "@l" + HI i -> pprImm platform i <> text "@h" + HA (ImmInt i) -> pprImm platform (HA (ImmInteger (toInteger i))) + HA (ImmInteger i) -> pprImm platform (ImmInteger ha16) + where + ha16 = if lo16 >= 0x8000 then hi16+1 else hi16 + hi16 = (i `shiftR` 16) + lo16 = i .&. 0xffff + + HA i -> pprImm platform i <> text "@ha" + HIGHERA i -> pprImm platform i <> text "@highera" + HIGHESTA i -> pprImm platform i <> text "@highesta" + + +pprAddr :: Platform -> AddrMode -> SDoc +pprAddr platform = \case + AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2 + AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 (ImmInteger i) -> hcat [ integer i, char '(', pprReg r1, char ')' ] + AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] pprSectionAlign :: NCGConfig -> Section -> SDoc @@ -321,11 +308,11 @@ pprDataItem platform lit imm = litToImm lit archPPC_64 = not $ target32Bit platform - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] ppr_item II64 _ - | archPPC_64 = [text "\t.quad\t" <> pprImm imm] + | archPPC_64 = [text "\t.quad\t" <> pprImm platform imm] ppr_item II64 (CmmInt x _) | not archPPC_64 = @@ -336,8 +323,8 @@ pprDataItem platform lit <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm] - ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm] + ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm] + ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] ppr_item _ _ = panic "PPC.Ppr.pprDataItem: no match" @@ -401,7 +388,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] LDFAR fmt reg (AddrRegImm source off) @@ -423,7 +410,7 @@ pprInstr platform instr = case instr of text "arx\t", pprReg reg1, text ", ", - pprAddr addr + pprAddr platform addr ] LA fmt reg addr @@ -443,7 +430,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] ST fmt reg addr @@ -456,7 +443,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] STFAR fmt reg (AddrRegImm source off) @@ -478,7 +465,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprAddr addr + pprAddr platform addr ] STC fmt reg1 addr @@ -491,7 +478,7 @@ pprInstr platform instr = case instr of text "cx.\t", pprReg reg1, text ", ", - pprAddr addr + pprAddr platform addr ] LIS reg imm @@ -501,7 +488,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprImm imm + pprImm platform imm ] LI reg imm @@ -511,7 +498,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprImm imm + pprImm platform imm ] MR reg1 reg2 @@ -534,7 +521,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -552,7 +539,7 @@ pprInstr platform instr = case instr of char '\t', pprReg reg, text ", ", - pprRI ri + pprRI platform ri ] where op = hcat [ @@ -570,7 +557,7 @@ pprInstr platform instr = case instr of pprCond cond, pprPrediction prediction, char '\t', - ppr lbl + pdoc platform lbl ] where lbl = mkLocalBlockLabel (getUnique blockid) pprPrediction p = case p of @@ -588,7 +575,7 @@ pprInstr platform instr = case instr of ], hcat [ text "\tb\t", - ppr lbl + pdoc platform lbl ] ] where lbl = mkLocalBlockLabel (getUnique blockid) @@ -605,7 +592,7 @@ pprInstr platform instr = case instr of char '\t', text "b", char '\t', - ppr lbl + pdoc platform lbl ] MTCTR reg @@ -636,12 +623,12 @@ pprInstr platform instr = case instr of -- they'd technically be more like 'ForeignLabel's. hcat [ text "\tbl\t.", - ppr lbl + pdoc platform lbl ] _ -> hcat [ text "\tbl\t", - ppr lbl + pdoc platform lbl ] BCTRL _ @@ -651,7 +638,7 @@ pprInstr platform instr = case instr of ] ADD reg1 reg2 ri - -> pprLogic (sLit "add") reg1 reg2 ri + -> pprLogic platform (sLit "add") reg1 reg2 ri ADDIS reg1 reg2 imm -> hcat [ @@ -662,26 +649,26 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] ADDO reg1 reg2 reg3 - -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3) ADDC reg1 reg2 reg3 - -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) ADDE reg1 reg2 reg3 - -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3) ADDZE reg1 reg2 -> pprUnary (sLit "addze") reg1 reg2 SUBF reg1 reg2 reg3 - -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3) SUBFO reg1 reg2 reg3 - -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri -> hcat [ @@ -695,14 +682,14 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] SUBFE reg1 reg2 reg3 - -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3) MULL fmt reg1 reg2 ri - -> pprMul fmt reg1 reg2 ri + -> pprMul platform fmt reg1 reg2 ri MULLO fmt reg1 reg2 reg3 -> hcat [ @@ -777,23 +764,23 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] AND reg1 reg2 ri - -> pprLogic (sLit "and") reg1 reg2 ri + -> pprLogic platform (sLit "and") reg1 reg2 ri ANDC reg1 reg2 reg3 - -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3) NAND reg1 reg2 reg3 - -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) + -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3) OR reg1 reg2 ri - -> pprLogic (sLit "or") reg1 reg2 ri + -> pprLogic platform (sLit "or") reg1 reg2 ri XOR reg1 reg2 ri - -> pprLogic (sLit "xor") reg1 reg2 ri + -> pprLogic platform (sLit "xor") reg1 reg2 ri ORIS reg1 reg2 imm -> hcat [ @@ -804,7 +791,7 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] XORIS reg1 reg2 imm @@ -816,7 +803,7 @@ pprInstr platform instr = case instr of text ", ", pprReg reg2, text ", ", - pprImm imm + pprImm platform imm ] EXTS fmt reg1 reg2 @@ -875,21 +862,21 @@ pprInstr platform instr = case instr of II32 -> "slw" II64 -> "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SR fmt reg1 reg2 ri -> let op = case fmt of II32 -> "srw" II64 -> "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SRA fmt reg1 reg2 ri -> let op = case fmt of II32 -> "sraw" II64 -> "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" - in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) + in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me -> hcat [ @@ -1019,8 +1006,8 @@ pprInstr platform instr = case instr of NOP -> text "\tnop" -pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc -pprLogic op reg1 reg2 ri = hcat [ +pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc +pprLogic platform op reg1 reg2 ri = hcat [ char '\t', ptext op, case ri of @@ -1031,12 +1018,12 @@ pprLogic op reg1 reg2 ri = hcat [ text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] -pprMul :: Format -> Reg -> Reg -> RI -> SDoc -pprMul fmt reg1 reg2 ri = hcat [ +pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc +pprMul platform fmt reg1 reg2 ri = hcat [ char '\t', text "mull", case ri of @@ -1050,7 +1037,7 @@ pprMul fmt reg1 reg2 ri = hcat [ text ", ", pprReg reg2, text ", ", - pprRI ri + pprRI platform ri ] @@ -1096,9 +1083,9 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [ pprReg reg3 ] -pprRI :: RI -> SDoc -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r +pprRI :: Platform -> RI -> SDoc +pprRI _ (RIReg r) = pprReg r +pprRI platform (RIImm r) = pprImm platform r pprFFormat :: Format -> SDoc |