
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmData to LLVM code.
--

module GHC.CmmToLlvm.Data (
        genLlvmData, genData
    ) where

import GHC.Prelude

import GHC.Llvm
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Config

import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.InitFini
import GHC.Cmm
import GHC.Platform

import GHC.Data.FastString
import GHC.Utils.Panic
import qualified Data.ByteString as BS

-- ----------------------------------------------------------------------------
-- * Constants
--

-- | The string appended to a variable name to create its structure type alias
structStr :: LMString
structStr = fsLit "_struct"

-- | The LLVM visibility of the label
linkage :: CLabel -> LlvmLinkageType
linkage lbl = if externallyVisibleCLabel lbl
              then ExternallyVisible else Internal

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

-- | Pass a CmmStatic section to an equivalent Llvm code.
genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
  | lbl == mkIndStaticInfoLabel
  , let labelInd (CmmLabelOff l _) = Just l
        labelInd (CmmLabel l) = Just l
        labelInd _ = Nothing
  , Just ind' <- labelInd ind
  , alias `mayRedirectTo` ind' = do
    label <- strCLabel_llvm alias
    label' <- strCLabel_llvm ind'
    let link     = linkage alias
        link'    = linkage ind'
        -- the LLVM type we give the alias is an empty struct type
        -- but it doesn't really matter, as the pointer is only
        -- used for (bit/int)casting.
        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])

        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
        -- we don't know the type of the indirectee here
        indType  = panic "will be filled by 'aliasify', later"
        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias

    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])

-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini.
genLlvmData (sect, statics)
  | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics)
  = let var = case initOrFini of
                IsInitArray -> fsLit "llvm.global_ctors"
                IsFiniArray -> fsLit "llvm.global_dtors"
    in genGlobalLabelArray var clbls

genLlvmData (sec, CmmStaticsRaw lbl xs) = do
    label <- strCLabel_llvm lbl
    static <- mapM genData xs
    lmsec <- llvmSection sec
    platform <- getPlatform
    let types   = map getStatType static

        strucTy = LMStruct types
        tyAlias = LMAlias (label `appendFS` structStr, strucTy)

        struct         = Just $ LMStaticStruc static tyAlias
        link           = linkage lbl
        align          = case sec of
                            Section CString _ -> if (platformArch platform == ArchS390X)
                                                    then Just 2 else Just 1
                            _                 -> Nothing
        const          = if sectionProtection sec == ReadOnlySection
                            then Constant else Global
        varDef         = LMGlobalVar label tyAlias link lmsec align const
        globDef        = LMGlobal varDef struct

    return ([globDef], [tyAlias])

-- | Produce an initializer or finalizer array declaration.
-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for
-- details.
genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData
genGlobalLabelArray var_nm clbls = do
    lbls <- mapM strCLabel_llvm clbls
    decls <- mapM mkFunDecl lbls
    let entries = map toArrayEntry lbls
        static = LMStaticArray entries arr_ty
        arr = LMGlobal arr_var (Just static)
    return ([arr], decls)
  where
    mkFunDecl :: LMString -> LlvmM LlvmType
    mkFunDecl fn_lbl = do
        let fn_ty = mkFunTy fn_lbl
        funInsert fn_lbl fn_ty
        return (fn_ty)

    toArrayEntry :: LMString -> LlvmStatic
    toArrayEntry fn_lbl =
        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global
            fn = LMStaticPointer fn_var
            null = LMStaticLit (LMNullLit i8Ptr)
            prio = LMStaticLit $ LMIntLit 0xffff i32
        in LMStaticStrucU [prio, fn, null] entry_ty

    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global
    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing
    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]
    arr_ty = LMArray (length clbls) entry_ty

-- | Format the section type part of a Cmm Section
llvmSectionType :: Platform -> SectionType -> FastString
llvmSectionType p t = case t of
    Text                    -> fsLit ".text"
    ReadOnlyData            -> case platformOS p of
                                 OSMinGW32 -> fsLit ".rdata"
                                 _         -> fsLit ".rodata"
    RelocatableReadOnlyData -> case platformOS p of
                                 OSMinGW32 -> fsLit ".rdata$rel.ro"
                                 _         -> fsLit ".data.rel.ro"
    ReadOnlyData16          -> case platformOS p of
                                 OSMinGW32 -> fsLit ".rdata$cst16"
                                 _         -> fsLit ".rodata.cst16"
    Data                    -> fsLit ".data"
    UninitialisedData       -> fsLit ".bss"
    CString                 -> case platformOS p of
                                 OSMinGW32 -> fsLit ".rdata$str"
                                 _         -> fsLit ".rodata.str"

    InitArray               -> panic "llvmSectionType: InitArray"
    FiniArray               -> panic "llvmSectionType: FiniArray"
    OtherSection _          -> panic "llvmSectionType: unknown section type"

-- | Format a Cmm Section into a LLVM section name
llvmSection :: Section -> LlvmM LMSection
llvmSection (Section t suffix) = do
  opts <- getConfig
  let splitSect = llvmCgSplitSection opts
      platform  = llvmCgPlatform     opts
  if not splitSect
  then return Nothing
  else do
    lmsuffix <- strCLabel_llvm suffix
    let result sep = Just (concatFS [llvmSectionType platform t
                                    , fsLit sep, lmsuffix])
    case platformOS platform of
      OSMinGW32 -> return (result "$")
      _         -> return (result ".")

-- ----------------------------------------------------------------------------
-- * Generate static data
--

-- | Handle static data
genData :: CmmStatic -> LlvmM LlvmStatic

genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal"
genData (CmmString str) = do
    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
                 (BS.unpack str)
        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
    return $ LMStaticArray ve (LMArray (length ve) i8)

genData (CmmUninitialised bytes)
    = return $ LMUninitType (LMArray bytes i8)

genData (CmmStaticLit lit)
    = genStaticLit lit

-- | Generate Llvm code for a static literal.
--
-- Will either generate the code or leave it unresolved if it is a 'CLabel'
-- which isn't yet known.
genStaticLit :: CmmLit -> LlvmM LlvmStatic
genStaticLit (CmmInt i w)
    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))

genStaticLit (CmmFloat r w)
    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))

genStaticLit (CmmVec ls)
    = do sls <- mapM toLlvmLit ls
         return $ LMStaticLit (LMVectorLit sls)
  where
    toLlvmLit :: CmmLit -> LlvmM LlvmLit
    toLlvmLit lit = do
      slit <- genStaticLit lit
      case slit of
        LMStaticLit llvmLit -> return llvmLit
        _ -> panic "genStaticLit"

-- Leave unresolved, will fix later
genStaticLit cmm@(CmmLabel l) = do
    var <- getGlobalPtr =<< strCLabel_llvm l
    platform <- getPlatform
    let ptr = LMStaticPointer var
        lmty = cmmToLlvmType $ cmmLitType platform cmm
    return $ LMPtoI ptr lmty

genStaticLit (CmmLabelOff label off) = do
    platform <- getPlatform
    var <- genStaticLit (CmmLabel label)
    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform)
    return $ LMAdd var offset

genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
    platform <- getPlatform
    var1 <- genStaticLit (CmmLabel l1)
    var2 <- genStaticLit (CmmLabel l2)
    let var
          | w == wordWidth platform = LMSub var1 var2
          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
    return $ LMAdd var offset

genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b

genStaticLit (CmmHighStackMark)
    = panic "genStaticLit: CmmHighStackMark unsupported!"
