summaryrefslogtreecommitdiff
path: root/ghc/compiler/coreSyn
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/coreSyn')
-rw-r--r--ghc/compiler/coreSyn/CorePrep.lhs6
-rw-r--r--ghc/compiler/coreSyn/CoreSyn.hi-boot-61
-rw-r--r--ghc/compiler/coreSyn/CoreUnfold.lhs5
-rw-r--r--ghc/compiler/coreSyn/CoreUtils.lhs12
-rw-r--r--ghc/compiler/coreSyn/ExternalCore.lhs4
-rw-r--r--ghc/compiler/coreSyn/MkExternalCore.lhs22
-rw-r--r--ghc/compiler/coreSyn/PprCore.lhs2
-rw-r--r--ghc/compiler/coreSyn/PprExternalCore.lhs6
-rw-r--r--ghc/compiler/coreSyn/Subst.lhs23
9 files changed, 35 insertions, 46 deletions
diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 18444b6892..1602a07b86 100644
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -16,7 +16,6 @@ import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe,
isUnLiftedType, isUnboxedTupleType, seqType )
-import TcType ( TyThing( AnId ) )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
@@ -26,7 +25,7 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
isLocalId, hasNoBinding, idNewStrictness,
idUnfolding, isDataConWorkId_maybe
)
-import HscTypes ( TypeEnv, typeEnvElts )
+import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
@@ -579,9 +578,6 @@ mkLocalNonRec bndr dem floats rhs
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')))
- where
- bndr_ty = idType bndr
-
mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
mkBinds (Floats _ binds) body
diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6
index db6c7550ac..38dc8c7f7e 100644
--- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6
+++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6
@@ -3,4 +3,3 @@ module CoreSyn where
-- Needed by Var.lhs
data Expr b
type CoreExpr = Expr Var.Var
-
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 01d7925741..baf76c7225 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -42,8 +42,7 @@ import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId,
- idUnfolding,
- isFCallId_maybe, globalIdDetails
+ idUnfolding, globalIdDetails
)
import DataCon ( isUnboxedTupleCon )
import Literal ( litSize )
@@ -137,7 +136,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
| not inline -> UnfoldNever
-- A big function with an INLINE pragma must
-- have an UnfoldIfGoodArgs guidance
- | inline -> UnfoldIfGoodArgs n_val_binders
+ | otherwise -> UnfoldIfGoodArgs n_val_binders
(map (const 0) val_binders)
max_inline_size 0
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 7921b3cfcf..5a82fdda3b 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -47,7 +47,7 @@ import Name ( hashName, isDllName )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
- isExistentialDataCon, dataConTyCon, dataConName )
+ isExistentialDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo,
@@ -59,7 +59,7 @@ import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
splitFunTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
- splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
+ splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
funResultTy, applyTy
)
@@ -932,13 +932,15 @@ eta_expand n us expr ty
; Nothing ->
-- Given this:
- -- newtype T = MkT (Int -> Int)
+ -- newtype T = MkT ([T] -> Int)
-- Consider eta-expanding this
-- eta_expand 1 e T
-- We want to get
- -- coerce T (\x::Int -> (coerce (Int->Int) e) x)
+ -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+ -- Only try this for recursive newtypes; the non-recursive kind
+ -- are transparent anyway
- case splitNewType_maybe ty of {
+ case splitRecNewType_maybe ty of {
Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs
index 06cf07940b..d7eb45579a 100644
--- a/ghc/compiler/coreSyn/ExternalCore.lhs
+++ b/ghc/compiler/coreSyn/ExternalCore.lhs
@@ -14,13 +14,13 @@ data Tdef
| Newtype (Qual Tcon) [Tbind] (Maybe Ty)
data Cdef
- = Constr (Qual Dcon) [Tbind] [Ty]
+ = Constr Dcon [Tbind] [Ty]
data Vdefg
= Rec [Vdef]
| Nonrec Vdef
-type Vdef = (Qual Var,Ty,Exp)
+type Vdef = (Var,Ty,Exp) -- Top level bindings are unqualified now
data Exp
= Var (Qual Var)
diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index 86c77da144..66fa9711e3 100644
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -18,6 +18,7 @@ import TyCon
import Class
import TypeRep
import Type
+import PprExternalCore -- Instances
import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys,
dataConName, dataConWrapId_maybe )
import CoreSyn
@@ -28,12 +29,10 @@ import CoreTidy ( tidyExpr )
import VarEnv ( emptyTidyEnv )
import Literal
import Name
-import CostCentre
import Outputable
import ForeignCall
-import PprExternalCore
import CmdLineOpts
-import Maybes ( orElse, catMaybes )
+import Maybes ( mapCatMaybes )
import IO
import FastString
@@ -73,11 +72,11 @@ mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = bin
other_implicit_binds = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))
implicit_con_ids :: TyThing -> [Id]
-implicit_con_ids (ATyCon tc) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc))
+implicit_con_ids (ATyCon tc) | isAlgTyCon tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
implicit_con_ids other = []
other_implicit_ids :: TyThing -> [Id]
-other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc
+other_implicit_ids (ATyCon tc) = tyConSelIds tc
other_implicit_ids (AClass cl) = classSelIds cl
other_implicit_ids other = []
@@ -110,7 +109,7 @@ collect_tdefs _ tdefs = tdefs
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
where
- dcon_name = make_con_qid (dataConName dcon)
+ dcon_name = make_var_id (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExistentialTyVars dcon
tys = map make_ty (dataConRepArgTys dcon)
@@ -126,7 +125,8 @@ make_vdef b =
case b of
NonRec v e -> C.Nonrec (f (v,e))
Rec ves -> C.Rec (map f ves)
- where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e)
+ where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e)
+ -- Top level bindings are unqualified now
make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =
@@ -187,7 +187,7 @@ make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
(map make_ty ts)
-- The special case for newtypes says "do not expand newtypes".
--- Reason: sourceTypeRep does substitution and, while substitution deals
+-- Reason: predTypeRep does substitution and, while substitution deals
-- correctly with name capture, it's only correct if you see the uniques!
-- If you just see occurrence names, name capture may occur.
-- Example: newtype A a = A (forall b. b -> a)
@@ -198,11 +198,11 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?
-make_ty (SourceTy (NType tc ts)) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
+make_ty (NewTcApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
(map make_ty ts)
-make_ty (SourceTy p) = make_ty (sourceTypeRep p)
-make_ty (NoteTy _ t) = make_ty t
+make_ty (PredTy p) = make_ty (predTypeRep p)
+make_ty (NoteTy _ t) = make_ty t
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 2d62772859..09bb56e092 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -258,8 +258,6 @@ ppr_case_pat con args
pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
pprArg expr = pprParendExpr expr
-
-arrow = ptext SLIT("->")
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs
index 73536fa99d..357780d295 100644
--- a/ghc/compiler/coreSyn/PprExternalCore.lhs
+++ b/ghc/compiler/coreSyn/PprExternalCore.lhs
@@ -55,12 +55,12 @@ ptdef (Newtype tcon tbinds rep ) =
Nothing -> empty
pcdef (Constr dcon tbinds tys) =
- (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
+ (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
pname id = text id
pqname ("",id) = pname id
-pqname (m,id) = pname m <> char '.' <> pname id
+pqname (m,id) = pname m <> char '.' <> pname id
ptbind (t,Klifted) = pname t
ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
@@ -96,7 +96,7 @@ pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes))))
pvdefg (Nonrec vte) = pvte vte
-pvte (v,t,e) = sep [pqname v <+> text "::" <+> pty t <+> char '=',
+pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=',
indent (pexp e)]
paexp (Var x) = pqname x
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index c406f926e0..1994caa358 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -44,7 +44,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
)
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( ThetaType, SourceType(..), PredType,
+import Type ( ThetaType, PredType(..),
tyVarsOfType, tyVarsOfTypes, mkAppTy,
)
import VarSet
@@ -58,8 +58,7 @@ import IdInfo ( IdInfo, vanillaIdInfo,
specInfo, setSpecInfo,
setArityInfo, unknownArity, arityInfo,
unfoldingInfo, setUnfoldingInfo,
- WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
- lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
)
import BasicTypes ( OccInfo(..) )
import Unique ( Unique, Uniquable(..), deriveUnique )
@@ -427,11 +426,8 @@ substTheta subst theta
| otherwise = map (substPred subst) theta
substPred :: TyVarSubst -> PredType -> PredType
-substPred = substSourceType
-
-substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty)
-substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
-substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys)
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
+substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
subst_ty subst ty
= go ty
@@ -439,7 +435,10 @@ subst_ty subst ty
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
- go (SourceTy p) = SourceTy $! (substSourceType subst p)
+ go (NewTcApp tc tys) = let args = map go tys
+ in args `seqList` NewTcApp tc args
+
+ go (PredTy p) = PredTy $! (substPred subst p)
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
@@ -632,8 +631,7 @@ simplIdInfo subst old_info
\begin{code}
-- substBndr and friends are used when doing expression substitution only
-- In this case we can *preserve* occurrence information, and indeed we *want*
--- to do so else lose useful occ info in rules. Hence the calls to
--- simpl_id with keepOccInfo
+-- to do so else lose useful occ info in rules.
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
@@ -651,8 +649,6 @@ substRecBndrs subst bndrs
-- Here's the reason we need to pass rec_subst to subst_id
(new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
subst bndrs
-
-keepOccInfo occ = False -- Never fragile
\end{code}
@@ -747,7 +743,6 @@ substIdInfo :: Bool -- True <=> keep even fragile info
-- Substitute the
-- rules
-- worker info
--- LBVar info
-- Zap the unfolding
-- If keep_fragile then
-- keep OccInfo
View Lorry Controller Status