{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE LambdaCase #-}

module Data.BitCode.LLVM.FromBitCode where

import Data.Bits (testBit, shift, (.|.), (.&.), complement, FiniteBits)

import Data.Word (Word64)

import Control.Monad (when, unless, foldM, foldM_, zipWithM)

import Data.BitCode (NBitCode(..), normalize, records, blocks, lookupBlock, lookupRecord)

import qualified Data.BitCode as BC

import Data.BitCode.LLVM

import Data.BitCode.LLVM.Util

import Data.BitCode.LLVM.Classes.HasType as T

import Data.BitCode.LLVM.Reader.Monad

import Data.BitCode.LLVM.ParamAttr

import Data.BitCode.LLVM.IDs.Blocks as B

import qualified Data.BitCode.LLVM.Codes.Identification as IC

import Data.BitCode.LLVM.Codes.AttributeKind

import Data.BitCode.LLVM.Codes.Attribute

import Data.BitCode.LLVM.Codes.ValueSymtab

import Data.BitCode.LLVM.Codes.Constants

import Data.BitCode.LLVM.Codes.AtomicOrdering

import Data.BitCode.LLVM.Codes.SynchronizationScope

import Data.BitCode.LLVM.Codes.Metadata as MD

import Data.BitCode.LLVM.Codes.Function as FC

import Data.BitCode.LLVM.Types

import Data.BitCode.LLVM.Value as V hiding (trace, traceM)

import Data.BitCode.LLVM.Type as T

import Data.BitCode.LLVM.Instruction as I

import Data.BitCode.LLVM.Function as F

import Data.BitCode.LLVM.Metadata

import Data.BitCode.LLVM.Codes.Type as TC

import Data.BitCode.LLVM.Codes.Module as M

import Data.Maybe (catMaybes, fromMaybe)

import qualified Data.Set as Set

import qualified Data.BitCode.LLVM.Linkage as Linkage

import qualified Data.BitCode.LLVM.Visibility as Visibility

import qualified Data.BitCode.LLVM.ThreadLocalMode as ThreadLocalMode

import qualified Data.BitCode.LLVM.StorageClass as DLLStorageClass

import qualified Data.BitCode.LLVM.Flags as Flags

import Data.BitCode.LLVM.Opcodes.Binary as BinOp

import qualified Data.BitCode.LLVM.Opcodes.Cast as CastOp

import GHC.Stack (HasCallStack)

parseAttr :: [NBitCode] -> LLVMReader ()

parseAttr = mapM_ parseAttr . records

where parseAttr :: (AttributeCode, [BC.Val]) -> LLVMReader ()

parseAttr (PARAMATTR_CODE_ENTRY, gidxs) = tellParamattr $ map fromIntegral gidxs

parseAttr (c,_) = fail $ "PARAMATTR: code: " ++ show c ++ "not (yet) supported"

-- | Documentation on this is pretty spotty.

parseAttrGroup :: [NBitCode] -> LLVMReader ()

parseAttrGroup = mapM_ parseAttrGroup . records

where parseAttrGroup :: (AttributeCode, [BC.Val]) -> LLVMReader ()

parseAttrGroup (PARAMATTR_GRP_CODE_ENTRY, (n:vals)) = tellParamattrGroup (fromIntegral n, parseAttrGroupEntry vals)

parseAttrGroup (c,_) = fail $ "PARAMATTR_GROUP: code: " ++ show c ++ "not (yet) supported"

parseAttrGroupEntry :: [BC.Val] -> ParamAttrGroupEntry

parseAttrGroupEntry (t:vs) = GroupEntry (grpIdx t) (go vs)

where grpIdx :: BC.Val -> ParamAttrGroupIdx

grpIdx 0 = Data.BitCode.LLVM.ParamAttr.Ret

grpIdx 0xffffffff = Fun

grpIdx n = Param n

go :: [BC.Val] -> [ParamAttrEntry]

go [] = []

go (0:n:vs) = Kind (toEnum . fromIntegral $ n):go vs

go (1:a:n:vs) | a == fromIntegral (fromEnum ATTR_KIND_ALIGNMENT) = Align n:go vs

| otherwise = StackAlign n:go vs

go (4:vs) = let key = map (toEnum . fromIntegral) $ takeWhile (/= 0) vs

val = map (toEnum . fromIntegral) $ takeWhile (/= 0) (drop (length key + 1) vs)

in Pair key (Just val):go (drop (length key + length val + 2) vs)

go (_:vs) = let key = map (toEnum . fromIntegral) $ takeWhile (/= 0) vs

in Pair key Nothing:go (drop (length key + 1) vs)

parseIdent :: [NBitCode] -> LLVMReader Ident

parseIdent body = let Just s = lookupRecord IC.STRING body

Just [e] = lookupRecord IC.EPOCH body

in return $ Ident (map toEnum' s) (toEnum' e)

parseTypes :: [NBitCode] -> LLVMReader ()

parseTypes = foldM_ parseType Nothing . records

where parseType :: Maybe String -> (Type,[BC.Val]) -> LLVMReader (Maybe String)

parseType name = \case

-- ignore number of entries record.

(NUMENTRY, [n] ) -> pure name

(NUMENTRY, [] ) -> error $ "Invalid record: empty NUMENTRY"

(VOID, [] ) -> tellType Void >> pure name

(FLOAT, [] ) -> tellType T.Float >> pure name

(DOUBLE, [] ) -> tellType Double >> pure name

(LABEL, [] ) -> tellType T.Label >> pure name

(OPAQUE, [] )

| (Just n) <- name -> tellType (Opaque n) >> pure Nothing

| otherwise -> fail "Opaque needs a name!"

-- TODO: why does OPAQUE check Record.size() != 1, and if so result in Invalid record?

-- (OPAQUE, [_] ) -> error $ "Invalid record: OPAQUE must not"

(INTEGER, [width] ) -> (tellType $ T.Int width) >> pure name

(INTEGER, [] ) -> error $ "Invalid record: empty INTEGER"

-- TODO: Check that the resulting type is valid (!Void, !Label, !Metadata, !Token)

(POINTER, [tyId, width] ) -> askType tyId >>= tellType . Ptr width >> pure name

(POINTER, [tyId] ) -> askType tyId >>= tellType . Ptr 0 >> pure name

(POINTER, [] ) -> error $ "Invalid record: empty POINTER"

(HALF, [] ) -> tellType Half >> pure name

-- TODO: Valid element types (!Void, !Label, !Metadata, !Function, !Token)

(ARRAY, [numElts, eltTyId] ) -> askType eltTyId >>= tellType . T.Array numElts >> pure name

(ARRAY, x ) | length x < 2 -> error $ "Invalid record: ARRAY"

-- TODO: Valid element type (Integer, FloatingPoint, Pointer)

(VECTOR, [numElts, eltTyId] ) -> askType eltTyId >>= tellType . T.Vector numElts >> pure name

(VECTOR, x ) | length x < 2 -> error $ "Invalid record: VECTOR"

(X86_FP80, [] ) -> tellType X86Fp80 >> pure name

(FP128, [] ) -> tellType Fp128 >> pure name

(TC.METADATA, [] ) -> tellType T.Metadata >> pure name

(X86_MMX, [] ) -> tellType X86Mmx >> pure name

-- TODO: Valid element type: (!Void, !Label, !Metadata, !Function, !Token)

-- TODO: Should also check that elemTyIds is the smae number after asking for the type (e.g. that askting for the type does not fail.)

(STRUCT_ANON, (isPacked:eltTyIds) ) -> mapM askType eltTyIds >>= tellType . StructAnon (isPacked /= 0) >> pure name

(STRUCT_ANON, [] ) -> error $ "Invalid record: Anon struct must have at least one op."

(STRUCT_NAME, ops ) -> pure (pure (toString ops))

(STRUCT_NAMED,(isPacked:eltTyIds) )

| (Just n) <- name -> mapM askType eltTyIds >>= tellType . StructNamed n (isPacked /= 0) >> pure Nothing

| otherwise -> fail "Named Struct needs a name!"

(STRUCT_NAMED, [] ) -> error $ "Invalid record: Named struct must have at least one op."

-- TODO: If the number of argument type does not match paramTys, this is an invalid record.

-- Must filter for isValidArgumentType (=isFirstClassType), (!Void, !Function)

(TC.FUNCTION, (vararg:retTy:paramTys)) -> T.Function (vararg /= 0) <$> askType retTy <*> mapM askType paramTys >>= tellType >> pure name

(TC.FUNCTION, [_] ) -> error $ "Invalid record: FUNCTION must have at least two ops."

(TOKEN, [] ) -> tellType Token >> pure name

(code, ops ) -> fail $ "Can not handle type: " ++ show code ++ " with ops: " ++ show ops

toString :: (Integral a) => [a] -> String

toString = map (toEnum . fromIntegral)

-- | toSigned helper. Bitcode does doesn't encode signed

toSigned :: (FiniteBits a) => a -> a

toSigned v | testBit v 0 = complement (shift v (-1))

| otherwise = shift v (-1)

-- | Parse constants.

parseConstants :: HasCallStack => [NBitCode] -> LLVMReader ()

parseConstants = foldM_ parseConstant undefined . records

where parseConstant :: Ty -> (Constant,[BC.Val]) -> LLVMReader Ty

parseConstant ty = \case

-- Also invalid record, if tyId outside of Typelist.

(CST_CODE_SETTYPE, [tyId]) -> askType tyId

(CST_CODE_SETTYPE, [] ) -> error $ "Invalid record: empty constants SETTYPE."

(CST_CODE_NULL, [] ) -> add $ mkConst V.Null

(CST_CODE_UNDEF, [] ) -> add $ mkConst V.Undef

(CST_CODE_INTEGER, [val] ) | T.Int{} <- ty -> add $ mkConst (V.Int (toSigned val))

| otherwise -> error "Invalid record: INTEGER constant, but type is not Int"

(CST_CODE_INTEGER, [] ) -> error "Invalid record: INTEGER must have one op!"

(CST_CODE_WIDE_INTEGER, vals) | T.Int{} <- ty -> add $ mkConst (V.WideInt (map toSigned vals))

| otherwise -> error "Invalid record: WIDE_INTEGER constant, but type is not Int"

(CST_CODE_WIDE_INTEGER, [] ) -> error "Invalid record: WIDE_INTEGER must have one op!"

(CST_CODE_FLOAT, [] ) -> error "Invalid record: FLOAT must have one op!"

(CST_CODE_AGGREGATE, []) -> error "Invalid record: AGGREGATE must have at least one op!"

(CST_CODE_AGGREGATE, valIds)

-- XXX: We *assume*, but do not verify that the types of the askValue's actually match those of the structure.

| T.StructAnon _ ts <- ty -> add =<< mkConst <$> (V.Struct <$> zipWithM askValue ts valIds)

| T.StructNamed _ _ ts <- ty -> add =<< mkConst <$> (V.Struct <$> zipWithM askValue ts valIds)

| T.Array _ t <- ty -> add =<< mkConst <$> (V.Array <$> mapM (askValue t) valIds)

| T.Vector _ t <- ty -> add =<< mkConst <$> (V.Vector <$> mapM (askValue t) valIds)

| otherwise -> add $ mkConst V.Undef

(CST_CODE_STRING, [] ) -> error "Invalid record: STRING must have at least one op!"

(CST_CODE_STRING, vals ) -> add $ mkConst (V.String $ map toEnum' vals)

(CST_CODE_CSTRING, [] ) -> error "Invalid record: CSTRING must have at least one op!"

(CST_CODE_CSTRING, vals) -> add $ mkConst (V.CString $ map toEnum' vals)

-- TODO: support Constant Binop with 4 operands.

(CST_CODE_CE_BINOP, [code, lhs, rhs]) -> add =<< mkConst <$> (V.BinOp (toEnum' code) <$> askValue' lhs <*> askValue' rhs)

(CST_CODE_CE_BINOP, _) -> error "Invalid record: BINOP only suppored with exactly three ops!"

(CST_CODE_CE_CAST, [ code, tyId, valId ]) -> add =<< mkConst <$> (V.Cast <$> askType tyId <*> pure (toEnum' code) <*> askValue' valId)

(CST_CODE_CE_BINOP, _) -> error "Invalid record: CAST only suppored with exactly three ops!"

-- TODO: proper parsing.

-- if even, assume pointee = nullptr

-- otherwise use first record.

-- the rest is [ty, val, ...], if type lookup fails -> Invalid record.

-- See INBOUNDS_GEP

(CST_CODE_CE_GEP, vals) -> add $ mkConst (V.Gep vals)

-- see GEP.

(CST_CODE_CE_INBOUNDS_GEP, (v:vs))

-- either [t, [tyId, valId, ...]]

| length vs `mod` 2 == 0 -> do

t <- askType v

add =<< mkConst . V.InboundsGep t <$> getTypedSymbols vs

| otherwise -> do

let t = Ptr 0 Void -- nullptr

add =<< mkConst . V.InboundsGep t <$> getTypedSymbols vs

(c,vs) -> error $ "Code: " ++ show c ++ " not supported; values: " ++ show vs ++ "; current type: " ++ show ty

where mkConst :: Const -> Value

mkConst = Constant ty

add :: Value -> LLVMReader Ty

add val = tellValue val >> pure ty

-- WARNING - TODO: Converting Word64 to possible Int(32).

toSigned :: Word64 -> Int

toSigned w = fromIntegral $ case (testBit w 0, shift w (-1)) of

(True, v) -> -v

(False, v) -> v

getTypedSymbols :: [Word64] -> LLVMReader [Symbol]

getTypedSymbols [] = pure []

getTypedSymbols (tId:vId:vs) = do

t <- askType tId

v <- askValue t vId

-- TODO: check that the type of v matches t.

(v:) <$> getTypedSymbols vs

parseMetadataKinds :: [NBitCode] -> LLVMReader ()

parseMetadataKinds = mapM_ parseMetadataKind . records

where parseMetadataKind :: (MD.Metadata,[BC.Val]) -> LLVMReader ()

parseMetadataKind = \case

(MD.METADATA_KIND, (idx:vals)) -> tellMetadataKind ((fromIntegral idx), map toEnum' vals)

_ -> pure () -- ignore.

parseMetadata :: [NBitCode] -> LLVMReader ()

parseMetadata = mapM_ parseMetadata . records

where parseMetadata :: (MD.Metadata, [BC.Val]) -> LLVMReader ()

parseMetadata = \case

(MD.METADATA_STRING, vals) -> tellMetadata $ MDString (map toEnum' vals)

(MD.METADATA_VALUE, [tyId,val]) -> askType tyId >>= \ty -> tellMetadata $ MDValue ty val

(MD.METADATA_NODE, mdIds) -> tellMetadata =<< MDNode <$> mapM askMetadata (map pred mdIds)

(MD.METADATA_NAME, vals) -> tellMetadata $ MDName (map toEnum' vals)

(MD.METADATA_DISTINCT_NODE, mdIds) -> tellMetadata =<< MDDistinctNode <$> mapM askMetadata (map pred mdIds)

(MD.METADATA_LOCATION, [distinct, line, col, scope, inlinedAt]) -> tellMetadata $ MDLocation (distinct /= 0) line col scope inlinedAt

-- this is such a weird encoding.

-- basically emit the name. And then emit a named node, to use the just emitted name.

(MD.METADATA_NAMED_NODE, mIds) -> popMetadata >>= \(MDName name) -> MDNamedNode name <$> mapM askMetadata mIds >>= tellMetadata

(MD.METADATA_KIND, (idx:vals)) -> tellMetadataKind ((fromIntegral idx), map toEnum' vals)

(c, ops) -> fail $ "Unsupported metadata: " ++ show c ++ " with ops: " ++ show ops

parseVersion :: HasCallStack => [BC.Val] -> Word64

parseVersion [v] = v

parseTriple :: HasCallStack => [BC.Val] -> String

parseTriple = map toEnum'

parseDataLayout :: HasCallStack => [BC.Val] -> String

parseDataLayout = map toEnum'

parseGlobalVar :: HasCallStack => [BC.Val] -> LLVMReader ()

parseGlobalVar vals

| length vals < 6 = error $ "Invalid record: Global Var must have at least six operands. " ++ show vals ++ " given."

| [ ptrTyId, isConst, initId, linkage, paramAttrId, section ] <- vals = do

ty <- askType ptrTyId

unless (testBit isConst 1) $ fail "non-explicit type global vars are not (yet) supported"

let addressSpace = shift isConst (-2)

initVal = if initId /= 0 then Just (Unnamed undefined ty (FwdRef (initId -1))) else Nothing

linkage' = toEnum' linkage

storageClass = upgradeDLLImportExportLinkage linkage'

comdat = 0 -- XXX. the Reader does some weird hasImplicitComdat for older bitcode.

-- we'll ignore this here for now.

tellValue $ Global (Ptr 0 ty) (testBit isConst 0) addressSpace initVal

linkage' paramAttrId section Visibility.Default ThreadLocalMode.NotThreadLocal

False False storageClass comdat

| [ ptrTyId, isConst, initId, linkage

, paramAttrId, section, visibility, threadLocalMode

, unnamedAddr, externallyInitialized, storageClass

, comdat ] <- vals = do

ty <- askType ptrTyId

-- TODO: isConst has bit 0 set if const. bit 1 if explicit type. We only handle explicit type so far.

unless (testBit isConst 1) $ fail "non-explicit type global vars are not (yet) supported"

let addressSpace = shift isConst (-2)

initVal = if initId /= 0 then Just (Unnamed undefined ty (FwdRef (initId - 1))) else Nothing

tellValue $ Global (Ptr 0 ty) (testBit isConst 0) addressSpace initVal

(toEnum' linkage) paramAttrId section (toEnum' visibility) (toEnum' threadLocalMode)

(unnamedAddr /= 0) (externallyInitialized /= 0) (toEnum' storageClass) comdat

| otherwise = error $ "unhandled parseGlobalVar with values: " ++ (show vals)

parseFunctionDecl :: HasCallStack => [BC.Val] -> LLVMReader ()

parseFunctionDecl vals = askVersion >>= \case

1 -> parseFunctionDecl' vals

2 -> parseFunctionDecl' (drop 2 vals)

parseFunctionDecl' :: HasCallStack => [BC.Val] -> LLVMReader ()

parseFunctionDecl'

[ tyId, cconv, isProto, linkage -- 4

, paramAttrId, alignment, section, visibility, gc -- 9

, unnamedAddr, prologueDataId, storageClass, comdat -- 13

, prefixDataId, personality ] -- 15

= do

ty <- askType tyId

let prologueData = if prologueDataId /= 0 then Just (Unnamed undefined ty (FwdRef (prologueDataId -1))) else Nothing

prefixData = if prefixDataId /= 0 then Just (Unnamed undefined ty (FwdRef (prefixDataId -1))) else Nothing

tellValue $ V.Function (Ptr 0 ty) (toEnum' cconv) (toEnum' linkage)

paramAttrId alignment section (toEnum' visibility) gc

(unnamedAddr /= 0) (toEnum' storageClass)

comdat personality (FE (isProto /= 0) prologueData prefixData)

parseFunctionDecl' vs = fail $ "Failed to parse functiond decl from " ++ show (length vs) ++ " values " ++ show vs

upgradeDLLImportExportLinkage :: Linkage.Linkage -> DLLStorageClass.DLLStorageClass

upgradeDLLImportExportLinkage = \case

Linkage.WeakODR -> DLLStorageClass.DLLImport

Linkage.Appending -> DLLStorageClass.DLLExport

_ -> DLLStorageClass.Default

parseAlias :: HasCallStack

=> Bool -- ^ New Alias

-> [BC.Val] -- Values

-> LLVMReader ()

parseAlias False [ tyId, valId, linkage, visibility, storageClass, threadLocalMode, unnamedAddr ] = do

nVals <- length <$> askValueList

nTypes <- length <$> askTypeList

ty@(Ptr addrSpace _) <- askType tyId

-- val <- askValue valId

tellValue $ Alias ty addrSpace (Unnamed undefined undefined (V.FwdRef valId)) (toEnum' linkage) (toEnum' visibility) (toEnum' threadLocalMode) (unnamedAddr /= 0) (toEnum' storageClass)

parseAlias False [ tyId, valId, linkage, visibility, storageClass, threadLocalMode ]

= parseAlias False [ tyId, valId, linkage, visibility, storageClass, threadLocalMode, 0 ]

parseAlias False [ tyId, valId, linkage, visibility, storageClass ]

= parseAlias False [ tyId, valId, linkage, visibility, storageClass, (fromIntegral (fromEnum ThreadLocalMode.NotThreadLocal)) ]

parseAlias False [ tyId, valId, linkage, visibility ]

= parseAlias False [ tyId, valId, linkage, visibility, (fromIntegral . fromEnum $ upgradeDLLImportExportLinkage (toEnum' linkage)) ]

parseAlias False [ tyId, valId, linkage ]

= parseAlias False [ tyId, valId, linkage, (fromIntegral (fromEnum Visibility.Default)) ]

parseAlias True [ tyId, addrSpace, valId, linkage, visibility, storageClass, threadLocalMode, unnamedAddr ] = do

ty <- askType tyId

val <- askValue ty valId

tellValue $ Alias ty addrSpace val (toEnum' linkage) (toEnum' threadLocalMode) (toEnum' visibility) (unnamedAddr /= 0) (toEnum' storageClass)

parseAlias True [ tyId, addrSpace, valId, linkage, visibility, storageClass, threadLocalMode ]

= parseAlias True [ tyId, addrSpace, valId, linkage, visibility, storageClass, threadLocalMode, 0 ]

parseAlias True [ tyId, addrSpace, valId, linkage, visibility, storageClass ]

= parseAlias True [ tyId, addrSpace, valId, linkage, visibility, storageClass, (fromIntegral (fromEnum ThreadLocalMode.NotThreadLocal)) ]

parseAlias True [ tyId, addrSpace, valId, linkage, visibility ]

= parseAlias True [ tyId, addrSpace, valId, linkage, visibility, (fromIntegral . fromEnum $ upgradeDLLImportExportLinkage (toEnum' linkage)) ]

parseAlias True [ tyId, addrSpace, valId, linkage ]

= parseAlias True [ tyId, addrSpace, valId, linkage, (fromIntegral (fromEnum Visibility.Default)) ]

toEnum' :: (HasCallStack, Integral a, Enum e) => a -> e

toEnum' = toEnum . fromIntegral

parseTopLevel :: HasCallStack => [NBitCode] -> LLVMReader (Maybe Ident, Module)

parseTopLevel bs = do

ident <- case lookupBlock IDENTIFICATION bs of

Just b -> Just <$> parseIdent b

Nothing -> return Nothing

let Just moduleBlock = lookupBlock MODULE bs

mod <- parseModule moduleBlock

return (ident, mod)

resolveFwdRefs :: HasCallStack => [Symbol] -> [Symbol]

resolveFwdRefs ss = map (fmap' resolveFwdRef') ss

where

-- TODO: Maybe Symbol should be more generic? Symbol a,

-- then we could have Functor Symbol.

fmap' :: (Value -> Value) -> Symbol -> Symbol

fmap' f (Named s i t v) = let v' = f v in Named s i (ty v) v

fmap' f (Unnamed i t v) = let v' = f v in Unnamed i (ty v) v

resolveFwdRef' :: Value -> Value

resolveFwdRef' g@(Global{..}) = case gInit of

Just s | (FwdRef id) <- symbolValue s -> g { gInit = Just $ (ss !! (fromIntegral id)) }

_ -> g

-- resolve fws refs only for globals for now.

resolveFwdRef' x = x

-- | Parse a module from a set of blocks (the body of the module)

parseModule :: HasCallStack => [NBitCode] -> LLVMReader Module

parseModule bs = do

let Just version = parseVersion <$> lookupRecord VERSION bs

triple = parseTriple <$> lookupRecord TRIPLE bs

layout = parseDataLayout <$> lookupRecord DATALAYOUT bs

vst = parseSymbolValueTable <$> lookupBlock VALUE_SYMTAB bs

tellVersion version

trace "Parsing Blocks"

flip mapM_ bs $ \case

(NBlock c bs') -> parseModuleBlock (toEnum (fromIntegral c), bs')

(NRec c vs) -> parseModuleRecord (toEnum (fromIntegral c), vs)

trace "Parsing VST"

-- update values with symbols

case vst of

Just vst -> tellValueSymbolTable vst

Nothing -> pure ()

-- update forward references

resolveFwdRefs <$> askValueList >>= tellValueList

-- obtain a snapshot of all current values

values <- askValueList

trace "Parsing Decls"

let functionDefs = [f | f@(Named _ _ _ (V.Function {..})) <- values, not (feProto fExtra)] ++

[f | f@(Unnamed _ _ (V.Function {..})) <- values, not (feProto fExtra)]

functionDecl = [f | f@(Named _ _ _ (V.Function {..})) <- values, feProto fExtra ] ++

[f | f@(Unnamed _ _ (V.Function {..})) <- values, feProto fExtra ]

(unless (length functionDefs == length functionBlocks)) $ fail $ "#functionDecls (" ++ show (length functionDefs) ++ ") does not match #functionBodies (" ++ show (length functionBlocks) ++ ")"

trace "Parsing Functions"

fns <- mapM parseFunction (zip functionDefs functionBlocks)

let functionDefs = map dSig fns

typeSet <- askTypeList

let isConstant x

| (V.Constant{}) <- V.symbolValue x = True

| otherwise = False

constsSet <- filter isConstant <$> askValueList

return $ Module version triple layout values functionDecl functionDefs fns constsSet typeSet

where

functionBlocks :: [[NBitCode]]

functionBlocks = [bs' | (B.FUNCTION, bs') <- blocks bs ]

symbolize :: [(Int, ValueSymbolEntry)] -> [Value] -> [Symbol]

symbolize m = map (\(idx, val) -> case (lookup idx m) of

Just (Entry s) -> Named s undefined (ty val) val

Just (FnEntry _ s) -> Named s undefined (ty val) val

Nothing -> Unnamed undefined (ty val) val

) . zip [0..]

-- | Parse value symbol table

parseSymbolValueTable :: HasCallStack => [NBitCode] -> ValueSymbolTable

parseSymbolValueTable = foldl (\l x -> parseSymbolValue x:l) [] . filter f . records

where parseSymbolValue :: (ValueSymtabCodes, [BC.Val]) -> (Int, ValueSymbolEntry)

parseSymbolValue (VST_CODE_ENTRY, (idx:vs)) = (fromIntegral idx, Entry $ map toEnum' vs)

parseSymbolValue (VST_CODE_FNENTRY, (idx:offset:vs)) = (fromIntegral idx, FnEntry (fromIntegral offset) $ map toEnum' vs)

f :: (ValueSymtabCodes, [BC.Val]) -> Bool

f (VST_CODE_ENTRY, _) = True

f (VST_CODE_FNENTRY, _) = True

f _ = False

parseModuleBlock :: HasCallStack => (ModuleBlockID, [NBitCode]) -> LLVMReader ()

parseModuleBlock (id,bs) = trace ("parseModuleBlock " ++ show id) >> case (id,bs) of

({- 9 -}PARAMATTR, bs) -> parseAttr bs

({- 10 -}PARAMATTR_GROUP, bs) -> parseAttrGroup bs

({- 11 -}CONSTANTS, bs) -> parseConstants bs

({- 12 -}B.FUNCTION, bs) -> return () -- parsing of function bodies is handled differently.

({- 13 -}IDENTIFICATION, bs) -> return () -- this is not even part of the MODULE block. But alongside the module block.

({- 14 -}VALUE_SYMTAB, bs) -> return () -- TODO

({- 15 -}B.METADATA, bs) -> parseMetadata bs

({- 16 -}METADATA_ATTACHMENT_ID, bs) -> return () -- TODO

({- 17 -}TYPE_NEW, bs) -> parseTypes bs

({- 18 -}USELIST, bs) -> return () -- TODO

({- 19 -}MODULE_STRTAB, bs) -> return () -- TODO

({- 20 -}FUNCTION_SUMMARY, bs) -> return () -- TODO

({- 21 -}OPERAND_BUNDLE_TAGS, bs) -> return () -- TODO

({- 22 -}B.METADATA_KIND, bs) -> parseMetadataKinds bs

({- 23 -}STRTAB, bs) -> return () -- TODO

({- 24 -}FULL_LTO_GLOBAL_SUMMARY, bs) -> return () -- TODO

({- 25 -}SYMTAB, bs) -> return () -- TODO

({- 26 -}SYNC_SCOPE_NAMES, bs) -> return () -- TODO

c -> fail $ "Encountered unhandled block: " ++ show c

parseModuleRecord :: HasCallStack => (ModuleCode, [BC.Val]) -> LLVMReader ()

parseModuleRecord (id,bs) = trace ("parseModuleRecord " ++ show id) >> case (id,bs) of

({- 1 -}VERSION, _) -> pure () -- ignore, it's being picked apart somewhere else.

({- 2 -}TRIPLE, _) -> pure () -- ignore

({- 3 -}DATALAYOUT, _) -> pure () -- ignore

-- ({- 4 -}ASM, asm) -> -- unhandled

({- 5 -}SECTIONNAME, name) -> trace $ "!! ignoring section name " ++ (map toEnum' name)

-- ({- 6 -}DEPLIB, name) -- unhanlded, will be removed in 4.0 anyway.

({- 7 -}GLOBALVAR, vs) -> parseGlobalVar vs

({- 8 -}M.FUNCTION, vs) -> parseFunctionDecl vs

({- 9 -}ALIAS_OLD, vs) -> parseAlias False vs

-- ({- 10 -}PURGEVALS, numvals) -- unhandled; no idea how to implement this without chaning to stream processing of the blocks.

-- ({- 11 -}GCNAME, name) -- unhandled

-- ({- 12 -}COMDAT, [ sectionKind, name ]) -- unhandled

-- as we do not jump to the VST, we can safely ignore it here.

({- 13 -}VSTOFFSET, [ offset ]) -> trace $ "!! ignoring VSTOffset " ++ show offset

({- 14 -}ALIAS, vs) -> parseAlias True vs

-- ignore others; e.g. we only need to parse the ones above in sequence to populate the valuetable properly.

({- 16 -}SOURCE_FILENAME, name) -> trace $ "!! ignoring source filename " ++ (map toEnum' name)

({- 17 -}HASH, vs) -> trace $ "!! ignoring hash " ++ show vs

-- ({- 18 -}IFUNC, [ valty, addrspace, resolverval, link, visibility ])

(id,ops) -> fail $ "Encountered unhandled record: " ++ show id ++ " with ops: " ++ show ops

-- | parsing a function block from bitcode.

parseFunction :: HasCallStack => (Symbol, [NBitCode]) -> LLVMReader F.Function

parseFunction (f@(Named _ _ _ V.Function{..}), b) = do

-- remember the size of the value list. We need to trim it back down after

-- parsing; and might want to attach the new values to the constants of the Function.

-- The same holds for metadata attachment.

savedValueList <- askValueList

savedVST <- askValueSymbolTable

-- Not sure what we do about Uselist yet.

let Ptr _ (T.Function _ _ paramTys) = fType

-- put the decl header onto the valuelist.

mapM_ tellValue (zipWith Arg paramTys [0..])

nVals' <- length <$> askValueList

-- let's parse all constants if any.

mapM_ parseFunctionBlock (blocks b)

case parseSymbolValueTable <$> lookupBlock VALUE_SYMTAB b of

Just vst -> tellValueSymbolTable vst

Nothing -> pure ()

consts <- drop nVals' . resolveFwdRefs <$> askValueList

-- parse the instructions

-- the first basic block is going to be empty. As the body

-- has to finish with a terminator, which adds a final empty

-- BB to the front.

(_:bbs,_) <- foldM foldHelper ([BasicBlock []],[]) (records b)

-- reset the valueList to before we entered the

-- function body, as they were local to

tellValueList savedValueList

tellValueSymbolTable savedVST

return $ F.Function f consts (reverse bbs)

parseFunction ((Unnamed i t f), b) = parseFunction ((Named "dummy" i t f), b)

parseFunction _ = fail "Invalid arguments"

parseFunctionBlock :: HasCallStack => (ModuleBlockID, [NBitCode]) -> LLVMReader ()

parseFunctionBlock = \case

(CONSTANTS, b) -> parseConstants b

(B.METADATA, b) -> parseMetadata b

(B.METADATA_ATTACHMENT_ID, b) -> trace ("Ignoring Metadata attachment: " ++ show b)

(B.USELIST, b) -> trace ("Cannot parse uselist yet (" ++ show b ++ ")") >> return ()

_ -> pure ()

getVal :: (HasCallStack, Integral a) => a -> LLVMReader Symbol

getVal n = do

valueList <- askValueList

let idx = fromIntegral n

if idx < 0 || idx > length valueList

then fail $ "index " ++ show idx ++ " out of range [0, " ++ show (length valueList) ++ ") of available values."

else pure (valueList !! idx)

getVal' :: (HasCallStack, Integral a) => Ty -> a -> LLVMReader Symbol

getVal' t n = do

val <- getVal n

if (ty val) == t

then return val

else do valueList <- askValueList

fail $ show val ++ " (" ++ show (fromIntegral n) ++ ") doesn't have type " ++ show t

getRelativeVal :: (HasCallStack, Integral a) => [Symbol] -> a -> LLVMReader Symbol

getRelativeVal refs n = do

valueList <- askValueList

let lst = reverse (valueList ++ refs)

idx = fromIntegral n - 1

if idx < 0 || idx > length lst

then fail $ "index " ++ (show idx) ++ " out of range [0, " ++ show (length lst) ++ ") of avaliable relative values."

else pure (lst !! idx)

getRelativeValWithType :: (HasCallStack, Integral a) => Ty -> [Symbol] -> a -> LLVMReader Symbol

getRelativeValWithType ty refs n = do

val <- getRelativeVal refs n

if (T.ty val) == ty

then return val

else do valueList <- askValueList

let lst = reverse (valueList ++ refs)

idx = fromIntegral n - 1

fail $ show val ++ " (" ++ show idx ++ ") doesn't have type " ++ show ty ++ "\nvalues\n" ++ unlines (map show lst)

foldHelper :: ([BasicBlock],[Symbol]) -> (Instruction, [BC.Val]) -> LLVMReader ([BasicBlock],[Symbol])

foldHelper s@((BasicBlock insts):bbs,vs) instr = do

i <- parseInst vs instr

case i of

Nothing -> return s

Just i -> do let mref = (\v -> Unnamed undefined (ty v) v) . flip TRef (length vs) <$> instTy i

vs' = vs ++ [r | Just r <- [mref]]

insts' = insts ++ [(mref, i)]

bbs' = (BasicBlock insts'):bbs

case isTerminator i of

True -> return ((BasicBlock []):bbs', vs')

False -> return (bbs', vs')

parseInst :: HasCallStack => [Symbol] -> (Instruction, [BC.Val]) -> LLVMReader (Maybe Inst)

parseInst rs = \case

-- 1

(DECLAREBLOCKS, x) | length x == 0 -> error "Invalid record: DECLAREBLOCKS must not be empty!"

| x == [0] -> error "Invalid record: DECLAREBLOCKS must not be 0."

| otherwise -> pure Nothing -- ignore.

-- 2

(INST_BINOP, (lhs:rhs:code:flags)) -> traceShow flags $ do

lhs <- getRelativeVal rs lhs

rhs <- getRelativeVal rs rhs

unless ((ty lhs) == (ty rhs)) $ pure $ error "Invalid record: BINOP, LHS and RHS types do not agree."

let opTy = ty (symbolValue lhs)

code' = (toEnum' code) :: BinOp

flags' = case flags of

[] -> []

[bitfield]

| code' `elem` [ADD, SUB, MUL, SHL] -> map Flags.Overflow $ filter (testBit bitfield . fromEnum) [Flags.NO_UNSIGNED_WRAP, Flags.NO_SIGNED_WRAP]

| code' `elem` [UDIV, SDIV, LSHR, ASHR] -> map Flags.Exact $ filter (testBit bitfield . fromEnum) [Flags.EXACT]

| otherwise -> []

_ -> error "Invalid record: At most one FLAG value allowed for BINOP."

return $ Just (I.BinOp opTy code' lhs rhs flags')

-- 3

(INST_CAST, [ valId, tyId, opCode ]) -> do

val <- getRelativeVal rs valId

ty <- askType tyId

let op = toEnum' opCode

-- TODO: if not ty or Opc = -1 -> Invalid Record

return $ Just (I.Cast ty op val)

-- 4

-- (INST_GEP_OLD, vals)

-- 5

-- (INST_SELECT, vals)

-- 6

-- (INST_EXTRACTELT, vals)

-- 7

-- (INST_INSERTELT, vals)

-- 8

-- (INST_SHUFFLEVEC, vals)

-- 9

-- (INST_CMP, vals)

-- 10

(INST_RET, []) -> return . Just $ I.Ret Nothing

(INST_RET, [valId]) -> do

val <- Just <$> getRelativeVal rs valId

return . Just $ I.Ret val

(INST_RET, _) -> error "Invalid record: INST_RET can only have none or one op."

-- 11

(INST_BR, [bbN]) -> return . Just $ UBr bbN

(INST_BR, [bbN, bbN', cond]) -> do

cond' <- getRelativeVal rs cond

return . Just $ Br cond' bbN bbN'

(INST_BR, _) -> error "Invalid record: INST_BR can only have one or three ops."

-- 12

(INST_SWITCH, (opTy:cond:defaultBlock:cases)) -> do

ty <- askType opTy

cond' <- getRelativeVal rs cond

Just . Switch cond' defaultBlock <$> parseCase ty cases

where

parseCase :: Ty -> [BC.Val] -> LLVMReader [(Symbol, BasicBlockId)]

parseCase ty [] = pure []

parseCase ty (valId:blockId:cases) = (:) <$> ((,blockId) <$> getVal' ty valId) <*> parseCase ty cases

-- 13

-- (INST_INVOKE, vals)

-- 14 - Unused

-- 15

-- (INST_UNREACHABLE, [])

-- 16

-- (INST_PHI, (ty:val:[bbs]))

-- 17, 18 - Unused

-- 19

(INST_ALLOCA, [ instty, opty, op, align ]) -> do

iTy <- askType instty

oTy <- askType opty

val <- askValue oTy op -- probably a constant.

unless (oTy == ty val) $ pure $ error "Invalid record"

return . Just $ Alloca (Ptr 0 iTy) val (decodeAlign align)

where decodeAlign :: Word64 -> Word64

decodeAlign a = 2^((a .&. (complement inAllocMask .|. explicitTypeMask .|. swiftErrorMask)) - 1)

inAllocMask = shift 1 5

explicitTypeMask = shift 1 6

swiftErrorMask = shift 1 7

(INST_ALLOCA, _) -> error "Invalid record: ALLOCA expects exactly four ops!"

-- 20

(INST_LOAD, [ op, opty, align, vol]) -> do

oTy <- askType opty

val <- getRelativeVal rs op

return . Just $ Load oTy val (2^(align-1))

-- 21, 22 - Unused

-- 23

-- (INST_VAARG, [ valistty, valist, instty ])

-- 24

-- (INST_STORE_OLD [ ptrty, ptr, val, align, vol])

-- 25 - Unused

-- 26

(INST_EXTRACTVAL, (op:idxs)) -> do

val <- getRelativeVal rs op

return . Just $ ExtractValue val idxs

-- 27

-- (INST_INSERTVAL, ops)

-- 28

(INST_CMP2, [lhs, rhs, pred]) -> do

lhs' <- getRelativeVal rs lhs

rhs' <- getRelativeVal rs rhs

unless (ty lhs' == ty rhs') $ pure $ error "Invalid record: CMP2 lhs and rhs types do not agree."

-- result type is:

-- if lhs is vector of n -> Vector <i1 x n>

-- else -> i1

let oTy = case (ty lhs') of

T.Vector n _ -> T.Vector n (T.Int 1)

_ -> T.Int 1

return . Just $ Cmp2 oTy lhs' rhs' (toEnum' pred)

-- 29

-- (INST_VSELECT, [ ty, opval, opval, predty, pred])

-- 30

-- (INST_INBOUNDS_GEP_OLD, ops)

-- 31

-- (INST_INDIRECTBR, (opty:ops))

-- 32 - Unused

-- 33

-- (DEBUG_LOC_AGAIN, [])

-- 34

-- [paramattrs, cc[, fmf][, explfnty], fnid, arg0, arg1...]

(INST_CALL, (paramattr:cc:ops)) -> do

let (fmf, ops') = if testBit cc (fromEnum Flags.CALL_FMF) then (Just (head ops), tail ops) else (Nothing, ops)

let (explFnTy, ops') = if testBit cc (fromEnum Flags.CALL_EXPLICIT_TYPE) then (Just (head ops), tail ops) else (Nothing, ops)

let tailCallKind | testBit cc (fromEnum Flags.CALL_TAIL) = Tail

| testBit cc (fromEnum Flags.CALL_MUSTTAIL) = MustTail

| testBit cc (fromEnum Flags.CALL_NOTAIL) = NoTail

| otherwise = None

-- cconv is encoded in the bits 1 to 11.

let cconv = toEnum' (shift (cc .&. 0x7ff) (-1 * fromEnum Flags.CALL_CCONV))

let (fnid:args) = ops'

fn <- getRelativeVal rs fnid

fnTy <- case explFnTy of

Just ty -> askType ty

Nothing -> pure $ tePointeeTy (fType (symbolValue fn))

args <- mapM (getRelativeVal rs) args

return . Just $ Call (teRetTy fnTy) tailCallKind cconv fn fnTy args

-- 35

-- (DEBUG_LOC)

-- 36

(INST_FENCE, [ordering, synchscope]) -> do

return . Just $ Fence (decodeOrdering ordering) (decodeSynchScope synchscope)

where

decodeOrdering :: BC.Val -> AtomicOrdering

decodeOrdering = toEnum'

decodeSynchScope :: BC.Val -> AtomicSynchScope

decodeSynchScope = toEnum'

-- 37

-- (INST_CMPXCHG_OLD, [ptrty, ptr, cmp, new, align, vol, ordering, synchscope])

-- 38

(INST_ATOMICRMW, [ ptr, val, op, vol, ordering, synchscope]) -> do

ref <- getRelativeVal rs ptr

val <- getRelativeVal rs val

return . Just $ AtomicRMW ref val (toEnum' op) (decodeOrdering ordering) (decodeSynchScope synchscope)

where

decodeOrdering :: BC.Val -> AtomicOrdering

decodeOrdering = toEnum'

decodeSynchScope :: BC.Val -> AtomicSynchScope

decodeSynchScope = toEnum'

-- 39

-- (INST_RESUME, [opval])

-- 40

-- (INST_LANDINGPAD_OLD, [ty, val, val, num, id0, val0, ...])

-- 41

(INST_LOADATOMIC, [ ptr, opty, align, vol, ordering, synchscope]) -> do

oTy <- askType opty

ref <- getRelativeVal rs ptr

return . Just $ AtomicLoad oTy ref (2^(align-1)) (toEnum' ordering) (toEnum' synchscope)

-- 42

-- (INST_STOREATOMIC_OLD, [ptrty, ptr, val, align, vol, odering, synchscope])

-- 43

-- TODO: also GEP_OLD, and INBOUNDS_GEP_OLD, same parse though.

(INST_GEP, (inbounds:opty:vs)) -> do

oTy <- askType opty

(val:idxs) <- mapM (getRelativeVal rs) vs

return . Just $ I.Gep (lift oTy) (inbounds /= 0) val idxs

-- 44

(INST_STORE, [ ptr, val, align, vol ]) -> do

ref <- getRelativeVal rs ptr

val <- getRelativeVal rs val

return . Just $ Store ref val (2^(align-1))

-- 45

(INST_STOREATOMIC, [ ptr, val, align, vol, ordering, synchscope ]) -> do

ref <- getRelativeVal rs ptr

val <- getRelativeVal rs val

return . Just $ AtomicStore ref val (2^(align-1)) (toEnum' ordering) (toEnum' synchscope)

-- 46

(INST_CMPXCHG, [ ptr, cmp, new, vol, ordering, synchscope, failureOrdering, weak ]) -> do

ref <- getRelativeVal rs ptr

cmp <- getRelativeVal rs cmp

new <- getRelativeVal rs new

unless (ty cmp == ty new) $ pure $ error "Invalid record: CMP2 lhs and rhs types do not agree."

return . Just $ CmpXchg ref cmp new (decodeOrdering ordering)

(decodeSynchScope synchscope)

(decodeOrdering failureOrdering)

where

decodeOrdering :: BC.Val -> AtomicOrdering

decodeOrdering = toEnum'

decodeSynchScope :: BC.Val -> AtomicSynchScope

decodeSynchScope = toEnum'

-- 47

-- (INST_LANDINGPAD, [ ty, val, num, id0, val0, ...])

-- 48

-- (INST_CLEANUPRET, [val])

-- (INST_CLEANUPRET, [val, bb#])

-- 49

-- (INST_CATCHRET, [val, bb#])

-- 50

-- (INST_CATCHPAD, [bb#, bb#, num, args...])

-- 51

-- (INST_CLEANUPPAD, [num, args...])

-- 52

-- (INST_CATCHSWITCH, [num, args...])

-- (INST_CATCHSWITCH, [num, args..., bb])

-- 53, 54 - Unused

-- (OPERAND_BUNDLE, vals)

-- ignore all other instructions for now.

r -> fail $ "Encountered unhandled instruction " ++ show r