accelerate-llvm-1.4.0.0: src/Data/Array/Accelerate/LLVM/CodeGen/Profile.hs
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module : Data.Array.Accelerate.LLVM.CodeGen.Profile
-- Copyright : [2015..2020] The Accelerate Team
-- License : BSD3
--
-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability : experimental
-- Portability : non-portable (GHC extensions)
--
module Data.Array.Accelerate.LLVM.CodeGen.Profile (
zone_begin, zone_begin_alloc,
zone_end,
) where
import LLVM.AST.Type.Constant
import LLVM.AST.Type.Downcast
import LLVM.AST.Type.Function
import LLVM.AST.Type.GetElementPtr
import LLVM.AST.Type.Global
import LLVM.AST.Type.Name
import LLVM.AST.Type.Operand
import LLVM.AST.Type.Representation
import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty as LP
import Data.Array.Accelerate.LLVM.CodeGen.Base
import Data.Array.Accelerate.LLVM.CodeGen.Constant
import Data.Array.Accelerate.LLVM.CodeGen.IR
import Data.Array.Accelerate.LLVM.CodeGen.Monad
import Data.Array.Accelerate.Sugar.Elt
import Data.Array.Accelerate.Debug.Internal ( tracyIsEnabled, SrcLoc, Zone )
import Control.Monad
import Data.Char
call' :: GlobalFunction args t -> CodeGen arch (Operands t)
call' f = call f [NoUnwind, NoDuplicate]
global_string :: String -> CodeGen arch (Name (Ptr (LLArray Word8)), Word64)
global_string str = do
let str0 = str ++ "\0"
l = fromIntegral (length str0)
--
nm <- freshGlobalName
_ <- declareGlobalVar $ LP.Global
{ LP.globalSym = nameToPrettyS nm
, LP.globalAttrs = LP.GlobalAttrs
{ LP.gaLinkage = Just LP.Private
, LP.gaVisibility = Nothing
, LP.gaAddrSpace = LP.defaultAddrSpace
, LP.gaConstant = True }
, LP.globalType = LP.Array l (LP.PrimType (LP.Integer 8))
, LP.globalValue = Just $ LP.ValArray (LP.PrimType (LP.Integer 8)) [ LP.ValInteger (toInteger (ord c)) | c <- str0 ]
, LP.globalAlign = Nothing
, LP.globalMetadata = mempty
}
return (nm, l)
derefGlobalString :: Word64 -> Name (Ptr (LLArray Word8)) -> Constant (Ptr Word8)
derefGlobalString slen sname =
-- Global references are _pointers_ to their values. A string is an
-- [_ x i8], hence the global reference is an [_ x i8]*. The GEP needs
-- to index the outer pointer (with a 0) and index the array (at index
-- 0) to address the first i8 in the string; GEP then returns a pointer
-- to this i8.
ConstantGetElementPtr $ GEP
(PrimType (ArrayPrimType slen scalarType))
(GlobalReference (PrimType (PtrPrimType (ArrayPrimType slen scalarType) defaultAddrSpace)) sname)
(ScalarConstant scalarType 0 :: Constant Int32)
(GEPArray (ScalarConstant scalarType 0 :: Constant Int32) (GEPEmpty primType))
-- struct ___tracy_source_location_data
-- {
-- const char* name;
-- const char* function;
-- const char* file;
-- uint32_t line;
-- uint32_t color;
-- };
--
source_location_data :: String -> String -> String -> Int -> Word32 -> CodeGen arch (Name a)
source_location_data nm fun src line colour = do
let i8ptr_t = LP.PtrTo (LP.PrimType (LP.Integer 8)) defaultAddrSpace
i32_t = LP.PrimType (LP.Integer 32)
_ <- typedef "___tracy_source_location_data" $ LP.Struct [ i8ptr_t, i8ptr_t, i8ptr_t, i32_t, i32_t ]
(s, sl) <- global_string src
(f, fl) <- global_string fun
(n, nl) <- global_string nm
let
source = if null src then NullPtrConstant type' else derefGlobalString sl s
function = if null fun then NullPtrConstant type' else derefGlobalString fl f
name = if null nm then NullPtrConstant type' else derefGlobalString nl n
--
v <- freshGlobalName
_ <- declareGlobalVar $ LP.Global
{ LP.globalSym = nameToPrettyS v
, LP.globalAttrs = LP.GlobalAttrs
{ LP.gaLinkage = Just LP.Internal
, LP.gaVisibility = Nothing
, LP.gaAddrSpace = LP.defaultAddrSpace
, LP.gaConstant = True }
, LP.globalType = LP.Alias (LP.Ident "___tracy_source_location_data")
, LP.globalValue = Just $
LP.ValStruct
[ downcast name
, downcast function
, downcast source
, LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger (toInteger line))
, LP.Typed (LP.PrimType (LP.Integer 32)) (LP.ValInteger (toInteger colour))
]
, LP.globalAlign = Just 8
, LP.globalMetadata = mempty
}
return v
alloc_srcloc_name
:: Int -- line
-> String -- source file
-> String -- function
-> String -- name
-> CodeGen arch (Operands SrcLoc)
alloc_srcloc_name l src fun nm
| not tracyIsEnabled = return (constant (eltR @SrcLoc) 0)
| otherwise = do
(s, sl) <- global_string src
(f, fl) <- global_string fun
(n, nl) <- global_string nm
let
line = ConstantOperand $ ScalarConstant scalarType (fromIntegral l :: Word32)
source = ConstantOperand $ if null src then NullPtrConstant type' else derefGlobalString sl s
function = ConstantOperand $ if null fun then NullPtrConstant type' else derefGlobalString fl f
name = ConstantOperand $ if null nm then NullPtrConstant type' else derefGlobalString nl n
sourceSz = ConstantOperand $ ScalarConstant scalarType (sl-1) -- null
functionSz = ConstantOperand $ ScalarConstant scalarType (fl-1) -- null
nameSz = ConstantOperand $ ScalarConstant scalarType (nl-1) -- null
--
call' $ Lam primType line
$ Lam primType source
$ Lam primType sourceSz
$ Lam primType function
$ Lam primType functionSz
$ Lam primType name
$ Lam primType nameSz
$ Body (type' @SrcLoc) (Just Tail) "___tracy_alloc_srcloc_name"
zone_begin
:: Int -- line
-> String -- source file
-> String -- function
-> String -- name
-> Word32 -- colour
-> CodeGen arch (Operands Zone)
zone_begin line src fun name colour
| not tracyIsEnabled = return (constant (eltR @SrcLoc) 0)
| otherwise = do
srcloc <- source_location_data name fun src line colour
let srcloc_ty = PtrPrimType (NamedPrimType "___tracy_source_location_data") defaultAddrSpace
--
call' $ Lam srcloc_ty (ConstantOperand (GlobalReference (PrimType srcloc_ty) srcloc))
$ Lam primType (ConstantOperand (ScalarConstant scalarType (1 :: Int32)))
$ Body (type' @SrcLoc) (Just Tail) "___tracy_emit_zone_begin"
zone_begin_alloc
:: Int -- line
-> String -- source file
-> String -- function
-> String -- name
-> Word32 -- colour
-> CodeGen arch (Operands Zone)
zone_begin_alloc line src fun name colour
| not tracyIsEnabled = return (constant (eltR @Zone) 0)
| otherwise = do
srcloc <- alloc_srcloc_name line src fun name
zone <- call' $ Lam primType (op primType srcloc)
$ Lam primType (ConstantOperand (ScalarConstant scalarType (1 :: Int32)))
$ Body (type' @SrcLoc) (Just Tail) "___tracy_emit_zone_begin_alloc"
when (colour /= 0) $
void . call' $ Lam primType (op primType zone)
$ Lam primType (ConstantOperand (ScalarConstant scalarType colour))
$ Body VoidType (Just Tail) "___tracy_emit_zone_color"
return zone
zone_end
:: Operands Zone
-> CodeGen arch ()
zone_end zone
| not tracyIsEnabled = return ()
| otherwise =
void . call' $ Lam primType (op primType zone)
$ Body VoidType (Just Tail) "___tracy_emit_zone_end"