Commit 50fd5a99 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 4ada19d8 3a3dcc31
......@@ -1989,10 +1989,12 @@ AC_DEFUN([XCODE_VERSION],[
# Finds where gcc is
AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" &&
test "$XCodeVersion1" -ge 4
test "$XCodeVersion1" -eq 4 &&
test "$XCodeVersion2" -lt 2
then
# From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy
# backend (instead of the LLVM backend)
# In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
# than the LLVM backend). We prefer the legacy gcc, but in
# Xcode 4.2 'gcc-4.2' was removed.
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2])
else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
......
......@@ -105,7 +105,7 @@ find an occurence of an Id, we fetch it from the in-scope set.
\begin{code}
lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message)
lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
-- Returns (warnings, errors)
lintCoreBindings binds
= initL $
......@@ -150,7 +150,7 @@ We use this to check all unfoldings that come in from interfaces
lintUnfolding :: SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
-> Maybe Message -- Nothing => OK
-> Maybe MsgDoc -- Nothing => OK
lintUnfolding locn vars expr
| isEmptyBag errs = Nothing
......@@ -905,7 +905,7 @@ newtype LintM a =
WarnsAndErrs -> -- Error and warning messages so far
(Maybe a, WarnsAndErrs) } -- Result and messages (if any)
type WarnsAndErrs = (Bag Message, Bag Message)
type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
{- Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -953,23 +953,23 @@ initL m
\end{code}
\begin{code}
checkL :: Bool -> Message -> LintM ()
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = failWithL msg
failWithL :: Message -> LintM a
failWithL :: MsgDoc -> LintM a
failWithL msg = LintM $ \ loc subst (warns,errs) ->
(Nothing, (warns, addMsg subst errs msg loc))
addErrL :: Message -> LintM ()
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \ loc subst (warns,errs) ->
(Just (), (warns, addMsg subst errs msg loc))
addWarnL :: Message -> LintM ()
addWarnL :: MsgDoc -> LintM ()
addWarnL msg = LintM $ \ loc subst (warns,errs) ->
(Just (), (addMsg subst warns msg loc, errs))
addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addMsg subst msgs msg locs
= ASSERT( notNull locs )
msgs `snocBag` mk_msg msg
......@@ -980,7 +980,7 @@ addMsg subst msgs msg locs
ptext (sLit "Substitution:") <+> ppr subst
| otherwise = cxt1
mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m =
......@@ -1052,7 +1052,7 @@ checkInScope loc_msg var =
; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [ppr var, loc_msg]) }
checkTys :: OutType -> OutType -> Message -> LintM ()
checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
......@@ -1110,39 +1110,39 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
------------------------------------------------------
-- Messages for case expressions
mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg :: CoreExpr -> MsgDoc
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg :: [Var] -> MsgDoc
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
mkCaseAltMsg e ty1 ty2
= hang (text "Type of case alternatives not the same as the annotation on case:")
4 (vcat [ppr ty1, ppr ty2, ppr e])
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc
mkScrutMsg var var_ty scrut_ty subst
= vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
text "Result binder type:" <+> ppr var_ty,--(idType var),
text "Scrutinee type:" <+> ppr scrut_ty,
hsep [ptext (sLit "Current TV subst"), ppr subst]]
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
mkNonIncreasingAltsMsg e
= hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadConMsg :: TyCon -> DataCon -> Message
mkBadConMsg :: TyCon -> DataCon -> MsgDoc
mkBadConMsg tycon datacon
= vcat [
text "In a case alternative, data constructor isn't in scrutinee type:",
......@@ -1150,7 +1150,7 @@ mkBadConMsg tycon datacon
text "Data con:" <+> ppr datacon
]
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg :: Type -> Type -> MsgDoc
mkBadPatMsg con_result_ty scrut_ty
= vcat [
text "In a case alternative, pattern result type doesn't match scrutinee type:",
......@@ -1158,17 +1158,17 @@ mkBadPatMsg con_result_ty scrut_ty
text "Scrutinee type:" <+> ppr scrut_ty
]
integerScrutinisedMsg :: Message
integerScrutinisedMsg :: MsgDoc
integerScrutinisedMsg
= text "In a LitAlt, the literal is lifted (probably Integer)"
mkBadAltMsg :: Type -> CoreAlt -> Message
mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
mkBadAltMsg scrut_ty alt
= vcat [ text "Data alternative when scrutinee is not a tycon application",
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
mkNewTyDataConAltMsg scrut_ty alt
= vcat [ text "Data alternative for newtype datacon",
text "Scrutinee type:" <+> ppr scrut_ty,
......@@ -1178,21 +1178,21 @@ mkNewTyDataConAltMsg scrut_ty alt
------------------------------------------------------
-- Other error messages
mkAppMsg :: Type -> Type -> CoreExpr -> Message
mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Argument value doesn't match argument type:"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
mkNonFunAppMsg fun_ty arg_ty arg
= vcat [ptext (sLit "Non-function type in function position"),
hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
mkLetErr :: TyVar -> CoreExpr -> Message
mkLetErr :: TyVar -> CoreExpr -> MsgDoc
mkLetErr bndr rhs
= vcat [ptext (sLit "Bad `let' binding:"),
hang (ptext (sLit "Variable:"))
......@@ -1200,7 +1200,7 @@ mkLetErr bndr rhs
hang (ptext (sLit "Rhs:"))
4 (ppr rhs)]
mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc
mkTyCoAppErrMsg tyvar arg_co
= vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
hang (ptext (sLit "Type variable:"))
......@@ -1208,7 +1208,7 @@ mkTyCoAppErrMsg tyvar arg_co
hang (ptext (sLit "Arg coercion:"))
4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg :: Type -> Type -> MsgDoc
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext (sLit "Exp type:"))
......@@ -1216,7 +1216,7 @@ mkTyAppMsg ty arg_ty
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> Type -> Message
mkRhsMsg :: Id -> Type -> MsgDoc
mkRhsMsg binder ty
= vcat
[hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
......@@ -1224,14 +1224,14 @@ mkRhsMsg binder ty
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]]
mkRhsPrimMsg :: Id -> CoreExpr -> Message
mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc
mkRhsPrimMsg binder _rhs
= vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
]
mkStrictMsg :: Id -> Message
mkStrictMsg :: Id -> MsgDoc
mkStrictMsg binder
= vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
ppr binder],
......@@ -1239,7 +1239,7 @@ mkStrictMsg binder
]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg :: TyVar -> Type -> MsgDoc
mkKindErrMsg tyvar arg_ty
= vcat [ptext (sLit "Kinds don't match in type application:"),
hang (ptext (sLit "Type variable:"))
......@@ -1247,7 +1247,7 @@ mkKindErrMsg tyvar arg_ty
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkArityMsg :: Id -> Message
mkArityMsg :: Id -> MsgDoc
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
ppr (dmdTypeDepth dmd_ty),
......@@ -1260,24 +1260,24 @@ mkArityMsg binder
]
where (StrictSig dmd_ty) = idStrictness binder
mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg :: Id -> MsgDoc
mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: Type -> Type -> Message
mkCastErr :: Type -> Type -> MsgDoc
mkCastErr from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
ptext (sLit "From-type:") <+> ppr from_ty,
ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
]
dupVars :: [[Var]] -> Message
dupVars :: [[Var]] -> MsgDoc
dupVars vars
= hang (ptext (sLit "Duplicate variables brought into scope"))
2 (ppr vars)
dupExtVars :: [[Name]] -> Message
dupExtVars :: [[Name]] -> MsgDoc
dupExtVars vars
= hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
2 (ppr vars)
......@@ -1310,7 +1310,7 @@ lintSplitCoVar cv
Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
, nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
mkCoVarLetErr :: CoVar -> Coercion -> Message
mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc
mkCoVarLetErr covar co
= vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
hang (ptext (sLit "Coercion variable:"))
......@@ -1318,7 +1318,7 @@ mkCoVarLetErr covar co
hang (ptext (sLit "Arg coercion:"))
4 (ppr co)]
mkCoAppErrMsg :: CoVar -> Coercion -> Message
mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc
mkCoAppErrMsg covar arg_co
= vcat [ptext (sLit "Kinds don't match in coercion application:"),
hang (ptext (sLit "Coercion variable:"))
......@@ -1327,7 +1327,7 @@ mkCoAppErrMsg covar arg_co
4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkCoAppMsg :: Type -> Coercion -> Message
mkCoAppMsg :: Type -> Coercion -> MsgDoc
mkCoAppMsg ty arg_co
= vcat [text "Illegal type application:",
hang (ptext (sLit "exp type:"))
......
......@@ -32,6 +32,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import MkCore
import CoreUtils
......@@ -40,6 +41,7 @@ import CoreUnfold
import CoreFVs
import Digraph
import TyCon ( isTupleTyCon, tyConDataCons_maybe )
import TcEvidence
import TcType
......@@ -705,7 +707,10 @@ dsEvTerm (EvSuperClass d n)
= Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
(cls, tys) = getClassPredTys (evVarPred d)
dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr msg)
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
......
......@@ -226,7 +226,7 @@ initDs hsc_env mod rdr_env type_env thing_inside
where
loadOneModule :: ModuleName -- the module to load
-> DsM Bool -- under which condition
-> Message -- error message if module not found
-> MsgDoc -- error message if module not found
-> DsM GlobalRdrEnv -- empty if condition 'False'
loadOneModule modname check err
= do { doLoad <- check
......@@ -370,8 +370,7 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext (sLit "Warning:") <+> warn)
; let msg = mkWarnMsg loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
......
......@@ -443,8 +443,8 @@ linkExpr hsc_env span root_ul_bco
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
dieWith :: SrcSpan -> Message -> IO a
dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
dieWith :: SrcSpan -> MsgDoc -> IO a
dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
......
......@@ -48,25 +48,25 @@ import GHC.Exts
-------------------------------------------------------------------
-- The external interface
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
where
cvt_dec d = wrapMsg "declaration" d (cvtDec d)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
convertToHsExpr loc e
= initCvt loc $ wrapMsg "expression" e $ cvtl e
convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
convertToPat loc p
= initCvt loc $ wrapMsg "pattern" p $ cvtPat p
convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
convertToHsType loc t
= initCvt loc $ wrapMsg "type" t $ cvtType t
-------------------------------------------------------------------
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a }
-- Push down the source location;
-- Can fail, with a single error message
......@@ -85,13 +85,13 @@ instance Monad CvtM where
Left err -> Left err
Right v -> unCvtM (k v) loc
initCvt :: SrcSpan -> CvtM a -> Either Message a
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
initCvt loc (CvtM m) = m loc
force :: a -> CvtM ()
force a = a `seq` return ()
failWith :: Message -> CvtM a
failWith :: MsgDoc -> CvtM a
failWith m = CvtM (\_ -> Left m)
getL :: CvtM SrcSpan
......@@ -232,7 +232,7 @@ cvtDec (TySynInstD tc tys rhs)
; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
----------------
cvt_ci_decs :: Message -> [TH.Dec]
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
[LTyClDecl RdrName])
......@@ -304,7 +304,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
is_bind decl = Right decl
mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message
mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc
mkBadDecMsg doc bads
= sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
, nest 2 (vcat (map Outputable.ppr bads)) ]
......@@ -437,7 +437,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
-- Declarations
---------------------------------------------------
cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtLocalDecs doc ds
| null ds
= return EmptyLocalBinds
......
......@@ -167,7 +167,7 @@ loadInterfaceWithException doc mod_name where_from
------------------
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr Message ModIface)
-> IfM lcl (MaybeErr MsgDoc ModIface)
-- loadInterface looks in both the HPT and PIT for the required interface
-- If not found, it loads it, and puts it in the PIT (always).
......@@ -294,7 +294,7 @@ loadInterface doc_str mod from
}}}}
wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
-> MaybeErr Message IsBootInterface
-> MaybeErr MsgDoc IsBootInterface
-- Figure out whether we want Foo.hi or Foo.hi-boot
wantHiBootFile dflags eps mod from
= case from of
......@@ -472,7 +472,7 @@ bumpDeclStats name
findAndReadIface :: SDoc -> Module
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
-> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))
-> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
......@@ -537,7 +537,7 @@ findAndReadIface doc_str mod hi_boot_file
\begin{code}
readIface :: Module -> FilePath -> IsBootInterface
-> TcRnIf gbl lcl (MaybeErr Message ModIface)
-> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
-- Failed err <=> file not found, or unreadable, or illegible
-- Succeeded iface <=> successfully found and parsed
......@@ -794,7 +794,7 @@ badIfaceFile file err
= vcat [ptext (sLit "Bad interface file:") <+> text file,
nest 4 err]
hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
withPprStyle defaultUserStyle $
-- we want the Modules below to be qualified with package names,
......
......@@ -844,7 +844,7 @@ oldMD5 dflags bh = do
instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn unqual inst
= mkWarnMsg (getSrcSpan inst) unqual $
hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
......
......@@ -125,7 +125,7 @@ tcImportDecl name
Succeeded thing -> return thing
Failed err -> failWithTc err }
importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
-- Get the TyThing for this Name from an interface file
-- It's not a wired-in thing -- the caller caught that
importDecl name
......
......@@ -34,6 +34,9 @@ module Llvm (
-- ** Some basic types
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
-- ** Metadata types
LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData,
-- ** Operations on the type system.
isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
......@@ -42,7 +45,8 @@ module Llvm (
-- * Pretty Printing
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
llvmSDoc
) where
......
......@@ -31,6 +31,9 @@ data LlvmModule = LlvmModule {
-- | LLVM Alias type definitions.
modAliases :: [LlvmAlias],
-- | LLVM meta data.
modMeta :: [LlvmMeta],
-- | Global variables to include in the module.
modGlobals :: [LMGlobal],
......@@ -138,8 +141,15 @@ data LlvmStatement
-}
| Nop
{- |
A LLVM statement with metadata attached to it.
-}
| MetaStmt [MetaData] LlvmStatement
deriving (Show, Eq)
type MetaData = (LMString, LlvmMetaUnamed)
-- | Llvm Expressions
data LlvmExpression
......@@ -229,5 +239,10 @@ data LlvmExpression
-}
| Asm LMString LMString LlvmType [LlvmVar] Bool Bool
{- |
A LLVM expression with metadata attached to it.
-}
| MetaExpr [MetaData] LlvmExpression
deriving (Show, Eq)
......@@ -10,8 +10,10 @@ module Llvm.PpLlvm (
ppLlvmComment,
ppLlvmGlobals,
ppLlvmGlobal,
ppLlvmAlias,
ppLlvmAliases,
ppLlvmAlias,
ppLlvmMetas,
ppLlvmMeta,
ppLlvmFunctionDecls,
ppLlvmFunctionDecl,
ppLlvmFunctions,
......@@ -38,9 +40,10 @@ import Unique
-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> Doc
ppLlvmModule (LlvmModule comments aliases globals decls funcs)
ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
$+$ ppLlvmMetas meta $+$ newLine
$+$ ppLlvmGlobals globals $+$ newLine
$+$ ppLlvmFunctionDecls decls $+$ newLine
$+$ ppLlvmFunctions funcs
......@@ -88,7 +91,32 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> Doc
ppLlvmAlias (name, ty)
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty $+$ newLine
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
-- | Print out a list of LLVM metadata.
ppLlvmMetas :: [LlvmMeta] -> Doc
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
-- | Print out an LLVM metadata definition.
ppLlvmMeta :: LlvmMeta -> Doc
ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
= exclamation <> int u <> text " = metadata !{" <>
hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
ppLlvmMeta (MetaNamed n metas)
= exclamation <> ftext n <> text " = !{" <>
hcat (intersperse comma $ map pprNode munq) <> text "}"
where
munq = map (\(LMMetaUnamed u) -> u) metas
pprNode n = exclamation <> int n
-- | Print out an LLVM metadata value.
ppLlvmMetaVal :: LlvmMetaVal -> Doc
ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaVal (MetaVar v) = texts v
ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
= text "metadata !" <> int u
-- | Print out a list of function definitions.
......@@ -168,29 +196,33 @@ ppLlvmBlock (LlvmBlock blockId stmts)
Just id2' -> go id2' rest
Nothing -> empty
in ppLlvmBlockLabel id
$+$ nest 4 (vcat $ map ppLlvmStatement block)
$+$ (vcat $ map ppLlvmStatement block)
$+$ newLine
$+$ ppRest
-- | Print out an LLVM block label.
ppLlvmBlockLabel :: LlvmBlockId -> Doc
ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
-- | Print out an LLVM statement.
ppLlvmStatement :: LlvmStatement -> Doc
ppLlvmStatement stmt
= case stmt of
Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr)
Branch target -> ppBranch target
BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF
Comment comments -> ppLlvmComments comments
ppLlvmStatement stmt =
let ind = (text " " <>)
in case stmt of
Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr)
Branch target -> ind $ ppBranch target
BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
Comment comments -> ind $ ppLlvmComments comments