{-# LANGUAGE CPP #-}

-- ----------------------------------------------------------------------------
-- | Pretty print helpers for the LLVM Code generator.
--
module LlvmCodeGen.Ppr (
        pprLlvmCmmDecl, pprLlvmData, infoSection
    ) where

#include "HsVersions.h"

import GhcPrelude

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Data

import CLabel
import Cmm

import FastString
import Outputable
import Unique

-- ----------------------------------------------------------------------------
-- * Top level
--

-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc
pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals :: [LMGlobal]
globals, types :: [LlvmType]
types) =
    let ppLlvmTys :: LlvmType -> SDoc
ppLlvmTys (LMAlias    a :: LlvmAlias
a) = LlvmAlias -> SDoc
ppLlvmAlias LlvmAlias
a
        ppLlvmTys (LMFunction f :: LlvmFunctionDecl
f) = LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl LlvmFunctionDecl
f
        ppLlvmTys _other :: LlvmType
_other         = SDoc
empty

        types' :: SDoc
types'   = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmType -> SDoc) -> [LlvmType] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LlvmType -> SDoc
ppLlvmTys [LlvmType]
types
        globals' :: SDoc
globals' = [LMGlobal] -> SDoc
ppLlvmGlobals [LMGlobal]
globals
    in SDoc
types' SDoc -> SDoc -> SDoc
$+$ SDoc
globals'


-- | Pretty print LLVM code
pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl (CmmData _ lmdata :: [LlvmData]
lmdata)
  = (SDoc, [LlvmVar]) -> LlvmM (SDoc, [LlvmVar])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmData -> SDoc) -> [LlvmData] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LlvmData -> SDoc
pprLlvmData [LlvmData]
lmdata, [])

pprLlvmCmmDecl (CmmProc mb_info :: Maybe CmmStatics
mb_info entry_lbl :: CLabel
entry_lbl live :: [GlobalReg]
live (ListGraph blks :: [GenBasicBlock LlvmStatement]
blks))
  = do let lbl :: CLabel
lbl = case Maybe CmmStatics
mb_info of
                     Nothing                   -> CLabel
entry_lbl
                     Just (Statics info_lbl :: CLabel
info_lbl _) -> CLabel
info_lbl
           link :: LlvmLinkageType
link = if CLabel -> Bool
externallyVisibleCLabel CLabel
lbl
                      then LlvmLinkageType
ExternallyVisible
                      else LlvmLinkageType
Internal
           lmblocks :: [LlvmBlock]
lmblocks = (GenBasicBlock LlvmStatement -> LlvmBlock)
-> [GenBasicBlock LlvmStatement] -> [LlvmBlock]
forall a b. (a -> b) -> [a] -> [b]
map (\(BasicBlock id :: BlockId
id stmts :: [LlvmStatement]
stmts) ->
                                LlvmBlockId -> [LlvmStatement] -> LlvmBlock
LlvmBlock (BlockId -> LlvmBlockId
forall a. Uniquable a => a -> LlvmBlockId
getUnique BlockId
id) [LlvmStatement]
stmts) [GenBasicBlock LlvmStatement]
blks

       LlvmFunctionDecl
funDec <- [GlobalReg] -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
llvmFunSig [GlobalReg]
live CLabel
lbl LlvmLinkageType
link
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let buildArg :: LlvmVar -> FastString
buildArg = String -> FastString
fsLit (String -> FastString)
-> (LlvmVar -> String) -> LlvmVar -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> (LlvmVar -> SDoc) -> LlvmVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> SDoc
ppPlainName
           funArgs :: [FastString]
funArgs = (LlvmVar -> FastString) -> [LlvmVar] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map LlvmVar -> FastString
buildArg (DynFlags -> [GlobalReg] -> [LlvmVar]
llvmFunArgs DynFlags
dflags [GlobalReg]
live)
           funSect :: LMSection
funSect = DynFlags -> FastString -> LMSection
llvmFunSection DynFlags
dflags (LlvmFunctionDecl -> FastString
decName LlvmFunctionDecl
funDec)

       -- generate the info table
       Maybe LlvmStatic
prefix <- case Maybe CmmStatics
mb_info of
                     Nothing -> Maybe LlvmStatic -> LlvmM (Maybe LlvmStatic)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LlvmStatic
forall a. Maybe a
Nothing
                     Just (Statics _ statics :: [CmmStatic]
statics) -> do
                       [LlvmStatic]
infoStatics <- (CmmStatic -> LlvmM LlvmStatic)
-> [CmmStatic] -> LlvmM [LlvmStatic]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmStatic -> LlvmM LlvmStatic
genData [CmmStatic]
statics
                       let infoTy :: LlvmType
