llvm-pretty-bc-parser 0.3.2.0 → 0.4.0.0
raw patch · 7 files changed
+248/−108 lines, 7 filesdep ~llvm-prettyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: llvm-pretty
API changes (from Hackage documentation)
Files
- fuzzing/Main.hs +61/−32
- llvm-pretty-bc-parser.cabal +2/−2
- src/Data/LLVM/BitCode/IR/Function.hs +2/−2
- src/Data/LLVM/BitCode/IR/Globals.hs +21/−9
- src/Data/LLVM/BitCode/IR/Metadata.hs +139/−60
- src/Data/LLVM/BitCode/IR/Module.hs +20/−2
- src/Data/LLVM/BitCode/IR/Types.hs +3/−1
fuzzing/Main.hs view
@@ -62,8 +62,12 @@ -- ^ Whether to collapse failures with the same error message , optReduceDisasm :: Bool -- ^ Whether to try reducing failures at the disasm stage+ , optRunAs :: Bool+ -- ^ Whether to run the assembly stage , optReduceAs :: Bool -- ^ Whether to try reducing failures at the assembly stage+ , optRunExec :: Bool+ -- ^ Whether to run re-execution stage , optReduceExec :: Bool -- ^ Whether to try reducing failures at the execution stage , optHelp :: Bool@@ -80,7 +84,9 @@ , optCsmithPath = Nothing , optCollapse = False , optReduceDisasm = False+ , optRunAs = False , optReduceAs = False+ , optRunExec = False , optReduceExec = False , optHelp = False }@@ -107,12 +113,16 @@ , Option "" ["reduce-disasm"] (NoArg setReduceDisasm) $ "reduce test cases that fail disassembly with a best-guess Creduce " ++ "(requires `--output`)"+ , Option "" ["run-as"] (NoArg setRunAs) $+ "run the re-assembly phase" , Option "" ["reduce-as"] (NoArg setReduceAs) $ "reduce test cases that fail reassembly with a best-guess Creduce " ++ "(requires `--output`)"+ , Option "" ["run-exec"] (NoArg setRunExec) $+ "try to execute the re-assembled program" , Option "" ["reduce-exec"] (NoArg setReduceExec) $- "reduce test cases that fail on test program execution with a " ++- "best-guess Creduce (requires `--output`)"+ "reduce test cases that fail on re-assembled program execution with " +++ "a best-guess Creduce (requires `--output`)" , Option "h" ["help"] (NoArg setHelp) "display this message" ]@@ -159,9 +169,15 @@ setReduceDisasm :: Endo Options setReduceDisasm = Endo (\opt -> opt { optReduceDisasm = True }) +setRunAs :: Endo Options+setRunAs = Endo (\opt -> opt { optRunAs = True })+ setReduceAs :: Endo Options setReduceAs = Endo (\opt -> opt { optReduceAs = True }) +setRunExec :: Endo Options+setRunExec = Endo (\opt -> opt { optRunExec = True })+ setReduceExec :: Endo Options setReduceExec = Endo (\opt -> opt { optReduceExec = True }) @@ -410,12 +426,15 @@ case stripPrefix "clang-" clangExe of Nothing -> "" Just ver -> "--llvm-version=" ++ ver+ ---- Run csmith ---- csmithPath <- getCsmithPath opts callProcess "csmith" [ "-o", tmpDir </> srcFile , "-s", show seed ] srcSize <- getFileSize (tmpDir </> srcFile)++ ---- Run clang ---- h <- spawnProcess clangExe (words flags ++ [ "-I" ++ csmithPath , "-c", "-emit-llvm"@@ -424,6 +443,8 @@ ]) clangErr <- waitForProcess h unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed++ ---- Disassemble ---- (ec, out, err) <- readProcessWithExitCode "llvm-disasm" [ llvmVersion, tmpDir </> bcFile ] "" case ec of@@ -437,36 +458,44 @@ X.throw $!! TestFail DisasmStage seed TestSrc{..} err ExitSuccess -> return () writeFile (tmpDir </> llFile) out- (ec, out, err) <- readProcessWithExitCode clangExe (words flags ++ [- "-I" ++ csmithPath- , tmpDir </> llFile- , "-o", tmpDir </> "ours"- ]) ""- case ec of- ExitFailure c -> do- putStrLn "[AS ERROR]"- putStrLn "[OUT]"- putStr out- putStrLn "[ERR]"- putStr err- putStrLn ("[ERROR CODE " ++ show c ++ "]")- X.throw $!! TestFail AsStage seed TestSrc{..} err- ExitSuccess -> return ()- h <- spawnProcess clangExe (words flags ++ [- "-I" ++ csmithPath- , tmpDir </> bcFile- , "-o", tmpDir </> "golden"- ])- clangErr <- waitForProcess h- unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed- timeout <- getTimeoutCmd- (ec1, out1, err1) <- do- readProcessWithExitCode timeout [ "10", (tmpDir </> "golden") ] ""- unless (ec1 == ExitFailure 124) $ X.throw $!! TestExecTimeout seed- (ec2, out2, err2) <-- readProcessWithExitCode timeout [ "10", (tmpDir </> "ours") ] ""- when (ec1 /= ec2 || out1 /= out2 || err1 /= err2) $- X.throw $!! TestFail ExecStage seed TestSrc{..} err2++ ---- Assemble ----+ when (optRunAs opts) $ do+ (ec, out, err) <- readProcessWithExitCode clangExe (words flags ++ [+ "-I" ++ csmithPath+ , tmpDir </> llFile+ , "-o", tmpDir </> "ours"+ ]) ""+ case ec of+ ExitFailure c -> do+ putStrLn "[AS ERROR]"+ putStrLn "[OUT]"+ putStr out+ putStrLn "[ERR]"+ putStr err+ putStrLn ("[ERROR CODE " ++ show c ++ "]")+ X.throw $!! TestFail AsStage seed TestSrc{..} err+ ExitSuccess -> return ()++ ---- Re-run Clang ----+ when (optRunExec opts) $ do+ h <- spawnProcess clangExe (words flags ++ [+ "-I" ++ csmithPath+ , tmpDir </> bcFile+ , "-o", tmpDir </> "golden"+ ])+ clangErr <- waitForProcess h+ unless (clangErr == ExitSuccess) $ X.throw $!! TestClangError seed+ timeout <- getTimeoutCmd+ (ec1, out1, err1) <- do+ readProcessWithExitCode timeout [ "10", (tmpDir </> "golden") ] ""+ unless (ec1 == ExitFailure 124) $ X.throw $!! TestExecTimeout seed+ (ec2, out2, err2) <-+ readProcessWithExitCode timeout [ "10", (tmpDir </> "ours") ] ""+ when (ec1 /= ec2 || out1 /= out2 || err1 /= err2) $+ X.throw $!! TestFail ExecStage seed TestSrc{..} err2++ ---- Succeed! ---- putStrLn "[PASS]" return (TestPass seed)
llvm-pretty-bc-parser.cabal view
@@ -1,5 +1,5 @@ Name: llvm-pretty-bc-parser-Version: 0.3.2.0+Version: 0.4.0.0 License: BSD3 License-file: LICENSE Author: Trevor Elliott <trevor@galois.com>@@ -57,7 +57,7 @@ fgl >= 5.5, cereal >= 0.3.5.2, bytestring >= 0.9.1,- llvm-pretty>= 0.7.1.0+ llvm-pretty>= 0.7.1.1 Executable llvm-disasm Main-is: LLVMDis.hs
src/Data/LLVM/BitCode/IR/Function.hs view
@@ -758,13 +758,13 @@ return d parseFunctionBlockEntry globals t d (metadataBlockId -> Just es) = do- (_, (globalUnnamedMds, localUnnamedMds), _, _) <- parseMetadataBlock globals t es+ (_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock globals t es unless (null localUnnamedMds) (fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata") return d { partialGlobalMd = globalUnnamedMds ++ partialGlobalMd d } parseFunctionBlockEntry globals t d (metadataAttachmentBlockId -> Just es) = do- (_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt)+ (_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt,_) <- parseMetadataBlock globals t es unless (null localUnnamedMds) (fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata")
src/Data/LLVM/BitCode/IR/Globals.hs view
@@ -11,6 +11,7 @@ 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) @@ -25,6 +26,7 @@ , pgType :: Type , pgValueIx :: Maybe Int , pgAlign :: Maybe Align+ , pgMd :: Map.Map KindMd PValMd } deriving Show -- [ pointer type, isconst, initid@@ -70,19 +72,29 @@ let aval = bit b `shiftR` 1 guard (aval > 0) return aval+ , pgMd = Map.empty } finalizeGlobal :: PartialGlobal -> Parse Global finalizeGlobal pg = case pgValueIx pg of- Nothing -> return (mkGlobal ValNull)+ Nothing -> mkGlobal Nothing Just ix -> do tv <- getFnValueById (pgType pg) (fromIntegral ix)- mkGlobal `fmap` relabel (const requireBbEntryName) (typedValue tv)+ val <- relabel (const requireBbEntryName) (typedValue tv)+ mkGlobal (Just val) where- mkGlobal val = Global- { globalSym = pgSym pg- , globalAttrs = pgAttrs pg- , globalType = pgType pg- , globalValue = Just val- , globalAlign = pgAlign pg- }+ mkGlobal mval =+ do md <- mapM (relabel (const requireBbEntryName)) (pgMd pg)+ return Global { globalSym = pgSym pg+ , globalAttrs = pgAttrs pg+ , globalType = pgType pg+ , globalValue = mval+ , globalAlign = pgAlign pg+ , globalMetadata = md+ }+++setGlobalMetadataAttachment ::+ Map.Map KindMd PValMd ->+ (PartialGlobal -> PartialGlobal)+setGlobalMetadataAttachment pmd pg = pg { pgMd = pmd }
src/Data/LLVM/BitCode/IR/Metadata.hs view
@@ -12,6 +12,7 @@ , InstrMdAttachments , PFnMdAttachments , PKindMd+ , PGlobalAttachments ) where import Data.LLVM.BitCode.Bitstream@@ -25,12 +26,13 @@ import Control.Monad (foldM,guard,mplus,unless,when) import Data.List (mapAccumL) import Data.Maybe (fromMaybe)-import Data.Bits (shiftR, testBit)+import Data.Bits (shiftR, testBit, shiftL)+import Data.Word (Word32,Word64) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as Char8 (unpack) import qualified Data.Map as Map-import qualified Data.Traversable as T + -- Parsing State --------------------------------------------------------------- data MetadataTable = MetadataTable@@ -59,7 +61,12 @@ (ix,es') = addValue' (metadata val) (mtEntries mt) addMdValue :: Typed PValue -> MetadataTable -> MetadataTable-addMdValue tv mt = mt { mtEntries = addValue tv (mtEntries mt) }+addMdValue tv mt = mt { mtEntries = addValue tv' (mtEntries mt) }+ where+ -- explicitly make a metadata value out of a normal value+ tv' = Typed { typedType = PrimType Metadata+ , typedValue = ValMd (ValMdValue tv)+ } nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable nameNode fnLocal isDistinct ix mt = mt@@ -141,6 +148,7 @@ , pmNextName :: Maybe String , pmInstrAttachments :: InstrMdAttachments , pmFnAttachments :: PFnMdAttachments+ , pmGlobalAttachments:: PGlobalAttachments } deriving (Show) emptyPartialMetadata ::@@ -152,12 +160,21 @@ , pmNextName = Nothing , pmInstrAttachments = Map.empty , pmFnAttachments = Map.empty+ , pmGlobalAttachments= Map.empty } updateMetadataTable :: (MetadataTable -> MetadataTable) -> (PartialMetadata -> PartialMetadata) updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) } +addGlobalAttachments ::+ Symbol {- ^ name of the global to attach to ^ -} ->+ (Map.Map KindMd PValMd) {- ^ metadata references to attach ^ -} ->+ (PartialMetadata -> PartialMetadata)+addGlobalAttachments sym mds pm =+ pm { pmGlobalAttachments = Map.insert sym mds (pmGlobalAttachments pm)+ }+ setNextName :: String -> PartialMetadata -> PartialMetadata setNextName name pm = pm { pmNextName = Just name } @@ -229,12 +246,14 @@ type PKindMd = Int type PFnMdAttachments = Map.Map PKindMd PValMd+type PGlobalAttachments = Map.Map Symbol (Map.Map KindMd PValMd) type ParsedMetadata = ( [NamedMd] , ([PartialUnnamedMd],[PartialUnnamedMd]) , InstrMdAttachments , PFnMdAttachments+ , PGlobalAttachments ) parsedMetadata :: PartialMetadata -> ParsedMetadata@@ -243,6 +262,7 @@ , unnamedEntries pm , pmInstrAttachments pm , pmFnAttachments pm+ , pmGlobalAttachments pm ) -- Metadata Parsing ------------------------------------------------------------@@ -342,7 +362,6 @@ let recordSize = length (recordFields r) when (recordSize == 0) (fail "Invalid record")- ctx <- getContext if (recordSize `mod` 2 == 0) then label "function attachment" $ do att <- Map.fromList <$> parseAttachment r 0@@ -354,10 +373,10 @@ return $! addInstrAttachment inst att 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+ --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" @@ -448,7 +467,9 @@ 20 -> label "METADATA_COMPILE_UNIT" $ do let recordSize = length (recordFields r)- when (recordSize < 14 || recordSize > 17)++ -- TODO: update this for llvm-4.0, which bumped the upper bound to 18+ when (recordSize < 14 || recordSize > 18) (fail "Invalid record") ctx <- getContext@@ -458,7 +479,7 @@ mdForwardRefOrNull ctx mt <$> parseField r 2 numeric dicuProducer <- mdStringOrNull ctx mt <$> parseField r 3 numeric dicuIsOptimized <- parseField r 4 nonzero- dicuFlags <- parseField r 5 numeric+ dicuFlags <- mdStringOrNull ctx mt <$> parseField r 5 numeric dicuRuntimeVersion <- parseField r 6 numeric dicuSplitDebugFilename <- mdStringOrNull ctx mt <$> parseField r 7 numeric dicuEmissionKind <- parseField r 8 numeric@@ -558,27 +579,27 @@ pm 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+ -- 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+ -- 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+ -- 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+ -- mdForwardRefOrNull cxt mt <$> parseField r 4 numeric -- TODO fail "not yet implemented" @@ -613,18 +634,34 @@ -- this one is a bit funky: -- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2308 let recordSize = length (recordFields r)- adj i | recordSize > 8 = i + 1- | otherwise = i when (recordSize < 8 || recordSize > 10) (fail "Invalid record") ctx <- getContext- isDistinct <- parseField r 0 nonzero- dilvScope <- mdForwardRefOrNull ctx mt <$> parseField r (adj 1) numeric- dilvName <- mdStringOrNull ctx mt <$> parseField r (adj 2) numeric- dilvFile <- mdForwardRefOrNull ctx mt <$> parseField r (adj 3) numeric++ field0 <- parseField r 0 numeric+ let isDistinct = testBit (field0 :: Word32) 0+ hasAlignment = testBit (field0 :: Word32) 1++ hasTag | not hasAlignment && recordSize > 8 = 1+ | otherwise = 0++ adj i = i + hasTag++ _alignInBits <-+ if hasAlignment+ then do n <- parseField r (adj 8) numeric+ when ((n :: Word64) > fromIntegral (maxBound :: Word32))+ (fail "Alignment value is too large")+ return (fromIntegral n :: Word32)++ else return 0++ dilvScope <- mdForwardRefOrNull ("dilvScope":ctx) mt <$> parseField r (adj 1) numeric+ dilvName <- mdStringOrNull ("dilvName" :ctx) mt <$> parseField r (adj 2) numeric+ dilvFile <- mdForwardRefOrNull ("dilvFile" :ctx) mt <$> parseField r (adj 3) numeric dilvLine <- parseField r (adj 4) numeric- dilvType <- mdForwardRefOrNull ctx mt <$> parseField r (adj 5) numeric+ dilvType <- mdForwardRefOrNull ("dilvType" :ctx) mt <$> parseField r (adj 5) numeric dilvArg <- parseField r (adj 6) numeric dilvFlags <- parseField r (adj 7) numeric return $! updateMetadataTable@@ -643,40 +680,40 @@ -- 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+ -- 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+ -- 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+ -- 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+ -- 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+ -- 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" @@ -699,10 +736,22 @@ (str,rest) -> (rest, Char8.unpack str) return $! updateMetadataTable (addStrings strings) pm + -- [ valueid, n x [id, mdnode] ] 36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do- -- TODO- fail "not yet implemented" + -- the record will always be of odd length+ when (mod (length (recordFields r)) 2 == 0)+ (fail "Invalid record")++ valueId <- parseField r 0 numeric+ sym <- case lookupValueTableAbs valueId vt of+ Just (Typed { typedValue = ValSymbol sym }) -> return sym+ _ -> fail "Non-global referenced"++ refs <- parseGlobalObjectAttachment mt r++ return $! addGlobalAttachments sym refs pm+ 37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do when (length (recordFields r) /= 3) (fail "Invalid record: unsupported layout")@@ -714,12 +763,23 @@ (addDebugInfo isDistinct (DebugInfoGlobalVariableExpression DIGlobalVariableExpression{..})) pm 38 -> label "METADATA_INDEX_OFFSET" $ do- -- TODO- fail "not yet implemented" + when (length (recordFields r) /= 2)+ (fail "Invalid record")++ a <- parseField r 0 numeric+ b <- parseField r 1 numeric+ let _offset = a + (b `shiftL` 32) :: Word64++ -- TODO: is it OK to skip this if we always parse everything?+ return pm+++ -- In the llvm source, this node is processed when the INDEX_OFFSET record is+ -- found. 39 -> label "METADATA_INDEX" $ do- -- TODO- fail "not yet implemented"+ -- TODO: is it OK to skip this if we always parse everything?+ return pm code -> fail ("unknown record code: " ++ show code) @@ -737,6 +797,25 @@ kind <- parseField r (n - 1) numeric md <- getMetadata =<< parseField r n numeric loop (n - 2) ((kind,typedValue md) : acc)+++-- | This is a named version of the metadata list that can show up at the end of+-- a global declaration. It will be of the form @!dbg !2 [!dbg !n, ...]@.+parseGlobalObjectAttachment :: MetadataTable -> Record -> Parse (Map.Map KindMd PValMd)+parseGlobalObjectAttachment mt r = label "parseGlobalObjectAttachment" $+ do cxt <- getContext+ go cxt Map.empty 1+ where+ len = length (recordFields r)++ go cxt acc n | n < len =+ do kind <- getKind =<< parseField r n numeric+ i <- parseField r (n + 1) numeric+ go cxt (Map.insert kind (mdForwardRef cxt mt i) acc) (n + 2)++ go _ acc _ =+ return acc+ -- | Parse a metadata node. parseMetadataNode :: Bool -> MetadataTable -> Record -> PartialMetadata
src/Data/LLVM/BitCode/IR/Module.hs view
@@ -21,6 +21,7 @@ import Data.Monoid (mempty) import Data.Ord (comparing) import qualified Data.Foldable as F+import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Traversable as T @@ -151,8 +152,8 @@ -- METADATA_BLOCK_ID vt <- getValueTable let globalsSoFar = length (partialUnnamedMd pm)- (ns,(gs,_),_,_) <- parseMetadataBlock globalsSoFar vt es- return pm+ (ns,(gs,_),_,_,atts) <- parseMetadataBlock globalsSoFar vt es+ return $ addGlobalAttachments atts pm { partialNamedMd = partialNamedMd pm ++ ns , partialUnnamedMd = partialUnnamedMd pm ++ gs }@@ -318,3 +319,20 @@ if isProto == (0 :: Int) then pushFunProto proto >> return pm else return pm { partialDeclares = partialDeclares pm Seq.|> proto }+++addGlobalAttachments :: PGlobalAttachments -> (PartialModule -> PartialModule)+addGlobalAttachments gs0 pm = pm { partialGlobals = go (partialGlobals pm) gs0 }+ where++ go gs atts | Map.null atts = gs++ go gs atts =+ case Seq.viewl gs of+ Seq.EmptyL -> Seq.empty++ g Seq.:< gs' ->+ let (mb,atts') = Map.updateLookupWithKey (\_ _ -> Nothing) (pgSym g) atts+ in case mb of+ Just md -> g { pgMd = md } Seq.<| go gs' atts'+ Nothing -> g Seq.<| go gs' atts'
src/Data/LLVM/BitCode/IR/Types.hs view
@@ -103,7 +103,9 @@ 5 -> label "TYPE_CODE_LABEL" (addType (PrimType Label)) - 6 -> label "TYPE_CODE_OPAQUE" (addType Opaque)+ 6 -> label "TYPE_CODE_OPAQUE" $ do+ do ident <- getTypeName+ addTypeWithAlias Opaque ident 7 -> label "TYPE_CODE_INTEGER" $ do let field = parseField r