llvm-pretty-bc-parser 0.2.1.0 → 0.3.0.0

raw patch · 16 files changed

+642/−109 lines, 16 filesdep ~llvm-prettyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: llvm-pretty

API changes (from Hackage documentation)

Files

• disasm-test/Main.hs +3/−2
• disasm-test/tests/printf_frexpl.ll +60/−0
• llvm-disasm/LLVMDis.hs +3/−2
• llvm-pretty-bc-parser.cabal +6/−5
• src/Data/LLVM/BitCode/IR.hs +20/−3
• src/Data/LLVM/BitCode/IR/Blocks.hs +30/−0
• src/Data/LLVM/BitCode/IR/Constants.hs +76/−33
• src/Data/LLVM/BitCode/IR/Function.hs +160/−37
• src/Data/LLVM/BitCode/IR/Globals.hs +11/−5
• src/Data/LLVM/BitCode/IR/Metadata.hs +164/−12
• src/Data/LLVM/BitCode/IR/Module.hs +63/−5
• src/Data/LLVM/BitCode/IR/Values.hs +10/−0
• src/Data/LLVM/BitCode/Match.hs +4/−1
• src/Data/LLVM/BitCode/Parse.hs +10/−2
• src/Data/LLVM/BitCode/Record.hs +18/−2
• src/Data/LLVM/CFG.hs +4/−0

@@ -4,7 +4,8 @@ module Main where  import Data.LLVM.BitCode (parseBitCodeLazyFromFile,Error(..),formatError)-import Text.LLVM.AST (Module,ppModule)+import Text.LLVM.AST (Module)+import Text.LLVM.PP (ppLLVM,ppModule)  import Control.Monad (when) import Data.Char (ord,isSpace,chr)@@ -152,7 +153,7 @@     Right m  -> do       tmp        <- getTemporaryDirectory       (parsed,h) <- openTempFile tmp (pfx <.> "ll")-      hPrint h (ppModule m)+      hPrint h (ppLLVM (ppModule m))       hClose h       stripComments parsed       return parsed

@@ -0,0 +1,60 @@+; ModuleID = 'lib/printf-frexpl.c'
+target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128"
+target triple = "x86_64-unknown-linux-gnu"
+
+; Function Attrs: nounwind uwtable
+define x86_fp80 @printf_frexpl(x86_fp80 %x, i32* nocapture %expptr) #0 {
+  %exponent = alloca i32, align 4
+  %_cw = alloca i16, align 2
+  %_ncw = alloca i16, align 2
+  %_ncw1 = alloca i16, align 2
+  call void asm sideeffect "fnstcw $0", "=*m,~{dirflag},~{fpsr},~{flags}"(i16* %_cw) #2, !srcloc !1
+  %1 = load i16* %_cw, align 2, !tbaa !2
+  %2 = or i16 %1, 768
+  store i16 %2, i16* %_ncw, align 2, !tbaa !2
+  call void asm sideeffect "fldcw $0", "*m,~{dirflag},~{fpsr},~{flags}"(i16* %_ncw) #2, !srcloc !6
+  %3 = call x86_fp80 @frexpl(x86_fp80 %x, i32* %exponent) #2
+  %4 = fadd x86_fp80 %3, %3
+  %5 = load i32* %exponent, align 4, !tbaa !7
+  %6 = add nsw i32 %5, -1
+  store i32 %6, i32* %exponent, align 4, !tbaa !7
+  %7 = icmp slt i32 %5, -16381
+  br i1 %7, label %8, label %11
+
+; <label>:8                                       ; preds = %0
+  %9 = add nsw i32 %5, 16381
+  %10 = call x86_fp80 @ldexpl(x86_fp80 %4, i32 %9) #2
+  store i32 -16382, i32* %exponent, align 4, !tbaa !7
+  br label %11
+
+; <label>:11                                      ; preds = %8, %0
+  %12 = phi i32 [ -16382, %8 ], [ %6, %0 ]
+  %.0 = phi x86_fp80 [ %10, %8 ], [ %4, %0 ]
+  store i16 %1, i16* %_ncw1, align 2, !tbaa !2
+  call void asm sideeffect "fldcw $0", "*m,~{dirflag},~{fpsr},~{flags}"(i16* %_ncw1) #2, !srcloc !9
+  store i32 %12, i32* %expptr, align 4, !tbaa !7
+  ret x86_fp80 %.0
+}
+
+; Function Attrs: nounwind
+declare x86_fp80 @frexpl(x86_fp80, i32* nocapture) #1
+
+; Function Attrs: nounwind
+declare x86_fp80 @ldexpl(x86_fp80, i32) #1
+
+attributes #0 = { nounwind uwtable "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" }
+attributes #1 = { nounwind "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" }
+attributes #2 = { nounwind }
+
+!llvm.ident = !{!0}
+
+!0 = !{!"clang version 3.6.2 (tags/RELEASE_362/final)"}
+!1 = !{i32 -2146987380}
+!2 = !{!3, !3, i64 0}
+!3 = !{!"short", !4, i64 0}
+!4 = !{!"omnipotent char", !5, i64 0}
+!5 = !{!"Simple C/C++ TBAA"}
+!6 = !{i32 -2146987172}
+!7 = !{!8, !8, i64 0}
+!8 = !{!"int", !4, i64 0}
+!9 = !{i32 -2146986812}

@@ -1,7 +1,8 @@  import Data.LLVM.BitCode (parseBitCode, formatError) import Data.LLVM.CFG (buildCFG, CFG(..), blockId)-import Text.LLVM.AST (ppModule, defBody, modDefines)+import Text.LLVM.AST (defBody, modDefines)+import Text.LLVM.PP (ppLLVM, ppModule)  import Control.Monad (when) import Data.Graph.Inductive.Graph (nmap, emap)@@ -36,7 +37,7 @@       exitFailure      Right m  -> do-      print (ppModule m)+      print (ppLLVM (ppModule m))       when doCFG $ do         let cfgs  = map (buildCFG . defBody) $ modDefines m             fixup = nmap (show . blockId) . emap (const "")

