ghc-9.14.1: GHC/CmmToAsm/AArch64/Ppr.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where
import GHC.Prelude hiding (EQ)
import GHC.CmmToAsm.AArch64.Instr
import GHC.CmmToAsm.AArch64.Regs
import GHC.CmmToAsm.AArch64.Cond
import GHC.CmmToAsm.Ppr
import GHC.CmmToAsm.Format
import GHC.Platform.Reg
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Utils
import GHC.Cmm hiding (topInfoTable)
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Types.Unique ( pprUniqueAlways, getUnique )
import GHC.Platform
import GHC.Utils.Outputable
import GHC.Utils.Panic
pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
let platform = ncgPlatform config
in
pprSectionAlign config section $$ pprDatas platform dats
pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
let platform = ncgPlatform config
with_dwarf = ncgDwarfEnabled config
in
case topInfoTable proc of
Nothing ->
-- special case for code without info table:
pprSectionAlign config (Section Text lbl) $$
-- do not
-- pprProcAlignment config $$
(if lbl /= blockLbl (blockId (head blocks)) -- blocks can have clashed names
then pprLabel platform lbl -- blocks guaranteed not null, so label needed
else empty) $$
vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$
(if ncgDwarfEnabled config
then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$
pprSizeDecl platform lbl
Just (CmmStaticsRaw info_lbl _) ->
pprSectionAlign config (Section Text info_lbl) $$
-- pprProcAlignment config $$
(if platformHasSubsectionsViaSymbols platform
then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
else empty) $$
vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
then -- See Note [Subsections Via Symbols]
line
$ text "\t.long "
<+> pprAsmLabel platform info_lbl
<+> char '-'
<+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
else empty) $$
pprSizeDecl platform info_lbl
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
pprLabel :: IsDoc doc => Platform -> CLabel -> doc
pprLabel platform lbl =
pprGloblDecl platform lbl
$$ pprTypeDecl platform lbl
$$ line (pprAsmLabel platform lbl <> char ':')
-- | Print appropriate alignment for the given section type.
pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
pprAlignForSection _platform _seg
-- .balign is stable, whereas .align is platform dependent.
= line (text "\t.balign 8") -- always 8
-- | Print section header and appropriate alignment for that section.
--
-- This one will emit the header:
--
-- .section .text
-- .balign 8
--
pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
pprSectionAlign _config (Section (OtherSection _) _) =
panic "AArch64.Ppr.pprSectionAlign: unknown section"
pprSectionAlign config sec@(Section seg _) =
line (pprSectionHeader config sec)
$$ pprAlignForSection (ncgPlatform config) seg
-- | Output the ELF .size directive.
pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprSizeDecl platform lbl
= if osElfTarget (platformOS platform)
then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
else empty
pprBasicBlock :: IsDoc doc => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr
-> doc
pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
(if with_dwarf
then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')
else empty
)
where
-- Filter out identity moves. E.g. mov x18, x18 will be dropped.
optInstrs = filter f instrs
where f (MOV o1 o2) | o1 == o2 = False
f _ = True
asmLbl = blockLbl blockid
maybe_infotable c = case mapLookup blockid info_env of
Nothing -> c
Just (CmmStaticsRaw info_lbl info) ->
-- pprAlignForSection platform Text $$
infoTableLoc $$
vcat (map (pprData platform) info) $$
pprLabel platform info_lbl $$
c $$
(if with_dwarf
then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':')
else empty)
-- Make sure the info table has the right .loc for the block
-- coming right after it. See Note [Info Offset]
infoTableLoc = case instrs of
(l@LOCATION{} : _) -> pprInstr platform l
_other -> empty
pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
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 platform alias
$$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind')
pprDatas platform (CmmStaticsRaw lbl dats)
= vcat (pprLabel platform lbl : map (pprData platform) dats)
pprData :: IsDoc doc => Platform -> CmmStatic -> doc
pprData _platform (CmmString str) = line (pprString str)
pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path)
pprData platform (CmmUninitialised bytes)
= line $ if platformOS platform == OSDarwin
then text ".space " <> int bytes
else text ".skip " <> int bytes
pprData platform (CmmStaticLit lit) = pprDataItem platform lit
pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
pprGloblDecl platform lbl
| not (externallyVisibleCLabel lbl) = empty
| otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)
-- Note [Always use objects for info tables]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- See discussion in X86.Ppr for why this is necessary. Essentially we need to
-- ensure that we never pass function symbols when we might want to lookup the
-- info table. If we did, we could end up with procedure linking tables
-- (PLT)s, and thus the lookup wouldn't point to the function, but into the
-- jump table.
--
-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as
-- well.
pprLabelType' :: IsLine doc => Platform -> CLabel -> doc
pprLabelType' platform lbl =
if isCFunctionLabel lbl || functionOkInfoTable then
text "@function"
else
text "@object"
where
functionOkInfoTable = platformTablesNextToCode platform &&
isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
-- this is called pprTypeAndSizeDecl in PPC.Ppr
pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
pprTypeDecl platform lbl
= if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
else empty
pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc
pprDataItem platform lit
= lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
imm = litToImm lit
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 _ = [text "\t.quad\t" <> pprImm platform imm]
ppr_item FF32 (CmmFloat r _)
= let bs = floatToBytes (fromRational r)
in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
ppr_item FF64 (CmmFloat r _)
= let bs = doubleToBytes (fromRational r)
in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)
pprImm :: IsLine doc => Platform -> Imm -> doc
pprImm _ (ImmInt i) = int i
pprImm _ (ImmInteger i) = integer i
pprImm p (ImmCLbl l) = pprAsmLabel p l
pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i
pprImm _ (ImmLit s) = ftext s
-- TODO: See pprIm below for why this is a bad idea!
pprImm _ (ImmFloat f)
| f == 0 = text "wzr"
| otherwise = float (fromRational f)
pprImm _ (ImmDouble d)
| d == 0 = text "xzr"
| otherwise = double (fromRational d)
pprImm p (ImmConstantSum a b) = pprImm p a <> char '+' <> pprImm p b
pprImm p (ImmConstantDiff a b) = pprImm p a <> char '-'
<> lparen <> pprImm p b <> rparen
-- aarch64 GNU as uses // for comments.
asmComment :: SDoc -> SDoc
asmComment c = whenPprDebug $ text "#" <+> c
asmDoubleslashComment :: SDoc -> SDoc
asmDoubleslashComment c = whenPprDebug $ text "//" <+> c
asmMultilineComment :: SDoc -> SDoc
asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"
pprIm :: IsLine doc => Platform -> Imm -> doc
pprIm platform im = case im of
ImmInt i -> char '#' <> int i
ImmInteger i -> char '#' <> integer i
-- TODO: This will only work for
-- The floating point value must be expressible as ±n ÷ 16 × 2^r,
-- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4.
-- and 0 needs to be encoded as wzr/xzr.
--
-- Except for 0, we might want to either split it up into enough
-- ADD operations into an Integer register and then just bit copy it into
-- the double register? See the toBytes + fromRational above for data items.
-- This is something the x86 backend does.
--
-- We could also just turn them into statics :-/ Which is what the
-- PowerPC backend does.
ImmFloat f | f == 0 -> text "wzr"
ImmFloat f -> char '#' <> float (fromRational f)
ImmDouble d | d == 0 -> text "xzr"
ImmDouble d -> char '#' <> double (fromRational d)
-- =<lbl> pseudo instruction!
ImmCLbl l -> char '=' <> pprAsmLabel platform l
ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'
_ -> panic "AArch64.pprIm"
pprExt :: IsLine doc => ExtMode -> doc
pprExt EUXTB = text "uxtb"
pprExt EUXTH = text "uxth"
pprExt EUXTW = text "uxtw"
pprExt EUXTX = text "uxtx"
pprExt ESXTB = text "sxtb"
pprExt ESXTH = text "sxth"
pprExt ESXTW = text "sxtw"
pprExt ESXTX = text "sxtx"
pprShift :: IsLine doc => ShiftMode -> doc
pprShift SLSL = text "lsl"
pprShift SLSR = text "lsr"
pprShift SASR = text "asr"
pprShift SROR = text "ror"
pprOp :: IsLine doc => Platform -> Operand -> doc
pprOp plat op = case op of
OpReg w r -> pprReg w r
OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x
OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i
OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i
OpImm im -> pprIm plat im
OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i
-- TODO: Address computation always use registers as 64bit -- is this correct?
OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']'
OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']'
OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']'
pprReg :: forall doc. IsLine doc => Width -> Reg -> doc
pprReg w r = case r of
RegReal (RealRegSingle i) -> ppr_reg_no w i
-- virtual regs should not show up, but this is helpful for debugging.
RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u
RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u
_ -> pprPanic "AArch64.pprReg" (text $ show r)
where
ppr_reg_no :: Width -> Int -> doc
ppr_reg_no w 31
| w == W64 = text "sp"
| w == W32 = text "wsp"
-- See Note [AArch64 Register assignments]
ppr_reg_no w i
| i < 0, w == W32 = text "wzr"
| i < 0, w == W64 = text "xzr"
| i < 0 = pprPanic "Invalid Zero Reg" (ppr w <+> int i)
-- General Purpose Registers
| i <= 31, w == W8 = text "w" <> int i -- there are no byte or half
| i <= 31, w == W16 = text "w" <> int i -- words... word will do.
| i <= 31, w == W32 = text "w" <> int i
| i <= 31, w == W64 = text "x" <> int i
| i <= 31 = pprPanic "Invalid Reg" (ppr w <+> int i)
-- Floating Point Registers
| i <= 63, w == W8 = text "b" <> int (i-32)
| i <= 63, w == W16 = text "h" <> int (i-32)
| i <= 63, w == W32 = text "s" <> int (i-32)
| i <= 63, w == W64 = text "d" <> int (i-32)
| i <= 63, w == W128= text "q" <> int (i-32)
| otherwise = text "very naughty AArch64 register" <+> parens (text (show w) <+> int i)
isFloatOp :: Operand -> Bool
isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True
isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True
-- SIMD NCG TODO: what about VirtualVecV128? Could be floating-point or not?
isFloatOp _ = False
pprInstr :: IsDoc doc => Platform -> Instr -> doc
pprInstr platform instr = case instr of
-- Meta Instructions ---------------------------------------------------------
-- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
COMMENT s -> dualDoc (asmComment s) empty
MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty
ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)
LOCATION file line' col _name
-> line (text "\t.loc" <+> int file <+> int line' <+> int col)
DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
-- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
NEWBLOCK blockid -> -- This is invalid assembly. But NEWBLOCK should never be contained
-- in the final instruction stream. But we still want to be able to
-- print it for debugging purposes.
line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid))
-- Pseudo Instructions -------------------------------------------------------
PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!",
text "\tmov x29, sp"]
POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16"
-- ===========================================================================
-- AArch64 Instruction Set
-- 1. Arithmetic Instructions ------------------------------------------------
ADD o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3
| otherwise -> op3 (text "\tadd") o1 o2 o3
CMP o1 o2
| isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2
| otherwise -> op2 (text "\tcmp") o1 o2
CMN o1 o2 -> op2 (text "\tcmn") o1 o2
MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4
MUL o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3
| otherwise -> op3 (text "\tmul") o1 o2 o3
SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3
SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3
UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3
UMULL o1 o2 o3 -> op3 (text "\tumull") o1 o2 o3
NEG o1 o2
| isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2
| otherwise -> op2 (text "\tneg") o1 o2
SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3
-> op3 (text "\tfdiv") o1 o2 o3
SDIV o1 o2 o3 -> op3 (text "\tsdiv") o1 o2 o3
SUB o1 o2 o3
| isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub") o1 o2 o3
| otherwise -> op3 (text "\tsub") o1 o2 o3
UDIV o1 o2 o3 -> op3 (text "\tudiv") o1 o2 o3
-- 2. Bit Manipulation Instructions ------------------------------------------
SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4
UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4
CLZ o1 o2 -> op2 (text "\tclz") o1 o2
RBIT o1 o2 -> op2 (text "\trbit") o1 o2
REV o1 o2 -> op2 (text "\trev") o1 o2
REV16 o1 o2 -> op2 (text "\trev16") o1 o2
-- REV32 o1 o2 -> op2 (text "\trev32") o1 o2
-- signed and unsigned bitfield extract
SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4
UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4
SXTB o1 o2 -> op2 (text "\tsxtb") o1 o2
UXTB o1 o2 -> op2 (text "\tuxtb") o1 o2
SXTH o1 o2 -> op2 (text "\tsxth") o1 o2
UXTH o1 o2 -> op2 (text "\tuxth") o1 o2
-- 3. Logical and Move Instructions ------------------------------------------
AND o1 o2 o3 -> op3 (text "\tand") o1 o2 o3
ASR o1 o2 o3 -> op3 (text "\tasr") o1 o2 o3
EOR o1 o2 o3 -> op3 (text "\teor") o1 o2 o3
LSL o1 o2 o3 -> op3 (text "\tlsl") o1 o2 o3
LSR o1 o2 o3 -> op3 (text "\tlsr") o1 o2 o3
MOV o1 o2
| isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2
| otherwise -> op2 (text "\tmov") o1 o2
MOVK o1 o2 -> op2 (text "\tmovk") o1 o2
MOVZ o1 o2 -> op2 (text "\tmovz") o1 o2
MVN o1 o2 -> op2 (text "\tmvn") o1 o2
ORR o1 o2 o3 -> op3 (text "\torr") o1 o2 o3
-- 4. Branch Instructions ----------------------------------------------------
J t -> pprInstr platform (B t)
J_TBL _ _ r -> pprInstr platform (B (TReg r))
B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl
B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r
BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl
BL (TReg r) _ -> line $ text "\tblr" <+> pprReg W64 r
BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl
BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!"
-- 5. Atomic Instructions ----------------------------------------------------
-- 6. Conditional Instructions -----------------------------------------------
CSET o c -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c
CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!"
CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"
-- 7. Load and Store Instructions --------------------------------------------
-- NOTE: GHC may do whacky things where it only load the lower part of an
-- address. Not observing the correct size when loading will lead
-- inevitably to crashes.
STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
op2 (text "\tstrb") o1 o2
STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
op2 (text "\tstrh") o1 o2
STR _f o1 o2 -> op2 (text "\tstr") o1 o2
STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2
LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_ldr o1 (ldr') $$
op_add o1 (check_off off)
LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
case platformOS platform of
OSMinGW32 ->
let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_add o1 add' $$
op_add o1 (check_off off)
_ ->
let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_ldr o1 (ldr') $$
op_add o1 (check_off off)
LDR _f o1 (OpImm (ImmIndex lbl off)) ->
let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_add o1 (add') $$
op_add o1 (check_off off)
LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_ldr o1 (ldr')
LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
case platformOS platform of
OSMinGW32 ->
let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_add o1 add'
_ ->
let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
op_adrp o1 (adrp') $$
op_ldr o1 (ldr')
LDR _f o1 (OpImm (ImmCLbl lbl)) ->
let (adrp', ldr') = op_adrp_reloc_local $ pprAsmLabel platform lbl in
op_adrp o1 adrp' $$
op_add o1 ldr'
LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
op2 (text "\tldrb") o1 o2
LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
op2 (text "\tldrh") o1 o2
LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
-- 8. Synchronization Instructions -------------------------------------------
DMBISH DmbLoadStore -> line $ text "\tdmb ish"
DMBISH DmbLoad -> line $ text "\tdmb ishld"
-- 9. Floating Point Instructions --------------------------------------------
FMOV o1 o2 -> op2 (text "\tfmov") o1 o2
FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2
SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2
FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2
FABS o1 o2 -> op2 (text "\tfabs") o1 o2
FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2
FMIN o1 o2 o3 -> op3 (text "\tfmin") o1 o2 o3
FMAX o1 o2 o3 -> op3 (text "\tfmax") o1 o2 o3
FMA variant d r1 r2 r3 ->
let fma = case variant of
FMAdd -> text "\tfmadd"
FMSub -> text "\tfmsub"
FNMAdd -> text "\tfnmadd"
FNMSub -> text "\tfnmsub"
in op4 fma d r1 r2 r3
where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2
op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
op_ldr o1 rest = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"
op_adrp o1 rest = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest
op_add o1 rest = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest
op_adrp_reloc_dynamic asm_lbl = case platformOS platform of
OSDarwin -> (asm_lbl <> text "@gotpage", asm_lbl <> text "@gotpageoff")
OSLinux -> (text ":got:" <> asm_lbl, text ":got_lo12:" <> asm_lbl)
OSMinGW32 -> (text "__imp_" <> asm_lbl, text ":lo12:__imp_" <> asm_lbl)
os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_dynamic : " ++ show os' ++ " is unsuppported by relocations"
op_adrp_reloc_local asm_lbl = case platformOS platform of
OSDarwin -> (asm_lbl <> text "@page", asm_lbl <> text "@pageoff")
OSLinux -> (asm_lbl, text ":lo12:" <> asm_lbl)
OSMinGW32 -> (asm_lbl, text ":lo12:" <> asm_lbl)
os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_local : " ++ show os' ++ " is unsuppported by relocations"
check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else
pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"
pprBcond :: IsLine doc => Cond -> doc
pprBcond c = text "b." <> pprCond c
pprCond :: IsLine doc => Cond -> doc
pprCond c = case c of
ALWAYS -> text "al" -- Always
EQ -> text "eq" -- Equal
NE -> text "ne" -- Not Equal
SLT -> text "lt" -- Signed less than ; Less than, or unordered
SLE -> text "le" -- Signed less than or equal ; Less than or equal, or unordered
SGE -> text "ge" -- Signed greater than or equal ; Greater than or equal
SGT -> text "gt" -- Signed greater than ; Greater than
ULT -> text "lo" -- Carry clear/ unsigned lower ; less than
ULE -> text "ls" -- Unsigned lower or same ; Less than or equal
UGE -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered
UGT -> text "hi" -- Unsigned higher ; Greater than, or unordered
-- NEVER -> text "nv" -- Never
VS -> text "vs" -- Overflow ; Unordered (at least one NaN operand)
VC -> text "vc" -- No overflow ; Not unordered
-- Ordered variants. Respecting NaN.
OLT -> text "mi"
OLE -> text "ls"
OGE -> text "ge"
OGT -> text "gt"
-- Unordered
UOLT -> text "lt"
UOLE -> text "le"
UOGE -> text "pl"
UOGT -> text "hi"