infoTy = [LlvmType] -> LlvmType
LMStruct ([LlvmType] -> LlvmType) -> [LlvmType] -> LlvmType
forall a b. (a -> b) -> a -> b
$ (LlvmStatic -> LlvmType) -> [LlvmStatic] -> [LlvmType]
forall a b. (a -> b) -> [a] -> [b]
map LlvmStatic -> LlvmType
getStatType [LlvmStatic]
infoStatics
                       Maybe LlvmStatic -> LlvmM (Maybe LlvmStatic)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LlvmStatic -> LlvmM (Maybe LlvmStatic))
-> Maybe LlvmStatic -> LlvmM (Maybe LlvmStatic)
forall a b. (a -> b) -> a -> b
$ LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just (LlvmStatic -> Maybe LlvmStatic) -> LlvmStatic -> Maybe LlvmStatic
forall a b. (a -> b) -> a -> b
$ [LlvmStatic] -> LlvmType -> LlvmStatic
LMStaticStruc [LlvmStatic]
infoStatics LlvmType
infoTy


       let fun :: LlvmFunction
fun = LlvmFunctionDecl
-> [FastString]
-> [LlvmFuncAttr]
-> LMSection
-> Maybe LlvmStatic
-> [LlvmBlock]
-> LlvmFunction
LlvmFunction LlvmFunctionDecl
funDec [FastString]
funArgs [LlvmFuncAttr]
llvmStdFunAttrs LMSection
funSect
                              Maybe LlvmStatic
prefix [LlvmBlock]
lmblocks
           name :: FastString
name = LlvmFunctionDecl -> FastString
decName (LlvmFunctionDecl -> FastString) -> LlvmFunctionDecl -> FastString
forall a b. (a -> b) -> a -> b
$ LlvmFunction -> LlvmFunctionDecl
funcDecl LlvmFunction
fun
           defName :: FastString
defName = FastString
name FastString -> FastString -> FastString
`appendFS` String -> FastString
fsLit "$def"
           funcDecl' :: LlvmFunctionDecl
funcDecl' = (LlvmFunction -> LlvmFunctionDecl
funcDecl LlvmFunction
fun) { decName :: FastString
decName = FastString
defName }
           fun' :: LlvmFunction
fun' = LlvmFunction
fun { funcDecl :: LlvmFunctionDecl
funcDecl = LlvmFunctionDecl
funcDecl' }
           funTy :: LlvmType
funTy = LlvmFunctionDecl -> LlvmType
LMFunction LlvmFunctionDecl
funcDecl'
           funVar :: LlvmVar
funVar = FastString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar FastString
name
                                (LlvmType -> LlvmType
LMPointer LlvmType
funTy)
                                LlvmLinkageType
link
                                LMSection
forall a. Maybe a
Nothing
                                LMAlign
forall a. Maybe a
Nothing
                                LMConst
Alias
           defVar :: LlvmVar
defVar = FastString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar FastString
defName
                                (LlvmType -> LlvmType
LMPointer LlvmType
funTy)
                                (LlvmFunctionDecl -> LlvmLinkageType
funcLinkage LlvmFunctionDecl
funcDecl')
                                (LlvmFunction -> LMSection
funcSect LlvmFunction
fun)
                                (LlvmFunctionDecl -> LMAlign
funcAlign LlvmFunctionDecl
funcDecl')
                                LMConst
Alias
           alias :: LMGlobal
alias = LlvmVar -> Maybe LlvmStatic -> LMGlobal
LMGlobal LlvmVar
funVar
                            (LlvmStatic -> Maybe LlvmStatic
forall a. a -> Maybe a
Just (LlvmStatic -> Maybe LlvmStatic) -> LlvmStatic -> Maybe LlvmStatic
forall a b. (a -> b) -> a -> b
$ LlvmStatic -> LlvmType -> LlvmStatic
LMBitc (LlvmVar -> LlvmStatic
LMStaticPointer LlvmVar
defVar)
                                           LlvmType
i8Ptr)

       (SDoc, [LlvmVar]) -> LlvmM (SDoc, [LlvmVar])
forall (m :: * -> *) a. Monad m => a -> m a
return (LMGlobal -> SDoc
ppLlvmGlobal LMGlobal
alias SDoc -> SDoc -> SDoc
$+$ LlvmFunction -> SDoc
ppLlvmFunction LlvmFunction
fun', [])


-- | The section we are putting info tables and their entry code into, should
-- be unique since we process the assembly pattern matching this.
infoSection :: String
infoSection :: String
infoSection = "X98A__STRIP,__me"