@@ -1,12 +1,12 @@ Name:                llvm-pretty-bc-parser-Version:             0.2.1.0+Version:             0.3.0.0 License:             BSD3 License-file:        LICENSE Author:              Trevor Elliott <trevor@galois.com> Maintainer:          Trevor Elliott Category:            Text Build-type:          Simple-Cabal-version:       >=1.16+Cabal-version:       >=1.10 Synopsis:            LLVM bitcode parsing library  Description:@@ -53,7 +53,7 @@                        fgl        >= 5.5,                        cereal     >= 0.3.5.2,                        bytestring >= 0.9.1,-                       llvm-pretty>= 0.4.0.0+                       llvm-pretty>= 0.5  Executable llvm-disasm   Main-is:             LLVMDis.hs@@ -69,12 +69,13 @@                        fgl        >= 5.5,                        fgl-visualize >= 0.1,                        cereal     >= 0.3.5.2,-                       llvm-pretty>= 0.4.0.0,+                       llvm-pretty>= 0.5,                        llvm-pretty-bc-parser  Test-suite disasm-test   type:                exitcode-stdio-1.0   Main-is:             Main.hs+  Default-language:    Haskell2010   hs-source-dirs:      disasm-test   Ghc-options:         -Wall   build-depends:       base >= 4 && < 5,@@ -82,5 +83,5 @@                        directory,                        bytestring,                        filepath,-                       llvm-pretty>= 0.4.0.0,+                       llvm-pretty>= 0.5,                        llvm-pretty-bc-parser

@@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}  module Data.LLVM.BitCode.IR where @@ -27,6 +28,22 @@  -- | Parse an LLVM Module out of a Bitstream object. parseModule :: Bitstream -> Parse Module-parseModule bs = do-  unless (bsAppMagic bs == llvmIrMagic) (fail "Bitstream is not an llvm-ir")-  parseModuleBlock =<< match (moduleBlock <=< oneChild) (bsEntries bs)+parseModule Bitstream { bsAppMagic, bsEntries } = label "Bitstream" $ do+  unless (bsAppMagic == llvmIrMagic) (fail "Bitstream is not an llvm-ir")+  parseTopLevel bsEntries+++-- | The only top-level block that we parse currently is the module block. The+-- Identification block that's introduced in 3.8 is ignored. In the future, it+-- might be advantageous to parse it, as it could include information that would+-- aid error reporting.+parseTopLevel :: [Entry] -> Parse Module++parseTopLevel (EntryBlock Block { blockId = 8, blockEntries } : _) =+  parseModuleBlock blockEntries++parseTopLevel (_ : rest) =+  parseTopLevel rest++parseTopLevel [] =+  fail "MODULE_BLOCK missing"

@@ -54,7 +54,18 @@ uselistBlockId :: Match Entry [Entry] uselistBlockId  = fmap blockEntries . hasBlockId 18 <=< block +moduleStrtabBlockId :: Match Entry [Entry]+moduleStrtabBlockId = fmap blockEntries . hasBlockId 19 <=< block +globalvalSummaryBlockId :: Match Entry [Entry]+globalvalSummaryBlockId = fmap blockEntries . hasBlockId 20 <=< block++operandBundleTagsBlockId :: Match Entry [Entry]+operandBundleTagsBlockId = fmap blockEntries . hasBlockId 21 <=< block++metadataKindBlockId :: Match Entry [Entry]+metadataKindBlockId  = fmap blockEntries . hasBlockId 22 <=< block+ -- Module Codes ----------------------------------------------------------------  -- | MODULE_CODE_VERSION@@ -96,4 +107,23 @@ moduleCodeGcname :: Match Entry Record moduleCodeGcname  = hasRecordCode 11 <=< fromEntry +moduleCodeComdat :: Match Entry Record+moduleCodeComdat = hasRecordCode 12 <=< fromEntry +moduleCodeVSTOffset :: Match Entry Record+moduleCodeVSTOffset = hasRecordCode 13 <=< fromEntry++moduleCodeAliasNew :: Match Entry Record+moduleCodeAliasNew = hasRecordCode 14 <=< fromEntry++moduleCodeMDValsUnused :: Match Entry Record+moduleCodeMDValsUnused = hasRecordCode 15 <=< fromEntry++moduleCodeSourceFilename :: Match Entry Record+moduleCodeSourceFilename = hasRecordCode 16 <=< fromEntry++moduleCodeHash :: Match Entry Record+moduleCodeHash = hasRecordCode 17 <=< fromEntry++moduleCodeIFunc :: Match Entry Record+moduleCodeIFunc = hasRecordCode 18 <=< fromEntry

