Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
ab50c9c5
Commit
ab50c9c5
authored
Jun 12, 2012
by
Ian Lynagh
Browse files
Pass DynFlags down to showSDoc
parent
543ec085
Changes
48
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/MkId.lhs
View file @
ab50c9c5
...
...
@@ -69,6 +69,7 @@ import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
import Pair
import DynFlags
import Outputable
import FastString
import ListSetOps
...
...
@@ -761,14 +762,14 @@ mkPrimOpId prim_op
-- details of the ccall, type and all. This means that the interface
-- file reader can reconstruct a suitable Id
mkFCallId :: Unique -> ForeignCall -> Type -> Id
mkFCallId uniq fcall ty
mkFCallId ::
DynFlags ->
Unique -> ForeignCall -> Type -> Id
mkFCallId
dflags
uniq fcall ty
= ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
mkGlobalId (FCallId fcall) name ty info
where
occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
occ_str = showSDoc
dflags
(braces (ppr fcall <+> ppr ty))
-- The "occurrence name" of a ccall is the full info about the
-- ccall; it is encoded, but may have embedded spaces etc!
...
...
compiler/cmm/CmmOpt.hs
View file @
ab50c9c5
...
...
@@ -20,6 +20,7 @@ import OldCmm
import
OldPprCmm
import
CmmNode
(
wrapRecExp
)
import
CmmUtils
import
DynFlags
import
StaticFlags
import
UniqFM
...
...
@@ -147,46 +148,47 @@ countUses :: UserOfLocalRegs a => a -> UniqFM Int
countUses
a
=
foldRegsUsed
(
\
m
r
->
addToUFM
m
r
(
count
m
r
+
1
))
emptyUFM
a
where
count
m
r
=
lookupWithDefaultUFM
m
(
0
::
Int
)
r
cmmMiniInline
::
Platform
->
[
CmmBasicBlock
]
->
[
CmmBasicBlock
]
cmmMiniInline
platform
blocks
=
map
do_inline
blocks
cmmMiniInline
::
DynFlags
->
[
CmmBasicBlock
]
->
[
CmmBasicBlock
]
cmmMiniInline
dflags
blocks
=
map
do_inline
blocks
where
do_inline
(
BasicBlock
id
stmts
)
=
BasicBlock
id
(
cmmMiniInlineStmts
platform
(
countUses
blocks
)
stmts
)
=
BasicBlock
id
(
cmmMiniInlineStmts
dflags
(
countUses
blocks
)
stmts
)
cmmMiniInlineStmts
::
Platform
->
UniqFM
Int
->
[
CmmStmt
]
->
[
CmmStmt
]
cmmMiniInlineStmts
_
_
[]
=
[]
cmmMiniInlineStmts
platform
uses
(
stmt
@
(
CmmAssign
(
CmmLocal
(
LocalReg
u
_
))
expr
)
:
stmts
)
cmmMiniInlineStmts
::
DynFlags
->
UniqFM
Int
->
[
CmmStmt
]
->
[
CmmStmt
]
cmmMiniInlineStmts
_
_
[]
=
[]
cmmMiniInlineStmts
dflags
uses
(
stmt
@
(
CmmAssign
(
CmmLocal
(
LocalReg
u
_
))
expr
)
:
stmts
)
-- not used: just discard this assignment
|
Nothing
<-
lookupUFM
uses
u
=
cmmMiniInlineStmts
platform
uses
stmts
=
cmmMiniInlineStmts
dflags
uses
stmts
-- used (literal): try to inline at all the use sites
|
Just
n
<-
lookupUFM
uses
u
,
isLit
expr
=
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
(
pprStmt
platform
stmt
))
$
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
dflags
(
pprStmt
platform
stmt
))
$
case
lookForInlineLit
u
expr
stmts
of
(
m
,
stmts'
)
|
n
==
m
->
cmmMiniInlineStmts
platform
(
delFromUFM
uses
u
)
stmts'
|
n
==
m
->
cmmMiniInlineStmts
dflags
(
delFromUFM
uses
u
)
stmts'
|
otherwise
->
stmt
:
cmmMiniInlineStmts
platform
(
adjustUFM
(
\
x
->
x
-
m
)
uses
u
)
stmts'
stmt
:
cmmMiniInlineStmts
dflags
(
adjustUFM
(
\
x
->
x
-
m
)
uses
u
)
stmts'
-- used (foldable to literal): try to inline at all the use sites
|
Just
n
<-
lookupUFM
uses
u
,
e
@
(
CmmLit
_
)
<-
wrapRecExp
foldExp
expr
=
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
(
pprStmt
platform
stmt
))
$
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
dflags
(
pprStmt
platform
stmt
))
$
case
lookForInlineLit
u
e
stmts
of
(
m
,
stmts'
)
|
n
==
m
->
cmmMiniInlineStmts
platform
(
delFromUFM
uses
u
)
stmts'
|
n
==
m
->
cmmMiniInlineStmts
dflags
(
delFromUFM
uses
u
)
stmts'
|
otherwise
->
stmt
:
cmmMiniInlineStmts
platform
(
adjustUFM
(
\
x
->
x
-
m
)
uses
u
)
stmts'
stmt
:
cmmMiniInlineStmts
dflags
(
adjustUFM
(
\
x
->
x
-
m
)
uses
u
)
stmts'
-- used once (non-literal): try to inline at the use site
|
Just
1
<-
lookupUFM
uses
u
,
Just
stmts'
<-
lookForInline
u
expr
stmts
=
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
(
pprStmt
platform
stmt
))
$
cmmMiniInlineStmts
platform
uses
stmts'
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
dflags
(
pprStmt
platform
stmt
))
$
cmmMiniInlineStmts
dflags
uses
stmts'
where
platform
=
targetPlatform
dflags
foldExp
(
CmmMachOp
op
args
)
=
cmmMachOpFold
platform
op
args
foldExp
e
=
e
...
...
compiler/codeGen/StgCmmLayout.hs
View file @
ab50c9c5
...
...
@@ -58,7 +58,7 @@ import Constants
import
Util
import
Data.List
import
Outputable
import
FastString
(
mkFastString
,
FastString
,
fsLit
)
import
FastString
------------------------------------------------------------------------
-- Call and return sequences
...
...
@@ -179,8 +179,8 @@ slow_call fun args reps
=
do
dflags
<-
getDynFlags
let
platform
=
targetPlatform
dflags
call
<-
getCode
$
direct_call
"slow_call"
(
mkRtsApFastLabel
rts_fun
)
arity
args
reps
emit
$
mkComment
$
mkFastString
(
"slow_call for "
++
showSDoc
(
pprPlatform
platform
fun
)
++
" with pat "
++
showSDoc
(
ftext
rts_fun
)
)
emit
$
mkComment
$
mkFastString
(
"slow_call for "
++
showSDoc
dflags
(
pprPlatform
platform
fun
)
++
" with pat "
++
unpackFS
rts_fun
)
emit
(
mkAssign
nodeReg
fun
<*>
call
)
where
(
rts_fun
,
arity
)
=
slowCallPattern
reps
...
...
compiler/codeGen/StgCmmProf.hs
View file @
ab50c9c5
...
...
@@ -218,7 +218,8 @@ emitCostCentreDecl cc = do
;
modl
<-
newByteStringCLit
(
bytesFS
$
Module
.
moduleNameFS
$
Module
.
moduleName
$
cc_mod
cc
)
;
loc
<-
newStringCLit
(
showSDoc
(
ppr
(
costCentreSrcSpan
cc
)))
;
dflags
<-
getDynFlags
;
loc
<-
newStringCLit
(
showPpr
dflags
(
costCentreSrcSpan
cc
))
-- XXX should UTF-8 encode
-- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages.
...
...
compiler/coreSyn/MkExternalCore.lhs
View file @
ab50c9c5
...
...
@@ -38,6 +38,7 @@ import DynFlags
import FastString
import Exception
import Control.Monad
import Data.Char
import System.IO
...
...
@@ -45,7 +46,7 @@ emitExternalCore :: DynFlags -> CgGuts -> IO ()
emitExternalCore dflags cg_guts
| dopt Opt_EmitExternalCore dflags
= (do handle <- openFile corename WriteMode
hPutStrLn handle (show (mkExternalCore cg_guts))
hPutStrLn handle (show (mkExternalCore
dflags
cg_guts))
hClose handle)
`catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
(text corename))
...
...
@@ -56,7 +57,10 @@ emitExternalCore _ _
-- Reinventing the Reader monad; whee.
newtype CoreM a = CoreM (CoreState -> (CoreState, a))
type CoreState = Module
data CoreState = CoreState {
cs_dflags :: DynFlags,
cs_module :: Module
}
instance Monad CoreM where
(CoreM m) >>= f = CoreM (\ s -> case m s of
(s',r) -> case f r of
...
...
@@ -67,55 +71,62 @@ runCoreM (CoreM f) s = snd $ f s
ask :: CoreM CoreState
ask = CoreM (\ s -> (s,s))
mkExternalCore :: CgGuts -> C.Module
instance HasDynFlags CoreM where
getDynFlags = liftM cs_dflags ask
mkExternalCore :: DynFlags -> CgGuts -> C.Module
-- The ModGuts has been tidied, but the implicit bindings have
-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons,
cg_binds = binds})
mkExternalCore
dflags
(CgGuts {cg_module=this_mod, cg_tycons = tycons,
cg_binds = binds})
{- Note that modules can be mutually recursive, but even so, we
print out dependency information within each module. -}
= C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds)
this_mod
)
= C.Module
(
mname
dflags)
tdefs (runCoreM (mapM (make_vdef True) binds)
initialState
)
where
mname = make_mid this_mod
tdefs = foldr collect_tdefs [] tycons
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs
initialState = CoreState {
cs_dflags = dflags,
cs_module = this_mod
}
mname dflags = make_mid dflags this_mod
tdefs = foldr (collect_tdefs dflags) [] tycons
collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs dflags tcon tdefs
| isAlgTyCon tcon = tdef: tdefs
where
tdef | isNewTyCon tcon =
C.Newtype (qtc tcon)
(qcc (newTyConCo tcon))
C.Newtype (qtc
dflags
tcon)
(qcc
dflags
(newTyConCo tcon))
(map make_tbind tyvars)
(make_ty (snd (newTyConRhs tcon)))
(make_ty
dflags
(snd (newTyConRhs tcon)))
| otherwise =
C.Data (qtc tcon) (map make_tbind tyvars)
(map make_cdef (tyConDataCons tcon))
C.Data (qtc
dflags
tcon) (map make_tbind tyvars)
(map
(
make_cdef
dflags)
(tyConDataCons tcon))
tyvars = tyConTyVars tcon
collect_tdefs _ tdefs = tdefs
collect_tdefs _
_
tdefs = tdefs
qtc :: TyCon -> C.Qual C.Tcon
qtc = make_con_qid . tyConName
qtc ::
DynFlags ->
TyCon -> C.Qual C.Tcon
qtc
dflags
= make_con_qid
dflags
. tyConName
qcc :: CoAxiom -> C.Qual C.Tcon
qcc = make_con_qid . co_ax_name
qcc ::
DynFlags ->
CoAxiom -> C.Qual C.Tcon
qcc
dflags
= make_con_qid
dflags
. co_ax_name
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
make_cdef ::
DynFlags ->
DataCon -> C.Cdef
make_cdef
dflags
dcon = C.Constr dcon_name existentials tys
where
dcon_name = make_qid False False (dataConName dcon)
dcon_name = make_qid
dflags
False False (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExTyVars dcon
tys = map make_ty (dataConRepArgTys dcon)
tys = map
(
make_ty
dflags)
(dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_vbind :: Var -> C.Vbind
make_vbind v = (make_var_id (Var.varName v), make_ty (varType v))
make_vbind ::
DynFlags ->
Var -> C.Vbind
make_vbind
dflags
v = (make_var_id (Var.varName v), make_ty
dflags
(varType v))
make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
make_vdef topLevel b =
...
...
@@ -129,29 +140,34 @@ make_vdef topLevel b =
let local = not topLevel || localN
rhs <- make_exp e
-- use local flag to determine where to add the module name
return (local, make_qid local True vName, make_ty (varType v),rhs)
dflags <- getDynFlags
return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
where vName = Var.varName v
make_exp :: CoreExpr -> CoreM C.Exp
make_exp (Var v) = do
let vName = Var.varName v
isLocal <- isALocal vName
dflags <- getDynFlags
return $
case idDetails v of
FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
-> C.External (unpackFS nm) (show
SDoc (ppr
callconv)
)
(make_ty (varType v))
-> C.External (unpackFS nm) (show
Ppr dflags
callconv) (make_ty
dflags
(varType v))
FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
panic "make_exp: FFI values not supported"
FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (show
SDoc (ppr
callconv)
)
(make_ty (varType v))
-> C.DynExternal (show
Ppr dflags
callconv) (make_ty
dflags
(varType v))
-- Constructors are always exported, so make sure to declare them
-- with qualified names
DataConWorkId _ -> C.Var (make_var_qid False vName)
DataConWrapId _ -> C.Var (make_var_qid False vName)
_ -> C.Var (make_var_qid isLocal vName)
DataConWorkId _ -> C.Var (make_var_qid
dflags
False vName)
DataConWrapId _ -> C.Var (make_var_qid
dflags
False vName)
_ -> C.Var (make_var_qid
dflags
isLocal vName)
make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = return $ C.Lit (make_lit l)
make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
make_exp (Lit l) = do dflags <- getDynFlags
return $ C.Lit (make_lit dflags l)
make_exp (App e (Type t)) = do b <- make_exp e
dflags <- getDynFlags
return $ C.Appt b (make_ty dflags t)
make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO
make_exp (App e1 e2) = do
rator <- make_exp e1
...
...
@@ -159,9 +175,12 @@ make_exp (App e1 e2) = do
return $ C.App rator rand
make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = make_exp e >>= (\ b ->
return $ C.Lam (C.Vb (make_vbind v)) b)
make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
make_exp (Lam v e) | otherwise = do b <- make_exp e
dflags <- getDynFlags
return $ C.Lam (C.Vb (make_vbind dflags v)) b
make_exp (Cast e co) = do b <- make_exp e
dflags <- getDynFlags
return $ C.Cast b (make_co dflags co)
make_exp (Let b e) = do
vd <- make_vdef False b
body <- make_exp e
...
...
@@ -169,19 +188,23 @@ make_exp (Let b e) = do
make_exp (Case e v ty alts) = do
scrut <- make_exp e
newAlts <- mapM make_alt alts
return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
dflags <- getDynFlags
return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> CoreM C.Alt
make_alt (DataAlt dcon, vs, e) = do
newE <- make_exp e
return $ C.Acon (make_con_qid (dataConName dcon))
dflags <- getDynFlags
return $ C.Acon (make_con_qid dflags (dataConName dcon))
(map make_tbind tbs)
(map make_vbind vbs)
(map
(
make_vbind
dflags)
vbs)
newE
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l)))
make_alt (LitAlt l,_,e) = do x <- make_exp e
dflags <- getDynFlags
return $ C.Alit (make_lit dflags l) x
make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault)
-- This should never happen, as the DEFAULT alternative binds no variables,
-- but we might as well check for it:
...
...
@@ -189,8 +212,8 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
++ "alternative had a non-empty var list") (ppr a)
make_lit :: Literal -> C.Lit
make_lit l =
make_lit ::
DynFlags ->
Literal -> C.Lit
make_lit
dflags
l =
case l of
-- Note that we need to check whether the character is "big".
-- External Core only allows character literals up to '\xff'.
...
...
@@ -208,22 +231,22 @@ make_lit l =
MachDouble r -> C.Lrational r t
_ -> error "MkExternalCore died: make_lit"
where
t = make_ty (literalType l)
t = make_ty
dflags
(literalType l)
-- Expand type synonyms, then convert.
make_ty :: Type -> C.Ty
-- Be sure to expand types recursively!
make_ty ::
DynFlags ->
Type -> C.Ty -- Be sure to expand types recursively!
-- example: FilePath ~> String ~> [Char]
make_ty t | Just expanded <- tcView t = make_ty expanded
make_ty t = make_ty' t
make_ty
dflags
t | Just expanded <- tcView t = make_ty
dflags
expanded
make_ty
dflags
t = make_ty'
dflags
t
-- note calls to make_ty so as to expand types recursively
make_ty' :: Type -> C.Ty
make_ty' (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty' (TyConApp tc ts) = make_tyConApp tc ts
make_ty' (LitTy {}) = panic "MkExernalCore can't do literal types yet"
make_ty' ::
DynFlags ->
Type -> C.Ty
make_ty'
_
(TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty'
dflags
(AppTy t1 t2) = C.Tapp (make_ty
dflags
t1) (make_ty
dflags
t2)
make_ty'
dflags
(FunTy t1 t2) = make_ty
dflags
(TyConApp funTyCon [t1,t2])
make_ty'
dflags
(ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty
dflags
t)
make_ty'
dflags
(TyConApp tc ts) = make_tyConApp
dflags
tc ts
make_ty'
_
(LitTy {}) = panic "MkExernalCore can't do literal types yet"
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
...
...
@@ -237,10 +260,10 @@ make_ty' (LitTy {}) = panic "MkExernalCore can't do literal types yet"
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?
make_tyConApp :: TyCon -> [Type] -> C.Ty
make_tyConApp tc ts =
foldl C.Tapp (C.Tcon (qtc tc))
(map make_ty ts)
make_tyConApp ::
DynFlags ->
TyCon -> [Type] -> C.Ty
make_tyConApp
dflags
tc ts =
foldl C.Tapp (C.Tcon (qtc
dflags
tc))
(map
(
make_ty
dflags)
ts)
make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
...
...
@@ -267,52 +290,53 @@ make_var_id = make_id True
-- because that would just be ugly.)
-- SIGH.
-- We encode the package name as well.
make_mid :: Module -> C.Id
make_mid ::
DynFlags ->
Module -> C.Id
-- Super ugly code, but I can't find anything else that does quite what I
-- want (encodes the hierarchical module name without encoding the colon
-- that separates the package name from it.)
make_mid m = showSDoc $
make_mid dflags m
= showSDoc dflags $
(text $ zEncodeString $ packageIdString $ modulePackageId m)
<> text ":"
<> (pprEncoded $ pprModuleName $ moduleName m)
where pprEncoded = pprCode CStyle
make_qid :: Bool -> Bool -> Name -> C.Qual C.Id
make_qid force_unqual is_var n = (mname,make_id is_var n)
make_qid ::
DynFlags ->
Bool -> Bool -> Name -> C.Qual C.Id
make_qid
dflags
force_unqual is_var n = (mname,make_id is_var n)
where mname =
case nameModule_maybe n of
Just m | not force_unqual -> make_mid m
Just m | not force_unqual -> make_mid
dflags
m
_ -> ""
make_var_qid :: Bool -> Name -> C.Qual C.Id
make_var_qid force_unqual = make_qid force_unqual True
make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False False
make_co :: Coercion -> C.Ty
make_co (Refl ty) = make_ty ty
make_co (TyConAppCo tc cos) = make_conAppCo
(qtc
tc) cos
make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2)
make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co)
make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
make_co (AxiomInstCo cc cos) = make_conAppCo
(qcc
cc) cos
make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2)
make_co (SymCo co) = C.SymCoercion (make_co co)
make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2)
make_co (NthCo d co) = C.NthCoercion d (make_co co)
make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty)
make_var_qid ::
DynFlags ->
Bool -> Name -> C.Qual C.Id
make_var_qid
dflags
force_unqual = make_qid
dflags
force_unqual True
make_con_qid ::
DynFlags ->
Name -> C.Qual C.Id
make_con_qid
dflags
= make_qid
dflags
False False
make_co ::
DynFlags ->
Coercion -> C.Ty
make_co
dflags
(Refl ty) = make_ty
dflags
ty
make_co
dflags
(TyConAppCo tc cos) = make_conAppCo
dflags (qtc dflags
tc) cos
make_co
dflags
(AppCo c1 c2) = C.Tapp (make_co
dflags
c1) (make_co
dflags
c2)
make_co
dflags
(ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co
dflags
co)
make_co
_
(CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
make_co
dflags
(AxiomInstCo cc cos) = make_conAppCo
dflags (qcc dflags
cc) cos
make_co
dflags
(UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty
dflags
t1) (make_ty
dflags
t2)
make_co
dflags
(SymCo co) = C.SymCoercion (make_co
dflags
co)
make_co
dflags
(TransCo c1 c2) = C.TransCoercion (make_co
dflags
c1) (make_co
dflags
c2)
make_co
dflags
(NthCo d co) = C.NthCoercion d (make_co
dflags
co)
make_co
dflags
(InstCo co ty) = C.InstCoercion (make_co
dflags
co) (make_ty
dflags
ty)
-- Used for both tycon app coercions and axiom instantiations.
make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
make_conAppCo con cos =
make_conAppCo ::
DynFlags ->
C.Qual C.Tcon -> [Coercion] -> C.Ty
make_conAppCo
dflags
con cos =
foldl C.Tapp (C.Tcon con)
(map make_co cos)
(map
(
make_co
dflags)
cos)
-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
modName <- ask
modName <-
liftM cs_module
ask
return $ case nameModule_maybe vName of
-- Not sure whether isInternalName corresponds to "local"ness
-- in the External Core sense; need to re-read the spec.
...
...
compiler/deSugar/DsBinds.lhs
View file @
ab50c9c5
...
...
@@ -451,11 +451,12 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
; dflags <- getDynFlags
; let spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ show
SDoc (ppr
poly_name))
)
(mkFastString ("SPEC " ++ show
Ppr dflags
poly_name))
rule_act poly_name
final_bndrs args
(mkVarApps (Var spec_id) bndrs)
...
...
@@ -463,7 +464,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; spec_rhs <- dsHsWrapper spec_co poly_rhs
; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; dflags <- getDynFlags
; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
(warnDs (specOnInline poly_name))
; return (Just (spec_pair `consOL` unf_pairs, rule))
...
...
compiler/deSugar/DsCCall.lhs
View file @
ab50c9c5
...
...
@@ -48,6 +48,7 @@ import Literal
import PrelNames
import VarSet
import Constants
import DynFlags
import Outputable
import Util
\end{code}
...
...
@@ -98,13 +99,14 @@ dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
dflags <- getDynFlags
let
target = StaticTarget lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
the_prim_app = mkFCall
dflags
uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: Unique -> ForeignCall
mkFCall ::
DynFlags ->
Unique -> ForeignCall
-> [CoreExpr] -- Args
-> Type -- Result type
-> CoreExpr
...
...
@@ -117,14 +119,14 @@ mkFCall :: Unique -> ForeignCall
-- Here we build a ccall thus
-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))
-- a b s x c
mkFCall uniq the_fcall val_args res_ty
mkFCall
dflags
uniq the_fcall val_args res_ty
= mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
tyvars = varSetElems (tyVarsOfType body_ty)
ty = mkForAllTys tyvars body_ty
the_fcall_id = mkFCallId uniq the_fcall ty
the_fcall_id = mkFCallId
dflags
uniq the_fcall ty
\end{code}
\begin{code}
...
...
compiler/deSugar/DsExpr.lhs
View file @
ab50c9c5
...
...
@@ -765,14 +765,15 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
handle_failure pat match fail_op
| matchCanFail match
= do { fail_op' <- dsExpr fail_op
; fail_msg <- mkStringExpr (mk_fail_msg pat)
; dflags <- getDynFlags
; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
; extractMatchResult match (App fail_op' fail_msg) }
| otherwise
= extractMatchResult match (error "It can't fail")
mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in do expression at " ++
showSDoc (ppr
(getLoc pat)
)
mk_fail_msg ::
DynFlags ->
Located e -> String
mk_fail_msg
dflags
pat = "Pattern match failure in do expression at " ++
showPpr dflags
(getLoc pat)
\end{code}
...
...
compiler/deSugar/DsForeign.lhs
View file @
ab50c9c5
...
...
@@ -207,12 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
ccall_uniq <- newUnique
work_uniq <- newUnique
dflags <- getDynFlags
(fcall', cDoc) <-
case fcall of
CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
do fcall_uniq <- newUnique
let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
mkFastString (show
SDoc (ppr
fcall_uniq)
)
`appendFS`
mkFastString (show
Ppr dflags
fcall_uniq) `appendFS`
mkFastString "_" `appendFS`
cName
fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
...
...
@@ -256,7 +257,7 @@ dsFCall fn_id co fcall mDeclHeader = do
let
-- Build the worker
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
the_ccall_app = mkFCall
dflags
ccall_uniq fcall' val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
...
...
@@ -298,8 +299,9 @@ dsPrimCall fn_id co fcall = do
args <- newSysLocalsDs arg_tys
ccall_uniq <- newUnique
dflags <- getDynFlags
let
call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
call_app = mkFCall
dflags
ccall_uniq fcall (map Var args) io_res_ty
rhs = mkLams tvs (mkLams args call_app)
rhs' = Cast rhs co
return ([(fn_id, rhs')], empty, empty)
...
...
@@ -403,9 +405,10 @@ dsFExportDynamic :: Id
dsFExportDynamic id co0 cconv = do
fe_id <- newSysLocalDs ty
mod <- getModuleDs
dflags <- getDynFlags
let
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName
dflags
fe_id)
cback <- newSysLocalDs arg_ty
newStablePtrId <- dsLookupGlobalId newStablePtrName
...
...
@@ -465,8 +468,8 @@ dsFExportDynamic id co0 cconv = do
Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
-- Must have an IO type; hence Just
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
toCName ::
DynFlags ->
Id -> String
toCName
dflags
i = showSDoc
dflags
(pprCode CStyle (ppr (idName i)))
\end{code}
%*
...
...
compiler/deSugar/DsListComp.lhs
View file @
ab50c9c5
...
...
@@ -820,14 +820,16 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
handle_failure pat match fail_op
| matchCanFail match
= do { fail_op' <- dsExpr fail_op
; fail_msg <- mkStringExpr (mk_fail_msg pat)
; dflags <- getDynFlags
; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
; extractMatchResult match (App fail_op' fail_msg) }
| otherwise
= extractMatchResult match (error "It can't fail")
mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++
showSDoc (ppr (getLoc pat))
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat
= "Pattern match failure in monad comprehension at " ++