Add support for LLVM address spaces

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

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

src/Data/LLVM/BitCode/IR/Function.hs

@@ -83,15 +83,15 @@ 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
 
 
   -- 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

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

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)

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

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.

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."

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

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