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 954aad5

Browse files
committed
more tests.
1 parent c32d6ef commit 954aad5

File tree

8 files changed

+103
-42
lines changed

8 files changed

+103
-42
lines changed

‎src/Data/BitCode/LLVM/Classes/ToSymbols.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -78,7 +78,7 @@ instance ToSymbols Inst where
7878
symbols (I.Call _ _ _ s _ ss) = s:ss
7979
symbols (I.Cmp2 _ s s' _) = [s,s']
8080
symbols (I.Gep _ _ s ss) = s:ss
81-
symbols (I.ExtractValue _ s ss) = s:ss
81+
symbols (I.ExtractValue s _) = [s]
8282
symbols (I.Ret (Just s)) = [s]
8383
symbols (I.Ret Nothing) = []
8484
symbols (I.UBr _) = []
@@ -98,7 +98,7 @@ instance ToSymbols Inst where
9898
fsymbols s_ (I.Call _ _ _ s _ ss) = foldl fsymbols s_ (s:ss)
9999
fsymbols s_ (I.Cmp2 _ s s' _) = foldl fsymbols s_ [s,s']
100100
fsymbols s_ (I.Gep _ _ s ss) = foldl fsymbols s_ (s:ss)
101-
fsymbols s_ (I.ExtractValue _ s ss) =foldlfsymbols s_ (s:ss)
101+
fsymbols s_ (I.ExtractValue s _) =fsymbols s_ s
102102
fsymbols s_ (I.Ret (Just s)) = fsymbols s_ s
103103
fsymbols s_ (I.Ret Nothing) = s_
104104
fsymbols s_ (I.UBr _) = s_

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

Lines changed: 30 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,8 @@ import qualified Data.BitCode.LLVM.Flags as Flags
4949
import Data.BitCode.LLVM.Opcodes.Binary as BinOp
5050
import qualified Data.BitCode.LLVM.Opcodes.Cast as CastOp
5151

52+
import GHC.Stack (HasCallStack)
53+
5254

5355
-- Conceptuall we take bitcode and interpret it as LLVM IR.
5456
-- This should result in a single module.
@@ -194,7 +196,7 @@ toSigned v | testBit v 0 = complement (shift v (-1))
194196
| otherwise = shift v (-1)
195197

196198
-- | Parse constants.
197-
parseConstants :: [NBitCode] -> LLVMReader ()
199+
parseConstants :: HasCallStack=>[NBitCode] -> LLVMReader ()
198200
parseConstants = foldM_ parseConstant undefined . records
199201
where parseConstant :: Ty -> (Constant,[BC.Val]) -> LLVMReader Ty
200202
parseConstant ty = \case
@@ -299,16 +301,16 @@ parseMetadata = mapM_ parseMetadata . records
299301

300302
-- * module codes
301303

302-
parseVersion :: [BC.Val] -> Word64
304+
parseVersion :: HasCallStack=>[BC.Val] -> Word64
303305
parseVersion [v] = v
304306

305-
parseTriple :: [BC.Val] -> String
307+
parseTriple :: HasCallStack=>[BC.Val] -> String
306308
parseTriple = map toEnum'
307309

308-
parseDataLayout :: [BC.Val] -> String
310+
parseDataLayout :: HasCallStack=>[BC.Val] -> String
309311
parseDataLayout = map toEnum'
310312

311-
parseGlobalVar :: [BC.Val] -> LLVMReader ()
313+
parseGlobalVar :: HasCallStack=>[BC.Val] -> LLVMReader ()
312314
parseGlobalVar vals
313315
| length vals < 6 = error $ "Invalid record: Global Var must have at least six operands. " ++ show vals ++ " given."
314316
| [ ptrTyId, isConst, initId, linkage, paramAttrId, section ] <- vals = do
@@ -342,12 +344,12 @@ parseGlobalVar vals
342344
-- if type can not be reconstructed, invalid record.
343345
-- if ty can not be cast to function type. -> invalid value
344346

345-
parseFunctionDecl :: [BC.Val] -> LLVMReader ()
347+
parseFunctionDecl :: HasCallStack=>[BC.Val] -> LLVMReader ()
346348
parseFunctionDecl vals = askVersion >>= \case
347349
1 -> parseFunctionDecl' vals
348350
2 -> parseFunctionDecl' (drop 2 vals)
349351

