-- * 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,
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
-- | 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],
ppLlvmModule,
ppLlvmComments,
ppLlvmComment,
- ppLlvmConstants,
- ppLlvmConstant,
ppLlvmGlobals,
ppLlvmGlobal,
ppLlvmType,
-- | 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
-- | 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
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.
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 "
-- | 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
-- | 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
-- | 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
-- | 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
-- | 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.
-- | 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.
-- | 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
-- | 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
(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
-- -----------------------------------------------------------------------------
-- | 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
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'])
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], [])
-- | 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
(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
-
-- | 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])
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)
-- ----------------------------------------------------------------------------
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])]]
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, [])
-- 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])
-- 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, [])
-- 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])
-- 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
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
-- | 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
--
-- 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])
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)
), 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
projects / ghc-hetmet.git / commitdiff