{-
  This module handles generation of position independent code and
  dynamic-linking related issues for the native code generator.

  This depends both the architecture and OS, so we define it here
  instead of in one of the architecture specific modules.

  Things outside this module which are related to this:

  + module CLabel
    - PIC base label (pretty printed as local label 1)
    - DynamicLinkerLabels - several kinds:
        CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset
    - labelDynamic predicate
  + module Cmm
    - The GlobalReg datatype has a PicBaseReg constructor
    - The CmmLit datatype has a CmmLabelDiffOff constructor
  + codeGen & RTS
    - When tablesNextToCode, no absolute addresses are stored in info tables
      any more. Instead, offsets from the info label are used.
    - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers
      because Win32 doesn't support external references in data sections.
      TODO: make sure this still works, it might be bitrotted
  + NCG
    - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all
      labels.
    - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output
      all the necessary stuff for imported symbols.
    - The NCG monad keeps track of a list of imported symbols.
    - MachCodeGen invokes initializePicBase to generate code to initialize
      the PIC base register when needed.
    - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel
      that wasn't in the original Cmm code (e.g. floating point literals).
-}

module PIC (
        cmmMakeDynamicReference,
        CmmMakeDynamicReferenceM(..),
        ReferenceKind(..),
        needImportedSymbols,
        pprImportedSymbol,
        pprGotDeclaration,

        initializePicBase_ppc,
        initializePicBase_x86
)

where

import GhcPrelude

import qualified PPC.Instr      as PPC
import qualified PPC.Regs       as PPC

import qualified X86.Instr      as X86

import Platform
import Instruction
import Reg
import NCGMonad

import Hoopl.Collections
import Cmm
import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
                          dynamicLinkerLabelInfo, mkPicBaseLabel,
                          labelDynamic, externallyVisibleCLabel )

import CLabel           ( mkForeignLabel )

import BasicTypes
import Module

import Outputable

import DynFlags
import FastString

--------------------------------------------------------------------------------
-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
-- code. It does The Right Thing(tm) to convert the CmmLabel into a
-- position-independent, dynamic-linking-aware reference to the thing
-- in question.
-- Note that this also has to be called from MachCodeGen in order to
-- access static data like floating point literals (labels that were
-- created after the cmmToCmm pass).
-- The function must run in a monad that can keep track of imported symbols
-- A function for recording an imported symbol must be passed in:
-- - addImportCmmOpt for the CmmOptM monad
-- - addImportNat for the NatM monad.

data ReferenceKind
        = DataReference
        | CallReference
        | JumpReference
        deriving(Eq)

class Monad m => CmmMakeDynamicReferenceM m where
    addImport :: CLabel -> m ()
    getThisModule :: m Module

instance CmmMakeDynamicReferenceM NatM where
    addImport = addImportNat
    getThisModule = getThisModuleNat

cmmMakeDynamicReference
  :: CmmMakeDynamicReferenceM m
  => DynFlags
  -> ReferenceKind     -- whether this is the target of a jump
  -> CLabel            -- the label
  -> m CmmExpr

cmmMakeDynamicReference dflags referenceKind lbl
  | Just _ <- dynamicLinkerLabelInfo lbl
  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through

  | otherwise
  = do this_mod <- getThisModule
       case howToAccessLabel
                dflags
                (platformArch $ targetPlatform dflags)
                (platformOS   $ targetPlatform dflags)
                this_mod
                referenceKind lbl of

        AccessViaStub -> do
              let stub = mkDynamicLinkerLabel CodeStub lbl
              addImport stub
              return $ CmmLit $ CmmLabel stub

        AccessViaSymbolPtr -> do
              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
              addImport symbolPtr
              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)

        AccessDirectly -> case referenceKind of
                -- for data, we might have to make some calculations:
              DataReference -> return $ cmmMakePicReference dflags lbl
                -- all currently supported processors support
                -- PC-relative branch and call instructions,
                -- so just jump there if it's a call or a jump
              _ -> return $ CmmLit $ CmmLabel lbl

-- -----------------------------------------------------------------------------
-- Create a position independent reference to a label.
-- (but do not bother with dynamic linking).
-- We calculate the label's address by adding some (platform-dependent)
-- offset to our base register; this offset is calculated by
-- the function picRelative in the platform-dependent part below.

cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr
cmmMakePicReference dflags lbl

        -- Windows doesn't need PIC,
        -- everything gets relocated at runtime
        | OSMinGW32 <- platformOS $ targetPlatform dflags
        = CmmLit $ CmmLabel lbl

        | OSAIX <- platformOS $ targetPlatform dflags
        = CmmMachOp (MO_Add W32)
                [ CmmReg (CmmGlobal PicBaseReg)
                , CmmLit $ picRelative dflags
                                (platformArch   $ targetPlatform dflags)
                                (platformOS     $ targetPlatform dflags)
                                lbl ]

        -- both ABI versions default to medium code model
        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags
        = CmmMachOp (MO_Add W32) -- code model medium
                [ CmmReg (CmmGlobal PicBaseReg)
                , CmmLit $ picRelative dflags
                                (platformArch   $ targetPlatform dflags)
                                (platformOS     $ targetPlatform dflags)
                                lbl ]

        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)
            && absoluteLabel lbl
        = CmmMachOp (MO_Add (wordWidth dflags))
                [ CmmReg (CmmGlobal PicBaseReg)
                , CmmLit $ picRelative dflags
                                (platformArch   $ targetPlatform dflags)
                                (platformOS     $ targetPlatform dflags)
                                lbl ]

        | otherwise
        = CmmLit $ CmmLabel lbl

absoluteLabel :: CLabel -> Bool
absoluteLabel lbl
 = case dynamicLinkerLabelInfo lbl of
        Just (GotSymbolPtr, _)    -> False
        Just (GotSymbolOffset, _) -> False
        _                         -> True

--------------------------------------------------------------------------------
-- Knowledge about how special dynamic linker labels like symbol
-- pointers, code stubs and GOT offsets look like is located in the
-- module CLabel.

-- We have to decide which labels need to be accessed
-- indirectly or via a piece of stub code.
data LabelAccessStyle
        = AccessViaStub
        | AccessViaSymbolPtr
        | AccessDirectly

howToAccessLabel
        :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle

-- Windows
-- In Windows speak, a "module" is a set of objects linked into the
-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).
--
-- If we're compiling a multi-module program then symbols from other modules
-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the
-- following.
--
--   (in the local module)
--     __imp_SYMBOL: addr of SYMBOL
--
--   (in the other module)
--     SYMBOL: the real function / data.
--
-- To access the function at SYMBOL from our local module, we just need to
-- dereference the local __imp_SYMBOL.
--
-- If not compiling with -dynamic we assume that all our code will be linked
-- into the same .exe file. In this case we always access symbols directly,
-- and never use __imp_SYMBOL.
--
howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl

        -- Assume all symbols will be in the same PE, so just access them directly.
        | not (gopt Opt_ExternalDynamicRefs dflags)
        = AccessDirectly

        -- If the target symbol is in another PE we need to access it via the
        --      appropriate __imp_SYMBOL pointer.
        | labelDynamic dflags this_mod lbl
        = AccessViaSymbolPtr

        -- Target symbol is in the same PE as the caller, so just access it directly.
        | otherwise
        = AccessDirectly

-- Mach-O (Darwin, Mac OS X)
--
-- Indirect access is required in the following cases:
--  * things imported from a dynamic library
--  * (not on x86_64) data from a different module, if we're generating PIC code
-- It is always possible to access something indirectly,
-- even when it's not necessary.
--
howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
        -- data access to a dynamic library goes via a symbol pointer
        | labelDynamic dflags this_mod lbl
        = AccessViaSymbolPtr

        -- when generating PIC code, all cross-module data references must
        -- must go via a symbol pointer, too, because the assembler
        -- cannot generate code for a label difference where one
        -- label is undefined. Doesn't apply t x86_64.
        -- Unfortunately, we don't know whether it's cross-module,
        -- so we do it for all externally visible labels.
        -- This is a slight waste of time and space, but otherwise
        -- we'd need to pass the current Module all the way in to
        -- this function.
        | arch /= ArchX86_64
        , positionIndependent dflags && externallyVisibleCLabel lbl
        = AccessViaSymbolPtr

        | otherwise
        = AccessDirectly

howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl
        -- dyld code stubs don't work for tailcalls because the
        -- stack alignment is only right for regular calls.
        -- Therefore, we have to go via a symbol pointer:
        | arch == ArchX86 || arch == ArchX86_64
        , labelDynamic dflags this_mod lbl
        = AccessViaSymbolPtr

howToAccessLabel dflags arch OSDarwin this_mod _ lbl
        -- Code stubs are the usual method of choice for imported code;
        -- not needed on x86_64 because Apple's new linker, ld64, generates
        -- them automatically.
        | arch /= ArchX86_64
        , labelDynamic dflags this_mod lbl
        = AccessViaStub

        | otherwise
        = AccessDirectly

----------------------------------------------------------------------------
-- AIX