350-
parseFunctionDecl' :: [BC.Val] -> LLVMReader ()
352+
parseFunctionDecl' :: HasCallStack=>[BC.Val] -> LLVMReader ()
351353
parseFunctionDecl'
352354
[ tyId, cconv, isProto, linkage -- 4
353355
, paramAttrId, alignment, section, visibility, gc -- 9
@@ -370,7 +372,8 @@ upgradeDLLImportExportLinkage = \case
370372
Linkage.Appending -> DLLStorageClass.DLLExport
371373
_ -> DLLStorageClass.Default
372374

373-
parseAlias :: Bool -- ^ New Alias
375+
parseAlias :: HasCallStack
376+
=> Bool -- ^ New Alias
374377
-> [BC.Val] -- Values
375378
-> LLVMReader ()
376379

@@ -404,10 +407,10 @@ parseAlias True [ tyId, addrSpace, valId, linkage ]
404407
= parseAlias True [ tyId, addrSpace, valId, linkage, (fromIntegral (fromEnum Visibility.Default)) ]
405408

406409
-- helper
407-
toEnum' :: (Integral a, Enum e) => a -> e
410+
toEnum' :: (HasCallStack, Integral a, Enum e) => a -> e
408411
toEnum' = toEnum . fromIntegral
409412

410-
parseTopLevel :: [NBitCode] -> LLVMReader (Maybe Ident, Module)
413+
parseTopLevel :: HasCallStack=>[NBitCode] -> LLVMReader (Maybe Ident, Module)
411414
parseTopLevel bs = do
412415
ident <- case lookupBlock IDENTIFICATION bs of
413416
Just b -> Just <$> parseIdent b
@@ -417,7 +420,7 @@ parseTopLevel bs = do
417420
mod <- parseModule moduleBlock
418421
return (ident, mod)
419422

420-
resolveFwdRefs :: [Symbol] -> [Symbol]
423+
resolveFwdRefs :: HasCallStack=>[Symbol] -> [Symbol]
421424
resolveFwdRefs ss = map (fmap' resolveFwdRef') ss
422425
where
423426
-- TODO: Maybe Symbol should be more generic? Symbol a,
@@ -433,7 +436,7 @@ resolveFwdRefs ss = map (fmap' resolveFwdRef') ss
433436
resolveFwdRef' x = x
434437

435438
-- | Parse a module from a set of blocks (the body of the module)
436-
parseModule :: [NBitCode] -> LLVMReader Module
439+
parseModule :: HasCallStack=>[NBitCode] -> LLVMReader Module
437440
parseModule bs = do
438441
let Just version = parseVersion <$> lookupRecord VERSION bs
439442
triple = parseTriple <$> lookupRecord TRIPLE bs
@@ -482,7 +485,7 @@ parseModule bs = do
482485
) . zip [0..]
483486

