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 c58755d

Browse files
committed
less fsymbols.
1 parent 11b6bb7 commit c58755d

File tree

6 files changed

+136
-40
lines changed

6 files changed

+136
-40
lines changed

‎src/Data/BitCode/LLVM.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ import Data.Word (Word64)
2121

2222
import GHC.Generics (Generic)
2323
import Data.Binary (Binary)
24+
import Data.Set (Set)
2425

2526
--- LLVM Bit Codes -------------------------------------------------------------
2627
-- see LLVMBitCodes.h (e.g. http://llvm.org/docs/doxygen/html/LLVMBitCodes_8h_source.html)
@@ -55,6 +56,11 @@ data Module = Module
5556
-- Only the mValues are used.
5657
, mDecls :: [Symbol] -- ^ Function declarations for functions outside of the module.
5758
, mFns :: [Function] -- ^ Function definitions for function contained within the module.
59+
-- NOTE: while we could compute these from
60+
-- the existing values, doing so is
61+
-- rather expensive. And the constructor
62+
-- might be able to compute these directrly.
63+
, mTypes :: Set Ty
5864
}
5965
deriving (Show, Eq, Generic)
6066

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

Lines changed: 19 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ import Data.BitCode (NBitCode(..), normalize, records, blocks, lookupBlock, look
1313
import qualified Data.BitCode as BC
1414
import Data.BitCode.LLVM
1515
import Data.BitCode.LLVM.Util
16-
import Data.BitCode.LLVM.Classes.HasType
16+
import Data.BitCode.LLVM.Classes.HasTypeasT
1717
import Data.BitCode.LLVM.Reader.Monad
1818
import Data.BitCode.LLVM.ParamAttr
1919
import Data.BitCode.LLVM.IDs.Blocks as B
@@ -38,6 +38,8 @@ import Data.BitCode.LLVM.Codes.Type as TC
3838
import Data.BitCode.LLVM.Codes.Module as M
3939
import Data.Maybe (catMaybes, fromMaybe)
4040

41+
import qualified Data.Set as Set
42+
4143
import qualified Data.BitCode.LLVM.Linkage as Linkage
4244
import qualified Data.BitCode.LLVM.Visibility as Visibility
4345
import qualified Data.BitCode.LLVM.ThreadLocalMode as ThreadLocalMode
@@ -473,7 +475,9 @@ parseModule bs = do
473475

474476
fns <- mapM parseFunction (zip functionDefs functionBlocks)
475477

476-
return $ Module version triple layout values functionDecl fns
478+
typeSet <- Set.fromList <$> askTypeList
479+
480+
return $ Module version triple layout values functionDecl fns typeSet
477481
where
478482
functionBlocks :: [[NBitCode]]
479483
functionBlocks = [bs' | (B.FUNCTION, bs') <- blocks bs ]
@@ -619,6 +623,15 @@ getRelativeVal refs n = do
619623
then fail $ "index " ++ (show idx) ++ " out of range [0, " ++ show (length lst) ++ ") of avaliable relative values."
620624
else pure (lst !! idx)
621625

626+
getRelativeValWithType :: (HasCallStack, Integral a) => Ty -> [Symbol] -> a -> LLVMReader Symbol
627+
getRelativeValWithType ty refs n = do
628+
val <- getRelativeVal refs n
629+
if (T.ty val) == ty
630+
then return val
631+
else do valueList <- askValueList
632+
let lst = reverse (valueList ++ refs)
633+
idx = fromIntegral n - 1
634+
fail $ show val ++ " (" ++ show idx ++ ") doesn't have type " ++ show ty ++ "\nvalues\n" ++ unlines (map show lst)
622635

623636
-- TODO: filter out the `FUNC_CODE_DECLAREBLOCKS` in
624637
-- the foldHelper. We can then simplify the
@@ -697,11 +710,11 @@ parseInst rs = \case
697710
(INST_SWITCH, (opTy:cond:defaultBlock:cases)) -> do
698711
ty <- askType opTy
699712
cond' <- getRelativeVal rs cond
700-
Just . Switch cond' defaultBlock <$> parseCase cases
713+
Just . Switch cond' defaultBlock <$> parseCase ty cases
701714
where
702-
parseCase :: [BC.Val] -> LLVMReader [(Symbol, BasicBlockId)]
703-
parseCase [] = pure []
704-
parseCase (valId:blockId:cases) = (:) <$> ((,blockId) <$> getRelativeVal rs valId) <*> parseCase cases
715+
parseCase :: Ty->[BC.Val] -> LLVMReader [(Symbol, BasicBlockId)]
716+
parseCase ty [] = pure []
717+
parseCase ty (valId:blockId:cases) = (:) <$> ((,blockId) <$> getRelativeValWithType ty rs valId) <*> parseCase ty cases
705718
-- 13
706719
-- (INST_INVOKE, vals)
707720
-- 14 - Unused

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

