Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit e994315

Browse files
committed
Cleanup. (Version 2, trace monad fns)
1 parent c594310 commit e994315

File tree

2 files changed

+32
-20
lines changed

2 files changed

+32
-20
lines changed

‎src/Data/BitCode/LLVM/FromBitCode.hs‎

Lines changed: 32 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,6 @@ import qualified Data.BitCode.LLVM.Flags as Flags
4747
import Data.BitCode.LLVM.Opcodes.Binary as BinOp
4848
import qualified Data.BitCode.LLVM.Opcodes.Cast as CastOp
4949

50-
import Debug.Trace
5150

5251
-- Conceptuall we take bitcode and interpret it as LLVM IR.
5352
-- This should result in a single module.
@@ -340,12 +339,18 @@ parseGlobalVar vals
340339
-- TODO: if less than eight values -> Invalid record.
341340
-- if type can not be reconstructed, invalid record.
342341
-- if ty can not be cast to function type. -> invalid value
342+
343343
parseFunctionDecl :: [BC.Val] -> LLVMReader ()
344-
parseFunctionDecl
345-
[ tyId, cconv, isProto, linkage
346-
, paramAttrId, alignment, section, visibility, gc
347-
, unnamedAddr, prologueDataId, storageClass, comdat
348-
, prefixDataId, personality ]
344+
parseFunctionDecl vals = askVersion >>= \case
345+
1 -> parseFunctionDecl' vals
346+
2 -> parseFunctionDecl' (drop 2 vals)
347+
348+
parseFunctionDecl' :: [BC.Val] -> LLVMReader ()
349+
parseFunctionDecl'
350+
[ tyId, cconv, isProto, linkage -- 4
351+
, paramAttrId, alignment, section, visibility, gc -- 9
352+
, unnamedAddr, prologueDataId, storageClass, comdat -- 13
353+
, prefixDataId, personality ] -- 15
349354
= do
350355
ty <- askType tyId
351356
let prologueData = if prologueDataId /= 0 then Just (Unnamed (FwdRef (prologueDataId -1))) else Nothing
@@ -355,6 +360,7 @@ parseFunctionDecl
355360
(unnamedAddr /= 0) prologueData (toEnum' storageClass)
356361
comdat prefixData personality
357362

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

359365
upgradeDLLImportExportLinkage :: Linkage.Linkage -> DLLStorageClass.DLLStorageClass
360366
upgradeDLLImportExportLinkage = \case
@@ -432,12 +438,13 @@ parseModule bs = do
432438
layout = parseDataLayout <$> lookupRecord DATALAYOUT bs
433439
vst = parseSymbolValueTable <$> lookupBlock VALUE_SYMTAB bs
434440

435-
traceM "Parsing Blocks"
441+
tellVersion version
442+
trace "Parsing Blocks"
436443
flip mapM_ bs $ \case
437444
(NBlock c bs') -> parseModuleBlock (toEnum c, bs')
438445
(NRec c vs) -> parseModuleRecord (toEnum c, vs)
439446

440-
traceM "Parsing VST"
447+
trace "Parsing VST"
441448
-- update values with symbols
442449
case vst of
443450
Just vst -> tellValueSymbolTable vst
@@ -449,15 +456,15 @@ parseModule bs = do
449456
-- obtain a snapshot of all current values
450457
values <- askValueList
451458

452-
traceM "Parsing Decls"
459+
trace "Parsing Decls"
453460

454461
let functionDefs = [f | f@(Named _ (V.Function {..})) <- values, not fIsProto] ++
455462
[f | f@(Unnamed (V.Function {..})) <- values, not fIsProto]
456463
functionDecl = [f | f@(Named _ (V.Function {..})) <- values, fIsProto ] ++
457464
[f | f@(Unnamed (V.Function {..})) <- values, fIsProto ]
458465
(unless (length functionDefs == length functionBlocks)) $ fail $ "#functionDecls (" ++ show (length functionDefs) ++ ") does not match #functionBodies (" ++ show (length functionBlocks) ++ ")"
459466

460-
traceM "Parsing Functions"
467+
trace "Parsing Functions"
461468

462469
fns <- mapM parseFunction (zip functionDefs functionBlocks)
463470

@@ -485,7 +492,7 @@ parseSymbolValueTable = foldl (\l x -> parseSymbolValue x:l) [] . filter f . rec
485492

486493
-- block ids
487494
parseModuleBlock :: (ModuleBlockID, [NBitCode]) -> LLVMReader ()
488-
parseModuleBlock (id,bs) = traceM ("parseModuleBlock " ++ show id) >> case (id,bs) of
495+
parseModuleBlock (id,bs) = trace ("parseModuleBlock " ++ show id) >> case (id,bs) of
489496
({- 9 -}PARAMATTR, bs) -> parseAttr bs
490497
({- 10 -}PARAMATTR_GROUP, bs) -> parseAttrGroup bs
491498
({- 11 -}CONSTANTS, bs) -> parseConstants bs
@@ -500,15 +507,19 @@ parseModuleBlock (id,bs) = traceM ("parseModuleBlock " ++ show id) >> case (id,b
500507
({- 20 -}FUNCTION_SUMMARY, bs) -> return () -- TODO
501508
({- 21 -}OPERAND_BUNDLE_TAGS, bs) -> return () -- TODO
502509
({- 22 -}B.METADATA_KIND, bs) -> parseMetadataKinds bs
503-
c -> fail $ "Encounterd unhandled block: " ++ show c
510+
({- 23 -}STRTAB, bs) -> return () -- TODO
511+
({- 24 -}FULL_LTO_GLOBAL_SUMMARY, bs) -> return () -- TODO
512+
({- 25 -}SYMTAB, bs) -> return () -- TODO
513+
({- 26 -}SYNC_SCOPE_NAMES, bs) -> return () -- TODO
514+
c -> fail $ "Encountered unhandled block: " ++ show c
504515

505516
parseModuleRecord :: (ModuleCode, [BC.Val]) -> LLVMReader ()
506-
parseModuleRecord (id,bs) = traceM ("parseModuleRecord " ++ show id) >> case (id,bs) of
517+
parseModuleRecord (id,bs) = trace ("parseModuleRecord " ++ show id) >> case (id,bs) of
507518
({- 1 -}VERSION, _) -> pure () -- ignore, it's being picked apart somewhere else.
508519
({- 2 -}TRIPLE, _) -> pure () -- ignore
509520
({- 3 -}DATALAYOUT, _) -> pure () -- ignore
510521
-- ({- 4 -}ASM, asm) -> -- unhandled
511-
({- 5 -}SECTIONNAME, name) -> traceM $ "!! ignoring section name " ++ (map toEnum' name)
522+
({- 5 -}SECTIONNAME, name) -> trace $ "!! ignoring section name " ++ (map toEnum' name)
512523
-- ({- 6 -}DEPLIB, name) -- unhanlded, will be removed in 4.0 anyway.
513524
({- 7 -}GLOBALVAR, vs) -> parseGlobalVar vs
514525
({- 8 -}M.FUNCTION, vs) -> parseFunctionDecl vs
@@ -517,10 +528,13 @@ parseModuleRecord (id,bs) = traceM ("parseModuleRecord " ++ show id) >> case (id
517528
-- ({- 11 -}GCNAME, name) -- unhandled
518529
-- ({- 12 -}COMDAT, [ sectionKind, name ]) -- unhandled
519530
-- as we do not jump to the VST, we can safely ignore it here.
520-
({- 13 -}VSTOFFSET, [ offset ]) -> traceM $ "!! ignoring VSTOffset " ++ show offset
531+
({- 13 -}VSTOFFSET, [ offset ]) -> trace $ "!! ignoring VSTOffset " ++ show offset
521532
({- 14 -}ALIAS, vs) -> parseAlias True vs
522533
-- ({- 15 -}METADATA_VALUES, numvals)
523534
-- ignore others; e.g. we only need to parse the ones above in sequence to populate the valuetable properly.
535+
({- 16 -}SOURCE_FILENAME, name) -> trace $ "!! ignoring source filename " ++ (map toEnum' name)
536+
({- 17 -}HASH, vs) -> trace $ "!! ignoring hash " ++ show vs
537+
-- ({- 18 -}IFUNC, [ valty, addrspace, resolverval, link, visibility ])
524538
(id,ops) -> fail $ "Encountered unhandled record: " ++ show id ++ " with ops: " ++ show ops
525539

526540

@@ -587,8 +601,8 @@ parseFunctionBlock :: (ModuleBlockID, [NBitCode]) -> LLVMReader ()
587601
parseFunctionBlock = \case
588602
(CONSTANTS, b) -> parseConstants b
589603
(B.METADATA, b) -> parseMetadata b
590-
(B.METADATA_ATTACHMENT_ID, b) -> traceM ("Ignoring Metadata attachment: " ++ show b)
591-
(B.USELIST, b) -> traceM ("Cannot parse uselist yet (" ++ show b ++ ")") >> return ()
604+
(B.METADATA_ATTACHMENT_ID, b) -> trace ("Ignoring Metadata attachment: " ++ show b)
605+
(B.USELIST, b) -> trace ("Cannot parse uselist yet (" ++ show b ++ ")") >> return ()
592606
_ -> pure ()
593607

594608
getRelativeVal :: (Integral a) => [Symbol] -> a -> LLVMReader Symbol
@@ -804,5 +818,5 @@ parseInst rs = \case
804818
-- 53, 54 - Unused
805819
-- (OPERAND_BUNDLE, vals)
806820
-- ignore all other instructions for now.
807-
r -> fail $ show r
821+
r -> fail $ "Encountered unhandled instruction "++show r
808822

‎src/Data/BitCode/LLVM/ToBitCode.hs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -86,8 +86,6 @@ instance {-# OVERLAPPING #-} ToNBitCode [T.Ty] where
8686
mkTypeRec T.Token = [ mkEmptyRec TC.TOKEN ]
8787

8888

89-
90-
9189
lookupIndexGeneric :: (Pretty a, Eq a, Show a, Integral b) => [a] -> a -> b
9290
lookupIndexGeneric xs x = case elemIndex x xs of
9391
Just i -> fromIntegral i

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /