Skip to content

GitLab

Commit 4a91d102 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-24 07:35:00 by simonpj] 

Mainly MkIface
parent ebef357f
Expand all Hide whitespace changes
Inline Side-by-side
ghc/compiler/absCSyn/Costs.lhs
View file @ 4a91d102
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: Costs.lhs,v 1.26 2000/09/27 14:03:12 simonpj Exp $
% $Id: Costs.lhs,v 1.27 2000/10/24 07:35:00 simonpj Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
......@@ -71,9 +71,6 @@ data CostRes = Cost (Int, Int, Int, Int, Int)
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes
errorCosts = Cost (-1, -1, -1, -1, -1) -- just for debugging
oneArithm = Cost (1, 0, 0, 0, 0) :: CostRes
instance Eq CostRes where
(==) t1 t2 = i && b && l && s && f
......@@ -367,9 +364,6 @@ gmpOps =
]
abs_costs = nullCosts -- NB: This is normal STG code with costs already
-- included; no need to add costs again.
umul_costs = Cost (21,4,0,0,0) -- due to spy counts
rem_costs = Cost (30,15,0,0,0) -- due to spy counts
div_costs = Cost (30,15,0,0,0) -- due to spy counts
......
ghc/compiler/basicTypes/BasicTypes.lhs
View file @ 4a91d102
......@@ -83,8 +83,10 @@ type Version = Int
bogusVersion :: Version -- Shouldn't look at these
bogusVersion = error "bogusVersion"
bumpVersion :: Version -> Version
bumpVersion v = v+1
bumpVersion :: Bool -> Version -> Version
-- Bump if the predicate (typically equality between old and new) is false
bumpVersion False v = v+1
bumpVersion True v = v+1
initialVersion :: Version
initialVersion = 1
......
ghc/compiler/codeGen/CgStackery.lhs
View file @ 4a91d102
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgStackery.lhs,v 1.14 2000/01/14 11:45:21 hwloidl Exp $
% $Id: CgStackery.lhs,v 1.15 2000/10/24 07:35:00 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
......@@ -23,7 +23,7 @@ import CgMonad
import AbsCSyn
import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import Panic ( panic )
......
ghc/compiler/hsSyn/HsCore.lhs
View file @ 4a91d102
......@@ -15,7 +15,7 @@ module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
HsIdInfo(..),
IfaceSig(..),
IfaceSig(..), ifaceSigName,
eq_ufExpr, eq_ufBinders, pprUfExpr,
......@@ -37,8 +37,7 @@ import Var ( varType, isId )
import IdInfo ( ArityInfo, InlinePragInfo,
pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
)
import RdrName ( RdrName )
import Name ( toRdrName )
import Name ( Name, getName )
import CoreSyn
import CostCentre ( pprCostCentreCore )
import PrimOp ( PrimOp(CCallOp) )
......@@ -104,7 +103,7 @@ data UfBinder name
%************************************************************************
\begin{code}
toUfExpr :: CoreExpr -> UfExpr RdrName
toUfExpr :: CoreExpr -> UfExpr Name
toUfExpr (Var v) = toUfVar v
toUfExpr (Lit l) = case maybeLitLit l of
Just (s,ty) -> UfLitLit s (toHsType ty)
......@@ -112,7 +111,7 @@ toUfExpr (Lit l) = case maybeLitLit l of
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
......@@ -127,11 +126,11 @@ toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
---------------------
toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
---------------------
toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
| otherwise = UfDataAlt (toRdrName dc)
toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
| otherwise = UfDataAlt (getName dc)
where
tc = dataConTyCon dc
......@@ -141,15 +140,15 @@ toUfCon (LitAlt l) = case maybeLitLit l of
toUfCon DEFAULT = UfDefault
---------------------
toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x))
| otherwise = UfTyBinder (toRdrName x) (varType x)
toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
| otherwise = UfTyBinder (getName x) (varType x)
---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
= case isDataConId_maybe v of
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
where
val_args = dropWhile isTypeArg as
saturated = length val_args == idArity v
......@@ -167,7 +166,7 @@ mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
toUfVar v = case isPrimOpId_maybe v of
-- Ccalls has special syntax
Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
other -> UfVar (toRdrName v)
other -> UfVar (getName v)
\end{code}
......@@ -330,6 +329,9 @@ instance Ord name => Eq (IfaceSig name) where
instance (Outputable name) => Outputable (IfaceSig name) where
ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
ifaceSigName :: IfaceSig name -> name
ifaceSigName (IfaceSig name _ _ _) = name
\end{code}
......
ghc/compiler/hsSyn/HsDecls.lhs
View file @ 4a91d102
......@@ -13,12 +13,12 @@ module HsDecls (
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
IfaceSig(..), SpecDataSig(..),
IfaceSig(..),
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
toClassDeclNameList,
fromClassDeclNameList
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
mkClassDeclSysNames,
getClassDeclSysNames
) where
#include "HsVersions.h"
......@@ -26,15 +26,15 @@ module HsDecls (
-- friends:
import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
import HsExpr ( HsExpr )
import HsPragmas ( DataPragmas, ClassPragmas )
import HsImpExp ( IE(..) )
import HsTypes
import PprCore ( pprCoreRule )
import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr )
import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), ifaceSigName,
eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr
)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
import Name ( toRdrName )
import Name ( getName )
-- others:
import FunDeps ( pprFundeps )
......@@ -84,7 +84,7 @@ hsDeclName :: (Outputable name, Outputable pat)
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (SigD (IfaceSig name _ _ _)) = name
hsDeclName (SigD decl) = ifaceSigName decl
hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
......@@ -93,11 +93,6 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ ) = name
instDeclName :: InstDecl name pat -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
......@@ -188,7 +183,6 @@ data TyClDecl name pat
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
-- expect...
(DataPragmas name)
SrcLoc
name -- generic converter functions
name -- generic converter functions
......@@ -204,30 +198,62 @@ data TyClDecl name pat
[FunDep name] -- functional dependencies
[Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
(ClassPragmas name)
[name] -- The names of the tycon, datacon
-- wrapper, datacon worker,
-- and superclass selectors for this
-- class (the first 3 are at the front
-- of the list in this order)
-- These are filled in as the
-- ClassDecl is made.
(ClassDeclSysNames name)
SrcLoc
-- Put type signatures in and explain further!!
-- The names of the tycon, datacon
-- wrapper, datacon worker,
-- and superclass selectors for this
-- class (the first 3 are at the front
-- of the list in this order)
-- These are filled in as the
toClassDeclNameList (a,b,c,ds) = a:b:c:ds
fromClassDeclNameList (a:b:c:ds) = (a,b,c,ds)
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- Returns all the binding names of the decl, along with their SrcLocs
-- The first one is guaranteed to be the name of the decl
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
tyClDeclNames (TySynonym name _ _ loc)
= [(name,loc)]
tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc)
= (name,loc) : [(name,loc) | ClassOpSig n _ _ loc <- sigs]
tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
= (name,loc) : conDeclsNames cons
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
-- superclass selector 1, ..., superclass selector n]
-- They are kept in a list rather than a tuple to make the
-- renamer easier.
mkClassDeclSysNames :: (name, name, name, [name]) -> [name]
getClassDeclSysNames :: [name] -> (name, name, name, [name])
mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
\begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
(==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _ _)
(TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _ _)
(==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
(TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
= n1 == n2 &&
nd1 == nd2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
......@@ -240,8 +266,8 @@ instance Ord name => Eq (TyClDecl name pat) where
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
(==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ )
(ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ )
(==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ )
(ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ )
= n1 == n2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
eq_hsContext env cxt1 cxt2 &&
......@@ -271,21 +297,10 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
= (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData DataType _ _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData NewType _ _ _ _ _ _ _ _ _ _ <- decls],
= (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls],
length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
\begin{code}
......@@ -296,7 +311,8 @@ instance (Outputable name, Outputable pat)
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
ppr (TyData new_or_data context tycon tyvars condecls ncons
derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
= pp_tydecl
(ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
(pp_condecls condecls ncons)
......@@ -306,7 +322,7 @@ instance (Outputable name, Outputable pat)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ src_loc)
ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc)
| null sigs -- No "where" part
= top_matter
......@@ -319,7 +335,6 @@ instance (Outputable name, Outputable pat)
pp_methods = getPprStyle $ \ sty ->
if ifaceStyle sty then empty else ppr methods
pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
......@@ -335,22 +350,6 @@ pp_tydecl pp_head pp_decl_rhs derivings
])
\end{code}
A type for recording what types a datatype should be specialised to.
It's called a ``Sig'' because it's sort of like a ``type signature''
for an datatype declaration.
\begin{code}
data SpecDataSig name
= SpecDataSig name -- tycon to specialise
(HsType name)
SrcLoc
instance (Outputable name)
=> Outputable (SpecDataSig name) where
ppr (SpecDataSig tycon ty _)
= hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
\end{code}
%************************************************************************
%* *
......@@ -383,7 +382,30 @@ data ConDetails name
| RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
\end{code}
\begin{code}
conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)]
-- See tyClDeclNames for what this does
-- The function is boringly complicated because of the records
-- And since we only have equality, we have to be a little careful
conDeclsNames cons
= snd (foldl do_one ([], []) cons)
where
do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
= do_details ((name,loc):acc) details
where
do_details acc (RecCon flds) = foldl do_fld (flds_seen, acc) flds
do_details acc other = (flds_seen, acc)
do_fld acc (flds, _) = foldl do_fld1 acc flds
do_fld1 (flds_seen, acc) fld
| fld `elem` flds_seen = (flds_seen,acc)
| otherwise = (fld:flds_seen, (fld,loc):acc)
\end{code}
\begin{code}
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
(ConDecl n2 _ tvs2 cxt2 cds2 _)
= n1 == n2 &&
......@@ -400,8 +422,9 @@ eq_ConDetails env (RecCon fs1) (RecCon fs2)
eq_ConDetails env _ _ = False
eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
\end{code}
\begin{code}
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
......@@ -642,11 +665,11 @@ toHsRule id (BuiltinRule _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
toHsRule id (Rule name bndrs args rhs)
= IfaceRule name (map toUfBndr bndrs) (toRdrName id)
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
......@@ -656,17 +679,14 @@ bogusIfaceRule id
%* *
%************************************************************************
We use exported entities for things to deprecate. Cunning trick (hack?):
`IEModuleContents undefined' is used for module deprecation.
We use exported entities for things to deprecate.
\begin{code}
data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc
data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
instance Outputable name => Outputable (DeprecDecl name) where
ppr (Deprecation (IEModuleContents _) txt _)
= hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
ppr (Deprecation thing txt _)
ppr (Deprecation thing txt _)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code}
ghc/compiler/hsSyn/HsPragmas.lhs
View file @ 4a91d102
......@@ -8,51 +8,16 @@
%************************************************************************
See also: @Sig@ (``signatures'') which is where user-supplied pragmas
for values show up; ditto @SpecInstSig@ (for instances) and
@SpecDataSig@ (for data types).
for values show up; ditto @SpecInstSig@ (for instances)
\begin{code}
module HsPragmas where
#include "HsVersions.h"
import IdInfo
import Outputable
\end{code}
All the pragma stuff has changed. Here are some placeholders!
\begin{code}
data GenPragmas name = NoGenPragmas
data DataPragmas name = NoDataPragmas
data InstancePragmas name = NoInstancePragmas
data ClassOpPragmas name = NoClassOpPragmas
data ClassPragmas name = NoClassPragmas
noClassPragmas = NoClassPragmas
isNoClassPragmas NoClassPragmas = True
noDataPragmas = NoDataPragmas
isNoDataPragmas NoDataPragmas = True
noGenPragmas = NoGenPragmas
isNoGenPragmas NoGenPragmas = True
noInstancePragmas = NoInstancePragmas
isNoInstancePragmas NoInstancePragmas = True
noClassOpPragmas = NoClassOpPragmas
isNoClassOpPragmas NoClassOpPragmas = True
instance Outputable name => Outputable (ClassPragmas name) where
ppr NoClassPragmas = empty
instance Outputable name => Outputable (ClassOpPragmas name) where
ppr NoClassOpPragmas = empty
instance Outputable name => Outputable (InstancePragmas name) where
ppr NoInstancePragmas = empty
instance Outputable name => Outputable (GenPragmas name) where
ppr NoGenPragmas = empty
\end{code}
ghc/compiler/hsSyn/HsSyn.lhs
View file @ 4a91d102
......@@ -10,7 +10,7 @@ therefore, is almost nothing but re-exporting.
\begin{code}
module HsSyn (
-- NB: don't reexport HsCore or HsPragmas;
-- NB: don't reexport HsCore
-- this module tells about "real Haskell"
module HsSyn,
......
ghc/compiler/hsSyn/HsTypes.lhs
View file @ 4a91d102
......@@ -32,7 +32,7 @@ import Type ( Type, Kind, PredType(..), ClassContext,
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity )
import RdrName ( RdrName )
import Name ( toRdrName )
import Name ( Name, getName )
import OccName ( NameSpace )
import Var ( TyVar, tyVarKind )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
......@@ -272,19 +272,19 @@ user-friendly as possible. Notably, it uses synonyms where possible, and
expresses overloaded functions using the '=>' context part of a HsForAllTy.
\begin{code}
toHsTyVar :: TyVar -> HsTyVarBndr RdrName
toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv)
toHsTyVar :: TyVar -> HsTyVarBndr Name
toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv)
toHsTyVars tvs = map toHsTyVar tvs
toHsType :: Type -> HsType RdrName
toHsType :: Type -> HsType Name
toHsType ty = toHsType' (unUsgTy ty)
-- For now we just discard the usage
toHsType' :: Type -> HsType RdrName
toHsType' :: Type -> HsType Name
-- Called after the usage is stripped off
-- This function knows the representation of types
toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv)
toHsType' (TyVarTy tv) = HsTyVar (getName tv)
toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
......@@ -295,11 +295,11 @@ toHsType' (PredTy p) = HsPredTy (toHsPred p)
toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| not saturated = generic_case
| isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
| isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
| otherwise = generic_case
where
generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
tys' = map toHsType tys
saturated = length tys == tyConArity tc
......@@ -309,14 +309,14 @@ toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of
(toHsType tau)
toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys)
toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty)
toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty)
toHsContext :: ClassContext -> HsContext RdrName
toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt]
toHsContext :: ClassContext -> HsContext Name
toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
toHsFDs :: [FunDep TyVar] -> [FunDep RdrName]
toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds]
toHsFDs :: [FunDep TyVar] -> [FunDep Name]
toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
\end{code}
......
ghc/compiler/javaGen/JavaGen.lhs
View file @ 4a91d102
......@@ -53,11 +53,10 @@ import Name ( NamedThing(..), getOccString, isGlobalName, isLocalName
, nameModule )
import PrimRep ( PrimRep(..) )
import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
import qualified TypeRep
import qualified Type
import qualified CoreSyn
import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
Bind(..), Alt, AltCon(..), collectBinders, isValArg
Bind(..), AltCon(..), collectBinders, isValArg
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import qualified CoreUtils
......
ghc/compiler/main/HscMain.lhs
View file @ 4a91d102
......@@ -282,3 +282,145 @@ initRules = foldl add emptyVarEnv builtinRules
add env (name,rule) = extendNameEnv_C add1 env name [rule]
add1 rules _ = rule : rules
\end{code}
\begin{code}
writeIface this_mod old_iface new_iface
local_tycons local_classes inst_info
final_ids tidy_binds tidy_orphan_rules
=
if isNothing opt_HiDir && isNothing opt_HiFile
then return () -- not producing any .hi file
else
let
hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
filename = case opt_HiFile of {
Just f -> f;
Nothing ->
case opt_HiDir of {
Just dir -> dir ++ '/':moduleUserString this_mod
++ '.':hi_suf;
Nothing -> panic "writeIface"
}}
in
do maybe_final_iface <- checkIface old_iface full_new_iface
case maybe_final_iface of {
Nothing -> when opt_D_dump_rn_trace $
putStrLn "Interface file unchanged" ; -- No need to update .hi file
Just final_iface ->
do let mod_vers_unchanged = case old_iface of
Just iface -> pi_vers iface == pi_vers final_iface
Nothing -> False
when (mod_vers_unchanged && opt_D_dump_rn_trace) $
putStrLn "Module version unchanged, but usages differ; hence need new hi file"
if_hdl <- openFile filename WriteMode
printForIface if_hdl (pprIface final_iface)
hClose if_hdl
}
where
full_new_iface = completeIface new_iface local_tycons local_classes
inst_info final_ids tidy_binds
tidy_orphan_rules
\end{code}
%************************************************************************
%* *