-- quite simple (for now)
howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl
        = case kind of
            DataReference -> AccessViaSymbolPtr
            CallReference -> AccessDirectly
            JumpReference -> AccessDirectly

-- ELF (Linux)
--
-- ELF tries to pretend to the main application code that dynamic linking does
-- not exist. While this may sound convenient, it tends to mess things up in
-- very bad ways, so we have to be careful when we generate code for a non-PIE
-- main program (-dynamic but no -fPIC).
--
-- Indirect access is required for references to imported symbols
-- from position independent code. It is also required from the main program
-- when dynamic libraries containing Haskell code are used.

howToAccessLabel _ (ArchPPC_64 _) os _ kind _
        | osElfTarget os
        = case kind of
          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
          DataReference -> AccessViaSymbolPtr
          -- RTLD does not generate stubs for function descriptors
          -- in tail calls. Create a symbol pointer and generate
          -- the code to load the function descriptor at the call site.
          JumpReference -> AccessViaSymbolPtr
          -- regular calls are handled by the runtime linker
          _             -> AccessDirectly

howToAccessLabel dflags _ os _ _ _
        -- no PIC -> the dynamic linker does everything for us;
        --           if we don't dynamically link to Haskell code,
        --           it actually manages to do so without messing things up.
        | osElfTarget os
        , not (positionIndependent dflags) &&
          not (gopt Opt_ExternalDynamicRefs dflags)
        = AccessDirectly

howToAccessLabel dflags arch os this_mod DataReference lbl
        | osElfTarget os
        = case () of
            -- A dynamic label needs to be accessed via a symbol pointer.
          _ | labelDynamic dflags this_mod lbl
            -> AccessViaSymbolPtr

            -- For PowerPC32 -fPIC, we have to access even static data
            -- via a symbol pointer (see below for an explanation why
            -- PowerPC32 Linux is especially broken).
            | arch == ArchPPC
            , positionIndependent dflags
            -> AccessViaSymbolPtr

            | otherwise
            -> AccessDirectly

        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table
        --   require the address of the GOT to be loaded into register %ebx on entry.
        --   The linker will take any reference to the symbol stub as a hint that
        --   the label in question is a code label. When linking executables, this
        --   will cause the linker to replace even data references to the label with
        --   references to the symbol stub.

        -- This leaves calling a (foreign) function from non-PIC code
        -- (AccessDirectly, because we get an implicit symbol stub)
        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)

howToAccessLabel dflags arch os this_mod CallReference lbl
        | osElfTarget os
        , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)
        = AccessDirectly

        | osElfTarget os
        , arch /= ArchX86
        , labelDynamic dflags this_mod lbl
        , positionIndependent dflags
        = AccessViaStub

howToAccessLabel dflags _ os this_mod _ lbl
        | osElfTarget os
        = if labelDynamic dflags this_mod lbl
            then AccessViaSymbolPtr
            else AccessDirectly

-- all other platforms
howToAccessLabel dflags _ _ _ _ _
        | not (positionIndependent dflags)
        = AccessDirectly

        | otherwise
        = panic "howToAccessLabel: PIC not defined for this platform"

-- -------------------------------------------------------------------
-- | Says what we have to add to our 'PIC base register' in order to
--      get the address of a label.

picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit

-- Darwin, but not x86_64:
-- The PIC base register points to the PIC base label at the beginning
-- of the current CmmDecl. We just have to use a label difference to
-- get the offset.
-- We have already made sure that all labels that are not from the current
-- module are accessed indirectly ('as' can't calculate differences between
-- undefined labels).
picRelative dflags arch OSDarwin lbl
        | arch /= ArchX86_64
        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)

-- On AIX we use an indirect local TOC anchored by 'gotLabel'.
-- This way we use up only one global TOC entry per compilation-unit
-- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)
picRelative dflags _ OSAIX lbl
        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)

-- PowerPC Linux:
-- The PIC base register points to our fake GOT. Use a label difference
-- to get the offset.
-- We have made sure that *everything* is accessed indirectly, so this
-- is only used for offsets from the GOT to symbol pointers inside the
-- GOT.
picRelative dflags ArchPPC os lbl
        | osElfTarget os
        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)

-- Most Linux versions:
-- The PIC base register points to the GOT. Use foo@got for symbol
-- pointers, and foo@gotoff for everything else.
-- Linux and Darwin on x86_64:
-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
-- and a GotSymbolOffset label for other things.
-- For reasons of tradition, the symbol offset label is written as a plain label.
picRelative _ arch os lbl
        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)
        = let   result
                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'

                        | otherwise
                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl

          in    result

picRelative _ _ _ _
        = panic "PositionIndependentCode.picRelative undefined for this platform"

--------------------------------------------------------------------------------

needImportedSymbols :: DynFlags -> Arch -> OS -> Bool
needImportedSymbols dflags arch os
        | os    == OSDarwin
        , arch  /= ArchX86_64
        = True

        | os    == OSAIX
        = True

        -- PowerPC Linux: -fPIC or -dynamic
        | osElfTarget os
        , arch  == ArchPPC
        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags

        -- PowerPC 64 Linux: always
        | osElfTarget os
        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2
        = True

        -- i386 (and others?): -dynamic but not -fPIC
        | osElfTarget os
        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
        = gopt Opt_ExternalDynamicRefs dflags &&
          not (positionIndependent dflags)

        | otherwise
        = False

-- gotLabel
-- The label used to refer to our "fake GOT" from
-- position-independent code.
gotLabel :: CLabel
gotLabel
        -- HACK: this label isn't really foreign
        = mkForeignLabel
                (fsLit ".LCTOC1")
                Nothing ForeignLabelInThisPackage IsData

--------------------------------------------------------------------------------
-- We don't need to declare any offset tables.
-- However, for PIC on x86, we need a small helper function.
pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc
pprGotDeclaration dflags ArchX86 OSDarwin
        | positionIndependent dflags
        = vcat [
                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
                text ".weak_definition ___i686.get_pc_thunk.ax",
                text ".private_extern ___i686.get_pc_thunk.ax",
                text "___i686.get_pc_thunk.ax:",
                text "\tmovl (%esp), %eax",
                text "\tret" ]

pprGotDeclaration _ _ OSDarwin
        = empty

-- Emit XCOFF TOC section
pprGotDeclaration _ _ OSAIX
        = vcat $ [ text ".toc"
                 , text ".tc ghc_toc_table[TC],.LCTOC1"
                 , text ".csect ghc_toc_table[RW]"
                   -- See Note [.LCTOC1 in PPC PIC code]
                 , text ".set .LCTOC1,$+0x8000"
                 ]

-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
pprGotDeclaration _ (ArchPPC_64 ELF_V1) _
        = text ".section \".toc\",\"aw\""
-- In ELF v2 we also need to tell the assembler that we want ABI
-- version 2. This would normally be done at the top of the file
-- right after a file directive, but I could not figure out how
-- to do that.
pprGotDeclaration _ (ArchPPC_64 ELF_V2) _
        = vcat [ text ".abiversion 2",
                 text ".section \".toc\",\"aw\""
               ]

-- Emit GOT declaration
-- Output whatever needs to be output once per .s file.
pprGotDeclaration dflags arch os
        | osElfTarget os
        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
        , not (positionIndependent dflags)
        = empty

        | osElfTarget os
        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
        = vcat [
                -- See Note [.LCTOC1 in PPC PIC code]
                text ".section \".got2\",\"aw\"",
                text ".LCTOC1 = .+32768" ]

pprGotDeclaration _ _ _
        = panic "pprGotDeclaration: no match"

--------------------------------------------------------------------------------
-- On Darwin, we have to generate our own stub code for lazy binding..
-- For each processor architecture, there are two versions, one for PIC
-- and one for non-PIC.
--

pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl
        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
        = case positionIndependent dflags of
           False ->
            vcat [
                text ".symbol_stub",
                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),
                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
                    text "\tjmp *L" <> pprCLabel platform lbl
                        <> text "$lazy_ptr",
                text "L" <> pprCLabel platform lbl
                    <> text "$stub_binder:",
                    text "\tpushl $L" <> pprCLabel platform lbl
                        <> text "$lazy_ptr",
                    text "\tjmp dyld_stub_binding_helper"
            ]
           True ->
            vcat [
                text ".section __TEXT,__picsymbolstub2,"
                    <> text "symbol_stubs,pure_instructions,25",
                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),
                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
                    text "\tcall ___i686.get_pc_thunk.ax",
                text "1:",
                    text "\tmovl L" <> pprCLabel platform lbl
                        <> text "$lazy_ptr-1b(%eax),%edx",
                    text "\tjmp *%edx",
                text "L" <> pprCLabel platform lbl
                    <> text "$stub_binder:",
                    text "\tlea L" <> pprCLabel platform lbl
                        <> text "$lazy_ptr-1b(%eax),%eax",
                    text "\tpushl %eax",
                    text "\tjmp dyld_stub_binding_helper"
            ]
          $+$ vcat [        text ".section __DATA, __la_sym_ptr"
                    <> (if positionIndependent dflags then int 2 else int 3)
                    <> text ",lazy_symbol_pointers",
                text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),
                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
                    text "\t.long L" <> pprCLabel platform lbl
                    <> text "$stub_binder"]

        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
        = vcat [
                text ".non_lazy_symbol_pointer",
                char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:",
                text "\t.indirect_symbol" <+> pprCLabel platform lbl,
                text "\t.long\t0"]

        | otherwise
        = empty

pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
        = empty

-- XCOFF / AIX
--
-- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To
-- workaround the limitation of a global TOC we use an indirect TOC
-- with the label `ghc_toc_table`.
--
-- See also GCC's `-mminimal-toc` compilation mode or
-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
--
-- NB: No DSO-support yet

pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl
        = case dynamicLinkerLabelInfo importedLbl of
            Just (SymbolPtr, lbl)
              -> vcat [
                   text "LC.." <> pprCLabel platform lbl <> char ':',
                   text "\t.long" <+> pprCLabel platform lbl ]
            _ -> empty

-- ELF / Linux
--
-- In theory, we don't need to generate any stubs or symbol pointers
-- by hand for Linux.
--
-- Reality differs from this in two areas.
--
-- 1) If we just use a dynamically imported symbol directly in a read-only
--    section of the main executable (as GCC does), ld generates R_*_COPY
--    relocations, which are fundamentally incompatible with reversed info
--    tables. Therefore, we need a table of imported addresses in a writable
--    section.
--    The "official" GOT mechanism (label@got) isn't intended to be used
--    in position dependent code, so we have to create our own "fake GOT"
--    when not Opt_PIC && WayDyn `elem` ways dflags.
--
-- 2) PowerPC Linux is just plain broken.
--    While it's theoretically possible to use GOT offsets larger
--    than 16 bit, the standard crt*.o files don't, which leads to
--    linker errors as soon as the GOT size exceeds 16 bit.
--    Also, the assembler doesn't support @gotoff labels.
--    In order to be able to use a larger GOT, we have to circumvent the
--    entire GOT mechanism and do it ourselves (this is also what GCC does).

-- When needImportedSymbols is defined,
-- the NCG will keep track of all DynamicLinkerLabels it uses
-- and output each of them using pprImportedSymbol.

pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ })
                  importedLbl
        | osElfTarget (platformOS platform)
        = case dynamicLinkerLabelInfo importedLbl of
            Just (SymbolPtr, lbl)
              -> vcat [
                   text ".section \".toc\", \"aw\"",
                   text ".LC_" <> pprCLabel platform lbl <> char ':',
                   text "\t.quad" <+> pprCLabel platform lbl ]
            _ -> empty

pprImportedSymbol dflags platform importedLbl
        | osElfTarget (platformOS platform)
        = case dynamicLinkerLabelInfo importedLbl of
            Just (SymbolPtr, lbl)
              -> let symbolSize = case wordWidth dflags of
                         W32 -> sLit "\t.long"
                         W64 -> sLit "\t.quad"
                         _ -> panic "Unknown wordRep in pprImportedSymbol"

                 in vcat [
                      text ".section \".got2\", \"aw\"",
                      text ".LC_" <> pprCLabel platform lbl <> char ':',
                      ptext symbolSize <+> pprCLabel platform lbl ]

            -- PLT code stubs are generated automatically by the dynamic linker.
            _ -> empty

pprImportedSymbol _ _ _
        = panic "PIC.pprImportedSymbol: no match"

--------------------------------------------------------------------------------
-- Generate code to calculate the address that should be put in the
-- PIC base register.
-- This is called by MachCodeGen for every CmmProc that accessed the
-- PIC base register. It adds the appropriate instructions to the
-- top of the CmmProc.

-- It is assumed that the first NatCmmDecl in the input list is a Proc
-- and the rest are CmmDatas.

-- Darwin is simple: just fetch the address of a local label.
-- The FETCHPC pseudo-instruction is expanded to multiple instructions
-- during pretty-printing so that we don't have to deal with the
-- local label:

-- PowerPC version:
--          bcl 20,31,1f.
--      1:  mflr picReg

-- i386 version:
--          call 1f
--      1:  popl %picReg

-- Get a pointer to our own fake GOT, which is defined on a per-module basis.
-- This is exactly how GCC does it in linux.

initializePicBase_ppc
        :: Arch -> OS -> Reg
        -> [NatCmmDecl CmmStatics PPC.Instr]
        -> NatM [NatCmmDecl CmmStatics PPC.Instr]

