Commit 3aadff5e authored by dterei's avatar dterei

Declare some top level globals to be constant when appropriate

This involved removing the old constant handling mechanism
which was fairly hard to use. Now being constant or not is
simply a property of a global variable instead of a separate
type.
parent 09e6aba8
......@@ -28,7 +28,7 @@ module Llvm (
-- * Variables and Type System
LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
LMGlobal, LMString, LMConstant, LMSection, LMAlign,
LMGlobal, LMString, LMSection, LMAlign,
-- ** Some basic types
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
......@@ -39,10 +39,9 @@ module Llvm (
pLift, pLower, isInt, isFloat, isPointer, llvmWidthInBits,
-- * Pretty Printing
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmConstants,
ppLlvmConstant, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls,
ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, ppLlvmType,
ppLlvmTypes, llvmSDoc
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmType, ppLlvmTypes, llvmSDoc
) where
......
......@@ -28,9 +28,6 @@ data LlvmModule = LlvmModule {
-- | Comments to include at the start of the module.
modComments :: [LMString],
-- | Constants to include in the module.
modConstants :: [LMConstant],
-- | Global variables to include in the module.
modGlobals :: [LMGlobal],
......
......@@ -8,8 +8,6 @@ module Llvm.PpLlvm (
ppLlvmModule,
ppLlvmComments,
ppLlvmComment,
ppLlvmConstants,
ppLlvmConstant,
ppLlvmGlobals,
ppLlvmGlobal,
ppLlvmType,
......@@ -40,10 +38,9 @@ import Unique
-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> Doc
ppLlvmModule (LlvmModule comments constants globals decls funcs)
ppLlvmModule (LlvmModule comments globals decls funcs)
= ppLlvmComments comments
$+$ empty
$+$ ppLlvmConstants constants
$+$ ppLlvmGlobals globals
$+$ empty
$+$ ppLlvmFunctionDecls decls
......@@ -65,10 +62,7 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
-- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> Doc
ppLlvmGlobal = ppLlvmGlobal' (text "global")
ppLlvmGlobal' :: Doc -> LMGlobal -> Doc
ppLlvmGlobal' vty (var@(LMGlobalVar _ _ link x a), cont) =
ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty
......@@ -77,22 +71,15 @@ ppLlvmGlobal' vty (var@(LMGlobalVar _ _ link x a), cont) =
Just a' -> text ", align" <+> int a'
Nothing -> empty
rhs = case cont of
rhs = case dat of
Just stat -> texts stat
Nothing -> texts (pLower $ getVarType var)
in ppAssignment var $ texts link <+> vty <+> rhs <> sect <> align
ppLlvmGlobal' _ oth = error $ "Non Global var ppr as global! " ++ show oth
const' = if c then text "constant" else text "global"
-- | Print out a list global constant variable
ppLlvmConstants :: [LMConstant] -> Doc
ppLlvmConstants cons = vcat $ map ppLlvmConstant cons
in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
-- | Print out a global constant variable
ppLlvmConstant :: LMConstant -> Doc
ppLlvmConstant (v,s) = ppLlvmGlobal' (text "constant") (v, Just s)
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
-- | Print out a list of LLVM type aliases.
......@@ -196,7 +183,7 @@ ppCall ct fptr vals attrs = case fptr of
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
-- should be function type otherwise
LMGlobalVar _ (LMFunction d) _ _ _ -> ppCall' d
LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
-- not pointer or function, so error
_other -> error $ "ppCall called with non LMFunction type!\nMust be "
......
......@@ -23,8 +23,6 @@ import PprBase
-- | A global mutable variable. Maybe defined or external
type LMGlobal = (LlvmVar, Maybe LlvmStatic)
-- | A global constant variable
type LMConstant = (LlvmVar, LlvmStatic)
-- | A String in LLVM
type LMString = FastString
......@@ -69,11 +67,12 @@ instance Show LlvmType where
-- | An LLVM section defenition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
type LMAlign = Maybe Int
type LMConst = Bool -- ^ is a variable constant or not
-- | Llvm Variables
data LlvmVar
-- | Variables with a global scope.
= LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign
= LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
-- | Variables local to a function or parameters.
| LMLocalVar Unique LlvmType
-- | Named local variables. Sometimes we need to be able to explicitly name
......@@ -176,18 +175,18 @@ commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x))
-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
getName :: LlvmVar -> String
getName v@(LMGlobalVar _ _ _ _ _) = "@" ++ getPlainName v
getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v
getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v
getName v@(LMLitVar _ ) = getPlainName v
getName v@(LMGlobalVar _ _ _ _ _ _) = "@" ++ getPlainName v
getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v
getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v
getName v@(LMLitVar _ ) = getPlainName v
-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
getPlainName :: LlvmVar -> String
getPlainName (LMGlobalVar x _ _ _ _) = unpackFS x
getPlainName (LMLocalVar x _ ) = show x
getPlainName (LMNLocalVar x _ ) = unpackFS x
getPlainName (LMLitVar x ) = getLit x
getPlainName (LMGlobalVar x _ _ _ _ _) = unpackFS x
getPlainName (LMLocalVar x _ ) = show x
getPlainName (LMNLocalVar x _ ) = unpackFS x
getPlainName (LMLitVar x ) = getLit x
-- | Print a literal value. No type.
getLit :: LlvmLit -> String
......@@ -196,10 +195,10 @@ getLit (LMFloatLit r _) = dToStr r
-- | Return the 'LlvmType' of the 'LlvmVar'
getVarType :: LlvmVar -> LlvmType
getVarType (LMGlobalVar _ y _ _ _) = y
getVarType (LMLocalVar _ y ) = y
getVarType (LMNLocalVar _ y ) = y
getVarType (LMLitVar l ) = getLitType l
getVarType (LMGlobalVar _ y _ _ _ _) = y
getVarType (LMLocalVar _ y ) = y
getVarType (LMNLocalVar _ y ) = y
getVarType (LMLitVar l ) = getLitType l
-- | Return the 'LlvmType' of a 'LlvmLit'
getLitType :: LlvmLit -> LlvmType
......@@ -230,8 +229,8 @@ getGlobalVar (v, _) = v
-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
getLink :: LlvmVar -> LlvmLinkageType
getLink (LMGlobalVar _ _ l _ _) = l
getLink _ = Internal
getLink (LMGlobalVar _ _ l _ _ _) = l
getLink _ = Internal
-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
-- cannot be lifted.
......@@ -242,10 +241,10 @@ pLift x = LMPointer x
-- | Lower a variable of 'LMPointer' type.
pVarLift :: LlvmVar -> LlvmVar
pVarLift (LMGlobalVar s t l x a) = LMGlobalVar s (pLift t) l x a
pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t)
pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t)
pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!"
pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c
pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t)
pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t)
pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!"
-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
-- constructors can be lowered.
......@@ -255,10 +254,10 @@ pLower x = error $ show x ++ " is a unlowerable type, need a pointer"
-- | Lower a variable of 'LMPointer' type.
pVarLower :: LlvmVar -> LlvmVar
pVarLower (LMGlobalVar s t l x a) = LMGlobalVar s (pLower t) l x a
pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t)
pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t)
pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!"
pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c
pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t)
pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t)
pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!"
-- | Test if the given 'LlvmType' is an integer
isInt :: LlvmType -> Bool
......@@ -280,8 +279,8 @@ isPointer _ = False
-- | Test if a 'LlvmVar' is global.
isGlobal :: LlvmVar -> Bool
isGlobal (LMGlobalVar _ _ _ _ _) = True
isGlobal _ = False
isGlobal (LMGlobalVar _ _ _ _ _ _) = True
isGlobal _ = False
-- | Width in bits of an 'LlvmType', returns 0 if not applicable
llvmWidthInBits :: LlvmType -> Int
......
......@@ -50,7 +50,7 @@ llvmCodeGen dflags h us cmms
(cdata,env) = foldr split ([],initLlvmEnv) cmm
split (CmmData _ d' ) (d,e) = (d':d,e)
split (CmmData s d' ) (d,e) = ((s,d'):d,e)
split (CmmProc i l _ _) (d,e) =
let lbl = strCLabel_llvm $ if not (null i)
then entryLblToInfoLbl l
......@@ -62,7 +62,7 @@ llvmCodeGen dflags h us cmms
-- -----------------------------------------------------------------------------
-- | Do llvm code generation on all these cmms data sections.
--
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [[CmmStatic]]
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])]
-> [LlvmUnresData] -> IO ( LlvmEnv )
cmmDataLlvmGens dflags h env [] lmdata
......@@ -74,7 +74,7 @@ cmmDataLlvmGens dflags h env [] lmdata
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
= let lmdata'@(l, ty, _) = genLlvmData cmm
= let lmdata'@(l, _, ty, _) = genLlvmData cmm
env' = funInsert (strCLabel_llvm l) ty env
in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
......@@ -95,7 +95,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
ty = (LMArray (length ivars) i8Ptr)
usedArray = LMStaticArray (map cast ivars) ty
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
in do
Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
......@@ -112,7 +112,6 @@ cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
-- | Complete llvm code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
-> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
cmmLlvmGen dflags us env cmm
= do
-- rewrite assignments to global regs
......@@ -122,20 +121,10 @@ cmmLlvmGen dflags us env cmm
(pprCmm $ Cmm [fixed_cmm])
-- generate llvm code from cmm
let ((env', llvmBC), usGen) = initUs us $ genLlvmCode env fixed_cmm
let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
(vcat $ map (docToSDoc . fst . pprLlvmCmmTop env' 0) llvmBC)
return (usGen, env', llvmBC)
-- -----------------------------------------------------------------------------
-- | Instruction selection
--
genLlvmCode :: LlvmEnv -> RawCmmTop
-> UniqSM (LlvmEnv, [LlvmCmmTop])
genLlvmCode env (CmmData _ _ ) = return (env, [])
genLlvmCode env (CmmProc _ _ _ (ListGraph [])) = return (env, [])
genLlvmCode env cp@(CmmProc _ _ _ _ ) = genLlvmProc env cp
......@@ -43,7 +43,7 @@ type LlvmBasicBlock = GenBasicBlock LlvmStatement
-- | Unresolved code.
-- Of the form: (data label, data type, unresovled data)
type LlvmUnresData = (CLabel, LlvmType, [UnresStatic])
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
-- | Top level LLVM Data (globals and type aliases)
type LlvmData = ([LMGlobal], [LlvmType])
......@@ -158,7 +158,7 @@ genCmmLabelRef = genStringLabelRef . strCLabel_llvm
genStringLabelRef :: LMString -> LMGlobal
genStringLabelRef cl
= let ty = LMPointer $ LMArray 0 llvmWord
in (LMGlobalVar cl ty External Nothing Nothing, Nothing)
in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
-- ----------------------------------------------------------------------------
......
......@@ -156,7 +156,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
FixedArgs (Left [i1, i1, i1, i1, i1]) llvmFunAlign
let fty = LMFunction funSig
let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing
let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
let tops = case funLookup fname env of
Just _ -> []
Nothing -> [CmmData Data [([],[fty])]]
......@@ -238,14 +238,14 @@ genCall env target res args ret = do
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig)
Nothing Nothing
Nothing Nothing False
return (env1, fun, nilOL, [])
Just _ -> do
-- label in module but not function pointer, convert
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
Nothing Nothing
Nothing Nothing False
(v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty)
return (env1, v1, unitOL s1, [])
......@@ -254,7 +254,7 @@ genCall env target res args ret = do
-- label not in module, create external reference
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
Nothing Nothing
Nothing Nothing False
let top = CmmData Data [([],[fty])]
let env' = funInsert name fty env1
return (env', fun, nilOL, [top])
......@@ -827,7 +827,7 @@ genLit env cmm@(CmmLabel l)
-- pointer to it.
Just ty' -> do
let var = LMGlobalVar label (LMPointer ty')
ExternallyVisible Nothing Nothing
ExternallyVisible Nothing Nothing False
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
return (env, v1, unitOL s1, [])
......@@ -894,26 +894,26 @@ funEpilogue = do
-- with foreign functions.
getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
getHsFunc env lbl
= let fname = strCLabel_llvm lbl
ty = funLookup fname env
= let fn = strCLabel_llvm lbl
ty = funLookup fn env
in case ty of
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar fname ty' (funcLinkage sig) Nothing Nothing
let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
return (env, fun, nilOL, [])
Just ty' -> do
-- label in module but not function pointer, convert
let fun = LMGlobalVar fname (pLift ty') ExternallyVisible
Nothing Nothing
let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
Nothing Nothing False
(v1, s1) <- doExpr (pLift llvmFunTy) $
Cast LM_Bitcast fun (pLift llvmFunTy)
return (env, v1, unitOL s1, [])
Nothing -> do
-- label not in module, create external reference
let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
let fun = LMGlobalVar fname ty' ExternallyVisible Nothing Nothing
let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
let top = CmmData Data [([],[ty'])]
let env' = funInsert fname ty' env
let env' = funInsert fn ty' env
return (env', fun, nilOL, [top])
......
......@@ -37,8 +37,8 @@ structStr = fsLit "_struct"
-- complete this completely though as we need to pass all CmmStatic
-- sections before all references can be resolved. This last step is
-- done by 'resolveLlvmData'.
genLlvmData :: [CmmStatic] -> LlvmUnresData
genLlvmData (CmmDataLabel lbl:xs) =
genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData
genLlvmData (sec, CmmDataLabel lbl:xs) =
let static = map genData xs
label = strCLabel_llvm lbl
......@@ -48,10 +48,11 @@ genLlvmData (CmmDataLabel lbl:xs) =
strucTy = LMStruct types
alias = LMAlias (label `appendFS` structStr) strucTy
in (lbl, alias, static)
in (lbl, sec, alias, static)
genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!"
resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData]
-> (LlvmEnv, [LlvmData])
resolveLlvmDatas env [] ldata
......@@ -63,17 +64,29 @@ resolveLlvmDatas env (udata : rest) ldata
-- | Fix up CLabel references now that we should have passed all CmmData.
resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
resolveLlvmData env (lbl, alias, unres) =
resolveLlvmData env (lbl, sec, alias, unres) =
let (env', static, refs) = resDatas env unres ([], [])
refs' = catMaybes refs
struct = Just $ LMStaticStruc static alias
label = strCLabel_llvm lbl
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
glob = LMGlobalVar label alias link Nothing Nothing
const = isSecConstant sec
glob = LMGlobalVar label alias link Nothing Nothing const
in (env', (refs' ++ [(glob, struct)], [alias]))
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
isSecConstant Text = True
isSecConstant Data = False
isSecConstant ReadOnlyData = True
isSecConstant RelocatableReadOnlyData = True
isSecConstant UninitialisedData = False
isSecConstant ReadOnlyData16 = True
isSecConstant (OtherSection _) = False
-- ----------------------------------------------------------------------------
-- ** Resolve Data/CLabel references
--
......@@ -114,7 +127,7 @@ resData env (Left cmm@(CmmLabel l)) =
-- pointer to it.
Just ty' ->
let var = LMGlobalVar label (LMPointer ty')
ExternallyVisible Nothing Nothing
ExternallyVisible Nothing Nothing False
ptr = LMStaticPointer var
in (env, LMPtoI ptr lmty, [Nothing])
......
......@@ -59,6 +59,17 @@ pprLlvmHeader :: Doc
pprLlvmHeader = moduleLayout
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> Doc
pprLlvmData (globals, types) =
let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s)
tryConst g@(_, Nothing) = ppLlvmGlobal g
types' = ppLlvmTypes types
globals' = vcat $ map tryConst globals
in types' $+$ globals'
-- | Pretty print LLVM code
pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
pprLlvmCmmTop _ _ (CmmData _ lmdata)
......@@ -85,24 +96,16 @@ pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
), ivar)
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> Doc
pprLlvmData (globals, types) =
let globals' = ppLlvmGlobals globals
types' = ppLlvmTypes types
in types' $+$ globals'
-- | Pretty print CmmStatic
pprCmmStatic :: LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
pprCmmStatic env count stat
= let unres = genLlvmData stat
= let unres = genLlvmData (Text, stat)
(_, (ldata, ltypes)) = resolveLlvmData env unres
setSection (gv@(LMGlobalVar s ty l _ _), d)
setSection (gv@(LMGlobalVar s ty l _ _ c), d)
= let v = if l == Internal then [gv] else []
sec = mkLayoutSection count
in ((LMGlobalVar s ty l sec llvmInfAlign, d), v)
in ((LMGlobalVar s ty l sec llvmInfAlign c, d), v)
setSection v = (v,[])
(ldata', llvmUsed) = mapAndUnzip setSection 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