@@ -11,7 +11,7 @@ import Data.LLVM.BitCode.Record import Text.LLVM.AST -import Control.Monad (mplus,mzero,foldM,(<=<))+import Control.Monad (mplus,mzero,foldM,(<=<),when) import Control.Monad.ST (runST,ST) import Data.Array.ST (newArray,readArray,MArray,STUArray) import Data.Bits (shiftL,shiftR,testBit)@@ -34,39 +34,48 @@ binop  = choose <=< numeric   where -  constant = return . const+  constant k kf = return $ \_mb x y ->+    case typedType x of+      PrimType (FloatType _) -> kf x y+      _ -> k x y    nuw x = testBit x 0   nsw x = testBit x 1    -- operations that accept the nuw and nsw flags-  wrapFlags i k = return $ \ mb x y ->-    case mb of-      Nothing -> i (k  False   False)  x y-      Just w  -> i (k (nuw w) (nsw w)) x y+  wrapFlags i k kf = return $ \ mb x y ->+    case typedType x of+      PrimType (FloatType _) -> i kf x y+      _ ->+        case mb of+          Nothing -> i (k  False   False)  x y+          Just w  -> i (k (nuw w) (nsw w)) x y    exact x = testBit x 0    -- operations that accept the exact flag-  exactFlag i k = return $ \ mb x y ->-    case mb of-      Nothing -> i (k  False)    x y-      Just w  -> i (k (exact w)) x y+  exactFlag i k kf = return $ \ mb x y ->+    case typedType x of+      PrimType (FloatType _) -> i kf x y+      _ ->+        case mb of+          Nothing -> i (k  False)    x y+          Just w  -> i (k (exact w)) x y    choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> PInstr)-  choose 0  = wrapFlags Arith Add-  choose 1  = wrapFlags Arith Sub-  choose 2  = wrapFlags Arith Mul-  choose 3  = exactFlag Arith UDiv-  choose 4  = exactFlag Arith SDiv-  choose 5  = constant (Arith URem)-  choose 6  = constant (Arith SRem)-  choose 7  = wrapFlags Bit Shl-  choose 8  = exactFlag Bit Lshr-  choose 9  = exactFlag Bit Ashr-  choose 10 = constant (Bit And)-  choose 11 = constant (Bit Or)-  choose 12 = constant (Bit Xor)+  choose 0  = wrapFlags Arith Add   FAdd+  choose 1  = wrapFlags Arith Sub   FSub+  choose 2  = wrapFlags Arith Mul   FMul+  choose 3  = exactFlag Arith UDiv  FDiv+  choose 4  = exactFlag Arith SDiv  FDiv+  choose 5  = constant (Arith URem) (Arith FRem)+  choose 6  = constant (Arith SRem) (Arith FRem)+  choose 7  = wrapFlags Bit Shl  (error "invalid shl on floating point")+  choose 8  = exactFlag Bit Lshr (error "invalid lshr on floating point")+  choose 9  = exactFlag Bit Ashr (error "invalid ashr on floating point")+  choose 10 = constant (Bit And) (error "invalid and on floating point")+  choose 11 = constant (Bit Or)  (error "invalid or on floating point")+  choose 12 = constant (Bit Xor) (error "invalid xor on floating point")   choose _  = mzero  fcmpOp :: Match Field (Typed PValue -> PValue -> PInstr)@@ -196,7 +205,7 @@     let field = parseField r     ty <- getTy     n  <- field 0 signed-    let val = fromMaybe (ValInteger n) $ do+    let val = fromMaybe (ValInteger (toInteger n)) $ do                 Integer 0 <- elimPrimType ty                 return (ValBool (n /= 0))     return (getTy, Typed ty val:cs)@@ -259,7 +268,7 @@    -- [opcode,opval,opval]   10 -> label "CST_CODE_CE_BINOP" $ do-    fail "not implemented"+    notImplemented    -- [opcode, opty, opval]   11 -> label "CST_CODE_CE_CAST" $ do@@ -292,18 +301,18 @@    -- [opty,opval,opval]   14 -> label "CST_CODE_CE_EXTRACTELT" $ do-    fail "not implemented"+    notImplemented    15 -> label "CST_CODE_CE_INSERTELT" $ do-    fail "not implemented"+    notImplemented    16 -> label "CST_CODE_CE_SHUFFLEVEC" $ do-    fail "not implemented"+    notImplemented    17 -> label "CST_CODE_CE_CMP" $ do-    fail "not implemented"+    notImplemented -  18 -> label "CST_CODE_INLINEASM" $ do+  18 -> label "CST_CODE_INLINEASM_OLD" $ do     let field = parseField r     ty    <- getTy     flags <- field 0 numeric@@ -319,7 +328,7 @@     return (getTy, Typed ty (ValAsm sideEffect alignStack asm cst):cs)    19 -> label "CST_CODE_CE_SHUFFLEVEC_EX" $ do-    fail "not implemented"+    notImplemented    -- [n x operands]   20 -> label "CST_CODE_CE_INBOUNDS_GEP" $ do@@ -358,6 +367,35 @@       FloatType Double -> build ValDouble       _                -> fail "unknown element type in CE_DATA" +  23 -> label "CST_CODE_INLINEASM" $ do+    let field = parseField r+    mask <- field 0 numeric++    let test = testBit (mask :: Word32)+        hasSideEffects = test 0+        isAlignStack   = test 1+        _asmDialect    = mask `shiftR` 2++    let len = length (recordFields r)+    asmStrSize <- field 1 numeric+    when (2 + asmStrSize >= len)+         (fail "Invalid record")++    constStrSize <- field (2 + asmStrSize) numeric+    when (3 + asmStrSize + constStrSize > len)+         (fail "Invalid record")++    asmStr   <- parseSlice r  2               asmStrSize   char+    constStr <- parseSlice r (3 + asmStrSize) constStrSize char++    ty <- getTy+    let val = ValAsm hasSideEffects isAlignStack asmStr constStr++    return (getTy, Typed ty val : cs)++++   code -> fail ("unknown constant record code: " ++ show code)  parseConstantEntry _ st (abbrevDef -> Just _) =@@ -368,8 +406,13 @@   fail ("constant block: unexpected: " ++ show e)  parseCeGep :: ValueTable -> Record -> Parse [Typed PValue]-parseCeGep t r = loop 0+parseCeGep t r = loop firstIdx   where++  -- TODO: we should check the result type if it exists, but for now we+  -- ignore it.+  firstIdx = if odd (length (recordFields r)) then 1 else 0+   field = parseField r    loop n = do@@ -382,7 +425,7 @@ parseWideInteger :: Record -> Parse Integer parseWideInteger r = do   limbs <- parseFields r 0 signed-  return (foldr (\l acc -> acc `shiftL` 64 + l) 0 limbs)+  return (foldr (\l acc -> acc `shiftL` 64 + (toInteger l)) 0 limbs)  resolveNull :: Type -> Parse PValue resolveNull ty = case typeNull ty of

@@ -13,17 +13,21 @@ import Data.LLVM.BitCode.Record import Text.LLVM.AST import Text.LLVM.Labels+import Text.LLVM.PP  import Control.Applicative ((<$>),(<*>)) import Control.Monad (unless,mplus,mzero,foldM,(<=<))-import Data.Bits (shiftR,bit,shiftL)+import Data.Bits (shiftR,bit,shiftL,testBit,(.&.),(.|.),complement) import Data.Int (Int32)+import Data.Word (Word32) import qualified Data.Foldable as F import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Traversable as T +import Debug.Trace + -- Function Aliases ------------------------------------------------------------  type AliasList = Seq.Seq PartialAlias@@ -159,7 +163,7 @@   where   syms = Map.fromList [ (partialName d, partialSymtab d) | d <- F.toList dl ]   lkp fn bid = case Map.lookup fn syms of-    Nothing -> fail ("symbol " ++ show (ppSymbol fn) ++ " is not defined")+    Nothing -> fail ("symbol " ++ show (ppLLVM (ppSymbol fn)) ++ " is not defined")     Just st -> case Map.lookup (SymTabBBEntry bid) st of       Nothing -> fail ("block id " ++ show bid ++ " does not exist")       Just sn -> return (mkBlockLabel sn)@@ -328,7 +332,7 @@     cast'   <-             field (ix+1) castOp     result resty (cast' tv resty) d -  4 -> label "FUNC_CODE_INST_GEP" (parseGEP t False r d)+  4 -> label "FUNC_CODE_INST_GEP_OLD" (parseGEP t (Just False) r d)    -- [opval,ty,opval,opval]   5 -> label "FUNC_CODE_INST_SELECT" $ do@@ -470,22 +474,38 @@     let sval = case typedValue size of           ValInteger i | i == 1 -> Nothing           _                     -> Just size-        aval = bit align `shiftR` 1+        mask :: Word32+        mask = (1 `shiftL` 5) .|. -- inalloca+               (1 `shiftL` 6) .|. -- explicit type+               (1 `shiftL` 7)     -- swift error+        aval = (1 `shiftL` (fromIntegral (align .&. complement mask))) `shiftR` 1+        explicitType = testBit align 6+        ity = if explicitType then PtrTo instty else instty -    ret <- elimPtrTo instty-        `mplus` fail "invalid return type in INST_ALLOCA"+    ret <- if explicitType+              then return instty+              else elimPtrTo instty+                      `mplus` fail "invalid return type in INST_ALLOCA" -    result instty (Alloca ret sval (Just aval)) d+    result ity (Alloca ret sval (Just aval)) d    -- [opty,op,align,vol]   20 -> label "FUNC_CODE_INST_LOAD" $ do     (tv,ix) <- getValueTypePair t r 0-    aval    <- parseField r ix numeric-    ret     <- elimPtrTo (typedType tv)-        `mplus` fail "invalid type to INST_LOAD"++    (ret,ix') <-+      if length (recordFields r) == ix + 3+         then do ty <- getType =<< parseField r ix numeric+                 return (ty,ix+1)++         else do ty <- elimPtrTo (typedType tv)+                           `mplus` fail "invalid type to INST_LOAD"+                 return (ty,ix)++    aval    <- parseField r ix' numeric     let align | aval > 0  = Just (bit aval `shiftR` 1)               | otherwise = Nothing-    result ret (Load tv align) d+    result ret (Load (tv { typedType = PtrTo ret }) align) d    -- 21 is unused   -- 22 is unused@@ -498,7 +518,7 @@     result resTy (VaArg op resTy) d    -- [ptrty,ptr,val,align,vol]-  24 -> label "FUNC_CODE_INST_STORE" $ do+  24 -> label "FUNC_CODE_INST_STORE_OLD" $ do     let field = parseField r     (ptr,ix) <- getValueTypePair t r 0     ty       <- elimPtrTo (typedType ptr)@@ -533,8 +553,7 @@     (c,_)   <- getValueTypePair t r (ix+1)     result (typedType tv) (Select c tv (typedValue fv)) d -  -- 30 is handled lower down, as it's processed the same way as 4-  30 -> label "FUNC_CODE_INST_INBOUNDS_GEP" (parseGEP t True r d)+  30 -> label "FUNC_CODE_INST_INBOUNDS_GEP_OLD" (parseGEP t (Just True) r d)    31 -> label "FUNC_CODE_INST_INDIRECTBR" $ do     let field = parseField r@@ -545,17 +564,42 @@    -- 32 is unused -  33 -> label "FUNC_CODE_INST_LOC_AGAIN" $ do+  33 -> label "FUNC_CODE_DEBUG_LOC_AGAIN" $ do     loc <- getLastLoc     updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d    -- [paramattrs, cc, fnty, fnid, arg0 .. arg n]   34 -> label "FUNC_CODE_INST_CALL" $ do-    (Typed fnty fn,ix) <- getValueTypePair t r 2+    let field = parseField r++    -- pal <- field 0 numeric+    ccinfo <- field 1 numeric++    (mbFnTy, ix) <- if testBit (ccinfo :: Word32) 15+                       then do fnTy <- getType =<< field 2 numeric+                               return (Just fnTy, 3)+                       else    return (Nothing,   2)++    (Typed opTy fn, ix') <- getValueTypePair t r ix+                                `mplus` fail "Invalid record"++    op <- elimPtrTo opTy `mplus` fail "Callee is not a pointer type"++    fnty <- case mbFnTy of+             Just ty | ty == op  -> return op+                     | otherwise -> fail "Explicit call type does not match \+                                         \pointee type of callee operand"++             Nothing ->+               case op of+                 FunTy{} -> return op+                 _       -> fail "Callee is not of pointer to function type"++     label (show fn) $ do-      (ret,as,va) <- elimFunPtr fnty `mplus` fail "invalid CALL record"-      args <- parseCallArgs t va r ix as-      result ret (Call False fnty fn args) d+      (ret,as,va) <- elimFunTy fnty `mplus` fail "invalid CALL record"+      args <- parseCallArgs t va r ix' as+      result ret (Call False opTy fn args) d    -- [Line,Col,ScopeVal, IAVal]   35 -> label "FUNC_CODE_DEBUG_LOC" $ do@@ -603,7 +647,7 @@     effect (Resume tv) d    -- [ty,val,val,num,id0,val0...]-  40 -> label "FUNC_CODE_LANDINGPAD" $ do+  40 -> label "FUNC_CODE_LANDINGPAD_OLD" $ do     let field = parseField r     ty          <- getType =<< field 0 numeric     (persFn,ix) <- getValueTypePair t r 1@@ -618,11 +662,51 @@   41 -> label "FUNC_CODE_LOADATOMIC" $ do     notImplemented -  -- [ptrty,ptr,val, align, vol-  --  ordering, synchscope]-  42 -> label "FUNC_CODE_STOREATOMIC" $ do+  -- [ptrty, ptr, val, align, vol, ordering, synchscope]+  42 -> label "FUNC_CODE_INST_STOREATOMIC_OLD" $ do     notImplemented +  43 -> label "FUNC_CODE_INST_GEP" (parseGEP t Nothing r d)++  44 -> label "FUNC_CODE_INST_STORE" $ do+    let field = parseField r+    (ptr,ix)  <- getValueTypePair t r 0+    (val,ix') <- getValueTypePair t r ix+    aval      <- field ix' numeric+    let align | aval > 0  = Just (bit aval `shiftR` 1)+              | otherwise = Nothing+    effect (Store val ptr align) d++  45 -> label "FUNC_CODE_INST_STOREATOMIC" $ do+    notImplemented++  46 -> label "FUNC_CODE_CMPXCHG" $ do+    notImplemented++  47 -> label "FUNC_CODE_LANDINGPAD" $ do+    notImplemented++  48 -> label "FUNC_CODE_CLEANUPRET" $ do+    notImplemented++  49 -> label "FUNC_CODE_CATCHRET" $ do+    notImplemented++  50 -> label "FUNC_CODE_CATCHPAD" $ do+    notImplemented++  51 -> label "FUNC_CODE_CLEANUPPAD" $ do+    notImplemented++  52 -> label "FUNC_CODE_CATCHSWITCH" $ do+    notImplemented++  -- 53 is unused+  -- 54 is unused++  55 -> label "FUNC_CODE_OPERAND_BUNDLE" $ do+    notImplemented+   -- [opty,opval,opval,pred]   code    |  code == 9@@ -662,6 +746,10 @@   -- ignore any abbreviation definitions   return d +parseFunctionBlockEntry _ d (uselistBlockId -> Just _) = do+  -- ignore the uselist block+  return d+ parseFunctionBlockEntry _ _ e = do   fail ("function block: unexpected: " ++ show e) @@ -689,11 +777,43 @@    go _ _ Seq.EmptyL = Seq.empty +baseType :: Type -> Type+baseType (PtrTo ty) = ty+baseType (Array _ ty) = ty+baseType (Vector _ ty) = ty+baseType ty = ty+ -- [n x operands]-parseGEP :: ValueTable -> Bool -> Record -> PartialDefine -> Parse PartialDefine-parseGEP t ib r d = do-  (tv,ix) <- label "valuetypepair" $ getValueTypePair t r 0-  args    <- label "parseGepArgs" (parseGepArgs t r ix)+parseGEP :: ValueTable -> Maybe Bool -> Record -> PartialDefine -> Parse PartialDefine+parseGEP t mbInBound r d = do+  (ib, tv, r', ix) <-+      case mbInBound of++        -- FUNC_CODE_INST_GEP_OLD+        -- FUNC_CODE_INST_INBOUNDS_GEP_OLD+        Just ib -> do+          (tv,ix') <- getValueTypePair t r 0+          return (ib, tv, r, ix')++        -- FUNC_CODE_INST_GEP+        Nothing -> do+          let r' = flattenRecord r+          let field = parseField r'+          ib <- field 0 boolean+          ty <- getType =<< field 1 numeric+          (tv,ix') <- getValueTypePair t r' 2+          -- TODO: the following sometimes fails, but it doesn't seem to matter.+          {-+          unless (baseType (typedType tv) == ty)+              (fail $ unlines [ "Explicit gep type does not match base type of pointer operand"+                              , "Declared type: " ++ show (ppType ty)+                              , "Operand type: " ++ show (ppType (typedType tv))+                              , "Base type of operand: " ++ show (ppType (baseType (typedType tv)))+                              ])+           -}+          return (ib, tv { typedType = PtrTo ty }, r', ix')++  args    <- label "parseGepArgs" (parseGepArgs t r' ix)   rty     <- label "interpGep"    (interpGep (typedType tv) args)   result rty (GEP ib tv args) d @@ -720,7 +840,7 @@     | relIds    = do       i   <- field n signed       pos <- getNextId-      return (pos - i)+      return (pos - fromIntegral i)     | otherwise =       field n numeric @@ -831,14 +951,17 @@     | n >= len  = return []     | otherwise = do       tv <- getFnValueById ty =<< field n numeric-      case typedValue tv of--        ValInteger i -> do-          l    <- field (n+1) numeric-          rest <- loop (n+2)-          return ((i,l):rest)--        _ -> fail "Invalid SWITCH record"+      i <- case typedValue tv of+             ValInteger i -> return i+             ValBool b -> return (toEnum (fromEnum b))+             v -> fail $ unwords [ "Invalid value in SWITCH record. Found"+                                 , show v+                                 , "at position"+                                 , show n+                                 ]+      l    <- field (n+1) numeric+      rest <- loop (n+2)+      return ((i,l):rest)  -- | See the comment for 'parseSwitchLabels' for information about what this -- does.@@ -879,7 +1002,7 @@       chunks <- parseSlice r lowStart activeWords signed        -- decode limbs in big-endian order-      let low = foldr (\l acc -> acc `shiftL` 64 + l) 0 chunks+      let low = foldr (\l acc -> acc `shiftL` 64 + toInteger l) 0 chunks        (num,n') <-         if isSingleNumber

@@ -9,9 +9,10 @@ import Text.LLVM.AST import Text.LLVM.Labels -import Control.Monad (guard)-import Data.Bits (bit,shiftR)+import Control.Monad (guard,mplus)+import Data.Bits (bit,shiftR,testBit) import qualified Data.Sequence as Seq+import Data.Word (Word32)   -- Global Variables ------------------------------------------------------------@@ -34,7 +35,9 @@ parseGlobalVar n r = label "GLOBALVAR" $ do   let field = parseField r   ptrty   <- getType =<< field 0 numeric-  isconst <-             field 1 numeric+  mask    <-             field 1 numeric+  let isconst    = testBit (mask :: Word32) 0+      explicitTy = testBit  mask            1   initid  <-             field 2 numeric   link    <-             field 3 linkage @@ -42,7 +45,10 @@                 then Just `fmap` field 4 numeric                 else return Nothing -  ty      <- elimPtrTo ptrty+  ty <- if explicitTy+           then return ptrty+           else elimPtrTo ptrty `mplus` fail "Invalid type for value"+   name    <- entryName n   _       <- pushValue (Typed ptrty (ValSymbol (Symbol name)))   let valid | initid == 0 = Nothing@@ -51,7 +57,7 @@         { gaLinkage    = do           guard (link /= External)           return link-        , gaConstant   = isconst == (1 :: Int)+        , gaConstant   = isconst         }    return PartialGlobal

@@ -4,6 +4,7 @@  module Data.LLVM.BitCode.IR.Metadata (     parseMetadataBlock+  , parseMetadataKindEntry   , PartialUnnamedMd(..)   , finalizePartialUnnamedMd   , MetadataAttachments@@ -83,6 +84,10 @@   reference (_,_,r) = ValMdRef r   nodeRef           = reference `fmap` Map.lookup ix (mtNodes mt) +mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd+mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))+                             | otherwise = Nothing+ mdNodeRef :: [String] -> MetadataTable -> Int -> Int mdNodeRef cxt mt ix =   maybe (throw (BadValueRef cxt ix)) prj (Map.lookup ix (mtNodes mt))@@ -241,16 +246,12 @@   7 -> label "METADATA_LOCATION" $ do     cxt       <- getContext     let field = parseField r-    distinct  <- field 0 numeric-    dlLine    <- field 1 numeric-    dlCol     <- field 2 numeric-    scopeId   <- field 3 numeric-    iaIx      <- field 4 numeric-    let dlScope          = mdForwardRef cxt mt scopeId-        dlIA | iaIx > 0  = Just (mdForwardRef cxt mt (iaIx - 1))-             | otherwise = Nothing-        isDistinct       = distinct /= (0 :: Int)-        loc              = DebugLoc { .. }+    isDistinct <- field 0 nonzero+    dlLine     <- field 1 numeric+    dlCol      <- field 2 numeric+    dlScope    <- mdForwardRef cxt mt <$> field 3 numeric+    dlIA       <- mdForwardRefOrNull cxt mt <$> field 4 numeric+    let loc = DebugLoc { .. }     return $! updateMetadataTable (addLoc isDistinct loc) pm  @@ -274,6 +275,152 @@     md   <- parseAttachment r     return $! addAttachment inst md pm +  12 -> label "METADATA_GENERIC_DEBUG" $ do+    isDistinct <- parseField r 0 numeric+    tag <- parseField r 1 numeric+    version <- parseField r 2 numeric+    header <- parseField r 3 string+    -- TODO: parse all remaining fields+    fail "not yet implemented"+  13 -> label "METADATA_SUBRANGE" $ do+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    parseField r 2 signed+    -- TODO+    fail "not yet implemented"+  14 -> label "METADATA_ENUMERATOR" $ do+    isDistinct <- parseField r 0 numeric+    parseField r 1 signed+    parseField r 2 string+    -- TODO+    fail "not yet implemented"+  15 -> label "METADATA_BASIC_TYPE" $ do+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    name <- parseField r 2 numeric+    parseField r 3 numeric+    parseField r 4 numeric+    parseField r 5 numeric+    -- TODO+    fail "not yet implemented"+  16 -> label "METADATA_FILE" $ do+    isDistinct <- parseField r 0 numeric+    name <- parseField r 1 numeric+    dir  <- parseField r 2 numeric+    -- TODO+    fail "not yet implemented"+  17 -> label "METADATA_DERIVED_TYPE" $ do+    -- TODO+    fail "not yet implemented"+  18 -> label "METADATA_COMPOSITE_TYPE" $ do+    -- TODO+    fail "not yet implemented"+  19 -> label "METADATA_SUBROUTINE_TYPE" $ do+    -- TODO+    fail "not yet implemented"+  20 -> label "METADATA_COMPILE_UNIT" $ do+    -- TODO+    fail "not yet implemented"+  21 -> label "METADATA_SUBPROGRAM" $ do+    -- TODO+    fail "not yet implemented"+  22 -> label "METADATA_LEXICAL_BLOCK" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric+    parseField r 3 numeric+    parseField r 4 numeric+    -- TODO+    fail "not yet implemented"+  23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric+    parseField r 3 numeric+    -- TODO+    fail "not yet implemented"+  24 -> label "METADATA_NAMESPACE" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric+    parseField r 3 string+    parseField r 4 numeric+    -- TODO+    fail "not yet implemented"+  25 -> label "METADATA_TEMPLATE_TYPE" $ do+    isDistinct <- parseField r 0 numeric+    parseField r 1 string+    -- getDITypeRefOrNull <$> parseField r 2 numeric+    -- TODO+    fail "not yet implemented"+  26 -> label "METADATA_TEMPLATE_VALUE" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    parseField r 2 string+    -- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 4 numeric+    -- TODO+    fail "not yet implemented"+  27 -> label "METADATA_GLOBAL_VAR" $ do+    -- TODO+    fail "not yet implemented"+  28 -> label "METADATA_LOCAL_VAR" $ do+    -- TODO+    fail "not yet implemented"+  29 -> label "METADATA_EXPRESSION" $ do+    -- TODO+    fail "not yet implemented"+  30 -> label "METADATA_OBJC_PROPERTY" $ do+    -- TODO+    fail "not yet implemented"+  31 -> label "METADATA_IMPORTED_ENTITY" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 2 numeric+    -- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric+    parseField r 4 numeric+    parseField r 5 string+    -- TODO+    fail "not yet implemented"+  32 -> label "METADATA_MODULE" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 1 numeric+    parseField r 2 string+    parseField r 3 string+    parseField r 4 string+    parseField r 5 string+    -- TODO+    fail "not yet implemented"+  33 -> label "METADATA_MACRO" $ do+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    parseField r 2 numeric+    parseField r 3 string+    parseField r 4 string+    -- TODO+    fail "not yet implemented"+  34 -> label "METADATA_MACRO_FILE" $ do+    cxt <- getContext+    isDistinct <- parseField r 0 numeric+    parseField r 1 numeric+    parseField r 2 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 3 numeric+    mdForwardRefOrNull cxt mt <$> parseField r 4 numeric+    -- TODO+    fail "not yet implemented"+  35 -> label "METADATA_STRINGS" $ do+    -- TODO+    fail "not yet implemented"+  36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do+    -- TODO+    fail "not yet implemented"+   code -> fail ("unknown record code: " ++ show code)  parseMetadataEntry _ _ pm (abbrevDef -> Just _) =@@ -298,8 +445,7 @@ parseMetadataNode isDistinct mt r pm = do   ixs <- parseFields r 0 numeric   cxt <- getContext-  let lkp ix | ix > 0    = Just (mdForwardRef cxt mt (ix - 1))-             | otherwise = Nothing+  let lkp = mdForwardRefOrNull cxt mt   return $! updateMetadataTable (addNode isDistinct (map lkp ixs)) pm  @@ -327,3 +473,9 @@     [] -> return []      _ -> fail "Malformed metadata node"++parseMetadataKindEntry :: Record -> Parse ()+parseMetadataKindEntry r = do+  kind <- parseField  r 0 numeric+  name <- parseFields r 1 char+  addKind kind name