initializePicBase_ppc ArchPPC os picReg
    (CmmProc info lab live (ListGraph blocks) : statics)
    | osElfTarget os
    = do
        let
            gotOffset = PPC.ImmConstantDiff
                                (PPC.ImmCLbl gotLabel)
                                (PPC.ImmCLbl mkPicBaseLabel)

            blocks' = case blocks of
                       [] -> []
                       (b:bs) -> fetchPC b : map maybeFetchPC bs

            maybeFetchPC b@(BasicBlock bID _)
              | bID `mapMember` info = fetchPC b
              | otherwise            = b

            -- GCC does PIC prologs thusly:
            --     bcl 20,31,.L1
            -- .L1:
            --     mflr 30
            --     addis 30,30,.LCTOC1-.L1@ha
            --     addi 30,30,.LCTOC1-.L1@l
            -- TODO: below we use it over temporary register,
            -- it can and should be optimised by picking
            -- correct PIC reg.
            fetchPC (BasicBlock bID insns) =
              BasicBlock bID (PPC.FETCHPC picReg
                              : PPC.ADDIS picReg picReg (PPC.HA gotOffset)
                              : PPC.ADD picReg picReg
                                        (PPC.RIImm (PPC.LO gotOffset))
                              : PPC.MR PPC.r30 picReg
                              : insns)

        return (CmmProc info lab live (ListGraph blocks') : statics)

-------------------------------------------------------------------------
-- Load TOC into register 2
-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee
-- in register 12.
-- We pass the label to FETCHTOC and create a .localentry too.
-- TODO: Explain this better and refer to ABI spec!
{-
We would like to do approximately this, but spill slot allocation
might be added before the first BasicBlock. That violates the ABI.

For now we will emit the prologue code in the pretty printer,
which is also what we do for ELF v1.
initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg
        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
        = do
           bID <-getUniqueM
           return (CmmProc info lab live (ListGraph (b':entry:blocks))
                                         : statics)
        where   BasicBlock entryID _ = entry
                b' = BasicBlock bID [PPC.FETCHTOC picReg lab,
                                     PPC.BCC PPC.ALWAYS entryID]
-}

initializePicBase_ppc _ _ _ _
        = panic "initializePicBase_ppc: not needed"

-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
-- which pretty-prints as:
--              call 1f
-- 1:           popl %picReg
--              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
-- (See PprMach.hs)

initializePicBase_x86
        :: Arch -> OS -> Reg
        -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
        -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr]

initializePicBase_x86 ArchX86 os picReg
        (CmmProc info lab live (ListGraph blocks) : statics)
    | osElfTarget os
    = return (CmmProc info lab live (ListGraph blocks') : statics)
    where blocks' = case blocks of
                     [] -> []
                     (b:bs) -> fetchGOT b : map maybeFetchGOT bs

          -- we want to add a FETCHGOT instruction to the beginning of
          -- every block that is an entry point, which corresponds to
          -- the blocks that have entries in the info-table mapping.
          maybeFetchGOT b@(BasicBlock bID _)
            | bID `mapMember` info = fetchGOT b
            | otherwise            = b

          fetchGOT (BasicBlock bID insns) =
             BasicBlock bID (X86.FETCHGOT picReg : insns)

initializePicBase_x86 ArchX86 OSDarwin picReg
        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
        = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)

    where BasicBlock bID insns = entry
          block' = BasicBlock bID (X86.FETCHPC picReg : insns)

initializePicBase_x86 _ _ _ _
        = panic "initializePicBase_x86: not needed"


{-# LANGUAGE MagicHash #-}

-----------------------------------------------------------------------------
--
-- Pretty-printing assembly language
--
-- (c) The University of Glasgow 1993-2005
--
-----------------------------------------------------------------------------

module PprBase (
        castFloatToWord8Array,
        castDoubleToWord8Array,
        floatToBytes,
        doubleToBytes,
        pprASCII,
        pprBytes,
        pprSectionHeader
)

where

import GhcPrelude

import AsmUtils
import CLabel
import Cmm
import DynFlags
import FastString
import Outputable
import Platform
import FileCleanup

import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST

import Control.Monad.ST

import Data.Word
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import GHC.Exts
import GHC.Word
import System.IO.Unsafe

-- -----------------------------------------------------------------------------
-- Converting floating-point literals to integrals for printing

castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
castFloatToWord8Array = U.castSTUArray

castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
castDoubleToWord8Array = U.castSTUArray

-- floatToBytes and doubleToBytes convert to the host's byte
-- order.  Providing that we're not cross-compiling for a
-- target with the opposite endianness, this should work ok
-- on all targets.

-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
-- could they be merged?

floatToBytes :: Float -> [Int]
floatToBytes f
   = runST (do
        arr <- newArray_ ((0::Int),3)
        writeArray arr 0 f
        arr <- castFloatToWord8Array arr
        i0 <- readArray arr 0
        i1 <- readArray arr 1
        i2 <- readArray arr 2
        i3 <- readArray arr 3
        return (map fromIntegral [i0,i1,i2,i3])
     )

doubleToBytes :: Double -> [Int]
doubleToBytes d
   = runST (do
        arr <- newArray_ ((0::Int),7)
        writeArray arr 0 d
        arr <- castDoubleToWord8Array arr
        i0 <- readArray arr 0
        i1 <- readArray arr 1
        i2 <- readArray arr 2
        i3 <- readArray arr 3
        i4 <- readArray arr 4
        i5 <- readArray arr 5
        i6 <- readArray arr 6
        i7 <- readArray arr 7
        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
     )

-- ---------------------------------------------------------------------------
-- Printing ASCII strings.
--
-- Print as a string and escape non-printable characters.
-- This is similar to charToC in Utils.

pprASCII :: ByteString -> SDoc
pprASCII str
  -- Transform this given literal bytestring to escaped string and construct
  -- the literal SDoc directly.
  -- See Trac #14741
  -- and Note [Pretty print ASCII when AsmCodeGen]
  = text $ BS.foldr (\w s -> do1 w ++ s) "" str
    where
       do1 :: Word8 -> String
       do1 w | 0x09 == w = "\\t"
             | 0x0A == w = "\\n"
             | 0x22 == w = "\\\""
             | 0x5C == w = "\\\\"
               -- ASCII printable characters range
             | w >= 0x20 && w <= 0x7E = [chr' w]
             | otherwise = '\\' : octal w

       -- we know that the Chars we create are in the ASCII range
       -- so we bypass the check in "chr"
       chr' :: Word8 -> Char
       chr' (W8# w#) = C# (chr# (word2Int# w#))

       octal :: Word8 -> String
       octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
                 , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)
                 , chr' (ord0 + w .&. 0x07)
                 ]
       ord0 = 0x30 -- = ord '0'

-- | Pretty print binary data.
--
-- Use either the ".string" directive or a ".incbin" directive.
-- See Note [Embedding large binary blobs]
--
-- A NULL byte is added after the binary data.
--
pprBytes :: ByteString -> SDoc
pprBytes bs = sdocWithDynFlags $ \dflags ->
  if binBlobThreshold dflags == 0
     || fromIntegral (BS.length bs) <= binBlobThreshold dflags
    then text "\t.string " <> doubleQuotes (pprASCII bs)
    else unsafePerformIO $ do
      bFile <- newTempName dflags TFL_CurrentModule ".dat"
      BS.writeFile bFile bs
      return $ text "\t.incbin \"" <> text bFile <> text "\"\n\t.byte 0"

{-
Note [Embedding large binary blobs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated
code object, we have several options:

   1. Generate a ".byte" directive for each byte. This is what was done in the past
      (see Note [Pretty print ASCII when AsmCodeGen]).

   2. Generate a single ".string"/".asciz" directive for the whole sequence of
      bytes. Bytes in the ASCII printable range are rendered as characters and
      other values are escaped (e.g., "\t", "\077", etc.).

   3. Create a temporary file into which we dump the binary data and generate a
      single ".incbin" directive. The assembler will include the binary file for
      us in the generated output object.

Now the code generator uses either (2) or (3), depending on the binary blob
size.  Using (3) for small blobs adds too much overhead (see benchmark results
in #16190), so we only do it when the size is above a threshold (500K at the
time of writing).

The threshold is configurable via the `-fbinary-blob-threshold` flag.

-}

{-
Note [Pretty print ASCII when AsmCodeGen]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously, when generating assembly code, we created SDoc with
`(ptext . sLit)` for every bytes in literal bytestring, then
combine them using `hcat`.

When handling literal bytestrings with millions of bytes,
millions of SDoc would be created and to combine, leading to
high memory usage.

Now we escape the given bytestring to string directly and construct
SDoc only once. This improvement could dramatically decrease the
memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
string in source code. See Trac #14741 for profiling results.
-}

-- ----------------------------------------------------------------------------
-- Printing section headers.
--
-- If -split-section was specified, include the suffix label, otherwise just
-- print the section type. For Darwin, where subsections-for-symbols are
-- used instead, only print section type.
--
-- For string literals, additional flags are specified to enable merging of
-- identical strings in the linker. With -split-sections each string also gets
-- a unique section to allow strings from unused code to be GC'd.

pprSectionHeader :: Platform -> Section -> SDoc
pprSectionHeader platform (Section t suffix) =
 case platformOS platform of
   OSAIX     -> pprXcoffSectionHeader t
   OSDarwin  -> pprDarwinSectionHeader t
   OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix
   _         -> pprGNUSectionHeader (char '.') t suffix

pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc
pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->
  let splitSections = gopt Opt_SplitSections dflags
      subsection | splitSections = sep <> ppr suffix
                 | otherwise     = empty
  in  text ".section " <> ptext (header dflags) <> subsection <>
      flags dflags
  where
    header dflags = case t of
      Text -> sLit ".text"
      Data -> sLit ".data"
      ReadOnlyData  | OSMinGW32 <- platformOS (targetPlatform dflags)
                                -> sLit ".rdata"
                    | otherwise -> sLit ".rodata"
      RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
                                -- Concept does not exist on Windows,
                                -- So map these to R/O data.
                                          -> sLit ".rdata$rel.ro"
                              | otherwise -> sLit ".data.rel.ro"
      UninitialisedData -> sLit ".bss"
      ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)
                                 -> sLit ".rdata$cst16"
                     | otherwise -> sLit ".rodata.cst16"
      CString
        | OSMinGW32 <- platformOS (targetPlatform dflags)
                    -> sLit ".rdata"
        | otherwise -> sLit ".rodata.str"
      OtherSection _ ->
        panic "PprBase.pprGNUSectionHeader: unknown section type"
    flags dflags = case t of
      CString
        | OSMinGW32 <- platformOS (targetPlatform dflags)
                    -> empty
        | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"
      _ -> empty

-- XCOFF doesn't support relocating label-differences, so we place all
-- RO sections into .text[PR] sections
pprXcoffSectionHeader :: SectionType -> SDoc
pprXcoffSectionHeader t = text $ case t of
     Text                    -> ".csect .text[PR]"
     Data                    -> ".csect .data[RW]"
     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"
     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"
     CString                 -> ".csect .text[PR] # CString"
     UninitialisedData       -> ".csect .data[BS]"
     OtherSection _          ->
       panic "PprBase.pprXcoffSectionHeader: unknown section type"

pprDarwinSectionHeader :: SectionType -> SDoc
pprDarwinSectionHeader t =
  ptext $ case t of
     Text -> sLit ".text"
     Data -> sLit ".data"
     ReadOnlyData -> sLit ".const"
     RelocatableReadOnlyData -> sLit ".const_data"
     UninitialisedData -> sLit ".data"
     ReadOnlyData16 -> sLit ".const"
     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
     OtherSection _ ->
       panic "PprBase.pprDarwinSectionHeader: unknown section type"


-- | An architecture independent description of a register.
--      This needs to stay architecture independent because it is used
--      by NCGMonad and the register allocators, which are shared
--      by all architectures.
--
module Reg (
        RegNo,
        Reg(..),
        regPair,
        regSingle,
        isRealReg,      takeRealReg,
        isVirtualReg,   takeVirtualReg,

        VirtualReg(..),
        renameVirtualReg,
        classOfVirtualReg,
        getHiVirtualRegFromLo,
        getHiVRegFromLo,

        RealReg(..),
        regNosOfRealReg,
        realRegsAlias,

        liftPatchFnToRegReg
)

where

import GhcPrelude

import Outputable
import Unique
import RegClass
import Data.List

-- | An identifier for a primitive real machine register.
type RegNo
        = Int

-- VirtualRegs are virtual registers.  The register allocator will
--      eventually have to map them into RealRegs, or into spill slots.
--
--      VirtualRegs are allocated on the fly, usually to represent a single
--      value in the abstract assembly code (i.e. dynamic registers are
--      usually single assignment).
--
--      The  single assignment restriction isn't necessary to get correct code,
--      although a better register allocation will result if single
--      assignment is used -- because the allocator maps a VirtualReg into
--      a single RealReg, even if the VirtualReg has multiple live ranges.
--
--      Virtual regs can be of either class, so that info is attached.
--
data VirtualReg
        = VirtualRegI  {-# UNPACK #-} !Unique
        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register
        | VirtualRegF  {-# UNPACK #-} !Unique
        | VirtualRegD  {-# UNPACK #-} !Unique
        | VirtualRegSSE {-# UNPACK #-} !Unique
        deriving (Eq, Show)

-- This is laborious, but necessary. We can't derive Ord because
-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
-- implementation. See Note [No Ord for Unique]
-- This is non-deterministic but we do not currently support deterministic
-- code-generation. See Note [Unique Determinism and code generation]
instance Ord VirtualReg where
  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b
  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b
  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b
  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b
  compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b
  compare VirtualRegI{} _ = LT
  compare _ VirtualRegI{} = GT
  compare VirtualRegHi{} _ = LT
  compare _ VirtualRegHi{} = GT
  compare VirtualRegF{} _ = LT
  compare _ VirtualRegF{} = GT
  compare VirtualRegD{} _ = LT
  compare _ VirtualRegD{} = GT

instance Uniquable VirtualReg where
        getUnique reg
         = case reg of
                VirtualRegI u   -> u
                VirtualRegHi u  -> u
                VirtualRegF u   -> u
                VirtualRegD u   -> u
                VirtualRegSSE u -> u

instance Outputable VirtualReg where
        ppr reg
         = case reg of
                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u
                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u
                VirtualRegF  u  -> text "%vF_"   <> pprUniqueAlways u
                VirtualRegD  u  -> text "%vD_"   <> pprUniqueAlways u
                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u

renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
renameVirtualReg u r
 = case r of
        VirtualRegI _   -> VirtualRegI  u
        VirtualRegHi _  -> VirtualRegHi u
        VirtualRegF _   -> VirtualRegF  u
        VirtualRegD _   -> VirtualRegD  u
        VirtualRegSSE _ -> VirtualRegSSE u

classOfVirtualReg :: VirtualReg -> RegClass
classOfVirtualReg vr
 = case vr of
        VirtualRegI{}   -> RcInteger
        VirtualRegHi{}  -> RcInteger
        VirtualRegF{}   -> RcFloat
        VirtualRegD{}   -> RcDouble
        VirtualRegSSE{} -> RcDoubleSSE

-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
-- when supplied with the vreg for the lower-half of the quantity.
-- (NB. Not reversible).
getHiVirtualRegFromLo :: VirtualReg -> VirtualReg
getHiVirtualRegFromLo reg
 = case reg of
        -- makes a pseudo-unique with tag 'H'
        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')
        _               -> panic "Reg.getHiVirtualRegFromLo"

getHiVRegFromLo :: Reg -> Reg
getHiVRegFromLo reg
 = case reg of
        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)
        RegReal _       -> panic "Reg.getHiVRegFromLo"

------------------------------------------------------------------------------------
-- | RealRegs are machine regs which are available for allocation, in
--      the usual way.  We know what class they are, because that's part of
--      the processor's architecture.
--
--      RealRegPairs are pairs of real registers that are allocated together
--      to hold a larger value, such as with Double regs on SPARC.
--
data RealReg
        = RealRegSingle {-# UNPACK #-} !RegNo
        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo
        deriving (Eq, Show, Ord)

instance Uniquable RealReg where
        getUnique reg
         = case reg of
                RealRegSingle i         -> mkRegSingleUnique i
                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)

instance Outputable RealReg where
        ppr reg
         = case reg of
                RealRegSingle i         -> text "%r"  <> int i
                RealRegPair r1 r2       -> text "%r(" <> int r1
                                           <> vbar <> int r2 <> text ")"

regNosOfRealReg :: RealReg -> [RegNo]
regNosOfRealReg rr
 = case rr of
        RealRegSingle r1        -> [r1]
        RealRegPair   r1 r2     -> [r1, r2]

realRegsAlias :: RealReg -> RealReg -> Bool
realRegsAlias rr1 rr2
        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)

--------------------------------------------------------------------------------
-- | A register, either virtual or real
data Reg
        = RegVirtual !VirtualReg
        | RegReal    !RealReg
        deriving (Eq, Ord)

regSingle :: RegNo -> Reg
regSingle regNo         = RegReal $ RealRegSingle regNo

regPair :: RegNo -> RegNo -> Reg
regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2

-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
-- in the register allocator.
instance Uniquable Reg where
        getUnique reg
         = case reg of
                RegVirtual vr   -> getUnique vr
                RegReal    rr   -> getUnique rr

-- | Print a reg in a generic manner
--      If you want the architecture specific names, then use the pprReg
--      function from the appropriate Ppr module.
instance Outputable Reg where
        ppr reg
         = case reg of
                RegVirtual vr   -> ppr vr
                RegReal    rr   -> ppr rr

isRealReg :: Reg -> Bool
isRealReg reg
 = case reg of
        RegReal _       -> True
        RegVirtual _    -> False

takeRealReg :: Reg -> Maybe RealReg
takeRealReg reg
 = case reg of
        RegReal rr      -> Just rr
        _               -> Nothing

isVirtualReg :: Reg -> Bool
isVirtualReg reg
 = case reg of
        RegReal _       -> False
        RegVirtual _    -> True

takeVirtualReg :: Reg -> Maybe VirtualReg
takeVirtualReg reg
 = case reg of
        RegReal _       -> Nothing
        RegVirtual vr   -> Just vr

-- | The patch function supplied by the allocator maps VirtualReg to RealReg
--      regs, but sometimes we want to apply it to plain old Reg.
--
liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)
liftPatchFnToRegReg patchF reg
 = case reg of
        RegVirtual vr   -> RegReal (patchF vr)
        RegReal _       -> reg


-- | An architecture independent description of a register's class.
module RegClass
        ( RegClass (..) )

where

import GhcPrelude

import  Outputable
import  Unique

-- | The class of a register.
--      Used in the register allocator.
--      We treat all registers in a class as being interchangable.
--
data RegClass
        = RcInteger
        | RcFloat
        | RcDouble
        | RcDoubleSSE -- x86 only: the SSE regs are a separate class
        deriving Eq

instance Uniquable RegClass where
    getUnique RcInteger = mkRegClassUnique 0
    getUnique RcFloat   = mkRegClassUnique 1
    getUnique RcDouble  = mkRegClassUnique 2
    getUnique RcDoubleSSE = mkRegClassUnique 3

instance Outputable RegClass where
    ppr RcInteger       = Outputable.text "I"
    ppr RcFloat         = Outputable.text "F"
    ppr RcDouble        = Outputable.text "D"
    ppr RcDoubleSSE     = Outputable.text "S"


{-# LANGUAGE CPP #-}
-- | Hard wired things related to registers.
--      This is module is preventing the native code generator being able to
--      emit code for non-host architectures.
--
--      TODO: Do a better job of the overloading, and eliminate this module.
--      We'd probably do better with a Register type class, and hook this to
--      Instruction somehow.
--
--      TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable
module TargetReg (
        targetVirtualRegSqueeze,
        targetRealRegSqueeze,
        targetClassOfRealReg,
        targetMkVirtualReg,
        targetRegDotColor,
        targetClassOfReg
)

where

#include "HsVersions.h"

import GhcPrelude

import Reg
import RegClass
import Format

import Outputable
import Unique
import Platform

import qualified X86.Regs       as X86
import qualified X86.RegInfo    as X86

import qualified PPC.Regs       as PPC

import qualified SPARC.Regs     as SPARC

targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
targetVirtualRegSqueeze platform
    = case platformArch platform of
      ArchX86       -> X86.virtualRegSqueeze
      ArchX86_64    -> X86.virtualRegSqueeze
      ArchPPC       -> PPC.virtualRegSqueeze
      ArchSPARC     -> SPARC.virtualRegSqueeze
      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"
      ArchPPC_64 _  -> PPC.virtualRegSqueeze
      ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"
      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"
      ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"
      ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"
      ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"
      ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"
      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"

targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int
targetRealRegSqueeze platform
    = case platformArch platform of
      ArchX86       -> X86.realRegSqueeze
      ArchX86_64    -> X86.realRegSqueeze
      ArchPPC       -> PPC.realRegSqueeze
      ArchSPARC     -> SPARC.realRegSqueeze
      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"
      ArchPPC_64 _  -> PPC.realRegSqueeze
      ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"
      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"
      ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"
      ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"
      ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"
      ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"
      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"

targetClassOfRealReg :: Platform -> RealReg -> RegClass
targetClassOfRealReg platform
    = case platformArch platform of
      ArchX86       -> X86.classOfRealReg platform
      ArchX86_64    -> X86.classOfRealReg platform
      ArchPPC       -> PPC.classOfRealReg
      ArchSPARC     -> SPARC.classOfRealReg
      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"
      ArchPPC_64 _  -> PPC.classOfRealReg
      ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"
      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"
      ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"
      ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"
      ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"
      ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"
      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"

targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg
targetMkVirtualReg platform
    = case platformArch platform of
      ArchX86       -> X86.mkVirtualReg
      ArchX86_64    -> X86.mkVirtualReg
      ArchPPC       -> PPC.mkVirtualReg
      ArchSPARC     -> SPARC.mkVirtualReg
      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"
      ArchPPC_64 _  -> PPC.mkVirtualReg
      ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"
      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"
      ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"
      ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"
      ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"
      ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"

targetRegDotColor :: Platform -> RealReg -> SDoc
targetRegDotColor platform
    = case platformArch platform of
      ArchX86       -> X86.regDotColor platform
      ArchX86_64    -> X86.regDotColor platform
      ArchPPC       -> PPC.regDotColor
      ArchSPARC     -> SPARC.regDotColor
      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"
      ArchPPC_64 _  -> PPC.regDotColor
      ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"
      ArchARM64     -> panic "targetRegDotColor ArchARM64"
      ArchAlpha     -> panic "targetRegDotColor ArchAlpha"
      ArchMipseb    -> panic "targetRegDotColor ArchMipseb"
      ArchMipsel    -> panic "targetRegDotColor ArchMipsel"
      ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"
      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"

targetClassOfReg :: Platform -> Reg -> RegClass
targetClassOfReg platform reg
 = case reg of
   RegVirtual vr -> classOfVirtualReg vr
   RegReal rr -> targetClassOfRealReg platform rr


-- | Constants describing the DWARF format. Most of this simply
-- mirrors /usr/include/dwarf.h.

module Dwarf.Constants where

import GhcPrelude

import AsmUtils
import FastString
import Platform
import Outputable

import Reg
import X86.Regs

import Data.Word

-- | Language ID used for Haskell.
dW_LANG_Haskell :: Word
dW_LANG_Haskell = 0x18
  -- Thanks to Nathan Howell for getting us our very own language ID!

-- * Dwarf tags
dW_TAG_compile_unit, dW_TAG_subroutine_type,
  dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,
  dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,
  dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,
  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,
  dW_TAG_ghc_src_note :: Word
dW_TAG_array_type      = 1
dW_TAG_lexical_block   = 11
dW_TAG_pointer_type    = 15
dW_TAG_compile_unit    = 17
dW_TAG_structure_type  = 19
dW_TAG_typedef         = 22
dW_TAG_subroutine_type = 32
dW_TAG_subrange_type   = 33
dW_TAG_base_type       = 36
dW_TAG_file_type       = 41
dW_TAG_subprogram      = 46
dW_TAG_variable        = 52
dW_TAG_auto_variable   = 256
dW_TAG_arg_variable    = 257

dW_TAG_ghc_src_note    = 0x5b00

-- * Dwarf attributes
dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
  dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word
dW_AT_name              = 0x03
dW_AT_stmt_list         = 0x10
dW_AT_low_pc            = 0x11
dW_AT_high_pc           = 0x12
dW_AT_language          = 0x13
dW_AT_comp_dir          = 0x1b
dW_AT_producer          = 0x25
dW_AT_external          = 0x3f
dW_AT_frame_base        = 0x40
dW_AT_use_UTF8          = 0x53
dW_AT_MIPS_linkage_name = 0x2007

-- * Custom DWARF attributes
-- Chosen a more or less random section of the vendor-extensible region

-- ** Describing C-- blocks
-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks
dW_AT_ghc_tick_parent :: Word
dW_AT_ghc_tick_parent     = 0x2b20

-- ** Describing source notes
-- These appear in DW_TAG_ghc_src_note DIEs
dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,
  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,
  dW_AT_ghc_span_end_col :: Word
dW_AT_ghc_span_file       = 0x2b00
dW_AT_ghc_span_start_line = 0x2b01
dW_AT_ghc_span_start_col  = 0x2b02
dW_AT_ghc_span_end_line   = 0x2b03
dW_AT_ghc_span_end_col    = 0x2b04

-- * Abbrev declarations
dW_CHILDREN_no, dW_CHILDREN_yes :: Word8
dW_CHILDREN_no  = 0
dW_CHILDREN_yes = 1

dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word
dW_FORM_addr   = 0x01
dW_FORM_data2  = 0x05
dW_FORM_data4  = 0x06
dW_FORM_string = 0x08
dW_FORM_flag   = 0x0c
dW_FORM_block1 = 0x0a
dW_FORM_ref_addr     = 0x10
dW_FORM_ref4         = 0x13
dW_FORM_flag_present = 0x19

-- * Dwarf native types
dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,
  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word
dW_ATE_address       = 1
dW_ATE_boolean       = 2
dW_ATE_float         = 4
dW_ATE_signed        = 5
dW_ATE_signed_char   = 6
dW_ATE_unsigned      = 7
dW_ATE_unsigned_char = 8

-- * Call frame information
dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,
  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,
  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,
  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,
  dW_CFA_offset :: Word8
dW_CFA_set_loc            = 0x01
dW_CFA_undefined          = 0x07
dW_CFA_same_value         = 0x08
dW_CFA_def_cfa            = 0x0c
dW_CFA_def_cfa_offset     = 0x0e
dW_CFA_def_cfa_expression = 0x0f
dW_CFA_expression         = 0x10
dW_CFA_offset_extended_sf = 0x11
dW_CFA_def_cfa_sf         = 0x12
dW_CFA_def_cfa_offset_sf  = 0x13
dW_CFA_val_offset         = 0x14
dW_CFA_val_expression     = 0x16
dW_CFA_offset             = 0x80

-- * Operations
dW_OP_addr, dW_OP_deref, dW_OP_consts,
  dW_OP_minus, dW_OP_mul, dW_OP_plus,
  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
dW_OP_addr           = 0x03
dW_OP_deref          = 0x06
dW_OP_consts         = 0x11
dW_OP_minus          = 0x1c
dW_OP_mul            = 0x1e
dW_OP_plus           = 0x22
dW_OP_lit0           = 0x30
dW_OP_breg0          = 0x70
dW_OP_call_frame_cfa = 0x9c

-- * Dwarf section declarations
dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
dwarfInfoSection    = dwarfSection "info"
dwarfAbbrevSection  = dwarfSection "abbrev"
dwarfLineSection    = dwarfSection "line"
dwarfFrameSection   = dwarfSection "frame"
dwarfGhcSection     = dwarfSection "ghc"
dwarfARangesSection = dwarfSection "aranges"

dwarfSection :: String -> SDoc
dwarfSection name = sdocWithPlatform $ \plat ->
  case platformOS plat of
    os | osElfTarget os
       -> text "\t.section .debug_" <> text name <> text ",\"\","
          <> sectionType "progbits"
       | osMachOTarget os
       -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
       | otherwise
       -> text "\t.section .debug_" <> text name <> text ",\"dr\""

-- * Dwarf section labels
dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString
dwarfInfoLabel   = sLit ".Lsection_info"
dwarfAbbrevLabel = sLit ".Lsection_abbrev"
dwarfLineLabel   = sLit ".Lsection_line"
dwarfFrameLabel  = sLit ".Lsection_frame"

-- | Mapping of registers to DWARF register numbers
dwarfRegNo :: Platform -> Reg -> Word8
dwarfRegNo p r = case platformArch p of
  ArchX86
    | r == eax  -> 0
    | r == ecx  -> 1  -- yes, no typo
    | r == edx  -> 2
    | r == ebx  -> 3
    | r == esp  -> 4
    | r == ebp  -> 5
    | r == esi  -> 6
    | r == edi  -> 7
  ArchX86_64
    | r == rax  -> 0
    | r == rdx  -> 1 -- this neither. The order GCC allocates registers in?
    | r == rcx  -> 2
    | r == rbx  -> 3
    | r == rsi  -> 4
    | r == rdi  -> 5
    | r == rbp  -> 6
    | r == rsp  -> 7
    | r == r8   -> 8
    | r == r9   -> 9
    | r == r10  -> 10
    | r == r11  -> 11
    | r == r12  -> 12
    | r == r13  -> 13
    | r == r14  -> 14
    | r == r15  -> 15
    | r == xmm0 -> 17
    | r == xmm1 -> 18
    | r == xmm2 -> 19
    | r == xmm3 -> 20
    | r == xmm4 -> 21
    | r == xmm5 -> 22
    | r == xmm6 -> 23
    | r == xmm7 -> 24
    | r == xmm8 -> 25
    | r == xmm9 -> 26
    | r == xmm10 -> 27
    | r == xmm11 -> 28
    | r == xmm12 -> 29
    | r == xmm13 -> 30
    | r == xmm14 -> 31
    | r == xmm15 -> 32
  _other -> error "dwarfRegNo: Unsupported platform or unknown register!"

-- | Virtual register number to use for return address.
dwarfReturnRegNo :: Platform -> Word8
dwarfReturnRegNo p
  -- We "overwrite" IP with our pseudo register - that makes sense, as
  -- when using this mechanism gdb already knows the IP anyway. Clang
  -- does this too, so it must be safe.
  = case platformArch p of
    ArchX86    -> 8  -- eip
    ArchX86_64 -> 16 -- rip
    _other     -> error "dwarfReturnRegNo: Unsupported platform!"


module Dwarf.Types
  ( -- * Dwarf information
    DwarfInfo(..)
  , pprDwarfInfo
  , pprAbbrevDecls
    -- * Dwarf address range table
  , DwarfARange(..)
  , pprDwarfARanges
    -- * Dwarf frame
  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
  , pprDwarfFrame
    -- * Utilities
  , pprByte
  , pprHalf
  , pprData4'
  , pprDwWord
  , pprWord
  , pprLEBWord
  , pprLEBInt
  , wordAlign
  , sectionOffset
  )
  where

import GhcPrelude

import Debug
import CLabel
import CmmExpr         ( GlobalReg(..) )
import Encoding
import FastString
import Outputable
import Platform
import Unique
import Reg
import SrcLoc
import Util

import Dwarf.Constants

import qualified Data.ByteString as BS
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad (zipWithM, join)
import Data.Bits
import qualified Data.Map as Map
import Data.Word
import Data.Char

import CodeGen.Platform

-- | Individual dwarf records. Each one will be encoded as an entry in
-- the @.debug_info@ section.
data DwarfInfo
  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
                     , dwName :: String
                     , dwProducer :: String
                     , dwCompDir :: String
                     , dwLowLabel :: CLabel
                     , dwHighLabel :: CLabel
                     , dwLineLabel :: PtrString }
  | DwarfSubprogram { dwChildren :: [DwarfInfo]
                    , dwName :: String
                    , dwLabel :: CLabel
                    , dwParent :: Maybe CLabel
                      -- ^ label of DIE belonging to the parent tick
                    }
  | DwarfBlock { dwChildren :: [DwarfInfo]
               , dwLabel :: CLabel
               , dwMarker :: Maybe CLabel
               }
  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
                 }

-- | Abbreviation codes used for encoding above records in the
-- @.debug_info@ section.
data DwarfAbbrev
  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
  | DwAbbrCompileUnit
  | DwAbbrSubprogram
  | DwAbbrSubprogramWithParent
  | DwAbbrBlockWithoutCode
  | DwAbbrBlock
  | DwAbbrGhcSrcNote
  deriving (Eq, Enum)

-- | Generate assembly for the given abbreviation code
pprAbbrev :: DwarfAbbrev -> SDoc
pprAbbrev = pprLEBWord . fromIntegral . fromEnum

-- | Abbreviation declaration. This explains the binary encoding we
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
pprAbbrevDecls :: Bool -> SDoc
pprAbbrevDecls haveDebugLine =
  let mkAbbrev abbr tag chld flds =
        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
      -- These are shared between DwAbbrSubprogram and
      -- DwAbbrSubprogramWithParent
      subprogramAttrs =
           [ (dW_AT_name, dW_FORM_string)
           , (dW_AT_MIPS_linkage_name, dW_FORM_string)
           , (dW_AT_external, dW_FORM_flag)
           , (dW_AT_low_pc, dW_FORM_addr)
           , (dW_AT_high_pc, dW_FORM_addr)
           , (dW_AT_frame_base, dW_FORM_block1)
           ]
  in dwarfAbbrevSection $$
     ptext dwarfAbbrevLabel <> colon $$
     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
       ([(dW_AT_name,     dW_FORM_string)
       , (dW_AT_producer, dW_FORM_string)
       , (dW_AT_language, dW_FORM_data4)
       , (dW_AT_comp_dir, dW_FORM_string)
       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body
       , (dW_AT_low_pc,   dW_FORM_addr)
       , (dW_AT_high_pc,  dW_FORM_addr)
       ] ++
       (if haveDebugLine
        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
        else [])) $$
     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
       subprogramAttrs $$
     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
       [ (dW_AT_name, dW_FORM_string)
       ] $$
     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
       [ (dW_AT_name, dW_FORM_string)
       , (dW_AT_low_pc, dW_FORM_addr)
       , (dW_AT_high_pc, dW_FORM_addr)
       ] $$
     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
       [ (dW_AT_ghc_span_file, dW_FORM_string)
       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
       ] $$
     pprByte 0

-- | Generate assembly for DWARF data
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
  = case d of
      DwarfCompileUnit {}  -> hasChildren
      DwarfSubprogram {}   -> hasChildren
      DwarfBlock {}        -> hasChildren
      DwarfSrcNote {}      -> noChildren
  where
    hasChildren =
        pprDwarfInfoOpen haveSrc d $$
        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
        pprDwarfInfoClose
    noChildren = pprDwarfInfoOpen haveSrc d

-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
                                           highLabel lineLbl) =
  pprAbbrev DwAbbrCompileUnit
  $$ pprString name
  $$ pprString producer
  $$ pprData4 dW_LANG_Haskell
  $$ pprString compDir
  $$ pprWord (ppr lowLabel)
  $$ pprWord (ppr highLabel)
  $$ if haveSrc
     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
     else empty
pprDwarfInfoOpen _ (DwarfSubprogram _ name label
                                    parent) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev abbrev
  $$ pprString name
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
  $$ pprFlag (externallyVisibleCLabel label)
  $$ pprWord (ppr label)
  $$ pprWord (ppr $ mkAsmTempEndLabel label)
  $$ pprByte 1
  $$ pprByte dW_OP_call_frame_cfa
  $$ parentValue
  where
    abbrev = case parent of Nothing -> DwAbbrSubprogram
                            Just _  -> DwAbbrSubprogramWithParent
    parentValue = maybe empty pprParentDie parent
    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev DwAbbrBlockWithoutCode
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
  ppr (mkAsmTempDieLabel label) <> colon
  $$ pprAbbrev DwAbbrBlock
  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
  $$ pprWord (ppr marker)
  $$ pprWord (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ (DwarfSrcNote ss) =
  pprAbbrev DwAbbrGhcSrcNote
  $$ pprString' (ftext $ srcSpanFile ss)
  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)

-- | Close a DWARF info record with children
pprDwarfInfoClose :: SDoc
pprDwarfInfoClose = pprAbbrev DwAbbrNull

-- | A DWARF address range. This is used by the debugger to quickly locate
-- which compilation unit a given address belongs to. This type assumes
-- a non-segmented address-space.
data DwarfARange
  = DwarfARange
    { dwArngStartLabel :: CLabel
    , dwArngEndLabel   :: CLabel
    }

-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
  let wordSize = platformWordSize plat
      paddingSize = 4 :: Int
      -- header is 12 bytes long.
      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
      -- pad such that first entry begins at multiple of entry size.
      pad n = vcat $ replicate n $ pprByte 0
      initialLength = 8 + paddingSize + 2*2*wordSize
  in pprDwWord (ppr initialLength)
     $$ pprHalf 2
     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
                      (ptext dwarfInfoLabel)
     $$ pprByte (fromIntegral wordSize)
     $$ pprByte 0
     $$ pad paddingSize
     -- body
     $$ vcat (map pprDwarfARange arngs)
     -- terminus
     $$ pprWord (char '0')
     $$ pprWord (char '0')

pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
  where
    length = ppr (dwArngEndLabel arng)
             <> char '-' <> ppr (dwArngStartLabel arng)

-- | Information about unwind instructions for a procedure. This
-- corresponds to a "Common Information Entry" (CIE) in DWARF.
data DwarfFrame
  = DwarfFrame
    { dwCieLabel :: CLabel
    , dwCieInit  :: UnwindTable
    , dwCieProcs :: [DwarfFrameProc]
    }

-- | Unwind instructions for an individual procedure. Corresponds to a
-- "Frame Description Entry" (FDE) in DWARF.
data DwarfFrameProc
  = DwarfFrameProc
    { dwFdeProc    :: CLabel
    , dwFdeHasInfo :: Bool
    , dwFdeBlocks  :: [DwarfFrameBlock]
      -- ^ List of blocks. Order must match asm!
    }

-- | Unwind instructions for a block. Will become part of the
-- containing FDE.
data DwarfFrameBlock
  = DwarfFrameBlock
    { dwFdeBlkHasInfo :: Bool
    , dwFdeUnwind     :: [UnwindPoint]
      -- ^ these unwind points must occur in the same order as they occur
      -- in the block
    }

instance Outputable DwarfFrameBlock where
  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds

-- | Header for the @.debug_frame@ section. Here we emit the "Common
-- Information Entry" record that etablishes general call frame
-- parameters and the default stack layout.
pprDwarfFrame :: DwarfFrame -> SDoc
pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
  = sdocWithPlatform $ \plat ->
    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
        cieEndLabel = mkAsmTempEndLabel cieLabel
        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
        spReg       = dwarfGlobalRegNo plat Sp
        retReg      = dwarfReturnRegNo plat
        wordSize    = platformWordSize plat
        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)

        -- Preserve C stack pointer: This necessary to override that default
        -- unwinding behavior of setting $sp = CFA.
        preserveSp = case platformArch plat of
          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4
          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
          _          -> empty
    in vcat [ ppr cieLabel <> colon
            , pprData4' length -- Length of CIE
            , ppr cieStartLabel <> colon
            , pprData4' (text "-1")
                               -- Common Information Entry marker (-1 = 0xf..f)
            , pprByte 3        -- CIE version (we require DWARF 3)
            , pprByte 0        -- Augmentation (none)
            , pprByte 1        -- Code offset multiplicator
            , pprByte (128-fromIntegral wordSize)
                               -- Data offset multiplicator
                               -- (stacks grow down => "-w" in signed LEB128)
            , pprByte retReg   -- virtual register holding return address
            ] $$
       -- Initial unwind table
       vcat (map pprInit $ Map.toList cieInit) $$
       vcat [ -- RET = *CFA
              pprByte (dW_CFA_offset+retReg)
            , pprByte 0

              -- Preserve C stack pointer
            , preserveSp

              -- Sp' = CFA
              -- (we need to set this manually as our (STG) Sp register is
              -- often not the architecture's default stack register)
            , pprByte dW_CFA_val_offset
            , pprLEBWord (fromIntegral spReg)
            , pprLEBWord 0
            ] $$
       wordAlign $$
       ppr cieEndLabel <> colon $$
       -- Procedure unwind tables
       vcat (map (pprFrameProc cieLabel cieInit) procs)

-- | Writes a "Frame Description Entry" for a procedure. This consists
-- mainly of referencing the CIE and writing state machine
-- instructions to describe how the frame base (CFA) changes.
pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
        procEnd     = mkAsmTempEndLabel procLbl
        ifInfo str  = if hasInfo then text str else empty
                      -- see [Note: Info Offset]
    in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
            , ppr fdeLabel <> colon
            , pprData4' (ppr frameLbl <> char '-' <>
                         ptext dwarfFrameLabel)    -- Reference to CIE
            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
            , pprWord (ppr procEnd <> char '-' <>
                       ppr procLbl <> ifInfo "+1") -- Block byte length
            ] $$
       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
       wordAlign $$
       ppr fdeEndLabel <> colon

