{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Globals where

import Data.LLVM.BitCode.IR.Attrs
import Data.LLVM.BitCode.IR.Values
import Data.LLVM.BitCode.Record
import Data.LLVM.BitCode.Parse
import Text.LLVM.AST
import Text.LLVM.Labels

import Control.Monad (guard,mplus)
import Data.Bits (bit,shiftR,testBit)
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import Data.Word (Word32)


-- Global Variables ------------------------------------------------------------

type GlobalList = Seq.Seq PartialGlobal

data PartialGlobal = PartialGlobal
  { PartialGlobal -> Symbol
pgSym     :: Symbol
  , PartialGlobal -> GlobalAttrs
pgAttrs   :: GlobalAttrs
  , PartialGlobal -> Type
pgType    :: Type
  , PartialGlobal -> Maybe Int
pgValueIx :: Maybe Int
  , PartialGlobal -> Maybe Int
pgAlign   :: Maybe Align
  , PartialGlobal -> Map KindMd PValMd
pgMd      :: Map.Map KindMd PValMd
  } deriving Int -> PartialGlobal -> ShowS
[PartialGlobal] -> ShowS
PartialGlobal -> KindMd
(Int -> PartialGlobal -> ShowS)
-> (PartialGlobal -> KindMd)
-> ([PartialGlobal] -> ShowS)
-> Show PartialGlobal
forall a.
(Int -> a -> ShowS) -> (a -> KindMd) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PartialGlobal -> ShowS
showsPrec :: Int -> PartialGlobal -> ShowS
$cshow :: PartialGlobal -> KindMd
show :: PartialGlobal -> KindMd
$cshowList :: [PartialGlobal] -> ShowS
showList :: [PartialGlobal] -> ShowS
Show

-- [ pointer type, isconst, initid
-- , linkage, alignment, section, visibility, threadlocal
-- , unnamed_addr
-- ]
parseGlobalVar :: Int -> Record -> Parse PartialGlobal
parseGlobalVar :: Int -> Record -> Parse PartialGlobal
parseGlobalVar Int
n Record
r = KindMd -> Parse PartialGlobal -> Parse PartialGlobal
forall a. KindMd -> Parse a -> Parse a
label KindMd
"GLOBALVAR" (Parse PartialGlobal -> Parse PartialGlobal)
-> Parse PartialGlobal -> Parse PartialGlobal
forall a b. (a -> b) -> a -> b
$ do
  (Symbol
name, Int
offset) <- Int -> Record -> Parse (Symbol, Int)
oldOrStrtabName Int
n Record
r
  let field :: Int -> Match Field a -> Parse a
field Int
i = Record -> Int -> Match Field a -> Parse a
forall a. Record -> LookupField a
parseField Record
r (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
  Type
ptrty   <- Int -> Parse Type
getType (Int -> Parse Type) -> Parse Int -> Parse Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Match Field Int -> Parse Int
forall {a}. Int -> Match Field a -> Parse a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Word32
mask    <-             Int -> Match Field Word32 -> Parse Word32
forall {a}. Int -> Match Field a -> Parse a
field Int
1 Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
  let isconst :: Bool
isconst    = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Word32
mask :: Word32) Int
0
      explicitTy :: Bool
explicitTy = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit  Word32
mask            Int
1
  Int
initid  <-             Int -> Match Field Int -> Parse Int
forall {a}. Int -> Match Field a -> Parse a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Linkage
link    <-             Int -> Match Field Linkage -> Parse Linkage
forall {a}. Int -> Match Field a -> Parse a
field Int
3 Match Field Linkage
linkage

  Maybe Int
mbAlign <- if [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
                then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Parse Int -> Parse (Maybe Int)
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> Match Field Int -> Parse Int
forall {a}. Int -> Match Field a -> Parse a
field Int
4 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                else Maybe Int -> Parse (Maybe Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
  Visibility
vis <- if [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset) Bool -> Bool -> Bool
&& Bool -> Bool
not (Linkage
link Linkage -> [Linkage] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Linkage
Internal, Linkage
Private])
                then Int -> Match Field Visibility -> Parse Visibility
forall {a}. Int -> Match Field a -> Parse a
field Int
6 Match Field Visibility
visibility
                else Visibility -> Parse Visibility
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Visibility
DefaultVisibility

  Type
ty <- if Bool
explicitTy
           then Type -> Parse Type
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ptrty
           else Type -> Parse Type
forall (m :: * -> *). MonadPlus m => Type -> m Type
elimPtrTo Type
ptrty Parse Type -> Parse Type -> Parse Type
forall a. Parse a -> Parse a -> Parse a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (KindMd -> Parse Type
forall a. KindMd -> Parse a
forall (m :: * -> *) a. MonadFail m => KindMd -> m a
fail (KindMd -> Parse Type) -> KindMd -> Parse Type
forall a b. (a -> b) -> a -> b
$ KindMd
"Invalid type for value: " KindMd -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> KindMd
forall a. Show a => a -> KindMd
show Type
ptrty)

  Int
_       <- Typed PValue -> Parse Int
pushValue (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed (Type -> Type
forall ident. Type' ident -> Type' ident
PtrTo Type
ty) (Symbol -> PValue
forall lab. Symbol -> Value' lab
ValSymbol Symbol
name))
  let valid :: Maybe Int
valid | Int
initid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe Int
forall a. Maybe a
Nothing
            | Bool
otherwise   = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
initid Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      attrs :: GlobalAttrs
attrs = GlobalAttrs
        { gaLinkage :: Maybe Linkage
gaLinkage    = Linkage -> Maybe Linkage
forall a. a -> Maybe a
Just Linkage
link
        , gaVisibility :: Maybe Visibility
gaVisibility = Visibility -> Maybe Visibility
forall a. a -> Maybe a
Just Visibility
vis
        , gaConstant :: Bool
gaConstant   = Bool
isconst
        }

  PartialGlobal -> Parse PartialGlobal
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialGlobal
    { pgSym :: Symbol
pgSym     = Symbol
name
    , pgAttrs :: GlobalAttrs
pgAttrs   = GlobalAttrs
attrs
    , pgType :: Type
pgType    = Type
ty
    , pgValueIx :: Maybe Int
pgValueIx = Maybe Int
valid
    , pgAlign :: Maybe Int
pgAlign   = do
        Int
b <- Maybe Int
mbAlign
        let aval :: Int
aval = Int -> Int
forall a. Bits a => Int -> a
bit Int
b Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
aval Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
        Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
aval
    , pgMd :: Map KindMd PValMd
pgMd      = Map KindMd PValMd
forall k a. Map k a
Map.empty
    }

finalizeGlobal :: PartialGlobal -> Parse Global
finalizeGlobal :: PartialGlobal -> Parse Global
finalizeGlobal PartialGlobal
pg = case PartialGlobal -> Maybe Int
pgValueIx PartialGlobal
pg of
  Maybe Int
Nothing -> Finalize Global -> Parse Global
forall a. Finalize a -> Parse a
liftFinalize (Finalize Global -> Parse Global)
-> Finalize Global -> Parse Global
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Finalize Global
mkGlobal Maybe Value
forall a. Maybe a
Nothing
  Just Int
ix -> do
    Typed PValue
tv <- Type -> Int -> Parse (Typed PValue)
getFnValueById (PartialGlobal -> Type
pgType PartialGlobal
pg) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ix)
    Value
val <- Finalize Value -> Parse Value
forall a. Finalize a -> Parse a
liftFinalize (Finalize Value -> Parse Value) -> Finalize Value -> Parse Value
forall a b. (a -> b) -> a -> b
$ (Maybe Symbol -> Int -> Finalize BlockLabel)
-> PValue -> Finalize Value
forall (f :: * -> *) (m :: * -> *) a b.
(HasLabel f, Applicative m) =>
(Maybe Symbol -> a -> m b) -> f a -> m (f b)
forall (m :: * -> *) a b.
Applicative m =>
(Maybe Symbol -> a -> m b) -> Value' a -> m (Value' b)
relabel ((Int -> Finalize BlockLabel)
-> Maybe Symbol -> Int -> Finalize BlockLabel
forall a b. a -> b -> a
const Int -> Finalize BlockLabel
requireBbEntryName) (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
tv)
    Finalize Global -> Parse Global