@@ -16,7 +16,7 @@ import Data.LLVM.BitCode.Record import Text.LLVM.AST -import Control.Monad (foldM,guard,when)+import Control.Monad (foldM,guard,when,forM_) import Data.List (sortBy) import Data.Monoid (mempty) import Data.Ord (comparing)@@ -133,12 +133,12 @@  parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do   -- PARAMATTR_BLOCK_ID-  -- skip for now+  -- TODO: skip for now   return pm  parseModuleBlockEntry pm (paramattrGroupBlockId -> Just _) = do   -- PARAMATTR_GROUP_BLOCK_ID-  -- skip for now+  -- TODO: skip for now   return pm  parseModuleBlockEntry pm (metadataBlockId -> Just es) = do@@ -183,7 +183,7 @@     }  parseModuleBlockEntry pm (moduleCodeAlias -> Just r) = do-  -- MODULE_CODE_ALIAS+  -- MODULE_CODE_ALIAS_OLD   pa <- parseAlias (partialAliasIx pm) r   return pm     { partialAliasIx = succ (partialAliasIx pm)@@ -207,6 +207,60 @@   name <- parseFields r 0 char   return pm { partialSections = partialSections pm Seq.|> name } +parseModuleBlockEntry _ (moduleCodeComdat -> Just _) = do+  -- MODULE_CODE_COMDAT+  fail "MODULE_CODE_COMDAT"++parseModuleBlockEntry pm (moduleCodeVSTOffset -> Just _) = do+  -- MODULE_CODE_VSTOFFSET+  -- TODO: should we handle this?+  return pm++parseModuleBlockEntry _ (moduleCodeAliasNew -> Just _) = do+  -- MODULE_CODE_ALIAS+  fail "MODULE_CODE_ALIAS"++parseModuleBlockEntry pm (moduleCodeMDValsUnused -> Just _) = do+  -- MODULE_CODE_METADATA_VALUES_UNUSED+  return pm++parseModuleBlockEntry _ (moduleCodeSourceFilename -> Just _) = do+  -- MODULE_CODE_SOURCE_FILENAME+  fail "MODULE_CODE_SOURCE_FILENAME"++parseModuleBlockEntry _ (moduleCodeHash -> Just _) = do+  -- MODULE_CODE_HASH+  fail "MODULE_CODE_HASH"++parseModuleBlockEntry _ (moduleCodeIFunc -> Just _) = do+  -- MODULE_CODE_IFUNC+  fail "MODULE_CODE_IFUNC"++parseModuleBlockEntry _ (uselistBlockId -> Just _) = do+  -- USELIST_BLOCK_ID+  fail "USELIST_BLOCK_ID"++parseModuleBlockEntry _ (moduleStrtabBlockId -> Just _) = do+  -- MODULE_STRTAB_BLOCK_ID+  fail "MODULE_STRTAB_BLOCK_ID"++parseModuleBlockEntry _ (globalvalSummaryBlockId -> Just _) = do+  -- GLOBALVAL_SUMMARY_BLOCK_ID+  fail "GLOBALVAL_SUMMARY_BLOCK_ID"++parseModuleBlockEntry pm (operandBundleTagsBlockId -> Just _) = do+  -- OPERAND_BUNDLE_TAGS_BLOCK_ID+  -- fail "OPERAND_BUNDLE_TAGS_BLOCK_ID"+  return pm++parseModuleBlockEntry pm (metadataKindBlockId -> Just es) = do+  -- METADATA_KIND_BLOCK_ID+  forM_ es $ \e ->+    case fromEntry e of+      Just r -> parseMetadataKindEntry r+      Nothing -> fail "Can't parse metadata kind block entry."+  return pm+ parseModuleBlockEntry _ e =   fail ("unexpected: " ++ show e) @@ -214,7 +268,11 @@ parseFunProto :: Record -> PartialModule -> Parse PartialModule parseFunProto r pm = label "FUNCTION" $ do   let field = parseField r-  ty      <- getType =<< field 0 numeric+  funTy   <- getType =<< field 0 numeric+  let ty = case funTy of+             PtrTo _  -> funTy+             _        -> PtrTo funTy+   isProto <-             field 2 numeric    link    <-             field 3 linkage

@@ -87,6 +87,8 @@ vstCodeBBEntry :: Match Entry Record vstCodeBBEntry  = hasRecordCode 2 <=< fromEntry +vstCodeFNEntry :: Match Entry Record+vstCodeFNEntry  = hasRecordCode 3 <=< fromEntry  -- Value Symbol Table Parsing -------------------------------------------------- @@ -108,6 +110,14 @@   bbid <- field 0 numeric   name <- field 1 (fieldArray (fieldChar6 ||| char))   return (addBBEntry bbid name vs)++parseValueSymbolTableBlockEntry vs (vstCodeFNEntry -> Just r) = do+  -- VST_FNENTRY: [valid, offset, namechar x N]+  let field = parseField r+  valid  <- field 0 numeric+  offset <- field 1 numeric+  name   <- field 2 (fieldArray (fieldChar6 ||| char))+  return (addFNEntry valid offset name vs)  parseValueSymbolTableBlockEntry vs (abbrevDef -> Just _) =   -- skip abbreviation definitions, they're already resolved

@@ -12,7 +12,10 @@  -- | Run a match in the context of the parsing monad. match :: Match i a -> i -> Parse a-match p = maybe (fail "match failed") return . p+match p i =+  case p i of+    Just a  -> return a+    Nothing -> failWithContext "match failed"  -- | The match that always succeeds. keep :: Match i i

@@ -9,6 +9,7 @@ module Data.LLVM.BitCode.Parse where  import Text.LLVM.AST+import Text.LLVM.PP  import Control.Applicative (Applicative(..),Alternative(..),(<$>)) import Control.Monad.Fix (MonadFix)@@ -503,7 +504,7 @@   symtab <- getTypeSymtab   case Map.lookup n (tsByName symtab) of     Just ix -> return ix-    Nothing -> fail ("unknown type alias " ++ show (ppIdent n))+    Nothing -> fail ("unknown type alias " ++ show (ppLLVM (ppIdent n)))   -- Value Symbol Table ----------------------------------------------------------@@ -515,6 +516,7 @@ data SymTabEntry   = SymTabEntry !Int   | SymTabBBEntry !Int+  | SymTabFNEntry !Int     deriving (Eq,Ord,Show)  renderName :: SymName -> String@@ -535,11 +537,17 @@ addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab addBBAnon i n = Map.insert (SymTabBBEntry i) (Right n) +addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab+-- TODO: do we ever need to be able to look up the offset?+addFNEntry i _o n = Map.insert (SymTabFNEntry i) (Left n)+ -- | Lookup the name of an entry. entryName :: Int -> Parse String entryName n = do   symtab <- getValueSymtab-  case Map.lookup (SymTabEntry n) symtab of+  let mentry = Map.lookup (SymTabEntry n) symtab `mplus`+               Map.lookup (SymTabFNEntry n) symtab+  case mentry of     Just i  -> return (renderName i)     Nothing -> fail ("entry " ++ show n ++ " is missing from the symbol table"              ++ "\n" ++ show symtab)

@@ -5,8 +5,10 @@ import Data.LLVM.BitCode.Match import Data.LLVM.BitCode.Parse -import Data.Bits (Bits,testBit,shiftR,bit)+import Data.Bits (testBit,shiftR,bit) import Data.Char (chr)+import Data.Word (Word64)+ import Control.Monad ((<=<),MonadPlus(..),guard)  @@ -74,6 +76,13 @@  type LookupField a = Int -> Match Field a -> Parse a +-- | Flatten arrays inside a record.+flattenRecord :: Record -> Record+flattenRecord r = r { recordFields = concatMap flatten (recordFields r) }+  where+  flatten (FieldArray as) = as+  flatten f               = [f]+ -- | Parse a field from a record. parseField :: Record -> LookupField a parseField r n p = case (p <=< fieldAt n) r of@@ -102,7 +111,7 @@ numeric  = fmap fromBitString . (fieldLiteral ||| fieldFixed ||| fieldVbr)  -- | Parse a @Field@ as a sign-encoded number.-signed :: (Bits a, Num a) => Match Field a+signed :: Match Field Word64 signed  = fmap decode . (fieldLiteral ||| fieldFixed ||| fieldVbr)   where   decode bs@@ -119,6 +128,13 @@     | bsData bs == 1 = return True     | bsData bs == 0 = return False     | otherwise      = mzero++nonzero :: Match Field Bool+nonzero  = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr)+  where+  decode bs+    | bsData bs == 0 = return False+    | otherwise      = return True  char :: Match Field Char char  = fmap chr . numeric

@@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings           #-} {-# LANGUAGE ScopedTypeVariables         #-} {-# LANGUAGE ViewPatterns                #-}+{-# LANGUAGE CPP                         #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}  module Data.LLVM.CFG@@ -22,7 +23,10 @@   ) where +#if !(MIN_VERSION_base(4,8,0)) import           Control.Applicative+#endif+ import           Control.Arrow  import qualified Data.Graph.Inductive.Query.Dominators as Dom