-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
  where
    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
        let -- Did a register's unwind expression change?
            isChanged :: GlobalReg -> Maybe UnwindExpr
                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
            isChanged g new
                -- the value didn't change
              | Just new == old = Nothing
                -- the value was and still is undefined
              | Nothing <- old
              , Nothing <- new  = Nothing
                -- the value changed
              | otherwise       = Just (join old, new)
              where
                old = Map.lookup g oldUws

            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws

        in if oldUws == uws
             then (empty, oldUws)
             else let -- see [Note: Info Offset]
                      needsOffset = firstDecl && hasInfo
                      lblDoc = ppr lbl <>
                               if needsOffset then text "-1" else empty
                      doc = sdocWithPlatform $ \plat ->
                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
                           vcat (map (uncurry $ pprSetUnwind plat) changed)
                  in (doc, uws)

-- Note [Info Offset]
--
-- GDB was pretty much written with C-like programs in mind, and as a
-- result they assume that once you have a return address, it is a
-- good idea to look at (PC-1) to unwind further - as that's where the
-- "call" instruction is supposed to be.
--
-- Now on one hand, code generated by GHC looks nothing like what GDB
-- expects, and in fact going up from a return pointer is guaranteed
-- to land us inside an info table! On the other hand, that actually
-- gives us some wiggle room, as we expect IP to never *actually* end
-- up inside the info table, so we can "cheat" by putting whatever GDB
-- expects to see there. This is probably pretty safe, as GDB cannot
-- assume (PC-1) to be a valid code pointer in the first place - and I
-- have seen no code trying to correct this.
--
-- Note that this will not prevent GDB from failing to look-up the
-- correct function name for the frame, as that uses the symbol table,
-- which we can not manipulate as easily.
--
-- There's a GDB patch to address this at [1]. At the moment of writing
-- it's not merged, so I recommend building GDB with the patch if you
-- care about unwinding. The hack above doesn't cover every case.
--
-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html

