summaryrefslogtreecommitdiff
path: root/compiler/llvmGen/LlvmCodeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen')
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs4
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs24
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs25
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs25
4 files changed, 47 insertions, 31 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 003c044db8..5e0df3ef86 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -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)
-- ----------------------------------------------------------------------------
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 13fe123f48..85094f7803 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -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])
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 13da03b840..3cf6cdac85 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -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])
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 5afbd174ce..55bb5d04a9 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -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
View Lorry Controller Status