<commit_before>-- | This module converts the C form of the LLVM IR into a fully
-- referential Haskell version of the IR.  The translation is slightly
-- lossy around integral types in some cases, as Haskell Ints do not
-- have the same range as C ints.  In the vast majority of cases this
-- should not really be an issue, but it is possible to lose
-- information.  If it is an issue it can be changed.
{-# LANGUAGE DeriveDataTypeable, RankNTypes, FlexibleInstances #-}
module Data.LLVM.Parse (
    -- * Types
  ParserOptions(..),
  PositionPrecision(..),
  -- * Helpers
  defaultParserOptions,
  -- * Parser
  parseLLVM,
  parseLLVMFile
  ) where

import Prelude hiding ( catch )

import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad.State
import Data.ByteString.Char8 ( ByteString )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.IORef
import Data.Map ( Map )
import Data.Set ( Set )
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe ( catMaybes )
import Data.Typeable
import Foreign.Ptr

import Data.LLVM.Types
import Data.LLVM.Internal.Interop

-- | Defines the level of precision of position information in the
-- metadata.  LLVM gives very precise information, but tracking all of
-- it can consume excessive amounts of space.  This option allows it
-- to be selectively discarded.
data PositionPrecision = PositionPrecise
                         -- ^ Preserve all information from LLVM (line
                         -- and column numbers)
                       | PositionNone
                         -- ^ Discard all position information
                       deriving (Show, Eq)

-- | Options controlling how 'Module's are constructed.
data ParserOptions = ParserOptions { metaPositionPrecision :: PositionPrecision }
                   deriving (Show, Eq)

-- | Reasonable default parsing options
defaultParserOptions :: ParserOptions
defaultParserOptions = ParserOptions { metaPositionPrecision = PositionNone }

data TranslationException = TooManyReturnValues
                          | InvalidBranchInst
                          | InvalidSwitchLayout
                          | InvalidIndirectBranchOperands
                          | KnotTyingFailure ValueTag
                          | TypeKnotTyingFailure TypeTag
                          | MetaKnotFailure
                          | InvalidSelectArgs !Int
                          | InvalidExtractElementInst !Int
                          | InvalidInsertElementInst !Int
                          | InvalidShuffleVectorInst !Int
                          | InvalidFunctionInTranslateValue
                          | InvalidAliasInTranslateValue
                          | InvalidGlobalVarInTranslateValue
                          | InvalidBinaryOp !Int
                          | InvalidUnaryOp !Int
                          | InvalidGEPInst !Int
                          | InvalidExtractValueInst !Int
                          | InvalidInsertValueInst !Int
                          | InvalidTag String ValueTag
                          | InvalidBlockAddressFunction Value
                          | InvalidBlockAddressBlock Value
                          | InvalidUnconditionalBranchTarget Value
                          | NonConstantTag ValueTag
                          | NonInstructionTag ValueTag
                          | InvalidBranchTarget Value
                          | InvalidSwitchTarget Value
                          | InvalidResumeInst !Int
                          deriving (Show, Typeable)
instance Exception TranslationException

type KnotMonad = StateT KnotState IO
data KnotState = KnotState { valueMap :: Map IntPtr Value
                           , typeMap :: Map IntPtr Type
                           , metaMap :: Map IntPtr Metadata
                           , idSrc :: IORef Int
                           , metaIdSrc :: IORef Int
                           , result :: Maybe Module
                           , visitedTypes :: Set IntPtr
                           , visitedMetadata :: Set IntPtr
                           , localId :: Int
                           , stringCache :: Map ByteString ByteString
                           }

instance InternString (StateT KnotState IO) where
  internString str = do
    s <- get
    let cache = stringCache s
    case M.lookup str cache of
      Just cval -> return cval
      Nothing -> do
        put s { stringCache = M.insert str str cache }
        return str


emptyState :: IORef Int -> IORef Int -> KnotState
emptyState r1 r2 =
  KnotState { valueMap = M.empty
            , typeMap = M.empty
            , metaMap = M.empty
            , idSrc = r1
            , metaIdSrc = r2
            , result = Nothing
            , visitedTypes = S.empty
            , visitedMetadata = S.empty
            , localId = 0
            , stringCache = M.empty
            }

genId :: (KnotState -> IORef Int) -> KnotMonad Int
genId accessor = do
  s <- get
  let r = accessor s
  thisId <- liftIO $ readIORef r
  let nextId = thisId + 1
  nextId `seq` return ()
  liftIO $ writeIORef r nextId

  return thisId

nextId :: KnotMonad Int
nextId = genId idSrc

nextMetaId :: KnotMonad Int
nextMetaId = genId metaIdSrc

-- | Parse the named LLVM file into the LLVM form of the IR (a
-- 'Module').  In the case of an error, a descriptive string will be
-- returned.  The input file can be either LLVM assembly or bitcode.
parseLLVMFile :: ParserOptions -> FilePath -> IO (Either String Module)
parseLLVMFile opts filename = do
  let includeLineNumbers = metaPositionPrecision opts == PositionPrecise
  m <- marshalLLVMFile filename includeLineNumbers

  hasError <- cModuleHasError m<commit_msg>Fix a shadowed variable<commit_after>-- | This module converts the C form of the LLVM IR into a fully
-- referential Haskell version of the IR.  The translation is slightly
-- lossy around integral types in some cases, as Haskell Ints do not
-- have the same range as C ints.  In the vast majority of cases this
-- should not really be an issue, but it is possible to lose
-- information.  If it is an issue it can be changed.
{-# LANGUAGE DeriveDataTypeable, RankNTypes, FlexibleInstances #-}
module Data.LLVM.Parse (
    -- * Types
  ParserOptions(..),
  PositionPrecision(..),
  -- * Helpers
  defaultParserOptions,
  -- * Parser
  parseLLVM,
  parseLLVMFile
  ) where

import Prelude hiding ( catch )

import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad.State
import Data.ByteString.Char8 ( ByteString )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.IORef
import Data.Map ( Map )
import Data.Set ( Set )
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe ( catMaybes )
import Data.Typeable
import Foreign.Ptr

import Data.LLVM.Types
import Data.LLVM.Internal.Interop

-- | Defines the level of precision of position information in the
-- metadata.  LLVM gives very precise information, but tracking all of
-- it can consume excessive amounts of space.  This option allows it
-- to be selectively discarded.
data PositionPrecision = PositionPrecise
                         -- ^ Preserve all information from LLVM (line
                         -- and column numbers)
                       | PositionNone
                         -- ^ Discard all position information
                       deriving (Show, Eq)

-- | Options controlling how 'Module's are constructed.
data ParserOptions = ParserOptions { metaPositionPrecision :: PositionPrecision }
                   deriving (Show, Eq)

-- | Reasonable default parsing options
defaultParserOptions :: ParserOptions
defaultParserOptions = ParserOptions { metaPositionPrecision = PositionNone }

data TranslationException = TooManyReturnValues
                          | InvalidBranchInst
                          | InvalidSwitchLayout
                          | InvalidIndirectBranchOperands
                          | KnotTyingFailure ValueTag
                          | TypeKnotTyingFailure TypeTag
                          | MetaKnotFailure
                          | InvalidSelectArgs !Int
                          | InvalidExtractElementInst !Int
                          | InvalidInsertElementInst !Int
                          | InvalidShuffleVectorInst !Int
                          | InvalidFunctionInTranslateValue
                          | InvalidAliasInTranslateValue
                          | InvalidGlobalVarInTranslateValue
                          | InvalidBinaryOp !Int
                          | InvalidUnaryOp !Int
                          | InvalidGEPInst !Int
                          | InvalidExtractValueInst !Int
                          | InvalidInsertValueInst !Int
                          | InvalidTag String ValueTag
                          | InvalidBlockAddressFunction Value
                          | InvalidBlockAddressBlock Value
                          | InvalidUnconditionalBranchTarget Value
                          | NonConstantTag ValueTag
                          | NonInstructionTag ValueTag
                          | InvalidBranchTarget Value
                          | InvalidSwitchTarget Value
                          | InvalidResumeInst !Int
                          deriving (Show, Typeable)
instance Exception TranslationException

type KnotMonad = StateT KnotState IO
data KnotState = KnotState { valueMap :: Map IntPtr Value
                           , typeMap :: Map IntPtr Type
                           , metaMap :: Map IntPtr Metadata
                           , idSrc :: IORef Int
                           , metaIdSrc :: IORef Int
                           , result :: Maybe Module
                           , visitedTypes :: Set IntPtr
                           , visitedMetadata :: Set IntPtr
                           , localId :: Int
                           , stringCache :: Map ByteString ByteString
                           }

instance InternString (StateT KnotState IO) where
  internString str = do
    s <- get
    let cache = stringCache s
    case M.lookup str cache of
      Just cval -> return cval
      Nothing -> do
        put s { stringCache = M.insert str str cache }
        return str


emptyState :: IORef Int -> IORef Int -> KnotState
emptyState r1 r2 =
  KnotState { valueMap = M.empty
            , typeMap = M.empty
            , metaMap = M.empty
            , idSrc = r1
            , metaIdSrc = r2
            , result = Nothing
            , visitedTypes = S.empty
            , visitedMetadata = S.empty
            , localId = 0
            , stringCache = M.empty
            }

genId :: (KnotState -> IORef Int) -> KnotMonad Int
genId accessor = do
  s <- get
  let r = accessor s
  thisId <- liftIO $ readIORef r
  let nid = thisId + 1
  nid `seq` return ()
  liftIO $ writeIORef r nid

  return thisId

nextId :: KnotMonad Int
nextId = genId idSrc

nextMetaId :: KnotMonad Int
nextMetaId = genId metaIdSrc

-- | Parse the named LLVM file into the LLVM form of the IR (a
-- 'Module').  In the case of an error, a descriptive string will be
-- returned.  The input file can be either LLVM assembly or bitcode.
parseLLVMFile :: ParserOptions -> FilePath -> IO (Either String Module)
parseLLVMFile opts filename = do
  let includeLineNumbers = metaPositionPrecision opts == PositionPrecise
  m <- marshalLLVMFile filename includeLineNumbers

  hasError <- cModuleHasError m
{'fraction_non_alphanumeric': 0.05581876130588337, 'fraction_numerical': 0.0013782410198983548, 'mean_word_length': 1.735626767200754, 'pattern_counts': {'":': 0, '<': 13, '<?xml version=': 0, '>': 19, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5411790', 'n_tokens_mistral': 2863, 'n_tokens_neox': 2786, 'n_words': 970}