forall a. Finalize a -> Parse a
liftFinalize (Finalize Global -> Parse Global)
-> Finalize Global -> Parse Global
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Finalize Global
mkGlobal (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
val)
  where
  mkGlobal :: Maybe Value -> Finalize Global
mkGlobal Maybe Value
mval =
    do Map KindMd (ValMd' BlockLabel)
md <- (PValMd -> Finalize (ValMd' BlockLabel))
-> Map KindMd PValMd -> Finalize (Map KindMd (ValMd' BlockLabel))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map KindMd a -> m (Map KindMd b)
mapM ((Maybe Symbol -> Int -> Finalize BlockLabel)
-> PValMd -> Finalize (ValMd' BlockLabel)
forall (f :: * -> *) (m :: * -> *) a b.
(HasLabel f, Applicative m) =>
(Maybe Symbol -> a -> m b) -> f a -> m (f b)
forall (m :: * -> *) a b.
Applicative m =>
(Maybe Symbol -> a -> m b) -> ValMd' a -> m (ValMd' b)
relabel ((Int -> Finalize BlockLabel)
-> Maybe Symbol -> Int -> Finalize BlockLabel
forall a b. a -> b -> a
const Int -> Finalize BlockLabel
requireBbEntryName)) (PartialGlobal -> Map KindMd PValMd
pgMd PartialGlobal
pg)
       Global -> Finalize Global
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return Global { globalSym :: Symbol
globalSym   = PartialGlobal -> Symbol
pgSym PartialGlobal
pg
                     , globalAttrs :: GlobalAttrs
globalAttrs = PartialGlobal -> GlobalAttrs
pgAttrs PartialGlobal
pg
                     , globalType :: Type
globalType  = PartialGlobal -> Type
pgType PartialGlobal
pg
                     , globalValue :: Maybe Value
globalValue = Maybe Value
mval
                     , globalAlign :: Maybe Int
globalAlign = PartialGlobal -> Maybe Int
pgAlign PartialGlobal
pg
                     , globalMetadata :: Map KindMd (ValMd' BlockLabel)
globalMetadata = Map KindMd (ValMd' BlockLabel)
md
                     }


setGlobalMetadataAttachment ::
  Map.Map KindMd PValMd ->
  (PartialGlobal -> PartialGlobal)
setGlobalMetadataAttachment :: Map KindMd PValMd -> PartialGlobal -> PartialGlobal
setGlobalMetadataAttachment Map KindMd PValMd
pmd PartialGlobal
pg = PartialGlobal
pg { pgMd = pmd }