-- | Get DWARF register ID for a given GlobalReg
dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg

-- | Generate code for setting the unwind information for a register,
-- optimized using its known old value in the table. Note that "Sp" is
-- special: We see it as synonym for the CFA.
pprSetUnwind :: Platform
             -> GlobalReg
                -- ^ the register to produce an unwinding table entry for
             -> (Maybe UnwindExpr, Maybe UnwindExpr)
                -- ^ the old and new values of the register
             -> SDoc
pprSetUnwind plat g  (_, Nothing)
  = pprUndefUnwind plat g
pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
  = if o' >= 0
    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
pprSetUnwind plat Sp (_, Just (UwReg s' o'))
  = if o' >= 0
    then pprByte dW_CFA_def_cfa $$
         pprLEBRegNo plat s' $$
         pprLEBWord (fromIntegral o')
    else pprByte dW_CFA_def_cfa_sf $$
         pprLEBRegNo plat s' $$
         pprLEBInt o'
pprSetUnwind _    Sp (_, Just uw)
  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
  | otherwise
  = pprByte dW_CFA_offset_extended_sf $$
    pprLEBRegNo plat g $$
    pprLEBInt o
pprSetUnwind plat g  (_, Just (UwDeref uw))
  = pprByte dW_CFA_expression $$
    pprLEBRegNo plat g $$
    pprUnwindExpr True uw
pprSetUnwind plat g  (_, Just (UwReg g' 0))
  | g == g'
  = pprByte dW_CFA_same_value $$
    pprLEBRegNo plat g
pprSetUnwind plat g  (_, Just uw)
  = pprByte dW_CFA_val_expression $$
    pprLEBRegNo plat g $$
    pprUnwindExpr True uw

-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
-- encoded number.
pprLEBRegNo :: Platform -> GlobalReg -> SDoc
pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat

-- | Generates a DWARF expression for the given unwind expression. If
-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
-- mentioned.
pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
pprUnwindExpr spIsCFA expr
  = sdocWithPlatform $ \plat ->
    let pprE (UwConst i)
          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
        pprE (UwReg Sp i) | spIsCFA
                             = if i == 0
                               then pprByte dW_OP_call_frame_cfa
                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
                               pprLEBInt i
        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)
        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
       -- computed as the difference of the following local labels 2: and 1:
       text "1:" $$
       pprE expr $$
       text "2:"

-- | Generate code for re-setting the unwind information for a
-- register to @undefined@
pprUndefUnwind :: Platform -> GlobalReg -> SDoc
pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
                         pprLEBRegNo plat g

-- | Align assembly at (machine) word boundary
wordAlign :: SDoc
wordAlign = sdocWithPlatform $ \plat ->
  text "\t.align " <> case platformOS plat of
    OSDarwin -> case platformWordSize plat of
      8      -> text "3"
      4      -> text "2"
      _other -> error "wordAlign: Unsupported word size!"
    _other   -> ppr (platformWordSize plat)

-- | Assembly for a single byte of constant DWARF data
pprByte :: Word8 -> SDoc
pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)

-- | Assembly for a two-byte constant integer
pprHalf :: Word16 -> SDoc
pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)