Lines changed: 51 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import qualified Data.BitCode.LLVM.Codes.Function as FC
2323
import qualified Data.BitCode.LLVM.Codes.ValueSymtab as VST
2424
import qualified Data.Map.Strict as Map
2525
import Data.Map.Strict (Map)
26+
import qualified Data.Set as Set
2627

2728
import Data.BitCode.LLVM.Classes.ToSymbols
2829
import Data.List (elemIndex, sort, sortBy, groupBy, nub)
@@ -42,7 +43,7 @@ import Data.BitCode (denormalize)
4243
import Data.BitCode.Writer (emitTopLevel)
4344
import Data.BitCode.Writer.Monad (evalBitCodeWriter, ask)
4445

45-
import Data.BitCode.LLVM.Pretty
46+
import Data.BitCode.LLVM.Prettyhiding (prettyIndexed)
4647
import Data.BitCode.LLVM.Util
4748
import Text.PrettyPrint ((<+>), text, (<>), int, vcat, Doc, ($+$), empty)
4849
import Control.Applicative ((<|>))
@@ -68,28 +69,47 @@ instance (ToNBitCode a) => ToNBitCode [a] where
6869

6970
instance {-# OVERLAPPING #-} ToNBitCode [T.Ty] where
7071
toBitCode tys
71-
= pure $ mkBlock TYPE_NEW (numEntryRec:concatMap mkTypeRec tys)
72-
where numEntryRec :: NBitCode
72+
= pure $ mkBlock TYPE_NEW (numEntryRec:concatMap mkTypeRec (zip [0..] tys))
73+
where -- A "safe" type lookup, that ensure we do not forward reference, which
74+
-- is only permissable for named structs.
75+
typeList = vcat (map p (zip [(0::Int)..] tys))
76+
where p (i, t) = pretty i <+> text ": " <+> pretty t <+> text (show t)
77+
lookupTypeIndex' :: (HasCallStack, Integral b) => Int -> T.Ty -> Maybe b
78+
lookupTypeIndex' n t = let t' = lookupTypeIndex tys t
79+
in if (fromIntegral t') < n then Just t' else Nothing
80+
numEntryRec :: NBitCode
7381
numEntryRec = mkRec TC.NUMENTRY (length tys)
74-
mkTypeRec :: T.Ty -> [NBitCode]
75-
mkTypeRec T.Void = [ mkEmptyRec TC.VOID ]
76-
mkTypeRec T.Float = [ mkEmptyRec TC.FLOAT ]
77-
mkTypeRec T.Double = [ mkEmptyRec TC.DOUBLE ]
78-
mkTypeRec T.Label = [ mkEmptyRec TC.LABEL ]
79-
mkTypeRec (T.Opaque name) = [ mkRec TC.STRUCT_NAME name, mkEmptyRec TC.OPAQUE ]
80-
mkTypeRec (T.Int w) = [ mkRec TC.INTEGER [w] ]
81-
mkTypeRec (T.Ptr s t) = [ mkRec TC.POINTER [lookupTypeIndex tys t, s] ]
82-
mkTypeRec T.Half = [ mkEmptyRec TC.HALF ]
83-
mkTypeRec (T.Array n t) = [ mkRec TC.ARRAY [n, lookupTypeIndex tys t] ]
84-
mkTypeRec (T.Vector n t) = [ mkRec TC.VECTOR [n, lookupTypeIndex tys t] ]
85-
mkTypeRec T.X86Fp80 = [ mkEmptyRec TC.X86_FP80 ]
86-
mkTypeRec T.Fp128 = [ mkEmptyRec TC.FP128 ]
87-
mkTypeRec T.Metadata = [ mkEmptyRec TC.METADATA ]
88-
mkTypeRec T.X86Mmx = [ mkEmptyRec TC.X86_MMX ]
89-
mkTypeRec (T.StructAnon p ts) = [ mkRec TC.STRUCT_ANON ((if p then 1 else 0 :: Int):map (lookupTypeIndex tys) ts) ]
90-
mkTypeRec (T.StructNamed name p ts)= [ mkRec TC.STRUCT_NAME name, mkRec TC.STRUCT_NAMED ((if p then 1 else 0 :: Int):map (lookupTypeIndex tys) ts) ]
91-
mkTypeRec (T.Function vargs t ts) = [ mkRec TC.FUNCTION ((if vargs then 1 else 0::Int):map (lookupTypeIndex tys) (t:ts)) ]
92-
mkTypeRec T.Token = [ mkEmptyRec TC.TOKEN ]
82+
mkTypeRec :: (Int, T.Ty) -> [NBitCode]
83+
mkTypeRec (i, T.Void) = [ mkEmptyRec TC.VOID ]
84+
mkTypeRec (i, T.Float) = [ mkEmptyRec TC.FLOAT ]
85+
mkTypeRec (i, T.Double) = [ mkEmptyRec TC.DOUBLE ]
86+
mkTypeRec (i, T.Label) = [ mkEmptyRec TC.LABEL ]
87+
mkTypeRec (i, (T.Opaque name)) = [ mkRec TC.STRUCT_NAME name, mkEmptyRec TC.OPAQUE ]
88+
mkTypeRec (i, (T.Int w)) = [ mkRec TC.INTEGER [w] ]
89+
mkTypeRec (i, ty@(T.Ptr s t))
90+
| Just t' <- lookupTypeIndex' i t = [ mkRec TC.POINTER [t', s] ]
91+
| otherwise = error $ "Pointee " ++ show t ++ " must be emitted before " ++ show ty
92+
mkTypeRec (i, T.Half) = [ mkEmptyRec TC.HALF ]
93+
mkTypeRec (i, ty@(T.Array n t))
94+
| Just t' <- lookupTypeIndex' i t = [ mkRec TC.ARRAY [n, t'] ]
95+
| otherwise = error $ "Array " ++ show ty ++ " must not forward reference " ++ show t
96+
mkTypeRec (i, ty@(T.Vector n t))
97+
| Just t' <- lookupTypeIndex' i t = [ mkRec TC.VECTOR [n, t'] ]
98+
| otherwise = error $ "Vector " ++ show ty ++ " must not forward reference " ++ show t
99+
mkTypeRec (i, T.X86Fp80) = [ mkEmptyRec TC.X86_FP80 ]
100+
mkTypeRec (i, T.Fp128) = [ mkEmptyRec TC.FP128 ]
101+
mkTypeRec (i, T.Metadata) = [ mkEmptyRec TC.METADATA ]
102+
mkTypeRec (i, T.X86Mmx) = [ mkEmptyRec TC.X86_MMX ]
103+
mkTypeRec (i, ty@(T.StructAnon p ts))
104+
| Just ts' <- mapM (lookupTypeIndex' i) ts = [ mkRec TC.STRUCT_ANON ((if p then 1 else 0 :: Int):ts') ]
105+
| otherwise = error $ "Anon Struct " ++ show (pretty ty) ++ " must not forward reference its types " ++ show (pretty ts)
106+
mkTypeRec (i, (T.StructNamed name p ts))= [ mkRec TC.STRUCT_NAME name, mkRec TC.STRUCT_NAMED ((if p then 1 else 0 :: Int):map (lookupTypeIndex tys) ts) ]
107+
108+
mkTypeRec (i, ty@(T.Function vargs t ts))
109+
| Just ts' <- mapM (lookupTypeIndex' i) (t:ts) = [ mkRec TC.FUNCTION ((if vargs then 1 else 0::Int):ts') ]
110+
| otherwise = error . show $ text "Function" <+> pretty ty <+> text "must not forward reference its types" <+> pretty (t:ts)
111+
$+$ text "Types:" $+$ typeList
112+
mkTypeRec (i, T.Token) = [ mkEmptyRec TC.TOKEN ]
93113

94114

95115
lookupIndexGeneric :: (HasCallStack, Pretty a, Eq a, Show a, Integral b) => [a] -> a -> b
@@ -229,15 +249,20 @@ instance ToNBitCode (Maybe Ident, Module) where
229249

230250
-- * T Y P E S
231251
-- all top level types, and all the types to construct them. (e.g. i8** -> i8, i8*, and i8**).
232-
topLevelTypes = foldl T.ftypes [] $ map ty flatSymbols
252+
--topLevelTypes = foldl T.ftypes [] $ map ty flatSymbols
233253
-- all symbols of functions, their constants and bodies.
234-
fullFunctionSymbols = fsymbols [] mFns
254+
--fullFunctionSymbols = fsymbols [] mFns
235255
-- The type list now additionally also contains all types that are
236256
-- part of the function signatures, bodies and constants.
237257
--
238258
-- TODO: FLAGS: if -dump-typelist:
239-
-- traceShowWith prettyIndexed $!
240-
typeList = foldl T.ftypes topLevelTypes $ map ty fullFunctionSymbols
259+
-- traceShowWith prettyIndexed $!
260+
-- typeListO = foldl T.ftypes topLevelTypes $ map ty fullFunctionSymbols
261+
-- typeList = traceShowWith (\x -> text "ORIGINAL:"
262+
-- $+$ prettyIndexed typeListO
263+
-- $+$ text "OPTIMIZED:"
264+
-- $+$ prettyIndexed x ) $!
265+
typeList = sortBy T.typeCompare (Set.toList mTypes) --
241266

242267
-- | Turn a set of Constant Values unto BitCode Records.
243268
mkConstBlock :: HasCallStack

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -68,10 +68,11 @@ isPtr _ = False
6868

6969
typeCompare :: Ty -> Ty -> Ordering
7070
typeCompare x y | x == y = EQ
71-
| isPrimitive x && isPrimitive y = if orderIdx x <= orderIdx y thenLTelseGT
71+
| isPrimitive x && isPrimitive y = x `compare` y
7272
-- primitives first
7373
| isPrimitive x && isComplex y = LT
74-
| isComplex x && isComplex y && x `elem` (subTypes y) = LT
74+
| isComplex x && isComplex y && length (subTypes x) < length (subTypes y) = LT
75+
| isComplex x && isComplex y && x `elem` (subTypes y) = LT
7576
| isComplex x && isComplex y && and ((map isLtEq (subTypes x)) <*> subTypes y) = LT
7677
| otherwise = GT
7778
where isLtEq x y = not (GT == typeCompare x y)

‎test/LLVMSpec.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -229,7 +229,8 @@ spec_llvm = do
229229
bcfile <- compile "test/fromBitcode/switch.ll"
230230
ret <- readBitcode bcfile
231231
ret `shouldSatisfy` isModule
232-
let Right mod = ret
232+
let Right mod@(_,mod') = ret
233+
putStrLn . show $ pretty mod'
233234
writeFile' bcfile . map denormalize $ toBitCode mod
234235
ret <- readBitcode bcfile
235236
ret `shouldSatisfy` isModule

‎test/ToBitCodeSpec.hs‎

Lines changed: 55 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,8 @@ import qualified Data.BitCode.LLVM.Value as V
88
import qualified Data.Map.Strict as Map
99
import Data.BitCode.LLVM.ToBitCode (lookupSymbolIndex)
1010

11+
import Data.List (sortBy)
12+
1113
import GHC.Stack (HasCallStack)
1214

1315

@@ -33,14 +35,62 @@ instance Arbitrary T.Ty where
3335
, pure T.Token
3436
]
3537

36-
prop_typeOrdEq :: T.Ty -> Bool
37-
prop_typeOrdEq x = x `compare` x == EQ
38+
--prop_typeOrdEq :: T.Ty -> Bool
39+
--prop_typeOrdEq x = x `compare` x == EQ
3840

3941
spec_bitcode :: Spec
4042
spec_bitcode = do
41-
-- describe "types" $ do
42-
-- when "`compare`ed" $ do
43-
-- it "return EQ" $ property $
43+
describe "types" $ do
44+
context "typeCompared" $ do
45+
let i32 = T.Int 32
46+
i8 = T.Int 8
47+
i8ptr = T.Ptr 0 i8
48+
i8ptrptr = T.Ptr 0 i8ptr
49+
i32ptr = T.Ptr 0 i32
50+
f = T.Function False i32 [i32, i8ptrptr]
51+
a = T.Array 13 i8
52+
aptr = T.Ptr 0 a
53+
f2 = T.Function True i32 [i8ptr]
54+
f3 = T.Function False i32 [i8ptr]
55+
f2ptr = T.Ptr 0 f2
56+
fptr = T.Ptr 0 f
57+
58+
it "should order function types prior to the function" $ do
59+
f `T.typeCompare` i32 `shouldBe` GT
60+
i32 `T.typeCompare` f `shouldBe` LT
61+
f `T.typeCompare` i8ptr `shouldBe` GT
62+
i8ptr `T.typeCompare` f `shouldBe` LT
63+
f `T.typeCompare` i8 `shouldBe` GT
64+
i8 `T.typeCompare` f `shouldBe` LT
65+
f `T.typeCompare` i8ptrptr `shouldBe` GT
66+
i8ptrptr `T.typeCompare` f `shouldBe` LT
67+
68+
it "should sort correctly" $ do
69+
sortBy T.typeCompare [i32ptr,f,i8,i8ptr,i8ptrptr, i32]
70+
`shouldBe` [i8,i32,i8ptr,i32ptr,i8ptrptr,f]
71+
sortBy T.typeCompare [ i8
72+
, i32
73+
, i8ptr
74+
, a
75+
, f2
76+
, f3
77+
, f
78+
, f2ptr
79+
, i8ptrptr
80+
, fptr
81+
, aptr
82+
]
83+
`shouldBe` [ i8
84+
, i32
85+
, i8ptr
86+
, a
87+
, aptr
88+
, i8ptrptr
89+
, f3
90+
, f2
91+
, f2ptr
92+
, f
93+
, fptr ]
4494
-- \x -> x `compare` x == EQ
4595
-- (T.NumEntry 1 `compare` T.NumEntry 1) `shouldBe` EQ
4696
-- (T.Void `compare` T.Void) `shouldBe` EQ

0 commit comments

Comments
(0)

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