#else
#define ASSERT(e)
#endif
-#define CHK_Ubiq() import Ubiq
+
+#if __STDC__
+#define CAT2(a,b)a##b
+#else
+#define CAT2(a,b)a/**/b
+#endif
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200
+# define REALLY_HASKELL_1_3
+# define SYN_IE(a) a
+# define IMPORT_DELOOPER(mod) import CAT2(mod,_1_3)
+# define IMPORT_1_3(mod) import mod
+# define _tagCmp compare
+# define _LT LT
+# define _EQ EQ
+# define _GT GT
+# define Text Show
+#else
+# define SYN_IE(a) a(..)
+# define IMPORT_DELOOPER(mod) import mod
+# define IMPORT_1_3(mod) {--}
+#endif
+#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq)
+#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#define trace _trace
#endif {- ! __GLASGOW_HASKELL__ -}
-#if __GLASGOW_HASKELL__ >= 23
+#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
SuffixRule_c_o()
LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
+.SUFFIXES: .lhi
+.lhi.hi:
+ $(RM) $@
+ $(GHC_UNLIT) $< $@
+ @chmod 444 $@
+
/* assume ALL source is in subdirectories one level below
they don't have Jmakefiles; this Jmakefile controls everything
*/
STG_SRCS_LHS \
BACKSRCS_LHS NATIVEGEN_SRCS_LHS
+#if GhcBuilderVersion >= 200
+# define loop_hi(f) CAT3(f,_1_3,.hi)
+#else
+# define loop_hi(f) CAT2(f,.hi)
+#endif
+
+DELOOP_HIs = \
+utils/Ubiq.hi \
+absCSyn/AbsCLoop.hi \
+basicTypes/IdLoop.hi \
+codeGen/CgLoop1.hi \
+codeGen/CgLoop2.hi \
+deSugar/DsLoop.hi \
+hsSyn/HsLoop.hi \
+nativeGen/NcgLoop.hi \
+prelude/PrelLoop.hi \
+rename/RnLoop.hi \
+simplCore/SmplLoop.hi \
+typecheck/TcMLoop.hi \
+typecheck/TcLoop.hi \
+types/TyLoop.hi
+
/*
\
*/
/* OK, here we go: */
-utils/Ubiq.hi : utils/Ubiq.lhi
- $(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi
-
-absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi
- $(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi
-basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
- $(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
-codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi
- $(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi
-codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi
- $(GHC_UNLIT) codeGen/CgLoop2.lhi codeGen/CgLoop2.hi
-deSugar/DsLoop.hi : deSugar/DsLoop.lhi
- $(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi
-hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi
- $(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi
-nativeGen/NcgLoop.hi : nativeGen/NcgLoop.lhi
- $(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi
-prelude/PrelLoop.hi : prelude/PrelLoop.lhi
- $(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
-rename/RnLoop.hi : rename/RnLoop.lhi
- $(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi
-simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi
- $(GHC_UNLIT) simplCore/SmplLoop.lhi simplCore/SmplLoop.hi
-typecheck/TcMLoop.hi : typecheck/TcMLoop.lhi
- $(GHC_UNLIT) typecheck/TcMLoop.lhi typecheck/TcMLoop.hi
-typecheck/TcLoop.hi : typecheck/TcLoop.lhi
- $(GHC_UNLIT) typecheck/TcLoop.lhi typecheck/TcLoop.hi
-types/TyLoop.hi : types/TyLoop.lhi
- $(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi
-
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
compile(rename/ParseIface,hs,)
compile(rename/ParseUtils,lhs,)
compile(rename/RnHsSyn,lhs,)
-compile(rename/RnMonad,lhs,)
+compile(rename/RnMonad,lhs,if_ghc(-fvia-C))
compile(rename/Rename,lhs,)
compile(rename/RnNames,lhs,)
compile(rename/RnSource,lhs,)
compile(deforest/TreelessForm,lhs,)
#endif
-compile(specialise/Specialise,lhs,)
+compile(specialise/Specialise,lhs,-H12m if_ghc(-Onot)) /* -Onot for compile-space reasons */
compile(specialise/SpecEnv,lhs,)
compile(specialise/SpecUtils,lhs,)
compile(typecheck/TcInstUtil,lhs,)
compile(typecheck/TcMatches,lhs,)
compile(typecheck/TcModule,lhs,)
-compile(typecheck/TcMonad,lhs,)
+compile(typecheck/TcMonad,lhs,if_ghc(-fvia-C))
compile(typecheck/TcKind,lhs,)
compile(typecheck/TcType,lhs,)
compile(typecheck/TcEnv,lhs,)
compile(types/Class,lhs,)
compile(types/Kind,lhs,)
-compile(types/PprType,lhs,)
+compile(types/PprType,lhs,if_ghc26(-Onot)) /* avoid a 0.26 bug */
compile(types/TyCon,lhs,)
compile(types/TyVar,lhs,)
compile(types/Usage,lhs,)
YaccRunWithExpectMsg(parser/hsparser,12,0)
-UgenTarget(parser/constr)
-UgenTarget(parser/binding)
-UgenTarget(parser/pbinding)
-UgenTarget(parser/entidt)
-UgenTarget(parser/list)
-UgenTarget(parser/literal)
-UgenTarget(parser/maybe)
-UgenTarget(parser/either)
-UgenTarget(parser/qid)
-UgenTarget(parser/tree)
-UgenTarget(parser/ttype)
+UgenTarget(parser,constr)
+UgenTarget(parser,binding)
+UgenTarget(parser,pbinding)
+UgenTarget(parser,entidt)
+UgenTarget(parser,list)
+UgenTarget(parser,literal)
+UgenTarget(parser,maybe)
+UgenTarget(parser,either)
+UgenTarget(parser,qid)
+UgenTarget(parser,tree)
+UgenTarget(parser,ttype)
UGENS_C = parser/constr.c \
parser/binding.c \
#if HaskellCompilerType != HC_USE_HC_FILES
/* otherwise, the dependencies jeopardize our .hc files --
which are all we have! */
+depend :: $(DELOOP_HIs)
HaskellDependTarget( $(DEPSRCS) )
#endif
CostRes(Cost)
)-} where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
-- printing/forcing stuff comes from PprAbsC
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
mkConEntryLabel,
mkStaticConEntryLabel,
mkRednCountsLabel,
+ mkConInfoTableLabel,
mkPhantomInfoTableLabel,
+ mkStaticClosureLabel,
mkStaticInfoTableLabel,
mkVapEntryLabel,
mkVapInfoTableLabel,
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop ( CtrlReturnConvention(..),
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..),
ctrlReturnConvAlg
)
#if ! OMIT_NATIVE_CODEGEN
-import NcgLoop ( underscorePrefix, fmtAsmLbl )
+IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl )
#endif
import CStrings ( pp_cSEP )
\begin{code}
data CLabelId = CLabelId Id
+instance Ord3 CLabelId where
+ cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b
+
instance Eq CLabelId where
- CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False }
- CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True }
+ CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord CLabelId where
- CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> True; GT__ -> False }
- CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> True; EQ_ -> False; GT__ -> False }
- CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> True; GT__ -> True }
- CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b
- of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b
- of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
data IdLabelInfo
= Closure -- Label for (static???) closure
+ | StaticClosure -- Static closure -- e.g., nullary constructor
| InfoTbl -- Info table for a closure; always read-only
-- encoded into the name)
| ConEntry -- the only kind of entry pt for constructors
- | StaticConEntry -- static constructor entry point
+ | ConInfoTbl -- corresponding info table
+ | StaticConEntry -- static constructor entry point
| StaticInfoTbl -- corresponding info table
| PhantomInfoTbl -- for phantom constructors that only exist in regs
| VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version
- | VapEntry Bool
+ | VapEntry Bool
-- Ticky-ticky counting
| RednCounts -- Label of place to keep reduction-count info for this Id
\end{code}
\begin{code}
-mkClosureLabel id = IdLabel (CLabelId id) Closure
-mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
-mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
+mkClosureLabel id = IdLabel (CLabelId id) Closure
+mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
+mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
mkFastEntryLabel id arity = ASSERT(arity > 0)
- IdLabel (CLabelId id) (EntryFast arity)
-mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
-mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
-mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
-mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl
-mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl
-mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
-mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
+ IdLabel (CLabelId id) (EntryFast arity)
+
+mkStaticClosureLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticClosure
+mkStaticInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticInfoTbl
+mkConInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) ConInfoTbl
+mkPhantomInfoTableLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) PhantomInfoTbl
+mkConEntryLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) ConEntry
+mkStaticConEntryLabel con = ASSERT(isDataCon con)
+ IdLabel (CLabelId con) StaticConEntry
+
+mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts
+mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag)
+mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag)
mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag)
mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag)
Whether the labelled thing can be put in C "text space":
\begin{code}
-isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
-isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other
-isReadOnly (IdLabel _ PhantomInfoTbl) = True
-isReadOnly (IdLabel _ (VapInfoTbl _)) = True
-isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
+isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes
+isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other
+isReadOnly (IdLabel _ StaticInfoTbl) = True
+isReadOnly (IdLabel _ PhantomInfoTbl) = True
+isReadOnly (IdLabel _ (VapInfoTbl _)) = True
+isReadOnly (IdLabel _ other) = False -- others: pessimistically, no
isReadOnly (TyConLabel _ _) = True
isReadOnly (CaseLabel _ _) = True
EntryStd -> uppPStr SLIT("entry")
EntryFast arity -> --false:ASSERT (arity > 0)
uppBeside (uppPStr SLIT("fast")) (uppInt arity)
- ConEntry -> uppPStr SLIT("entry")
+ StaticClosure -> uppPStr SLIT("static_closure")
+ ConEntry -> uppPStr SLIT("con_entry")
+ ConInfoTbl -> uppPStr SLIT("con_info")
StaticConEntry -> uppPStr SLIT("static_entry")
StaticInfoTbl -> uppPStr SLIT("static_info")
PhantomInfoTbl -> uppPStr SLIT("inregs_info")
import Pretty
import Unpretty( uppChar )
+
+IMPORT_1_3(Char (isAlphanum))
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+chr = toEnum :: Int -> Char
+#endif
\end{code}
addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
SpARelOffset(..), SpBRelOffset(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
#if ! OMIT_NATIVE_CODEGEN
-import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords )
+IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords )
#endif
import Maybes ( catMaybes )
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- break its dependence on ClosureInfo
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo
import AbsCSyn
@pprAbsC@ has a new ``costs'' argument. %% HWL
\begin{code}
-writeRealC :: _FILE -> AbstractC -> IO ()
+writeRealC :: Handle -> AbstractC -> IO ()
-writeRealC file absC
- = uppAppendFile file 80 (
+writeRealC handle absC
+ = uppPutStr handle 80 (
uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n')
)
module FieldLabel where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-} )
import Type ( Type(..) )
getMentionedTyConsAndClassesFromId,
dataConTag, dataConStrictMarks,
- dataConSig, dataConArgTys,
+ dataConSig, dataConRawArgTys, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
-- PREDICATES
isDataCon, isTupleCon,
+ isNullaryDataCon,
isSpecId_maybe, isSpecPragmaId_maybe,
toplevelishId, externallyVisibleId,
isTopLevId, isWorkerId, isWrapperId,
GenIdSet(..), IdSet(..)
)-} where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
-mkMethodSelId u c op ty info
- = Id u n ty (MethodSelId c op) NoPragmaInfo info
+mkMethodSelId u rec_c op ty info
+ = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
where
- cname = getName c -- we get other info out of here
+ cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
-mkDefaultMethodId u c op gen ty info
- = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info
+mkDefaultMethodId u rec_c op gen ty info
+ = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
where
- cname = getName c -- we get other info out of here
+ cname = getName rec_c -- we get other info out of here
n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
Just i -> i
+isNullaryDataCon con = dataConArity con == 0 -- function of convenience
+
addIdArity :: Id -> Int -> Id
addIdArity (Id u n ty details pinfo info) arity
= Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
= nOfThem arity NotMarkedStrict
+dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
+dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
+
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-> [Type] -- Needs arguments of these types
cmp = cmpId
instance Eq (GenId ty) where
- a == b = case cmpId a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord (GenId ty) where
- a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
@cmpId_withSpecDataCon@ ensures that any spectys are taken into
) where
-import Ubiq
+IMP_Ubiq()
-import IdLoop -- IdInfo is a dependency-loop ranch, and
+IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
-- we break those loops by using IdLoop and
-- *not* importing much of anything else,
-- except from the very general "utils".
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
mkFormSummary = panic "IdInfo.mkFormSummary"
-occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
isWrapperFor = panic "IdInfo.isWrapperFor"
pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
\end{code}
the wrapper only; so under these circumstances we return \tr{False}.
\begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read Demand where
+#else
instance Text Demand where
+#endif
readList str = read_em [{-acc-}] str
where
read_em acc [] = [(reverse acc, "")]
read_em acc other = panic ("IdInfo.readem:"++other)
+#ifdef REALLY_HASKELL_1_3
+instance Show Demand where
+#endif
showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
where
show1 (WwLazy False) = "L"
\begin{code}
mkUnfolding guide expr
- = GenForm False (mkFormSummary NoStrictnessInfo expr)
+ = GenForm (mkFormSummary NoStrictnessInfo expr)
(occurAnalyseGlobalExpr expr)
guide
\end{code}
getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
= case unfolding of
- GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails
- unfolding_as_was -> unfolding_as_was
+ GenForm _ _ BadUnfolding -> NoUnfoldingDetails
+ unfolding_as_was -> unfolding_as_was
-- getInfo_UF ensures that any BadUnfoldings are never returned
-- We had to delay the test required in TcPragmas until now due
pp (MagicForm tag _)
= ppCat [ppPStr SLIT("_MF_"), ppPStr tag]
- pp (GenForm _ _ _ BadUnfolding) = pp_NONE
+ pp (GenForm _ _ BadUnfolding) = pp_NONE
- pp (GenForm _ _ template guide)
+ pp (GenForm _ template guide)
= let
untagged = unTagBinders template
in
Text instance so that the update annotations can be read in.
\begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read UpdateInfo where
+#else
instance Text UpdateInfo where
+#endif
readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
| otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
where
data FormSummary = WhnfForm | BottomForm | OtherForm
data UnfoldingDetails
= NoUnfoldingDetails
- | LitForm Literal
| OtherLitForm [Literal]
- | ConForm (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique]
| OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
- | GenForm Bool FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
+ | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
| MagicForm _PackedString MagicUnfoldingFun
data UnfoldingGuidance
module IdUtils ( primOpNameInfo, primOpId ) where
-import Ubiq
-import PrelLoop -- here for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( mkPreludeId )
+import Id ( mkPreludeId, mkTemplateLocals )
import IdInfo -- quite a few things
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
-import Type ( mkForAllTys, mkFunTys, applyTyCon )
+import Type ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
import Util ( panic )
\begin{code}
mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-mk_prim_unfold prim_op tvs arg_tys
- = panic "IdUtils.mk_prim_unfold"
-{-
+mk_prim_unfold prim_op tyvars arg_tys
= let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs)
- inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
- vars = mkTemplateLocals inst_arg_tys
+ vars = mkTemplateLocals arg_tys
in
- mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars])
--}
+ mkLam tyvars vars $
+ Prim prim_op
+ ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
literalType, literalPrimRep,
showLiteral,
isNoRepLit, isLitLitLit
-
- -- and to make the interface self-sufficient....
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import PrimRep ( PrimRep(..) ) -- non-abstract
-- others:
import CStrings ( stringToC, charToC, charToEasyHaskell )
-import TysWiredIn ( integerTy, rationalTy, stringTy )
+import TysWiredIn ( stringTy )
import Pretty -- pretty-printing stuff
import PprStyle ( PprStyle(..), codeStyle )
-import Util ( panic )
+import Util ( thenCmp, panic )
\end{code}
So-called @Literals@ are {\em either}:
PrimRep
| NoRepStr FAST_STRING -- the uncommitted ones
- | NoRepInteger Integer
- | NoRepRational Rational
+ | NoRepInteger Integer Type{-save what we learned in the typechecker-}
+ | NoRepRational Rational Type{-ditto-}
- deriving (Eq, Ord)
+ -- deriving (Eq, Ord): no, don't want to compare Types
-- The Ord is needed for the FiniteMap used in the lookForConstructor
-- in SimplEnv. If you declared that lookForConstructor *ignores*
-- constructor-applications with LitArg args, then you could get
mkMachInt x = MachInt x True{-signed-}
mkMachWord x = MachInt x False{-unsigned-}
+
+instance Ord3 Literal where
+ cmp (MachChar a) (MachChar b) = a `tcmp` b
+ cmp (MachStr a) (MachStr b) = a `tcmp` b
+ cmp (MachAddr a) (MachAddr b) = a `tcmp` b
+ cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
+ cmp (MachFloat a) (MachFloat b) = a `tcmp` b
+ cmp (MachDouble a) (MachDouble b) = a `tcmp` b
+ cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
+ cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b
+ cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b
+ cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
+
+ -- now we *know* the tags are different, so...
+ cmp other_1 other_2
+ | tag1 _LT_ tag2 = LT_
+ | otherwise = GT_
+ where
+ tag1 = tagof other_1
+ tag2 = tagof other_2
+
+ tagof (MachChar _) = ILIT(1)
+ tagof (MachStr _) = ILIT(2)
+ tagof (MachAddr _) = ILIT(3)
+ tagof (MachInt _ _) = ILIT(4)
+ tagof (MachFloat _) = ILIT(5)
+ tagof (MachDouble _) = ILIT(6)
+ tagof (MachLitLit _ _) = ILIT(7)
+ tagof (NoRepStr _) = ILIT(8)
+ tagof (NoRepInteger _ _) = ILIT(9)
+ tagof (NoRepRational _ _) = ILIT(10)
+
+tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+
+instance Eq Literal where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord Literal where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
-isNoRepLit (NoRepInteger _) = True
-isNoRepLit (NoRepRational _) = True
+isNoRepLit (NoRepInteger _ _) = True
+isNoRepLit (NoRepRational _ _) = True
isNoRepLit _ = False
isLitLitLit (MachLitLit _ _) = True
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
-literalType (NoRepInteger _) = integerTy
-literalType (NoRepRational _)= rationalTy
+literalType (NoRepInteger _ t) = t
+literalType (NoRepRational _ t) = t
literalType (NoRepStr _) = stringTy
\end{code}
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachLitLit _ k) = k
#ifdef DEBUG
-literalPrimRep (NoRepInteger _) = panic "literalPrimRep:NoRepInteger"
-literalPrimRep (NoRepRational _)= panic "literalPrimRep:NoRepRational"
-literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
+literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
+literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
+literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
#endif
\end{code}
ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
- ppr sty (NoRepInteger i)
+ ppr sty (NoRepInteger i _)
| codeStyle sty = ppInteger i
| ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
| otherwise = ppBesides [ppInteger i, ppChar 'I']
- ppr sty (NoRepRational r)
+ ppr sty (NoRepRational r _)
| ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
| codeStyle sty = panic "ppr.ForC.NoRepRational"
| otherwise = ppBesides [ppRational r, ppChar 'R']
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
-import Ubiq
+IMP_Ubiq()
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
%************************************************************************
-- lookupValVar, lookupTyVar, lookupUVar
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( Pretty(..) )
import Unique ( initRenumberingUniques )
module PragmaInfo where
-import Ubiq
+IMP_Ubiq()
\end{code}
\begin{code}
unpackSrcLoc
) where
-import Ubiq
+IMP_Ubiq()
import PprStyle ( PprStyle(..) )
import Pretty
splitUniqSupply
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Unique
import Util
addrDataConKey,
addrPrimTyConKey,
addrTyConKey,
+ andandIdKey,
appendIdKey,
arrayPrimTyConKey,
augmentIdKey,
byteArrayPrimTyConKey,
cCallableClassKey,
cReturnableClassKey,
- voidTyConKey,
charDataConKey,
charPrimTyConKey,
charTyConKey,
+ composeIdKey,
consDataConKey,
- evalClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
eqClassOpKey,
eqDataConKey,
errorIdKey,
+ evalClassKey,
falseDataConKey,
floatDataConKey,
floatPrimTyConKey,
floatingClassKey,
foldlIdKey,
foldrIdKey,
+ foreignObjDataConKey,
+ foreignObjPrimTyConKey,
+ foreignObjTyConKey,
forkIdKey,
fractionalClassKey,
fromIntClassOpKey,
fromIntegerClassOpKey,
fromRationalClassOpKey,
funTyConKey,
+ functorClassKey,
geClassOpKey,
gtDataConKey,
iOTyConKey,
integerTyConKey,
integerZeroIdKey,
integralClassKey,
+ irrefutPatErrorIdKey,
ixClassKey,
+ lexIdKey,
liftDataConKey,
liftTyConKey,
listTyConKey,
ltDataConKey,
mainIdKey,
mainPrimIOIdKey,
- foreignObjDataConKey,
- foreignObjPrimTyConKey,
- foreignObjTyConKey,
monadClassKey,
- monadZeroClassKey,
monadPlusClassKey,
- functorClassKey,
+ monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
nilDataConKey,
+ noDefaultMethodErrorIdKey,
+ nonExhaustiveGuardsErrorIdKey,
+ nonExplicitMethodErrorIdKey,
+ notIdKey,
numClassKey,
ordClassKey,
orderingTyConKey,
parErrorIdKey,
parIdKey,
patErrorIdKey,
- recConErrorIdKey,
- recUpdErrorIdKey,
- irrefutPatErrorIdKey,
- nonExhaustiveGuardsErrorIdKey,
- noDefaultMethodErrorIdKey,
- nonExplicitMethodErrorIdKey,
primIoTyConKey,
+ primIoDataConKey,
ratioDataConKey,
ratioTyConKey,
rationalTyConKey,
readClassKey,
+ readParenIdKey,
realClassKey,
realFloatClassKey,
realFracClassKey,
realWorldPrimIdKey,
realWorldTyConKey,
+ recConErrorIdKey,
+ recUpdErrorIdKey,
return2GMPsDataConKey,
return2GMPsTyConKey,
returnIntAndGMPDataConKey,
runSTIdKey,
seqIdKey,
showClassKey,
+ showParenIdKey,
+ showSpaceIdKey,
+ showStringIdKey,
stTyConKey,
+ stDataConKey,
stablePtrDataConKey,
stablePtrPrimTyConKey,
stablePtrTyConKey,
stateAndDoublePrimTyConKey,
stateAndFloatPrimDataConKey,
stateAndFloatPrimTyConKey,
- stateAndIntPrimDataConKey,
- stateAndIntPrimTyConKey,
stateAndForeignObjPrimDataConKey,
stateAndForeignObjPrimTyConKey,
+ stateAndIntPrimDataConKey,
+ stateAndIntPrimTyConKey,
stateAndMutableArrayPrimDataConKey,
stateAndMutableArrayPrimTyConKey,
stateAndMutableByteArrayPrimDataConKey,
stateDataConKey,
statePrimTyConKey,
stateTyConKey,
- stringTyConKey,
synchVarPrimTyConKey,
+ thenMClassOpKey,
traceIdKey,
trueDataConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
- voidPrimIdKey,
- voidPrimTyConKey,
+ ureadListIdKey,
+ ushowListIdKey,
+ voidIdKey,
+ voidTyConKey,
wordDataConKey,
wordPrimTyConKey,
- wordTyConKey
+ wordTyConKey,
+ zeroClassOpKey
, copyableIdKey
, noFollowIdKey
, parAtAbsIdKey
import PreludeGlaST
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty
import Util
instance Text Unique where
showsPrec p uniq rest = _UNPK_ (showUnique uniq)
- readsPrec p = panic "no readsPrec for Unique"
\end{code}
%************************************************************************
stateAndWordPrimTyConKey = mkPreludeTyConUnique 46
statePrimTyConKey = mkPreludeTyConUnique 47
stateTyConKey = mkPreludeTyConUnique 48
-stringTyConKey = mkPreludeTyConUnique 49
+ -- 49 is spare
stTyConKey = mkPreludeTyConUnique 50
primIoTyConKey = mkPreludeTyConUnique 51
-voidPrimTyConKey = mkPreludeTyConUnique 52
+ -- 52 is spare
wordPrimTyConKey = mkPreludeTyConUnique 53
wordTyConKey = mkPreludeTyConUnique 54
voidTyConKey = mkPreludeTyConUnique 55
stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29
stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30
stateAndIntPrimDataConKey = mkPreludeDataConUnique 31
-stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32
+stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32
stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33
stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35
stateDataConKey = mkPreludeDataConUnique 39
trueDataConKey = mkPreludeDataConUnique 40
wordDataConKey = mkPreludeDataConUnique 41
+stDataConKey = mkPreludeDataConUnique 42
+primIoDataConKey = mkPreludeDataConUnique 43
\end{code}
%************************************************************************
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
-appendIdKey = mkPreludeMiscIdUnique 2
-augmentIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-errorIdKey = mkPreludeMiscIdUnique 5
-foldlIdKey = mkPreludeMiscIdUnique 6
-foldrIdKey = mkPreludeMiscIdUnique 7
-forkIdKey = mkPreludeMiscIdUnique 8
-int2IntegerIdKey = mkPreludeMiscIdUnique 9
-integerMinusOneIdKey = mkPreludeMiscIdUnique 10
-integerPlusOneIdKey = mkPreludeMiscIdUnique 11
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
-integerZeroIdKey = mkPreludeMiscIdUnique 13
-packCStringIdKey = mkPreludeMiscIdUnique 14
-parErrorIdKey = mkPreludeMiscIdUnique 15
-parIdKey = mkPreludeMiscIdUnique 16
-patErrorIdKey = mkPreludeMiscIdUnique 17
-realWorldPrimIdKey = mkPreludeMiscIdUnique 18
-runSTIdKey = mkPreludeMiscIdUnique 19
-seqIdKey = mkPreludeMiscIdUnique 20
-traceIdKey = mkPreludeMiscIdUnique 21
-unpackCString2IdKey = mkPreludeMiscIdUnique 22
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 23
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
-unpackCStringIdKey = mkPreludeMiscIdUnique 25
-voidPrimIdKey = mkPreludeMiscIdUnique 26
-mainIdKey = mkPreludeMiscIdUnique 27
-mainPrimIOIdKey = mkPreludeMiscIdUnique 28
-recConErrorIdKey = mkPreludeMiscIdUnique 29
-recUpdErrorIdKey = mkPreludeMiscIdUnique 30
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
-noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33
-nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34
-
-copyableIdKey = mkPreludeMiscIdUnique 35
-noFollowIdKey = mkPreludeMiscIdUnique 36
-parAtAbsIdKey = mkPreludeMiscIdUnique 37
-parAtForNowIdKey = mkPreludeMiscIdUnique 38
-parAtIdKey = mkPreludeMiscIdUnique 39
-parAtRelIdKey = mkPreludeMiscIdUnique 40
-parGlobalIdKey = mkPreludeMiscIdUnique 41
-parLocalIdKey = mkPreludeMiscIdUnique 42
+andandIdKey = mkPreludeMiscIdUnique 2
+appendIdKey = mkPreludeMiscIdUnique 3
+augmentIdKey = mkPreludeMiscIdUnique 4
+buildIdKey = mkPreludeMiscIdUnique 5
+composeIdKey = mkPreludeMiscIdUnique 6
+errorIdKey = mkPreludeMiscIdUnique 7
+foldlIdKey = mkPreludeMiscIdUnique 8
+foldrIdKey = mkPreludeMiscIdUnique 9
+forkIdKey = mkPreludeMiscIdUnique 10
+int2IntegerIdKey = mkPreludeMiscIdUnique 11
+integerMinusOneIdKey = mkPreludeMiscIdUnique 12
+integerPlusOneIdKey = mkPreludeMiscIdUnique 13
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
+integerZeroIdKey = mkPreludeMiscIdUnique 15
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
+lexIdKey = mkPreludeMiscIdUnique 17
+mainIdKey = mkPreludeMiscIdUnique 18
+mainPrimIOIdKey = mkPreludeMiscIdUnique 19
+noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
+nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
+notIdKey = mkPreludeMiscIdUnique 23
+packCStringIdKey = mkPreludeMiscIdUnique 24
+parErrorIdKey = mkPreludeMiscIdUnique 25
+parIdKey = mkPreludeMiscIdUnique 26
+patErrorIdKey = mkPreludeMiscIdUnique 27
+readParenIdKey = mkPreludeMiscIdUnique 28
+realWorldPrimIdKey = mkPreludeMiscIdUnique 29
+recConErrorIdKey = mkPreludeMiscIdUnique 30
+recUpdErrorIdKey = mkPreludeMiscIdUnique 31
+runSTIdKey = mkPreludeMiscIdUnique 32
+seqIdKey = mkPreludeMiscIdUnique 33
+showParenIdKey = mkPreludeMiscIdUnique 34
+showSpaceIdKey = mkPreludeMiscIdUnique 35
+showStringIdKey = mkPreludeMiscIdUnique 36
+traceIdKey = mkPreludeMiscIdUnique 37
+unpackCString2IdKey = mkPreludeMiscIdUnique 38
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 39
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 40
+unpackCStringIdKey = mkPreludeMiscIdUnique 41
+voidIdKey = mkPreludeMiscIdUnique 42
+ushowListIdKey = mkPreludeMiscIdUnique 43
+ureadListIdKey = mkPreludeMiscIdUnique 44
+
+copyableIdKey = mkPreludeMiscIdUnique 45
+noFollowIdKey = mkPreludeMiscIdUnique 46
+parAtAbsIdKey = mkPreludeMiscIdUnique 47
+parAtForNowIdKey = mkPreludeMiscIdUnique 48
+parAtIdKey = mkPreludeMiscIdUnique 49
+parAtRelIdKey = mkPreludeMiscIdUnique 50
+parGlobalIdKey = mkPreludeMiscIdUnique 51
+parLocalIdKey = mkPreludeMiscIdUnique 52
\end{code}
Certain class operations from Prelude classes. They get
their own uniques so we can look them up easily when we want
to conjure them up during type checking.
\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 37
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 38
-fromRationalClassOpKey = mkPreludeMiscIdUnique 39
-enumFromClassOpKey = mkPreludeMiscIdUnique 40
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 41
-enumFromToClassOpKey = mkPreludeMiscIdUnique 42
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
-eqClassOpKey = mkPreludeMiscIdUnique 44
-geClassOpKey = mkPreludeMiscIdUnique 45
+fromIntClassOpKey = mkPreludeMiscIdUnique 53
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 54
+fromRationalClassOpKey = mkPreludeMiscIdUnique 55
+enumFromClassOpKey = mkPreludeMiscIdUnique 56
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 57
+enumFromToClassOpKey = mkPreludeMiscIdUnique 58
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59
+eqClassOpKey = mkPreludeMiscIdUnique 60
+geClassOpKey = mkPreludeMiscIdUnique 61
+zeroClassOpKey = mkPreludeMiscIdUnique 62
+thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
\end{code}
rebindToAStack, rebindToBStack
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
import AbsCSyn
import CgMonad
module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes )
import CgMonad
import StgSyn
import CgTailCall ( tailCallBusiness, performReturn )
import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel, mkClosureLabel
+ mkAltLabel
)
import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
where
lf_info = mkConLFInfo con
tag = dataConTag con
- closure_lbl = mkClosureLabel con
-- alloc_code generates code to allocate constructor con, whose args are
-- in the arguments to alloc_code, assigning the result to Node.
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, cgSccExpr )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr, cgSccExpr )
import CgMonad
import AbsCSyn
ViaNode | is_concurrent -> []
other -> panic "closureCodeBody:arg_regs"
- stk_args = drop (length arg_regs) all_args
+ num_arg_regs = length arg_regs
+
+ (reg_args, stk_args) = splitAt num_arg_regs all_args
+
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps
- bindArgsToRegs all_args arg_regs `thenC`
+ bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
`thenC`
returnFC amode
- closure_label = mkClosureLabel (closureId closure_info)
-
vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
spARelToInt,
spBRelToInt
-
- -- and to make the interface self-sufficient...
--- RegRelative
) where
-- This magical #include brings in all the everybody-knows-these magic
cgReturnDataCon
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
import CgHeapery ( allocDynClosure )
import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CLabel ( mkClosureLabel, mkInfoTableLabel,
- mkPhantomInfoTableLabel,
- mkConEntryLabel, mkStdEntryLabel
+import CLabel ( mkClosureLabel, mkStaticClosureLabel,
+ mkConInfoTableLabel, mkPhantomInfoTableLabel
)
import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
-- RETURN
returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = dataConTyCon con
- lf_info = mkConLFInfo con
-
- closure_label = mkClosureLabel name
- info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
+ closure_label = mkClosureLabel name
\end{code}
The general case is:
buildDynCon binder cc con args all_zero_size_args@True
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel con) PtrRep)
+ (CLbl (mkStaticClosureLabel con) PtrRep)
(mkConLFInfo con))
\end{code}
-- MAKE NODE POINT TO IT
let reg_assts = move_to_reg amode node
- info_lbl = mkInfoTableLabel con
+ info_lbl = mkConInfoTableLabel con
in
-- RETURN
module CgConTbls ( genStaticConBits ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import CgMonad
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabel ( mkConEntryLabel, mkClosureLabel,
+import CLabel ( mkConEntryLabel, mkStaticClosureLabel,
mkConUpdCodePtrVecLabel,
mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
)
import CostCentre ( dontCareCostCentre )
import FiniteMap ( fmToList )
import HeapOffs ( zeroOff, VirtualHeapOffset(..) )
-import Id ( dataConTag, dataConSig,
+import Id ( dataConTag, dataConRawArgTys,
dataConArity, fIRST_TAG,
emptyIdSet,
GenId{-instance NamedThing-}
zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
- (_,_,arg_tys,_) = dataConSig data_con
- con_arity = dataConArity data_con
- entry_label = mkConEntryLabel data_con
- closure_label = mkClosureLabel data_con
+ arg_tys = dataConRawArgTys data_con
+ con_arity = dataConArity data_con
+ entry_label = mkConEntryLabel data_con
+ closure_label = mkStaticClosureLabel data_con
\end{code}
The entry code for a constructor now loads the info ptr by indirecting
ReturnInHeap ->
let
- (_, _, arg_tys, _) = dataConSig con
+ arg_tys = dataConRawArgTys con
(closure_info, arg_things)
= layOutDynCon con typePrimRep arg_tys
module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where
-import Ubiq{-uitous-}
-import CgLoop2 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking
import StgSyn
import CgMonad
, heapCheckOnly, fetchAndReschedule, yield
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import CgMonad
module CgLetNoEscape ( cgLetNoEscapeClosure ) where
-import Ubiq{-uitious-}
-import CgLoop2 ( cgExpr )
+IMP_Ubiq(){-uitious-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr )
import StgSyn
import CgMonad
cgLetNoEscapeBody all_args rhs
= getVirtSps `thenFC` \ (vA, vB) ->
let
- arg_kinds = map idPrimRep all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
- stk_args = drop (length arg_regs) all_args
+ arg_kinds = map idPrimRep all_args
+ (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
+ (reg_args, stk_args) = splitAt (length arg_regs) all_args
-- stk_args is the args which are passed on the stack at the fast-entry point
-- Using them, we define the stack layout
in
-- Bind args to appropriate regs/stk locns
- bindArgsToRegs all_args arg_regs `thenC`
+ bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
CompilationInfo(..)
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- stuff from CgBindery and CgUsages
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
assignPrimOpResultRegs,
makePrimOpArgsRobust,
assignRegs
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- paranoia checking
import AbsCSyn -- quite a few things
import AbsCUtils ( mkAbstractCs, getAmodeRep,
mAX_Double_REG
)
import CmdLineOpts ( opt_ReturnInRegsThreshold )
-import Id ( isDataCon, dataConSig,
+import Id ( isDataCon, dataConRawArgTys,
DataCon(..), GenId{-instance Eq-}
)
import Maybes ( catMaybes )
[] -> ReturnInRegs reg_assignment
other -> ReturnInHeap -- Didn't fit in registers
where
- (_, _, arg_tys, _) = dataConSig data_con
+ arg_tys = dataConRawArgTys data_con
(reg_assignment, leftover_kinds)
= assignRegs [node, infoptr] -- taken...
mkVirtStkOffsets, mkStkAmodes
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
tailCallBusiness
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
module CgUpdate ( pushUpdateFrame ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CgMonad
import AbsCSyn
modify (\tr{set*} functions) the stacks and heap usage information.
\begin{code}
+#include "HsVersions.h"
+
module CgUsages (
initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp,
setRealAndVirtualSps,
freeBStkSlot
) where
-import Ubiq{-uitous-}
-import CgLoop1 -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking
import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode )
import CgMonad
dataConLiveness -- concurrency
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking
import AbsCSyn
import StgSyn
)
import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkConInfoTableLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
VirtualHeapOffset(..)
)
import Id ( idType, idPrimRep, getIdArity,
- externallyVisibleId, dataConSig,
+ externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, dataConArity, dataConTyCon,
+ isDataCon, isNullaryDataCon, dataConTyCon,
isTupleCon, DataCon(..),
GenId{-instance Eq-}
)
offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- (_,_,_, tycon) = dataConSig con
+ tycon = dataConTyCon con
\end{code}
Same kind of thing, looking for vector-apply thunks, of the form:
mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con
- = ASSERT(isDataCon con)
- let
- arity = dataConArity con
- in
- if isTupleCon con then
- LFTuple con (arity == 0)
- else
- LFCon con (arity == 0)
+ = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
+ (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
\end{code}
Int -- Its arity
[MagicId] -- Its register assignments (possibly empty)
-getEntryConvention :: Id -- Function being applied
- -> LambdaFormInfo -- Its info
+getEntryConvention :: Id -- Function being applied
+ -> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
-> FCode EntryConvention
-> let itbl = if zero_arity then
mkPhantomInfoTableLabel con
else
- mkInfoTableLabel con
- in StdEntry (mkStdEntryLabel con) (Just itbl)
- -- Should have no args
+ mkConInfoTableLabel con
+ in
+ --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel con) (Just itbl)
+
LFTuple tup zero_arity
- -> StdEntry (mkStdEntryLabel tup)
- (Just (mkInfoTableLabel tup))
- -- Should have no args
+ -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup))
LFThunk _ _ updatable std_form_info
-> if updatable
else -} mkInfoTableLabel id
mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel id
- StaticRep _ _ -> mkStaticInfoTableLabel id
- _ -> mkInfoTableLabel id
+mkConInfoPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ PhantomRep -> mkPhantomInfoTableLabel con
+ StaticRep _ _ -> mkStaticInfoTableLabel con
+ _ -> mkConInfoTableLabel con
mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel id
- _ -> mkConEntryLabel id
+mkConEntryPtr con rep
+ = ASSERT(isDataCon con)
+ case rep of
+ StaticRep _ _ -> mkStaticConEntryLabel con
+ _ -> mkConEntryLabel con
closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
module CodeGen ( codeGen ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import CgMonad
isIntLikeRep
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( ppStr )
import Util ( panic )
deAnnotate -- we may eventually export some of the other deAnners
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
\end{code}
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUtils ( coreExprType )
lintUnfolding
) where
-import Ubiq
+IMP_Ubiq()
import CoreSyn
import SrcLoc ( SrcLoc )
import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
getFunTyExpandingDicts_maybe,
+ getForAllTyExpandingDicts_maybe,
isPrimType,typeKind,instantiateTy,splitSigmaTy,
mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
maybeAppDataTyConExpandingDicts, eqTy
= -- ToDo: Check that ty is well-kinded and has no unbound tyvars
checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
`seqL`
- case (getForAllTy_maybe ty) of
+ case (getForAllTyExpandingDicts_maybe ty) of
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
Just (tyvar,body) ->
SimplifiableCoreArg(..),
SimplifiableCoreCaseAlts(..),
SimplifiableCoreCaseDefault(..)
-
- -- and to make the interface self-sufficient ...
-
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- ToDo:rm:
--import PprCore ( GenCoreExpr{-instance-} )
FormSummary(..),
mkFormSummary,
- mkGenForm,
+ mkGenForm, mkLitForm, mkConForm,
+ whnfDetails,
mkMagicUnfolding,
- modifyUnfoldingDetails,
calcUnfoldingGuidance,
mentionedInUnfolding
) where
-import Ubiq
-import IdLoop -- for paranoia checking;
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
-- and also to get mkMagicUnfoldingFun
-import PrelLoop -- for paranoia checking
+IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
import Bag ( emptyBag, unitBag, unionBags, Bag )
import BinderInfo ( oneTextualOcc, oneSafeOcc )
data UnfoldingDetails
= NoUnfoldingDetails
- | LitForm
- Literal
-
| OtherLitForm
[Literal] -- It is a literal, but definitely not one of these
- | ConForm
- Id -- The constructor
- [CoreArg] -- Type/value arguments; NB OutArgs, already cloned
-
| OtherConForm
[Id] -- It definitely isn't one of these constructors
-- This captures the situation in the default branch of
| GenForm
- Bool -- True <=> At most one textual occurrence of the
- -- binder in its scope, *or*
- -- if we are happy to duplicate this
- -- binding.
FormSummary -- Tells whether the template is a WHNF or bottom
TemplateOutExpr -- The template
UnfoldingGuidance -- Tells about the *size* of the template.
-- | manifestlyBottom expr = BottomForm
| otherwise = OtherForm
+
+whnfDetails :: UnfoldingDetails -> Bool -- True => thing is evaluated
+whnfDetails (GenForm WhnfForm _ _) = True
+whnfDetails (OtherLitForm _) = True
+whnfDetails (OtherConForm _) = True
+whnfDetails other = False
\end{code}
\begin{code}
%************************************************************************
%* *
-\subsection{@mkGenForm@ and @modifyUnfoldingDetails@}
+\subsection{@mkGenForm@ and friends}
%* *
%************************************************************************
\begin{code}
-mkGenForm :: Bool -- Ok to Dup code down different case branches,
- -- because of either a flag saying so,
- -- or alternatively the object is *SMALL*
- -> BinderInfo --
- -> FormSummary
+mkGenForm :: FormSummary
-> TemplateOutExpr -- Template
-> UnfoldingGuidance -- Tells about the *size* of the template.
-> UnfoldingDetails
-mkGenForm safe_to_dup occ_info WhnfForm template guidance
- = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance
-
-mkGenForm safe_to_dup occ_info form_summary template guidance
- | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences
- = GenForm True form_summary template guidance
-
- | otherwise -- Not a WHNF, many occurrences
- = NoUnfoldingDetails
-\end{code}
+mkGenForm = GenForm
-\begin{code}
-modifyUnfoldingDetails
- :: Bool -- OK to dup
- -> BinderInfo -- New occurrence info for the thing
- -> UnfoldingDetails
- -> UnfoldingDetails
+-- two shorthand variants:
+mkLitForm lit = mk_go_for_it (Lit lit)
+mkConForm con args = mk_go_for_it (Con con args)
-modifyUnfoldingDetails ok_to_dup occ_info
- (GenForm only_one form_summary template guidance)
- | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance
-
-modifyUnfoldingDetails ok_to_dup occ_info other = other
+mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways
\end{code}
-
%************************************************************************
%* *
\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
-} ) where
-import Ubiq
-import IdLoop -- for pananoia-checking purposes
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
import CoreSyn
import CostCentre ( isDictCC )
import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
+ toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, IdEnv(..),
GenId{-instances-}
import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
-import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
+import TyVar ( cloneTyVar,
+ isNullTyVarEnv, addOneToTyVarEnv, TyVarEnv(..)
+ )
import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
getFunTy_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
-dup_binder = panic "CoreUtils.dup_binder"
\end{code}
%************************************************************************
do_PrimOp other_op = returnUs other_op
-do_CoreExpr venv tenv (Lam binder expr)
+do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
= dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
let new_venv = addOneToIdEnv venv old new in
do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
- returnUs (Lam new_binder new_expr)
+ returnUs (Lam (ValBinder new_binder) new_expr)
+
+do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
+ = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
+ let
+ new_tenv = addOneToTyVarEnv tenv old new
+ in
+ do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
+ returnUs (Lam (TyBinder new_tyvar) new_expr)
+
+do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
do_CoreExpr venv tenv (App expr arg)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
\end{code}
+
+\begin{code}
+dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
+dup_tyvar tyvar
+ = getUnique `thenUs` \ uniq ->
+ let new_tyvar = cloneTyVar tyvar uniq in
+ returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
+
+-- same thing all over again --------------------
+
+dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
+dup_binder tenv b
+ = if (toplevelishId b) then
+ -- binder is "top-level-ish"; -- it should *NOT* be renamed
+ -- ToDo: it's unsavoury that we return something to heave in env
+ returnUs (b, (b, Var b))
+
+ else -- otherwise, the full business
+ getUnique `thenUs` \ uniq ->
+ let
+ new_b1 = mkIdWithNewUniq b uniq
+ new_b2 = applyTypeEnvToId tenv new_b1
+ in
+ returnUs (new_b2, (b, Var new_b2))
+\end{code}
FVInfo(..), LeakInfo(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn -- output
#endif
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CostCentre ( showCostCentre )
module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( HsBinds, HsExpr )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
module DsBinds ( dsBinds, dsInstBinds ) where
-import Ubiq
-import DsLoop -- break dsExpr-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn -- lots of things
hiding ( collectBinders{-also in CoreSyn-} )
module DsCCall ( dsCCall ) where
-import Ubiq
+IMP_Ubiq()
import CoreSyn
import Pretty
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy )
+import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType )
import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy )
import TysWiredIn ( getStatePairingConInfo,
realWorldStateTy, stateDataCon,
stringTy
)
import Util ( pprPanic, pprError, panic )
-
-maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
\end{code}
Desugaring of @ccall@s consists of adding some state manipulation,
module DsExpr ( dsExpr ) where
-import Ubiq
-import DsLoop -- partly to get dsBinds, partly to chk dsExpr
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr
-import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- Match, Qual, HsBinds, Stmt, PolyType )
+import HsSyn ( failureFreePat,
+ HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
+ Stmt(..), Match(..), Qual, HsBinds, PolyType,
+ GRHSsAndBinds
+ )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
- TypecheckedRecordBinds(..), TypecheckedPat(..)
+ TypecheckedRecordBinds(..), TypecheckedPat(..),
+ TypecheckedStmt(..)
)
import CoreSyn
import DsMonad
import DsCCall ( dsCCall )
+import DsHsSyn ( outPatType )
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
-import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID )
+import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId )
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import TyCon ( isDataTyCon, isNewTyCon )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
- getAppDataTyConExpandingDicts, getAppTyCon, applyTy
+ getAppDataTyConExpandingDicts, getAppTyCon, applyTy,
+ maybeBoxedPrimType
)
-import TysWiredIn ( mkTupleTy, unitTy, nilDataCon, consDataCon,
+import TysWiredIn ( mkTupleTy, voidTy, nilDataCon, consDataCon,
charDataCon, charTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
-maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
-
mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
\end{code}
-> pprError "ERROR: ``literal-literal'' not a single-constructor type: "
(ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty])
-dsExpr (HsLitOut (HsInt i) _)
- = returnDs (Lit (NoRepInteger i))
+dsExpr (HsLitOut (HsInt i) ty)
+ = returnDs (Lit (NoRepInteger i ty))
-dsExpr (HsLitOut (HsFrac r) _)
- = returnDs (Lit (NoRepRational r))
+dsExpr (HsLitOut (HsFrac r) ty)
+ = returnDs (Lit (NoRepRational r ty))
-- others where we know what to do:
dsExpr expr `thenDs` \ core_expr ->
returnDs ( mkCoLetsAny core_binds core_expr )
-dsExpr (HsDoOut stmts m_id mz_id src_loc)
+dsExpr (HsDoOut stmts then_id zero_id src_loc)
= putSrcLocDs src_loc $
- panic "dsExpr:HsDoOut"
+ dsDo then_id zero_id stmts
dsExpr (HsIf guard_expr then_expr else_expr src_loc)
= putSrcLocDs src_loc $
dsExpr then_expr `thenDs` \ core_then ->
dsExpr else_expr `thenDs` \ core_else ->
returnDs (mkCoreIfThenElse core_guard core_then core_else)
-
\end{code}
`thenDs` \ core_d_and_ms ->
(case num_of_d_and_ms of
- 0 -> returnDs cocon_unit -- unit
+ 0 -> returnDs (Var voidId)
1 -> returnDs (head core_d_and_ms) -- just a single Id
dsExpr (ClassDictLam dicts methods expr)
= dsExpr expr `thenDs` \ core_expr ->
case num_of_d_and_ms of
- 0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
+ 0 -> newSysLocalDs voidTy `thenDs` \ new_x ->
returnDs (mkValLam [new_x] core_expr)
1 -> -- no untupling
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
-cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh)
out_of_range_msg -- ditto
= " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
Nothing -> -- we're only saturating constructors and PrimOps
case getIdUnfolding v of
- GenForm _ _ the_unfolding EssentialUnfolding
+ GenForm _ the_unfolding EssentialUnfolding
-> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
_ -> apply_to_args (Var v) args
-- Apply result to remaining arguments
apply_to_args body' args
\end{code}
+
+Basically does the translation given in the Haskell~1.3 report:
+\begin{code}
+dsDo :: Id -- id for: (>>=) m
+ -> Id -- id for: zero m
+ -> [TypecheckedStmt]
+ -> DsM CoreExpr
+
+dsDo then_id zero_id (stmt:stmts)
+ = case stmt of
+ ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn
+
+ ExprStmtOut expr locn a b ->
+ do_expr expr locn `thenDs` \ expr2 ->
+ ds_rest `thenDs` \ rest ->
+ dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, VarArg rest]
+
+ LetStmt binds ->
+ dsBinds binds `thenDs` \ binds2 ->
+ ds_rest `thenDs` \ rest ->
+ returnDs (mkCoLetsAny binds2 rest)
+
+ BindStmtOut pat expr locn a b ->
+ do_expr expr locn `thenDs` \ expr2 ->
+ let
+ zero_expr = TyApp (HsVar zero_id) [b]
+ main_match
+ = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn))
+ the_matches
+ = if failureFreePat pat
+ then [main_match]
+ else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)]
+ in
+ matchWrapper DoBindMatch the_matches "`do' statement"
+ `thenDs` \ (binders, matching_code) ->
+ dsApp (HsVar then_id) [TyArg a, TyArg b,
+ VarArg expr2, VarArg (mkValLam binders matching_code)]
+ where
+ ds_rest = dsDo then_id zero_id stmts
+ do_expr expr locn = putSrcLocDs locn (dsExpr expr)
+
+#ifdef DEBUG
+dsDo then_expr zero_expr [] = panic "dsDo:[]"
+#endif
+\end{code}
module DsGRHSs ( dsGuarded, dsGRHSs ) where
-import Ubiq
-import DsLoop -- break dsExpr/dsBinds-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds )
module DsHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..),
Sig, HsExpr, GRHSsAndBinds, Match, HsLit )
\section[DsListComp]{Desugaring list comprehensions}
\begin{code}
+#include "HsVersions.h"
+
module DsListComp ( dsListComp ) where
-import Ubiq
-import DsLoop -- break dsExpr-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
import HsSyn ( Qual(..), HsExpr, HsBinds )
import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
DsMatchContext(..), DsMatchKind(..), pprDsWarnings
) where
-import Ubiq
+IMP_Ubiq()
import Bag ( emptyBag, snocBag, bagToList )
import CmdLineOpts ( opt_SccGroup )
| CaseMatch
| LambdaMatch
| PatBindMatch
+ | DoBindMatch
pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
pprDsWarnings sty warns
= ppHang (ppPStr SLIT("in a lambda abstraction:"))
4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+ pp_match DoBindMatch pats
+ = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
+ 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+
pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
\end{code}
showForErr
) where
-import Ubiq
-import DsLoop ( match, matchSimply )
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
-import PrelVals ( iRREFUT_PAT_ERROR_ID )
+import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
+import TysWiredIn ( voidTy )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
only boxed types can be let-bound, we just turn the fail into a function
for the primitive case:
\begin{verbatim}
- let fail.33 :: () -> Int#
+ let fail.33 :: Void -> Int#
fail.33 = \_ -> error "Help"
in
case x of
p1 -> ...
- p2 -> fail.33 ()
- p3 -> fail.33 ()
+ p2 -> fail.33 void
+ p3 -> fail.33 void
p4 -> ...
\end{verbatim}
-- applied to unit tuple
mkFailurePair ty
| isUnboxedType ty
- = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
- newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
+ = newFailLocalDs (mkFunTys [voidTy] ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs voidTy `thenDs` \ fail_fun_arg ->
returnDs (\ body ->
NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
- App (Var fail_fun_var) (VarArg unit_id))
+ App (Var fail_fun_var) (VarArg voidId))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
returnDs (\ body -> NonRec fail_var body, Var fail_var)
+\end{code}
+
-unit_id :: Id -- out here to avoid CAF (sigh)
-unit_id = mkTupleCon 0
-unit_ty :: Type
-unit_ty = idType unit_id
-\end{code}
module Match ( match, matchWrapper, matchSimply ) where
-import Ubiq
-import DsLoop -- here for paranoia-checking reasons
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
import MatchLit ( matchLiterals )
import FieldLabel ( allFieldLabelTags, fieldLabelTag )
-import Id ( idType, mkTupleCon, dataConSig,
+import Id ( idType, mkTupleCon,
dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy,
- doubleDataCon, integerTy, stringTy, addrTy,
+ doubleDataCon, stringTy, addrTy,
addrDataCon, wordTy, wordDataCon
)
import Unique ( Unique{-instance Eq-} )
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs)
- = if ( (unfailablePat p1 && unfailablePat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
+ = if ( (irrefutablePat p1 && irrefutablePat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
- | unfailablePat first_pat
- = ASSERT( unfailablePats column_1_pats ) -- Sanity check
+ | irrefutablePat first_pat
+ = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
-- Real true variables, just like in matchVar, SLPJ p 94
match vars remaining_eqns_info remaining_shadows
module MatchCon ( matchConFamily ) where
-import Ubiq
-import DsLoop ( match ) -- break match-ish loop
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) ( match ) -- break match-ish loop
import HsSyn ( OutPat(..), HsLit, HsExpr )
import DsHsSyn ( outPatType )
module MatchLit ( matchLiterals ) where
-import Ubiq
-import DsLoop -- break match-ish and dsExpr-ish loops
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
> then no_unfold
>
> else case (getIdUnfolding id) of
-> GenForm _ _ expr guidance ->
+> GenForm _ expr guidance ->
> panic "DefExpr:GenForm has changed a little; needs mod here"
> -- SLPJ March 95
>
module HsBinds where
-import Ubiq
+IMP_Ubiq()
-- friends:
-import HsLoop
+IMPORT_DELOOPER(HsLoop)
import HsMatches ( pprMatches, pprGRHSsAndBinds,
Match, GRHSsAndBinds )
import HsPat ( collectPatBinders, InPat )
UnfoldingPrimOp(..), UfCostCentre(..)
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsTypes ( MonoType, PolyType )
module HsDecls where
-import Ubiq
+IMP_Ubiq()
-- friends:
-import HsLoop ( nullMonoBinds, MonoBinds, Sig )
+IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas
)
module HsExpr where
-import Ubiq{-uitous-}
-import HsLoop -- for paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(HsLoop) -- for paranoia checking
-- friends:
import HsBinds ( HsBinds )
| HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
- id id -- Monad and MonadZero dicts
+ | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
+ id -- id for >>=, types applied
+ id -- id for zero, typed applied
SrcLoc
| ListComp (HsExpr tyvar uvar id pat) -- list comprehension
ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)]
pprExpr sty (HsDo stmts _)
- = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
pprExpr sty (HsDoOut stmts _ _ _)
- = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
pprExpr sty (ListComp expr quals)
= ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
- 4 (ppBeside (ppr sty sig) ppRparen)
+ = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::")))
+ 4 (ppr sty sig)
pprExpr sty (ArithSeqIn info)
= ppBracket (ppr sty info)
| ExprStmt (HsExpr tyvar uvar id pat)
SrcLoc
| LetStmt (HsBinds tyvar uvar id pat)
+
+ -- Translations; the types are the "a" and "b" types of the monad.
+ | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
+ | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
\end{code}
\begin{code}
= ppCat [ppPStr SLIT("let"), ppr sty binds]
ppr sty (ExprStmt expr _)
= ppr sty expr
+ ppr sty (BindStmtOut pat expr _ _ _)
+ = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+ ppr sty (ExprStmtOut expr _ _ _)
+ = ppr sty expr
\end{code}
%************************************************************************
module HsImpExp where
-import Ubiq
+IMP_Ubiq()
+import Name ( pprNonSym )
import Outputable
import PprStyle ( PprStyle(..) )
import Pretty
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (ImportDecl name) where
+instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where
ppr sty (ImportDecl mod qual as spec _)
- = ppHang (ppCat [ppStr "import", pp_qual qual, ppPStr mod, pp_as as])
+ = ppHang (ppCat [ppPStr SLIT("import"), pp_qual qual, ppPStr mod, pp_as as])
4 (pp_spec spec)
where
pp_qual False = ppNil
- pp_qual True = ppStr "qualified"
+ pp_qual True = ppPStr SLIT("qualified")
pp_as Nothing = ppNil
- pp_as (Just a) = ppCat [ppStr "as", ppPStr a]
+ pp_as (Just a) = ppBeside (ppPStr SLIT("as ")) (ppPStr a)
pp_spec Nothing = ppNil
pp_spec (Just (False, spec))
- = ppBesides [ppStr "(", interpp'SP sty spec, ppStr ")"]
+ = ppParens (interpp'SP sty spec)
pp_spec (Just (True, spec))
- = ppBesides [ppStr "hiding (", interpp'SP sty spec, ppStr ")"]
-
+ = ppBeside (ppPStr SLIT("hiding ")) (ppParens (interpp'SP sty spec))
\end{code}
%************************************************************************
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (IE name) where
- ppr sty (IEVar var) = ppr sty var
+instance (NamedThing name, Outputable name) => Outputable (IE name) where
+ ppr sty (IEVar var) = pprNonSym sty var
ppr sty (IEThingAbs thing) = ppr sty thing
ppr sty (IEThingAll thing)
= ppBesides [ppr sty thing, ppStr "(..)"]
ppr sty (IEThingWith thing withs)
- = ppBesides [ppr sty thing, ppLparen, ppInterleave ppComma (map (ppr sty) withs), ppRparen]
+ = ppBeside (ppr sty thing)
+ (ppParens (ppInterleave ppComma (map (pprNonSym sty) withs)))
ppr sty (IEModuleContents mod)
= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
\end{code}
module HsLit where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(Rational))
import Pretty
\end{code}
module HsMatches where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import HsLoop ( HsExpr, nullBinds, HsBinds )
+IMPORT_DELOOPER(HsLoop) ( HsExpr, nullBinds, HsBinds )
import Outputable ( ifPprShowAll )
import PprType ( GenType{-instance Outputable-} )
import Pretty
InPat(..),
OutPat(..),
- unfailablePats, unfailablePat,
+ irrefutablePat, irrefutablePats,
+ failureFreePat,
patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
- irrefutablePat,
collectPatBinders
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsLit ( HsLit )
-import HsLoop ( HsExpr )
+IMPORT_DELOOPER(HsLoop) ( HsExpr )
-- others:
-import Id ( GenId, dataConSig )
+import Id ( dataConTyCon, GenId )
import Maybes ( maybeToBool )
import Name ( pprSym, pprNonSym )
import Outputable ( interppSP, interpp'SP, ifPprShowAll )
A pattern is in {\em exactly one} of the above three categories; `as'
patterns are treated specially, of course.
+The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
-unfailablePats :: [OutPat a b c] -> Bool
-unfailablePats pat_list = all unfailablePat pat_list
-
-unfailablePat (AsPat _ pat) = unfailablePat pat
-unfailablePat (WildPat _) = True
-unfailablePat (VarPat _) = True
-unfailablePat (LazyPat _) = True
-unfailablePat (DictPat ds ms) = (length ds + length ms) <= 1
-unfailablePat other = False
+irrefutablePats :: [OutPat a b c] -> Bool
+irrefutablePats pat_list = all irrefutablePat pat_list
+
+irrefutablePat (AsPat _ pat) = irrefutablePat pat
+irrefutablePat (WildPat _) = True
+irrefutablePat (VarPat _) = True
+irrefutablePat (LazyPat _) = True
+irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
+irrefutablePat other = False
+
+failureFreePat :: OutPat a b c -> Bool
+
+failureFreePat (WildPat _) = True
+failureFreePat (VarPat _) = True
+failureFreePat (LazyPat _) = True
+failureFreePat (AsPat _ pat) = failureFreePat pat
+failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats
+failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
+failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
+failureFreePat (ListPat _ _) = False
+failureFreePat (TuplePat pats) = all failureFreePat pats
+failureFreePat (DictPat _ _) = True
+failureFreePat other_pat = False -- Literals, NPat
+
+only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
+\end{code}
+\begin{code}
patsAreAllCons :: [OutPat a b c] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
isLitPat other = False
\end{code}
-A pattern is irrefutable if a match on it cannot fail
-(at any depth).
-\begin{code}
-irrefutablePat :: OutPat a b c -> Bool
-
-irrefutablePat (WildPat _) = True
-irrefutablePat (VarPat _) = True
-irrefutablePat (LazyPat _) = True
-irrefutablePat (AsPat _ pat) = irrefutablePat pat
-irrefutablePat (ConPat con tys pats) = only_con con && all irrefutablePat pats
-irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1
-irrefutablePat (RecPat con _ fields) = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ]
-irrefutablePat (ListPat _ _) = False
-irrefutablePat (TuplePat pats) = all irrefutablePat pats
-irrefutablePat (DictPat _ _) = True
-irrefutablePat other_pat = False -- Literals, NPat
-
-only_con con = maybeToBool (maybeTyConSingleCon tycon)
- where
- (_,_,_,tycon) = dataConSig con
-\end{code}
-
This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc. The order in which the binders are
collected is important; see @HsBinds.lhs@.
module HsPragmas where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsCore ( UnfoldingCoreExpr )
) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import HsBinds
) where
#ifdef COMPILING_GHC
-import Ubiq
+IMP_Ubiq()
import Outputable ( interppSP, ifnotPprForUser )
import Pretty
ghcExit
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( bagToList )
import PprStyle ( PprStyle(..) )
module Main ( main ) where
-import Ubiq{-uitous-}
-
-import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
+IMP_Ubiq(){-uitous-}
import HsSyn
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
import TcInstUtil ( InstInfo )
+import TyCon ( isDataTyCon )
import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >>
-- ******* READER
show_pass "Reader" >>
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
- interface_stuff,
- (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
+ interface_stuff@(_,local_tycons,_,_),
+ pragma_tycon_specs, ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppAboves [
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
show_pass "Core2Core" >>
_scc_ "Core2Core"
+ let
+ local_data_tycons = filter isDataTyCon local_tycons
+ in
core2core core_cmds mod_name pprStyle
- sm_uniqs local_tycons pragma_tycon_specs desugared
+ sm_uniqs local_data_tycons pragma_tycon_specs desugared
>>=
\ (simplified, inlinings_env,
= case switch of
Nothing -> return ()
Just fname ->
- fopen fname "a+" `thenPrimIO` \ file ->
- if (file == ``NULL'') then
- error ("doOutput: failed to open:"++fname)
- else
- io_action file >>= \ () ->
- fclose file `thenPrimIO` \ status ->
- if status == 0
- then return ()
- else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+ openFile fname WriteMode >>= \ handle ->
+ io_action handle >>
+ hClose handle
doDump switch hdr string
= if switch
ifacePragmas
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( emptyBag, snocBag, bagToList )
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
import FiniteMap ( fmToList )
import HsSyn
-import Id ( idType, dataConSig, dataConFieldLabels,
+import Id ( idType, dataConRawArgTys, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
pp = prettyToUn (ppr PprInterface on)
in
(if isLexSym s then uppParens else id) pp
+{-OLD:
ppr_unq_name n
= let
on = origName n
pp = uppPStr s
in
(if isLexSym s then uppParens else id) pp
+-}
\end{code}
We have a function @startIface@ to open the output file and put
upp_versions (fmToList versions), uppSemi]
upp_versions nvs
- = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
+ = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
ifaceDecls Nothing{-no iface handle-} _ = return ()
ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
- = let
- togo_classes = [ c | c <- classes, isLocallyDefined c ]
- togo_tycons = [ t | t <- tycons, isLocallyDefined t ]
- togo_vals = [ v | v <- vals, isLocallyDefined v ]
-
- sorted_classes = sortLt ltLexical togo_classes
- sorted_tycons = sortLt ltLexical togo_tycons
- sorted_vals = sortLt ltLexical togo_vals
+ = ASSERT(all isLocallyDefined vals)
+ ASSERT(all isLocallyDefined tycons)
+ ASSERT(all isLocallyDefined classes)
+ let
+ sorted_classes = sortLt ltLexical classes
+ sorted_tycons = sortLt ltLexical tycons
+ sorted_vals = sortLt ltLexical vals
in
if (null sorted_classes && null sorted_tycons && null sorted_vals) then
-- You could have a module with just instances in it
ppr_tc (initNmbr (nmbrTyCon tycon))
------------------------
-ppr_tc (PrimTyCon _ n _)
+ppr_tc (PrimTyCon _ n _ _)
= uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
ppr_tc FunTyCon
ppr_context ctxt,
ppr_name n,
uppIntersperse uppSP (map ppr_tyvar tvs),
- pp_unabstract_condecls,
+ uppEquals, pp_condecls,
uppSemi]
-- NB: we do not print deriving info in interfaces
where
uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
uppRparen, uppPStr SLIT(" =>")]
- yes_we_print_condecls
- = case (getExportFlag n) of
- ExportAbs -> False
- other -> True
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then uppCat [uppEquals, pp_condecls]
- else uppNil
-
pp_condecls
= let
(c:cs) = cons
ppr_con con
= let
- (_, _, con_arg_tys, _) = dataConSig con
+ con_arg_tys = dataConRawArgTys con
labels = dataConFieldLabels con -- none if not a record
strict_marks = dataConStrictMarks con
in
- uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
+ uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
ppr_fields labels strict_marks con_arg_tys
= if null labels then -- not a record thingy
(prettyToUn (pprParendType PprInterface t))
ppr_field l b t
- = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "),
+ = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
ppr_ty t]
\end{code}
module AbsCStixGen ( genCodeAbstractC ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn
import Stix
import StixPrim ( primCode, amodeToStix, amodeToStix' )
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
import Util ( naturalMergeSortLe, panic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
For each independent chunk of AbstractC code, we generate a list of
module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachMisc
import MachRegs
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
import UniqSupply ( returnUs, thenUs, mapUs, UniqSM(..) )
-import Unpretty ( uppAppendFile, uppShow, uppAboves, Unpretty(..) )
+import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) )
\end{code}
The 96/03 native-code generator has machine-independent and
So, here we go:
\begin{code}
-writeRealAsm :: _FILE -> AbstractC -> UniqSupply -> IO ()
+writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO ()
-writeRealAsm file absC us
- = uppAppendFile file 80 (runNCG absC us)
+writeRealAsm handle absC us
+ = uppPutStr handle 80 (runNCG absC us)
dumpRealAsm :: AbstractC -> UniqSupply -> String
module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachCode ( InstrList(..) )
import MachMisc ( Instr )
import MachRegs
import RegAllocInfo
+import AbsCSyn ( MagicId )
import BitSet ( BitSet )
import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM )
import Maybes ( maybeToBool )
module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import MachMisc -- may differ per-platform
import MachRegs
#endif
) where
-import Ubiq{-uitous-}
-import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
-import NcgLoop ( underscorePrefix, fmtAsmLbl ) -- paranoia
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia
+IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
#endif
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
cmp_ihash :: FAST_INT -> FAST_INT -> TAG_
cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_
+instance Ord3 Reg where
+ cmp = cmpReg
+
instance Eq Reg where
- a == b = case cmpReg a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpReg a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord Reg where
- a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
instance Uniquable Reg where
uniqueOf (UnmappedReg u _) = u
module PprMach ( pprInstr ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import MachRegs -- may differ per-platform
import MachMisc
+import AbsCSyn ( MagicId )
import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CStrings ( charToC )
import Maybes ( maybeToBool )
#endif
#if sparc_TARGET_ARCH
B -> SLIT("sb")
+ BU -> SLIT("ub")
-- HW -> SLIT("hw") UNUSED
--- BU -> SLIT("ub") UNUSED
-- HWU -> SLIT("uhw") UNUSED
W -> SLIT("")
F -> SLIT("")
freeRegSet
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import MachMisc
import MachRegs
import MachCode ( InstrList(..) )
+import AbsCSyn ( MagicId )
import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet )
import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM )
getUniqLabelNCG
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AbsCSyn ( node, infoptr, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
module StixInfo ( genCodeInfoTable ) where
-import Ubiq{-uitious-}
+IMP_Ubiq(){-uitious-}
import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo,
RegRelative, MagicId, CStmtMacro
encodeFloatingKind, decodeFloatingKind
) where
-import Ubiq{-uitous-}
-import NcgLoop ( amodeToStix )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
import MachRegs
module StixMacro ( macroCode, heapCheck ) where
-import Ubiq{-uitious-}
-import NcgLoop ( amodeToStix )
+IMP_Ubiq(){-uitious-}
+IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
import MachMisc
import MachRegs
module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
-import Ubiq{-uitous-}
-import NcgLoop -- paranoia checking only
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
import MachMisc
import MachRegs
import UniqSupply ( returnUs, thenUs, UniqSM(..) )
import Unpretty ( uppBeside, uppPStr, uppInt )
import Util ( panic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
The main honcho here is primCode, which handles the guts of COpStmts.
Stuff the Ugenny things show to the parser.
\begin{code}
+#include "HsVersions.h"
+
module UgenAll (
-- re-exported Prelude stuff
returnUgn, thenUgn,
import PreludeGlaST
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import U_binding
import PreludeGlaST
-import Ubiq
+IMP_Ubiq()
import Name ( RdrName(..) )
import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc )
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_binding where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_constr where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_maybe
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_either where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type either;
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_entidt where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
H [0-9A-Fa-f]
N {D}+
F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
-S [!#$%&*+./<=>?@\\^|-~:\xa1-\xbf\xd7\xf7]
+S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7]
SId {S}{S}*
L [A-Z\xc0-\xd6\xd8-\xde]
l [a-z\xdf-\xf6\xf8-\xff]
PUSH_STATE(UserPragma);
RETURN(DEFOREST_UPRAGMA);
}
+<Code,GlaExt>"{-#"{WS}*"GENERATE_SPECS" {
+ /* these are handled by hscpp */
+ nested_comments =1;
+ PUSH_STATE(Comment);
+ }
<Code,GlaExt>"{-#"{WS}*[A-Z_]+ {
- fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
+ fprintf(stderr, "\"%s\", line %d: Warning: Unrecognised pragma '",
input_filename, hsplineno);
format_string(stderr, (unsigned char *) yytext, yyleng);
fputs("'\n", stderr);
This allows unnamed sources to be piped into the parser.
*/
-extern BOOLEAN acceptPrim;
-
void
yyinit(void)
{
setyyin _before_ calling yylex for the first time! */
yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
- if (acceptPrim)
+ if (nonstandardFlag)
PUSH_STATE(GlaExt);
else
PUSH_STATE(Code);
qvarid qconid qvarsym qconsym
qvar qcon qvarop qconop qop
qvark qconk qtycon qtycls
- gcon gconk gtycon qop1 qvarop1
+ gcon gconk gtycon itycon qop1 qvarop1
ename iname
%type <ubinding> topdecl topdecls letdecls
;
import : var { $$ = mkentid(mknoqual($1)); }
- | tycon { $$ = mkenttype(mknoqual($1)); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall(mknoqual($1)); }
- | tycon OPAREN CPAREN { $$ = mkenttypenamed(mknoqual($1),Lnil); }
- | tycon OPAREN inames CPAREN { $$ = mkenttypenamed(mknoqual($1),$3); }
+ | itycon { $$ = mkenttype($1); }
+ | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
+ | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);}
+ | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); }
+ ;
+
+itycon : tycon { $$ = mknoqual($1); }
+ | OBRACK CBRACK { $$ = creategid(-1); }
+ | OPAREN CPAREN { $$ = creategid(0); }
+ | OPAREN commas CPAREN { $$ = creategid($2); }
;
inames : iname { $$ = lsing($1); }
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_list where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type list;
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_literal where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type literal;
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_maybe where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type maybe;
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_pbinding where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr ( U_constr ) -- interface only
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_qid where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
%}}
type qid;
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_tree where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_constr ( U_constr ) -- interface only
#include "hspincl.h"
%}
%{{
+#include "HsVersions.h"
+
module U_ttype where
-import Ubiq -- debugging consistency check
+IMP_Ubiq() -- debugging consistency check
import UgenUtil
import U_list
#include "constants.h"
#include "utils.h"
-#define PARSER_VERSION "1.3-???"
+#define PARSER_VERSION "2.01 (Haskell 1.3)"
tree root; /* The root of the built syntax tree. */
list Lnil;
BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */
-BOOLEAN acceptPrim = FALSE; /* Set if Int#, etc., may be used */
BOOLEAN haskell1_2Flag = FALSE; /* Set if we are compiling for 1.2 */
BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */
BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */
BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */
-static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
-
-/* Forward decls */
-static void who_am_i PROTO((void));
-
/**********************************************************************
* *
* *
{
BOOLEAN keep_munging_option = FALSE;
- argc--, argv++;
-
while (argc > 0 && argv[0][0] == '-') {
keep_munging_option = TRUE;
while (keep_munging_option && *++*argv != '\0') {
switch(**argv) {
- case 'v':
- who_am_i(); /* identify myself */
- verbose = TRUE;
- break;
-
case 'N':
nonstandardFlag = TRUE;
- acceptPrim = TRUE;
break;
case '2':
fprintf(stderr, "Cannot open %s.\n", argv[1]);
exit(1);
}
-
- if (verbose) {
- fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
- if(acceptPrim)
- fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
- }
}
void
exit(1);
}
-static void
-who_am_i(void)
-{
- fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
-}
-
list
lconc(l1, l2)
list l1;
extern BOOLEAN nonstandardFlag;
extern BOOLEAN hashIds;
-extern BOOLEAN acceptPrim;
extern BOOLEAN etags;
extern BOOLEAN ignoreSCC;
maybeCharLikeTyCon, maybeIntLikeTyCon
) where
-import Ubiq
-import PrelLoop ( primOpNameInfo )
+IMP_Ubiq()
+IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
-- friends:
import PrelMods -- Prelude module names
-- tycons
map pcTyConWiredInInfo prim_tycons,
map pcTyConWiredInInfo g_tycons,
- map pcTyConWiredInInfo data_tycons,
- map pcTyConWiredInInfo synonym_tycons
+ map pcTyConWiredInInfo data_tycons
]
assoc_keys
min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
= [ boolTyCon
- , orderingTyCon
, charTyCon
, intTyCon
, floatTyCon
, doubleTyCon
, integerTyCon
- , ratioTyCon
, liftTyCon
, return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
, returnIntAndGMPTyCon
= [ addrTyCon
, boolTyCon
, charTyCon
- , orderingTyCon
, doubleTyCon
, floatTyCon
+ , foreignObjTyCon
, intTyCon
, integerTyCon
, liftTyCon
- , foreignObjTyCon
- , ratioTyCon
+ , primIoTyCon
, return2GMPsTyCon
, returnIntAndGMPTyCon
+ , stTyCon
, stablePtrTyCon
, stateAndAddrPrimTyCon
, stateAndArrayPrimTyCon
, stateAndCharPrimTyCon
, stateAndDoublePrimTyCon
, stateAndFloatPrimTyCon
- , stateAndIntPrimTyCon
, stateAndForeignObjPrimTyCon
+ , stateAndIntPrimTyCon
, stateAndMutableArrayPrimTyCon
, stateAndMutableByteArrayPrimTyCon
- , stateAndSynchVarPrimTyCon
, stateAndPtrPrimTyCon
, stateAndStablePtrPrimTyCon
+ , stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
, stateTyCon
, wordTyCon
]
-
-synonym_tycons
- = [ primIoTyCon
- , rationalTyCon
- , stTyCon
- , stringTyCon
- ]
\end{code}
The WiredIn Ids ...
\begin{code}
id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)]
id_keys_infos
- = [ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing)
+ = [ -- here so we can check the type of main/mainPrimIO
+ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing)
, ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing)
+
+ -- here because we use them in derived instances
+ , ((SLIT("&&"), pRELUDE), andandIdKey, Nothing)
+ , ((SLIT("."), pRELUDE), composeIdKey, Nothing)
+ , ((SLIT("lex"), pRELUDE), lexIdKey, Nothing)
+ , ((SLIT("not"), pRELUDE), notIdKey, Nothing)
+ , ((SLIT("readParen"), pRELUDE), readParenIdKey, Nothing)
+ , ((SLIT("showParen"), pRELUDE), showParenIdKey, Nothing)
+ , ((SLIT("showString"), pRELUDE), showStringIdKey,Nothing)
+ , ((SLIT("__readList"), pRELUDE), ureadListIdKey, Nothing)
+ , ((SLIT("__showList"), pRELUDE), ushowListIdKey, Nothing)
+ , ((SLIT("__showSpace"), pRELUDE), showSpaceIdKey, Nothing)
]
tysyn_keys
- = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon))
+ = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon))
+ , ((SLIT("Rational"),rATIO), (rationalTyConKey, RnImplicitTyCon))
+ , ((SLIT("Ratio"),rATIO), (ratioTyConKey, RnImplicitTyCon))
+ , ((SLIT("Ordering"),pRELUDE), (orderingTyConKey, RnImplicitTyCon))
]
-- this "class_keys" list *must* include:
, ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey)
, ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey)
, ((SLIT("Functor"),pRELUDE), functorClassKey)
- , ((SLIT("CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish
- , ((SLIT("CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish
+ , ((SLIT("_CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish
+ , ((SLIT("_CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish
]]
class_op_keys
, ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey)
, ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey)
, ((SLIT("=="),pRELUDE), eqClassOpKey)
+ , ((SLIT(">>="),pRELUDE), thenMClassOpKey)
+ , ((SLIT("zero"),pRELUDE), zeroClassOpKey)
]]
\end{code}
fromPrelude :: FAST_STRING -> Bool
fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
+ where
+ substr str beg end
+ = take (end - beg + 1) (drop beg str)
\end{code}
module PrelVals where
-import Ubiq
-import IdLoop ( UnfoldingGuidance(..) )
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) )
import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
-import PrelLoop
+IMPORT_DELOOPER(PrelLoop)
-- friends:
import PrelMods
import Literal ( mkMachInt )
import PrimOp ( PrimOp(..) )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
-import TyVar ( alphaTyVar, betaTyVar, gammaTyVar )
+import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
\end{code}
(mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
errorTy :: Type
-errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
\end{code}
We want \tr{_trace} (NB: name not in user namespace) to be wired in
%************************************************************************
%* *
-\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@}
+\subsection[PrelVals-void]{@void@: Magic value of type @Void@}
%* *
%************************************************************************
-I don't think this is available to the user; it's used in the
-simplifier (WDP 94/06).
\begin{code}
-voidPrimId
- = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#")
- voidPrimTy noIdInfo
+voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo
\end{code}
%************************************************************************
pprPrimOp, showPrimOp
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PrimRep -- most of it
import TysPrim
import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize )
-import PprStyle ( codeStyle )
+import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
= AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
+
+primOpInfo CopyableOp -- copyable# :: a -> a
+ = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+
+primOpInfo NoFollowOp -- noFollow# :: a -> a
+ = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
\end{code}
%************************************************************************
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = _trace "PrimOp.getAppDataTyConExpandingDicts" $
+ (result_tycon, tys_applied, _) = -- _trace "PrimOp.getAppDataTyConExpandingDicts" $
getAppDataTyConExpandingDicts result_ty
+
+#ifdef DEBUG
+primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))
+#endif
\end{code}
%************************************************************************
guessPrimRep
) where
-import Ubiq
+IMP_Ubiq()
import Pretty -- pretty-printing code
import Util
-- (Primitive states are mapped onto this)
deriving (Eq, Ord)
-- Kinds are used in PrimTyCons, which need both Eq and Ord
- -- Text is needed for derived-Text on PrimitiveOps
\end{code}
%************************************************************************
module TysPrim where
-import Ubiq
+IMP_Ubiq(){-uitous-}
-import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind )
+import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
\begin{code}
-- only used herein
-pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING
- -> Int -> ([PrimRep] -> PrimRep) -> TyCon
-pcPrimTyCon key str arity{-UNUSED-} kind_fn{-UNUSED-}
- = mkPrimTyCon name mkUnboxedTypeKind
+pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon
+
+pcPrimTyCon key str arity primrep
+ = mkPrimTyCon name (mk_kind arity) primrep
where
name = mkBuiltinName key pRELUDE_BUILTIN str
+ mk_kind 0 = mkUnboxedTypeKind
+ mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
+
charPrimTy = applyTyCon charPrimTyCon []
-charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharRep)
+charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep
intPrimTy = applyTyCon intPrimTyCon []
-intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntRep)
+intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 IntRep
wordPrimTy = applyTyCon wordPrimTyCon []
-wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordRep)
+wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 WordRep
addrPrimTy = applyTyCon addrPrimTyCon []
-addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrRep)
+addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 AddrRep
floatPrimTy = applyTyCon floatPrimTyCon []
-floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatRep)
+floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 FloatRep
doublePrimTy = applyTyCon doublePrimTyCon []
-doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleRep)
+doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep
\end{code}
@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need
%************************************************************************
%* *
-\subsection[TysPrim-void]{The @Void#@ type}
+\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}
%* *
%************************************************************************
-Very similar to the @State#@ type.
-\begin{code}
-voidPrimTy = applyTyCon voidPrimTyCon []
- where
- voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0
- (\ [] -> VoidRep)
-\end{code}
+State# is the primitive, unboxed type of states. It has one type parameter,
+thus
+ State# RealWorld
+or
+ State# s
-%************************************************************************
-%* *
-\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)}
-%* *
-%************************************************************************
+where s is a type variable. The only purpose of the type parameter is to
+keep different state threads separate. It is represented by nothing at all.
\begin{code}
mkStatePrimTy ty = applyTyCon statePrimTyCon [ty]
-statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1
- (\ [s_kind] -> VoidRep)
+statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 VoidRep
\end{code}
@_RealWorld@ is deeply magical. It {\em is primitive}, but it
{\em is not unboxed}.
+We never manipulate values of type RealWorld; it's only used in the type
+system, to parameterise State#.
+
\begin{code}
realWorldTy = applyTyCon realWorldTyCon []
realWorldTyCon
%************************************************************************
\begin{code}
-arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1
- (\ [elt_kind] -> ArrayRep)
+arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 ArrayRep
-byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0
- (\ [] -> ByteArrayRep)
+byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 ByteArrayRep
-mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2
- (\ [s_kind, elt_kind] -> ArrayRep)
+mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 ArrayRep
-mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1
- (\ [s_kind] -> ByteArrayRep)
+mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 ByteArrayRep
mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt]
byteArrayPrimTy = applyTyCon byteArrayPrimTyCon []
%************************************************************************
\begin{code}
-synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2
- (\ [s_kind, elt_kind] -> PtrRep)
+synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 PtrRep
mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt]
\end{code}
%************************************************************************
\begin{code}
-stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1
- (\ [elt_kind] -> StablePtrRep)
+stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep
mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty]
\end{code}
\begin{code}
foreignObjPrimTy = applyTyCon foreignObjPrimTyCon []
-foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0
- (\ [] -> ForeignObjRep)
+foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep
\end{code}
doubleDataCon,
doubleTy,
doubleTyCon,
- eqDataCon,
falseDataCon,
floatDataCon,
floatTy,
floatTyCon,
getStatePairingConInfo,
- gtDataCon,
intDataCon,
intTy,
intTyCon,
liftDataCon,
liftTyCon,
listTyCon,
- ltDataCon,
foreignObjTyCon,
mkLiftTy,
mkListTy,
mkStateTransformerTy,
mkTupleTy,
nilDataCon,
- orderingTy,
- orderingTyCon,
primIoTyCon,
- ratioDataCon,
- ratioTyCon,
- rationalTy,
- rationalTyCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
stateDataCon,
stateTyCon,
stringTy,
- stringTyCon,
trueDataCon,
unitTy,
voidTy, voidTyCon,
--import PprStyle
--import Kind
-import Ubiq
-import TyLoop ( mkDataCon, StrictnessMark(..) )
+IMP_Ubiq()
+IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) )
-- friends:
import PrelMods
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
)
-import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy,
- mkFunTys, maybeAppDataTyConExpandingDicts,
+import Type ( mkTyConTy, applyTyCon, mkSigmaTy,
+ mkFunTys, maybeAppTyCon,
GenType(..), ThetaType(..), TauType(..) )
import TyVar ( tyVarKind, alphaTyVar, betaTyVar )
import Unique
pc_gen_specs = error "TysWiredIn:pc_gen_specs "
mkSpecInfo = error "TysWiredIn:SpecInfo"
-pcDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING
- -> [TyVar] -> [Id] -> TyCon
-pcDataTyCon key mod str tyvars cons
+alpha_tyvar = [alphaTyVar]
+alpha_ty = [alphaTy]
+alpha_beta_tyvars = [alphaTyVar, betaTyVar]
+
+pcDataTyCon, pcNewTyCon
+ :: Unique{-TyConKey-} -> Module -> FAST_STRING
+ -> [TyVar] -> [Id] -> TyCon
+
+pcDataTyCon = pc_tycon DataType
+pcNewTyCon = pc_tycon NewType
+
+pc_tycon new_or_data key mod str tyvars cons
= mkDataTyCon (mkBuiltinName key mod str) tycon_kind
tyvars [{-no context-}] cons [{-no derivings-}]
- DataType
+ new_or_data
where
tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
\begin{code}
-- The Void type is represented as a data type with no constructors
+-- It's a built in type (i.e. there's no way to define it in Haskell
+-- the nearest would be
+--
+-- data Void = -- No constructors!
+--
+-- It's boxed; there is only one value of this
+-- type, namely "void", whose semantics is just bottom.
voidTy = mkTyConTy voidTyCon
voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] []
mkStateTy ty = applyTyCon stateTyCon [ty]
realWorldStateTy = mkStateTy realWorldTy -- a common use
-stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alphaTyVar] [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") alpha_tyvar [stateDataCon]
stateDataCon
= pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
+ alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\end{code}
\begin{code}
stablePtrTyCon
= pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr")
- [alphaTyVar] [stablePtrDataCon]
+ alpha_tyvar [stablePtrDataCon]
where
stablePtrDataCon
= pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
- [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
+ alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
\begin{code}
stateAndPtrPrimTyCon
= pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alphaTyVar, betaTyVar] [stateAndPtrPrimDataCon]
+ alpha_beta_tyvars [stateAndPtrPrimDataCon]
stateAndPtrPrimDataCon
= pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
stateAndPtrPrimTyCon nullSpecEnv
stateAndCharPrimTyCon
= pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alphaTyVar] [stateAndCharPrimDataCon]
+ alpha_tyvar [stateAndCharPrimDataCon]
stateAndCharPrimDataCon
= pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, charPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
stateAndCharPrimTyCon nullSpecEnv
stateAndIntPrimTyCon
= pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alphaTyVar] [stateAndIntPrimDataCon]
+ alpha_tyvar [stateAndIntPrimDataCon]
stateAndIntPrimDataCon
= pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, intPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
stateAndIntPrimTyCon nullSpecEnv
stateAndWordPrimTyCon
= pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alphaTyVar] [stateAndWordPrimDataCon]
+ alpha_tyvar [stateAndWordPrimDataCon]
stateAndWordPrimDataCon
= pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, wordPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
stateAndWordPrimTyCon nullSpecEnv
stateAndAddrPrimTyCon
= pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alphaTyVar] [stateAndAddrPrimDataCon]
+ alpha_tyvar [stateAndAddrPrimDataCon]
stateAndAddrPrimDataCon
= pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, addrPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
stateAndAddrPrimTyCon nullSpecEnv
stateAndStablePtrPrimTyCon
= pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alphaTyVar, betaTyVar] [stateAndStablePtrPrimDataCon]
+ alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
stateAndStablePtrPrimDataCon
= pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
- [alphaTyVar, betaTyVar] []
+ alpha_beta_tyvars []
[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
stateAndForeignObjPrimTyCon
= pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
- [alphaTyVar] [stateAndForeignObjPrimDataCon]
+ alpha_tyvar [stateAndForeignObjPrimDataCon]
stateAndForeignObjPrimDataCon
= pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
- [alphaTyVar] []
+ alpha_tyvar []
[mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
stateAndForeignObjPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
= pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alphaTyVar] [stateAndFloatPrimDataCon]
+ alpha_tyvar [stateAndFloatPrimDataCon]
stateAndFloatPrimDataCon
= pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, floatPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
stateAndFloatPrimTyCon nullSpecEnv
stateAndDoublePrimTyCon
= pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alphaTyVar] [stateAndDoublePrimDataCon]
+ alpha_tyvar [stateAndDoublePrimDataCon]
stateAndDoublePrimDataCon
= pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, doublePrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
stateAndDoublePrimTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndArrayPrimTyCon
= pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alphaTyVar, betaTyVar] [stateAndArrayPrimDataCon]
+ alpha_beta_tyvars [stateAndArrayPrimDataCon]
stateAndArrayPrimDataCon
= pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
stateAndArrayPrimTyCon nullSpecEnv
stateAndMutableArrayPrimTyCon
= pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alphaTyVar, betaTyVar] [stateAndMutableArrayPrimDataCon]
+ alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
stateAndMutableArrayPrimDataCon
= pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
stateAndMutableArrayPrimTyCon nullSpecEnv
stateAndByteArrayPrimTyCon
= pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alphaTyVar] [stateAndByteArrayPrimDataCon]
+ alpha_tyvar [stateAndByteArrayPrimDataCon]
stateAndByteArrayPrimDataCon
= pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
stateAndByteArrayPrimTyCon nullSpecEnv
stateAndMutableByteArrayPrimTyCon
= pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alphaTyVar] [stateAndMutableByteArrayPrimDataCon]
+ alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
stateAndMutableByteArrayPrimDataCon
= pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
- [alphaTyVar] [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon [alphaTy]]
+ alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty]
stateAndMutableByteArrayPrimTyCon nullSpecEnv
stateAndSynchVarPrimTyCon
= pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alphaTyVar, betaTyVar] [stateAndSynchVarPrimDataCon]
+ alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
stateAndSynchVarPrimDataCon
= pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
- [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
stateAndSynchVarPrimTyCon nullSpecEnv
\end{code}
Type) -- type of state pair
getStatePairingConInfo prim_ty
- = case (maybeAppDataTyConExpandingDicts prim_ty) of
+ = case (maybeAppTyCon prim_ty) of
Nothing -> panic "getStatePairingConInfo:1"
- Just (prim_tycon, tys_applied, _) ->
+ Just (prim_tycon, tys_applied) ->
let
(pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon
pair_ty = applyTyCon pair_tycon (realWorldTy : drop num_tys tys_applied)
This is really just an ordinary synonym, except it is ABSTRACT.
\begin{code}
-mkStateTransformerTy s a = mkSynTy stTyCon [s, a]
-
-stTyCon
- = let
- ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
- in
- mkSynTyCon
- (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST"))
- (mkBoxedTypeKind `mkArrowKind` (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind))
- 2 [alphaTyVar, betaTyVar]
- ty
+mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
+
+stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon]
+ where
+ ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
+
+ stDataCon = pcDataCon stDataConKey pRELUDE SLIT("_ST")
+ alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
\end{code}
%************************************************************************
@PrimIO@ and @IO@ really are just plain synonyms.
\begin{code}
-mkPrimIoTy a = mkSynTy primIoTyCon [a]
-
-primIoTyCon
- = let
- ty = mkStateTransformerTy realWorldTy alphaTy
- in
--- pprTrace "primIOTyCon:" (ppCat [pprType PprDebug ty, ppr PprDebug (typeKind ty)]) $
- mkSynTyCon
- (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO"))
- (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
- 1 [alphaTyVar] ty
+mkPrimIoTy a = applyTyCon primIoTyCon [a]
+
+primIoTyCon = pcNewTyCon primIoTyConKey pRELUDE SLIT("_PrimIO") alpha_tyvar [primIoDataCon]
+ where
+ ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy])
+
+ primIoDataCon = pcDataCon primIoDataConKey pRELUDE SLIT("_PrimIO")
+ alpha_tyvar [] [ty] primIoTyCon nullSpecEnv
\end{code}
%************************************************************************
%************************************************************************
%* *
-\subsection[TysWiredIn-Ordering]{The @Ordering@ type}
-%* *
-%************************************************************************
-
-\begin{code}
----------------------------------------------
--- data Ordering = LT | EQ | GT deriving ()
----------------------------------------------
-
-orderingTy = mkTyConTy orderingTyCon
-
-orderingTyCon = pcDataTyCon orderingTyConKey pRELUDE_BUILTIN SLIT("Ordering") []
- [ltDataCon, eqDataCon, gtDataCon]
-
-ltDataCon = pcDataCon ltDataConKey pRELUDE_BUILTIN SLIT("LT") [] [] [] orderingTyCon nullSpecEnv
-eqDataCon = pcDataCon eqDataConKey pRELUDE_BUILTIN SLIT("EQ") [] [] [] orderingTyCon nullSpecEnv
-gtDataCon = pcDataCon gtDataConKey pRELUDE_BUILTIN SLIT("GT") [] [] [] orderingTyCon nullSpecEnv
-\end{code}
-
-%************************************************************************
-%* *
\subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)}
%* *
%************************************************************************
mkListTy :: GenType t u -> GenType t u
mkListTy ty = applyTyCon listTyCon [ty]
-alphaListTy = mkSigmaTy [alphaTyVar] [] (applyTyCon listTyCon [alphaTy])
+alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty)
listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]")
- [alphaTyVar] [nilDataCon, consDataCon]
+ alpha_tyvar [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") [alphaTyVar] [] [] listTyCon
+nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") alpha_tyvar [] [] listTyCon
(pcGenerateDataSpecs alphaListTy)
consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":")
- [alphaTyVar] [] [alphaTy, applyTyCon listTyCon [alphaTy]] listTyCon
+ alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon
(pcGenerateDataSpecs alphaListTy)
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
%************************************************************************
%* *
-\subsection[TysWiredIn-Ratios]{@Ratio@ and @Rational@}
-%* *
-%************************************************************************
-
-ToDo: make this (mostly) go away.
-
-\begin{code}
-rationalTy :: GenType t u
-
-mkRatioTy ty = applyTyCon ratioTyCon [ty]
-rationalTy = mkRatioTy integerTy
-
-ratioTyCon = pcDataTyCon ratioTyConKey rATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
-
-ratioDataCon = pcDataCon ratioDataConKey rATIO SLIT(":%")
- [alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
- -- context omitted to match lib/prelude/ defn of "data Ratio ..."
-
-rationalTyCon
- = mkSynTyCon
- (mkBuiltinName rationalTyConKey rATIO SLIT("Rational"))
- mkBoxedTypeKind
- 0 [] rationalTy -- == mkRatioTy integerTy
-\end{code}
-
-%************************************************************************
-%* *
\subsection[TysWiredIn-_Lift]{@_Lift@ type: to support array indexing}
%* *
%************************************************************************
-}
-alphaLiftTy = mkSigmaTy [alphaTyVar] [] (applyTyCon liftTyCon [alphaTy])
+alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty)
liftTyCon
- = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alphaTyVar] [liftDataCon]
+ = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") alpha_tyvar [liftDataCon]
liftDataCon
= pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift")
- [alphaTyVar] [] [alphaTy] liftTyCon
+ alpha_tyvar [] alpha_ty liftTyCon
((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
(mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
where
\begin{code}
stringTy = mkListTy charTy
-
-stringTyCon
- = mkSynTyCon
- (mkBuiltinName stringTyConKey pRELUDE SLIT("String"))
- mkBoxedTypeKind
- 0 [] stringTy
\end{code}
cmpCostCentre -- used for removing dups in a list
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Id ( externallyVisibleId, GenId, Id(..) )
import CStrings ( identToC, stringToC )
module SCCauto ( addAutoCostCentres ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
module SCCfinal ( stgMassageForProfiling ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
readInteger
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
import Util ( panic )
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
+
type RdrId = RdrName
type SrcLine = Int
type SrcFile = FAST_STRING
sepDeclsIntoSigsAndBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PrefixSyn -- and various syntaxen.
import HsSyn
getRawExportees
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn
import Name ( ExportFlag(..) )
\begin{code}
#include "HsVersions.h"
-module ReadPrefix (
- rdModule
- ) where
+module ReadPrefix ( rdModule ) where
-import Ubiq
+IMP_Ubiq()
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import FiniteMap ( elemFM, FiniteMap )
import Name ( RdrName(..), isRdrLexConOrSpecial )
import PprStyle ( PprStyle(..) )
-import PrelMods ( fromPrelude )
+import PrelMods ( fromPrelude, pRELUDE )
import Pretty
import SrcLoc ( SrcLoc )
import Util ( nOfThem, pprError, panic )
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr (HsVar (Qual SLIT("Prelude") SLIT("negate"))))
+ -- this is a hack
+ let
+ neg = SLIT("negate")
+ rdr = if opt_CompilingPrelude
+ then Unqual neg
+ else Qual pRELUDE neg
+ in
+ returnUgn (NegApp expr (HsVar rdr))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
= case pat of
U_par ppat -> -- parenthesised pattern
wlkPat ppat `thenUgn` \ pat ->
- returnUgn (ParPatIn pat)
+ -- tidy things up a little:
+ returnUgn (
+ case pat of
+ VarPatIn _ -> pat
+ WildPatIn -> pat
+ other -> ParPatIn pat
+ )
U_as avar as_pat -> -- "as" pattern
wlkQid avar `thenUgn` \ var ->
wlkLiteral ulit
= returnUgn (
case ulit of
- U_integer s -> HsInt (as_integer s)
+ U_integer s -> HsInt (as_integer s)
U_floatr s -> HsFrac (as_rational s)
U_intprim s -> HsIntPrim (as_integer s)
U_doubleprim s -> HsDoublePrim (as_rational s)
module ParseIface ( parseIface ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import ParseUtils
iname : VARID { $1 }
| CONID { $1 }
| OPAREN VARSYM CPAREN { $2 }
+ | OPAREN BANG CPAREN { SLIT("!"){-sigh, double-sigh-} }
| OPAREN CONSYM CPAREN { $2 }
qiname :: { RdrName }
module ParseUtils where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
ITinteger (read num) : lexIface rest }
-----------
- is_var_sym '_' = True
- is_var_sym c = isAlphanum c
+ is_var_sym '_' = True
+ is_var_sym '\'' = True
+ is_var_sym '#' = True -- for Glasgow-extended names
+ is_var_sym c = isAlphanum c
+
+ is_var_sym1 '\'' = False
+ is_var_sym1 '#' = False
+ is_var_sym1 c = is_var_sym c
is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
lex_word str@(c:cs) -- we know we have a capital letter to start
= -- we first try for "<module>." on the front...
case (module_dot str) of
- Nothing -> lex_name Nothing is_var_sym str
+ Nothing -> lex_name Nothing (in_the_club str) str
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
- where
- in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (c:_) | isAlpha c = is_var_sym
- | is_sym_sym c = is_sym_sym
- | otherwise = panic ("lex_word:in_the_club="++[c])
+ where
+ in_the_club [] = panic "lex_word:in_the_club"
+ in_the_club (c:_) | isAlpha c = is_var_sym
+ | c == '_' = is_var_sym
+ | is_sym_sym c = is_sym_sym
+ | otherwise = panic ("lex_word:in_the_club="++[c])
module_dot (c:cs)
- = if not (isUpper c) then
+ = if not (isUpper c) || c == '\'' then
Nothing
else
case (span is_var_sym cs) of { (word, rest) ->
lex_name module_dot in_the_club str
= case (span in_the_club str) of { (word, rest) ->
case (lookupFM keywordsFM word) of
- Just xx -> ASSERT( not (maybeToBool module_dot) )
- xx : lexIface rest
+ Just xx -> let
+ cont = xx : lexIface rest
+ in
+ case xx of
+ ITbang -> case module_dot of
+ Nothing -> cont
+ Just m -> ITqvarsym (Qual m SLIT("!"))
+ : lexIface rest
+ _ -> cont
Nothing ->
(let
f = head word -- first char
-----------------------------------------------------------------
ifaceParseErr ln toks sty
- = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]
+ = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
\end{code}
import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
import RnIfaces ( rnIfaces )
-import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
+import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv )
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts ( opt_HiMap )
+import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
import Maybes ( catMaybes )
= let
(b_names, b_keys, _) = builtinNameInfo
+ pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
in
- --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
- -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
- -- , ppCat (map ppPStr (keysFM builtin_tcs))
- -- , ppCat (map ppPStr (keysFM b_keys))
- -- ]}) $
-
+ {-
+ pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
+ , ppCat (map pp_pair (keysFM builtin_tcs))
+ , ppCat (map pp_pair (keysFM b_keys))
+ ]}) $
+ -}
makeHiMap opt_HiMap >>= \ hi_files ->
-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
pair_orig rn = (origName rn, rn)
must_haves
+ | opt_NoImplicitPrelude
+ = [{-no Prelude.hi, no point looking-}]
+ | otherwise
= [ name_fn (mkBuiltinName u mod str)
| ((str, mod), (u, name_fn)) <- fmToList b_keys,
str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath)
\end{code}
+Warning message used herein:
+\begin{code}
+multipleOccWarn (name, occs) sty
+ = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
+ ppInterleave ppComma (map (ppr sty) occs)]
+\end{code}
+
\begin{code}
{- TESTING:
pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
DefinedVars(..)
) where
-import Ubiq
-import RnLoop -- break the RnPass/RnExpr/RnBinds loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import HsPragmas ( isNoGenPragmas, noGenPragmas )
checkPrecMatch
) where
-import Ubiq
-import RnLoop -- break the RnPass/RnExpr/RnBinds loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
import HsSyn
import RdrHsSyn
module RnHsSyn where
-import Ubiq
+IMP_Ubiq()
import HsSyn
isRnField _ = False
isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls _ = False
+isRnClassOp cls n = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
isRnImplicit (RnImplicit _) = True
isRnImplicit (RnImplicitTyCon _) = True
IfaceCache(..)
) where
-import Ubiq
+IMP_Ubiq()
import LibDirectory
import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, keysFM{-ToDo:rm-}
+ plusFM_C, addListToFM, keysFM{-ToDo:rm-}
)
import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, RdrName(..) )
+import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo )
-> IO (MaybeErr RdrIfaceDecl Error)
cachedDecl iface_cache class_or_tycon orig
- = cachedIface True iface_cache mod >>= \ maybe_iface ->
+ = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $
+ cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
- Failed err -> return (Failed err)
+ Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
+ return (Failed err)
Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
Just decl -> return (Succeeded decl)
return_failed msg = return (Failed msg)
in
case maybe_decl of
- Failed _ -> return_maybe_decl
+ Failed io_msg -> return_failed (ifaceIoErr io_msg rn)
Succeeded if_decl ->
case rn of
WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
-> IO (MaybeErr ParsedIface Error)
readIface file mod
- = --hPutStr stderr (" reading "++file) >>
+ = hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> --hPutStr stderr " parsing" >>
+ Right contents -> hPutStr stderr ".." >>
let parsed = parseIface contents in
- --hPutStr stderr " done\n" >>
+ hPutStr stderr "..\n" >>
return (
case parsed of
Failed _ -> parsed
todo
= {-
pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
-
pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
Nothing
| fst (moduleNamePair n) == modname ->
-- avoid looking in interface for the module being compiled
- -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
- do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
+ --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
+ do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
| otherwise ->
-- OK, see what the cache has for us...
cachedDeclByType iface_cache n >>= \ maybe_ans ->
case maybe_ans of
Failed err -> -- add the error, but keep going:
- -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
do_decls ns down (add_err err to_return)
Succeeded iface_decl -> -- something needing renaming!
add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
= case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- ASSERT(isEmptyBag def_dups)
+ (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
+-- ASSERT(isEmptyBag def_dups)
let
val_occs = val_defds ++ fmToList val_imps
tc_occs = tc_defds ++ fmToList tc_imps
add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
+add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
\end{code}
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
in
+ --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
-- Sanity Check:
want_inst i@(InstSig clas tycon _ _)
= -- it's a "good instance" (one to hang onto) if we have a
-- chance of referring to *both* the class and tycon later on ...
-
+ --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
mentionable tycon && mentionable clas && not (is_done_inst i)
where
mentionable nm
\end{code}
\begin{code}
+type BigMaps = (FiniteMap Module Version, -- module-version map
+ FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
+
finalIfaceInfo ::
IfaceCache -- iface cache
-> Module -- this module's name
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+ readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
let
+ all_ifaces = eltsFM orig_iface_fm
+ -- all the interfaces we have looked at
+
+ big_maps
+ -- combine all the version maps we have seen into maps to
+ -- (a) lookup a module-version number, lookup an entity's
+ -- individual version number
+ = foldr mk_map (emptyFM,emptyFM) all_ifaces
+
val_stuff@(val_usages, val_versions)
- = foldFM process_item (emptyFM, emptyFM){-init-} qual
+ = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
(all_usages, all_versions)
- = foldFM process_item val_stuff{-keep going-} tc_qual
+ = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
in
return (all_usages, all_versions, [])
where
- process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
+ mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
+ = (addToFM mv_map m mv, -- add this module
+ addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
+
+ -----------------------
+ process_item :: BigMaps
+ -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
-> (UsagesMap, VersionsMap) -- input
-> (UsagesMap, VersionsMap) -- output
- process_item (n,m) rn as_before@(usages, versions)
+ process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
| irrelevant rn
= as_before
| m == modname -- this module => add to "versions"
= (usages, addToFM versions n 1{-stub-})
| otherwise -- from another module => add to "usages"
- = (add_to_usages usages m n 1{-stub-}, versions)
+ = (add_to_usages usages key, versions)
+ where
+ add_to_usages usages key@(n,m)
+ = let
+ mod_v = case (lookupFM big_mv_map m) of
+ Nothing -> pprTrace "big_mv_map:miss? " (ppPStr m) $
+ 1
+ Just nv -> nv
+ key_v = case (lookupFM big_version_map key) of
+ Nothing -> pprTrace "big_version_map:miss? " (ppCat [ppPStr n, ppPStr m]) $
+ 1
+ Just nv -> nv
+ in
+ addToFM usages m (
+ case (lookupFM usages m) of
+ Nothing -> -- nothing for this module yet...
+ (mod_v, unitFM n key_v)
+
+ Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
+ ASSERT(mversion == mod_v)
+ (mversion, addToFM mstuff n key_v)
+ )
irrelevant (RnConstr _ _) = True -- We don't report these in their
irrelevant (RnField _ _) = True -- own right in usages/etc.
irrelevant (RnClassOp _ _) = True
+ irrelevant (RnImplicit n) = isRdrLexCon (origName n) -- really a RnConstr
irrelevant _ = False
- add_to_usages usages m n version
- = addToFM usages m (
- case (lookupFM usages m) of
- Nothing -> -- nothing for this module yet...
- (1{-stub-}, unitFM n version)
-
- Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
- (mversion, addToFM mstuff n version)
- )
\end{code}
\begin{code}
-thisModImplicitErr mod n sty
- = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod]
+thisModImplicitWarn mod n sty
+ = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
noIfaceErr mod sty
= ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
badIfaceLookupErr msg name decl sty
= ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+
+ifaceIoErr io_msg rn sty
+ = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
\end{code}
fixIO
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import SST
isRnClassOp, RenamedFixityDecl(..) )
import RnUtils ( RnEnv(..), extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
- unknownNameErr, badClassOpErr, qualNameErr,
- dupNamesErr, shadowedNameWarn
+ qualNameErr, dupNamesErr
)
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import CmdLineOpts ( opt_WarnNameShadowing )
-import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
+import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
+ Error(..), Warning(..)
+ )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
import Maybes ( assocMaybe )
import Name ( Module(..), RdrName(..), isQual,
Name, mkLocalName, mkImplicitName,
- getOccName
+ getOccName, pprNonSym
)
import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( pRELUDE )
-import Pretty ( Pretty(..), PrettyRep )
+import PprStyle{-ToDo:rm-}
+import Outputable{-ToDo:rm-}
+import Pretty--ToDo:rm ( Pretty(..), PrettyRep )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
- = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_names str_mod) of
- Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
- Just xx -> returnSST xx
+ = let
+ str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
+ in
+ --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
+ case (lookupFM b_names str_mod) of
+ Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
+ Just xx -> returnSST xx
lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
= readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
in
result
\end{code}
+
+*********************************************************
+* *
+\subsection{Errors used in RnMonad}
+* *
+*********************************************************
+
+\begin{code}
+unknownNameErr descriptor name locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
+
+badClassOpErr clas op locn
+ = addErrLoc locn "" $ \ sty ->
+ ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'"]
+
+shadowedNameWarn locn shadow
+ = addShortWarnLocLine locn $ \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+\end{code}
import PreludeGlaST ( MutableVar(..) )
-import Ubiq
+IMP_Ubiq()
import HsSyn
import RdrHsSyn
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, filterBag, listToBag, bagToList )
-import CmdLineOpts ( opt_NoImplicitPrelude )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude )
import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
+import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE, rATIO, iX )
+import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic )
+ equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-}
+ )
\end{code}
-> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
condecls `thenRn` \ (con_names, field_names) ->
let
returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- newGlobalName con_loc (Just (nameExportFlag tycon_name)) con
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
`thenRn` \ con_name ->
returnRn (RnData tycon_name [con_name] [],
unitBag (RnConstr con_name tycon_name),
emptyBag)
getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
returnRn (RnSyn tycon_name, emptyBag, emptyBag)
= returnRn (bagToList constrs, bagToList fields)
getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
- = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
getConFieldNames exp (constrs `snocBag` con_name) fields have rest
getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
= mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
- newGlobalName src_loc exp con `thenRn` \ con_name ->
- mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names ->
+ newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
+ mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
let
all_constrs = constrs `snocBag` con_name
all_fields = fields `unionBags` listToBag field_names
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
- = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
+ = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
getClassOpNames (Just (nameExportFlag class_name))
sigs `thenRn` \ op_names ->
returnRn (RnClass class_name op_names,
getClassOpNames exp []
= returnRn []
getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp op `thenRn` \ op_name ->
+ = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
getClassOpNames exp sigs `thenRn` \ op_names ->
returnRn (op_name : op_names)
getClassOpNames exp (_ : sigs)
doField locn (_, pat, _) = doPat locn pat
doName locn rdr
- = newGlobalName locn Nothing rdr `thenRn` \ name ->
+ = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
returnRn (unitBag (RnName name))
\end{code}
*********************************************************
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag
+newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-}
-> RdrName -> RnM_Info s Name
-- ToDo: b_names and b_keys being defined in this module !!!
-newGlobalName locn maybe_exp rdr
- = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) ->
+newGlobalName locn maybe_exp is_val_name rdr
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) ->
getModuleRn `thenRn` \ mod ->
rnGetUnique `thenRn` \ u ->
let
- (uniq, unqual)
- = case rdr of
- Qual m n -> (u, n)
- Unqual n -> case (lookupFM b_keys n) of
- Nothing -> (u, n)
- Just (key,_) -> (key, n)
+ unqual = case rdr of { Qual m n -> n; Unqual n -> n }
orig = if fromPrelude mod
then (Unqual unqual)
else (Qual mod unqual)
+ uniq
+ = let
+ str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) }
+ n = fst str_mod
+ m = snd str_mod
+ in
+ --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $
+ case (lookupFM b_keys str_mod) of
+ Just (key,_) -> key
+ Nothing -> if not opt_CompilingPrelude then u else
+ case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of
+ Nothing -> u
+ Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $
+ uniqueOf xx
+
exp = case maybe_exp of
Just exp -> exp
Nothing -> exp_fn n
-- cache the imported modules
-- this ensures that all directly imported modules
-- will have their original name iface in scope
+ -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
accumulate (map (cachedIface False iface_cache) imp_mods) >>
-- process the imports
all_imps = implicit_qprel ++ the_imps
implicit_qprel = if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}]
+ then [{- no "import qualified Prelude" -}
+ ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc
+ ]
else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
mod == pRELUDE ])
implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude
- then [{- no "import Prelude" -}]
+ then [{- no "import Prelude" -}
+ ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc
+ ]
else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= pRELUDE_BUILTIN ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = cachedIface False iface_cache mod >>= \ maybe_iface ->
+ = let
+ (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
+ in
+ (if mod == pRELUDE_BUILTIN then
+ return (Succeeded (panic "doImport:PreludeBuiltin"),
+ \ iface -> ([], [], emptyBag))
+ else
+ --pprTrace "doImport:" (ppPStr mod) $
+ cachedIface False iface_cache mod >>= \ maybe_iface ->
+ return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec')
+ ) >>= \ (maybe_iface, do_ies) ->
+
case maybe_iface of
Failed err ->
return (emptyBag, emptyBag, emptyBag, emptyBag,
unitBag err, emptyBag, emptyBag)
Succeeded iface ->
let
- (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
- (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec'
+ (ies, chk_ies, get_errs) = do_ies iface
in
doOrigIEs iface_cache info mod src_loc us ies
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
let
final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
+ final_vals_list = bagToList final_vals
in
- accumulate (map (getFixityDecl iface_cache) (bagToList final_vals))
- >>= \ fix_maybes_errs ->
+ (if mod == pRELUDE_BUILTIN then
+ return [ (Nothing, emptyBag) | _ <- final_vals_list ]
+ else
+ accumulate (map (getFixityDecl iface_cache) final_vals_list)
+ ) >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
getBuiltins _ mod maybe_spec
- | not ((fromPrelude mod) || mod == iX || mod == rATIO )
+ | not (fromPrelude mod || mod == iX || mod == rATIO)
= (emptyBag, emptyBag, maybe_spec)
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
= with_decl iface_cache n
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
(\ decl -> case decl of
- NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag)
- DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag)
+ NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag)
+ DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
where
check_with str has rdrs
getFixityDecl iface_cache (_,rn)
= let
(mod, str) = moduleNamePair rn
+
+ succeeded infx i = return (Just (infx rn i), emptyBag)
in
cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
- Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
- Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag)
- Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag)
+ Just (InfixL _ i) -> succeeded InfixL i
+ Just (InfixR _ i) -> succeeded InfixR i
+ Just (InfixN _ i) -> succeeded InfixN i
ie_name (IEVar n) = n
ie_name (IEThingAbs n) = n
getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
= newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- cons `thenRn` \ con_names ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- fields `thenRn` \ field_names ->
+ let
+ map_me = mapRn (newImportedName False src_loc
+ (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name)))
+ in
+ map_me cons `thenRn` \ con_names ->
+ map_me fields `thenRn` \ field_names ->
let
rn_tycon = RnData tycon_name con_names field_names
rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
Nothing ->
rnGetUnique `thenRn` \ u ->
let
- uniq = case rdr of
- Qual m n -> u
- Unqual n -> case lookupFM b_keys n of
- Nothing -> u
- Just (key,_) -> key
+ str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) }
+
+ uniq = case lookupFM b_keys str_mod of
+ Nothing -> u
+ Just (key,_) -> key
exp = case maybe_exp of
Just exp -> exp
module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
-import Ubiq
-import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
import HsSyn
import HsPragmas
import Unique ( Unique )
import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isIn, isn'tIn, sortLt, removeDups, mapAndUnzip3, cmpPString,
+import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
`unionBags`
listToBag (map exp_all fields))
| otherwise
- = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
+ = rnWithErr "constructors (and fields)" rn (cons++fields) rns
checkIEWith rn@(RnClass n ops) rns
| same_names ops rns
= returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecls `thenRn` \ condecls' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
= pushSrcLocRn src_loc $
lookupTyCon tycon `thenRn` \ tycon' ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env context `thenRn` \ context' ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
rnConDecls tv_env condecl `thenRn` \ condecl' ->
rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
= pushSrcLocRn src_loc $
- mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
- rnContext tv_env context `thenRn` \ context' ->
- lookupClass cname `thenRn` \ cname' ->
- mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
- rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
+ rnContext tv_env src_loc context `thenRn` \ context' ->
+ lookupClass cname `thenRn` \ cname' ->
+ mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
+ rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
ASSERT(isNoClassPragmas pragmas)
returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
where
- rn_op clas tv_env (ClassOpSig op ty pragmas locn)
+ rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
= pushSrcLocRn locn $
lookupClassOp clas op `thenRn` \ op_name ->
rnPolyType tv_env ty `thenRn` \ new_ty ->
-
-{-
-*** Please check here that tyvar' appears in new_ty ***
-*** (used to be in tcClassSig, but it's better here)
-*** not_elem = isn'tIn "tcClassSigs"
-*** -- Check that the class type variable is mentioned
-*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
-*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
--}
+ let
+ (HsForAllTy tvs ctxt op_ty) = new_ty
+ ctxt_tvs = extractCtxtTyNames ctxt
+ op_tvs = extractMonoTyNames is_tyvar_name op_ty
+ in
+ -- check that class tyvar appears in op_ty
+ ( if isIn "rn_op" clas_tyvar op_tvs
+ then returnRn ()
+ else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
+ ) `thenRn_`
+
+ -- check that class tyvar *doesn't* appear in the sig's context
+ ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
+ then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
+ else returnRn ()
+ ) `thenRn_`
ASSERT(isNoClassOpPragmas pragmas)
returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
ppStr ";ty=", ppr PprShowAll ty]) $
-}
- getSrcLocRn `thenRn` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
+ getSrcLocRn `thenRn` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
let
tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
in
- rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
- rnMonoType tv_env2 ty `thenRn` \ new_ty ->
+ rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
+ rnMonoType tv_env2 ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
\end{code}
\begin{code}
-rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
-rnContext tv_env ctxt
- = mapRn rn_ctxt ctxt
+rnContext tv_env locn ctxt
+ = mapRn rn_ctxt ctxt `thenRn` \ result ->
+ let
+ (_, dup_asserts) = removeDups cmp_assert result
+ in
+ -- If this isn't an error, then it ought to be:
+ mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
+ returnRn result
where
rn_ctxt (clas, tyvar)
- = lookupClass clas `thenRn` \ clas_name ->
- lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
- returnRn (clas_name, tyvar_name)
+ = lookupClass clas `thenRn` \ clas_name ->
+ lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
+ returnRn (clas_name, tyvar_name)
+
+ cmp_assert (c1,tv1) (c2,tv2)
+ = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
\end{code}
\begin{code}
dupNameExportWarn locn names@((n,_):_)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
dupLocalsExportErr locn locals@((str,_):_)
- = addErrLoc locn "exported names have same local name" (\ sty ->
- ppInterleave ppSP (map (pprNonSym sty . snd) locals))
+ = addErrLoc locn "exported names have same local name" $ \ sty ->
+ ppInterleave ppSP (map (pprNonSym sty . snd) locals)
classOpExportErr op locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]
synAllExportErr is_error syn locn
- = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty ->
- ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
+ = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
withExportErr str rn has rns locn
- = addErrLoc locn "" (\ sty ->
+ = addErrLoc locn "" $ \ sty ->
ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
- ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ])
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
importAllErr rn locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
+ = addShortErrLocLine locn $ \ sty ->
+ ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
badModExportErr mod locn
- = addShortErrLocLine locn (\ sty ->
- ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
emptyModExportWarn locn mod
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
dupModExportWarn locn mods@(mod:_)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+ = addShortWarnLocLine locn $ \ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
derivingNonStdClassErr clas locn
- = addShortErrLocLine locn (\ sty ->
- ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
+ = addShortErrLocLine locn $ \ sty ->
+ ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
= ppAboves (item1 : map dup_item dup_things)
where
item1
- = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
+ = addShortErrLocLine locn1 (\ sty ->
+ ppStr "multiple default declarations") sty
dup_item (DefaultDecl _ locn)
- = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
+ = addShortErrLocLine locn (\ sty ->
+ ppStr "here was another default declaration") sty
undefinedFixityDeclErr locn decl
- = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
- ppr sty decl)
+ = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
+ ppr sty decl
dupFixityDeclErr locn dups
- = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
- ppAboves (map (ppr sty) dups))
+ = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
+ ppAboves (map (ppr sty) dups)
+
+classTyVarNotInOpTyErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+ 4 (ppr sty sig)
+
+classTyVarInOpCtxtErr clas_tyvar sig locn
+ = addShortErrLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
+ 4 (ppr sty sig)
+
+dupClassAssertWarn ctxt locn dups
+ = addShortWarnLocLine locn $ \ sty ->
+ ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+ 4 (ppr sty ctxt)
\end{code}
lubExportFlag,
- unknownNameErr,
- badClassOpErr,
qualNameErr,
- dupNamesErr,
- shadowedNameWarn,
- multipleOccWarn
+ dupNamesErr
) where
-import Ubiq
+IMP_Ubiq(){-uitous-}
import Bag ( Bag, emptyBag, snocBag, unionBags )
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, addErrLoc )
+import ErrUtils ( addShortErrLocLine )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
lookupFM, addListToFM, addToFM )
import Maybes ( maybeToBool )
*********************************************************
* *
-\subsection{Errors used in RnMonad}
+\subsection{Errors used *more than once* in the renamer}
* *
*********************************************************
\begin{code}
-unknownNameErr descriptor name locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] )
-
-badClassOpErr clas op locn
- = addErrLoc locn "" ( \ sty ->
- ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
- ppr sty clas, ppStr "'"] )
-
qualNameErr descriptor (name,locn)
= addShortErrLocLine locn ( \ sty ->
ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] )
= addShortErrLocLine locn (\ sty ->
ppBesides [ppStr "here was another declaration of `",
pprNonSym sty name, ppStr "'" ]) sty
-
-shadowedNameWarn locn shadow
- = addShortWarnLocLine locn ( \ sty ->
- ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] )
-
-multipleOccWarn (name, occs) sty
- = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
- ppInterleave ppComma (map (ppr sty) occs)]
\end{code}
module AnalFBWW ( analFBWW ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreBinding(..) )
import Util ( panic{-ToDo:rm-} )
inlineUnconditionally, oneTextualOcc, oneSafeOcc,
- combineBinderInfo, combineAltsBinderInfo,
+ addBinderInfo, orBinderInfo,
argOccurrence, funOccurrence,
markMany, markDangerousToDup, markInsideSCC,
isFun, isDupDanger -- for Simon Marlow deforestation
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty
import Util ( panic )
| ManyOcc -- Everything else besides DeadCode and OneOccs
- Int -- number of arguments on stack when called
+ Int -- number of arguments on stack when called; this is a minimum guarantee
| OneOcc -- Just one occurrence (or one each in
-- time we *use* the info; we could be more clever for
-- other cases if we really had to. (WDP/PS)
- Int -- number of arguments on stack when called
+ Int -- number of arguments on stack when called; minimum guarantee
-- In general, we are feel free to substitute unless
-- (a) is in an argument position (ArgOcc)
= OneOcc posn dup_danger InsideSCC n_alts ar
markInsideSCC other = other
-combineBinderInfo, combineAltsBinderInfo
+addBinderInfo, orBinderInfo
:: BinderInfo -> BinderInfo -> BinderInfo
-combineBinderInfo DeadCode info2 = info2
-combineBinderInfo info1 DeadCode = info1
-combineBinderInfo info1 info2
+addBinderInfo DeadCode info2 = info2
+addBinderInfo info1 DeadCode = info1
+addBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
-combineAltsBinderInfo DeadCode info2 = info2
-combineAltsBinderInfo info1 DeadCode = info1
-combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
+-- (orBinderInfo orig new) is used in two situations:
+-- First, it combines occurrence info from branches of a case
+--
+-- Second, when a variable whose occurrence
+-- info is currently "orig" is bound to a variable whose occurrence info is "new"
+-- eg (\new -> e) orig
+-- What we want to do is to *worsen* orig's info to take account of new's
+
+orBinderInfo DeadCode info2 = info2
+orBinderInfo info1 DeadCode = info1
+orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
(OneOcc posn2 dup2 scc2 n_alts2 ar_2)
= OneOcc (combine_posns posn1 posn2)
(combine_dups dup1 dup2)
(n_alts1 + n_alts2)
(min ar_1 ar_2)
where
- combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn
- combine_posns _ _ = ArgOcc
-
combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo
combine_dups _ DupDanger = DupDanger
combine_dups _ _ = NoDupDanger
combine_sccs _ InsideSCC = InsideSCC
combine_sccs _ _ = NotInsideSCC
-combineAltsBinderInfo info1 info2
+orBinderInfo info1 info2
= ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2))
+combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn
+combine_posns _ _ = ArgOcc
+
+{-
+multiplyBinderInfo orig@(ManyOcc _) new
+ = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new))
+
+multiplyBinderInfo orig new@(ManyOcc _)
+ = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new))
+
+multiplyBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1)
+ (OneOcc posn2 dup2 scc2 n_alts2 ar_2)
+ = OneOcc (combine_posns posn1 posn2) ???
+-}
+
setBinderInfoArityToZero :: BinderInfo -> BinderInfo
setBinderInfoArityToZero DeadCode = DeadCode
setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0
module ConFold ( completePrim ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) )
+import CoreUnfold ( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
import SimplEnv
import SimplMonad
import TysWiredIn ( trueDataCon, falseDataCon )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+chr = toEnum :: Int -> Char
+#endif
\end{code}
\begin{code}
= returnSmpl (Lit (mkMachInt 1))
completePrim env op@SeqOp args@[TyArg ty, VarArg var]
- = case (lookupUnfolding env var) of
- NoUnfoldingDetails -> give_up
- LitForm _ -> hooray
- OtherLitForm _ -> hooray
- ConForm _ _ -> hooray
- OtherConForm _ -> hooray
- GenForm _ WhnfForm _ _ -> hooray
- _ -> give_up
- where
- give_up = returnSmpl (Prim op args)
- hooray = returnSmpl (Lit (mkMachInt 1))
+ | whnfDetails (lookupUnfolding env var)
+ = returnSmpl (Lit (mkMachInt 1))
+ | otherwise
+ = returnSmpl (Prim op args)
\end{code}
\begin{code}
module FloatIn ( floatInwards ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn
import CoreSyn
module FloatOut ( floatOutwards ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
module FoldrBuildWW ( mkFoldrBuildWW ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreBinding(..) )
import Util ( panic{-ToDo:rm?-} )
module LiberateCase ( liberateCase ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
liberateCase = panic "LiberateCase.liberateCase: ToDo"
applyMagicUnfoldingFun
) where
-import Ubiq{-uitous-}
-import IdLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop) -- paranoia checking
import CoreSyn
import SimplEnv ( SimplEnv )
isConsFun :: SimplEnv -> CoreArg -> Bool
isConsFun env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ _ (Lam (x,_) (Lam (y,_)
- (Con con tys [VarArg x',VarArg y']))) _
- | con == consDataCon && x==x' && y==y'
+ GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
+ | con == consDataCon && x==x' && y==y'
-> ASSERT ( length tys == 1 ) True
_ -> False
isConsFun env _ = False
isNilForm :: SimplEnv -> CoreArg -> Bool
isNilForm env (VarArg v)
= case lookupUnfolding env v of
- GenForm _ _ (CoTyApp (Var id) _) _
- | id == nilDataCon -> True
- ConForm id _ _
- | id == nilDataCon -> True
- LitForm (NoRepStr s) | _NULL_ s -> True
- _ -> False
+ GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
+ GenForm _ (Lit (NoRepStr s)) _ | _NULL_ s -> True
+ _ -> False
isNilForm env _ = False
getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
= case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _
+ GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _
| bld == buildId -> Just g
- GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ GenForm _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId && isNilForm env h -> Just g
_ -> Nothing
= case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing
-- not allowed to inline :-(
- GenForm _ _ (App (App (CoTyApp (Var bld) _)
+ GenForm _ (App (App (CoTyApp (Var bld) _)
(VarArg g)) h) _
| bld == augmentId -> Just (g,h)
_ -> Nothing
getAppendForm env (VarArg v) =
case lookupUnfolding env v of
GenForm False _ _ _ -> Nothing -- not allowed to inline :-(
- GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
+ GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
| fld == foldrId && isConsFun env con -> Just (xs,ys)
_ -> Nothing
getAppendForm env _ = Nothing
-> Maybe ([CoreArg],CoreArg)
getListForm env (VarArg v)
= case lookupUnfolding env v of
- ConForm id _ [head,tail]
+ GenForm _ (Con id [ty_arg,head,tail]) _
| id == consDataCon ->
case getListForm env tail of
Nothing -> Just ([head],tail)
isInterestingArg env (VarArg v)
= case lookupUnfolding env v of
GenForm False _ _ UnfoldNever -> False
- GenForm _ _ exp guide -> True
+ GenForm _ exp guide -> True
_ -> False
isInterestingArg env _ = False
occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import BinderInfo
import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = combineIdEnvs combineBinderInfo usage1 usage2
+ = combineIdEnvs addBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = combineIdEnvs combineAltsBinderInfo usage1 usage2
+ = combineIdEnvs orBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
addOneOcc usage id info
- = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
+ = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
-- ToDo: make this more efficient
emptyDetails = (nullIdEnv :: UsageDetails)
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr
+ snd (occurAnalyseExpr emptyIdSet expr)
\end{code}
%************************************************************************
module SAT ( doStaticArgs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
module SATMonad where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
-- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnnCoreSyn
import CoreSyn
module SimplCase ( simplCase, bindLargeRhs ) where
-import Ubiq{-uitous-}
-import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+import CoreUnfold ( whnfDetails, mkConForm, mkLitForm,
+ UnfoldingDetails(..), UnfoldingGuidance(..),
FormSummary(..)
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit, Literal{-instance Eq-} )
import Maybes ( maybeToBool )
-import PrelVals ( voidPrimId )
+import PrelVals ( voidId )
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
-import TysPrim ( voidPrimTy )
+import TysWiredIn ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
[alt | alt@(alt_con,_,_) <- alts,
not (alt_con `is_elem` not_these)]
-#ifdef DEBUG
--- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts))
- -- ConForm can't happen, since we'd have
- -- inlined it, and be in completeCaseWithKnownCon by now
-#endif
other -> alts
alt_binders_unused (con, args, rhs) = all is_dead args
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
- scrut_is_evald = case scrut_form of
- OtherLitForm _ -> True
- ConForm _ _ -> True
- OtherConForm _ -> True
- other -> False
-
+ scrut_is_evald = whnfDetails scrut_form
scrut_is_eliminable_primitive
= case scrut of
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- instead we turn it into a function: \v -> e
- -- where v::VoidPrim. Since arguments of type
+ -- where v::Void. Since arguments of type
-- VoidPrim don't generate any code, this gives the
-- desired effect.
--
-- The general structure is just the same as for the common "otherwise~ case
= newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
- newId voidPrimTy `thenSmpl` \ void_arg_id ->
+ newId voidTy `thenSmpl` \ void_arg_id ->
rhs_c env `thenSmpl` \ prim_new_body ->
returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
- App (Var prim_rhs_fun_id) (VarArg voidPrimId))
+ App (Var prim_rhs_fun_id) (VarArg voidId))
| otherwise
= -- Make the new binding Id. NB: it's an OutId
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
+ prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
do_alt (lit, rhs)
= let
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
+ Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit)
other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
= case (form_from_this_case, scrut_form) of
(OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
(OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
- -- ConForm, LitForm impossible
- -- (ASSERT? ASSERT? Hello? WDP 95/05)
other -> form_from_this_case
env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-- Change unfold details for scrut var. We now want to unfold it
-- to binder'
- new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
- (Var binder') UnfoldAlways
+ new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways
+
new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
in
let
env1 = extendIdEnvWithClone env binder id'
new_env = extendUnfoldEnvGivenFormDetails env1 id'
- (ConForm con con_args)
+ (mkConForm con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
module SimplCore ( core2core ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import AnalFBWW ( analFBWW )
import Bag ( isEmptyBag, foldBag )
where
pp_det NoUnfoldingDetails = ppStr "_N_"
--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
- pp_det (GenForm _ _ expr guide)
+ pp_det (GenForm _ expr guide)
= ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
pp_det other = ppStr "???"
OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import SmplLoop -- breaks the MagicUFs / SimplEnv loop
+IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
-import BinderInfo ( BinderInfo{-instances-} )
+import BinderInfo ( orBinderInfo, oneSafeOcc,
+ BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
+ )
import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
+import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm,
calcUnfoldingGuidance, UnfoldingGuidance(..),
- mkFormSummary, FormSummary
+ mkFormSummary, FormSummary(..)
)
import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness,
applyTypeEnvToId,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
- addOneToIdEnv, modifyIdEnv,
+ addOneToIdEnv, modifyIdEnv, mkIdSet,
IdEnv(..), IdSet(..), GenId )
import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
+import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
import OccurAnal ( occurAnalyseExpr )
import Outputable ( Outputable(..){-instances-} )
TyVarEnv(..), GenTyVar{-instance Eq-}
)
import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
-import UniqSet -- lots of things
+import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
+ delFromUFM, ufmToList
+ )
+--import UniqSet -- lots of things
import Usage ( UVar(..), GenUsage{-instances-} )
import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
type TypeEnv = TyVarEnv Type
cmpType = panic "cmpType (SimplEnv)"
-oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
-oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
-simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
\end{code}
%************************************************************************
= ppCat [ppr PprDebug v, ppStr "=>",
case form of
NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
- LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
[ppr PprDebug l | l <- ls]]
- ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
[ppr PprDebug c | c <- cs]]
- GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
+ GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w,
ppr PprDebug g, ppr PprDebug e]
MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
]
data UnfoldEnv -- yup, a glorified triple...
= UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
- IdSet -- The Ids in the domain of the env
- -- which have details (GenForm True ...)
- -- i.e., they claim they are duplicatable.
- -- These are the ones we have to worry
- -- about when adding new items to the
- -- unfold env.
+
+ (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
+ -- in-scope ids. The "Id" part is just so that
+ -- we can recover the domain of the mapping, which
+ -- IdEnvs don't allow directly.
+ --
+ -- Anything that isn't in here
+ -- should be assumed to occur many times.
+ -- The things in here all occur once, and the
+ -- binder-info tells about whether that "once"
+ -- is inside a lambda, or perhaps once in each branch
+ -- of a case etc.
+ -- We keep this info so we can modify it when
+ -- something changes.
+
(FiniteMap UnfoldConApp [([Type], OutId)])
-- Maps applications of constructors (to
-- value atoms) back to an association list
-- mapping for (part of) the main IdEnv
-- (1st part of UFE)
-null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
+null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
\end{code}
The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
elsewhere in the module:
\begin{code}
-grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
+grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
lookup_unfold_env_encl_cc
:: UnfoldEnv -> OutId -> EnclosingCcDetails
-grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
+grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
-grow_unfold_env (UFE u_env interesting_ids con_apps) id
- uf_details@(GenForm True _ _ _) encl_cc
- -- Only interested in Ids which have a "dangerous" unfolding; that is
- -- one that claims to have a single occurrence.
+grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
= UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- (addOneToUniqSet interesting_ids id)
- con_apps
-
-grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- interesting_ids
+ new_occ_env
new_con_apps
where
+ new_occ_env = modify_occ_info occ_env id occ_info
+
new_con_apps
= case uf_details of
- ConForm con args -> snd (lookup_conapp_help con_apps con args id)
+ GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
not_a_constructor -> con_apps -- unchanged
-addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
+addto_unfold_env (UFE u_env occ_env con_apps) extra_items
= ASSERT(not (any constructor_form_in_those extra_items))
-- otherwise, we'd need to change con_apps
- UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
+ UFE (growIdEnvList u_env extra_items) occ_env con_apps
where
- constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
+ constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
constructor_form_in_those _ = False
rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
+get_interesting_ids (UFE _ occ_env _)
+ = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
-foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
- = UFE (foldr fun u_env stuff) interesting_ids con_apps
+foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
+ = UFE u_env (foldr fun occ_env stuff) con_apps
lookup_unfold_env (UFE u_env _ _) id
= case (lookupIdEnv u_env id) of
cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
= if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
-modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
- = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
+modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
+ = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
--- If the current binding claims to be a "unique" one, then
--- we modify it.
-modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
-
-modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
- = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
+modify_occ_info occ_env id other_new_occ
+ = -- Many or Dead occurrence, just delete from occ_env
+ delFromUFM occ_env id
\end{code}
The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
it, so we can use it for a @FiniteMap@ key.
\begin{code}
instance Eq UnfoldConApp where
- a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
- a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
instance Ord UnfoldConApp where
- a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
instance Ord3 UnfoldConApp where
cmp = cmp_app
-- ToDo: make an "instance Ord3 CoreArg"???
cmp_arg (VarArg x) (VarArg y) = x `cmp` y
- cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+ cmp_arg (LitArg x) (LitArg y) = x `cmp` y
cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
cmp_arg x y
-> InBinder -> OutArg{-Val args only, please-}
-> SimplEnv
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
+ (in_id,occ_info) atom@(LitArg lit)
= SimplEnv chkr encl_cc ty_env new_id_env unfold_env
where
new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
- (in_id, occ_info) atom@(VarArg out_id)
+extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
+ (in_id, occ_info) atom@(VarArg out_id)
= SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
where
- new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
-
- new_unfold_env = modify_unfold_env
- unfold_env
- (modifyItem ok_to_dup occ_info)
- out_id
- -- Modify binding for in_id
- -- NO! modify out_id, because its the info on the
- -- atom that interest's us.
-
- ok_to_dup = switchIsOn chkr SimplOkToDupCode
+ new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
+ new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
+ -- Modify occ info for out_id
#ifdef DEBUG
extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
NoUnfoldingDetails -> env
good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
where
- new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
+ new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc
+ fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid
extendUnfoldEnvGivenConstructor -- specialised variant
:: SimplEnv
(_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
in
extendUnfoldEnvGivenFormDetails
- env var (ConForm con (map TyArg ty_args ++ map VarArg args))
+ env var (mkConForm con (map TyArg ty_args ++ map VarArg args))
\end{code}
= SimplEnv chkr encl_cc ty_env id_env new_unfold_env
where
-- Occurrence-analyse the RHS
- (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
+ (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
- interesting_fvs = get_interesting_ids unfold_env
+ interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv
-- Compute unfolding details
- details = case rhs of
- Var v -> panic "Vars already dealt with"
- Lit lit | isNoRepLit lit -> LitForm lit
- | otherwise -> panic "non-noRep Lits already dealt with"
-
- Con con args -> ConForm con args
-
- other -> mkGenForm ok_to_dup occ_info
- (mkFormSummary (getIdStrictness out_id) rhs)
- template guidance
+ details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
+ template guidance
-- Compute resulting unfold env
new_unfold_env = case details of
- NoUnfoldingDetails -> unfold_env
- GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
- other -> unfold_env1
+ NoUnfoldingDetails -> unfold_env
+ other -> unfold_env1
-- Add unfolding to unfold env
- unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
+ unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
+{- OLD: done in grow_unfold_env
-- Modify unfoldings of free vars of rhs, based on their
-- occurrence info in the rhs [see notes above]
- unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
-
- modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
- modify (u, occ_info) env
- = case (lookupUFM_Directly env u) of
- Nothing -> env -- ToDo: can this happen?
- Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
+ unfold_env2
+ = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
+ where
+ modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
+ modify (u, item@(i,occ_info)) env
+ = if maybeToBool (lookupUFM_Directly env u) then
+ -- it occurred before, so now it occurs multiple times;
+ -- therefore, *delete* it from the occ(urs once) env.
+ delFromUFM_Directly env u
+
+ else if not (oneSafeOcc ok_to_dup occ_info) then
+ env -- leave it alone
+ else
+ addToUFM_Directly env u item
+-}
-- Compute unfolding guidance
guidance = if simplIdWantsToBeINLINEd out_id env
Just xx -> xx
ok_to_dup = switchIsOn chkr SimplOkToDupCode
- || exprSmallEnoughToDup rhs
- -- [Andy] added, Jun 95
+--NO: || exprSmallEnoughToDup rhs
+-- -- [Andy] added, Jun 95
{- Reinstated AJG Jun 95; This is needed
--example that does not (currently) work
-- Cloning
cloneId, cloneIds, cloneTyVarSmpl, newIds, newId
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import SmplLoop -- well, cheating sort of
+IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
import Id ( mkSysLocal, mkIdWithNewUniq )
import SimplEnv
module SimplPgm ( simplifyPgm ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_D_verbose_core2core,
switchIsOn, intSwitchSet, SimplifierSwitch(..)
type_ok_for_let_to_case
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) -- paranoia checking
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplVar]{Simplifier stuff related to variables}
leastItCouldCost
) where
-import Ubiq{-uitous-}
-import SmplLoop ( simplExpr )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) ( simplExpr )
import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
+import CoreUnfold ( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..),
FormSummary(..)
)
import Id ( idType, getIdInfo,
in
case (lookupUnfolding env var) of
- LitForm lit
- | not (isNoRepLit lit)
- -- Inline literals, if they aren't no-repish things
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- ConForm con con_args
- -- Always inline constructors.
- -- See comments before completeLetBinding
- -> ASSERT( null args )
- returnSmpl (Con con con_args)
-
- GenForm txt_occ form_summary template guidance
+ GenForm form_summary template guidance
-> considerUnfolding env var args
- txt_occ form_summary template guidance
+ (panic "completeVar"{-txt_occ-}) form_summary template guidance
MagicForm str magic_fun
-> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
full_price
else
case arg of
- LitArg _ -> full_price
- VarArg v -> case lookupUnfolding env v of
- ConForm _ _ -> take_something_off v
- other_form -> full_price
+ LitArg _ -> full_price
+ VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v
+ | otherwise -> full_price
) want_cons rest_args
\end{code}
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-import Ubiq{-uitous-}
-import SmplLoop -- paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) -- paranoia checking
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
Simplify.simplExpr) and SimplExpr (which uses whatever
SimplVar/SimplCase cough up).
+Tell SimplEnv about SimplUtils.simplIdWantsToBeINLINEd.
+
\begin{code}
interface SmplLoop where
OutArg(..), OutExpr(..), OutType(..)
)
import Simplify ( simplExpr, simplBind )
+import SimplUtils ( simplIdWantsToBeINLINEd )
import BinderInfo(BinderInfo)
import CoreSyn(GenCoreArg, GenCoreBinding, GenCoreExpr)
data MagicUnfoldingFun
data SimplCount
+simplIdWantsToBeINLINEd :: GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -> SimplEnv -> Bool
+
simplBind :: SimplEnv -> GenCoreBinding (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> (SimplEnv -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)) -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
simplExpr :: SimplEnv -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)
\end{code}
module LambdaLift ( liftProgram ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
module SatStgRhs ( satStgRhs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
module SimplStg ( stg2stg ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import StgUtils
module StgSAT ( doStaticArgs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
import UniqSupply ( UniqSM(..) )
module StgSATMonad ( getArgLists, saTransform ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic )
module StgStats ( showStgStats ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
module StgVarInfo ( setStgVarInfo ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
> module UpdAnal ( updateAnalyse ) where
>
-> import Ubiq{-uitous-}
+> IMP_Ubiq(){-uitous-}
>
> import StgSyn
> import Util ( panic )
specEnvToList
) where
-import Ubiq
+IMP_Ubiq()
import MatchEnv
import Type ( matchTys, isTyVarTy )
pprSpecErrs
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( isEmptyBag, bagToList )
import Class ( classOpString, GenClass{-instance NamedThing-} )
SpecialiseData(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
partitionBag, listToBag, bagToList
module CoreToStg ( topCoreBindsToStg ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn -- input
import StgSyn -- output
import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( getAppDataTyConExpandingDicts )
-import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon )
+import TyCon ( TyCon{-instance Uniquable-} )
+import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
+import TysWiredIn ( stringTy )
+import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqSupply -- all of it, really
-import Util ( panic )
+import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Pretty--ToDo:rm
+import PprStyle--ToDo:rm
+import PprType --ToDo:rm
+import Outputable--ToDo:rm
+import PprEnv--ToDo:rm
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
where
is_NUL c = c == '\0'
-litToStgArg (NoRepInteger i)
+litToStgArg (NoRepInteger i integer_ty)
-- extremely convenient to look out for a few very common
-- Integer literals!
| i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
| i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
| otherwise
- = newStgVar integerTy `thenUs` \ var ->
+ = newStgVar integer_ty `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
in
returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-litToStgArg (NoRepRational r)
- = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) ->
- litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) ->
- newStgVar rationalTy `thenUs` \ var ->
- let
- rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
- ratioDataCon -- Constructor
- [num_atom, denom_atom]
- in
- returnUs (StgVarArg var, binds1 `unionBags`
- binds2 `unionBags`
- unitBag (StgNonRec var rhs))
+litToStgArg (NoRepRational r rational_ty)
+ = --ASSERT(is_rational_ty)
+ (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
+ litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
+ litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
+ newStgVar rational_ty `thenUs` \ var ->
+ let
+ rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
+ ratio_data_con -- Constructor
+ [num_atom, denom_atom]
+ in
+ returnUs (StgVarArg var, binds1 `unionBags`
+ binds2 `unionBags`
+ unitBag (StgNonRec var rhs))
+ where
+ (is_rational_ty, ratio_data_con, integer_ty)
+ = case (maybeAppDataTyCon rational_ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(is_integer_ty i_ty)
+ (uniqueOf tycon == ratioTyConKey, con, i_ty)
+
+ _ -> (False, panic "ratio_data_con", panic "integer_ty")
+
+ is_integer_ty ty
+ = case (maybeAppDataTyCon ty) of
+ Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+ _ -> False
litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
\end{code}
module StgLint ( lintStgBindings ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import StgSyn
isLitLitArg,
stgArity,
collectExportedStgBinders
-
- -- and to make the interface self-sufficient...
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre )
import Id ( idPrimRep, GenId{-instance NamedThing-} )
module StgUtils ( mapStgBindeesRhs ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Id ( GenId{-instanced NamedThing-} )
import StgSyn
isBot
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUnfold ( UnfoldingDetails(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
- dataConSig, dataConArgTys
+ dataConTyCon, dataConArgTys
)
import IdInfo ( StrictnessInfo(..), Demand(..),
wwPrim, wwStrict, wwEnum, wwUnpack
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, LitForm _) ->
- AbsTop -- Literals all terminate, and have no poison
-
- (Nothing, NoStrictnessInfo, ConForm _ _) ->
- AbsTop -- An imported constructor won't have
- -- bottom components, nor poison!
-
- (Nothing, NoStrictnessInfo, GenForm _ _ unfolding _) ->
+ (Nothing, NoStrictnessInfo, GenForm _ unfolding _) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
-- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
-- Try the strictness info
absValFromStrictness anal strictness_info
-
-
- -- Done via strictness now
- -- GenForm _ BottomForm _ _ -> AbsBot
in
- -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
+ -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $
result
- -- )
where
pp_anal StrAnal = ppStr "STR"
pp_anal AbsAnal = ppStr "ABS"
then AbsBot
else AbsTop
where
- (_,_,_, tycon) = dataConSig con
- has_single_con = maybeToBool (maybeTyConSingleCon tycon)
+ has_single_con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
\end{code}
\begin{code}
absValFromStrictness
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn ( CoreExpr(..) )
import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
module StrictAnal ( saWwTopBinds, saTopBinds ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict,
opt_D_dump_stranal, opt_D_simplifier_stats
module WorkWrap ( workersAndWrappers ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
mkWwBodies, mAX_WORKER_ARGS
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import Id ( idType, mkSysLocal, dataConArgTys )
checkSigTyVars, checkSigTyVarsGivenGlobals
) where
-import Ubiq
+IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
import TcEnv ( tcGetGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
- TcTyVarSet(..), TcTyVar(..), tcInstType,
- newTyVarTy, zonkTcType
+ TcTyVarSet(..), TcTyVar(..),
+ newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars
)
import Unify ( unifyTauTy )
import Pretty
import PprType ( GenClass, GenType, GenTyVar )
import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys,
- getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
+ getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
import TyVar ( GenTyVar, TyVar(..), tyVarKind, minusTyVarSet, emptyTyVarSet,
elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
import Usage ( UVar(..) )
-> TcM s ()
checkSigTyVars sig_tyvars sig_tau
- = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau
+ = checkSigTyVarsGivenGlobals emptyTyVarSet sig_tyvars sig_tau
checkSigTyVarsGivenGlobals
- :: TcTyVarSet s -- Consider these fully-zonked tyvars as global
+ :: TcTyVarSet s -- Consider these tyvars as global in addition to envt ones
-> [TcTyVar s] -- The original signature type variables
-> TcType s -- signature type (for err msg)
-> TcM s ()
-checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau
- = -- Check point (c)
+checkSigTyVarsGivenGlobals extra_globals sig_tyvars sig_tau
+ = zonkTcTyVars extra_globals `thenNF_Tc` \ extra_tyvars' ->
+ tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
+ let
+ globals = env_tyvars `unionTyVarSets` extra_tyvars'
+ mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
+ in
+ -- TEMPORARY FIX
+ -- Until the final Bind-handling stuff is in, several type signatures in the same
+ -- bindings group can cause the signature type variable from the different
+ -- signatures to be unified. So we still need to zonk and check point (b).
+ -- Remove when activating the new binding code
+ mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys ->
+ checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys))
+ (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' ->
+ failTc (badMatchErr sig_tau sig_tau')
+ ) `thenTc_`
+
+
+ -- Check point (c)
-- We want to report errors in terms of the original signature tyvars,
-- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond
-- 1-1 with sig_tyvars, so we can just map back.
checkTc (null mono_tyvars)
(notAsPolyAsSigErr sig_tau mono_tyvars)
- where
- mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars
\end{code}
\begin{code}
notAsPolyAsSigErr sig_tau mono_tyvars sty
= ppHang (ppStr "A type signature is more polymorphic than the inferred type")
- 4 (ppAboves [ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)",
- ppHang (ppStr "Monomorphic type variable(s):")
- 4 (interpp'SP sty mono_tyvars),
+ 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:",
+ interpp'SP sty mono_tyvars,
ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction"
])
\end{code}
zonkInst, instToId,
matchesInst,
- instBindingRequired, instCanBeGeneralised
-
+ instBindingRequired, instCanBeGeneralised,
+
+ pprInst
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
InPat, OutPat, Stmt, Qual, Match,
ArithSeqInfo, PolyType, Fake )
import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
- mkHsTyApp, mkHsDictApp )
+ mkHsTyApp, mkHsDictApp, tcIdTyVars )
import TcMonad hiding ( rnMtoTcM )
-import TcEnv ( tcLookupGlobalValueByKey )
+import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
tcInstType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv )
+import Class ( isCcallishClass, isNoDictClass, classInstEnv,
+ Class(..), GenClass, ClassInstEnv(..)
+ )
+import ErrUtils ( addErrLoc, Error(..) )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( mkLocalName, getLocalName, Name )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
- splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
-import TyVar ( GenTyVar )
+ splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
+ mkSynTy
+ )
+import TyVar ( unionTyVarSets, GenTyVar )
import TysPrim ( intPrimTy )
-import TysWiredIn ( intDataCon )
-import Unique ( Unique, showUnique,
- fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
-import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic )
+import TysWiredIn ( intDataCon, integerTy )
+import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
+ fromIntClassOpKey, fromIntegerClassOpKey, Unique
+ )
+import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
%************************************************************************
= -- Get the Id type and instantiate it at the specified types
(case id of
RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
- in tcInstType (zipEqual "newMethod" tyvars tys) rho
+ in
+ (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
+ tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
) `thenNF_Tc` \ rho_ty ->
\begin{code}
tyVarsOfInst :: Inst s -> TcTyVarSet s
tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty
-tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
+tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
+ -- The id might not be a RealId; in the case of
+ -- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
\end{code}
\begin{code}
instBindingRequired :: Inst s -> Bool
-instBindingRequired inst
- = case getInstOrigin inst of
- CCallOrigin _ _ -> False -- No binding required
- LitLitOrigin _ -> False
- OccurrenceOfCon _ -> False
- other -> True
+instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
+instBindingRequired other = True
instCanBeGeneralised :: Inst s -> Bool
-instCanBeGeneralised inst
- = case getInstOrigin inst of
- CCallOrigin _ _ -> False -- Can't be generalised
- LitLitOrigin _ -> False -- Can't be generalised
- other -> True
+instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
+instCanBeGeneralised other = True
\end{code}
\begin{code}
instance Outputable (Inst s) where
- ppr sty (LitInst uniq lit ty orig loc)
- = ppSep [case lit of
- OverloadedIntegral i -> ppInteger i
- OverloadedFractional f -> ppRational f,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ]
-
- ppr sty (Dict uniq clas ty orig loc)
- = ppSep [ppr sty clas,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ]
-
- ppr sty (Method uniq id tys rho orig loc)
- = ppSep [ppr sty id,
- ppStr "at",
- ppr sty tys,
- show_uniq sty uniq
- ]
-
-show_uniq PprDebug uniq = ppr PprDebug uniq
-show_uniq sty uniq = ppNil
+ ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
+
+pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
+
+ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [case lit of
+ OverloadedIntegral i -> ppInteger i
+ OverloadedFractional f -> ppRational f,
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty u])
+ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u])
+
+ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
+ = ppHang (ppr_orig orig loc)
+ 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
+
+show_uniq PprDebug u = ppr PprDebug u
+show_uniq sty u = ppNil
\end{code}
Printing in error messages
lookupInst dict@(Dict _ clas ty orig loc)
= case lookupMEnv matchTy (get_inst_env clas orig) ty of
Nothing -> tcAddSrcLoc loc $
- tcAddErrCtxt (pprOrigin orig) $
+ tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $
failTc (noInstanceErr dict)
Just (dfun_id, tenv)
= -- Alas, it is overloaded and a big literal!
tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
+ returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
where
intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
= tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
+
+ -- The type Rational isn't wired in so we have to conjure it up
+ tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
+ let
+ rational_ty = mkSynTy rational_tycon []
+ rational_lit = HsLitOut (HsFrac f) rational_ty
+ in
newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
+ returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit))
\end{code}
There is a second, simpler interface, when you want an instance of a
get_inst_env clas other_orig = classInstEnv clas
-pprOrigin :: InstOrigin s -> PprStyle -> Pretty
+pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
-pprOrigin (OccurrenceOf id) sty
- = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
+pprOrigin hdr orig locn
+ = addErrLoc locn hdr $ \ sty ->
+ case orig of
+ OccurrenceOf id ->
+ ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
ppr sty id, ppChar '\'']
-pprOrigin (OccurrenceOfCon id) sty
- = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
+ OccurrenceOfCon id ->
+ ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
ppr sty id, ppChar '\'']
-pprOrigin (InstanceDeclOrigin) sty
- = ppStr "in an instance declaration"
-pprOrigin (LiteralOrigin lit) sty
- = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
-pprOrigin (ArithSeqOrigin seq) sty
- = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
-pprOrigin (SignatureOrigin) sty
- = ppStr "in a type signature"
-pprOrigin (DoOrigin) sty
- = ppStr "in a do statement"
-pprOrigin (ClassDeclOrigin) sty
- = ppStr "in a class declaration"
--- pprOrigin (DerivingOrigin _ clas tycon) sty
--- = ppBesides [ppStr "in a `deriving' clause; class `",
--- ppr sty clas,
--- ppStr "'; offending type `",
--- ppr sty tycon,
--- ppStr "'"]
-pprOrigin (InstanceSpecOrigin _ clas ty) sty
- = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
+ InstanceDeclOrigin ->
+ ppStr "in an instance declaration"
+ LiteralOrigin lit ->
+ ppCat [ppStr "at an overloaded literal:", ppr sty lit]
+ ArithSeqOrigin seq ->
+ ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
+ SignatureOrigin ->
+ ppStr "in a type signature"
+ DoOrigin ->
+ ppStr "in a do statement"
+ ClassDeclOrigin ->
+ ppStr "in a class declaration"
+ InstanceSpecOrigin _ clas ty ->
+ ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
ppr sty clas, ppStr "\" type: ", ppr sty ty]
--- pprOrigin (DefaultDeclOrigin) sty
--- = ppStr "in a `default' declaration"
-pprOrigin (ValSpecOrigin name) sty
- = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
+ ValSpecOrigin name ->
+ ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
ppr sty name, ppStr "'"]
-pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
- = ppBesides [ppStr "in the result of the _ccall_ to `",
+ CCallOrigin clabel Nothing{-ccall result-} ->
+ ppBesides [ppStr "in the result of the _ccall_ to `",
ppStr clabel, ppStr "'"]
-pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
- = ppBesides [ppStr "in an argument in the _ccall_ to `",
+ CCallOrigin clabel (Just arg_expr) ->
+ ppBesides [ppStr "in an argument in the _ccall_ to `",
ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
-pprOrigin (LitLitOrigin s) sty
- = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
-pprOrigin UnknownOrigin sty
- = ppStr "in... oops -- I don't know where the overloading came from!"
+ LitLitOrigin s ->
+ ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
+ UnknownOrigin ->
+ ppStr "in... oops -- I don't know where the overloading came from!"
\end{code}
-
-
-
module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
HsExpr, Match, PolyType, InPat, OutPat(..),
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( newTcTyVar, tcInstType )
+import TcType ( newTcTyVar, tcInstSigType )
import Unify ( unifyTauTy )
import Kind ( mkBoxedTypeKind, mkTypeKind )
genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
where
kind = case bind of
- NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types
- RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types
+ NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types
+ RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types
\end{code}
tcTySigs (Sig v ty _ src_loc : other_sigs)
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
- tcInstType [] sigma_ty `thenNF_Tc` \ sigma_ty' ->
+ tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
let
(tyvars', theta', tau') = splitSigmaTy sigma_ty'
in
-- Get and instantiate its alleged specialised type
tcPolyType poly_ty `thenTc` \ sig_sigma ->
- tcInstType [] sig_sigma `thenNF_Tc` \ sig_ty ->
+ tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
origin = ValSpecOrigin name
-- Get and instantiate the type of the id mentioned
tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
- tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty ->
+ tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
let
(main_tyvars, main_rho) = splitForAllTy main_ty
(main_theta,main_tau) = splitRhoTy main_rho
tcClassDecl1, tcClassDecls2
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
RnName{-instance Uniquable-}
)
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
- mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam )
+ mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
-import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
-import TcInstDcls ( processInstBinds )
-import TcKind ( unifyKind )
-import TcMonoType ( tcMonoType, tcContext )
-import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
+import TcInstDcls ( processInstBinds, newMethodId )
import TcKind ( TcKind )
+import TcKind ( unifyKind )
+import TcMonad hiding ( rnMtoTcM )
+import TcMonoType ( tcPolyType, tcMonoType, tcContext )
+import TcSimplify ( tcSimplifyAndCheck )
+import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType )
-import Bag ( foldBag )
+import Bag ( foldBag, unionManyBags )
import Class ( GenClass, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
classOpTagByString
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
import TysWiredIn ( stringTy )
-import TyVar ( GenTyVar )
+import TyVar ( mkTyVarSet, GenTyVar )
import Unique ( Unique )
import Util
+
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
tcGenPragmas ty id ps = returnNF_Tc noIdInfo
tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
-
\end{code}
+
+
+Dictionary handling
+~~~~~~~~~~~~~~~~~~~
+Every class implicitly declares a new data type, corresponding to dictionaries
+of that class. So, for example:
+
+ class (D a) => C a where
+ op1 :: a -> a
+ op2 :: forall b. Ord b => a -> b -> b
+
+would implicitly declare
+
+ data CDict a = CDict (D a)
+ (a -> a)
+ (forall b. Ord b => a -> b -> b)
+
+(We could use a record decl, but that means changing more of the existing apparatus.
+One step at at time!)
+
+For classes with just one superclass+method, we use a newtype decl instead:
+
+ class C a where
+ op :: forallb. a -> b -> b
+
+generates
+
+ newtype CDict a = CDict (forall b. a -> b -> b)
+
+Now DictTy in Type is just a form of type synomym:
+ DictTy c t = TyConTy CDict `AppTy` t
+
+Death to "ExpandingDicts".
+
+
\begin{code}
tcClassDecl1 rec_inst_mapper
(ClassDecl context class_name
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
--- BOGUS:
--- tcGetUnique `thenNF_Tc` \ uniq ->
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
\end{code}
+ let
+ clas_ty = mkTyVarTy clas_tyvar
+ dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
+ [classOpLocalType op | op <- ops])
+ new_or_data = case dict_component_tys of
+ [_] -> NewType
+ other -> DataType
+
+ dict_con_id = mkDataCon class_name
+ [NotMarkedStrict]
+ [{- No labelled fields -}]
+ [clas_tyvar]
+ [{-No context-}]
+ dict_component_tys
+ tycon
+
+ tycon = mkDataTyCon class_name
+ (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
+ [rec_tyvar]
+ [{- Empty context -}]
+ [dict_con_id]
+ [{- No derived classes -}]
+ new_or_data
+ in
+
+
\begin{code}
tcClassContext :: Class -> TyVar
-> RenamedContext -- class context
Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
) `thenNF_Tc` \ id_info ->
let
- ty = mkForAllTy rec_tyvar (
- mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar))
- (mkDictTy super_class (mkTyVarTy rec_tyvar))
- )
+ rec_tyvar_ty = mkTyVarTy rec_tyvar
+ ty = mkForAllTy rec_tyvar $
+ mkFunTy (mkDictTy rec_class rec_tyvar_ty)
+ (mkDictTy super_class rec_tyvar_ty)
in
-- BUILD THE SUPERCLASS ID
returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
(ClassOpSig op_name
- (HsForAllTy tyvar_names context monotype)
+ op_ty
pragmas src_loc)
= tcAddSrcLoc src_loc $
fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
- tcContext context `thenTc` \ theta ->
- tcMonoType monotype `thenTc` \ tau ->
- mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) ->
+
+ -- NB: Renamer checks that the class type variable is mentioned in local_ty,
+ -- and that it is not constrained by theta
+ tcPolyType op_ty `thenTc` \ local_ty ->
let
- full_tyvars = rec_clas_tyvar : tyvars
- full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
- global_ty = mkSigmaTy full_tyvars full_theta tau
- local_ty = mkSigmaTy tyvars theta tau
+ global_ty = mkSigmaTy [rec_clas_tyvar]
+ [(rec_clas, mkTyVarTy rec_clas_tyvar)]
+ local_ty
class_op_nm = getLocalName op_name
class_op = mkClassOp class_op_nm
(classOpTagByString rec_clas{-yeeps!-} class_op_nm)
Make a selector expression for @sel_id@ from a dictionary @clas_dict@
consisting of @dicts@ and @methods@.
+====================== OLD ============================
We have to do a bit of jiggery pokery to get the type variables right.
Suppose we have the class decl:
\begin{verbatim}
\begin{verbatim}
op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
\end{verbatim}
+========================= END OF OLD ===========================
+
+NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
+the rest of the compiler darn well ought to cope.
+
+
NOTE that we return a TcMonoBinds (which is later zonked) even though
there's no real back-substitution to do. It's just simpler this way!
-> NF_TcM s (TcMonoBinds s)
mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
- = let
- (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
- op_tys = mkTyVarTys op_tyvars
- in
- newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
-
- -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
+ =
+ -- sel_id = /\ clas_tyvar -> \ clas_dict ->
-- case clas_dict of
- -- <dicts..methods> -> method_or_dict op_tyvars op_dicts
+ -- <dicts..methods> -> method_or_dict
returnNF_Tc (VarMonoBind (RealId sel_id) (
- TyLam (clas_tyvar:op_tyvars) (
- DictLam (clas_dict:op_dicts) (
+ TyLam [clas_tyvar] (
+ DictLam [clas_dict] (
HsCase
(HsVar clas_dict)
([PatMatch (DictPat dicts methods) (
GRHSMatch (GRHSsAndBindsOut
[OtherwiseGRHS
- (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
+ (HsVar method_or_dict)
mkGeneratedSrcLoc]
EmptyBinds
- op_tau))])
+ (idType op)))])
mkGeneratedSrcLoc
))))
\end{code}
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True
+====================== OLD ==================
+\begin{verbatim}
defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}
Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
+====================== END OF OLD ===================
+
+NEW:
+\begin{verbatim}
+defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
+defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
+ if (op1 a dfoo x) && (< b dord y z) then y else z
+\end{verbatim}
+
When we come across an instance decl, we may need to use the default
methods:
const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
-const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
+const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
dfun.Foo.Int :: Foo Int
dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
\end{verbatim}
Notice that, as with method selectors above, we assume that dictionary
application is curried, so there's no need to mention the Ord dictionary
-in const.Foo.Int.op2
+in const.Foo.Int.op2 (or the type variable).
+
\begin{verbatim}
instance Foo a => Foo [a] where {}
= /\ a -> \ dfoo_a ->
let rec
op1 = defm.Foo.op1 [a] dfoo_list
- op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
+ op2 = defm.Foo.op2 [a] dfoo_list
dfoo_list = (op1, op2)
in
dfoo_list
buildDefaultMethodBinds clas clas_tyvar
default_method_ids default_binds
- = -- Deal with the method declarations themselves
+ = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
+ let
+ avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
+ in
processInstBinds
clas
- (makeClassDeclDefaultMethodRhs clas default_method_ids)
- [] -- No tyvars in scope for "this inst decl"
- emptyLIE -- No insts available
- (map RealId default_method_ids)
- default_binds `thenTc` \ (dicts_needed, default_binds') ->
+ (makeClassDeclDefaultMethodRhs clas local_defm_ids)
+ [clas_tyvar] -- Tyvars in scope
+ avail_insts
+ local_defm_ids
+ default_binds `thenTc` \ (insts_needed, default_binds') ->
+
+ tcSimplifyAndCheck
+ (mkTyVarSet [clas_tyvar])
+ avail_insts
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
+
- returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
+ let
+ defm_binds = AbsBinds
+ [clas_tyvar]
+ [this_dict_id]
+ (local_defm_ids `zip` map RealId default_method_ids)
+ dict_binds
+ (RecBind default_binds')
+ in
+ returnTc (const_lie, defm_binds)
+ where
+ inst_ty = mkTyVarTy clas_tyvar
+ mk_method defm_id = newMethodId defm_id inst_ty origin
+ origin = ClassDeclOrigin
\end{code}
@makeClassDeclDefaultMethodRhs@ builds the default method for a
\begin{code}
makeClassDeclDefaultMethodRhs
:: Class
- -> [Id]
+ -> [TcIdOcc s]
-> Int
-> NF_TcM s (TcExpr s)
makeClassDeclDefaultMethodRhs clas method_ids tag
- = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty ->
+ = -- Return the expression
+ -- error ty "No default method for ..."
+ -- The interesting thing is that method_ty is a for-all type;
+ -- this is fun, although unusual in a type application!
+
+ returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))
+
+{- OLD AND COMPLICATED
+ tcInstSigType () `thenNF_Tc` \ method_ty ->
let
(tyvars, theta, tau) = splitSigmaTy method_ty
in
mkHsDictLam dict_ids (
HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+-}
+
where
(clas_mod, clas_name) = moduleNamePair clas
method_id = method_ids !! (tag-1)
- class_op = (classOps clas) !! (tag-1)
+ class_op = (classOps clas) !! (tag-1)
error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser class_op))
module TcDefaults ( tcDefaults ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( DefaultDecl(..), MonoType,
HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcDeriv]{Deriving}
module TcDeriv ( tcDeriving ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
ArithSeqInfo, Fake, MonoType )
import HsPragmas ( InstancePragmas(..) )
-import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
+import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad hiding ( rnMtoTcM )
-import Inst ( InstOrigin(..), InstanceMapper(..) )
-import TcEnv ( getEnv_TyCons )
+import TcMonad
+import Inst ( InstanceMapper(..) )
+import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
import TcKind ( TcKind )
---import TcGenDeriv -- Deriv stuff
+import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import RnMonad
-import RnUtils ( RnEnv(..) )
+import RnUtils ( RnEnv(..), extendGlobalRnEnv )
import RnBinds ( rnMethodBinds, rnTopBinds )
import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
-import Class ( GenClass, classKey )
+import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
-import Id ( dataConSig, dataConArity )
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import Outputable
+import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import Maybes ( maybeToBool, Maybe(..) )
+import Name ( moduleNamePair, isLocallyDefined, getSrcLoc,
+ mkTopLevName, origName, mkImplicitName, ExportFlag(..),
+ RdrName{-instance Outputable-}, Name{--O only-}
+ )
+import Outputable ( Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
-import PprStyle
-import Pretty
-import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
+import PprStyle ( PprStyle(..) )
+import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) )
+import Pretty--ToDo:rm
+import FiniteMap--ToDo:rm
+import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
- maybeTyConSingleCon, isEnumerationTyCon, TyCon )
+ tyConTheta, maybeTyConSingleCon,
+ isEnumerationTyCon, isDataTyCon, TyCon
+ )
import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
- getAppTyCon, getAppDataTyCon
+ getAppDataTyCon, getAppTyCon
)
+import TysWiredIn ( voidTy )
import TyVar ( GenTyVar )
import UniqFM ( emptyUFM )
import Unique -- Keys stuff
-import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
- thenCmp, cmpList, panic, pprPanic, pprPanic#
+import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
+ thenCmp, cmpList, panic, pprPanic, pprPanic#,
+ assertPanic, pprTrace{-ToDo:rm-}
)
\end{code}
| C3 (T a a)
deriving (Eq)
+[NOTE: See end of these comments for what to do with
+ data (C a, D b) => T a b = ...
+]
+
We want to come up with an instance declaration of the form
instance (Ping a, Pong b, ...) => Eq (T a b) where
type DerivSoln = DerivRhs
\end{code}
+
+A note about contexts on data decls
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+ data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
+
+We will need an instance decl like:
+
+ instance (Read a, RealFloat a) => Read (Complex a) where
+ ...
+
+The RealFloat in the context is because the read method for Complex is bound
+to construct a Complex, and doing that requires that the argument type is
+in RealFloat.
+
+But this ain't true for Show, Eq, Ord, etc, since they don't construct
+a Complex; they only take them apart.
+
+Our approach: identify the offending classes, and add the data type
+context to the instance decl. The "offending classes" are
+
+ Read, Enum?
+
+
%************************************************************************
%* *
\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
-- for debugging via -ddump-derivings.
tcDeriving modname rn_env inst_decl_infos_in fixities
- = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
-{- LATER:
-
-tcDeriving modname rn_env inst_decl_infos_in fixities
= -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
- let
- nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
-
- -- We have the renamer's final "name funs" in our hands
- -- (they were passed in). So we can handle ProtoNames
- -- that refer to anything "out there". But our generated
- -- code may also mention "con2tag" (etc.). So we need
- -- to augment to "name funs" to include those.
- (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
-
- deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
- Just xx -> Just xx
- Nothing -> rn_val_gnf pname
-
- deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
-
- assoc_maybe [] _ = Nothing
- assoc_maybe ((k,v) : vs) key
- = if k `eqProtoName` key then Just v else assoc_maybe vs key
- in
- gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds ->
+ gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
+ gen_tag_n_con_binds rn_env nm_alist_etc
+ `thenTc` \ (extra_binds, deriver_rn_env) ->
mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
- `thenTc` \ really_new_inst_infos ->
+ `thenTc` \ really_new_inst_infos ->
+ let
+ ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
+ in
+ --pprTrace "derived:\n" (ddump_deriv PprDebug) $
returnTc (listToBag really_new_inst_infos,
extra_binds,
- ddump_deriving really_new_inst_infos extra_binds)
+ ddump_deriv)
where
- maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
+ maybe_mod = if opt_CompilingPrelude then Nothing else Just modname
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
makeDerivEqns :: TcM s [DerivEqn]
makeDerivEqns
- = tcGetEnv `thenNF_Tc` \ env ->
+ = tcGetEnv `thenNF_Tc` \ env ->
+ tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
let
- tycons = getEnv_TyCons env
- think_about_deriving = need_deriving tycons
+ tycons = filter isDataTyCon (getEnv_TyCons env)
+ -- ToDo: what about newtypes???
+ think_about_deriving = need_deriving eval_clas tycons
in
- mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
+ mapTc chk_out think_about_deriving `thenTc_`
let
(derive_these, _) = removeDups cmp_deriv think_about_deriving
eqns = map mk_eqn derive_these
returnTc eqns
where
------------------------------------------------------------------
- need_deriving :: [TyCon] -> [(Class, TyCon)]
- -- find the tycons that have `deriving' clauses
+ need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
+ -- find the tycons that have `deriving' clauses;
+ -- we handle the "every datatype in Eval" by
+ -- doing a dummy "deriving" for it.
- need_deriving tycons_to_consider
+ need_deriving eval_clas tycons_to_consider
= foldr ( \ tycon acc ->
+ let
+ acc_plus = if isLocallyDefined tycon
+ then (eval_clas, tycon) : acc
+ else acc
+ in
case (tyConDerivings tycon) of
- [] -> acc
- cs -> [ (clas,tycon) | clas <- cs ] ++ acc
+ [] -> acc_plus
+ cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
)
[]
tycons_to_consider
------------------------------------------------------------------
- chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
- chk_out whole_deriving_list this_one@(clas, tycon)
+ chk_out :: (Class, TyCon) -> TcM s ()
+ chk_out this_one@(clas, tycon)
= let
clas_key = classKey clas
- in
+ is_enumeration = isEnumerationTyCon tycon
+ is_single_con = maybeToBool (maybeTyConSingleCon tycon)
+
+ chk_clas clas_uniq clas_str cond
+ = if (clas_uniq == clas_key)
+ then checkTc cond (derivingThingErr clas_str tycon)
+ else returnTc ()
+ in
-- Are things OK for deriving Enum (if appropriate)?
- checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
- (derivingEnumErr tycon) `thenTc_`
+ chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
+
+ -- Are things OK for deriving Bounded (if appropriate)?
+ chk_clas boundedClassKey "Bounded"
+ (is_enumeration || is_single_con) `thenTc_`
-- Are things OK for deriving Ix (if appropriate)?
- checkTc (clas_key == ixClassKey
- && not (isEnumerationTyCon tycon
- || maybeToBool (maybeTyConSingleCon tycon)))
- (derivingIxErr tycon)
+ chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
------------------------------------------------------------------
cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
-- to make the rest of the equation
mk_eqn (clas, tycon)
- = (clas, tycon, tyvars, constraints)
+ = (clas, tycon, tyvars, if_not_Eval constraints)
where
+ clas_key = classKey clas
tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
tyvar_tys = mkTyVarTys tyvars
data_cons = tyConDataCons tycon
- constraints = concat (map mk_constraints data_cons)
+
+ if_not_Eval cs = if clas_key == evalClassKey then [] else cs
+
+ constraints = extra_constraints ++ concat (map mk_constraints data_cons)
+
+ -- "extra_constraints": see notes above about contexts on data decls
+ extra_constraints
+ | offensive_class = tyConTheta tycon
+ | otherwise = []
+ where
+ offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
mk_constraints data_con
- = [ (clas, instantiateTy inst_env arg_ty)
- | arg_ty <- arg_tys,
+ = [ (clas, arg_ty)
+ | arg_ty <- instd_arg_tys,
not (isPrimType arg_ty) -- No constraints for primitive types
]
where
- (con_tyvars, _, arg_tys, _) = dataConSig data_con
- inst_env = zipEqual "mk_eqn" con_tyvars tyvar_tys
- -- same number of tyvars in data constr and type constr!
+ instd_arg_tys = dataConArgTys data_con tyvar_tys
\end{code}
%************************************************************************
equation.
\begin{itemize}
\item
-Each (k,UniTyVarTemplate tv) in a solution constrains only a type
+Each (k,TyVarTy tv) in a solution constrains only a type
variable, tv.
\item
-The (k,UniTyVarTemplate tv) pairs in a solution are canonically
+The (k,TyVarTy tv) pairs in a solution are canonically
ordered by sorting on type varible, tv, (major key) and then class, k,
(minor key)
\end{itemize}
add_solns inst_decl_infos_in orig_eqns current_solns
`thenTc` \ (new_inst_infos, inst_mapper) ->
-
- -- Simplify each RHS, using a DerivingOrigin containing an
- -- inst_mapper reflecting the previous solution
let
- mk_deriv_origin clas ty
- = DerivingOrigin inst_mapper clas tycon
- where
- (tycon,_) = getAppTyCon ty
+ class_to_inst_env cls = fst (inst_mapper cls)
in
- listTc [ tcSimplifyThetas mk_deriv_origin rhs
- | (_, _, _, rhs) <- orig_eqns
- ] `thenTc` \ next_solns ->
+ -- Simplify each RHS
+
+ listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
+ | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely
let canonicalised_next_solns
= [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
- if current_solns `eq_solns` canonicalised_next_solns then
+ if (current_solns `eq_solns` canonicalised_next_solns) then
returnTc new_inst_infos
else
iterateDeriv canonicalised_next_solns
\end{code}
\begin{code}
-add_solns :: FAST_STRING
- -> Bag InstInfo -- The global, non-derived ones
+add_solns :: Bag InstInfo -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln]
-> TcM s ([InstInfo], -- The new, derived ones
InstanceMapper)
mk_deriv_inst_info (clas, tycon, tyvars, _) theta
= InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
theta
- theta -- Blarg. This is the dfun_theta slot,
- -- which is needed by buildInstanceEnv;
- -- This works ok for solving the eqns, and
- -- gen_eqns sets it to its final value
- -- (incl super class dicts) before we
- -- finally return it.
-#ifdef DEBUG
- (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
- (panic "add_soln:binds") (panic "add_soln:from_here")
- (panic "add_soln:modname") mkGeneratedSrcLoc
- (panic "add_soln:upragmas")
-#else
- bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
+ (my_panic "dfun_theta")
+
+ dummy_dfun_id
+
+ (my_panic "const_meth_ids")
+ (my_panic "binds") (my_panic "from_here")
+ (my_panic "modname") mkGeneratedSrcLoc
+ (my_panic "upragmas")
where
- bottom = panic "add_soln"
-#endif
+ dummy_dfun_id
+ = mkDictFunId bottom bottom bottom dummy_dfun_ty
+ bottom bottom bottom bottom
+ where
+ bottom = panic "dummy_dfun_id"
+
+ dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
+ -- All we need from the dfun is its "theta" part, used during
+ -- equation simplification (tcSimplifyThetas). The final
+ -- dfun_id will have the superclass dictionaries as arguments too,
+ -- but that'll be added after the equations are solved. For now,
+ -- it's enough just to make a dummy dfun with the simple theta part.
+ --
+ -- The part after the theta is dummied here as voidTy; actually it's
+ -- (C (T a b)), but it doesn't seem worth constructing it.
+ -- We can't leave it as a panic because to get the theta part we
+ -- have to run down the type!
+
+ my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
\end{code}
%************************************************************************
``you-couldn't-do-better-by-hand'' efficient.
\item
-Deriving @Text@---also pretty common, usually just for
-@show@---should also be reasonable good code.
+Deriving @Show@---also pretty common--- should also be reasonable good code.
\item
Deriving for the other classes isn't that common or that big a deal.
\begin{itemize}
\item
-Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
\item
-Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
\item
-We {\em normally} generated code only for the non-defaulted methods;
+We {\em normally} generate code only for the non-defaulted methods;
there are some exceptions for @Eq@ and (especially) @Ord@...
\item
@gen_tag_n_con_binds@, and the heuristic for deciding if one of
these is around is given by @hasCon2TagFun@.
-
The examples under the different sections below will make this
clearer.
@_tag2con_<tycon>@ function. See the examples.
\item
-We use Pass~4 of the renamer!!! Reason: we're supposed to be
+We use the renamer!!! Reason: we're supposed to be
producing @RenamedMonoBinds@ for the methods, but that means
producing correctly-uniquified code on the fly. This is entirely
possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
-So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
+So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
the renamer. What a great hack!
\end{itemize}
-> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
gen_inst_info modname fixities deriver_rn_env
- info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+ (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
=
-- Generate the various instance-related Ids
mkInstanceRelatedIds
-- Generate the bindings for the new instance declaration,
-- rename it, and check for errors
let
- (tycon,_,_) = getAppDataTyCon ty
+ (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
+ getAppDataTyCon ty
proto_mbinds
- | clas_key == eqClassKey = gen_Eq_binds tycon
- | clas_key == showClassKey = gen_Show_binds fixities tycon
- | clas_key == ordClassKey = gen_Ord_binds tycon
- | clas_key == enumClassKey = gen_Enum_binds tycon
- | clas_key == ixClassKey = gen_Ix_binds tycon
- | clas_key == readClassKey = gen_Read_binds fixities tycon
- | clas_key == binaryClassKey = gen_Binary_binds tycon
- | otherwise = panic "gen_inst_info:bad derived class"
+ = assoc "gen_inst_info:bad derived class"
+ [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(evalClassKey, gen_Eval_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(showClassKey, gen_Show_binds fixities)
+ ,(readClassKey, gen_Read_binds fixities)
+ ,(ixClassKey, gen_Ix_binds)
+ ]
+ clas_key $ tycon
+ in
+{-
+ let
+ ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
in
+ pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
+ pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
+ pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
+ pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+-}
+ -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
+
rnMtoTcM deriver_rn_env (
setExtraRn emptyUFM{-no fixities-} $
rnMethodBinds clas_Name proto_mbinds
pprPanic "gen_inst_info:renamer errs!\n"
(ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
else
- --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
-- All done
let
from_here = isLocallyDefined tycon -- If so, then from here
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
where
- clas_key = classKey clas
- clas_Name
- = let (mod, nm) = moduleNamePair clas in
- ClassName clas_key (mkPreludeCoreName mod nm) []
+ clas_key = classKey clas
+ clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas))
\end{code}
%************************************************************************
\begin{code}
gen_tag_n_con_binds :: RnEnv
- -> [(RdrName, RnName, TyCon, TagThingWanted)]
- -> TcM s RenamedHsBinds
+ -> [(RdrName, TyCon, TagThingWanted)]
+ -> TcM s (RenamedHsBinds,
+ RnEnv) -- input one with any new names added
-gen_tag_n_con_binds deriver_rn_env nm_alist_etc
- = let
- proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
- proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
+gen_tag_n_con_binds rn_env nm_alist_etc
+ =
+ let
+ -- We have the renamer's final "name funs" in our hands
+ -- (they were passed in). So we can handle ProtoNames
+ -- that refer to anything "out there". But our generated
+ -- code may also mention "con2tag" (etc.). So we need
+ -- to augment to "name funs" to include those.
+
+ names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
+ in
+ tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
+ let
+ pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll []))
+ | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
+
+ deriver_rn_env
+ = if null names_to_add
+ then rn_env else added_rn_env
+
+ (added_rn_env, errs_bag)
+ = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
+
+ ----------------
+ proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
+ proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
in
+ ASSERT(isEmptyBag errs_bag)
rnMtoTcM deriver_rn_env (
setExtraRn emptyUFM{-no fixities-} $
) `thenNF_Tc` \ (binds, errs) ->
if not (isEmptyBag errs) then
- panic "gen_inst_info:renamer errs (2)!"
+ pprPanic "gen_tag_n_con_binds:renamer errs!\n"
+ (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
else
- returnTc binds
+ returnTc (binds, deriver_rn_env)
\end{code}
%************************************************************************
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-gen_taggery_Names :: [DerivEqn]
- -> TcM s [(RdrName, RnName, -- for an assoc list
- TyCon, -- related tycon
+gen_taggery_Names :: [InstInfo]
+ -> TcM s [(RdrName, -- for an assoc list
+ TyCon, -- related tycon
TagThingWanted)]
-gen_taggery_Names eqns
- = let
- all_tycons = [ tc | (_, tc, _, _) <- eqns ]
- (tycons_of_interest, _) = removeDups cmp all_tycons
- in
- foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
- foldlTc do_tag2con names_so_far tycons_of_interest
+gen_taggery_Names inst_infos
+ = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
+ foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
+ foldlTc do_tag2con names_so_far tycons_of_interest
where
+ all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
+
+ mk_CT c ty = (c, fst (getAppTyCon ty))
+
+ all_tycons = map snd all_CTs
+ (tycons_of_interest, _) = removeDups cmp all_tycons
+
do_con2tag acc_Names tycon
= if (we_are_deriving eqClassKey tycon
- && any ( (== 0).dataConArity ) (tyConDataCons tycon))
+ && any isNullaryDataCon (tyConDataCons tycon))
|| (we_are_deriving ordClassKey tycon
&& not (maybeToBool (maybeTyConSingleCon tycon)))
|| (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- tcGetUnique `thenNF_Tc` ( \ u ->
- returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
- : acc_Names) )
+ returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
+ : acc_Names)
else
returnTc acc_Names
= if (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- tcGetUnique `thenNF_Tc` \ u1 ->
- tcGetUnique `thenNF_Tc` \ u2 ->
- returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
- : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag)
+ returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
+ : (maxtag_PN tycon, tycon, GenMaxTag)
: acc_Names)
else
returnTc acc_Names
we_are_deriving clas_key tycon
- = is_in_eqns clas_key tycon eqns
+ = is_in_eqns clas_key tycon all_CTs
where
is_in_eqns clas_key tycon [] = False
- is_in_eqns clas_key tycon ((c,t,_,_):eqns)
+ is_in_eqns clas_key tycon ((c,t):cts)
= (clas_key == classKey c && tycon == t)
- || is_in_eqns clas_key tycon eqns
+ || is_in_eqns clas_key tycon cts
\end{code}
\begin{code}
-derivingEnumErr :: TyCon -> Error
-derivingEnumErr tycon
- = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
- ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-
-derivingIxErr :: TyCon -> Error
-derivingIxErr tycon
- = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
- ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
--}
+derivingThingErr :: String -> TyCon -> Error
+
+derivingThingErr thing tycon sty
+ = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
+ 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])
\end{code}
) where
-import Ubiq
-import TcMLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
import Id ( Id(..), GenId, idType, mkUserLocal )
import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) )
import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..),
- newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars
+ newTyVarTys, tcInstTyVars, zonkTcTyVars
)
import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes )
-import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
+import TyCon ( TyCon, tyConKind, synTyConArity )
import Class ( Class(..), GenClass, classSig )
import TcMonad hiding ( rnMtoTcM )
mk_id name uniq ty
= let
- name_str = case (getOccName name) of { Unqual n -> n }
+ name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n }
in
mkUserLocal name_str uniq ty (getSrcLoc name)
in
module TcExpr ( tcExpr ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
- irrefutablePat, collectPatBinders )
+ failureFreePat, collectPatBinders )
import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
RenamedStmt(..), RenamedRecordBinds(..),
RnName{-instance Outputable-}
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
import TcType ( TcType(..), TcMaybe(..),
- tcInstId, tcInstType, tcInstTheta, tcInstTyVars,
+ tcInstId, tcInstType, tcInstSigTyVars,
+ tcInstSigType, tcInstTcType, tcInstTheta,
newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
import Class ( Class(..), classSig )
import FieldLabel ( fieldLabelName )
-import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
+import Id ( idType, dataConFieldLabels, dataConSig, Id(..), GenId )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
import Name ( Name{-instance Eq-} )
-import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
+import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
getTyVar_maybe, getFunTy_maybe, instantiateTy,
splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- monadClassKey, monadZeroClassKey
+ thenMClassOpKey, zeroClassOpKey
)
--import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
\end{code}
\begin{code}
-tcExpr (HsDo stmts src_loc)
- = -- get the Monad and MonadZero classes
- -- create type consisting of a fresh monad tyvar
- tcAddSrcLoc src_loc $
- newTyVarTy monadKind `thenNF_Tc` \ m ->
- tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
-
- -- create dictionaries for monad and possibly monadzero
- (if monad then
- tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
- newDicts DoOrigin [(monadClass, m)]
- else
- returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
- ) `thenNF_Tc` \ (m_lie, [m_id]) ->
- (if mzero then
- tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
- newDicts DoOrigin [(monadZeroClass, m)]
- else
- returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
- ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
-
- returnTc (HsDoOut stmts' m_id mz_id src_loc,
- lie `plusLIE` m_lie `plusLIE` mz_lie,
- do_ty)
- where
- monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
+tcExpr expr@(HsDo stmts src_loc)
+ = tcDoStmts stmts src_loc
\end{code}
\begin{code}
-- Check the tau-type part
tcSetErrCtxt (exprSigCtxt in_expr) $
- tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
+ tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
-- of instantiating a function involving rank-2 polymorphism, so there
-- isn't any danger of using the same tyvars twice
-- The argument type shouldn't be overloaded type (hence ASSERT)
+
+ -- To ensure that the forall'd type variables don't get unified with each
+ -- other or any other types, we make fresh *signature* type variables
+ -- and unify them with the tyvars.
let
(expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
in
ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
-
+ tcInstSigTyVars expected_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+ unifyTauTyLists (mkTyVarTys expected_tyvars) sig_tyvar_tys `thenTc_`
+
-- Type-check the arg and unify with expected type
tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
unifyTauTy expected_tau actual_arg_ty `thenTc_` (
-- So now s' isn't unconstrained because it's linked to a.
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
+
tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
- tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
- zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
checkSigTyVarsGivenGlobals
- (env_tyvars `unionTyVarSets` free_tyvars)
+ (tyVarsOfType expected_arg_ty)
expected_tyvars expected_tau `thenTc_`
-- Check that there's no overloading involved
= -- Look up the Id and instantiate its type
tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
- (case maybe_local of
- Just tc_id -> let
- (tyvars, rho) = splitForAllTy (idType tc_id)
- in
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) ->
- let
- rho' = instantiateTy tenv rho
- in
- returnNF_Tc (TcId tc_id, arg_tys', rho')
-
- Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
- let
- (tyvars, rho) = splitForAllTy (idType id)
- in
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
- tcInstType tenv rho `thenNF_Tc` \ rho' ->
- returnNF_Tc (RealId id, arg_tys, rho')
-
- ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
-
- -- Is it overloaded?
- case splitRhoTy rho of
- ([], tau) -> -- Not overloaded, so just make a type application
- returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
-
- (theta, tau) -> -- Overloaded, so make a Method inst
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
- returnNF_Tc (HsVar meth_id, lie, tau)
-\end{code}
+ case maybe_local of
+ Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
+ Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
+ let
+ (tyvars, rho) = splitForAllTy inst_ty
+ in
+ instantiate_it2 (RealId id) tyvars rho
+ where
+ -- The instantiate_it loop runs round instantiating the Id.
+ -- It has to be a loop because we are now prepared to entertain
+ -- types like
+ -- f:: forall a. Eq a => forall b. Baz b => tau
+ -- We want to instantiate this to
+ -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
+ instantiate_it tc_id_occ ty
+ = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
+ instantiate_it2 tc_id_occ tyvars rho
+
+ instantiate_it2 tc_id_occ tyvars rho
+ | null theta -- Is it overloaded?
+ = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+
+ | otherwise -- Yes, it's overloaded
+ = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
+ tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
+ instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
+
+ where
+ (theta, tau) = splitRhoTy rho
+ arg_tys = mkTyVarTys tyvars
+\end{code}
%************************************************************************
%* *
-\subsection{@tcQuals@ typchecks list comprehension qualifiers}
+\subsection{@tcQuals@ typechecks list-comprehension qualifiers}
%* *
%************************************************************************
%************************************************************************
\begin{code}
-tcDoStmts :: Bool -- True => require a monad
- -> TcType s -- m
- -> [RenamedStmt]
- -> TcM s (([TcStmt s],
- Bool, -- True => Monad
- Bool), -- True => MonadZero
- LIE s,
- TcType s)
-
-tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
- = tcAddSrcLoc src_loc $
- tcSetErrCtxt (stmtCtxt stmt) $
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- (if monad then
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty
- else
- returnTc ()
- ) `thenTc_`
- returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
-
-tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
- = tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (ExprStmt exp' src_loc, exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
- = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt stmt) (
- tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
-
- tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+tcDoStmts stmts src_loc
+ = -- get the Monad and MonadZero classes
+ -- create type consisting of a fresh monad tyvar
+ tcAddSrcLoc src_loc $
+ newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
+
+
+ -- Build the then and zero methods in case we need them
+ tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
+ tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ newMethod DoOrigin
+ (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
+ newMethod DoOrigin
+ (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
+
+ let
+ get_m_arg ty
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
+ unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
+ returnTc arg_ty
+
+ go [stmt@(ExprStmt exp src_loc)]
+ = tcAddSrcLoc src_loc $
+ tcSetErrCtxt (stmtCtxt stmt) $
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
+
+ go (stmt@(ExprStmt exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ get_m_arg exp_ty `thenTc` \ a ->
+ returnTc (a, exp', exp_lie)
+ )) `thenTc` \ (a, exp', exp_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (ExprStmtOut exp' src_loc a b : stmts',
+ exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
+ stmts_ty)
+
+ go (stmt@(BindStmt pat exp src_loc) : stmts)
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
-- See comments with tcListComp on GeneratorQual
- newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
- unifyTauTy a pat_ty `thenTc_`
- unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
- returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
- )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
- tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
- returnTc ((stmt':stmts', True, mzero || not failure_free),
- stmt_lie `plusLIE` stmts_lie,
- stmts_ty)
-
-tcDoStmts monad m (LetStmt binds : stmts)
- = tcBindsAndThen -- No error context, but a binding group is
- combine -- rather a large thing for an error context anyway
- binds
- (tcDoStmts monad m stmts)
- where
- combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
+ get_m_arg exp_ty `thenTc` \ a ->
+ unifyTauTy a pat_ty `thenTc_`
+ returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
+ )) `thenTc` \ (a, pat', exp', stmt_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
+ stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
+ (if failureFreePat pat' then emptyLIE else mz_lie),
+ stmts_ty)
+
+ go (LetStmt binds : stmts)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (go stmts)
+ where
+ combine binds' stmts' = LetStmt binds' : stmts'
+ in
+ go stmts `thenTc` \ (stmts', final_lie, final_ty) ->
+ returnTc (HsDoOut stmts' then_id zero_id src_loc,
+ final_lie,
+ final_ty)
\end{code}
Game plan for record bindings
\section[TcGRHSs]{Typecheck guarded right-hand-sides}
\begin{code}
+#include "HsVersions.h"
+
module TcGRHSs ( tcGRHSsAndBinds ) where
-import Ubiq{-uitous-}
-import TcLoop -- for paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(TcLoop) -- for paranoia checking
import HsSyn ( GRHSsAndBinds(..), GRHS(..),
HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake )
\begin{code}
#include "HsVersions.h"
-module TcGenDeriv {- (
+module TcGenDeriv (
a_Expr,
a_PN,
a_Pat,
d_PN,
d_Pat,
dh_PN,
- eqH_PN,
+ eqH_Int_PN,
eqTag_Expr,
eq_PN,
error_PN,
false_Expr,
false_PN,
geH_PN,
- gen_Binary_binds,
+ gen_Bounded_binds,
gen_Enum_binds,
+ gen_Eval_binds,
gen_Eq_binds,
gen_Ix_binds,
gen_Ord_binds,
gtTag_Expr,
gt_PN,
leH_PN,
- ltH_PN,
+ ltH_Int_PN,
ltTag_Expr,
lt_PN,
minusH_PN,
true_Expr,
true_PN,
- con2tag_FN, tag2con_FN, maxtag_FN,
con2tag_PN, tag2con_PN, maxtag_PN,
TagThingWanted(..)
- ) -} where
+ ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
-import RnHsSyn ( RnName(..), RenamedFixityDecl(..) )
+import RnHsSyn ( RenamedFixityDecl(..) )
+--import RnUtils
---import RnMonad4 -- initRn4, etc.
-import RnUtils
-
-import Id ( GenId, dataConArity, dataConTag,
- dataConSig, fIRST_TAG,
+import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag,
+ dataConRawArgTys, fIRST_TAG,
isDataCon, DataCon(..), ConTag(..) )
import IdUtils ( primOpId )
import Maybes ( maybeToBool )
---import Name ( Name(..) )
-import Outputable
-import PrimOp
---import PrelInfo
-import Pretty
+import Name ( moduleNamePair, origName, RdrName(..) )
+import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT )
+import PrelVals ( eRROR_ID )
+
+import PrimOp ( PrimOp(..) )
import SrcLoc ( mkGeneratedSrcLoc )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
import Type ( eqTy, isPrimType )
-import Unique
-import Util
+import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
+ floatPrimTy, doublePrimTy
+ )
+import TysWiredIn ( falseDataCon, trueDataCon, intDataCon )
+--import Unique
+import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
\end{code}
%************************************************************************
%* *
-\subsection[TcGenDeriv-classes]{Generating code, by derivable class}
+\subsection{Generating code, by derivable class}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations}
+\subsubsection{Generating @Eq@ instance declarations}
%* *
%************************************************************************
\end{itemize}
\begin{code}
-foo_TcGenDeriv = panic "Nothing in TcGenDeriv LATER ToDo"
-
-{- LATER:
gen_Eq_binds :: TyCon -> RdrNameMonoBinds
gen_Eq_binds tycon
- = case (partition (\ con -> dataConArity con == 0)
- (tyConDataCons tycon))
- of { (nullary_cons, nonnullary_cons) ->
- let
+ = let
+ (nullary_cons, nonnullary_cons)
+ = partition isNullaryDataCon (tyConDataCons tycon)
+
rest
- = if null nullary_cons then
+ = if (null nullary_cons) then
case maybeTyConSingleCon tycon of
Just _ -> []
Nothing -> -- if cons don't match, then False
else -- calc. and compare the tags
[([a_Pat, b_Pat],
untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
- (cmp_tags_Expr eqH_PN ah_PN bh_PN true_Expr false_Expr))]
+ (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
in
mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
`AndMonoBinds` boring_ne_method
- }
where
------------------------------------------------------------------
pats_etc data_con
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInId data_con)
- as_needed = take (dataConArity data_con) as_PNs
- bs_needed = take (dataConArity data_con) bs_PNs
- tys_needed = case (dataConSig data_con) of
- (_,_, arg_tys, _) -> arg_tys
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ tys_needed = dataConRawArgTys data_con
in
([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
where
+ nested_eq_expr [] [] [] = true_Expr
+ nested_eq_expr tys as bs
+ = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+ where
+ nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
+{-OLD:
nested_eq_expr [] [] [] = true_Expr
- nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar b)
+ nested_eq_expr [ty] [a] [b] =
nested_eq_expr (t:ts) (a:as) (b:bs)
= let
rest_expr = nested_eq_expr ts as bs
in
and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
+-}
boring_ne_method
- = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
- HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
- )
+ = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
+ HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
\end{code}
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations}
+\subsubsection{Generating @Ord@ instance declarations}
%* *
%************************************************************************
We do all the other @Ord@ methods with calls to @compare@:
\begin{verbatim}
instance ... (Ord <wurble> <wurble>) where
- a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
- a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
- a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
- a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
+ a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
+ a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
+ a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
- max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
- min a b = case compare a b of { LT -> a; EQ -> b; GT -> b }
+ max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
+ min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
-- compare to come...
\end{verbatim}
\begin{verbatim}
compare a b = case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
- case (a# ==# b#) of {
+ case (a# ==# b#) of {
True -> cmp_eq a b
False -> case (a# <# b#) of
True -> _LT
cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
else
untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
- (cmp_tags_Expr eqH_PN ah_PN bh_PN
+ (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
-- True case; they are equal
-- If an enumeration type we are done; else
-- recursively compare their components
)
-- False case; they aren't equal
-- So we need to do a less-than comparison on the tags
- (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
+ (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
(nullary_cons, nonnullary_cons)
= partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInId data_con)
- as_needed = take (dataConArity data_con) as_PNs
- bs_needed = take (dataConArity data_con) bs_PNs
- tys_needed = case (dataConSig data_con) of
- (_,_, arg_tys, _) -> arg_tys
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ tys_needed = dataConRawArgTys data_con
nested_compare_expr [ty] [a] [b]
= careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
+\subsubsection{Generating @Enum@ instance declarations}
%* *
%************************************************************************
= enum_from `AndMonoBinds` enum_from_then
where
enum_from
- = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
- untag_Expr tycon [(a_PN, ah_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsVar (maxtag_PN tycon)))))
+ = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
+ untag_Expr tycon [(a_PN, ah_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (HsVar (maxtag_PN tycon)))
enum_from_then
- = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
- untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_then_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
- (HsVar (maxtag_PN tycon)))))
+ = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
+ untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_then_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (mk_easy_App mkInt_PN [bh_PN])
+ (HsVar (maxtag_PN tycon)))
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Generating @Eval@ instance declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+gen_Eval_binds tycon = EmptyMonoBinds
\end{code}
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
+\subsubsection{Generating @Bounded@ instance declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+gen_Bounded_binds tycon
+ = if isEnumerationTyCon tycon then
+ min_bound_enum `AndMonoBinds` max_bound_enum
+ else
+ ASSERT(length data_cons == 1)
+ min_bound_1con `AndMonoBinds` max_bound_1con
+ where
+ data_cons = tyConDataCons tycon
+
+ ----- enum-flavored: ---------------------------
+ min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
+ max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
+
+ data_con_1 = head data_cons
+ data_con_N = last data_cons
+ data_con_1_PN = origName data_con_1
+ data_con_N_PN = origName data_con_N
+
+ ----- single-constructor-flavored: -------------
+ arity = dataConArity data_con_1
+
+ min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
+ mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
+ max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
+ mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Generating @Ix@ instance declarations}
%* *
%************************************************************************
enum_index `AndMonoBinds` enum_inRange
enum_range
- = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
- untag_Expr tycon [(a_PN, ah_PN)] (
- untag_Expr tycon [(b_PN, bh_PN)] (
- HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
- enum_from_to_Expr
- (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
- (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
- ))))
+ = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
+ untag_Expr tycon [(a_PN, ah_PN)] $
+ untag_Expr tycon [(b_PN, bh_PN)] $
+ HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ HsPar (enum_from_to_Expr
+ (mk_easy_App mkInt_PN [ah_PN])
+ (mk_easy_App mkInt_PN [bh_PN]))
enum_index
= mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
- HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
+ HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(d_PN, dh_PN)] (
let
- grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
+ grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
in
HsCase
- (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
+ (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
[PatMatch (VarPatIn c_PN)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
mkGeneratedSrcLoc
untag_Expr tycon [(a_PN, ah_PN)] (
untag_Expr tycon [(b_PN, bh_PN)] (
untag_Expr tycon [(c_PN, ch_PN)] (
- HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
+ HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
(OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
) {-else-} (
false_Expr
data_con
= case maybeTyConSingleCon tycon of -- just checking...
Nothing -> panic "get_Ix_binds"
- Just dc -> let
- (_, _, arg_tys, _) = dataConSig dc
- in
- if any isPrimType arg_tys then
+ Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
else
dc
con_arity = dataConArity data_con
- data_con_PN = Prel (WiredInId data_con)
+ data_con_PN = origName data_con
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
- con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
+ con_expr xs = mk_easy_App data_con_PN xs
- as_needed = take (dataConArity data_con) as_PNs
- bs_needed = take (dataConArity data_con) bs_PNs
- cs_needed = take (dataConArity data_con) cs_PNs
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ cs_needed = take con_arity cs_PNs
--------------------------------------------------------------
single_con_range
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
+\subsubsection{Generating @Read@ instance declarations}
%* *
%************************************************************************
\begin{code}
gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
-gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
gen_Read_binds fixities tycon
= reads_prec `AndMonoBinds` read_list
where
-----------------------------------------------------------------------
read_list = mk_easy_FunMonoBind readList_PN [] []
- (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
+ (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
reads_prec
= let
where
read_con data_con -- note: "b" is the string being "read"
= let
- data_con_PN = Prel (WiredInId data_con)
+ data_con_PN = origName data_con
data_con_str= snd (moduleNamePair data_con)
- as_needed = take (dataConArity data_con) as_PNs
- bs_needed = take (dataConArity data_con) bs_PNs
- con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
- nullary_con = dataConArity data_con == 0
+ con_arity = dataConArity data_con
+ as_needed = take con_arity as_PNs
+ bs_needed = take con_arity bs_PNs
+ con_expr = mk_easy_App data_con_PN as_needed
+ nullary_con = isNullaryDataCon data_con
con_qual
= GeneratorQual
= if nullary_con then -- must be False (parens are surely optional)
false_Expr
else -- parens depend on precedence...
- OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
+ HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
in
HsApp (
- readParen_Expr read_paren_arg (
+ readParen_Expr read_paren_arg $ HsPar $
HsLam (mk_easy_Match [c_Pat] [] (
ListComp (ExplicitTuple [con_expr,
if null bs_needed then d_Expr else HsVar (last bs_needed)])
(con_qual : field_quals)))
- )) (HsVar b_PN)
+ ) (HsVar b_PN)
where
mk_qual draw_from (con_field, str_left)
= (HsVar str_left, -- what to draw from down the line...
GeneratorQual
(TuplePatIn [VarPatIn con_field, VarPatIn str_left])
(HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+\end{code}
+%************************************************************************
+%* *
+\subsubsection{Generating @Show@ instance declarations}
+%* *
+%************************************************************************
+
+Ignoring all the infix-ery mumbo jumbo (ToDo)
+
+\begin{code}
+gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
gen_Show_binds fixities tycon
= shows_prec `AndMonoBinds` show_list
where
-----------------------------------------------------------------------
show_list = mk_easy_FunMonoBind showList_PN [] []
- (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
+ (HsApp (HsVar _showList_PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
shows_prec
= mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
where
pats_etc data_con
= let
- data_con_PN = Prel (WiredInId data_con)
- bs_needed = take (dataConArity data_con) bs_PNs
+ data_con_PN = origName data_con
+ con_arity = dataConArity data_con
+ bs_needed = take con_arity bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- nullary_con = dataConArity data_con == 0
+ nullary_con = isNullaryDataCon data_con
show_con
= let (mod, nm) = moduleNamePair data_con
([a_Pat, con_pat], show_con)
else
([a_Pat, con_pat],
- showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))
- (nested_compose_Expr show_thingies))
+ showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
+ (HsPar (nested_compose_Expr show_thingies)))
where
spacified [] = []
spacified [x] = [x]
%************************************************************************
%* *
-\subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
-%* *
-%************************************************************************
-
-ToDo: NOT DONE YET.
-
-\begin{code}
-gen_Binary_binds :: TyCon -> RdrNameMonoBinds
-
-gen_Binary_binds tycon
- = panic "gen_Binary_binds"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
%* *
%************************************************************************
= GenCon2Tag | GenTag2Con | GenMaxTag
gen_tag_n_con_monobind
- :: (RdrName, RnName, -- (proto)Name for the thing in question
+ :: (RdrName, -- (proto)Name for the thing in question
TyCon, -- tycon in question
TagThingWanted)
-> RdrNameMonoBinds
-gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
+gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
- var_PN = Prel (WiredInId var)
+ var_PN = origName var
-gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
+gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
([lit_pat], HsVar var_PN)
where
lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
- var_PN = Prel (WiredInId var)
+ var_PN = origName var
-gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
+gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
= mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
where
max_tag = case (tyConDataCons tycon) of
%************************************************************************
%* *
-\subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
+\subsection{Utility bits for generating bindings}
%* *
%************************************************************************
= FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
mk_easy_Match pats binds expr
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
- pats
+ = mk_match pats expr (mkbind binds)
where
mkbind [] = EmptyBinds
mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
mk_FunMonoBind fun pats_and_exprs
- = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc
+ = FunMonoBind fun False{-not infix-}
+ [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
+ mkGeneratedSrcLoc
+
+mk_match pats expr binds
+ = foldr PatMatch
+ (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
+ (map paren pats)
where
- mk_match (pats, expr)
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
- pats
+ paren p@(VarPatIn _) = p
+ paren other_p = ParPatIn other_p
+\end{code}
+
+\begin{code}
+mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
\end{code}
\begin{code}
cmp_eq_Expr = compare_gen_Case cmp_eq_PN
compare_gen_Case fun lt eq gt a b
- = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-}
+ = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
[PatMatch (ConPatIn ltTag_PN [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
compare_gen_Case compare_PN lt eq gt a b
else -- we have to do something special for primitive things...
- HsIf (OpApp a (HsVar relevant_eq_op) b)
+ HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
eq
- (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
+ (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
mkGeneratedSrcLoc
where
relevant_eq_op = assoc_ty_id eq_op_tbl ty
where
res = [id | (ty',id) <- tyids, eqTy ty ty']
-eq_op_tbl = [
- (charPrimTy, Prel (WiredInId (primOpId CharEqOp))),
- (intPrimTy, Prel (WiredInId (primOpId IntEqOp))),
- (wordPrimTy, Prel (WiredInId (primOpId WordEqOp))),
- (addrPrimTy, Prel (WiredInId (primOpId AddrEqOp))),
- (floatPrimTy, Prel (WiredInId (primOpId FloatEqOp))),
- (doublePrimTy, Prel (WiredInId (primOpId DoubleEqOp))) ]
-
-lt_op_tbl = [
- (charPrimTy, Prel (WiredInId (primOpId CharLtOp))),
- (intPrimTy, Prel (WiredInId (primOpId IntLtOp))),
- (wordPrimTy, Prel (WiredInId (primOpId WordLtOp))),
- (addrPrimTy, Prel (WiredInId (primOpId AddrLtOp))),
- (floatPrimTy, Prel (WiredInId (primOpId FloatLtOp))),
- (doublePrimTy, Prel (WiredInId (primOpId DoubleLtOp))) ]
+eq_op_tbl =
+ [(charPrimTy, eqH_Char_PN)
+ ,(intPrimTy, eqH_Int_PN)
+ ,(wordPrimTy, eqH_Word_PN)
+ ,(addrPrimTy, eqH_Addr_PN)
+ ,(floatPrimTy, eqH_Float_PN)
+ ,(doublePrimTy, eqH_Double_PN)
+ ]
+
+lt_op_tbl =
+ [(charPrimTy, ltH_Char_PN)
+ ,(intPrimTy, ltH_Int_PN)
+ ,(wordPrimTy, ltH_Word_PN)
+ ,(addrPrimTy, ltH_Addr_PN)
+ ,(floatPrimTy, ltH_Float_PN)
+ ,(doublePrimTy, ltH_Double_PN)
+ ]
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
OpApp a (HsVar eq_PN) b
untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
- = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
+ = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
[PatMatch (VarPatIn put_tag_here)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
mkGeneratedSrcLoc
where
grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
-cmp_tags_Expr :: RdrName -- Comparison op
- -> RdrName -> RdrName -- Things to compare
+cmp_tags_Expr :: RdrName -- Comparison op
+ -> RdrName -> RdrName -- Things to compare
-> RdrNameHsExpr -- What to return if true
- -> RdrNameHsExpr -- What to return if false
+ -> RdrNameHsExpr -- What to return if false
-> RdrNameHsExpr
cmp_tags_Expr op a b true_case false_case
- = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
+ = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
enum_from_to_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
-nested_compose_Expr [e] = e
+nested_compose_Expr [e] = parenify e
nested_compose_Expr (e:es)
- = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
+ = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
+
+parenify e@(HsVar _) = e
+parenify e = HsPar e
\end{code}
\begin{code}
-a_PN = Unk SLIT("a")
-b_PN = Unk SLIT("b")
-c_PN = Unk SLIT("c")
-d_PN = Unk SLIT("d")
-ah_PN = Unk SLIT("a#")
-bh_PN = Unk SLIT("b#")
-ch_PN = Unk SLIT("c#")
-dh_PN = Unk SLIT("d#")
-cmp_eq_PN = Unk SLIT("cmp_eq")
-rangeSize_PN = Unk SLIT("rangeSize")
-
-as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
+a_PN = Unqual SLIT("a")
+b_PN = Unqual SLIT("b")
+c_PN = Unqual SLIT("c")
+d_PN = Unqual SLIT("d")
+ah_PN = Unqual SLIT("a#")
+bh_PN = Unqual SLIT("b#")
+ch_PN = Unqual SLIT("c#")
+dh_PN = Unqual SLIT("d#")
+cmp_eq_PN = Unqual SLIT("cmp_eq")
+rangeSize_PN = Unqual SLIT("rangeSize")
+
+as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
eq_PN = prelude_method SLIT("Eq") SLIT("==")
ne_PN = prelude_method SLIT("Eq") SLIT("/=")
max_PN = prelude_method SLIT("Ord") SLIT("max")
min_PN = prelude_method SLIT("Ord") SLIT("min")
compare_PN = prelude_method SLIT("Ord") SLIT("compare")
-ltTag_PN = Prel (WiredInId ltDataCon)
-eqTag_PN = Prel (WiredInId eqDataCon)
-gtTag_PN = Prel (WiredInId gtDataCon)
+minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound")
+maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound")
+ltTag_PN = Unqual SLIT("LT")
+eqTag_PN = Unqual SLIT("EQ")
+gtTag_PN = Unqual SLIT("GT")
enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
plus_PN = prelude_method SLIT("Num") SLIT("+")
times_PN = prelude_method SLIT("Num") SLIT("*")
-false_PN = Prel (WiredInId falseDataCon)
-true_PN = Prel (WiredInId trueDataCon)
-eqH_PN = Prel (WiredInId (primOpId IntEqOp))
-geH_PN = Prel (WiredInId (primOpId IntGeOp))
-leH_PN = Prel (WiredInId (primOpId IntLeOp))
-ltH_PN = Prel (WiredInId (primOpId IntLtOp))
-minusH_PN = Prel (WiredInId (primOpId IntSubOp))
+false_PN = prelude_val pRELUDE SLIT("False")
+true_PN = prelude_val pRELUDE SLIT("True")
+eqH_Char_PN = prelude_primop CharEqOp
+ltH_Char_PN = prelude_primop CharLtOp
+eqH_Word_PN = prelude_primop WordEqOp
+ltH_Word_PN = prelude_primop WordLtOp
+eqH_Addr_PN = prelude_primop AddrEqOp
+ltH_Addr_PN = prelude_primop AddrLtOp
+eqH_Float_PN = prelude_primop FloatEqOp
+ltH_Float_PN = prelude_primop FloatLtOp
+eqH_Double_PN = prelude_primop DoubleEqOp
+ltH_Double_PN = prelude_primop DoubleLtOp
+eqH_Int_PN = prelude_primop IntEqOp
+ltH_Int_PN = prelude_primop IntLtOp
+geH_PN = prelude_primop IntGeOp
+leH_PN = prelude_primop IntLeOp
+minusH_PN = prelude_primop IntSubOp
and_PN = prelude_val pRELUDE SLIT("&&")
not_PN = prelude_val pRELUDE SLIT("not")
append_PN = prelude_val pRELUDE_LIST SLIT("++")
map_PN = prelude_val pRELUDE_LIST SLIT("map")
compose_PN = prelude_val pRELUDE SLIT(".")
-mkInt_PN = Prel (WiredInId intDataCon)
-error_PN = Prel (WiredInId eRROR_ID)
-showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
+mkInt_PN = prelude_val pRELUDE_BUILTIN SLIT("I#")
+error_PN = prelude_val pRELUDE SLIT("error")
showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
-_showList_PN = prelude_val pRELUDE SLIT("_showList")
-_readList_PN = prelude_val pRELUDE SLIT("_readList")
+showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace")
+_showList_PN = prelude_val pRELUDE SLIT("__showList")
+_readList_PN = prelude_val pRELUDE SLIT("__readList")
-prelude_val m s = Imp m s [m] s
-prelude_method c o = Imp pRELUDE o [pRELUDE] o -- class not used...
+prelude_val m s = Unqual s
+prelude_method c o = Unqual o
+prelude_primop o = origName (primOpId o)
a_Expr = HsVar a_PN
b_Expr = HsVar b_PN
c_Pat = VarPatIn c_PN
d_Pat = VarPatIn d_PN
-
con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
con2tag_PN tycon
= let (mod, nm) = moduleNamePair tycon
con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod con2tag [mod] con2tag
+ (if fromPrelude mod then Unqual else Qual mod) con2tag
tag2con_PN tycon
= let (mod, nm) = moduleNamePair tycon
tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod tag2con [mod] tag2con
+ (if fromPrelude mod then Unqual else Qual mod) tag2con
maxtag_PN tycon
= let (mod, nm) = moduleNamePair tycon
maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- Imp mod maxtag [mod] maxtag
-
-
-con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName
-
-tag2con_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
-
-maxtag_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
-
-con2tag_FN tycon
- = let (mod, nm) = moduleNamePair tycon
- con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
- in
- mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
--}
+ (if fromPrelude mod then Unqual else Qual mod) maxtag
\end{code}
-
checker.
\begin{code}
+#include "HsVersions.h"
+
module TcHsSyn (
TcIdBndr(..), TcIdOcc(..),
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
- tcIdType,
+ tcIdType, tcIdTyVars,
zonkBinds,
zonkDictBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-- friends:
import HsSyn -- oodles of it
import Name ( Name{--O only-} )
import TcMonad hiding ( rnMtoTcM )
import TcType ( TcType(..), TcMaybe, TcTyVar(..),
- zonkTcTypeToType, zonkTcTyVarToTyVar,
- tcInstType
+ zonkTcTypeToType, zonkTcTyVarToTyVar
)
import Usage ( UVar(..) )
import Util ( zipEqual, panic, pprPanic, pprTrace )
import PprType ( GenType, GenTyVar ) -- instances
-import Type ( mkTyVarTy )
+import Type ( mkTyVarTy, tyVarsOfType )
import TyVar ( GenTyVar {- instances -},
- TyVarEnv(..), growTyVarEnvList ) -- instances
+ TyVarEnv(..), growTyVarEnvList, emptyTyVarSet )
import TysWiredIn ( voidTy )
import Unique ( Unique ) -- instances
import UniqFM
tcIdType :: TcIdOcc s -> TcType s
tcIdType (TcId id) = idType id
tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
-\end{code}
-
+tcIdTyVars (TcId id) = tyVarsOfType (idType id)
+tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
+\end{code}
\begin{code}
instance Eq (TcIdOcc s) where
zonkExpr te ve (HsLet binds expr)
= zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
+ zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo"
-zonkExpr te ve (HsDoOut stmts m_id mz_id src_loc)
+zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc)
= zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
- where
- m_new = zonkIdOcc ve m_id
- mz_new = zonkIdOcc ve mz_id
+ returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc)
zonkExpr te ve (ListComp expr quals)
= zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) ->
zonkStmts :: TyVarEnv Type -> IdEnv Id
-> [TcStmt s] -> NF_TcM s [TypecheckedStmt]
-zonkStmts te ve []
- = returnNF_Tc []
+zonkStmts te ve [] = returnNF_Tc []
+
+zonkStmts te ve [ExprStmt expr locn]
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc [ExprStmt new_expr locn]
-zonkStmts te ve (BindStmt pat expr src_loc : stmts)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+zonkStmts te ve (ExprStmtOut expr locn a b : stmts)
+ = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
+ zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts)
+
+zonkStmts te ve (LetStmt binds : stmts)
+ = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
+ zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (LetStmt new_binds : new_stmts)
+
+zonkStmts te ve (BindStmtOut pat expr locn a b : stmts)
+ = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
+ zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
let
new_ve = extend_ve ve ids
in
zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (BindStmt new_pat new_expr src_loc : new_stmts)
+ returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
-zonkStmts te ve (ExprStmt expr src_loc : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr src_loc : new_stmts)
-zonkStmts te ve (LetStmt binds : stmts)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (LetStmt new_binds : new_stmts)
-------------------------------------------------------------------------
zonkRbinds :: TyVarEnv Type -> IdEnv Id
module TcIfaceSig ( tcInterfaceSigs ) where
-import Ubiq
+IMP_Ubiq()
import TcMonad hiding ( rnMtoTcM )
import TcMonoType ( tcPolyType )
import CmdLineOpts ( opt_CompilingPrelude )
import Id ( mkImported )
--import Name ( Name(..) )
+import Maybes ( maybeToBool )
import Pretty
import Util ( panic )
tcInterfaceSigs [] = returnTc []
-tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs)
+tcInterfaceSigs (Sig name ty pragmas src_loc : sigs)
+ | has_full_name
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
fixTc ( \ rec_id ->
tcInterfaceSigs sigs `thenTc` \ sigs' ->
returnTc (id:sigs')
-
-tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs)
- = case odd_name of
+ | otherwise -- odd name...
+ = case name of
WiredInId _ | opt_CompilingPrelude
-> tcInterfaceSigs sigs
_ -> tcAddSrcLoc src_loc $
- failTc (ifaceSigNameErr odd_name)
+ failTc (ifaceSigNameErr name)
+ where
+ has_full_name = maybeToBool full_name_maybe
+ (Just full_name) = full_name_maybe
+ full_name_maybe = case name of
+ RnName fn -> Just fn
+ RnImplicit fn -> Just fn
+ _ -> Nothing
ifaceSigNameErr name sty
= ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
module TcInstDcls (
tcInstDecls1,
tcInstDecls2,
- processInstBinds
+ processInstBinds,
+ newMethodId
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
SpecInstSig(..), HsBinds(..), Bind(..),
import TcMonad hiding ( rnMtoTcM )
-import GenSpecEtc ( checkSigTyVars )
+import GenSpecEtc ( checkSigTyVarsGivenGlobals )
import Inst ( Inst, InstOrigin(..), InstanceMapper(..),
newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
import TcKind ( TcKind, unifyKind )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcContext, tcMonoTypeKind )
-import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas )
+import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType(..), TcTyVar(..),
- tcInstSigTyVars, tcInstType, tcInstTheta
+ tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
)
-import Unify ( unifyTauTy )
+import Unify ( unifyTauTy, unifyTauTyLists )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
import TyCon ( isSynTyCon, derivedFor )
import Type ( GenType(..), ThetaType(..), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
- getTyCon_maybe, maybeBoxedPrimType
+ getTyCon_maybe, maybeBoxedPrimType, splitRhoTy
)
-import TyVar ( GenTyVar, mkTyVarSet )
+import TyVar ( GenTyVar, mkTyVarSet, unionTyVarSets )
import TysWiredIn ( stringTy )
import Unique ( Unique )
import Util ( zipEqual, panic )
let
sc_theta' = super_classes `zip` repeat inst_ty'
origin = InstanceDeclOrigin
- mk_method sel_id = newMethodId sel_id inst_ty' origin locn
+ mk_method sel_id = newMethodId sel_id inst_ty' origin
in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
returnTc (const_lie `plusLIE` spec_lie, inst_binds)
\end{code}
+============= OLD ================
+
@mkMethodId@ manufactures an id for a local method.
It's rather turgid stuff, because there are two cases:
So for these we just make a local (non-Inst) id with a suitable type.
How disgusting.
+=============== END OF OLD ===================
\begin{code}
-newMethodId sel_id inst_ty origin loc
- = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
+newMethodId sel_id inst_ty origin
+ = newMethod origin (RealId sel_id) [inst_ty]
+
+
+{- REMOVE SOON: (this was pre-split-poly selector types)
+let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
(_:meth_theta) = sel_theta -- The local theta is all except the
-- first element of the context
in
`thenNF_Tc` \ method_ty ->
newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id ->
returnNF_Tc (emptyLIE, meth_id)
+-}
\end{code}
The next function makes a default method which calls the global default method, at
-> NF_TcM s (TcExpr s)
makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
- = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) ->
-
- -- def_op_id = /\ op_tyvars -> \ op_dicts ->
- -- defm_id inst_ty op_tyvars this_dict op_dicts
- returnNF_Tc (
- mkHsTyLam op_tyvars (
- mkHsDictLam op_dicts (
- mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
- (inst_ty : mkTyVarTys op_tyvars))
- (this_dict : op_dicts)
- )))
+ =
+ -- def_op_id = defm_id inst_ty this_dict
+ returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
where
idx = tag - 1
meth_id = meth_ids !! idx
defm_id = defm_ids !! idx
- (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id)
makeInstanceDeclNoDefaultExpr
:: InstOrigin s
-> NF_TcM s (TcExpr s)
makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
- = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) ->
-
+ =
-- Produce a warning if the default instance method
-- has been omitted when one exists in the class
warnTc (not err_defm_ok)
(omitDefaultMethodWarn clas_op clas_name inst_ty)
`thenNF_Tc_`
- returnNF_Tc (mkHsTyLam op_tyvars (
- mkHsDictLam op_dicts (
- HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau])
- (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+ returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
+ (HsLitOut (HsString (_PK_ error_msg)) stringTy))
where
idx = tag - 1
meth_id = meth_ids !! idx
clas_op = (classOps clas) !! idx
defm_id = defm_ids !! idx
- (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
let
tag = classOpTagByString clas occ
method_id = method_ids !! (tag-1)
+ method_ty = tcIdType method_id
in
- -- The "method" might be a RealId, when processInstBinds is used by
- -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings
- (case method_id of
- TcId id -> returnNF_Tc (idType id)
- RealId id -> tcInstType [] (idType id)
- ) `thenNF_Tc` \ method_ty ->
+ tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) ->
let
- (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
+ (method_theta, method_tau) = splitRhoTy method_rho
in
newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
-- The latter is needed just so we can return an AbsBinds wrapped
-- up inside a MonoBinds.
+
+ -- Make the method_tyvars into signature tyvars so they
+ -- won't get unified with anything.
+ tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+ unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_`
+
newLocalId occ method_tau `thenNF_Tc` \ local_id ->
newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
let
- inst_method_tyvars = inst_tyvars ++ method_tyvars
+ inst_tyvar_set = mkTyVarSet inst_tyvars
+ inst_method_tyvar_set = inst_tyvar_set `unionTyVarSets` (mkTyVarSet sig_tyvars)
in
-- Typecheck the method
tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-- Here we must simplify constraints on "a" to catch all
-- the Bar-ish things.
tcAddErrCtxt (methodSigCtxt op method_ty) (
+ checkSigTyVarsGivenGlobals
+ inst_tyvar_set
+ sig_tyvars method_tau `thenTc_`
+
tcSimplifyAndCheck
- (mkTyVarSet inst_method_tyvars)
+ inst_method_tyvar_set
(method_dicts `plusLIE` avail_insts)
lieIop
) `thenTc` \ (f_dicts, dict_binds) ->
+
returnTc ([tag],
f_dicts,
VarMonoBind method_id
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
isCcallishClass clas
- && not opt_CompilingPrelude -- which allows anything
- && maybeToBool (maybeBoxedPrimType inst_tau)
+-- && not opt_CompilingPrelude -- which allows anything
+ && not (maybeToBool (maybeBoxedPrimType inst_tau))
= failTc (nonBoxedPrimCCallErr clas inst_tau)
| otherwise
buildInstanceEnvs
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
addClassInstance
(class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+ (InstInfo clas inst_tyvars inst_ty _ _
dfun_id const_meth_ids _ _ _ src_loc _)
=
\begin{code}
+#include "HsVersions.h"
+
module TcKind (
Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
tcDefaultKind -- TcKind s -> NF_TcM s Kind
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Kind
import TcMonad hiding ( rnMtoTcM )
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
HsExpr, HsBinds, OutPat, Fake,
import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, LIE(..), plusLIE )
import TcEnv ( newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
import TcType ( TcType(..), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
TcResults(..),
TcResultBinds(..),
TcIfaceInfo(..),
- TcLocalTyConsAndClasses(..),
TcSpecialiseRequests(..),
TcDDumpDeriv(..)
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
TyDecl, SpecDataSig, ClassDecl, InstDecl,
import Bag ( listToBag )
import Class ( GenClass, classSelIds )
import ErrUtils ( Warning(..), Error(..) )
-import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv )
+import Id ( idType, isMethodSelId, isTopLevId, GenId, IdEnv(..), nullIdEnv )
import Maybes ( catMaybes )
import Name ( isExported, isLocallyDefined )
import Pretty
import RnUtils ( RnEnv(..) )
-import TyCon ( isDataTyCon, TyCon )
-import Type ( mkSynTy )
+import TyCon ( TyCon )
+import Type ( applyTyCon )
import TysWiredIn ( unitTy, mkPrimIoTy )
import TyVar ( TyVarEnv(..), nullTyVarEnv )
import Unify ( unifyTauTy )
type TcResults
= (TcResultBinds,
TcIfaceInfo,
- TcLocalTyConsAndClasses,
TcSpecialiseRequests,
TcDDumpDeriv)
type TcIfaceInfo -- things for the interface generator
= ([Id], [TyCon], [Class], Bag InstInfo)
-type TcLocalTyConsAndClasses -- things defined in this module
- = ([TyCon], [Class])
- -- not sure the classes are used at all (ToDo)
-
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
let
localids = getEnv_LocalIds final_env
- tycons = getEnv_TyCons final_env
- classes = getEnv_Classes final_env
+ tycons = getEnv_TyCons final_env
+ classes = getEnv_Classes final_env
- local_tycons = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ]
+ local_tycons = filter isLocallyDefined tycons
local_classes = filter isLocallyDefined classes
- exported_ids' = filter isExported (eltsUFM ve2)
- in
-
+ local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ]
+ -- the isTopLevId is doubtful...
+ in
-- FINISHED AT LAST
returnTc (
(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
- (exported_ids', tycons, classes, inst_info),
-
- (local_tycons, local_classes),
+ (local_vals, local_tycons, local_classes, inst_info),
tycon_specs,
ty_decls_bag = listToBag ty_decls
cls_decls_bag = listToBag cls_decls
inst_decls_bag = listToBag inst_decls
-
\end{code}
case (maybe_main, maybe_prim) of
(Just main, Nothing) -> tcAddErrCtxt mainCtxt $
- unifyTauTy (mkSynTy io_tc [unitTy])
+ unifyTauTy (applyTyCon io_tc [unitTy])
(idType main)
(Nothing, Just prim) -> tcAddErrCtxt primCtxt $
\begin{code}
+#include "HsVersions.h"
+
module TcMonad(
TcM(..), NF_TcM(..), TcDown, TcEnv,
SST_R, FSST_R,
MutableVar(..), _MutableArray
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
-import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
import Type ( Type(..), GenType )
import TyVar ( TyVar(..), GenTyVar )
Warning(..) )
import SST
-import RnMonad ( RnM(..), RnDown, initRn, setExtraRn )
+import RnMonad ( RnM(..), RnDown, initRn, setExtraRn,
+ returnRn, thenRn, getImplicitUpRn
+ )
import RnUtils ( RnEnv(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import FiniteMap ( FiniteMap, emptyFM )
+import FiniteMap ( FiniteMap, emptyFM, isEmptyFM )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import ErrUtils ( Error(..) )
import Maybes ( MaybeErr(..) )
writeMutVarSST u_var new_uniq_supply `thenSST_`
let
(rn_result, rn_errs, rn_warns)
- = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action
+ = initRn False{-*interface* mode! so we can see the builtins-}
+ (panic "rnMtoTcM:module")
+ rn_env uniq_s (
+ rn_action `thenRn` \ result ->
+
+ -- Though we are in "interface mode", we must
+ -- not have added anything to the ImplicitEnv!
+ getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
+ if (isEmptyFM v_env && isEmptyFM tc_env)
+ then returnRn result
+ else panic "rnMtoTcM: non-empty ImplicitEnv!"
+ )
in
returnSST (rn_result, rn_errs)
where
module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( PolyType(..), MonoType(..), Fake )
import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
import TyVar ( GenTyVar, TyVar(..), mkTyVar )
import Type ( mkDictTy )
import Class ( cCallishClassKeys )
-import TyCon ( TyCon, Arity(..) )
+import TyCon ( TyCon )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
module TcPat ( tcPat ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Match, HsBinds, Qual, PolyType,
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
-import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
+import TcType ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[TcSimplify]{TcSimplify}
bindInstsOfLocalFuns
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
Match, HsBinds, Qual, PolyType, ArithSeqInfo,
import TcMonad hiding ( rnMtoTcM )
import Inst ( lookupInst, lookupSimpleInst,
- tyVarsOfInst, isTyVarDict, isDict, matchesInst,
- instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
- Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
- InstOrigin(..), OverloadedLit )
+ tyVarsOfInst, isTyVarDict, isDict,
+ matchesInst, instToId, instBindingRequired,
+ instCanBeGeneralised, newDictsAtLoc,
+ pprInst,
+ Inst(..), LIE(..), zonkLIE, emptyLIE,
+ plusLIE, unitLIE, consLIE, InstOrigin(..),
+ OverloadedLit )
import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
import Unify ( unifyTauTy )
%************************************************************************
%* *
\subsection[elimSCs]{@elimSCs@}
-%* 2 *
+%* *
%************************************************************************
\begin{code}
where
rest' = elimSCsSimple rest
(c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 &&
- maybeToBool (c2 `isSuperClassOf` c1)
+ (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
+-- We deal with duplicates here ^^^^^^^^
+-- It's a simple place to do it, although it's done in elimTyCons in the
+-- full-blown version of the simpifier.
\end{code}
%************************************************************************
\end{verbatim}
Since we're not using the result of @foo@, the result if (presumably)
@void@.
-WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
-SLPJ comment: since
\begin{code}
disambigOne :: [SimpleDictInfo s] -> TcM s ()
\begin{code}
ambigErr insts sty
- = ppHang (ppStr "Ambiguous overloading")
- 4 (ppAboves (map (ppr sty) insts))
+ = ppAboves (map (pprInst sty "Ambiguous overloading") insts)
\end{code}
@reduceErr@ complains if we can't express required dictionaries in
\begin{code}
reduceErr insts sty
- = ppHang (ppStr "Type signature lacks context required by inferred type")
- 4 (ppHang (ppStr "Context reqd: ")
- 4 (ppAboves (map (ppr sty) (bagToList insts)))
- )
+ = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature")
+ (bagToList insts))
\end{code}
\begin{code}
= ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
4 (ppAboves [
ppHang (ppStr "Conflicting:")
- 4 (ppInterleave ppSemi (map (ppr sty) dicts)),
+ 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)),
ppHang (ppStr "Defaulting types :")
4 (ppr sty defaulting_tys),
ppStr "([Int, Double] is the default list of defaulting types.)" ])
tcTyAndClassDecls1
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
ClassDecl(..), MonoType(..), PolyType(..),
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon )
+import TyCon ( TyCon )
import Unique ( Unique )
-import Util ( panic, pprTrace )
+import Util ( panic{-, pprTrace-} )
\end{code}
mkDataBinds
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
checkTc (null eval_theta')
(missingEvalErr con_id eval_theta') `thenTc_`
-
-- Build the data constructor
let
con_rhs = mkHsTyLam tc_tyvars $
\begin{code}
+#include "HsVersions.h"
+
module TcType (
TcTyVar(..),
tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
- tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstTyVars,
tcInstSigTyVars,
- tcInstType, tcInstTheta, tcInstId,
+ tcInstType, tcInstSigType, tcInstTcType,
+ tcInstTheta, tcInstId,
zonkTcTyVars,
zonkTcType,
zonkTcTypeToType,
+ zonkTcTyVar,
zonkTcTyVarToTyVar
) where
-- friends:
import Type ( Type(..), ThetaType(..), GenType(..),
tyVarsOfTypes, getTyVar_maybe,
- splitForAllTy, splitRhoTy
+ splitForAllTy, splitRhoTy,
+ mkForAllTys, instantiateTy
)
import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..),
- TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, mkTyVarEnv,
+ TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv,
+ nullTyVarEnv, mkTyVarEnv,
tyVarSetToList
)
import TysWiredIn ( voidTy )
-import Ubiq
+IMP_Ubiq()
import Unique ( Unique )
import UniqFM ( UniqFM )
import Maybes ( assocMaybe )
-import Util ( zipEqual, nOfThem, panic, pprPanic )
+import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} )
import Outputable ( Outputable(..) ) -- Debugging messages
import PprType ( GenTyVar, GenType )
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
-
-- For signature type variables, mark them as "DontBind"
tcInstTyVars, tcInstSigTyVars
:: [GenTyVar flexi]
-> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)])
+
tcInstTyVars tyvars = inst_tyvars UnBound tyvars
tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars
-
inst_tyvars initial_cts tyvars
= mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars ->
let
returnNF_Tc (TyVar uniq kind name box)
\end{code}
-@tcInstType@ and @tcInstTcType@ both create a fresh instance of a
+@tcInstType@ and @tcInstSigType@ both create a fresh instance of a
type, returning a @TcType@. All inner for-alls are instantiated with
fresh TcTyVars.
-There are two versions, one for instantiating a @Type@, and one for a @TcType@.
-The former must instantiate everything; all tyvars must be bound either
-by a forall or by an environment passed in. The latter can do some sharing,
-and is happy with free tyvars (which is vital when instantiating the type
-of local functions). In the future @tcInstType@ may try to be clever about not
-instantiating constant sub-parts.
+The difference is that tcInstType instantiates all forall'd type
+variables (and their bindees) with UnBound type variables, whereas
+tcInstSigType instantiates them with DontBind types variables.
+@tcInstSigType@ also doesn't take an environment.
+
+On the other hand, @tcInstTcType@ instantiates a TcType. It uses
+instantiateTy which could take advantage of sharing some day.
\begin{code}
+tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
+tcInstTcType ty
+ = case tyvars of
+ [] -> returnNF_Tc ([], ty) -- Nothing to do
+ other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ returnNF_Tc (tyvars', instantiateTy tenv rho)
+ where
+ (tyvars, rho) = splitForAllTy ty
+
tcInstType :: [(GenTyVar flexi,TcType s)]
-> GenType (GenTyVar flexi) UVar
-> NF_TcM s (TcType s)
tcInstType tenv ty_to_inst
= tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst
where
+ bind_fn = inst_tyvar UnBound
+ occ_fn env tyvar = case lookupTyVarEnv env tyvar of
+ Just ty -> returnNF_Tc ty
+ Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst,
+ ppr PprDebug tyvar])
+
+tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s)
+tcInstSigType ty_to_inst
+ = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst
+ where
bind_fn = inst_tyvar DontBind
occ_fn env tyvar = case lookupTyVarEnv env tyvar of
Just ty -> returnNF_Tc ty
ppr PprDebug tyvar])
zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
-zonkTcTyVarToTyVar tyvar
- = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
- returnNF_Tc (tcTyVarToTyVar tyvar')
+zonkTcTyVarToTyVar tv
+ = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
+ case tv_ty of -- Should be a tyvar!
+
+ TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv')
+
+ _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+ returnNF_Tc (tcTyVarToTyVar tv)
+
zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
zonkTcTypeToType env ty
returnNF_Tc (SynTy tc tys' ty')
zonkTcType (ForAllTy tv ty)
- = zonkTcTyVar tv `thenNF_Tc` \ (TyVarTy tv') -> -- Should be a tyvar!
+ = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
zonkTcType ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tv' ty')
+ case tv_ty of -- Should be a tyvar!
+ TyVarTy tv' ->
+ returnNF_Tc (ForAllTy tv' ty')
+ _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $
+
+ returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')
zonkTcType (ForAllUsageTy uv uvs ty)
= panic "zonk:ForAllUsageTy"
module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where
-import Ubiq
+IMP_Ubiq()
-- friends:
import TcMonad hiding ( rnMtoTcM )
case (maybe_ty1, maybe_ty2) of
(_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
- (DontBind,DontBind)
- -> failTc (unifyDontBindErr tv1 ps_ty2)
-
(UnBound, _) | kind2 `hasMoreBoxityInfo` kind1
-> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
(_, UnBound) | kind1 `hasMoreBoxityInfo` kind2
-> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+-- TEMPORARY FIX
+-- (DontBind,DontBind)
+-- -> failTc (unifyDontBindErr tv1 ps_ty2)
+
+-- TEMPORARILY allow two type-sig variables to be bound together.
+-- See notes in tcCheckSigVars
+ (DontBind,DontBind) | kind2 `hasMoreBoxityInfo` kind1
+ -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
+
+ | kind1 `hasMoreBoxityInfo` kind2
+ -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
+
other -> failTc (unifyKindErr tv1 ps_ty2)
-- Second one isn't a type variable
isSuperClassOf,
classOpTagByString,
- derivableClassKeys, cCallishClassKeys,
+ derivableClassKeys, needsDataDeclCtxtClassKeys,
+ cCallishClassKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass,
GenClassOp(..), ClassOp(..),
CHK_Ubiq() -- debugging consistency check
-import TyLoop
+IMPORT_DELOOPER(TyLoop)
import TyCon ( TyCon )
import TyVar ( TyVar(..), GenTyVar )
key `is_elem` numericClassKeys
isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
+isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
numericClassKeys
- = [ numClassKey,
- realClassKey,
- integralClassKey,
- fractionalClassKey,
- floatingClassKey,
- realFracClassKey,
- realFloatClassKey ]
+ = [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
derivableClassKeys
- = [ eqClassKey,
- showClassKey,
- ordClassKey,
- boundedClassKey,
- enumClassKey,
- ixClassKey,
- readClassKey ]
+ = [ eqClassKey
+ , ordClassKey
+ , enumClassKey
+ , evalClassKey
+ , boundedClassKey
+ , showClassKey
+ , readClassKey
+ , ixClassKey
+ ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+ = [ readClassKey
+ ]
cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
-- _ccall_ foo ... 93{-numeric literal-} ...
--
-- ... it can do The Right Thing on the 93.
+
+noDictClassKeys -- These classes are used only for type annotations;
+ -- they are not implemented by dictionaries, ever.
+ = cCallishClassKeys
+ -- I used to think that class Eval belonged in here, but
+ -- we really want functions with type (Eval a => ...) and that
+ -- means that we really want to pass a placeholder for an Eval
+ -- dictionary. The unit tuple is what we'll get if we leave things
+ -- alone, and that'll do for now. Could arrange to drop that parameter
+ -- in the end.
\end{code}
%************************************************************************
hasMoreBoxityInfo,
resultKind, argKind,
- isUnboxedKind, isTypeKind
+ isUnboxedKind, isTypeKind,
+ notArrowKind
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( panic, assertPanic )
--import Outputable ( Outputable(..) )
kind1 `hasMoreBoxityInfo` kind2 = False
--- Not exported
notArrowKind (ArrowKind _ _) = False
notArrowKind other_kind = True
GenClass,
GenClassOp, pprGenClassOp,
- addTyVar, nmbrTyVar,
+ addTyVar{-ToDo:don't export-}, nmbrTyVar,
addUVar, nmbrUsage,
nmbrType, nmbrTyCon, nmbrClass
) where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
pprTyCon :: PprStyle -> TyCon -> Pretty
-pprTyCon sty FunTyCon = ppStr "(->)"
-pprTyCon sty (TupleTyCon _ name _) = ppr sty name
-pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
+pprTyCon sty FunTyCon = ppStr "(->)"
+pprTyCon sty (TupleTyCon _ name _) = ppr sty name
+pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
= ppr sty name
addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
case (lookupUFM_Directly tvenv u) of
- Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
+ Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
+ -- (It gets triggered when we do a datatype: first we
+ -- "addTyVar" the tyvars for the datatype as a whole;
+ -- we will subsequently "addId" the data cons, including
+ -- the type for each of them -- each of which includes
+ -- _forall_ ...tvs..., which we will addTyVar.
+ -- Harmless, if that's all that happens....
(nenv, xx)
Nothing ->
let
nmbrTyCon : only called from ``top-level'', if you know what I mean.
\begin{code}
-nmbrTyCon tc@FunTyCon = returnNmbr tc
-nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
-nmbrTyCon tc@(PrimTyCon _ _ _) = returnNmbr tc
+nmbrTyCon tc@FunTyCon = returnNmbr tc
+nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
+nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc
nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
= --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
tyConDataCons,
tyConFamilySize,
tyConDerivings,
- tyConArity, synTyConArity,
+ tyConTheta,
+ tyConPrimRep,
+ synTyConArity,
getSynTyConDefn,
maybeTyConSingleCon,
CHK_Ubiq() -- debugging consistency check
-import TyLoop ( Type(..), GenType,
+IMPORT_DELOOPER(TyLoop) ( Type(..), GenType,
Class(..), GenClass,
Id(..), GenId,
- mkTupleCon, dataConSig,
+ mkTupleCon, isNullaryDataCon,
specMaybeTysSuffix
)
)
import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
import Pretty ( Pretty(..), PrettyRep )
+import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Util ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) )
import {-hide me-}
Unique -- Always unboxed; hence never represented by a closure
Name -- Often represented by a bit-pattern for the thing
Kind -- itself (eg Int#), but sometimes by a pointer to
+ PrimRep
| SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
TyCon
isFunTyCon FunTyCon = True
isFunTyCon _ = False
-isPrimTyCon (PrimTyCon _ _ _) = True
+isPrimTyCon (PrimTyCon _ _ _ _) = True
isPrimTyCon _ = False
-- At present there are no unboxed non-primitive types, so
tyConKind :: TyCon -> Kind
tyConKind FunTyCon = kind2
tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
-tyConKind (PrimTyCon _ _ kind) = kind
+tyConKind (PrimTyCon _ _ kind _) = kind
tyConKind (SynTyCon _ _ k _ _ _) = k
tyConKind (TupleTyCon _ _ n)
tyConUnique FunTyCon = funTyConKey
tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq
tyConUnique (TupleTyCon uniq _ _) = uniq
-tyConUnique (PrimTyCon uniq _ _) = uniq
+tyConUnique (PrimTyCon uniq _ _ _) = uniq
tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq
tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon"
-tyConArity :: TyCon -> Arity
-tyConArity FunTyCon = 2
-tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs
-tyConArity (TupleTyCon _ _ arity) = arity
-tyConArity (PrimTyCon _ _ _) = 0 -- ??
-tyConArity (SpecTyCon _ _) = 0
-tyConArity (SynTyCon _ _ _ arity _ _) = arity
-
synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon
synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity
synTyConArity _ = Nothing
tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs
tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars
tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs
-tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon"
+#ifdef DEBUG
+tyConTyVars (PrimTyCon _ _ _ _) = panic "tyConTyVars:PrimTyCon"
tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon"
+#endif
\end{code}
\begin{code}
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
#endif
+
+tyConPrimRep :: TyCon -> PrimRep
+tyConPrimRep (PrimTyCon _ _ _ rep) = rep
+tyConPrimRep _ = PtrRep
\end{code}
\begin{code}
\end{code}
\begin{code}
+tyConTheta :: TyCon -> [(Class,Type)]
+tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta
+tyConTheta (TupleTyCon _ _ _) = []
+-- should ask about anything else
+\end{code}
+
+\begin{code}
getSynTyConDefn :: TyCon -> ([TyVar], Type)
getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty)
\end{code}
maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity)
maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing
-maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing
+maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing
maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon"
-- requires DataCons of TyCon
isEnumerationTyCon (TupleTyCon _ _ arity)
= arity == 0
isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _)
- = not (null data_cons) && all is_nullary data_cons
- where
- is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) ->
- null arg_tys }
+ = not (null data_cons) && all isNullaryDataCon data_cons
\end{code}
@derivedFor@ reports if we have an {\em obviously}-derived instance
\begin{code}
instance Ord3 TyCon where
- cmp FunTyCon FunTyCon = EQ_
- cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b
- cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b
- cmp (TupleTyCon _ _ a) (TupleTyCon _ _ b) = a `cmp` b
- cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b
- cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2)
- = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx }
-
- -- now we *know* the tags are different, so...
- cmp other_1 other_2
- | tag1 _LT_ tag2 = LT_
- | otherwise = GT_
- where
- tag1 = tag_TyCon other_1
- tag2 = tag_TyCon other_2
-
- tag_TyCon FunTyCon = ILIT(1)
- tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2)
- tag_TyCon (TupleTyCon _ _ _) = ILIT(3)
- tag_TyCon (PrimTyCon _ _ _) = ILIT(4)
- tag_TyCon (SpecTyCon _ _) = ILIT(5)
- tag_TyCon (SynTyCon _ _ _ _ _ _) = ILIT(6)
+ cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2
instance Eq TyCon where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
instance Uniquable TyCon where
uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
uniqueOf (TupleTyCon u _ _) = u
- uniqueOf (PrimTyCon u _ _) = u
+ uniqueOf (PrimTyCon u _ _ _) = u
uniqueOf (SynTyCon u _ _ _ _ _) = u
uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon"
uniqueOf tc = uniqueOf (getName tc)
\begin{code}
instance NamedThing TyCon where
getName (DataTyCon _ n _ _ _ _ _ _) = n
- getName (PrimTyCon _ n _) = n
+ getName (PrimTyCon _ n _ _) = n
getName (SpecTyCon tc _) = getName tc
getName (SynTyCon _ n _ _ _ _) = n
getName FunTyCon = mkFunTyConName
import FieldLabel ( FieldLabel )
import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
- dataConSig, dataConArgTys )
+ isNullaryDataCon, dataConArgTys )
import PprType ( specMaybeTysSuffix )
import Name ( Name )
import TyCon ( TyCon )
import Type ( GenType, Type )
import Usage ( GenUsage )
import Class ( Class, GenClass )
+import TysWiredIn ( voidTy )
data GenId ty
data GenType tyvar uvar
-- Needed in TyCon
mkTupleCon :: Int -> Id
-dataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon)
+isNullaryDataCon :: Id -> Bool
specMaybeTysSuffix :: [Maybe Type] -> _PackedString
instance Eq (GenClass a b)
-- Needed in Type
dataConArgTys :: Id -> [Type] -> [Type]
+voidTy :: Type
-- Needed in TysWiredIn
data StrictnessMark = MarkedStrict | NotMarkedStrict
tyVarKind, -- TyVar -> Kind
cloneTyVar,
+ openAlphaTyVar,
alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,
-- We also export "environments" keyed off of
) where
CHK_Ubiq() -- debugging consistency check
-import IdLoop -- for paranoia checking
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-- friends
import Usage ( GenUsage, Usage(..), usageOmega )
-import Kind ( Kind, mkBoxedTypeKind )
+import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-- others
import UniqSet -- nearly all of it
Fixed collection of type variables
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+ -- openAlphaTyVar is prepared to be instantiated
+ -- to a boxed or unboxed type variable. It's used for the
+ -- result type for "error", so that we can have (error Int# "Help")
+openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing usageOmega
+
alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega
- | u <- map mkAlphaTyVarUnique [1..] ]
+ | u <- map mkAlphaTyVarUnique [2..] ]
(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars
+
\end{code}
getFunTy_maybe, getFunTyExpandingDicts_maybe,
mkTyConTy, getTyCon_maybe, applyTyCon,
mkSynTy,
- mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
+ mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy,
mkForAllUsageTy, getForAllUsageTy,
applyTy,
#ifdef DEBUG
tyVarsOfType, tyVarsOfTypes, typeKind
) where
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
-import PrelLoop -- for paranoia checking
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
+IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
-import Kind ( mkBoxedTypeKind, resultKind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
+import Kind ( mkBoxedTypeKind, resultKind, notArrowKind )
+import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
emptyTyVarSet, unionTyVarSets, minusTyVarSet,
eqUsage )
-- others
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
-import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
+import Unique -- quite a few *Keys
+import Util ( thenCmp, zipEqual, assoc,
+ panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
Ord3(..){-instances-}
)
-- ToDo:rm all these
import {-mumble-}
PprStyle
import {-mumble-}
- PprType (pprType )
+ PprType --(pprType )
import {-mumble-}
UniqFM (ufmToList )
-import {-mumble-}
- Unique (pprUnique )
+import {-mumble-}
+ Outputable
\end{code}
Data types
expandTy (DictTy clas ty u)
= case all_arg_tys of
+ [] -> voidTy -- Empty dictionary represented by Void
+
[arg_ty] -> expandTy arg_ty -- just the <whatever> itself
-- The extra expandTy is to make sure that
applyTyCon :: TyCon -> [GenType t u] -> GenType t u
applyTyCon tycon tys
- = ASSERT (not (isSynTyCon tycon))
+ = --ASSERT (not (isSynTyCon tycon))
+ (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $
foldl AppTy (TyConTy tycon usageOmega) tys
getTyCon_maybe :: GenType t u -> Maybe TyCon
getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
getForAllTy_maybe _ = Nothing
+getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
+getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t
+getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
+getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty)
+getForAllTyExpandingDicts_maybe _ = Nothing
+
splitForAllTy :: GenType t u-> ([t], GenType t u)
splitForAllTy t = go t []
where
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
maybeAppDataTyCon
- :: GenType tyvar uvar
+ :: GenType (GenTyVar any) uvar
-> Maybe (TyCon, -- the type constructor
- [GenType tyvar uvar], -- types to which it is applied
+ [GenType (GenTyVar any) uvar], -- types to which it is applied
[Id]) -- its family of data-constructors
maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
:: Type -> Maybe (TyCon, [Type], [Id])
maybe_app_data_tycon expand ty
- = case (getTyCon_maybe app_ty) of
- Just tycon | isDataTyCon tycon &&
- tyConArity tycon == length arg_tys
+ = let
+ expanded_ty = expand ty
+ (app_ty, arg_tys) = splitAppTy expanded_ty
+ in
+ case (getTyCon_maybe app_ty) of
+ Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
+ isDataTyCon tycon &&
+ notArrowKind (typeKind expanded_ty)
-- Must be saturated for ty to be a data type
-> Just (tycon, arg_tys, tyConDataCons tycon)
other -> Nothing
- where
- (app_ty, arg_tys) = splitAppTy (expand ty)
getAppDataTyCon, getAppSpecDataTyCon
- :: GenType tyvar uvar
+ :: GenType (GenTyVar any) uvar
-> (TyCon, -- the type constructor
- [GenType tyvar uvar], -- types to which it is applied
+ [GenType (GenTyVar any) uvar], -- types to which it is applied
[Id]) -- its family of data-constructors
getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
:: Type -> (TyCon, [Type], [Id])
getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty
-getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty
+getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
+ get_app_data_tycon maybeAppDataTyConExpandingDicts ty
-- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
getAppSpecDataTyCon = getAppDataTyCon
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
typeKind :: GenType (GenTyVar any) u -> Kind
+
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConTy tycon usage) = tyConKind tycon
typeKind (SynTy _ _ ty) = typeKind ty
typePrimRep :: GenType tyvar uvar -> PrimRep
typePrimRep (SynTy _ _ ty) = typePrimRep ty
-typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
typePrimRep (AppTy ty _) = typePrimRep ty
+typePrimRep (TyConTy tc _) = if not (isPrimTyCon tc) then
+ PtrRep
+ else
+ case (assocMaybe tc_primrep_list (uniqueOf tc)) of
+ Just xx -> xx
+ Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
+
typePrimRep _ = PtrRep -- the "default"
+
+tc_primrep_list
+ = [(addrPrimTyConKey, AddrRep)
+ ,(arrayPrimTyConKey, ArrayRep)
+ ,(byteArrayPrimTyConKey, ByteArrayRep)
+ ,(charPrimTyConKey, CharRep)
+ ,(doublePrimTyConKey, DoubleRep)
+ ,(floatPrimTyConKey, FloatRep)
+ ,(foreignObjPrimTyConKey, ForeignObjRep)
+ ,(intPrimTyConKey, IntRep)
+ ,(mutableArrayPrimTyConKey, ArrayRep)
+ ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
+ ,(stablePtrPrimTyConKey, StablePtrRep)
+ ,(statePrimTyConKey, VoidRep)
+ ,(synchVarPrimTyConKey, PtrRep)
+ ,(voidTyConKey, VoidRep)
+ ,(wordPrimTyConKey, WordRep)
+ ]
\end{code}
%************************************************************************
eqUVar, eqUsage
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside )
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
+#include "HsVersions.h"
+
module Bag (
Bag, -- abstract type
) where
#ifdef COMPILING_GHC
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
import Outputable ( interpp'SP )
import Pretty
#if ! defined(COMPILING_GHC)
) where
#else
- , cAppendFile
+ , cPutStr
) where
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(IO)
-import PreludeGlaST
#endif
\end{code}
cInt :: Int -> CSeq
#if defined(COMPILING_GHC)
-cAppendFile :: _FILE -> CSeq -> IO ()
+cPutStr :: Handle -> CSeq -> IO ()
#endif
\end{code}
| CCh Char
| CInt Int -- equiv to "CStr (show the_int)"
#if defined(COMPILING_GHC)
- | CPStr _PackedString
+ | CPStr FAST_STRING
#endif
\end{code}
cShows seq rest = cShow seq ++ rest
cLength seq = length (cShow seq) -- *not* the best way to do this!
#endif
-
-#if defined(COMPILING_GHC)
-cAppendFile file_star seq
- = flattenIO file_star seq `seqPrimIO` return ()
-#endif
\end{code}
This code is {\em hammered}. We are not above doing sleazy
flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs
flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs
#if defined(COMPILING_GHC)
-flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs
+flatten n _FALSE_ (CPStr s) seqs = _UNPK_ s ++ flattenS _FALSE_ seqs
#endif
flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs)
flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs)
flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs)
#if defined(COMPILING_GHC)
-flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs)
+flatten n _TRUE_ (CPStr s) seqs = mkIndent n ( _UNPK_ s ++ flattenS _FALSE_ seqs)
#endif
\end{code}
This code is massively {\em hammered}.
It {\em ignores} indentation.
+(NB: 1.3 compiler: efficiency hacks removed for now!)
+
\begin{code}
#if defined(COMPILING_GHC)
-flattenIO :: _FILE -- file we are writing to
- -> CSeq -- Seq to print
- -> PrimIO ()
-
-flattenIO file sq
- | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-)
- | otherwise
- = flat sq
+cPutStr handle sq = flat sq
where
- flat CNil = returnPrimIO ()
+ flat CNil = return ()
flat (CIndent n2 seq) = flat seq
- flat (CAppend s1 s2) = flat s1 `seqPrimIO` flat s2
- flat CNewline = _ccall_ stg_putc '\n' file
- flat (CCh c) = _ccall_ stg_putc c file
- flat (CInt i) = _ccall_ fprintf file percent_d i
- flat (CStr s) = put_str s
- flat (CPStr s) = put_pstr s
-
- -----
- put_str, put_str2 :: String -> PrimIO ()
-
- put_str str
- = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO`
- put_str2 str
-
- put_str2 [] = returnPrimIO ()
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- _ccall_ stg_putc c4 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : c2@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_str2 (c1@(C# _) : cs)
- = _ccall_ stg_putc c1 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
-
- put_pstr ps = _putPS file ps
-
-percent_d = _psToByteArray SLIT("%d")
+ flat (CAppend s1 s2) = flat s1 >> flat s2
+ flat CNewline = hPutChar handle '\n'
+ flat (CCh c) = hPutChar handle c
+ flat (CInt i) = hPutStr handle (show i)
+ flat (CStr s) = hPutStr handle s
+ flat (CPStr s) = hPutStr handle (_UNPK_ s)
#endif {- COMPILING_GHC -}
\end{code}
, FiniteSet(..), emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet
#endif
-
- -- To make it self-sufficient
-#if __HASKELL1__ < 3
- , Maybe
-#endif
) where
import Maybes
#ifdef COMPILING_GHC
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
# ifdef DEBUG
import Pretty
# endif
\tr{Uniques}, for dastardly efficiency reasons.
\begin{code}
-#if 0
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__
+#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3)
-{-# SPECIALIZE listToFM
- :: [(Int,elt)] -> FiniteMap Int elt,
- [(CLabel,elt)] -> FiniteMap CLabel elt,
- [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt,
- [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM
- :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE addListToFM
- :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
+ :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
-{-NOT EXPORTED!! # SPECIALIZE addToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE addListToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
+ :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt,
+ (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
-{-NOT EXPORTED!!! # SPECIALIZE delFromFM
- :: FiniteMap Int elt -> Int -> FiniteMap Int elt,
- FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE delListFromFM
- :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
+{-# SPECIALIZE addToFM
+ :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt,
+ FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt,
+ FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt,
+ FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt
+ IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
-{-# SPECIALIZE elemFM
- :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool
+{-# SPECIALIZE addToFM_C
+ :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt,
+ (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt
+ IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
#-}
-{-not EXPORTED!!! # SPECIALIZE filterFM
- :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt,
- (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE bagToFM
+ :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt
#-}
-{-NOT EXPORTED!!! # SPECIALIZE intersectFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE delListFromFM
+ :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt,
+ FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt
+ IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
#-}
-{-not EXPORTED !!!# SPECIALIZE intersectFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
+{-# SPECIALIZE listToFM
+ :: [([Char],elt)] -> FiniteMap [Char] elt,
+ [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt,
+ [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
+ IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE lookupFM
- :: FiniteMap Int elt -> Int -> Maybe elt,
- FiniteMap CLabel elt -> CLabel -> Maybe elt,
+ :: FiniteMap CLabel elt -> CLabel -> Maybe elt,
+ FiniteMap [Char] elt -> [Char] -> Maybe elt,
FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt,
- FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
+ FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt,
+ FiniteMap RdrName elt -> RdrName -> Maybe elt,
+ FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt
IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
#-}
{-# SPECIALIZE lookupWithDefaultFM
- :: FiniteMap Int elt -> elt -> Int -> elt,
- FiniteMap CLabel elt -> elt -> CLabel -> elt
+ :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt
IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
#-}
-{-# SPECIALIZE minusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
{-# SPECIALIZE plusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
+ :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt,
+ FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
{-# SPECIALIZE plusFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
+ :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt
IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
#-}
#endif {- compiling for GHC -}
-#endif {- 0 -}
\end{code}
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
+#include "HsVersions.h"
+
module ListSetOps (
unionLists,
intersectLists,
) where
#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Util ( isIn, isn'tIn )
#endif
failMaB,
failMaybe,
seqMaybe,
- mapMaybe,
returnMaB,
returnMaybe,
- thenMaB,
- thenMaybe
+ thenMaB
#if ! defined(COMPILING_GHC)
, findJust
failMaybe :: Maybe a
failMaybe = Nothing
-
-mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
-mapMaybe f [] = returnMaybe []
-mapMaybe f (x:xs) = f x `thenMaybe` \ x' ->
- mapMaybe f xs `thenMaybe` \ xs' ->
- returnMaybe (x':xs')
\end{code}
Lookup functions
ifPprInterface
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import PprStyle ( PprStyle(..) )
import Pretty
#endif
module Pretty (
- Pretty(..),
+ SYN_IE(Pretty),
#if defined(COMPILING_GHC)
prettyToUn,
ppShow, speakNth,
#if defined(COMPILING_GHC)
- ppAppendFile,
+ ppPutStr,
#endif
-- abstract type, to complete the interface...
- PrettyRep(..), CSeq, Delay
-#if defined(COMPILING_GHC)
- , Unpretty(..)
-#endif
+ PrettyRep(..), Delay
) where
#if defined(COMPILING_GHC)
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(Ratio)
+IMPORT_1_3(IO)
-import Unpretty ( Unpretty(..) )
+import Unpretty ( SYN_IE(Unpretty) )
#endif
import CharSeq
ppShow :: Int -> Pretty -> [Char]
#if defined(COMPILING_GHC)
-ppAppendFile :: _FILE -> Int -> Pretty -> IO ()
+ppPutStr :: Handle -> Int -> Pretty -> IO ()
#endif
\end{code}
MkPrettyRep seq ll emp sl -> cShow seq
#if defined(COMPILING_GHC)
-ppAppendFile f width p
+ppPutStr f width p
= case (p width False) of
- MkPrettyRep seq ll emp sl -> cAppendFile f seq
+ MkPrettyRep seq ll emp sl -> cPutStr f seq
#endif
ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
import Kind ( Kind )
import Literal ( Literal )
+import MachRegs ( Reg )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) )
data MatchEnv a b
data Name
data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
+data Reg
data OutPat a b c
data PprStyle
data PragmaInfo
type Type = GenType (GenTyVar (GenUsage Unique)) Unique
type TyVar = GenTyVar (GenUsage Unique)
type Usage = GenUsage Unique
+
+-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
+instance Ord Reg
+instance Ord RdrName
+instance Ord CLabel
+instance Ord TyCon
+instance Eq Reg
+instance Eq RdrName
+instance Eq CLabel
+instance Eq TyCon
\end{code}
IF_NOT_GHC(addToUFM_C COMMA)
addListToUFM_C,
delFromUFM,
+ delFromUFM_Directly,
delListFromUFM,
plusUFM,
plusUFM_C,
) where
#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM fm key = delete fm (u2i (uniqueOf key))
+delFromUFM_Directly fm u = delete fm (u2i u)
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
isEmptyUniqSet
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import Maybes ( maybeToBool, Maybe )
import UniqFM
#include "HsVersions.h"
module Unpretty (
- Unpretty(..),
+ SYN_IE(Unpretty),
uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger,
uppSP, upp'SP, uppLbrack, uppRbrack, uppLparen, uppRparen,
uppCat, uppBeside, uppBesides, uppAbove, uppAboves,
uppNest, uppSep, uppInterleave, uppIntersperse,
uppShow,
- uppAppendFile,
+ uppPutStr,
-- abstract type, to complete the interface...
CSeq
) where
CHK_Ubiq() -- debugging consistency check
+IMPORT_1_3(IO)
import CharSeq
\end{code}
uppShow :: Int -> Unpretty -> [Char]
-uppAppendFile :: _FILE -> Int -> Unpretty -> IO ()
+uppPutStr :: Handle -> Int -> Unpretty -> IO ()
\end{code}
%************************************************
\begin{code}
uppShow _ p = cShow p
-uppAppendFile f _ p = cAppendFile f p
+uppPutStr f _ p = cPutStr f p
uppNil = cNil
uppStr s = cStr s
-> [a] -- The transitive closure
transitiveClosure succ eq xs
- = do [] xs
+ = go [] xs
where
- do done [] = done
- do done (x:xs) | x `is_in` done = do done xs
- | otherwise = do (x:done) (succ x ++ xs)
+ go done [] = done
+ go done (x:xs) | x `is_in` done = go done xs
+ | otherwise = go (x:done) (succ x ++ xs)
x `is_in` [] = False
x `is_in` (y:ys) | eq x y = True
projects / ghc-hetmet.git / commitdiff