Skip to content

GitLab

GHC
GHC
Commit ab50c9c5 authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

Pass DynFlags down to showSDoc

parent 543ec085
Hide whitespace changes
Inline Side-by-side
Showing with 434 additions and 320 deletions
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) (showSDoc (ppr callconv)) (make_ty (varType v))
-> C.External (unpackFS nm) (showPpr 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 (showSDoc (ppr callconv)) (make_ty (varType v))
-> C.DynExternal (showPpr 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 " ++ showSDoc (ppr poly_name)))
(mkFastString ("SPEC " ++ showPpr 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 (showSDoc (ppr fcall_uniq)) `appendFS`
mkFastString (showPpr 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 " ++
showPpr dflags (getLoc pat)
-- Desugar nested monad comprehensions, for example in `then..` constructs
-- dsInnerMonadComp quals [a,b,c] ret_op
......
compiler/deSugar/DsUtils.lhs
View file @ ab50c9c5
......@@ -76,6 +76,7 @@ import Outputable
import SrcLoc
import Util
import ListSetOps
import DynFlags
import FastString
import Control.Monad ( zipWithM )
......@@ -439,8 +440,9 @@ mkErrorAppDs :: Id -- The error function
mkErrorAppDs err_id ty msg = do
src_loc <- getSrcSpanDs
dflags <- getDynFlags