484487
-- | Parse value symbol table
485-
parseSymbolValueTable :: [NBitCode] -> ValueSymbolTable
488+
parseSymbolValueTable :: HasCallStack=>[NBitCode] -> ValueSymbolTable
486489
parseSymbolValueTable = foldl (\l x -> parseSymbolValue x:l) [] . filter f . records
487490
where parseSymbolValue :: (ValueSymtabCodes, [BC.Val]) -> (Int, ValueSymbolEntry)
488491
parseSymbolValue (VST_CODE_ENTRY, (idx:vs)) = (fromIntegral idx, Entry $ map toEnum' vs)
@@ -493,7 +496,7 @@ parseSymbolValueTable = foldl (\l x -> parseSymbolValue x:l) [] . filter f . rec
493496
f _ = False
494497

495498
-- block ids
496-
parseModuleBlock :: (ModuleBlockID, [NBitCode]) -> LLVMReader ()
499+
parseModuleBlock :: HasCallStack=>(ModuleBlockID, [NBitCode]) -> LLVMReader ()
497500
parseModuleBlock (id,bs) = trace ("parseModuleBlock " ++ show id) >> case (id,bs) of
498501
({- 9 -}PARAMATTR, bs) -> parseAttr bs
499502
({- 10 -}PARAMATTR_GROUP, bs) -> parseAttrGroup bs
@@ -515,7 +518,7 @@ parseModuleBlock (id,bs) = trace ("parseModuleBlock " ++ show id) >> case (id,bs
515518
({- 26 -}SYNC_SCOPE_NAMES, bs) -> return () -- TODO
516519
c -> fail $ "Encountered unhandled block: " ++ show c
517520

518-
parseModuleRecord :: (ModuleCode, [BC.Val]) -> LLVMReader ()
521+
parseModuleRecord :: HasCallStack=>(ModuleCode, [BC.Val]) -> LLVMReader ()
519522
parseModuleRecord (id,bs) = trace ("parseModuleRecord " ++ show id) >> case (id,bs) of
520523
({- 1 -}VERSION, _) -> pure () -- ignore, it's being picked apart somewhere else.
521524
({- 2 -}TRIPLE, _) -> pure () -- ignore
@@ -564,7 +567,7 @@ parseModuleRecord (id,bs) = trace ("parseModuleRecord " ++ show id) >> case (id,
564567
-- Function bodies should come in sequence of their declaration in the GV.
565568
-- prototype functions are external.
566569
--
567-
parseFunction :: (Symbol, [NBitCode]) -> LLVMReader F.Function
570+
parseFunction :: HasCallStack=>(Symbol, [NBitCode]) -> LLVMReader F.Function
568571
parseFunction (f@(Named _ V.Function{..}), b) = do
569572
-- remember the size of the value list. We need to trim it back down after
570573
-- parsing; and might want to attach the new values to the constants of the Function.
@@ -599,18 +602,22 @@ parseFunction ((Unnamed f), b) = parseFunction ((Named "dummy" f), b)
599602
parseFunction _ = fail "Invalid arguments"
600603

601604

602-
parseFunctionBlock :: (ModuleBlockID, [NBitCode]) -> LLVMReader ()
605+
parseFunctionBlock :: HasCallStack=>(ModuleBlockID, [NBitCode]) -> LLVMReader ()
603606
parseFunctionBlock = \case
604607
(CONSTANTS, b) -> parseConstants b
605608
(B.METADATA, b) -> parseMetadata b
606609
(B.METADATA_ATTACHMENT_ID, b) -> trace ("Ignoring Metadata attachment: " ++ show b)
607610
(B.USELIST, b) -> trace ("Cannot parse uselist yet (" ++ show b ++ ")") >> return ()
608611
_ -> pure ()
609612

610-
getRelativeVal :: (Integral a) => [Symbol] -> a -> LLVMReader Symbol
613+
getRelativeVal :: (HasCallStack, Integral a) => [Symbol] -> a -> LLVMReader Symbol
611614
getRelativeVal refs n = do
612615
valueList <- askValueList
613-
pure $ reverse (valueList ++ refs) !! (fromIntegral n - 1)
616+
let lst = reverse (valueList ++ refs)
617+
idx = fromIntegral n - 1
618+
if idx < 0 || idx > length lst
619+
then fail $ "index " ++ (show idx) ++ " out of range [0, " ++ show (length lst) ++ ") of avaliable relative values."
620+
else pure (lst !! idx)
614621

615622

616623
-- TODO: filter out the `FUNC_CODE_DECLAREBLOCKS` in
@@ -630,7 +637,7 @@ foldHelper s@((BasicBlock insts):bbs,vs) instr = do
630637
True -> return ((BasicBlock []):bbs', vs')
631638
False -> return (bbs', vs')
632639

633-
parseInst :: [Symbol] -> (Instruction, [BC.Val]) -> LLVMReader (Maybe Inst)
640+
parseInst :: HasCallStack=>[Symbol] -> (Instruction, [BC.Val]) -> LLVMReader (Maybe Inst)
634641
parseInst rs = \case
635642
-- 1
636643
(DECLAREBLOCKS, x) | length x == 0 -> error "Invalid record: DECLAREBLOCKS must not be empty!"
@@ -728,7 +735,9 @@ parseInst rs = \case
728735
-- (INST_STORE_OLD [ ptrty, ptr, val, align, vol])
729736
-- 25 - Unused
730737
-- 26
731-
-- (INST_EXTRACTVAL, ops)
738+
(INST_EXTRACTVAL, (op:idxs)) -> do
739+
val <- getRelativeVal rs op
740+
return . Just $ ExtractValue val idxs
732741
-- 27
733742
-- (INST_INSERTVAL, ops)
734743
-- 28

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Data.BitCode.LLVM.Codes.SynchronizationScope (AtomicSynchScope)
1818

1919
import GHC.Generics (Generic)
2020
import Data.Binary (Binary)
21+
import Data.Word (Word64)
2122

2223
data TailCallKind = None | Tail | MustTail | NoTail deriving (Eq, Show, Generic)
2324

@@ -52,9 +53,8 @@ data Inst
5253
[Symbol] -- ^ indices.
5354
-- | Extract value
5455
| ExtractValue
55-
Ty -- ^ aggregate type
5656
Symbol -- ^ Value indexed into
57-
[Symbol] -- ^ indices.
57+
[Word64] -- ^ indices.
5858
-- | Return Terminator
5959
| Ret (Maybe Symbol)
6060
-- | Unconditional branch

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -524,11 +524,14 @@ instance ToNBitCode (Maybe Ident, Module) where
524524
, lookupRelativeSymbolIndex' n val
525525
, bbId
526526
]
527-
++ concat [ [ lookupRelativeSymbolIndex' n val
527+
++ concat [ [ lookupSymbolIndex allVals val
528528
, bbId ]
529529
| (val, bbId) <- bbIds
530530
]
531531

532+
mkInstRec n (I.ExtractValue val idxs)
533+
= mkRec FC.INST_EXTRACTVAL $ [ lookupRelativeSymbolIndex' n val ] ++ idxs
534+
532535
mkInstRec n i = error $ "Instruction " ++ (show i) ++ " not yet supported."
533536
-- Fold helper to keep track of the instruction count.
534537
mkInstRecFold :: (Int, [NBitCode]) -> I.Inst -> (Int, [NBitCode])

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -93,8 +93,8 @@ instTy (Inst.AtomicLoad t _ _ _ _) = Just t
9393
-- GEP returns a pointer to it's type.
9494
instTy (Inst.Gep bt _ s idxs) | bt == ty s = Just $ lift $ drill (ty s) idxs
9595
| otherwise = error $ "Broken getElementPointer. Basetype: " ++ show bt ++ " and value type type: " ++ show (lower (ty s)) ++ " don't match!"
96-
instTy (Inst.ExtractValue bt s idxs) | bt == ty s =Just $ drill (ty s) idxs
97-
|otherwise=error$"Broken extractValue. Basetype: "++show bt ++" and value type type: "++show (lower (ty s)) ++" don't match!"
96+
instTy (Inst.ExtractValue s idxs) =Just $ drill' (ty s) (map mkI32Val idxs)
97+
where mkI32Val =Val.Constant (Ty.Int32) .Val.Int.fromIntegral
9898
instTy i = error $ "No instTy for instruction: " ++ show i
9999

100100

‎test/LLVMSpec.hs‎

Lines changed: 44 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -17,13 +17,14 @@ import Data.BitCode.Writer.Combinators (withHeader)
1717

1818
import System.Process (readProcessWithExitCode)
1919
import System.Exit (ExitCode(ExitSuccess))
20-
import System.FilePath ((-<.>))
20+
import System.FilePath ((-<.>), (</>))
2121
import Data.Either (isRight)
22+
import GHC.Stack (HasCallStack)
2223

23-
writeFile' :: FilePath -> [BitCode] -> IO ()
24+
writeFile' :: HasCallStack=>FilePath -> [BitCode] -> IO ()
2425
writeFile' fp = BCM.writeFile fp . withHeader True . emitTopLevel
2526

26-
compile :: FilePath -> IO FilePath
27+
compile :: HasCallStack=>FilePath -> IO FilePath
2728
compile f = do
2829
(exit, _out, _err) <- readProcessWithExitCode
2930
"clang"
@@ -40,7 +41,7 @@ compile f = do
4041
where
4142
fout = f -<.> "bc"
4243

43-
decompile :: FilePath -> IO FilePath
44+
decompile :: HasCallStack=>FilePath -> IO FilePath
4445
decompile f = do
4546
(exit, _out, _err) <- readProcessWithExitCode
4647
"llvm-dis"
@@ -54,12 +55,12 @@ decompile f = do
5455
where
5556
fout = f -<.> "dis"
5657

57-
readBitcode :: FilePath -> IO (Either String (Maybe Ident, Module))
58+
readBitcode :: HasCallStack=>FilePath -> IO (Either String (Maybe Ident, Module))
5859
readBitcode f = do
5960
res <- BC.readFile f
6061
return $ (evalLLVMReader . parseTopLevel . catMaybes . map normalize) =<< res
6162

62-
moduleInstructions :: Module -> [I.Inst]
63+
moduleInstructions :: HasCallStack=>Module -> [I.Inst]
6364
moduleInstructions m =
6465
concatMap funcInsts (LLVM.mFns m)
6566
where
@@ -74,33 +75,54 @@ moduleInstructions m =
7475
-- LLVM EDSL, and as such tests for writing modules
7576
-- should be done there.
7677

77-
isModule :: Either String (Maybe Ident, Module) -> Bool
78+
isModule :: HasCallStack=>Either String (Maybe Ident, Module) -> Bool
7879
isModule = isRight
7980

8081

81-
isCmpXchg :: I.Inst -> Bool
82+
isCmpXchg, isFence, isAtomicRMW, isAtomicLoad, isAtomicStore, isSwitch, isExtractValue
83+
:: HasCallStack => I.Inst -> Bool
84+
8285
isCmpXchg (I.CmpXchg{}) = True
8386
isCmpXchg _ = False
8487

85-
isFence :: I.Inst -> Bool
8688
isFence (I.Fence{}) = True
8789
isFence _ = False
8890

89-
isAtomicRMW :: I.Inst -> Bool
9091
isAtomicRMW (I.AtomicRMW{}) = True
9192
isAtomicRMW _ = False
9293

93-
isAtomicLoad :: I.Inst -> Bool
9494
isAtomicLoad (I.AtomicLoad{}) = True
9595
isAtomicLoad _ = False
9696

97-
isAtomicStore :: I.Inst -> Bool
9897
isAtomicStore (I.AtomicStore{}) = True
9998
isAtomicStore _ = False
10099

101-
isSwitch :: I.Inst -> Bool
102100
isSwitch (I.Switch{}) = True
103-
isSwitch _ = False
101+
isSwitch _ = False
102+
103+
isExtractValue (I.ExtractValue{}) = True
104+
isExtractValue _ = False
105+
106+
107+
compileModule :: HasCallStack => FilePath -> IO (FilePath, (Maybe Ident, Module))
108+
compileModule fname = do
109+
bcfile <- compile $ "test/fromBitcode" </> fname
110+
ret <- readBitcode bcfile
111+
ret `shouldSatisfy` isModule
112+
let Right mod = ret
113+
return (bcfile, mod)
114+
115+
roundtripModule :: HasCallStack => FilePath -> IO [String]
116+
roundtripModule fname = do
117+
(bcfile, mod) <- compileModule fname
118+
-- write the module back into the same file
119+
writeFile' bcfile . map denormalize $ toBitCode mod
120+
-- try to read it again
121+
ret <- readBitcode bcfile
122+
ret `shouldSatisfy` isModule
123+
-- make sure llvm doesn't throw up trying to decompile it
124+
decompile bcfile `shouldReturn` (bcfile -<.> "dis")
125+
lines <$> Prelude.readFile (bcfile -<.> "dis")
104126

105127
spec_llvm :: Spec
106128
spec_llvm = do
@@ -206,3 +228,11 @@ spec_llvm = do
206228
ret <- readBitcode bcfile
207229
ret `shouldSatisfy` isModule
208230
decompile bcfile `shouldReturn` "test/fromBitcode/switch.dis"
231+
232+
it "should be able to read EXTRACT VALUE" $ do
233+
(bcfile, (_mbIdent, mod)) <- compileModule "extractvalue.ll"
234+
moduleInstructions mod `shouldSatisfy` (any isExtractValue)
235+
236+
it "should be able to roundtrip EXTRACT VALUE" $ do
237+
_ <- roundtripModule "extractvalue.ll"
238+
return ()

‎test/fromBitcode/extractvalue.ll‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
2+
define i32 @main() {
3+
%ptr = alloca { i32, i1 }
4+
store { i32, i1 } { i32 1, i1 1 }, { i32, i1 }* %ptr
5+
%val = load { i32, i1 }, { i32, i1 }* %ptr
6+
7+
%ret = extractvalue { i32, i1 } %val, 0
8+
9+
ret i32 %ret
10+
}

‎test/fromBitcode/memset.ll‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
2+
declare void @llvm.memset.i32(i8*, i8, i32, i32)
3+
; declare void @llvm.memset.p0i8.i64(i8*, i8, i64, i32)
4+
5+
define i32 @main() {
6+
%ptr = alloca i8, i8 16, align 4
7+
call void @llvm.memset.i32(i8* %ptr, i8 0, i32 16, i32 4)
8+
ret i32 0
9+
}

0 commit comments

Comments
(0)

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