-- | Assembly for a constant DWARF flag
pprFlag :: Bool -> SDoc
pprFlag f = pprByte (if f then 0xff else 0x00)

-- | Assembly for 4 bytes of dynamic DWARF data
pprData4' :: SDoc -> SDoc
pprData4' x = text "\t.long " <> x

-- | Assembly for 4 bytes of constant DWARF data
pprData4 :: Word -> SDoc
pprData4 = pprData4' . ppr

-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
-- we are generating 32 bit DWARF.
pprDwWord :: SDoc -> SDoc
pprDwWord = pprData4'

-- | Assembly for a machine word of dynamic data. Depends on the
-- architecture we are currently generating code for.
pprWord :: SDoc -> SDoc
pprWord s = (<> s) . sdocWithPlatform $ \plat ->
  case platformWordSize plat of
    4 -> text "\t.long "
    8 -> text "\t.quad "
    n -> panic $ "pprWord: Unsupported target platform word length " ++
                 show n ++ "!"

-- | Prints a number in "little endian base 128" format. The idea is
-- to optimize for small numbers by stopping once all further bytes
-- would be 0. The highest bit in every byte signals whether there
-- are further bytes to read.
pprLEBWord :: Word -> SDoc
pprLEBWord x | x < 128   = pprByte (fromIntegral x)
             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
                           pprLEBWord (x `shiftR` 7)

-- | Same as @pprLEBWord@, but for a signed number
pprLEBInt :: Int -> SDoc
pprLEBInt x | x >= -64 && x < 64
                        = pprByte (fromIntegral (x .&. 127))
            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
                          pprLEBInt (x `shiftR` 7)

-- | Generates a dynamic null-terminated string. If required the
-- caller needs to make sure that the string is escaped properly.
pprString' :: SDoc -> SDoc
pprString' str = text "\t.asciz \"" <> str <> char '"'

-- | Generate a string constant. We take care to escape the string.
pprString :: String -> SDoc
pprString str
  = pprString' $ hcat $ map escapeChar $
    if str `lengthIs` utf8EncodedLength str
    then str
    else map (chr . fromIntegral) $ BS.unpack $ bytesFS $ mkFastString str

-- | Escape a single non-unicode character
escapeChar :: Char -> SDoc
escapeChar '\\' = text "\\\\"
escapeChar '\"' = text "\\\""
escapeChar '\n' = text "\\n"
escapeChar c
  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
  = char c
  | otherwise
  = char '\\' <> char (intToDigit (ch `div` 64)) <>
                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
                 char (intToDigit (ch `mod` 8))
  where ch = ord c

-- | Generate an offset into another section. This is tricky because
-- this is handled differently depending on platform: Mac Os expects
-- us to calculate the offset using assembler arithmetic. Linux expects
-- us to just reference the target directly, and will figure out on
-- their own that we actually need an offset. Finally, Windows has
-- a special directive to refer to relative offsets. Fun.
sectionOffset :: SDoc -> SDoc -> SDoc
sectionOffset target section = sdocWithPlatform $ \plat ->
  case platformOS plat of
    OSDarwin  -> pprDwWord (target <> char '-' <> section)
    OSMinGW32 -> text "\t.secrel32 " <> target
    _other    -> pprDwWord target