Commit 720a87c7 authored by Peter Wortmann's avatar Peter Wortmann Committed by dterei

Extend globals to aliases

Also give them a proper constructor - getGlobalVar and getGlobalValue
map directly to the accessors.
parent 99d39221
...@@ -32,7 +32,8 @@ module Llvm ( ...@@ -32,7 +32,8 @@ module Llvm (
-- * Variables and Type System -- * Variables and Type System
LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
LlvmAlias, LMGlobal, LMString, LMSection, LMAlign, LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
LMConst(..),
-- ** Some basic types -- ** Some basic types
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
...@@ -42,7 +43,7 @@ module Llvm ( ...@@ -42,7 +43,7 @@ module Llvm (
-- ** Operations on the type system. -- ** Operations on the type system.
isGlobal, getLitType, getVarType, isGlobal, getLitType, getVarType,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, getLink, getStatType, pVarLift, pVarLower,
pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
-- * Pretty Printing -- * Pretty Printing
......
...@@ -61,7 +61,7 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls ...@@ -61,7 +61,7 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
-- | Print out a global mutable variable definition -- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> SDoc ppLlvmGlobal :: LMGlobal -> SDoc
ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
let sect = case x of let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x') Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty Nothing -> empty
...@@ -74,12 +74,16 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = ...@@ -74,12 +74,16 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
Just stat -> ppr stat Just stat -> ppr stat
Nothing -> ppr (pLower $ getVarType var) Nothing -> ppr (pLower $ getVarType var)
const' = if c then text "constant" else text "global" -- Position of linkage is different for aliases.
const_link = case c of
Global -> ppr link <+> text "global"
Constant -> ppr link <+> text "constant"
Alias -> text "alias" <+> ppr link
in ppAssignment var $ ppr link <+> const' <+> rhs <> sect <> align in ppAssignment var $ const_link <+> rhs <> sect <> align
$+$ newLine $+$ newLine
ppLlvmGlobal (var, val) = sdocWithDynFlags $ \dflags -> ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
error $ "Non Global var ppr as global! " error $ "Non Global var ppr as global! "
++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val) ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
......
...@@ -27,7 +27,11 @@ import GHC.Float ...@@ -27,7 +27,11 @@ import GHC.Float
-- --
-- | A global mutable variable. Maybe defined or external -- | A global mutable variable. Maybe defined or external
type LMGlobal = (LlvmVar, Maybe LlvmStatic) data LMGlobal = LMGlobal {
getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal'
getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
}
-- | A String in LLVM -- | A String in LLVM
type LMString = FastString type LMString = FastString
...@@ -86,7 +90,11 @@ ppParams varg p ...@@ -86,7 +90,11 @@ ppParams varg p
-- | An LLVM section definition. If Nothing then let LLVM decide the section -- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString type LMSection = Maybe LMString
type LMAlign = Maybe Int type LMAlign = Maybe Int
type LMConst = Bool -- ^ is a variable constant or not
data LMConst = Global -- ^ Mutable global variable
| Constant -- ^ Constant global variable
| Alias -- ^ Alias of another variable
deriving (Eq)
-- | LLVM Variables -- | LLVM Variables
data LlvmVar data LlvmVar
...@@ -239,14 +247,6 @@ getStatType (LMAdd t _) = getStatType t ...@@ -239,14 +247,6 @@ getStatType (LMAdd t _) = getStatType t
getStatType (LMSub t _) = getStatType t getStatType (LMSub t _) = getStatType t
getStatType (LMComment _) = error "Can't call getStatType on LMComment!" getStatType (LMComment _) = error "Can't call getStatType on LMComment!"
-- | Return the 'LlvmType' of the 'LMGlobal'
getGlobalType :: LMGlobal -> LlvmType
getGlobalType (v, _) = getVarType v
-- | Return the 'LlvmVar' part of a 'LMGlobal'
getGlobalVar :: LMGlobal -> LlvmVar
getGlobalVar (v, _) = v
-- | Return the 'LlvmLinkageType' for a 'LlvmVar' -- | Return the 'LlvmLinkageType' for a 'LlvmVar'
getLink :: LlvmVar -> LlvmLinkageType getLink :: LlvmVar -> LlvmLinkageType
getLink (LMGlobalVar _ _ l _ _ _) = l getLink (LMGlobalVar _ _ l _ _ _) = l
...@@ -634,7 +634,7 @@ instance Outputable LlvmLinkageType where ...@@ -634,7 +634,7 @@ instance Outputable LlvmLinkageType where
-- in Llvm. -- in Llvm.
ppr ExternallyVisible = empty ppr ExternallyVisible = empty
ppr External = text "external" ppr External = text "external"
ppr Private = text "private"
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- * LLVM Operations -- * LLVM Operations
......
...@@ -128,8 +128,9 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars ...@@ -128,8 +128,9 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars
cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
ty = (LMArray (length ivars') i8Ptr) ty = (LMArray (length ivars') i8Ptr)
usedArray = LMStaticArray (map cast ivars') ty usedArray = LMStaticArray (map cast ivars') ty
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) (Just $ fsLit "llvm.metadata") Nothing Global
lmUsed = LMGlobal lmUsedVar (Just usedArray)
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
= cmmProcLlvmGens dflags h us env cmms count ivars = cmmProcLlvmGens dflags h us env cmms count ivars
......
...@@ -261,7 +261,7 @@ genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env ...@@ -261,7 +261,7 @@ genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env
genStringLabelRef :: DynFlags -> LMString -> LMGlobal genStringLabelRef :: DynFlags -> LMString -> LMGlobal
genStringLabelRef dflags cl genStringLabelRef dflags cl
= let ty = LMPointer $ LMArray 0 (llvmWord dflags) = let ty = LMPointer $ LMArray 0 (llvmWord dflags)
in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) in LMGlobal (LMGlobalVar cl ty External Nothing Nothing Global) Nothing
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- * Misc -- * Misc
......
...@@ -156,7 +156,7 @@ oldBarrier env = do ...@@ -156,7 +156,7 @@ oldBarrier env = do
FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags)
let fty = LMFunction funSig let fty = LMFunction funSig
let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Global
let tops = case funLookup fname env of let tops = case funLookup fname env of
Just _ -> [] Just _ -> []
Nothing -> [CmmData Data [([],[fty])]] Nothing -> [CmmData Data [([],[fty])]]
...@@ -417,14 +417,14 @@ getFunPtr env funTy targ = case targ of ...@@ -417,14 +417,14 @@ getFunPtr env funTy targ = case targ of
Just ty'@(LMFunction sig) -> do Just ty'@(LMFunction sig) -> do
-- Function in module in right form -- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig) let fun = LMGlobalVar name ty' (funcLinkage sig)
Nothing Nothing False Nothing Nothing Global
return (env, fun, nilOL, []) return (env, fun, nilOL, [])
Just ty' -> do Just ty' -> do
-- label in module but not function pointer, convert -- label in module but not function pointer, convert
let fty@(LMFunction sig) = funTy name let fty@(LMFunction sig) = funTy name
fun = LMGlobalVar name (pLift ty') (funcLinkage sig) fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
Nothing Nothing False Nothing Nothing Global
(v1, s1) <- doExpr (pLift fty) (v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty) $ Cast LM_Bitcast fun (pLift fty)
return (env, v1, unitOL s1, []) return (env, v1, unitOL s1, [])
...@@ -433,7 +433,7 @@ getFunPtr env funTy targ = case targ of ...@@ -433,7 +433,7 @@ getFunPtr env funTy targ = case targ of
-- label not in module, create external reference -- label not in module, create external reference
let fty@(LMFunction sig) = funTy name let fty@(LMFunction sig) = funTy name
fun = LMGlobalVar name fty (funcLinkage sig) fun = LMGlobalVar name fty (funcLinkage sig)
Nothing Nothing False Nothing Nothing Global
top = [CmmData Data [([],[fty])]] top = [CmmData Data [([],[fty])]]
env' = funInsert name fty env env' = funInsert name fty env
return (env', fun, nilOL, top) return (env', fun, nilOL, top)
...@@ -1427,7 +1427,7 @@ genLit _ env cmm@(CmmLabel l) ...@@ -1427,7 +1427,7 @@ genLit _ env cmm@(CmmLabel l)
in case ty of in case ty of
-- Make generic external label definition and then pointer to it -- Make generic external label definition and then pointer to it
Nothing -> do Nothing -> do
let glob@(var, _) = genStringLabelRef dflags label let glob@(LMGlobal var _) = genStringLabelRef dflags label
let ldata = [CmmData Data [([glob], [])]] let ldata = [CmmData Data [([glob], [])]]
let env' = funInsert label (pLower $ getVarType var) env let env' = funInsert label (pLower $ getVarType var) env
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
...@@ -1437,7 +1437,7 @@ genLit _ env cmm@(CmmLabel l) ...@@ -1437,7 +1437,7 @@ genLit _ env cmm@(CmmLabel l)
-- pointer to it. -- pointer to it.
Just ty' -> do Just ty' -> do
let var = LMGlobalVar label (LMPointer ty') let var = LMGlobalVar label (LMPointer ty')
ExternallyVisible Nothing Nothing False ExternallyVisible Nothing Nothing Global
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
return (env, v1, unitOL s1, []) return (env, v1, unitOL s1, [])
...@@ -1557,13 +1557,13 @@ getHsFunc env live lbl ...@@ -1557,13 +1557,13 @@ getHsFunc env live lbl
in case ty of in case ty of
-- Function in module in right form -- Function in module in right form
Just ty'@(LMFunction sig) -> do Just ty'@(LMFunction sig) -> do
let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing Global
return (env, fun, nilOL, []) return (env, fun, nilOL, [])
-- label in module but not function pointer, convert -- label in module but not function pointer, convert
Just ty' -> do Just ty' -> do
let fun = LMGlobalVar fn (pLift ty') ExternallyVisible let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
Nothing Nothing False Nothing Nothing Global
(v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
return (env, v1, unitOL s1, []) return (env, v1, unitOL s1, [])
...@@ -1571,7 +1571,7 @@ getHsFunc env live lbl ...@@ -1571,7 +1571,7 @@ getHsFunc env live lbl
-- label not in module, create external reference -- label not in module, create external reference
Nothing -> do Nothing -> do
let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing Global
let top = CmmData Data [([],[ty'])] let top = CmmData Data [([],[ty'])]
let env' = funInsert fn ty' env let env' = funInsert fn ty' env
return (env', fun, nilOL, [top]) return (env', fun, nilOL, [top])
......
...@@ -66,9 +66,9 @@ resolveLlvmData env (lbl, sec, alias, unres) = ...@@ -66,9 +66,9 @@ resolveLlvmData env (lbl, sec, alias, unres) =
label = strCLabel_llvm env lbl label = strCLabel_llvm env lbl
link = if (externallyVisibleCLabel lbl) link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal then ExternallyVisible else Internal
const = isSecConstant sec const = if isSecConstant sec then Constant else Global
glob = LMGlobalVar label alias link Nothing Nothing const glob = LMGlobalVar label alias link Nothing Nothing const
in (env', ((glob,struct):refs, [alias])) in (env', ((LMGlobal glob struct):refs, [alias]))
-- | Should a data in this section be considered constant -- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool isSecConstant :: Section -> Bool
...@@ -114,7 +114,7 @@ resData env (Left cmm@(CmmLabel l)) = ...@@ -114,7 +114,7 @@ resData env (Left cmm@(CmmLabel l)) =
in case ty of in case ty of
-- Make generic external label defenition and then pointer to it -- Make generic external label defenition and then pointer to it
Nothing -> Nothing ->
let glob@(var, _) = genStringLabelRef dflags label let glob@(LMGlobal var _) = genStringLabelRef dflags label
env' = funInsert label (pLower $ getVarType var) env env' = funInsert label (pLower $ getVarType var) env
ptr = LMStaticPointer var ptr = LMStaticPointer var
in (env', LMPtoI ptr lmty, [glob]) in (env', LMPtoI ptr lmty, [glob])
...@@ -122,7 +122,7 @@ resData env (Left cmm@(CmmLabel l)) = ...@@ -122,7 +122,7 @@ resData env (Left cmm@(CmmLabel l)) =
-- pointer to it. -- pointer to it.
Just ty' -> Just ty' ->
let var = LMGlobalVar label (LMPointer ty') let var = LMGlobalVar label (LMPointer ty')
ExternallyVisible Nothing Nothing False ExternallyVisible Nothing Nothing Global
ptr = LMStaticPointer var ptr = LMStaticPointer var
in (env, LMPtoI ptr lmty, []) in (env, LMPtoI ptr lmty, [])
......
...@@ -75,8 +75,8 @@ moduleLayout = sdocWithPlatform $ \platform -> ...@@ -75,8 +75,8 @@ moduleLayout = sdocWithPlatform $ \platform ->
-- | Pretty print LLVM data code -- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) = pprLlvmData (globals, types) =
let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s) let tryConst (LMGlobal v (Just s)) = ppLlvmGlobal (LMGlobal v $ Just s)
tryConst g@(_, Nothing) = ppLlvmGlobal g tryConst g@(LMGlobal _ Nothing) = ppLlvmGlobal g
ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMAlias a) = ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
...@@ -119,13 +119,13 @@ pprInfoTable env count info_lbl stat ...@@ -119,13 +119,13 @@ pprInfoTable env count info_lbl stat
unres = genLlvmData env (Text, stat) unres = genLlvmData env (Text, stat)
(_, (ldata, ltypes)) = resolveLlvmData env unres (_, (ldata, ltypes)) = resolveLlvmData env unres
setSection ((LMGlobalVar _ ty l _ _ c), d) setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d)
= let sec = mkLayoutSection count = let sec = mkLayoutSection count
ilabel = strCLabel_llvm env info_lbl ilabel = strCLabel_llvm env info_lbl
`appendFS` fsLit iTableSuf `appendFS` fsLit iTableSuf
gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
v = if l == Internal then [gv] else [] v = if l == Internal then [gv] else []
in ((gv, d), v) in (LMGlobal gv d, v)
setSection v = (v,[]) setSection v = (v,[])
(ldata', llvmUsed) = setSection (last ldata) (ldata', llvmUsed) = setSection (last ldata)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment