diff --git a/llvm-pretty b/llvm-pretty index fceba7a3..47d844f0 160000 --- a/llvm-pretty +++ b/llvm-pretty @@ -1 +1 @@ -Subproject commit fceba7a30a1a96a821b4f7fa1e75d0c45d68dc44 +Subproject commit 47d844f0a2721bbf25b12ade14869ec102ac4824 diff --git a/src/Data/LLVM/BitCode/IR/Attrs.hs b/src/Data/LLVM/BitCode/IR/Attrs.hs index b7c2dac9..bd1f79fb 100644 --- a/src/Data/LLVM/BitCode/IR/Attrs.hs +++ b/src/Data/LLVM/BitCode/IR/Attrs.hs @@ -45,3 +45,25 @@ visibility = choose <=< numeric 1 -> return HiddenVisibility 2 -> return ProtectedVisibility _ -> mzero + +threadLocal :: Match Field ThreadLocality +threadLocal = choose <=< numeric + where + choose :: Match Int ThreadLocality + choose n = case n of + 0 -> return NotThreadLocal + 1 -> return ThreadLocal + 2 -> return LocalDynamic + 3 -> return InitialExec + 4 -> return LocalExec + _ -> mzero + +unnamedAddr :: Match Field (Maybe UnnamedAddr) +unnamedAddr = choose <=< numeric + where + choose :: Match Int (Maybe UnnamedAddr) + choose n = case n of + 0 -> return Nothing + 1 -> return $ Just GlobalUnnamedAddr + 2 -> return $ Just LocalUnnamedAddr + _ -> mzero diff --git a/src/Data/LLVM/BitCode/IR/Constants.hs b/src/Data/LLVM/BitCode/IR/Constants.hs index 942037eb..76f1b2ec 100644 --- a/src/Data/LLVM/BitCode/IR/Constants.hs +++ b/src/Data/LLVM/BitCode/IR/Constants.hs @@ -225,7 +225,7 @@ parseConstantEntry t (getTy,cs) (fromEntry -> Just r) = 4 -> label "CST_CODE_INTEGER" $ do let field = parseField r ty <- getTy - n <- field 0 signedWord64 + n <- field 0 signedInt64 let val = fromMaybe (ValInteger (toInteger n)) $ do Integer 0 <- elimPrimType ty return (ValBool (n /= 0)) @@ -540,9 +540,11 @@ parseInlineAsm code getTy r = do let field = parseField r -- If using InlineAsmCode30 or later, we parse the type as an explicit - -- field. + -- field. We use the default function address space, all inline asm is + -- cast to a function type. let parseTy = do ty <- getType =<< field 0 numeric - return (PtrTo ty, 1) + addrSpace <- getDefaultFunctionAddrSpace + return (PtrTo addrSpace ty, 1) -- If using an older InlineAsmCode, then we retrieve the type from the -- current context. let useCurTy = do ty <- getTy diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs index e23d456a..0f5551e1 100644 --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -83,7 +83,7 @@ parseAlias r = do (name, offset) <- oldOrStrtabName n r let field i = parseField r (i + offset) ty <- getType =<< field 0 numeric - _addrSp <- field 1 unsigned + addrSp <- AddrSpace <$> field 1 numeric tgt <- field 2 numeric lnk <- field 3 linkage vis <- field 4 visibility @@ -91,7 +91,7 @@ parseAlias r = do -- XXX: is it the case that the alias type will always be a pointer to the -- aliasee? - _ <- pushValue (Typed (PtrTo ty) (ValSymbol name)) + _ <- pushValue (Typed (PtrTo addrSp ty) (ValSymbol name)) return PartialAlias { paLinkage = Just lnk @@ -122,15 +122,18 @@ type DeclareList = Seq.Seq FunProto -- | Turn a function prototype into a declaration. finalizeDeclare :: FunProto -> Parse Declare finalizeDeclare fp = case protoType fp of - PtrTo (FunTy ret args va) -> return Declare + PtrTo adr (FunTy ret args va) -> return Declare { decLinkage = protoLinkage fp , decVisibility = protoVisibility fp + , decUnnamedAddr = protoUnnamedAddr fp , decRetType = ret , decName = protoSym fp , decArgs = args , decVarArgs = va , decAttrs = [] , decComdat = protoComdat fp + -- TODO what if this isn't equal to adr? + , decAddrSpace = protoAddrSpace fp } _ -> fail "invalid type on function prototype" @@ -144,6 +147,7 @@ type DefineList = Seq.Seq PartialDefine data PartialDefine = PartialDefine { partialLinkage :: Maybe Linkage , partialVisibility :: Maybe Visibility + , partialAddrSpace :: AddrSpace , partialGC :: Maybe GC , partialSection :: Maybe String , partialRetType :: Type @@ -171,6 +175,7 @@ emptyPartialDefine proto = do return PartialDefine { partialLinkage = protoLinkage proto , partialVisibility = protoVisibility proto + , partialAddrSpace = protoAddrSpace proto , partialGC = protoGC proto , partialSection = protoSect proto , partialRetType = rty @@ -246,6 +251,7 @@ finalizePartialDefine lkp pd = return Define { defLinkage = partialLinkage pd , defVisibility = partialVisibility pd + , defAddrSpace = partialAddrSpace pd , defGC = partialGC pd , defAttrs = [] , defRetType = partialRetType pd @@ -599,6 +605,7 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of ty <- getType =<< field 1 numeric -- size type size <- getFnValueById ty =<< field 2 numeric -- size value align <- field 3 numeric -- alignment value + as <- getDefaultAllocaAddrSpace let sval = case typedValue size of ValInteger i | i == 1 -> Nothing @@ -609,13 +616,13 @@ parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of (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 + ity = if explicitType then PtrTo as instty else instty ret <- if explicitType then return instty else Assert.elimPtrTo "In return type:" instty - result ity (Alloca ret sval (Just aval)) d + result ity (Alloca ret as sval (Just aval)) d -- [opty,op,align,vol] 20 -> label "FUNC_CODE_INST_LOAD" $ do @@ -1284,7 +1291,7 @@ interpGep :: Type -> Typed PValue -> [Typed PValue] -> Parse Type interpGep baseTy ptr vs = check (resolveGep baseTy ptr vs) where check res = case res of - HasType rty -> return (PtrTo rty) + HasType rty -> return (PtrTo (ptrAddrSpace ptr) rty) Invalid -> fail $ unlines $ [ "Unable to determine the type of getelementptr" , "Base type: " ++ show baseTy diff --git a/src/Data/LLVM/BitCode/IR/Globals.hs b/src/Data/LLVM/BitCode/IR/Globals.hs index d27d7ab7..7dc25d72 100644 --- a/src/Data/LLVM/BitCode/IR/Globals.hs +++ b/src/Data/LLVM/BitCode/IR/Globals.hs @@ -50,18 +50,37 @@ parseGlobalVar n r = label "GLOBALVAR" $ do vis <- if length (recordFields r) > (6 + offset) && not (link `elem` [Internal, Private]) then field 6 visibility else pure DefaultVisibility + tl <- if length (recordFields r) > (7 + offset) -- && not (link `elem` [Internal, Private]) + then field 7 threadLocal + else pure NotThreadLocal + + unnamed <- + if length (recordFields r) > (8 + offset) + then do + field 8 unnamedAddr + else return Nothing + + addrspace <- if explicitTy + then return . AddrSpace . fromIntegral $ shiftR mask 2 + else case ptrty of + PtrTo as _ -> return as + PtrOpaque as -> return as + _ -> fail $ "Invalid type for value: " ++ show ptrty ty <- if explicitTy then return ptrty else elimPtrTo ptrty `mplus` (fail $ "Invalid type for value: " ++ show ptrty) - _ <- pushValue (Typed (PtrTo ty) (ValSymbol name)) + _ <- pushValue (Typed (PtrTo addrspace ty) (ValSymbol name)) let valid | initid == 0 = Nothing | otherwise = Just (initid - 1) attrs = GlobalAttrs - { gaLinkage = Just link - , gaVisibility = Just vis - , gaConstant = isconst + { gaLinkage = Just link + , gaVisibility = Just vis + , gaThreadLocality = Just tl + , gaUnnamedAddr = unnamed + , gaConstant = isconst + , gaAddrSpace = addrspace } return PartialGlobal diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs index c9558337..a18d4f63 100644 --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -182,7 +182,9 @@ parseModuleBlockEntry pm (moduleCodeDatalayout -> Just r) = do layout <- UTF8.decode <$> parseFields r 0 char case parseDataLayout layout of Nothing -> fail ("unable to parse data layout: ``" ++ layout ++ "''") - Just dl -> return (pm { partialDataLayout = dl }) + Just dl -> do + setDataLayout dl + return (pm { partialDataLayout = dl }) parseModuleBlockEntry pm (moduleCodeAsm -> Just r) = do -- MODULE_CODE_ASM @@ -320,9 +322,14 @@ parseFunProto r pm = label "FUNCTION" $ do (name, offset) <- oldOrStrtabName ix r let field i = parseField r (i + offset) funTy <- getType =<< field 0 numeric + + addrSpace <- if length (recordFields r) >= (16 + offset) + then AddrSpace <$> field 16 numeric + else getDefaultFunctionAddrSpace + let ty = case funTy of - PtrTo _ -> funTy - _ -> PtrTo funTy + PtrTo _ _ -> funTy + _ -> PtrTo addrSpace funTy isProto <- field 2 numeric @@ -342,6 +349,12 @@ parseFunProto r pm = label "FUNCTION" $ do else return Nothing + unnamed <- + if length (recordFields r) >= 9 + then do + field 9 unnamedAddr + else return Nothing + -- push the function type _ <- pushValue (Typed ty (ValSymbol name)) let lkMb t x @@ -359,11 +372,13 @@ parseFunProto r pm = label "FUNCTION" $ do guard (link /= External) return link , protoVisibility = Just vis + , protoUnnamedAddr = unnamed , protoGC = Nothing , protoSym = name , protoIndex = ix , protoSect = section , protoComdat = comdat + , protoAddrSpace = addrSpace } if isProto == (0 :: Int) diff --git a/src/Data/LLVM/BitCode/IR/Types.hs b/src/Data/LLVM/BitCode/IR/Types.hs index ef564bdf..5ca9e0ea 100644 --- a/src/Data/LLVM/BitCode/IR/Types.hs +++ b/src/Data/LLVM/BitCode/IR/Types.hs @@ -116,11 +116,13 @@ parseTypeBlockEntry (fromEntry -> Just r) = case recordCode r of 8 -> label "TYPE_CODE_POINTER" $ do let field = parseField r ty <- field 0 typeRef - when (length (recordFields r) == 2) $ do - -- We do not currently store address spaces in the @llvm-pretty@ AST. - _space <- field 1 keep - return () - addType (PtrTo ty) + space <- AddrSpace <$> if length (recordFields r) == 2 + then + field 1 numeric + else + return 0 + + addType (PtrTo space ty) -- [vararg, attrid, [retty, paramty x N]] 9 -> label "TYPE_CODE_FUNCTION_OLD" $ do @@ -203,9 +205,8 @@ parseTypeBlockEntry (fromEntry -> Just r) = case recordCode r of let field = parseField r when (length (recordFields r) /= 1) $ fail "Invalid opaque pointer record" - -- We do not currently store address spaces in the @llvm-pretty@ AST. - _space <- field 0 keep - addType PtrOpaque + space <- AddrSpace <$> field 0 numeric + addType $ PtrOpaque space 26 -> label "TYPE_CODE_TARGET_TYPE" $ do notImplemented diff --git a/src/Data/LLVM/BitCode/Parse.hs b/src/Data/LLVM/BitCode/Parse.hs index 99c1c440..abc714f5 100644 --- a/src/Data/LLVM/BitCode/Parse.hs +++ b/src/Data/LLVM/BitCode/Parse.hs @@ -111,9 +111,11 @@ data ParseState = ParseState , psNextResultId :: !Int , psTypeName :: Maybe String , psNextTypeId :: !Int + , psNextSymbolId :: !Int , psLastLoc :: Maybe PDebugLoc , psKinds :: !KindTable , psModVersion :: !Int + , psDataLayout :: Maybe DataLayout } deriving (Show) -- | The initial parsing state. @@ -129,9 +131,11 @@ emptyParseState = ParseState , psNextResultId = 0 , psTypeName = Nothing , psNextTypeId = 0 + , psNextSymbolId = 0 , psLastLoc = Nothing , psKinds = emptyKindTable , psModVersion = 0 + , psDataLayout = Nothing } -- | The next implicit result id. @@ -141,6 +145,14 @@ nextResultId = Parse $ do put ps { psNextResultId = psNextResultId ps + 1 } return (psNextResultId ps) +-- | The next implicit result id. +nextSymbolId :: Parse Int +nextSymbolId = Parse $ do + ps <- get + put ps { psNextSymbolId = psNextSymbolId ps + 1 } + return (psNextSymbolId ps) + + type PDebugLoc = DebugLoc' Int setLastLoc :: PDebugLoc -> Parse () @@ -173,6 +185,22 @@ setModVersion v = Parse $ do getModVersion :: Parse Int getModVersion = Parse (psModVersion <$> get) +setDataLayout :: DataLayout -> Parse () +setDataLayout v = Parse $ do + ps <- get + put $! ps { psDataLayout = Just v } + +getDataLayout :: Parse (Maybe DataLayout) +getDataLayout = Parse (psDataLayout <$> get) + +getDefaultFunctionAddrSpace :: Parse AddrSpace +getDefaultFunctionAddrSpace = + maybe (AddrSpace 0) programAddrSpace <$> getDataLayout + +getDefaultAllocaAddrSpace :: Parse AddrSpace +getDefaultAllocaAddrSpace = + maybe (AddrSpace 0) allocaAddrSpace <$> getDataLayout + -- | Sort of a hack to preserve state between function body parses. It would -- really be nice to separate this into a different monad, that could just run -- under the Parse monad, but sort of unnecessary in the long run. @@ -449,14 +477,16 @@ setMdRefs refs = Parse $ do -- Function Prototypes --------------------------------------------------------- data FunProto = FunProto - { protoType :: Type - , protoLinkage :: Maybe Linkage - , protoVisibility :: Maybe Visibility - , protoGC :: Maybe GC - , protoSym :: Symbol - , protoIndex :: Int - , protoSect :: Maybe String - , protoComdat :: Maybe String + { protoType :: Type + , protoLinkage :: Maybe Linkage + , protoVisibility :: Maybe Visibility + , protoUnnamedAddr :: Maybe UnnamedAddr + , protoGC :: Maybe GC + , protoSym :: Symbol + , protoIndex :: Int + , protoSect :: Maybe String + , protoComdat :: Maybe String + , protoAddrSpace :: AddrSpace } deriving Show -- | Push a function prototype on to the prototype stack. diff --git a/src/Data/LLVM/BitCode/Record.hs b/src/Data/LLVM/BitCode/Record.hs index cda8f607..b749f85d 100644 --- a/src/Data/LLVM/BitCode/Record.hs +++ b/src/Data/LLVM/BitCode/Record.hs @@ -182,5 +182,10 @@ oldOrStrtabName n r = do Just st -> do offset <- parseField r 0 numeric len <- parseField r 1 numeric - return (resolveStrtabSymbol st offset len, 2) + if len == 0 + then do + n <- show <$> nextSymbolId + return (Symbol n, 2) + else + return (resolveStrtabSymbol st offset len, 2) Nothing -> fail "New-style name encountered with no string table." diff --git a/unit-test/Tests/FuncDataInstances.hs b/unit-test/Tests/FuncDataInstances.hs index dd38521e..6dfc9e68 100644 --- a/unit-test/Tests/FuncDataInstances.hs +++ b/unit-test/Tests/FuncDataInstances.hs @@ -17,6 +17,7 @@ instance Arbitrary Global where arbitrary = genericArbitrary uniform instance Arbitrary GlobalAttrs where arbitrary = genericArbitrary uniform instance Arbitrary Linkage where arbitrary = genericArbitrary uniform instance Arbitrary Visibility where arbitrary = genericArbitrary uniform +instance Arbitrary ThreadLocality where arbitrary = genericArbitrary uniform instance Arbitrary FunAttr where arbitrary = genericArbitrary uniform instance Arbitrary Define where arbitrary = genericArbitrary uniform diff --git a/unit-test/Tests/PrimInstances.hs b/unit-test/Tests/PrimInstances.hs index 2dd8ee2d..e858cea6 100644 --- a/unit-test/Tests/PrimInstances.hs +++ b/unit-test/Tests/PrimInstances.hs @@ -11,3 +11,5 @@ instance Arbitrary FloatType where arbitrary = genericArbitrary uniform instance Arbitrary FP80Value where arbitrary = genericArbitrary uniform instance Arbitrary Ident where arbitrary = genericArbitrary uniform instance Arbitrary Symbol where arbitrary = genericArbitrary uniform +instance Arbitrary UnnamedAddr where arbitrary = genericArbitrary uniform +instance Arbitrary AddrSpace where arbitrary = genericArbitrary uniform